swh:1:cnt:3319c582b9bb2d580d6832c1fb2cd08c8c2d72ee;origin=https://github.com/krisds/koopa;anchor=swh:1:rev:34ced67d50536b4dea31b540ad7a145c6b2144bd;path=/testsuite/cobol85/IF108A.CBL
Show source
*HEADER,COBOL,IF108A
000100 IDENTIFICATION DIVISION. IF1084.2
000200 PROGRAM-ID. IF1084.2
000300 IF108A. IF1084.2
000400 IF1084.2
000500*********************************************************** IF1084.2
000600* * IF1084.2
000700* This program forms part of the CCVS85 COBOL Test Suite. * IF1084.2
000800* It contains tests for the Intrinsic Function * IF1084.2
000900* DATE-OF-INTEGER. * IF1084.2
001000* * IF1084.2
001100*********************************************************** IF1084.2
001200 ENVIRONMENT DIVISION. IF1084.2
001300 CONFIGURATION SECTION. IF1084.2
001400 SOURCE-COMPUTER. IF1084.2
001500 XXXXX082. IF1084.2
001600 OBJECT-COMPUTER. IF1084.2
001700 XXXXX083. IF1084.2
001800 INPUT-OUTPUT SECTION. IF1084.2
001900 FILE-CONTROL. IF1084.2
002000 SELECT PRINT-FILE ASSIGN TO IF1084.2
002100 XXXXX055. IF1084.2
002200 DATA DIVISION. IF1084.2
002300 FILE SECTION. IF1084.2
002400 FD PRINT-FILE. IF1084.2
002500 01 PRINT-REC PICTURE X(120). IF1084.2
002600 01 DUMMY-RECORD PICTURE X(120). IF1084.2
002700 WORKING-STORAGE SECTION. IF1084.2
002800*********************************************************** IF1084.2
002900* Variables specific to the Intrinsic Function Test IF108A* IF1084.2
003000*********************************************************** IF1084.2
003100 01 A PIC S9(10) VALUE 400. IF1084.2
003200 01 C PIC S9(10) VALUE 300. IF1084.2
003300 01 D PIC S9(10) VALUE 1. IF1084.2
003400 01 ARG1 PIC S9(10) VALUE 1. IF1084.2
003500 01 ARR VALUE "40537". IF1084.2
003600 02 IND OCCURS 5 TIMES PIC 9. IF1084.2
003700 01 TEMP PIC S9(5)V9(5). IF1084.2
003800 01 WS-DATE PIC 9(8). IF1084.2
003900* IF1084.2
004000********************************************************** IF1084.2
004100* IF1084.2
004200 01 TEST-RESULTS. IF1084.2
004300 02 FILLER PIC X VALUE SPACE. IF1084.2
004400 02 FEATURE PIC X(20) VALUE SPACE. IF1084.2
004500 02 FILLER PIC X VALUE SPACE. IF1084.2
004600 02 P-OR-F PIC X(5) VALUE SPACE. IF1084.2
004700 02 FILLER PIC X VALUE SPACE. IF1084.2
004800 02 PAR-NAME. IF1084.2
004900 03 FILLER PIC X(19) VALUE SPACE. IF1084.2
005000 03 PARDOT-X PIC X VALUE SPACE. IF1084.2
005100 03 DOTVALUE PIC 99 VALUE ZERO. IF1084.2
005200 02 FILLER PIC X(8) VALUE SPACE. IF1084.2
005300 02 RE-MARK PIC X(61). IF1084.2
005400 01 TEST-COMPUTED. IF1084.2
005500 02 FILLER PIC X(30) VALUE SPACE. IF1084.2
005600 02 FILLER PIC X(17) VALUE IF1084.2
005700 " COMPUTED=". IF1084.2
005800 02 COMPUTED-X. IF1084.2
005900 03 COMPUTED-A PIC X(20) VALUE SPACE. IF1084.2
006000 03 COMPUTED-N REDEFINES COMPUTED-A IF1084.2
006100 PIC -9(9).9(9). IF1084.2
006200 03 COMPUTED-0V18 REDEFINES COMPUTED-A PIC -.9(18). IF1084.2
006300 03 COMPUTED-4V14 REDEFINES COMPUTED-A PIC -9(4).9(14). IF1084.2
006400 03 COMPUTED-14V4 REDEFINES COMPUTED-A PIC -9(14).9(4). IF1084.2
006500 03 CM-18V0 REDEFINES COMPUTED-A. IF1084.2
006600 04 COMPUTED-18V0 PIC -9(18). IF1084.2
006700 04 FILLER PIC X. IF1084.2
006800 03 FILLER PIC X(50) VALUE SPACE. IF1084.2
006900 01 TEST-CORRECT. IF1084.2
007000 02 FILLER PIC X(30) VALUE SPACE. IF1084.2
007100 02 FILLER PIC X(17) VALUE " CORRECT =". IF1084.2
007200 02 CORRECT-X. IF1084.2
007300 03 CORRECT-A PIC X(20) VALUE SPACE. IF1084.2
007400 03 CORRECT-N REDEFINES CORRECT-A PIC -9(9).9(9). IF1084.2
007500 03 CORRECT-0V18 REDEFINES CORRECT-A PIC -.9(18). IF1084.2
007600 03 CORRECT-4V14 REDEFINES CORRECT-A PIC -9(4).9(14). IF1084.2
007700 03 CORRECT-14V4 REDEFINES CORRECT-A PIC -9(14).9(4). IF1084.2
007800 03 CR-18V0 REDEFINES CORRECT-A. IF1084.2
007900 04 CORRECT-18V0 PIC -9(18). IF1084.2
008000 04 FILLER PIC X. IF1084.2
008100 03 FILLER PIC X(2) VALUE SPACE. IF1084.2
008200 03 COR-ANSI-REFERENCE PIC X(48) VALUE SPACE. IF1084.2
008300 01 CCVS-C-1. IF1084.2
008400 02 FILLER PIC IS X(99) VALUE IS " FEATURE PAIF1084.2
008500- "SS PARAGRAPH-NAME IF1084.2
008600- " REMARKS". IF1084.2
008700 02 FILLER PIC X(20) VALUE SPACE. IF1084.2
008800 01 CCVS-C-2. IF1084.2
008900 02 FILLER PIC X VALUE SPACE. IF1084.2
009000 02 FILLER PIC X(6) VALUE "TESTED". IF1084.2
009100 02 FILLER PIC X(15) VALUE SPACE. IF1084.2
009200 02 FILLER PIC X(4) VALUE "FAIL". IF1084.2
009300 02 FILLER PIC X(94) VALUE SPACE. IF1084.2
009400 01 REC-SKL-SUB PIC 9(2) VALUE ZERO. IF1084.2
009500 01 REC-CT PIC 99 VALUE ZERO. IF1084.2
009600 01 DELETE-COUNTER PIC 999 VALUE ZERO. IF1084.2
009700 01 ERROR-COUNTER PIC 999 VALUE ZERO. IF1084.2
009800 01 INSPECT-COUNTER PIC 999 VALUE ZERO. IF1084.2
009900 01 PASS-COUNTER PIC 999 VALUE ZERO. IF1084.2
010000 01 TOTAL-ERROR PIC 999 VALUE ZERO. IF1084.2
010100 01 ERROR-HOLD PIC 999 VALUE ZERO. IF1084.2
010200 01 DUMMY-HOLD PIC X(120) VALUE SPACE. IF1084.2
010300 01 RECORD-COUNT PIC 9(5) VALUE ZERO. IF1084.2
010400 01 ANSI-REFERENCE PIC X(48) VALUE SPACES. IF1084.2
010500 01 CCVS-H-1. IF1084.2
010600 02 FILLER PIC X(39) VALUE SPACES. IF1084.2
010700 02 FILLER PIC X(42) VALUE IF1084.2
010800 "OFFICIAL COBOL COMPILER VALIDATION SYSTEM". IF1084.2
010900 02 FILLER PIC X(39) VALUE SPACES. IF1084.2
011000 01 CCVS-H-2A. IF1084.2
011100 02 FILLER PIC X(40) VALUE SPACE. IF1084.2
011200 02 FILLER PIC X(7) VALUE "CCVS85 ". IF1084.2
011300 02 FILLER PIC XXXX VALUE IF1084.2
011400 "4.2 ". IF1084.2
011500 02 FILLER PIC X(28) VALUE IF1084.2
011600 " COPY - NOT FOR DISTRIBUTION". IF1084.2
011700 02 FILLER PIC X(41) VALUE SPACE. IF1084.2
011800 IF1084.2
011900 01 CCVS-H-2B. IF1084.2
012000 02 FILLER PIC X(15) VALUE IF1084.2
012100 "TEST RESULT OF ". IF1084.2
012200 02 TEST-ID PIC X(9). IF1084.2
012300 02 FILLER PIC X(4) VALUE IF1084.2
012400 " IN ". IF1084.2
012500 02 FILLER PIC X(12) VALUE IF1084.2
012600 " HIGH ". IF1084.2
012700 02 FILLER PIC X(22) VALUE IF1084.2
012800 " LEVEL VALIDATION FOR ". IF1084.2
012900 02 FILLER PIC X(58) VALUE IF1084.2
013000 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".IF1084.2
013100 01 CCVS-H-3. IF1084.2
013200 02 FILLER PIC X(34) VALUE IF1084.2
013300 " FOR OFFICIAL USE ONLY ". IF1084.2
013400 02 FILLER PIC X(58) VALUE IF1084.2
013500 "COBOL 85 VERSION 4.2, Apr 1993 SSVG ".IF1084.2
013600 02 FILLER PIC X(28) VALUE IF1084.2
013700 " COPYRIGHT 1985 ". IF1084.2
013800 01 CCVS-E-1. IF1084.2
013900 02 FILLER PIC X(52) VALUE SPACE. IF1084.2
014000 02 FILLER PIC X(14) VALUE IS "END OF TEST- ". IF1084.2
014100 02 ID-AGAIN PIC X(9). IF1084.2
014200 02 FILLER PIC X(45) VALUE SPACES. IF1084.2
014300 01 CCVS-E-2. IF1084.2
014400 02 FILLER PIC X(31) VALUE SPACE. IF1084.2
014500 02 FILLER PIC X(21) VALUE SPACE. IF1084.2
014600 02 CCVS-E-2-2. IF1084.2
014700 03 ERROR-TOTAL PIC XXX VALUE SPACE. IF1084.2
014800 03 FILLER PIC X VALUE SPACE. IF1084.2
014900 03 ENDER-DESC PIC X(44) VALUE IF1084.2
015000 "ERRORS ENCOUNTERED". IF1084.2
015100 01 CCVS-E-3. IF1084.2
015200 02 FILLER PIC X(22) VALUE IF1084.2
015300 " FOR OFFICIAL USE ONLY". IF1084.2
015400 02 FILLER PIC X(12) VALUE SPACE. IF1084.2
015500 02 FILLER PIC X(58) VALUE IF1084.2
015600 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".IF1084.2
015700 02 FILLER PIC X(13) VALUE SPACE. IF1084.2
015800 02 FILLER PIC X(15) VALUE IF1084.2
015900 " COPYRIGHT 1985". IF1084.2
016000 01 CCVS-E-4. IF1084.2
016100 02 CCVS-E-4-1 PIC XXX VALUE SPACE. IF1084.2
016200 02 FILLER PIC X(4) VALUE " OF ". IF1084.2
016300 02 CCVS-E-4-2 PIC XXX VALUE SPACE. IF1084.2
016400 02 FILLER PIC X(40) VALUE IF1084.2
016500 " TESTS WERE EXECUTED SUCCESSFULLY". IF1084.2
016600 01 XXINFO. IF1084.2
016700 02 FILLER PIC X(19) VALUE IF1084.2
016800 "*** INFORMATION ***". IF1084.2
016900 02 INFO-TEXT. IF1084.2
017000 04 FILLER PIC X(8) VALUE SPACE. IF1084.2
017100 04 XXCOMPUTED PIC X(20). IF1084.2
017200 04 FILLER PIC X(5) VALUE SPACE. IF1084.2
017300 04 XXCORRECT PIC X(20). IF1084.2
017400 02 INF-ANSI-REFERENCE PIC X(48). IF1084.2
017500 01 HYPHEN-LINE. IF1084.2
017600 02 FILLER PIC IS X VALUE IS SPACE. IF1084.2
017700 02 FILLER PIC IS X(65) VALUE IS "************************IF1084.2
017800- "*****************************************". IF1084.2
017900 02 FILLER PIC IS X(54) VALUE IS "************************IF1084.2
018000- "******************************". IF1084.2
018100 01 CCVS-PGM-ID PIC X(9) VALUE IF1084.2
018200 "IF108A". IF1084.2
018300 PROCEDURE DIVISION. IF1084.2
018400 CCVS1 SECTION. IF1084.2
018500 OPEN-FILES. IF1084.2
018600 OPEN OUTPUT PRINT-FILE. IF1084.2
018700 MOVE CCVS-PGM-ID TO TEST-ID. MOVE CCVS-PGM-ID TO ID-AGAIN. IF1084.2
018800 MOVE SPACE TO TEST-RESULTS. IF1084.2
018900 PERFORM HEAD-ROUTINE THRU COLUMN-NAMES-ROUTINE. IF1084.2
019000 GO TO CCVS1-EXIT. IF1084.2
019100 CLOSE-FILES. IF1084.2
019200 PERFORM END-ROUTINE THRU END-ROUTINE-13. CLOSE PRINT-FILE. IF1084.2
019300 TERMINATE-CCVS. IF1084.2
019400 STOP RUN. IF1084.2
019500 INSPT. MOVE "INSPT" TO P-OR-F. ADD 1 TO INSPECT-COUNTER. IF1084.2
019600 PASS. MOVE "PASS " TO P-OR-F. ADD 1 TO PASS-COUNTER. IF1084.2
019700 FAIL. MOVE "FAIL*" TO P-OR-F.
…(truncated)…
swh:1:cnt:fd982154388e0121ed98ad1cfcdabaccd484b627;origin=https://github.com/krisds/koopa;anchor=swh:1:rev:34ced67d50536b4dea31b540ad7a145c6b2144bd;path=/testsuite/cobol85/IF138A.CBL
Show source
*HEADER,COBOL,IF138A
000100 IDENTIFICATION DIVISION. IF1384.2
000200 PROGRAM-ID. IF1384.2
000300 IF138A. IF1384.2
000400 IF1384.2
000500*********************************************************** IF1384.2
000600* * IF1384.2
000700* This program forms part of the CCVS85 COBOL Test Suite. * IF1384.2
000800* It contains tests for the Intrinsic Function SUM . * IF1384.2
000900* * IF1384.2
001000*********************************************************** IF1384.2
001100 ENVIRONMENT DIVISION. IF1384.2
001200 CONFIGURATION SECTION. IF1384.2
001300 SOURCE-COMPUTER. IF1384.2
001400 XXXXX082. IF1384.2
001500 OBJECT-COMPUTER. IF1384.2
001600 XXXXX083. IF1384.2
001700 INPUT-OUTPUT SECTION. IF1384.2
001800 FILE-CONTROL. IF1384.2
001900 SELECT PRINT-FILE ASSIGN TO IF1384.2
002000 XXXXX055. IF1384.2
002100 DATA DIVISION. IF1384.2
002200 FILE SECTION. IF1384.2
002300 FD PRINT-FILE. IF1384.2
002400 01 PRINT-REC PICTURE X(120). IF1384.2
002500 01 DUMMY-RECORD PICTURE X(120). IF1384.2
002600 WORKING-STORAGE SECTION. IF1384.2
002700*********************************************************** IF1384.2
002800* Variables specific to the Intrinsic Function Test IF138A* IF1384.2
002900*********************************************************** IF1384.2
003000 01 A PIC S9(10) VALUE 5. IF1384.2
003100 01 B PIC S9(10) VALUE 7. IF1384.2
003200 01 C PIC S9(10) VALUE -4. IF1384.2
003300 01 D PIC S9(10) VALUE 10. IF1384.2
003400 01 E PIC S9(5)V9(5) VALUE 34.26. IF1384.2
003500 01 F PIC S9(5)V9(5) VALUE -8.32. IF1384.2
003600 01 G PIC S9(5)V9(5) VALUE 4.08. IF1384.2
003700 01 H PIC S9(5)V9(5) VALUE -5.3. IF1384.2
003800 01 M PIC S9(10) VALUE 320000. IF1384.2
003900 01 N PIC S9(10) VALUE 650000. IF1384.2
004000 01 O PIC S9(10) VALUE -430000. IF1384.2
004100 01 P PIC S9(10) VALUE 1. IF1384.2
004200 01 Q PIC S9(10) VALUE 3. IF1384.2
004300 01 R PIC S9(10) VALUE 5. IF1384.2
004400 01 ARG1 PIC S9(10) VALUE 1. IF1384.2
004500 01 ARR VALUE "40537". IF1384.2
004600 02 IND OCCURS 5 TIMES PIC 9. IF1384.2
004700 01 TEMP PIC S9(10)V9(5). IF1384.2
004800 01 WS-NUM PIC S9(6)V9(7). IF1384.2
004900 01 MIN-RANGE PIC S9(5)V9(7). IF1384.2
005000 01 MAX-RANGE PIC S9(5)V9(7). IF1384.2
005100* IF1384.2
005200********************************************************** IF1384.2
005300* IF1384.2
005400 01 TEST-RESULTS. IF1384.2
005500 02 FILLER PIC X VALUE SPACE. IF1384.2
005600 02 FEATURE PIC X(20) VALUE SPACE. IF1384.2
005700 02 FILLER PIC X VALUE SPACE. IF1384.2
005800 02 P-OR-F PIC X(5) VALUE SPACE. IF1384.2
005900 02 FILLER PIC X VALUE SPACE. IF1384.2
006000 02 PAR-NAME. IF1384.2
006100 03 FILLER PIC X(19) VALUE SPACE. IF1384.2
006200 03 PARDOT-X PIC X VALUE SPACE. IF1384.2
006300 03 DOTVALUE PIC 99 VALUE ZERO. IF1384.2
006400 02 FILLER PIC X(8) VALUE SPACE. IF1384.2
006500 02 RE-MARK PIC X(61). IF1384.2
006600 01 TEST-COMPUTED. IF1384.2
006700 02 FILLER PIC X(30) VALUE SPACE. IF1384.2
006800 02 FILLER PIC X(17) VALUE IF1384.2
006900 " COMPUTED=". IF1384.2
007000 02 COMPUTED-X. IF1384.2
007100 03 COMPUTED-A PIC X(20) VALUE SPACE. IF1384.2
007200 03 COMPUTED-N REDEFINES COMPUTED-A IF1384.2
007300 PIC -9(9).9(9). IF1384.2
007400 03 COMPUTED-0V18 REDEFINES COMPUTED-A PIC -.9(18). IF1384.2
007500 03 COMPUTED-4V14 REDEFINES COMPUTED-A PIC -9(4).9(14). IF1384.2
007600 03 COMPUTED-14V4 REDEFINES COMPUTED-A PIC -9(14).9(4). IF1384.2
007700 03 CM-18V0 REDEFINES COMPUTED-A. IF1384.2
007800 04 COMPUTED-18V0 PIC -9(18). IF1384.2
007900 04 FILLER PIC X. IF1384.2
008000 03 FILLER PIC X(50) VALUE SPACE. IF1384.2
008100 01 TEST-CORRECT. IF1384.2
008200 02 FILLER PIC X(30) VALUE SPACE. IF1384.2
008300 02 FILLER PIC X(17) VALUE " CORRECT =". IF1384.2
008400 02 CORRECT-X. IF1384.2
008500 03 CORRECT-A PIC X(20) VALUE SPACE. IF1384.2
008600 03 CORRECT-N REDEFINES CORRECT-A PIC -9(9).9(9). IF1384.2
008700 03 CORRECT-0V18 REDEFINES CORRECT-A PIC -.9(18). IF1384.2
008800 03 CORRECT-4V14 REDEFINES CORRECT-A PIC -9(4).9(14). IF1384.2
008900 03 CORRECT-14V4 REDEFINES CORRECT-A PIC -9(14).9(4). IF1384.2
009000 03 CR-18V0 REDEFINES CORRECT-A. IF1384.2
009100 04 CORRECT-18V0 PIC -9(18). IF1384.2
009200 04 FILLER PIC X. IF1384.2
009300 03 FILLER PIC X(2) VALUE SPACE. IF1384.2
009400 03 COR-ANSI-REFERENCE PIC X(48) VALUE SPACE. IF1384.2
009500 01 TEST-CORRECT-MIN. IF1384.2
009600 02 FILLER PIC X(30) VALUE SPACE. IF1384.2
009700 02 FILLER PIC X(17) VALUE " MIN VALUE =". IF1384.2
009800 02 CORRECTMI-X. IF1384.2
009900 03 CORRECTMI-A PIC X(20) VALUE SPACE. IF1384.2
010000 03 CORRECT-MIN REDEFINES CORRECTMI-A PIC -9(9).9(9). IF1384.2
010100 03 CORRECTMI-0V18 REDEFINES CORRECTMI-A PIC -.9(18). IF1384.2
010200 03 CORRECTMI-4V14 REDEFINES CORRECTMI-A PIC -9(4).9(14). IF1384.2
010300 03 CORRECTMI-14V4 REDEFINES CORRECTMI-A PIC -9(14).9(4). IF1384.2
010400 03 CR-18V0 REDEFINES CORRECTMI-A. IF1384.2
010500 04 CORRECTMI-18V0 PIC -9(18). IF1384.2
010600 04 FILLER PIC X. IF1384.2
010700 03 FILLER PIC X(2) VALUE SPACE. IF1384.2
010800 03 FILLER PIC X(48) VALUE SPACE. IF1384.2
010900 01 TEST-CORRECT-MAX. IF1384.2
011000 02 FILLER PIC X(30) VALUE SPACE. IF1384.2
011100 02 FILLER PIC X(17) VALUE " MAX VALUE =". IF1384.2
011200 02 CORRECTMA-X. IF1384.2
011300 03 CORRECTMA-A PIC X(20) VALUE SPACE. IF1384.2
011400 03 CORRECT-MAX REDEFINES CORRECTMA-A PIC -9(9).9(9). IF1384.2
011500 03 CORRECTMA-0V18 REDEFINES CORRECTMA-A PIC -.9(18). IF1384.2
011600 03 CORRECTMA-4V14 REDEFINES CORRECTMA-A PIC -9(4).9(14). IF1384.2
011700 03 CORRECTMA-14V4 REDEFINES CORRECTMA-A PIC -9(14).9(4). IF1384.2
011800 03 CR-18V0 REDEFINES CORRECTMA-A. IF1384.2
011900 04 CORRECTMA-18V0 PIC -9(18). IF1384.2
012000 04 FILLER PIC X. IF1384.2
012100 03 FILLER PIC X(2) VALUE SPACE. IF1384.2
012200 03 CORMA-ANSI-REFERENCE PIC X(48) VALUE SPACE. IF1384.2
012300 01 CCVS-C-1. IF1384.2
012400 02 FILLER PIC IS X(99) VALUE IS " FEATURE PAIF1384.2
012500- "SS PARAGRAPH-NAME IF1384.2
012600- " REMARKS". IF1384.2
012700 02 FILLER PIC X(20) VALUE SPACE. IF1384.2
012800 01 CCVS-C-2. IF1384.2
012900 02 FILLER PIC X VALUE SPACE. IF1384.2
013000 02 FILLER PIC X(6) VALUE "TESTED". IF1384.2
013100 02 FILLER PIC X(15) VALUE SPACE. IF1384.2
013200 02 FILLER PIC X(4) VALUE "FAIL". IF1384.2
013300 02 FILLER PIC X(94) VALUE SPACE. IF1384.2
013400 01 REC-SKL-SUB PIC 9(2) VALUE ZERO. IF1384.2
013500 01 REC-CT PIC 99 VALUE ZERO. IF1384.2
013600 01 DELETE-COUNTER PIC 999 VALUE ZERO. IF1384.2
013700 01 ERROR-COUNTER PIC 999 VALUE ZERO. IF1384.2
013800 01 INSPECT-COUNTER PIC 999 VALUE ZERO. IF1384.2
013900 01 PASS-COUNTER PIC 999 VALUE ZERO. IF1384.2
014000 01 TOTAL-ERROR PIC 999 VALUE ZERO. IF1384.2
014100 01 ERROR-HOLD PIC 999 VALUE ZERO. IF1384.2
014200 01 DUMMY-HOLD PIC X(120) VALUE SPACE. IF1384.2
014300 01 RECORD-COUNT PIC 9(5) VALUE ZERO. IF1384.2
014400 01 ANSI-REFERENCE PIC X(48) VALUE SPACES. IF1384.2
014500 01 CCVS-H-1. IF1384.2
014600 02 FILLER PIC X(39) VALUE SPACES. IF1384.2
014700 02 FILLER PIC X(42) VALUE IF1384.2
014800 "OFFICIAL COBOL COMPILER VALIDATION SYSTEM". IF1384.2
014900 02 FILLER PIC X(39) VALUE SPACES. IF1384.2
015000 01 CCVS-H-2A. IF1384.2
015100 02 FILLER PIC X(40) VALUE SPACE. IF1384.2
015200 02 FILLER PIC X(7) VALUE "CCVS85 ". IF1384.2
015300 02 FILLER PIC XXXX VALUE IF1384.2
015400 "4.2 ". IF1384.2
015500 02 FILLER PIC X(28) VALUE IF1384.2
015600 " COPY - NOT FOR DISTRIBUTION". IF1384.2
015700 02 FILLER PIC X(41) VALUE SPACE. IF1384.2
015800 IF1384.2
015900 01 CCVS-H-2B. IF1384.2
016000 02 FILLER PIC X(15) VALUE IF1384.2
016100 "TEST RESULT OF ". IF1384.2
016200 02 TEST-ID PIC X(9). IF1384.2
016300 02 FILLER PIC X(4) VALUE IF1384.2
016400 " IN ". IF1384.2
016500 02 FILLER PIC X(12) VALUE IF1384.2
016600 " HIGH ". IF1384.2
016700 02 FILLER PIC X(22) VALUE IF1384.2
016800 " LEVEL VALIDATION FOR ". IF1384.2
016900 02 FILLER PIC X(58) VALUE IF1384.2
017000 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".IF1384.2
017100 01 CCVS-H-3. IF1384.2
017200 02 FILLER PIC X(34) VALUE IF1384.2
017300 " FOR OFFICIAL USE ONLY ". IF1384.2
017400 02 FILLER PIC X(58) VALUE IF1384.2
017500 "COBOL 85 VERSION 4.2, Apr 1993 SSVG ".IF1384.2
017600 02 FILLER PIC X(28) VALUE IF1384.2
017700 " COPYRIGHT 1985 ". IF1384.2
017800 01 CCVS-E-1. IF1384.2
017900 02 FILLER PIC X(52) VALUE SPACE. IF1384.2
018000 02 FILLER PIC X(14) VALUE IS "END OF TEST- ". IF1384.2
018100 02 ID-AGAIN PIC X(9). IF1384.2
018200 02 FILLER PIC X(45) VALUE SPACES. IF1384.2
018300 01 CCVS-E-2. IF1384.2
018400 02 FILLER PIC X(31) VALUE SPACE. IF1384.2
018500 02 FILLER PIC X(21) VALUE SPACE. IF1384.2
018600 02 CCVS-E-2-2. IF1384.2
018700 03 ERROR-TOTAL PIC XXX VALUE SPACE. IF1384.2
018800 03 FILLER PIC X VALUE SPACE. IF1384.2
018900 03 ENDER-DESC PIC X(44) VALUE IF1384.2
019000 "ERRORS ENCOUNTERED". IF1384.2
019100 01 CCVS-E-3. IF1384.2
019200 02 FILLER PIC X(22) VALUE IF1384.2
019300 " FOR OFFICIAL USE ONLY". IF1384.2
019400 02 FILLER PIC X(12) VALUE SPACE. IF1384.2
019500 02 FILLER PIC X(58) VALUE IF1384.2
019600 "ON-SITE VALIDATION, NATIONAL INSTITUTE OF STD & TECH. ".IF1384.2
019700 02 FILLER
…(truncated)…
01.cbl · 373 B · ext .cbl · SWH occurrences unknown
via swh_study:cobol (reclassifier:cobol; human:mathieu-acher)
swh:1:cnt:84dc7ee9806a492bfa98b5d307fe018808c50fff;origin=https://github.com/michalasobczak/q;path=/05/cobol/01.cbl
Reviews (1 human)
👤 mathieu-acher → pl/cobol (medium) 2026-07-08
demo-example
Show source
*> setup the identification division
IDENTIFICATION DIVISION.
*> setup the program id
PROGRAM-ID. HELLO.
*> setup the procedure division (like 'main' function)
PROCEDURE DIVISION.
*> print a string
DISPLAY 'WILLKOMMEN'.
*> end our program
STOP RUN.
Form1.Designer.cbl · 1250 B · ext .cbl · SWH occurrences unknown
via swh_study:cobol (judge:claude-sonnet-4.6 (cobol-judge/2, shown indicators); reclassifier:cobol-generated)
swh:1:cnt:11085a16efb09a9bca78144ab36461d68ecb8920;origin=https://github.com/schleyer/GitStrtUp;path=/Form1.Designer.cbl
Reviews (1 LLM)
🤖 anthropic-claude-sonnet-4.6 cobol-judge/2 → pl/cobol (high) 2026-07-07
micro-focus, COBOL-2002, fixed; subprogram, utility-tooling
Show source
class-id. Form1 as "STARTPROG.Form1" is partial
inherits type "System.Windows.Forms.Form".
environment division.
configuration section.
repository.
object.
working-storage section.
01 components type "System.ComponentModel.IContainer".
*> Required method for Designer support - do not modify
*> the contents of this method with the code editor.
method-id. "InitializeComponent" private.
procedure division.
set components to new "System.ComponentModel.Container"()
set self::"Text" to "Form1"
set self::"Size" to new "System.Drawing.Size"(400, 400)
goback.
end method "InitializeComponent".
*> Clean up any resources being used.
method-id. "Dispose" override protected.
procedure division using by value disposing as condition-value.
if disposing then
if components not = null then
invoke components::"Dispose"()
end-if
end-if
invoke super::"Dispose"(by value disposing)
goback.
end method "Dispose".
end object.
end class Form1.
sys.d.cbl · 1042 B · ext .cbl · SWH occurrences unknown
via swh_study:cobol (judge:claude-sonnet-4.6 (cobol-judge/2, shown indicators); reclassifier:cobol)
swh:1:cnt:a4b1dbc856e6c267ed7b840be8eff21dc667acba;origin=https://github.com/yakiro-nvg/cobol.js;path=/types/sys.d.cbl
Reviews (1 LLM)
🤖 anthropic-claude-sonnet-4.6 cobol-judge/2 → pl/cobol (low) 2026-07-07
unknown, unknown, fixed; copybook, utility-tooling
Show source
* Type declarations for system `Sys` module.
export-module. Sys.
* Formats primitives value as string.
program-id. To-String.
* Match a Comp-2.
data division.
linkage section.
* A value to format.
01 Val Comp-2.
* Formatted string.
01 Str pic X(n).
procedure division using Val returning Str.
* Match a Comp-4.
data division.
linkage section.
* A value to format.
01 Val pic S9(n)V9(n) Comp-4.
* Formatted string.
01 Str pic X(n).
procedure division using Val returning Str.
end program To-String.
* Prints a string to output terminal, used by `DISPLAY`.
program-id. Console-Display.
data division.
linkage section.
* A string to print-out.
01 Msg pic X(n).
procedure division using Msg.
end program Console-Display.
ORCSMISAVE.CBL · 12122 B · ext .CBL · SWH occurrences unknown
via swh_study:cobol (judge:claude-sonnet-4.6 (cobol-judge/2, shown indicators); reclassifier:cobol)
swh:1:cnt:e2bcfeb80e3dbf3078a766995eaeef958361b9e7;origin=https://github.com/izumiya/jma-receipt;path=/cobol/common/ORCSMISAVE.CBL
Reviews (1 LLM)
🤖 anthropic-claude-sonnet-4.6 cobol-judge/2 → pl/cobol (high) 2026-06-17
gnucobol, COBOL-85, fixed; subprogram, healthcare-medical
Show source
*******************************************************************
* Project code name "ORCA"
* ����ɸ��쥻�ץȥ��եȡ�JMA standard receipt software��
* Copyright(C) 2002 JMA (Japan Medical Association)
*
* This program is part of "JMA standard receipt software".
*
* This program is distributed in the hope that it will be useful
* for further advancement in medical care, according to JMA Open
* Source License, but WITHOUT ANY WARRANTY.
* Everyone is granted permission to use, copy, modify and
* redistribute this program, but only under the conditions described
* in the JMA Open Source License. You should have received a copy of
* this license along with this program. If not, stop using this
* program and contact JMA, 2-28-16 Honkomagome, Bunkyo-ku, Tokyo,
* 113-8621, Japan.
********************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. ORCSMISAVE.
*****************************************************************
* �����ƥ�̾ : �ϣңã�
* ���֥����ƥ�̾ : ����������
* ����ݡ��ͥ��̾ : ���ޥ������Ͽ
* ������ :
* �������� ��ȼ� ����
* 14/07/28 NACL�ݰ�ƣ ��������
*****************************************************************
* �ץ�����ཤ������
* Maj/Min/Rev ������ ���� ����
*****************************************************************
*
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
*
* ������ǡ����ե�����
SELECT IMAGE-FILE ASSIGN IMAGE-FILENAME
FILE STATUS IS STS-IMAGE.
*
DATA DIVISION.
FILE SECTION.
*
* ������ǡ����ե�����
FD IMAGE-FILE.
01 IMAGE-REC PIC X(500000).
*
WORKING-STORAGE SECTION.
*
* �ե饰�ΰ�
01 STS-AREA.
03 STS-IMAGE PIC X(02).
*
01 FLG-AREA.
03 FLG-END PIC 9(01).
03 FLG-OPEN PIC 9(01).
03 FLG-MEDIMAGE PIC 9(01).
*
* ������ǡ����ե�����̾
01 IMAGE-FILENAME PIC X(256).
*
* ���ޥ��
01 COMMAND PIC X(512).
*
* �ֵ���
01 RESULT PIC S9(09).
*
* �����ե�����ե����̾
01 WRK-CONS-AREA.
03 WRK-CONS-MEDIMGDIR PIC X(08) VALUE "medimage".
*
*****************************************************************
* �ե�����쥤������
*****************************************************************
*
COPY "CPMEDIMAGE.INC".
*
*****************************************************************
* ���֥ץ����ΰ�
*****************************************************************
*
* ���̥ѥ�
COPY "MCPAREA".
COPY "MCPDATA.INC".
*
01 MCPDATA.
03 MCPREC PIC X(510000).
*
****************************************************************
LINKAGE SECTION.
*
COPY "CPORCSMIAREA.INC".
COPY "COMMON-SPA".
*
PROCEDURE DIVISION
USING
ORCSMIAREA
SPA-AREA
.
*****************************************************************
* �����
*****************************************************************
000-PROC-SEC SECTION.
*
PERFORM 100-INIT-SEC
*
PERFORM 200-MAIN-SEC UNTIL FLG-END = 1
*
PERFORM 300-TERM-SEC
.
000-PROC-EXT.
EXIT PROGRAM.
*
*****************************************************************
* ���������
*****************************************************************
100-INIT-SEC SECTION.
*
INITIALIZE STS-AREA
INITIALIZE FLG-AREA
*
* ������ǡ����ե�����̾
MOVE SPACE TO IMAGE-FILENAME
STRING ORCSMI-TEMPDIR DELIMITED BY SPACE
"/" DELIMITED BY SIZE
ORCSMI-SRYCD DELIMITED BY SPACE
".txt" DELIMITED BY SIZE
INTO IMAGE-FILENAME
END-STRING
*
* �����ե����뤫�饤����ǡ����������ޥ��
MOVE LOW-VALUE TO COMMAND
STRING "base64 " DELIMITED BY SIZE
ORCSMI-TEMPDIR DELIMITED BY SPACE
"/" DELIMITED BY SIZE
WRK-CONS-MEDIMGDIR DELIMITED BY SIZE
"/" DELIMITED BY SIZE
ORCSMI-FILENAME DELIMITED BY SPACE
" > " DELIMITED BY SIZE
IMAGE-FILENAME DELIMITED BY SPACE
INTO COMMAND
END-STRING
* ���ޥ�ɼ¹�
CALL "system" USING
COMMAND
RETURNING RESULT
*
IF RESULT NOT = ZERO
DISPLAY "base64 RC:[ " RESULT " ]"
MOVE 1 TO ORCSMI-RETCD
MOVE 1 TO FLG-END
ELSE
* ������ǡ����ե������ɤ߹���
OPEN INPUT IMAGE-FILE
IF STS-IMAGE NOT = ZERO
DISPLAY "ORCSMISAVE IMAGE FILE OPEN ERROR"
MOVE 1 TO ORCSMI-RETCD
MOVE 1 TO FLG-END
ELSE
READ IMAGE-FILE
AT END
MOVE 1 TO FLG-END
END-READ
END-IF
MOVE 1 TO FLG-OPEN
END-IF
.
100-INIT-EXT.
EXIT.
*
*****************************************************************
* �����
*****************************************************************
200-MAIN-SEC SECTION.
*
* ������ǡ����ɤ߹���
PERFORM 900-MEDIMAGE-READ-SEC
*
INITIALIZE MEDIMAGE-REC
MOVE SPA-HOSPNUM TO MEDIMG-HOSPNUM
MOVE ORCSMI-SRYCD TO MEDIMG-SRYCD
MOVE ORCSMI-IMAGEKBN TO MEDIMG-IMAGEKBN
MOVE IMAGE-REC TO MEDIMG-IMAGEDATA
MOVE SPA-OPID TO MEDIMG-OPID
MOVE SPA-SYSYMD TO MEDIMG-UPYMD
MOVE MEDIMAGE-REC TO MCPREC
*
IF FLG-MEDIMAGE = ZERO
* ������ǡ�������
PERFORM 900-MEDIMAGE-UPD-SEC
ELSE
* ������ǡ����ɲ�
PERFORM 900-MEDIMAGE-INS-SEC
END-IF
*
MOVE 1 TO FLG-END
.
200-MAIN-EXT.
EXIT.
*
*****************************************************************
* �����
*****************************************************************
300-TERM-SEC SECTION.
*
IF FLG-OPEN = 1
CLOSE IMAGE-FILE
END-IF
*
* ������ǡ����ե����������ޥ��
MOVE LOW-VALUE TO COMMAND
STRING "rm -f " DELIMITED BY SIZE
IMAGE-FILENAME DELIMITED BY SPACE
INTO COMMAND
END-STRING
* ���ޥ�ɼ¹�
CALL "system" USING
COMMAND
RETURNING RESULT
.
300-TERM-EXT.
EXIT.
*
*****************************************************************
* ������ǡ����ɤ߹��� ����
*****************************************************************
900-MEDIMAGE-READ-SEC SECTION.
*
INITIALIZE MEDIMAGE-REC
MOVE SPA-HOSPNUM TO MEDIMG-HOSPNUM
MOVE ORCSMI-SRYCD TO MEDIMG-SRYCD
MOVE MEDIMAGE-REC TO MCPREC
MOVE "DBSELECT" TO MCP-FUNC
MOVE "tbl_med_image" TO MCP-TABLE
MOVE "key" TO MCP-PATHNAME
CALL "MONFUNC" USING
MCPAREA
MCPREC
SPA-AREA
IF MCP-RC = ZERO
MOVE "DBFETCH" TO MCP-FUNC
MOVE "tbl_med_image" TO MCP-TABLE
MOVE "key" TO MCP-PATHNAME
CALL "MONFUNC" USING
MCPAREA
MCPREC
SPA-AREA
IF MCP-RC = ZERO
MOVE ZERO TO FLG-MEDIMAGE
ELSE
MOVE 1 TO FLG-MEDIMAGE
END-IF
ELSE
MOVE 1 TO FLG-MEDIMAGE
END-IF
*
MOVE "DBCLOSECURSOR" TO MCP-FUNC
MOVE "tbl_med_image" TO MCP-TABLE
MOVE "key" TO MCP-PATHNAME
CALL "MONFUNC" USING
MCPAREA
MCPREC
SPA-AREA
.
900-MEDIMAGE-READ-EXT.
EXIT.
*
*****************************************************************
* ������ǡ����ɲ� ����
*****************************************************************
900-MEDIMAGE-INS-SEC SECTION.
*
MOVE "DBINSERT" TO MCP-FUNC
MOVE "tbl_med_image" TO MCP-TABLE
MOVE "key" TO MCP-PATHNAME
CALL "MONFUNC" USING
MCPAREA
MCPREC
SPA-AREA
IF MCP-RC NOT = ZERO
DISPLAY "ORCSMISAVE INSERT ERROR :" MCP-RC "."
MOVE 1 TO ORCSMI-RETCD
END-IF
.
900-MEDIMAGE-INS-EXT.
EXIT.
*
*****************************************************************
* ������ǡ������� ����
*****************************************************************
900-MEDIMAGE-UPD-SEC SECTION.
*
MOVE "DBUPDATE" TO MCP-FUNC
MOVE "tbl_med_image" TO MCP-TABLE
MOVE "key" TO MCP-PATHNAME
CALL "MONFUNC" USING
MCPAREA
MCPREC
SPA-AREA
IF MCP-RC NOT = ZERO
DISPLAY "ORCSMISAVE UPDATE ERROR :" MCP-RC "."
MOVE 1 TO ORCSMI-RETCD
END-IF
.
900-MEDIMAGE-UPD-EXT.
EXIT.
*
calc-expenses.cbl · 2439 B · ext .cbl · SWH occurrences unknown
via swh_study:cobol (judge:claude-sonnet-4.6 (cobol-judge/2, shown indicators); reclassifier:cobol)
swh:1:cnt:04db07df088b136f11f64d356c2ef3abfa1042b9;origin=https://github.com/isobelscott/business_expenses;path=/calc-expenses.cbl
Reviews (1 LLM)
🤖 anthropic-claude-sonnet-4.6 cobol-judge/2 → pl/cobol (medium) 2026-07-07
gnucobol, COBOL-85, fixed; batch, accounting-erp
Show source
IDENTIFICATION DIVISION.
PROGRAM-ID. CALC-EXPENSES.
AUTHOR. ISOBEL SCOTT.
ENVIRONMENT DIVISION.
INPUT-OUTPUT SECTION.
FILE-CONTROL.
SELECT ExpenseFile ASSIGN TO 'expense_reports/CASABLANCA.csv'
ORGANIZATION IS LINE SEQUENTIAL.
SELECT SortedExpenseFile ASSIGN TO 'processed/CASASORTED.csv'
ORGANIZATION IS LINE SEQUENTIAL.
SELECT TP ASSIGN TO TEMP.
DATA DIVISION.
FILE SECTION.
FD ExpenseFile.
01 IN-REC.
03 ExpenseDate PIC X(50).
03 EmployeeName PIC X(50).
03 EmployeeId PIC 9(6).
03 City PIC X(15).
03 Country PIC X(15).
03 BusinessName PIC X(50).
03 Category PIC X(50).
03 ReportId PIC 9(6).
03 LocalAmount PIC 9(10)V99.
03 LocalCurrency PIC X(3).
03 UsdAmount PIC 9(7)V99.
FD SortedExpenseFile.
01 OUT-REC.
03 ExpenseDate-S PIC X(50).
03 EmployeeName-S PIC X(50).
03 EmployeeId-S PIC 9(6).
03 City-S PIC X(15).
03 Country-S PIC X(15).
03 BusinessName-S PIC X(50).
03 Category-S PIC X(50).
03 ReportId-S PIC 9(6).
03 LocalAmount-S PIC 9(10)V99.
03 LocalCurrency-S PIC X(3).
03 UsdAmount-S PIC 9(7)V99.
SD TP.
01 ExpenseDate-T PIC X(50).
01 EmployeeName-T PIC X(50).
01 City-T PIC X(15).
01 Country-T PIC X(15).
01 BusinessName-T PIC X(50).
01 Category-T PIC X(50).
01 ReportId-T PIC 9(6).
01 LocalAmount-T PIC 9(10)V99.
01 LocalCurrency-T PIC X(3).
01 UsdAmount-T PIC 9(7)V99.
WORKING-STORAGE SECTION.
77 EOF pic x value 'n'.
PROCEDURE DIVISION.
BEGIN.
OPEN INPUT ExpenseFile.
OPEN OUTPUT SortedExpenseFile.
READ ExpenseFile AT END MOVE 'y' TO EOF.
PERFORM p-para UNTIL EOF = 'y'.
CLOSE ExpenseFile SortedExpenseFile.
STOP RUN.
p-para.
WRITE OUT-REC FROM IN-REC AFTER ADVANCING 1 LINE.
DISPLAY 'COMPLETED.'
READ ExpenseFile AT END MOVE 'y' to EOF.
DFH0XSOD.cbl · 7259 B · ext .cbl · SWH occurrences unknown
via swh_study:cobol (judge:claude-sonnet-4.6 (cobol-judge/2, shown indicators); reclassifier:cobol)
swh:1:cnt:bab43fcee6d1fa4eac7f03463c9f9df45b07f054;origin=https://github.com/Jack-Billings-IBM/catalog;path=/COBOL/DFH0XSOD.cbl
Reviews (1 LLM)
🤖 anthropic-claude-sonnet-4.6 cobol-judge/2 → pl/cobol (high) 2026-06-17
ibm-mainframe, COBOL-85, fixed; online-cics, demo-example
Show source
CBL CICS('COBOL3') APOST
******************************************************************
* *
* MODULE NAME = DFH0XSOD *
* *
* DESCRIPTIVE NAME = CICS TS (Samples) Example Application - *
* Stubbed Order Dispatcher *
* *
* *
* *
* Licensed Materials - Property of IBM *
* *
* "Restricted Materials of IBM" *
* *
* 5655-Y04 *
* *
* (C) Copyright IBM Corp. 2004" *
* *
* *
* *
* *
* STATUS = 7.2.0 *
* *
* TRANSACTION NAME = n/a *
* *
* FUNCTION = *
* This program is a stubbed version of the order dispatcher *
* program used when outbound webservices are not required *
* *
*----------------------------------------------------------------*
* *
* ENTRY POINT = DFH0XSOD *
* *
*----------------------------------------------------------------*
* *
* CHANGE ACTIVITY : *
* *
* $MOD(DFH0XSOD),COMP(SAMPLES),PROD(CICS TS ): *
* *
* PN= REASON REL YYMMDD HDXXIII : REMARKS *
* $D0= I07544 640 040910 HDIPCB : EXAMPLE - BASE APPLICATION *
* *
******************************************************************
IDENTIFICATION DIVISION.
PROGRAM-ID. DFH0XSOD.
ENVIRONMENT DIVISION.
CONFIGURATION SECTION.
DATA DIVISION.
WORKING-STORAGE SECTION.
*----------------------------------------------------------------*
* Common defintions *
*----------------------------------------------------------------*
* Run time (debug) infomation for this invocation
01 WS-HEADER.
03 WS-EYECATCHER PIC X(16)
VALUE 'DFH0XSOD------WS'.
03 WS-TRANSID PIC X(4).
03 WS-TERMID PIC X(4).
03 WS-TASKNUM PIC 9(7).
03 WS-CALEN PIC S9(4) COMP.
* Variables for time/date processing
01 ABS-TIME PIC S9(8) COMP VALUE +0.
01 TIME1 PIC X(8) VALUE SPACES.
01 DATE1 PIC X(10) VALUE SPACES.
* Error Message structure
01 ERROR-MSG.
03 EM-DATE PIC X(8) VALUE SPACES.
03 FILLER PIC X VALUE SPACES.
03 EM-TIME PIC X(6) VALUE SPACES.
03 FILLER PIC X(9) VALUE ' EXMPCMAN'.
03 EM-DETAIL PIC X(50) VALUE SPACES.
*----------------------------------------------------------------*
******************************************************************
* L I N K A G E S E C T I O N
******************************************************************
LINKAGE SECTION.
01 DFHCOMMAREA.
COPY DFH0XCP2.
******************************************************************
* P R O C E D U R E S
******************************************************************
PROCEDURE DIVISION.
*----------------------------------------------------------------*
MAINLINE SECTION.
*----------------------------------------------------------------*
* Common code *
*----------------------------------------------------------------*
* initialize working storage variables
INITIALIZE WS-HEADER.
* set up general variable
MOVE EIBTRNID TO WS-TRANSID.
MOVE EIBTRMID TO WS-TERMID.
MOVE EIBTASKN TO WS-TASKNUM.
*---------------------------------------------------------------*
* Check commarea and obtain required details *
*---------------------------------------------------------------*
* If NO commarea received issue an ABEND
IF EIBCALEN IS EQUAL TO ZERO
MOVE ' NO COMMAREA RECEIVED' TO EM-DETAIL
PERFORM WRITE-ERROR-MESSAGE
EXEC CICS ABEND ABCODE('EXCA') NODUMP END-EXEC
END-IF
* Initalize commarea return code to zero
MOVE '00' TO CA-ORD-RETURN-CODE
* Return to caller
EXEC CICS RETURN END-EXEC.
MAINLINE-EXIT.
EXIT.
*----------------------------------------------------------------*
*================================================================*
* Procedure to write error message to TD QUEUE(CSMT) *
* message will include Date, Time, Program Name, *
* and error details. *
*================================================================*
WRITE-ERROR-MESSAGE.
* Obtain and format current time and date
EXEC CICS ASKTIME ABSTIME(ABS-TIME)
END-EXEC
EXEC CICS FORMATTIME ABSTIME(ABS-TIME)
MMDDYYYY(DATE1)
TIME(TIME1)
END-EXEC
MOVE DATE1 TO EM-DATE
MOVE TIME1 TO EM-TIME
* Write output message to TDQ
EXEC CICS WRITEQ TD QUEUE('CSMT')
FROM(ERROR-MSG)
LENGTH(LENGTH OF ERROR-MSG)
END-EXEC.
EXIT.