./ ADD NAME=CICSHELL 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. CICSSEND. 000300 AUTHOR. 000400 DATE-WRITTEN. 000500 DATE-COMPILED. 000600 ENVIRONMENT DIVISION. 000700****************************************************************** 000800 DATA DIVISION. 000900/**************************************************************** 001000* W O R K I N G - S T O R A G E S E C T I O N * 001100***************************************************************** 001200 WORKING-STORAGE SECTION. 001300 01 STANDARD-PROGRAM-ID. 001400 05 A-STANDARD-PROGRAM-ID PIC X(26) VALUE 001500 'UNIPAC/???????/??????-1.00'. 001600***************************************************************** 001700* A C C U M U L A T O R S * 001800***************************************************************** 001900 01 ACCUMULATORS. 002000 05 FILLER PIC X(13) VALUE 002100 'ACCUMULATORS:'. 002200/**************************************************************** 002300* C O N S T A N T S * 002400***************************************************************** 002500 01 CONSTANTS. 002600 05 FILLER PIC X(10) VALUE 002700 'CONSTANTS:'. 002800 05 C-MESSAGE-AREA. 002900 10 FILLER PIC X(80) VALUE ALL '*'. 003000 10 FILLER PIC X(80) VALUE ALL '*'. 003100 10 C-MESSAGE-LINE-1 PIC X(80) VALUE SPACES. 003200 10 C-MESSAGE-LINE-2 PIC X(80) VALUE SPACES. 003300 10 C-MESSAGE-LINE-3 PIC X(80) VALUE SPACES. 003400 10 FILLER PIC X(80) VALUE ALL '*'. 003500 10 FILLER PIC X(80) VALUE ALL '*'. 003600 05 C-MAP-NAME PIC X(08) VALUE '????????'. 003700 05 C-MAP-SET-NAME PIC X(08) VALUE '????????'. 003800 05 C-TRANSACTION-ID PIC X(04) VALUE '????'. 003900/**************************************************************** 004000* S W I T C H E S * 004100***************************************************************** 004200 01 SWITCHES. 004300 05 FILLER PIC X(09) VALUE 004400 'SWITCHES:'. 004500 05 S-ERROR-SWITCH PIC X(01) VALUE ' '. 004600 88 S-ERROR-CONDITION VALUE 'E'. 004700 05 S-EXIT-SWITCH PIC X(01) VALUE 'N'. 004800 88 S-EXIT-TRANSACTION VALUE 'Y'. 004900/**************************************************************** 005000* W O R K A R E A S * 005100***************************************************************** 005200 01 WORK-AREAS. 005300 05 FILLER PIC X(11) VALUE 005400 'WORK AREAS:'. 005500 05 W-COMMAREA. 005600 10 W-CA-????? PIC X(80) VALUE SPACES. 005700/**************************************************************** 005800* T A B L E S * 005900***************************************************************** 006000 01 TABLES. 006100 05 FILLER PIC X(07) VALUE 006200 'TABLES:'. 008700/**************************************************************** 008800* C I C S S Y S T E M C O P Y B O O K S * 008900***************************************************************** 009000***************************************************************** 009100* A I D K E Y M N E M O N I C S * 009200***************************************************************** 009300 COPY DFHAID. 009400/**************************************************************** 009500* B M S A T T R I B U T E V A L U E S * 009600***************************************************************** 009700 COPY DFHBMSCA. 009800/**************************************************************** 009900* B M S S Y M B O L I C M A P * 010000***************************************************************** 010100 COPY ????????. 010200/**************************************************************** 010300* R E D E F I N E D B M S M A P * 010400***************************************************************** 010500 01 MAP-REDEFIES-AREA REDEFINES ????????. 010600 05 ???????? 010700/**************************************************************** 010800* L I N K A G E S E C T I O N * 010900***************************************************************** 011000 LINKAGE SECTION. 011100 01 DFHCOMMAREA. 011200 05 COMM-AREA-DATA PIC X(80). 011300 PROCEDURE DIVISION. 011400/**************************************************************** 011500* A000-CONTROL * 011600* 1. PERFORMS THE PRIMARY PROCESSES. * 011700***************************************************************** 011800 A000-CONTROL SECTION. 011900 012000 PERFORM A100-INITIALIZATION. 012100 012200 PERFORM B100-MAINLINE. 012300 012400 PERFORM Z100-FINALIZATION. 012500 012600 A000-EXIT. 012700 GOBACK. 012800/**************************************************************** 012900* A100-INITIALIZATION * 013000* 1. * 013100***************************************************************** 013200 A100-INITIALIZATION SECTION. 013300 013400 MOVE 'A100-INITIALIZATION' TO W-SECTION-NAME. 013500 013600 IF EIBCALEN = 0 013700 SET S-FIRST-TIME TO TRUE 013800 EXEC CICS RECEIVE 013900 MAP (C-MAP-NAME) 014000 MAPSET (C-MAPSET-NAME) 014100 NOHANDLE 014200 END-EXEC 014300 EVALUATE EIBRESP 014400 WHEN DFHRESP(NORMAL) 014500 PERFORM A200-PARSE-INITIAL-INPUT 014600 WHEN DFHRESP(MAPFAIL) 014700 PERFORM A200-PARSE-INITIAL-INPUT 014800 WHEN OTHER 014900 PERFORM E100-FORMAT-ERROR-MESSAGE 015000 END-EVALUATE 015100 ELSE 015200 SET S-NOT-FIRST-TIME TO TRUE 015300 EVALUATE EIBAID 015400 WHEN DFHCLEAR 015500 SET S-EXIT-TRANSACTION TO TRUE 015600 WHEN DFHPF3 015700 SET S-EXIT-TRANSACTION TO TRUE 015800 WHEN DFHENTER 015900 EXEC CICS RECEIVE 016000 MAP (C-MAP-NAME) 016100 MAPSET (C-MAPSET-NAME) 016200 NOHANDLE 016300 END-EXEC 016400 EVALUATE EIBRESP 016500 WHEN DFHRESP(NORMAL) 016600 CONTINUE 016700 WHEN OTHER 016800 PERFORM E100-FORMAT-ERROR-MESSAGE 016900 END-EVALUATE 017000 WHEN OTHER 017100 SET M-INVALID-KEY TO TRUE 017200 END-EVALUATE 017300 END-IF. 017400 017500 A100-EXIT. 017600 EXIT. 017700/**************************************************************** 017800* A200-PARSE-INITIAL-INPUT * 017900* 1. * 018000***************************************************************** 018100 A200-PARSE-INITIAL-INPUT SECTION. 018200 018300 MOVE 'A200-PARSE-INITIAL-INPUT' TO W-SECTION-NAME. 018400* ENTER INITIAL INPUT PARSING LOGIC HERE ????? 018500 018600 A200-EXIT. 018700 EXIT. 018800/**************************************************************** 018900* B100-MAINLINE * 019000* 1. * 019100***************************************************************** 019200 B100-MAINLINE SECTION. 019300 019400 MOVE 'B100-MAINLINE' TO W-SECTION-NAME. 019500 019600 EVALUATE TRUE 019700 WHEN S-ERROR-CONDITION 019800 PERFORM B200-SEND-TEXT-RESPONSE 019900 SET S-EXIT-TRANSACTION TO TRUE 020000 WHEN S-EXIT-TRANSACTION 020100 PERFORM B200-SEND-TEXT-RESPONSE 020200 WHEN S-FIRST-TIME 020300 PERFORM B300-SEND-INITIAL-MAP 020400 WHEN M-NO-MAP-MESSAGE 020500 PERFORM B400-PROCESS-MAP-INPUT 020600 PERFORM B500-SEND-RESPONSE-MAP 020700 WHEN OTHER 020800 PERFORM B500-SEND-RESPONSE-MAP 020900 WHEN 021000 END-EVALUATE. 021100 021200 B100-EXIT. 021300 EXIT. 021400/**************************************************************** 021500* B200-SEND-TEXT-RESPONSE * 021600* 1. * 021700***************************************************************** 021800 B200-SEND-TEXT-RESPONSE SECTION. 021900 022000 MOVE 'B200-SEND-TEXT-RESPONSE' TO W-SECTION-NAME. 022100 022200 EXEC CICS SEND 022300 FROM (C-MESSAGE-AREA) 022400 LENGTH (LENGTH OF C-MESSAGE-AREA) 022500 NOHANDLE 022600 END-EXEC. 022700 022800 B200-EXIT. 022900 EXIT. 023000/**************************************************************** 023100* B300-SEND-INITIAL-MAP * 023200* 1. * 023300***************************************************************** 023400 B300-SEND-INITIAL-MAP SECTION. 023500 023600 MOVE 'B300-SEND-INITIAL-MAP' TO W-SECTION-NAME. 023700 023800 EXEC CICS SEND 023900 MAP (C-MAP-NAME) 024000 MAPSET (C-MAPSET-NAME) 024100 MAPONLY 024200 NOHANDLE 024300 END-EXEC. 024400 024500 EVALUATE EIBRESP 024600 WHEN DFHRESP(NORMAL) 024700 CONTINUE 024800 WHEN OTHER 024900 PERFORM E100-FORMAT-ERROR-MESSAGE 025000 PERFORM B200-SEND-TEXT-RESPONSE 025100 SET S-EXIT-TRANSACTION TO TRUE 025200 END-EVALUATE. 025300 025400 B300-EXIT. 025500 EXIT. 025600/**************************************************************** 025700* B400-PROCESS-MAP-INPUT * 025800* 1. * 025900***************************************************************** 026000 B400-PROCESS-MAP-INPUT SECTION. 026100 026200 MOVE 'B400-PROCESS-MAP-INPUT' TO W-SECTION-NAME. 026300*???? LOGIC TO PROCESS THE INPUT TO THE MAP GOES HERE 026400 026500 B400-EXIT. 026600 EXIT. 026700/**************************************************************** 026800* B500-SEND-RESPONSE-MAP * 026900* 1. * 027000***************************************************************** 027100 B500-SEND-RESPONSE-MAP SECTION. 027200 027300 MOVE 'B500-SEND-RESPONSE-MAP' TO W-SECTION-NAME. 027400 027500 EXEC CICS SEND 027600 MAP (C-MAP-NAME) 027700 MAPSET (C-MAPSET-NAME) 027800 DATAONLY 027900 NOHANDLE 028000 END-EXEC. 028100 028200 EVALUATE EIBRESP 028300 WHEN DFHRESP(NORMAL) 028400 CONTINUE 028500 WHEN OTHER 028600 PERFORM E100-FORMAT-ERROR-MESSAGE 028700 PERFORM B200-SEND-TEXT-RESPONSE 028800 SET S-EXIT-TRANSACTION TO TRUE 028900 END-EVALUATE. 029000 029100 B500-EXIT. 029200 EXIT. 029300/**************************************************************** 029400* E100-FORMAT-ERROR-MESSAGE * 029500* 1. * 029600***************************************************************** 029700 E100-FORMAT-ERROR-MESSAGE SECTION. 029800 029900* ENTER ERROR MESSAGE FORMATTING LOGIC HERE ????? 030000 030100 E100-EXIT. 030200 EXIT. 030300/**************************************************************** 030400* Z100-FINALIZATION * 030500* 1. * 030600***************************************************************** 030700 Z100-FINALIZATION SECTION. 030800 030900 MOVE 'Z100-FINALIZATION' TO W-SECTION-NAME. 031000 031100 IF S-EXIT-TRANSACTION 031200 EXEC CICS RETURN 031300 END-EXEC 031400 ELSE 031500 EXEC CICS RETURN 031600 TRANSID (C-TRANSACTION-ID) 031700 COMMAREA (W-COMMAREA) 031800 LENGTH (LENGTH OF W-COMMAREA) 031900 END-EXEC 032000 END-IF. 032100 032200 Z100-EXIT. 032300 EXIT. ./ ADD NAME=CSRXTRAC ******************************************************************CSRXTRAC * I D E N T I F I C A T I O N D I V I S I O N *CSRXTRAC ******************************************************************CSRXTRAC IDENTIFICATION DIVISION. CSRXTRAC PROGRAM-ID. CSRXTRAC. CSRXTRAC AUTHOR. DAVE LEIGH. CSRXTRAC DATE-WRITTEN. JULY 5, 1989. CSRXTRAC DATE-COMPILED. CSRXTRAC * COMPOPT: DYNAM CSRXTRAC ******************************************************************CSRXTRAC * PROGRAM NAME: CSRXTRAC *CSRXTRAC * *CSRXTRAC * FUNCTION: THIS PROGRAM EXTRACTS DATA FROM EITHER THE CSRTABL *CSRXTRAC * AND CSRDESC ISPF TABLES OR THE CSRHTABL ISPF TABLE *CSRXTRAC * AND OUTPUTS THEM TO A 2022 BYTE OUTPUT FILE. IT PICKS*CSRXTRAC * THE TABLE(S) TO USE FROM AN INPUT PARM. *CSRXTRAC * *CSRXTRAC * INPUTS: INPUT PARM : EITHER CSRTABL (FOR CSRTABL & CSRDESC) *CSRXTRAC * OR *CSRXTRAC * CSRHTABL (FOR CSRHTABL) *CSRXTRAC * *CSRXTRAC * ISPF TABLES - CSRTABL & CSRDESC *CSRXTRAC * OR *CSRXTRAC * CSRHTABL *CSRXTRAC * *CSRXTRAC * OUTPUTS: 2022 BYPE OUTPUT FLAT FILE. OUTPUT DD NAME IS *CSRXTRAC * CSRTDATA *CSRXTRAC * *CSRXTRAC * EXITS NORMAL: *CSRXTRAC * *CSRXTRAC * EXITS ABNORMAL: *CSRXTRAC * *CSRXTRAC * SWITCHES: NONE *CSRXTRAC * *CSRXTRAC * TABLES: NONE *CSRXTRAC * *CSRXTRAC * COPY MEMBERS: NONE *CSRXTRAC * *CSRXTRAC *--------------------------------------------------------------- *CSRXTRAC * MODIFICATION LOG *CSRXTRAC *--------------------------------------------------------------- *CSRXTRAC * INIT . DATE . COMMENTS *CSRXTRAC *======¬========¬=============================================== *CSRXTRAC ******************************************************************CSRXTRAC /*****************************************************************CSRXTRAC * E N V I R O N M E N T D I V I S I O N *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC ENVIRONMENT DIVISION. CSRXTRAC CSRXTRAC INPUT-OUTPUT SECTION. CSRXTRAC FILE-CONTROL. CSRXTRAC CSRXTRAC SELECT CSR-DATA ASSIGN TO CSRTDATA. CSRXTRAC CSRXTRAC /*****************************************************************CSRXTRAC * D A T A D I V I S I O N *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC DATA DIVISION. CSRXTRAC CSRXTRAC FILE SECTION. CSRXTRAC CSRXTRAC FD CSR-DATA CSRXTRAC LABEL RECORDS ARE STANDARD CSRXTRAC BLOCK CONTAINS 0 RECORDS CSRXTRAC DATA RECORD IS OUT-CSR-DATA-RECORD. CSRXTRAC CSRXTRAC 01 OUT-CSR-DATA-RECORD PIC X(2022). CSRXTRAC CSRXTRAC /*****************************************************************CSRXTRAC * W O R K I N G - S T O R A G E S E C T I O N *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC WORKING-STORAGE SECTION. CSRXTRAC CSRXTRAC 01 WS-START PIC X(48) VALUE CSRXTRAC '**** CSRXTRAC WORKING-STORAGE STARTS HERE ****'. CSRXTRAC CSRXTRAC ******************************************************************CSRXTRAC * A C C U M U L A T O R S *CSRXTRAC ******************************************************************CSRXTRAC 01 A-ACCUMULATORS. CSRXTRAC 05 A-CSRTABL-ROWS-READ PIC 9(07) VALUE ZEROS. CSRXTRAC 05 A-CSRDESC-ROWS-READ PIC 9(07) VALUE ZEROS. CSRXTRAC 05 A-CSRHTABL-ROWS-READ PIC 9(07) VALUE ZEROS. CSRXTRAC 05 A-ISPF-CALLS-MADE PIC 9(07) VALUE ZEROS. CSRXTRAC 05 A-RECORDS-WRITTEN PIC 9(07) VALUE ZEROS. CSRXTRAC CSRXTRAC ******************************************************************CSRXTRAC * C O N S T A N T S *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC 01 C-CONSTANTS. CSRXTRAC 05 C-NORMAL-RETURN-CODE PIC 9(01) VALUE 4. 05 C-CUSSERNO-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-RD-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-RM-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-RY-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-SHRTDESC-LENGTH PIC S9(06) COMP SYNC VALUE +30. 05 C-SUBSYS-LENGTH PIC S9(06) COMP SYNC VALUE +05. 05 C-PRTY-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-CSRTYPE-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-CSRSTAT-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-PGM-LENGTH PIC S9(06) COMP SYNC VALUE +58. 05 C-ESTHRS-LENGTH PIC S9(06) COMP SYNC VALUE +06. 05 C-ACTHRS-LENGTH PIC S9(06) COMP SYNC VALUE +06. 05 C-SE-LENGTH PIC S9(06) COMP SYNC VALUE +11. 05 C-RQSTR-LENGTH PIC S9(06) COMP SYNC VALUE +14. 05 C-SM-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-SD-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-SY-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-UM-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-UD-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-UY-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-EM-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-ED-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-EY-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-IM-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-ID-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-IY-LENGTH PIC S9(06) COMP SYNC VALUE +02. 05 C-S1-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE1-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I1-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S2-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE2-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I2-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S3-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE3-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I3-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S4-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE4-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I4-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S5-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE5-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I5-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S6-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE6-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I6-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S7-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE7-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I7-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S8-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE8-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I8-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S9-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE9-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I9-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S10-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE10-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I10-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S11-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE11-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I11-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-S12-LENGTH PIC S9(06) COMP SYNC VALUE +01. 05 C-DTE12-LENGTH PIC S9(06) COMP SYNC VALUE +08. 05 C-I12-LENGTH PIC S9(06) COMP SYNC VALUE +03. 05 C-DESCR1-LENGTH PIC S9(06) COMP SYNC VALUE +64. 05 C-DESCR2-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR3-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR4-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR5-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR6-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR7-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR8-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR9-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR10-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR11-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR12-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR13-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR14-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR15-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR16-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR17-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR18-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR19-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR20-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR21-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-DESCR22-LENGTH PIC S9(06) COMP SYNC VALUE +77. 05 C-CUSSERNO PIC X(10) VALUE '(CUSSERNO)'. 05 C-RD PIC X(04) VALUE '(RD)'. 05 C-RM PIC X(04) VALUE '(RM)'. 05 C-RY PIC X(04) VALUE '(RY)'. 05 C-SHRTDESC PIC X(10) VALUE '(SHRTDESC)'. 05 C-SUBSYS PIC X(08) VALUE '(SUBSYS)'. 05 C-PRTY PIC X(06) VALUE '(PRTY)'. 05 C-CSRTYPE PIC X(09) VALUE '(CSRTYPE)'. 05 C-CSRSTAT PIC X(09) VALUE '(CSRSTAT)'. 05 C-PGM PIC X(05) VALUE '(PGM)'. 05 C-ESTHRS PIC X(08) VALUE '(ESTHRS)'. 05 C-ACTHRS PIC X(08) VALUE '(ACTHRS)'. 05 C-SE PIC X(04) VALUE '(SE)'. 05 C-RQSTR PIC X(07) VALUE '(RQSTR)'. 05 C-SM PIC X(04) VALUE '(SM)'. 05 C-SD PIC X(04) VALUE '(SD)'. 05 C-SY PIC X(04) VALUE '(SY)'. 05 C-UM PIC X(04) VALUE '(UM)'. 05 C-UD PIC X(04) VALUE '(UD)'. 05 C-UY PIC X(04) VALUE '(UY)'. 05 C-EM PIC X(04) VALUE '(EM)'. 05 C-ED PIC X(04) VALUE '(ED)'. 05 C-EY PIC X(04) VALUE '(EY)'. 05 C-IM PIC X(04) VALUE '(IM)'. 05 C-ID PIC X(04) VALUE '(ID)'. 05 C-IY PIC X(04) VALUE '(IY)'. 05 C-S1 PIC X(04) VALUE '(S1)'. 05 C-DTE1 PIC X(06) VALUE '(DTE1)'. 05 C-I1 PIC X(04) VALUE '(I1)'. 05 C-S2 PIC X(04) VALUE '(S2)'. 05 C-DTE2 PIC X(06) VALUE '(DTE2)'. 05 C-I2 PIC X(04) VALUE '(I2)'. 05 C-S3 PIC X(04) VALUE '(S3)'. 05 C-DTE3 PIC X(06) VALUE '(DTE3)'. 05 C-I3 PIC X(04) VALUE '(I3)'. 05 C-S4 PIC X(04) VALUE '(S4)'. 05 C-DTE4 PIC X(06) VALUE '(DTE4)'. 05 C-I4 PIC X(04) VALUE '(I4)'. 05 C-S5 PIC X(04) VALUE '(S5)'. 05 C-DTE5 PIC X(06) VALUE '(DTE5)'. 05 C-I5 PIC X(04) VALUE '(I5)'. 05 C-S6 PIC X(04) VALUE '(S6)'. 05 C-DTE6 PIC X(06) VALUE '(DTE6)'. 05 C-I6 PIC X(04) VALUE '(I6)'. 05 C-S7 PIC X(04) VALUE '(S7)'. 05 C-DTE7 PIC X(06) VALUE '(DTE7)'. 05 C-I7 PIC X(04) VALUE '(I7)'. 05 C-S8 PIC X(04) VALUE '(S8)'. 05 C-DTE8 PIC X(06) VALUE '(DTE8)'. 05 C-I8 PIC X(04) VALUE '(I8)'. 05 C-S9 PIC X(04) VALUE '(S9)'. 05 C-DTE9 PIC X(06) VALUE '(DTE9)'. 05 C-I9 PIC X(04) VALUE '(I9)'. 05 C-S10 PIC X(05) VALUE '(S10)'. 05 C-DTE10 PIC X(07) VALUE '(DTE10)'. 05 C-I10 PIC X(05) VALUE '(I10)'. 05 C-S11 PIC X(05) VALUE '(S11)'. 05 C-DTE11 PIC X(07) VALUE '(DTE11)'. 05 C-I11 PIC X(05) VALUE '(I11)'. 05 C-S12 PIC X(05) VALUE '(S12)'. 05 C-DTE12 PIC X(07) VALUE '(DTE12)'. 05 C-I12 PIC X(05) VALUE '(I12)'. 05 C-DESCR1 PIC X(08) VALUE '(DESCR1)'. 05 C-DESCR2 PIC X(08) VALUE '(DESCR2)'. 05 C-DESCR3 PIC X(08) VALUE '(DESCR3)'. 05 C-DESCR4 PIC X(08) VALUE '(DESCR4)'. 05 C-DESCR5 PIC X(08) VALUE '(DESCR5)'. 05 C-DESCR6 PIC X(08) VALUE '(DESCR6)'. 05 C-DESCR7 PIC X(08) VALUE '(DESCR7)'. 05 C-DESCR8 PIC X(08) VALUE '(DESCR8)'. 05 C-DESCR9 PIC X(08) VALUE '(DESCR9)'. 05 C-DESCR10 PIC X(09) VALUE '(DESCR10)'. 05 C-DESCR11 PIC X(09) VALUE '(DESCR11)'. 05 C-DESCR12 PIC X(09) VALUE '(DESCR12)'. 05 C-DESCR13 PIC X(09) VALUE '(DESCR13)'. 05 C-DESCR14 PIC X(09) VALUE '(DESCR14)'. 05 C-DESCR15 PIC X(09) VALUE '(DESCR15)'. 05 C-DESCR16 PIC X(09) VALUE '(DESCR16)'. 05 C-DESCR17 PIC X(09) VALUE '(DESCR17)'. 05 C-DESCR18 PIC X(09) VALUE '(DESCR18)'. 05 C-DESCR19 PIC X(09) VALUE '(DESCR19)'. 05 C-DESCR20 PIC X(09) VALUE '(DESCR20)'. 05 C-DESCR21 PIC X(09) VALUE '(DESCR21)'. 05 C-DESCR22 PIC X(09) VALUE '(DESCR22)'. 05 C-NOWRITE PIC X(08) VALUE 'NOWRITE '. CSRXTRAC 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 05 C-TBOPEN PIC X(08) VALUE 'TBOPEN '. 05 C-TBEND PIC X(08) VALUE 'TBEND '. 05 C-TBSKIP PIC X(08) VALUE 'TBSKIP '. 05 C-CHAR PIC X(08) VALUE 'CHAR '. CSRXTRAC 05 C-TBTOP PIC X(08) VALUE 'TBTOP '. CSRXTRAC 05 C-TBGET PIC X(08) VALUE 'TBGET '. CSRXTRAC 05 C-TBVCLEAR PIC X(08) VALUE 'TBVCLEAR'. CSRXTRAC 05 C-CSRTABL PIC X(08) VALUE 'CSRTABL '. CSRXTRAC 05 C-CSRDESC PIC X(08) VALUE 'CSRDESC '. CSRXTRAC 05 C-CSRHTABL PIC X(08) VALUE 'CSRHTABL'. CSRXTRAC CSRXTRAC ******************************************************************CSRXTRAC * S W I T C H E S *CSRXTRAC ******************************************************************CSRXTRAC 01 S-SWITCHES. CSRXTRAC 05 S-CSRTABL-SWITCH PIC X(01) VALUE LOW-VALUES. 88 S-NO-MORE-CSRTABL-ROWS VALUE HIGH-VALUES.CSRXTRAC 88 S-MORE-CSRTABL-ROWS VALUE LOW-VALUES. CSRXTRAC 05 S-CSRDESC-SWITCH PIC X(01) VALUE LOW-VALUES. 88 S-NO-MORE-CSRDESC-ROWS VALUE HIGH-VALUES.CSRXTRAC 88 S-MORE-CSRDESC-ROWS VALUE LOW-VALUES. CSRXTRAC 05 S-CSRHTABL-SWITCH PIC X(01) VALUE LOW-VALUES. 88 S-NO-MORE-CSRHTABL-ROWS VALUE HIGH-VALUES.CSRXTRAC 88 S-MORE-CSRHTABL-ROWS VALUE LOW-VALUES. CSRXTRAC CSRXTRAC ******************************************************************CSRXTRAC * W O R K - A R E A S *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC 01 W-WORK-AREAS. CSRXTRAC 05 W-NORMAL-RETURN-CODE PIC 9(01) VALUE ZERO. 05 W-SAVE-CUSSERNO PIC X(08) VALUE ZERO. 05 W-CSR-RECORD. 10 W-CUSSERNO PIC X(08) VALUE SPACES. 10 W-RECEIVED-DATE. 15 W-RM PIC 9(02) VALUE ZEROS. 15 FILLER PIC X(01) VALUE '/'. 15 W-RD PIC 9(02) VALUE ZEROS. 15 FILLER PIC X(01) VALUE '/'. 15 W-RY PIC 9(02) VALUE ZEROS. 10 W-SHRTDESC PIC X(30) VALUE SPACES. 10 W-SUBSYS PIC X(05) VALUE SPACES. 10 W-PRTY PIC ZZ9 VALUE ZEROS. 10 W-CSRTYPE PIC X(01) VALUE SPACES. 10 W-CSRSTAT PIC X(01) VALUE SPACES. 10 W-PGM PIC X(58) VALUE SPACES. 10 W-ESTHRS PIC ZZ9.99 VALUE ZEROS. 10 W-ACTHRS PIC ZZ9.99 VALUE ZEROS. 10 W-SE PIC X(11) VALUE SPACES. 10 W-RQSTR PIC X(14) VALUE SPACES. 10 W-SM PIC 9(02) VALUE ZEROS. 10 W-SD PIC 9(02) VALUE ZEROS. 10 W-SY PIC 9(02) VALUE ZEROS. 10 W-UM PIC 9(02) VALUE ZEROS. 10 W-UD PIC 9(02) VALUE ZEROS. 10 W-UY PIC 9(02) VALUE ZEROS. 10 W-EM PIC 9(02) VALUE ZEROS. 10 W-ED PIC 9(02) VALUE ZEROS. 10 W-EY PIC 9(02) VALUE ZEROS. 10 W-IM PIC 9(02) VALUE ZEROS. 10 W-ID PIC 9(02) VALUE ZEROS. 10 W-IY PIC 9(02) VALUE ZEROS. 10 W-S1 PIC X(01) VALUE SPACES. 10 W-DTE1 PIC X(08) VALUE SPACES. 10 W-I1 PIC X(03) VALUE SPACES. 10 W-S2 PIC X(01) VALUE SPACES. 10 W-DTE2 PIC X(08) VALUE SPACES. 10 W-I2 PIC X(03) VALUE SPACES. 10 W-S3 PIC X(01) VALUE SPACES. 10 W-DTE3 PIC X(08) VALUE SPACES. 10 W-I3 PIC X(03) VALUE SPACES. 10 W-S4 PIC X(01) VALUE SPACES. 10 W-DTE4 PIC X(08) VALUE SPACES. 10 W-I4 PIC X(03) VALUE SPACES. 10 W-S5 PIC X(01) VALUE SPACES. 10 W-DTE5 PIC X(08) VALUE SPACES. 10 W-I5 PIC X(03) VALUE SPACES. 10 W-S6 PIC X(01) VALUE SPACES. 10 W-DTE6 PIC X(08) VALUE SPACES. 10 W-I6 PIC X(03) VALUE SPACES. 10 W-S7 PIC X(01) VALUE SPACES. 10 W-DTE7 PIC X(08) VALUE SPACES. 10 W-I7 PIC X(03) VALUE SPACES. 10 W-S8 PIC X(01) VALUE SPACES. 10 W-DTE8 PIC X(08) VALUE SPACES. 10 W-I8 PIC X(03) VALUE SPACES. 10 W-S9 PIC X(01) VALUE SPACES. 10 W-DTE9 PIC X(08) VALUE SPACES. 10 W-I9 PIC X(03) VALUE SPACES. 10 W-S10 PIC X(01) VALUE SPACES. 10 W-DTE10 PIC X(08) VALUE SPACES. 10 W-I10 PIC X(03) VALUE SPACES. 10 W-S11 PIC X(01) VALUE SPACES. 10 W-DTE11 PIC X(08) VALUE SPACES. 10 W-I11 PIC X(03) VALUE SPACES. 10 W-S12 PIC X(01) VALUE SPACES. 10 W-DTE12 PIC X(08) VALUE SPACES. 10 W-I12 PIC X(03) VALUE SPACES. 10 W-DESCR1 PIC X(64) VALUE SPACES. 10 FILLER PIC X(01) VALUE SPACES. 10 W-DESCR2 PIC X(77) VALUE SPACES. 10 W-DESCR3 PIC X(77) VALUE SPACES. 10 W-DESCR4 PIC X(77) VALUE SPACES. 10 W-DESCR5 PIC X(77) VALUE SPACES. 10 W-DESCR6 PIC X(77) VALUE SPACES. 10 W-DESCR7 PIC X(77) VALUE SPACES. 10 W-DESCR8 PIC X(77) VALUE SPACES. 10 W-DESCR9 PIC X(77) VALUE SPACES. 10 W-DESCR10 PIC X(77) VALUE SPACES. 10 W-DESCR11 PIC X(77) VALUE SPACES. 10 W-DESCR12 PIC X(77) VALUE SPACES. 10 W-DESCR13 PIC X(77) VALUE SPACES. 10 W-DESCR14 PIC X(77) VALUE SPACES. 10 W-DESCR15 PIC X(77) VALUE SPACES. 10 W-DESCR16 PIC X(77) VALUE SPACES. 10 W-DESCR17 PIC X(77) VALUE SPACES. 10 W-DESCR18 PIC X(77) VALUE SPACES. 10 W-DESCR19 PIC X(77) VALUE SPACES. 10 W-DESCR20 PIC X(77) VALUE SPACES. 10 W-DESCR21 PIC X(77) VALUE SPACES. 10 W-DESCR22 PIC X(77) VALUE SPACES. 10 FILLER PIC X(21) VALUE SPACES. 05 W-RM-WORK PIC X(02) VALUE SPACES. 05 W-RD-WORK PIC X(02) VALUE SPACES. 05 W-RY-WORK PIC X(02) VALUE SPACES. 05 W-PRTY-WORK PIC X(03) VALUE SPACES. 05 W-PRTY-WORK-2 PIC 9(03) VALUE ZEROS. 05 W-ESTHRS-WORK PIC X(06) VALUE SPACES. 05 W-ACTHRS-WORK PIC X(06) VALUE SPACES. 05 W-SM-WORK PIC X(02) VALUE SPACES. 05 W-SD-WORK PIC X(02) VALUE SPACES. 05 W-SY-WORK PIC X(02) VALUE SPACES. 05 W-UM-WORK PIC X(02) VALUE SPACES. 05 W-UD-WORK PIC X(02) VALUE SPACES. 05 W-UY-WORK PIC X(02) VALUE SPACES. 05 W-EM-WORK PIC X(02) VALUE SPACES. 05 W-ED-WORK PIC X(02) VALUE SPACES. 05 W-EY-WORK PIC X(02) VALUE SPACES. 05 W-IM-WORK PIC X(02) VALUE SPACES. 05 W-ID-WORK PIC X(02) VALUE SPACES. 05 W-IY-WORK PIC X(02) VALUE SPACES. 05 W-ESTHRS-WORK-2. 10 W-ESTHRS-NUMBER PIC 9(03) VALUE ZEROS. 10 W-ESTHRS-DECIMAL PIC X(02) VALUE SPACES. 05 W-ESTHRS-WORK-3 REDEFINES W-ESTHRS-WORK-2 PIC 999V99. 05 W-ACTHRS-WORK-2. 10 W-ACTHRS-NUMBER PIC 9(03) VALUE ZEROS. 10 W-ACTHRS-DECIMAL PIC X(02) VALUE SPACES. 05 W-ACTHRS-WORK-3 REDEFINES W-ACTHRS-WORK-2 PIC 999V99. 05 W-DISPLAY-RETURN-CODE PIC 9(08) VALUE ZEROS. 05 W-ISPF-CALL PIC 9(02) VALUE ZEROS. ******************************************************************CSRXTRAC * T A B L E S *CSRXTRAC ******************************************************************CSRXTRAC * NO TABLES CSRXTRAC 01 WS-END PIC X(48) VALUE CSRXTRAC '**** CSRXTRAC WORKING-STORAGE ENDS HERE ****'. CSRXTRAC ******************************************************************CSRXTRAC * L I N K A G E *CSRXTRAC ******************************************************************CSRXTRAC LINKAGE SECTION. CSRPRG01 01 L-PARM-AREA. CSRPRG01 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. CSRPRG01 05 L-PARM PIC X(08). CSRPRG01 PROCEDURE DIVISION USING L-PARM-AREA. CSRPRG01 ******************************************************************CSRXTRAC * P R O C E D U R E D I V I S I O N *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC /*****************************************************************CSRXTRAC * S0000-DRIVER *CSRXTRAC * PERFORMED BY: *CSRXTRAC * FUNCTIONS: THIS ROUTINE CONTROLS THE WHOLE PROGRAM. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S0000-DRIVER SECTION. CSRXTRAC CSRXTRAC PERFORM S1000-INITIALIZATION. CSRXTRAC CSRXTRAC IF L-PARM = C-CSRTABL PERFORM S2000-MAINLINE UNTIL CSRX S-NO-MORE-CSRTABL-ROWS ELSE IF L-PARM = C-CSRHTABL PERFORM S3000-MAINLINE UNTIL S-NO-MORE-CSRHTABL-ROWS ELSE DISPLAY '*** INVALID PARM : ' L-PARM ' *** NO PROCESSING PERFORMED ***'. CSRXTRAC PERFORM S9000-FINALIZATION. CSRXTRAC CSRXTRAC S0000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S1000-INITIALIZATION *CSRXTRAC * PERFORMED BY: S0000-CONTROL *CSRXTRAC * FUNCTIONS: THIS ROUTINE OPENS THE OUTPUT FILE, "VDEFINES" *CSRXTRAC * ALL THE VARIABLES, OPENS THE NECESSARY TABLE(S), *CSRXTRAC * AND PERFORMS THE PRIMING TABLE ACCESS. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S1000-INITIALIZATION SECTION. CSRXTRAC CSRXTRAC OPEN OUTPUT CSR-DATA. CSRXTRAC CSRXTRAC MOVE C-NORMAL-RETURN-CODE TO W-NORMAL-RETURN-CODE. CSRXTRAC CSRXTRAC ADD 1 TO A-ISPF-CALLS-MADE. MOVE 1 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-CUSSERNO W-CUSSERNO C-CHAR C-CUSSERNO-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 2 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-RD W-RD-WORK C-CHAR C-RD-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 3 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-RM W-RM-WORK C-CHAR C-RM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 4 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-RY W-RY-WORK C-CHAR C-RY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 5 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SHRTDESC W-SHRTDESC C-CHAR C-SHRTDESC-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 6 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SUBSYS W-SUBSYS C-CHAR C-SUBSYS-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 7 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-PRTY W-PRTY-WORK C-CHAR C-PRTY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 8 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-CSRTYPE W-CSRTYPE C-CHAR C-CSRTYPE-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 9 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-CSRSTAT W-CSRSTAT C-CHAR C-CSRSTAT-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 10 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-PGM W-PGM C-CHAR C-PGM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 11 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-ESTHRS W-ESTHRS-WORK C-CHAR C-ESTHRS-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 12 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-ACTHRS W-ACTHRS-WORK C-CHAR C-ACTHRS-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 13 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SE W-SE C-CHAR C-SE-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 14 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-RQSTR W-RQSTR C-CHAR C-RQSTR-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 15 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SM W-SM-WORK C-CHAR C-SM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 16 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SD W-SD-WORK C-CHAR C-SD-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 17 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-SY W-SY-WORK C-CHAR C-SY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 18 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-UM W-UM-WORK C-CHAR C-UM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 19 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-UD W-UD-WORK C-CHAR C-UD-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 20 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-UY W-UY-WORK C-CHAR C-UY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 21 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-EM W-EM-WORK C-CHAR C-EM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 22 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-ED W-ED-WORK C-CHAR C-ED-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 23 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-EY W-EY-WORK C-CHAR C-EY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 24 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-IM W-IM-WORK C-CHAR C-IM-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 25 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-ID W-ID-WORK C-CHAR C-ID-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 26 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-IY W-IY-WORK C-CHAR C-IY-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 27 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S1 W-S1 C-CHAR C-S1-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 28 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE1 W-DTE1 C-CHAR C-DTE1-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 29 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I1 W-I1 C-CHAR C-I1-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 30 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S2 W-S2 C-CHAR C-S2-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 31 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE2 W-DTE2 C-CHAR C-DTE2-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 32 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I2 W-I2 C-CHAR C-I2-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 33 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S3 W-S3 C-CHAR C-S3-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 34 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE3 W-DTE3 C-CHAR C-DTE3-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 35 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I3 W-I3 C-CHAR C-I3-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 36 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S4 W-S4 C-CHAR C-S4-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 37 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE4 W-DTE4 C-CHAR C-DTE4-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 38 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I4 W-I4 C-CHAR C-I4-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 39 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S5 W-S5 C-CHAR C-S5-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 40 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE5 W-DTE5 C-CHAR C-DTE5-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 41 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I5 W-I5 C-CHAR C-I5-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 42 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S6 W-S6 C-CHAR C-S6-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 43 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE6 W-DTE6 C-CHAR C-DTE6-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 44 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I6 W-I6 C-CHAR C-I6-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 45 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S7 W-S7 C-CHAR C-S7-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 46 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE7 W-DTE7 C-CHAR C-DTE7-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 47 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I7 W-I7 C-CHAR C-I7-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 48 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S8 W-S8 C-CHAR C-S8-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 49 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE8 W-DTE8 C-CHAR C-DTE8-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 50 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I8 W-I8 C-CHAR C-I8-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 51 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S9 W-S9 C-CHAR C-S9-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 52 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE9 W-DTE9 C-CHAR C-DTE9-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 53 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I9 W-I9 C-CHAR C-I9-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 54 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S10 W-S10 C-CHAR C-S10-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 55 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE10 W-DTE10 C-CHAR C-DTE10-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 56 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I10 W-I10 C-CHAR C-I10-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 57 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S11 W-S11 C-CHAR C-S11-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 58 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE11 W-DTE11 C-CHAR C-DTE11-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 59 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I11 W-I11 C-CHAR C-I11-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 60 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-S12 W-S12 C-CHAR C-S12-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 61 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DTE12 W-DTE12 C-CHAR C-DTE12-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 62 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-I12 W-I12 C-CHAR C-I12-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 63 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR1 W-DESCR1 C-CHAR C-DESCR1-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 64 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR2 W-DESCR2 C-CHAR C-DESCR2-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 65 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR3 W-DESCR3 C-CHAR C-DESCR3-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 66 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR4 W-DESCR4 C-CHAR C-DESCR4-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 67 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR5 W-DESCR5 C-CHAR C-DESCR5-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 68 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR6 W-DESCR6 C-CHAR C-DESCR6-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 69 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR7 W-DESCR7 C-CHAR C-DESCR7-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 70 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR8 W-DESCR8 C-CHAR C-DESCR8-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 71 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR9 W-DESCR9 C-CHAR C-DESCR9-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 72 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR10 W-DESCR10 C-CHAR C-DESCR10-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 73 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR11 W-DESCR11 C-CHAR C-DESCR11-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 74 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR12 W-DESCR12 C-CHAR C-DESCR12-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 75 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR13 W-DESCR13 C-CHAR C-DESCR13-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 76 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR14 W-DESCR14 C-CHAR C-DESCR14-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 77 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR15 W-DESCR15 C-CHAR C-DESCR15-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 78 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR16 W-DESCR16 C-CHAR C-DESCR16-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 79 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR17 W-DESCR17 C-CHAR C-DESCR17-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 80 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR18 W-DESCR18 C-CHAR C-DESCR18-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 81 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR19 W-DESCR19 C-CHAR C-DESCR19-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 82 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR20 W-DESCR20 C-CHAR C-DESCR20-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 83 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR21 W-DESCR21 C-CHAR C-DESCR21-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 84 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DESCR22 W-DESCR22 C-CHAR C-DESCR22-LENGTH PERFORM S5000-ISPF-RETURN-CODE-CHECK. IF L-PARM = C-CSRTABL ADD 1 TO A-ISPF-CALLS-MADE MOVE 85 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBOPEN C-CSRTABL P C-NOWRITE P PERFORM S5000-ISPF-RETURN-CODE-CHECK ADD 1 TO A-ISPF-CALLS-MADE MOVE 86 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBTOP C-CSRTABL P PERFORM S5000-ISPF-RETURN-CODE-CHECK PERFORM S4000-GET-CSRTABL-ROW ADD 1 TO A-ISPF-CALLS-MADE MOVE 87 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBOPEN C-CSRDESC P C-NOWRITE P PERFORM S5000-ISPF-RETURN-CODE-CHECK PERFORM S4100-GET-CSRDESC-ROW ELSE ADD 1 TO A-ISPF-CALLS-MADE MOVE 88 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBOPEN C-CSRHTABL P C-NOWRITE P PERFORM S5000-ISPF-RETURN-CODE-CHECK PERFORM S4200-GET-CSRHTABL-ROW. CSRXTRAC S1000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S2000-MAINLINE *CSRXTRAC * PERFORMED BY: S0000-CONTROL *CSRXTRAC * FUNCTIONS: THIS ROUTINE TAKES DATA FROM THE CSRTABL AND *CSRXTRAC * CSRDESC TABLES AND WRITES IT OUT. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S2000-MAINLINE SECTION. CSRXTRAC CSRXTRAC PERFORM S2200-ADJUST-DATA. CSRXTRAC CSRXTRAC PERFORM S2100-WRITE-RECORD. CSRXTRAC CSRXTRAC PERFORM S4000-GET-CSRTABL-ROW. CSRXTRAC CSRXTRAC PERFORM S4100-GET-CSRDESC-ROW. CSRXTRAC CSRXTRAC S2000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S2100-WRITE-RECORD *CSRXTRAC * PERFORMED BY: S2000, S3000 *CSRXTRAC * FUNCTIONS: THIS ROUTINE WRITES OUT THE RECORD FROM THE WORK *CSRXTRAC * AREA RECORD LAYOUT. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S2100-WRITE-RECORD SECTION. CSRXTRAC CSRXTRAC WRITE OUT-CSR-DATA-RECORD FROM W-CSR-RECORD. CSRXTRAC ADD 1 TO A-RECORDS-WRITTEN. CSRXTRAC S2100-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S2200-ADJUST-DATA *CSRXTRAC * PERFORMED BY: S2000, S3000 *CSRXTRAC * FUNCTIONS: THIS ROUTINE ADJUSTS THE NUMERIC DATA CURRENTLY *CSRXTRAC * IN CHARACTER FORMAT INTO NUMERIC EDITED FORMAT. *CSRXTRAC * IT ALSO PERFORMS THE CSR STATUS CODE CONVERSION. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S2200-ADJUST-DATA SECTION. CSRXTRAC CSRXTRAC IF W-CSRSTAT = 'V' MOVE '0' TO W-CSRSTAT. IF W-CSRSTAT = 'Q' MOVE '1' TO W-CSRSTAT. IF W-CSRSTAT = 'A' MOVE '2' TO W-CSRSTAT. IF W-CSRSTAT = 'D' MOVE '3' TO W-CSRSTAT. IF W-CSRSTAT = 'U' MOVE '4' TO W-CSRSTAT. IF W-CSRSTAT = 'P' MOVE '5' TO W-CSRSTAT. IF W-CSRSTAT = 'F' MOVE '6' TO W-CSRSTAT. IF W-CSRSTAT = 'C' MOVE '7' TO W-CSRSTAT. IF W-CSRSTAT = 'I' MOVE '8' TO W-CSRSTAT. IF W-CSRSTAT = 'X' MOVE '9' TO W-CSRSTAT. CSRXTRAC MOVE ZEROS TO W-ESTHRS-NUMBER CSRXTRAC W-ESTHRS-DECIMAL CSRXTRAC W-ACTHRS-NUMBER CSRXTRAC W-ACTHRS-DECIMAL. CSRXTRAC UNSTRING W-ESTHRS-WORK DELIMITED BY '.' OR SPACE INTO W-ESTHRS-NUMBER CSRXTRAC W-ESTHRS-DECIMAL. CSRXTRAC CSRXTRAC UNSTRING W-ACTHRS-WORK DELIMITED BY '.' OR SPACE INTO W-ACTHRS-NUMBER CSRXTRAC W-ACTHRS-DECIMAL. CSRXTRAC CSRXTRAC MOVE W-ESTHRS-WORK-3 TO W-ESTHRS. MOVE W-ACTHRS-WORK-3 TO W-ACTHRS. UNSTRING W-RM-WORK DELIMITED BY SPACES INTO W-RM. UNSTRING W-RD-WORK DELIMITED BY SPACES INTO W-RD. UNSTRING W-RY-WORK DELIMITED BY SPACES INTO W-RY. UNSTRING W-PRTY-WORK DELIMITED BY SPACES INTO W-PRTY-WORK-2. MOVE W-PRTY-WORK-2 TO W-PRTY. UNSTRING W-SM-WORK DELIMITED BY SPACES INTO W-SM. UNSTRING W-SD-WORK DELIMITED BY SPACES INTO W-SD. UNSTRING W-SY-WORK DELIMITED BY SPACES INTO W-SY. UNSTRING W-UM-WORK DELIMITED BY SPACES INTO W-UM. UNSTRING W-UD-WORK DELIMITED BY SPACES INTO W-UD. UNSTRING W-UY-WORK DELIMITED BY SPACES INTO W-UY. UNSTRING W-EM-WORK DELIMITED BY SPACES INTO W-EM. UNSTRING W-ED-WORK DELIMITED BY SPACES INTO W-ED. UNSTRING W-EY-WORK DELIMITED BY SPACES INTO W-EY. UNSTRING W-IM-WORK DELIMITED BY SPACES INTO W-IM. UNSTRING W-ID-WORK DELIMITED BY SPACES INTO W-ID. UNSTRING W-IY-WORK DELIMITED BY SPACES INTO W-IY. CSRXTRAC S2200-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S3000-MAINLINE *CSRXTRAC * PERFORMED BY: S0000-CONTROL *CSRXTRAC * FUNCTIONS: THIS ROUTINE TAKES DATA FROM THE CSRHTABL TABLE *CSRXTRAC * AND WRITES IT OUT. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S3000-MAINLINE SECTION. CSRXTRAC CSRXTRAC PERFORM S2200-ADJUST-DATA. CSRXTRAC CSRXTRAC PERFORM S2100-WRITE-RECORD. CSRXTRAC CSRXTRAC PERFORM S4200-GET-CSRHTABL-ROW. CSRXTRAC CSRXTRAC S3000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S4000-GET-CSRTABL-ROW *CSRXTRAC * PERFORMED BY: S1000, S2000 *CSRXTRAC * FUNCTIONS: THIS ROUTINE READS THE NEXT ROW FROM THE CSRTABL.*CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S4000-GET-CSRTABL-ROW SECTION. CSRXTRAC CSRXTRAC ADD 1 TO A-ISPF-CALLS-MADE. MOVE 89 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-TBVCLEAR C-CSRTABL PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC ADD 1 TO A-ISPF-CALLS-MADE. MOVE 90 TO W-ISPF-CALL. MOVE 8 TO W-NORMAL-RETURN-CODE. CALL 'ISPLINK' USING C-TBSKIP C-CSRTABL PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC IF RETURN-CODE = 8 MOVE HIGH-VALUES TO S-CSRTABL-SWITCH ELSE ADD 1 TO A-CSRTABL-ROWS-READ. CSRXTRAC S4000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S4100-GET-CSRDESC-ROW *CSRXTRAC * PERFORMED BY: S1000, S2000 *CSRXTRAC * FUNCTIONS: THIS ROUTINE READS THE NEXT ROW FROM THE CSRDESC.*CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S4100-GET-CSRDESC-ROW SECTION. CSRXTRAC CSRXTRAC MOVE W-CUSSERNO TO W-SAVE-CUSSERNO. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 91 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-TBVCLEAR C-CSRDESC PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC MOVE W-SAVE-CUSSERNO TO W-CUSSERNO. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 92 TO W-ISPF-CALL. MOVE 8 TO W-NORMAL-RETURN-CODE. CALL 'ISPLINK' USING C-TBGET C-CSRDESC PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC IF RETURN-CODE = 0 ADD 1 TO A-CSRDESC-ROWS-READ ELSE NEXT SENTENCE. CSRXTRAC S4100-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S4200-GET-CSRHTABL-ROW *CSRXTRAC * PERFORMED BY: S1000, S3000 *CSRXTRAC * FUNCTIONS: THIS ROUTINE READS THE NEXT ROW FROM THE CSRHTABL*CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S4200-GET-CSRHTABL-ROW SECTION. CSRXTRAC CSRXTRAC ADD 1 TO A-ISPF-CALLS-MADE. MOVE 93 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-TBVCLEAR C-CSRHTABL PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC ADD 1 TO A-ISPF-CALLS-MADE. MOVE 94 TO W-ISPF-CALL. MOVE 8 TO W-NORMAL-RETURN-CODE. CALL 'ISPLINK' USING C-TBSKIP C-CSRHTABL PERFORM S5000-ISPF-RETURN-CODE-CHECK. CSRXTRAC IF RETURN-CODE = 8 MOVE HIGH-VALUES TO S-CSRHTABL-SWITCH ELSE ADD 1 TO A-CSRHTABL-ROWS-READ. CSRXTRAC S4200-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S5000-ISPF-RETURN-CODE-CHECK *CSRXTRAC * PERFORMED BY: S1000-INITIALIZATION *CSRXTRAC * FUNCTIONS: THIS ROUTINE CHECKS THE RETURN CODE FROM ANY *CSRXTRAC * CALL TO ISPF AND DISPLAYS ABEND MESSAGES IF ANY. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S5000-ISPF-RETURN-CODE-CHECK SECTION. CSRXTRAC CSRXTRAC IF RETURN-CODE > W-NORMAL-RETURN-CODE CSRXTRAC MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' CSRXTRAC DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' CSRXTRAC DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************' CSRXTRAC PERFORM S9000-FINALIZATION ELSE CSRXTRAC MOVE C-NORMAL-RETURN-CODE TO W-NORMAL-RETURN-CODE. CSRXTRAC CSRXTRAC S5000-EXIT. CSRXTRAC EXIT. CSRXTRAC /*****************************************************************CSRXTRAC * S9000-FINALIZATION *CSRXTRAC * PERFORMED BY: S0000-CONTROL *CSRXTRAC * FUNCTIONS: THIS ROUTINE CLOSES FILES AND ISPF TABLES. *CSRXTRAC ******************************************************************CSRXTRAC CSRXTRAC S9000-FINALIZATION SECTION. CSRXTRAC CSRXTRAC CLOSE CSR-DATA. CSRXTRAC CSRXTRAC IF L-PARM = C-CSRTABL ADD 1 TO A-ISPF-CALLS-MADE MOVE 95 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBEND C-CSRTABL IF RETURN-CODE > 0 MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************* ISPF ABEND **************' DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '***************************************' ADD 1 TO A-ISPF-CALLS-MADE MOVE 96 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBEND C-CSRDESC IF RETURN-CODE > 0 MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '*********** ISPF ABEND ************' DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '***********************************' ELSE NEXT SENTENCE ELSE ADD 1 TO A-ISPF-CALLS-MADE MOVE 97 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBEND C-CSRDESC IF RETURN-CODE > 0 MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '*********** ISPF ABEND ************' DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '***********************************' ELSE NEXT SENTENCE ELSE IF L-PARM = C-CSRHTABL ADD 1 TO A-ISPF-CALLS-MADE MOVE 98 TO W-ISPF-CALL CALL 'ISPLINK' USING C-TBEND C-CSRHTABL IF RETURN-CODE > 0 MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '*********** ISPF ABEND ************' DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '***********************************' ELSE NEXT SENTENCE ELSE NEXT SENTENCE. CSRXTRAC GOBACK. CSRXTRAC CSRXTRAC S9000-EXIT. CSRXTRAC EXIT. CSRXTRAC ./ ADD NAME=DATEUTIL 000100 IDENTIFICATION DIVISION. DATEUTIL 000200 PROGRAM-ID. DATEUTIL. DATEUTIL 000300 AUTHOR. DAVID LEIGH DATEUTIL 000400 DATE-COMPILED. DATEUTIL 000500***************************************************************** DATEUTIL 000600* "DATEUTIL" IS A GENERIC DATE UTILITY. AS A COBOL2 PROGRAM, * DATEUTIL 000700* IT IS CALLABLE FROM OTHER COBOL2 PROGRAMS IN EITHER BATCH OR * DATEUTIL 000800* CICS. IT ALSO HAS AN ISPF COMPONENT WHICH ALLOWS IT TO BE * DATEUTIL 000900* CALLED FROM AN ISPF DIALOG (CLIST, REXX, OR PROGRAM) AND TO * DATEUTIL 001000* PASS PARAMETERS IN ISPF SHARED POOL VARIABLES. * DATEUTIL 001100* * DATEUTIL 001200* DATEUTIL USES A COPYBOOK BY THE SAME NAME TO CONVERSE WITH * DATEUTIL 001300* OTHER COBOL PROGRAMS. PARAMETERS ARE PLACED IN THE DATEUTIL * DATEUTIL 001400* COPYBOOK, DATEUTIL IS CALLED, AND DATEUTIL RETURNS THE RESULTS* DATEUTIL 001500* INTO THE DATEUTIL COPYBOOK. * DATEUTIL 001600***************************************************************** DATEUTIL 001700* THE COPYBOOK FORMAT IS AS FOLLOWS: * DATEUTIL 001800* * DATEUTIL 001900* 05 DATEUTIL-MESSAGE PIC X(130). * DQF20115 002000* 05 DATEUTIL-WORK-AREA REDEFINES DATEUTIL-MESSAGE. * DATEUTIL 002100* 10 DU-FUNCTION PIC X(10). * DATEUTIL 002200* 10 DU-NUMBER PIC 9(08). * DQF20115 002300* 10 DU-DATE-1 PIC X(20). * DATEUTIL 002400* 10 DU-DAY-1-FORMAT PIC X(03). * DATEUTIL 002500* 10 DU-MONTH-1-FORMAT PIC X(05). * DATEUTIL 002600* 10 DU-YEAR-1-FORMAT PIC X(04). * DATEUTIL 002700* 10 DU-YEAR-1-SWITCH PIC X(02). * DQF20115 002800* 10 DU-YEAR-1-SWITCH-NUM REDEFINES * DQF20115 002900* DU-YEAR-1-SWITCH PIC 9(02). * DQF20115 003000* 10 DU-DATE-1-FORMAT-CODE PIC 9(02). * DQF20115 003100* 88 DU-DATE-1-VALID-CODE VALUES 01 THRU 54. * DQF20115 003200* 10 DU-DATE-1-FORMAT-CODE-A REDEFINES * DQF20115 003300* DU-DATE-1-FORMAT-CODE PIC X(02). * DQF20115 002700* 10 DU-DATE-1-FORMAT PIC X(20). * DATEUTIL 002800* 10 DU-DATE-2 PIC X(20). * DATEUTIL 002900* 10 DU-DAY-2-FORMAT PIC X(03). * DATEUTIL 003000* 10 DU-MONTH-2-FORMAT PIC X(05). * DATEUTIL 003100* 10 DU-YEAR-2-FORMAT PIC X(04). * DATEUTIL 003900* 10 DU-YEAR-2-SWITCH PIC X(02). * DQF20115 004000* 10 DU-YEAR-2-SWITCH-NUM REDEFINES * DQF20115 004100* DU-YEAR-2-SWITCH PIC 9(02). * DQF20115 004200* 10 DU-DATE-2-FORMAT-CODE PIC 9(02). * DQF20115 004300* 88 DU-DATE-2-VALID-CODE VALUES 01 THRU 54. * DQF20115 004400* 10 DU-DATE-2-FORMAT-CODE-A REDEFINES * DQF20115 004500* DU-DATE-2-FORMAT-CODE PIC X(02). * DQF20115 003200* 10 DU-DATE-2-FORMAT PIC X(20). * DATEUTIL 003300***************************************************************** DATEUTIL 003400* THE INDIVIDUAL DATA ELEMENTS ARE USED AS FOLLOWS: * DATEUTIL 003500* * DATEUTIL 003600* DU-FUNCTION - THE DATE FUNCTION YOU WANT TO PERFORM * DATEUTIL 003700* SHOULD BE PLACED HERE. THE VALID * DATEUTIL 003800* ISPF: DUFUNC FUNCTIONS ARE: * DATEUTIL 003900* * DATEUTIL 004000* CONVERT - CONVERT THE INPUT DATE TO THE * DATEUTIL 004100* DATE-2 FORMAT AND PLACE THE * DATEUTIL 004200* RESULT IN DU-DATE-2. * DATEUTIL 004300* SYSTEM - RETURN THE SYSTEM DATE IN THE * DATEUTIL 004400* DATE-2 FORMAT IN THE FIELD * DATEUTIL 004500* NAMED DU-DATE-2. * DATEUTIL 004600* BETWEEN - CALCULATE THE NUMBER OF DAYS * DATEUTIL 004700* (ACTUAL CALENDAR DAYS) BETWEEN* DATEUTIL 004800* THE DATE IN DU-DATE-1 AND * DATEUTIL 004900* DU-DATE-2. EITHER DATE CAN BE* DATEUTIL 005000* "LARGER". * DATEUTIL 005100* INCREMENT - INCREMENT THE DATE IN * DATEUTIL 005200* DU-DATE-1 BY THE NUMBER IN * DATEUTIL 005300* DU-NUMBER AND PLACE THE RESULT* DATEUTIL 005400* IN DU-DATE-2 IN THE FORMAT * DATEUTIL 005500* SPECIFIED BY THE DATE-2 * DATEUTIL 005600* FORMAT. * DATEUTIL 005700* DECREMENT - DECREMENT THE DATE IN * DATEUTIL 005800* DU-DATE-1 BY THE NUMBER IN * DATEUTIL 005900* DU-NUMBER AND PLACE THE RESULT* DATEUTIL 006000* IN DU-DATE-2 IN THE FORMAT * DATEUTIL 006100* SPECIFIED BY THE DATE-2 * DATEUTIL 006200* FORMAT. * DATEUTIL 006300* * DATEUTIL 006400* IF THE FUNCTION IS LEFT BLANK AND * DATEUTIL 006500* DU-DATE-2 IS BLANK, THE FUNCTION THAT WILL* DATEUTIL 006600* BE EXECUTED IS "CONVERT". IF THE FUNCTION* DATEUTIL 006700* IS LEFT BLANK BUT DU-DATE-2 HAS A DATE IN * DATEUTIL 006800* IT, THE FUNCTION THAT WILL BE EXECUTED IS * DATEUTIL 006900* "BETWEEN". * DATEUTIL 007000* * DATEUTIL 007100* DU-NUMBER - THIS FIELD IS AN UN-SIGNED DISPLAY NUMERIC* DATEUTIL 007200* FIELD WHICH IS USED IN ONE OF TWO WAYS. * DATEUTIL 007300* ISPF: DUNUMBER IF THE FUNCTION IS "BETWEEN", DU-NUMBER * DATEUTIL 007400* WILL CONTAIN THE NUMBER OF DAYS WHICH WERE* DATEUTIL 007500* CALCULATED TO HAVE BEEN BEWTEEN DATE 1 AND* DATEUTIL 007600* DATE 2. IF THE FUNCTION IS "INCREMENT" OR* DATEUTIL 007700* "DECREMENT", DU-NUMBER MUST CONTAIN THE * DATEUTIL 007800* NUMBER OF DAYS BY WHICH DU-DATE-1 MUST BE * DATEUTIL 007900* INCREMENTED OR DECREMENTED. * DATEUTIL 008000* * DATEUTIL 008100* DU-DATE-1 - THIS FIELD CONTAINS THE INPUT TO THE * DATEUTIL 008200* "CONVERT", "INCREMENT" AND "DECREMENT" * DATEUTIL 008300* ISPF: DUDATE1 FUNCTIONS. IT CONTAINS ONE HALF OF THE * DATEUTIL 008400* INPUT DATES FOR THE "BETWEEN" FUNCTION. * DATEUTIL 008500* IF THIS FIELD IS LEFT BLANK, THE SYSTEM * DATEUTIL 008600* DATE WILL BE SUBSTITUTED FOR IT, AND ALL * DATEUTIL 008700* ALL REMAINING PROCESSING WILL OCCUR AS IF * DATEUTIL 008800* A JULIAN DATE THAT HAPPENS TO BE "TODAY" * DATEUTIL 008900* HAD BEEN ENTERED IN DU-DATE-1. * DATEUTIL 009000* * DATEUTIL 009100* DU-DAY-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 009200* THE "DAY" PORTION OF DU-DATE-1. THE * DATEUTIL 009300* ISPF: DUDY1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 009400* * DATEUTIL 009500* DD - THE 2 DIGIT DAY OF THE MONTH * DATEUTIL 009600* ZD - THE 2 DIGIT DAY OF THE MONTH WITH * DATEUTIL 009700* LEADING ZEROS SUPPRESSED * DATEUTIL 009800* DDD - THE 3 DIGIT DAY OF THE YEAR * DATEUTIL 009900* ZZD - THE 3 DIGIT DAY OF THE YEAR WITH * DATEUTIL 010000* LEADING ZEROS SUPPRESSED * DATEUTIL 010100* * DATEUTIL 010200* IF THE FUNCTION IS "SYSTEM" OR DU-DATE-1 * DATEUTIL 010300* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 010400* THIS FIELD NEED NOT BE SPECIFIED. * DATEUTIL 010500* * DATEUTIL 010600* DU-MONTH-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 010700* THE "MONTH" PORTION OF DU-DATE-1. THE * DATEUTIL 010800* ISPF: DUMO1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 010900* * DATEUTIL 011000* MM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 011100* ZM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 011200* (ZERO SUPPRESSED) * DATEUTIL 011300* MMM - THE 3 LETTER MONTH ABBREVIATION * DATEUTIL 011400* MONTH - THE FULL MONTH NAME * DATEUTIL 011500* * DATEUTIL 011600* IF THE FUNCTION IS "SYSTEM", OR DU-DATE-1 * DATEUTIL 011700* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 011800* OR DU-DATE-1 IS A JULIAN DATE, THIS FIELD * DATEUTIL 011900* NEED NOT BE SPECIFIED. * DATEUTIL 012000* * DATEUTIL 012100* DU-YEAR-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 012200* THE "YEAR" PORTION OF DU-DATE-1. THE * DATEUTIL 012300* ISPF: DUYR1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 012400* * DATEUTIL 012500* YY - THE 2 DIGIT DECADE OF THE CENTURY * DATEUTIL 012600* YYYY - THE FULL FOUR DIGIT YEAR * DATEUTIL 012700* * DATEUTIL 012800* IF THE FUNCTION IS "SYSTEM" OR DU-DATE-1 * DATEUTIL 012900* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 013000* THIS FIELD NEED NOT BE SPECIFIED. IF THE * DATEUTIL 013100* FORMAT IS "YY", "19" WILL ALWAYS BE * DATEUTIL 013200* ASSUMED TO BE THE CENTURY AND WILL BE * DATEUTIL 013300* USED IN ALL SUBSEQUENT PROCESSING * DATEUTIL 013400* THROUGHOUT THAT EXECUTION OF THE PROGRAM. * DATEUTIL 013500* * DATEUTIL 015000* DU-YEAR-1-SWITCH - THIS FIELD LETS YOU OVERRIDE THE YEAR * DQF20115 015100* WHICH IS USED TO DETERMINE WHETHER A 2 * DQF20115 015200* ISPF: DUYR1SWT DIGIT YEAR FALLS IN THE CENTURY "19" OR * DQF20115 015300* "20". THE DEFAULT FOR THE PROGRAM IS 50. * DQF20115 015400* CONSEQUENTLY, YOU WOULD MOVE "YY" TO * DQF20115 015500* DU-YEAR-1-FORMAT (OR PICK ONE OF THE 2 * DQF20115 015600* DIGIT YEAR FORMAT CODES) AND THEN MOVE * DQF20115 015700* YOUR "SWITCH YEAR", (E.G. "60") TO * DQF20115 015800* DU-YEAR-1-SWITCH. THEN, WHEN THE PROGRAM * DQF20115 015900* ENCOUNTERS YOUR TWO DIGIT YEAR, AND THE * DQF20115 016000* YEAR IS LESS THAN 60, THEN "20" WILL BE * DQF20115 016100* USED FOR THE CENTURY. OTHERWISE "19" * DQF20115 016200* WILL BE USED. * DQF20115 016300* * DQF20115 013600* DU-DATE-1-FORMAT - THIS FIELD DESCRIBES HOW THE "DAY", * DATEUTIL 013700* "MONTH", AND "YEAR" COMPONENTS ARE * DATEUTIL 013800* ISPF: DUDT1FMT ARRANGED IN DU-DATE-1 SO THAT THE PROGRAM * DATEUTIL 013900* CAN PROPERLY PARSE THE INPUT DATE FOR USE * DATEUTIL 014000* IN FURTHER PROGRAM PROCESSING. THE * DATEUTIL 014100* LETTERS "Y", "M", AND "D" ARE USED TO * DATEUTIL 014200* REPRESENT THE YEAR, MONTH, AND DAY * DATEUTIL 014300* COMPONENTS. EXAMPLES AND FURTHER * DATEUTIL 014400* EXPLANATION OF HOW THE DAY-FORMAT, * DATEUTIL 014500* MONTH-FORMAT, YEAR-FORMAT, AND * DATEUTIL 014600* DATE-FORMAT COMPONENTS WORK TOGETHER IS * DATEUTIL 014700* FOUND LATER ON IN THIS DOCUMENTATION AREA.* DATEUTIL 017600* * DQF20115 017700* DU-DATE-1-FORMAT-CODE - THIS FIELD PERMITS YOU TO SPECIFY A * DQF20115 017800* FORMAT FOR DU-DATE-1 VIA A NUMBER INSTEAD * DQF20115 017900* ISPF: DUDT1FCD THE "BUILD YOUR OWN" FORMAT. IF YOU USE * DQF20115 018000* DU-DATE-1-FORMAT-CODE, ANY VALUES IN: * DQF20115 018100* DU-DAY-1-FORMAT * DQF20115 018200* DU-MONTH-1-FORMAT * DQF20115 018300* DU-YEAR-1-FORMAT * DQF20115 018400* DU-DATE-1-FORMAT * DQF20115 018500* WILL BE OVERWRITTEN TO CONFORM TO THE * DQF20115 018600* VALUE IN THE FORMAT CODE FIELD. THE * DQF20115 018700* FORMAT CODE FIELD WILL ALSO BE OVER- * DQF20115 018800* WRITTEN WITH THE EXPANDED DATE FORMAT * DQF20115 018900* THAT THE CODE REPRESENTS. FOLLOWING IS * DQF20115 019000* THE CODE VALUES AND THE FORMATS WHICH * DQF20115 019100* THEY REPRESENT: * DQF20115 019200* 1 YYYY-MM-DD * DQF20115 019300* 2 YYYY.MM.DD * DQF20115 019400* 3 YYYY/MM/DD * DQF20115 019500* 4 YYYY MM DD * DQF20115 019600* 5 YYYYMMDD * DQF20115 019700* 6 MM-DD-YYYY * DQF20115 019800* 7 MM.DD.YYYY * DQF20115 019900* 8 MM/DD/YYYY * DQF20115 020000* 9 MM DD YYYY * DQF20115 020100* 10 MMDDYYYY * DQF20115 020200* 11 YYYY-DDD * DQF20115 020300* 12 YYYY.DDD * DQF20115 020400* 13 YYYY/DDD * DQF20115 020500* 14 YYYY DDD * DQF20115 020600* 15 YYYYDDD * DQF20115 020700* 16 YY-MM-DD * DQF20115 020800* 17 YY.MM.DD * DQF20115 020900* 18 YY/MM/DD * DQF20115 021000* 19 YY MM DD * DQF20115 021100* 20 YYMMDD * DQF20115 021200* 21 MM-DD-YY * DQF20115 021300* 22 MM.DD.YY * DQF20115 021400* 23 MM/DD/YY * DQF20115 021500* 24 MM DD YY * DQF20115 021600* 25 MMDDYY * DQF20115 021700* 26 YY-DDD * DQF20115 021800* 27 YY.DDD * DQF20115 021900* 28 YY/DDD * DQF20115 022000* 29 YY DDD * DQF20115 022100* 30 YYDDD * DQF20115 022200* 31 DD-MMM-YYYY * DQF20115 022300* 32 DD.MMM.YYYY * DQF20115 022400* 33 DD/MMM/YYYY * DQF20115 022500* 34 DD MMM YYYY * DQF20115 022600* 35 DDMMMYYYY * DQF20115 022700* 36 DD-MMM-YY * DQF20115 022800* 37 DD.MMM.YY * DQF20115 022900* 38 DD/MMM/YY * DQF20115 023000* 39 DD MMM YY * DQF20115 023100* 40 DDMMMYY * DQF20115 023200* 41 YYYY-MMM-DD * DQF20115 023300* 42 YYYY.MMM.DD * DQF20115 023400* 43 YYYY/MMM/DD * DQF20115 023500* 44 YYYY MMM DD * DQF20115 023600* 45 YYYYMMMDD * DQF20115 023700* 46 YY-MMM-DD * DQF20115 023800* 47 YY.MMM.DD * DQF20115 023900* 48 YY/MMM/DD * DQF20115 024000* 49 YY MMM DD * DQF20115 024100* 50 YYMMMDD * DQF20115 024200* 51 FULLMONTH ZD, YYYY * DQF20115 024300* 52 FULLMONTH DD, YYYY * DQF20115 024400* 53 DAY-OF-THE-WEEK NUMBER * DQF20115 024500* 54 DAY-OF-THE-WEEK TEXT * DQF20115 014800* * DATEUTIL 014900* DU-DATE-2 - THIS FIELD CONTAINS THE OUTPUT OF ALL THE * DATEUTIL 015000* DATE FUNCTIONS EXCEPT FOR "BETWEEN". IN * DATEUTIL 015100* ISPF: DUDATE2 THE "BETWEEN" FUNCTION, DU-DATE-2 IS ONE * DATEUTIL 015200* OF THE INPUT FIELDS. THE FORMAT OF THE * DATEUTIL 015300* THE DATE IS DETERMINED BY THE FORMAT * DATEUTIL 015400* SPECIFICATIONS IN DU-DAY-2-FORMAT, * DATEUTIL 015500* DU-MONTH-2-FORMAT, DU-YEAR-2-FORMAT, AND * DATEUTIL 015600* DU-DATE-2-FORMAT. * DATEUTIL 015700* * DATEUTIL 015800* DU-DAY-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 015900* THE "DAY" PORTION OF DU-DATE-2. THE * DATEUTIL 016000* ISPF: DUDY2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 016100* * DATEUTIL 016200* DD - THE 2 DIGIT DAY OF THE MONTH * DATEUTIL 016300* ZD - THE 2 DIGIT DAY OF THE MONTH WITH * DATEUTIL 016400* LEADING ZEROS SUPPRESSED * DATEUTIL 016500* DDD - THE 3 DIGIT DAY OF THE YEAR * DATEUTIL 016600* ZZD - THE 3 DIGIT DAY OF THE YEAR WITH * DATEUTIL 016700* LEADING ZEROS SUPPRESSED * DATEUTIL 016800* D - THE 1 DIGIT DAY OF THE WEEK * DATEUTIL 016900* (MONDAY IS 1) * DATEUTIL 017000* DA - THE 2 LETTER DAY OF THE WEEK ABBR. * DATEUTIL 017100* DAY - THE FULL DAY OF THE WEEK NAME * DATEUTIL 017200* * DATEUTIL 017300* IF THE FUNCTION IS "BETWEEN", YOU MAY * DATEUTIL 017400* NOT USE FORMATS "D", "DA" OR "DAY" SINCE * DATEUTIL 017500* THEY WILL NOT GIVE ENOUGH DATE TO PROVIDE * DATEUTIL 017600* AN EXACT DATE FOR CALCULATIONS. * DATEUTIL 017700* * DATEUTIL 017800* DU-MONTH-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 017900* THE "MONTH" PORTION OF DU-DATE-2. THE * DATEUTIL 018000* ISPF: DUMO2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 018100* * DATEUTIL 018200* MM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 018300* ZM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 018400* (ZERO SUPPRESSED) * DATEUTIL 018500* MMM - THE 3 LETTER MONTH ABBREVIATION * DATEUTIL 018600* MONTH - THE FULL MONTH NAME * DATEUTIL 018700* * DATEUTIL 028600* DU-YEAR-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DQF20115 018900* THE "YEAR" PORTION OF DU-DATE-2. THE * DATEUTIL 019000* ISPF: DUYR2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 019100* * DATEUTIL 019200* YY - THE 2 DIGIT DECADE OF THE CENTURY * DATEUTIL 019300* YYYY - THE FULL FOUR DIGIT YEAR * DATEUTIL 019400* * DATEUTIL 019500* IF THE FUNCTION IS "BETWEEN" AND THE * DATEUTIL 019600* FORMAT IS "YY", THE CENTURY WILL ALWAYS * DATEUTIL 019700* BE ASSUMED TO BE "19". IF YOU WANT TO * DATEUTIL 019800* SPECIFY ANY OTHER CENTURY OTHER THAN "19",* DATEUTIL 019900* YOU MUST PROVIDE THE FULL 4 DIGIT YEAR. * DATEUTIL 029800* * DQF20115 029900* DU-YEAR-2-SWITCH - THIS FIELD LETS YOU OVERRIDE THE YEAR * DQF20115 030000* WHICH IS USED TO DETERMINE WHETHER A 2 * DQF20115 030100* ISPF: DUYR2SWT DIGIT YEAR FALLS IN THE CENTURY "19" OR * DQF20115 030200* "20". THE DEFAULT FOR THE PROGRAM IS 50. * DQF20115 030300* CONSEQUENTLY, YOU WOULD MOVE "YY" TO * DQF20115 030400* DU-YEAR-2-FORMAT (OR PICK ONE OF THE 2 * DQF20115 030500* DIGIT YEAR FORMAT CODES) AND THEN MOVE * DQF20115 030600* YOUR "SWITCH YEAR", (E.G. "60") TO * DQF20115 030700* DU-YEAR-2-SWITCH. THEN, WHEN THE PROGRAM * DQF20115 030800* ENCOUNTERS YOUR TWO DIGIT YEAR, AND THE * DQF20115 030900* YEAR IS LESS THAN 60, THEN "20" WILL BE * DQF20115 031000* USED FOR THE CENTURY. OTHERWISE "19" * DQF20115 031100* WILL BE USED. * DQF20115 020000* * DATEUTIL 020100* DU-DATE-2-FORMAT - THIS FIELD DESCRIBES HOW THE "DAY", * DATEUTIL 020200* "MONTH", AND "YEAR" COMPONENTS ARE * DATEUTIL 020300* ISPF: DUDT2FMT ARRANGED IN DU-DATE-2 SO THAT THE PROGRAM * DATEUTIL 020400* CAN PROPERLY PARSE THE INPUT DATE FOR USE * DATEUTIL 020500* IN "BETWEEN" PROCESSING, OR SO THE * DATEUTIL 020600* PROGRAM CAN CREATE THE OUTPUT DATE IN THE * DATEUTIL 020700* DESIRED FORMAT IN FIELD DU-DATE-2. THE * DATEUTIL 020800* LETTERS "Y", "M", AND "D" ARE USED TO * DATEUTIL 020900* REPRESENT THE YEAR, MONTH, AND DAY * DATEUTIL 021000* COMPONENTS. EXAMPLES AND FURTHER * DATEUTIL 021100* EXPLANATION OF HOW THE DAY-FORMAT, * DATEUTIL 021200* MONTH-FORMAT, YEAR-FORMAT, AND * DATEUTIL 021300* DATE-FORMAT COMPONENTS WORK TOGETHER IS * DATEUTIL 021400* FOUND LATER ON IN THIS DOCUMENTATION AREA.* DATEUTIL 032700* * DQF20115 032800* DU-DATE-2-FORMAT-CODE - THIS FIELD PERMITS YOU TO SPECIFY A * DQF20115 032900* FORMAT FOR DU-DATE-2 VIA A NUMBER INSTEAD * DQF20115 033000* ISPF: DUDT2FCD THE "BUILD YOUR OWN" FORMAT. IF YOU USE * DQF20115 033100* DU-DATE-2-FORMAT-CODE, ANY VALUES IN: * DQF20115 033200* DU-DAY-2-FORMAT * DQF20115 033300* DU-MONTH-2-FORMAT * DQF20115 033400* DU-YEAR-2-FORMAT * DQF20115 033500* DU-DATE-2-FORMAT * DQF20115 033600* WILL BE OVERWRITTEN TO CONFORM TO THE * DQF20115 033700* VALUE IN THE FORMAT CODE FIELD. THE * DQF20115 033800* FORMAT CODE FIELD WILL ALSO BE OVER- * DQF20115 033900* WRITTEN WITH THE EXPANDED DATE FORMAT * DQF20115 034000* THAT THE CODE REPRESENTS. FOLLOWING IS * DQF20115 034100* THE CODE VALUES AND THE FORMATS WHICH * DQF20115 034200* THEY REPRESENT: * DQF20115 034300* 1 YYYY-MM-DD * DQF20115 034400* 2 YYYY.MM.DD * DQF20115 034500* 3 YYYY/MM/DD * DQF20115 034600* 4 YYYY MM DD * DQF20115 034700* 5 YYYYMMDD * DQF20115 034800* 6 MM-DD-YYYY * DQF20115 034900* 7 MM.DD.YYYY * DQF20115 035000* 8 MM/DD/YYYY * DQF20115 035100* 9 MM DD YYYY * DQF20115 035200* 10 MMDDYYYY * DQF20115 035300* 11 YYYY-DDD * DQF20115 035400* 12 YYYY.DDD * DQF20115 035500* 13 YYYY/DDD * DQF20115 035600* 14 YYYY DDD * DQF20115 035700* 15 YYYYDDD * DQF20115 035800* 16 YY-MM-DD * DQF20115 035900* 17 YY.MM.DD * DQF20115 036000* 18 YY/MM/DD * DQF20115 036100* 19 YY MM DD * DQF20115 036200* 20 YYMMDD * DQF20115 036300* 21 MM-DD-YY * DQF20115 036400* 22 MM.DD.YY * DQF20115 036500* 23 MM/DD/YY * DQF20115 036600* 24 MM DD YY * DQF20115 036700* 25 MMDDYY * DQF20115 036800* 26 YY-DDD * DQF20115 036900* 27 YY.DDD * DQF20115 037000* 28 YY/DDD * DQF20115 037100* 29 YY DDD * DQF20115 037200* 30 YYDDD * DQF20115 037300* 31 DD-MMM-YYYY * DQF20115 037400* 32 DD.MMM.YYYY * DQF20115 037500* 33 DD/MMM/YYYY * DQF20115 037600* 34 DD MMM YYYY * DQF20115 037700* 35 DDMMMYYYY * DQF20115 037800* 36 DD-MMM-YY * DQF20115 037900* 37 DD.MMM.YY * DQF20115 038000* 38 DD/MMM/YY * DQF20115 038100* 39 DD MMM YY * DQF20115 038200* 40 DDMMMYY * DQF20115 038300* 41 YYYY-MMM-DD * DQF20115 038400* 42 YYYY.MMM.DD * DQF20115 038500* 43 YYYY/MMM/DD * DQF20115 038600* 44 YYYY MMM DD * DQF20115 038700* 45 YYYYMMMDD * DQF20115 038800* 46 YY-MMM-DD * DQF20115 038900* 47 YY.MMM.DD * DQF20115 039000* 48 YY/MMM/DD * DQF20115 039100* 49 YY MMM DD * DQF20115 039200* 50 YYMMMDD * DQF20115 039300* 51 FULLMONTH ZD, YYYY * DQF20115 039400* 52 FULLMONTH DD, YYYY * DQF20115 039500* 53 DAY-OF-THE-WEEK NUMBER * DQF20115 039600* 54 DAY-OF-THE-WEEK TEXT * DQF20115 021500* * DATEUTIL 021600* DATEUTIL-MESSAGE - THIS FIELD IS A REDEFINES OF THE ENTIRE * DATEUTIL 021700* DATEUTIL-WORK-AREA. IF THE DATEUTIL * DATEUTIL 021800* ISPF: DUMSG PROGRAM ENDS WITH AN INVALID USER RETURN * DATEUTIL 021900* CODE (ANYTHING GREATER THAN +1999), THEN * DATEUTIL 022000* THE DATEUTIL-WORK-AREA IS CLEARED OUT AND * DATEUTIL 022100* DATEUTIL-MESSAGE WILL CONTAIN AN ERROR * DATEUTIL 022200* MESSAGE INDICATING WHAT PROBLEM CAUSED * DATEUTIL 022300* DATEUTIL TO TERMINATE PROCESSING. IT IS * DATEUTIL 022400* A GOOD IDEA TO NOT USE DATEUTIL-WORK-AREA * DATEUTIL 022500* IN YOUR PROGRAM FOR ANYTHING BUT * DATEUTIL 022600* COMMUNICATING WITH DATEUTIL. THAT WAY, * DATEUTIL 022700* IF THERE IS A PROBLEM WITH DATEUTIL, AND * DATEUTIL 022800* DATEUTIL HAS OVERWRITTEN THE * DATEUTIL 022900* DATEUTIL-WORK-AREA WITH THE ERROR MESSAGE,* DATEUTIL 023000* AND YOU HAVE YOUR INPUT IN YOUR OWN WORK * DATEUTIL 023100* AREA, YOU WILL BE ABLE TO DISPLAY THE * DATEUTIL 023200* MESSAGE AND YOUR WORK AREAS TO HELP IN * DATEUTIL 023300* DEBUGGING THE PROBLEM. ADDITIONALLY, IT * DATEUTIL 023400* IS ALWAYS A GOOD IDEA TO INITIALIZE THE * DATEUTIL 023500* DATEUTIL-WORK-AREA BEFORE MOVING THINGS * DATEUTIL 023600* TO IT SO THAT YOU MAKE SURE THAT IN * DATEUTIL 023700* ADDITION TO YOUR PARAMETERS WHICH YOU ARE * DATEUTIL 023800* PASSING, THERE IS NOT SOME GARBAGE IN THE * DATEUTIL 023900* OTHER FIELDS. * DATEUTIL 024000***************************************************************** DATEUTIL 042300* BUILDING YOUR OWN DATE FORMATS! * DQF20115 024200* * DATEUTIL 042500* INSTEAD OF LIMITING YOU TO THE FINITE LIST OF DATE FORMATS * DQF20115 042600* WHICH YOU CAN PASS OR RECEIVE, DATEUTIL ALSO ALLOWS YOU TO * DQF20115 042700* BUILD YOUR OWN DATE INPUT AND OUTPUT FORMATS BY SPECIFYING A * DQF20115 042800* FORMAT FOR EACH COMPONENT OF THE DATE (THE DAY, MONTH, AND * DQF20115 042900* YEAR) AND THE OVERALL COMPOSITE FORMAT OF HOW THE COMPONENTS * DQF20115 043000* FIT TOGETHER. YOU CAN USE STANDARD FORMAT CODES FOR BOTH * DQF20115 043100* DATE 1 AND DATE 2 OR BUILD YOUR OWN FOR BOTH OR DO STANDARD * DQF20115 043200* FOR ONE AND "HOME BUILT" FOR THE OTHER. * DQF20115 024600* * DATEUTIL 024700* THE "DATE" FORMAT FIELD (EITHER FOR DATE-1 OR DATE-2) IS THE * DATEUTIL 024800* FORMAT OF THE ENTIRE DATE, AND THE "DAY", "MONTH", AND "YEAR" * DATEUTIL 024900* FORMAT FIELDS ARE THE FORMATS OF EACH OF THOSE COMPONENTS OF * DATEUTIL 025000* THE DATE. * DATEUTIL 025100* * DATEUTIL 025200* THE BEST WAY TO EXPLAIN HOW THIS WORKS IS PROBABLY BY SHOWING * DATEUTIL 025300* SOME EXAMPLES. WHAT FOLLOWS IS A LIST OF DATES AND HOW THEIR * DATEUTIL 025400* FORMATS WOULD BE REPRESENTED IN THE FORMAT FIELDS. * DATEUTIL 025500* * DATEUTIL 025600* DAY MONTH YEAR * DATEUTIL 025700* ACTUAL DATE FIELD FMT FMT FMT DATE FORMAT * DATEUTIL 025800* -------------------- --- ----- ---- -------------------- * DATEUTIL 025900* A THURSDAY IN APRIL DAY MONTH A D IN M * DATEUTIL 026000* 12/31/91 DD MM YY M/D/Y * DATEUTIL 026100* MARCH 5, 1985 ZD MONTH YYYY M D, Y * DATEUTIL 026200* 13 SEP 2001 DD MMM YYYY D M Y * DATEUTIL 026300* 1999...JULY...24 DD MONTH YYYY Y...M...D * DATEUTIL 026400* FRIDAY DAY D * DATEUTIL 026500* JANUARY MONTH M * DATEUTIL 026600* 1776 YYYY Y * DATEUTIL 026700* 91 YY Y * DATEUTIL 026800* 13/86 MM YY M/Y * DATEUTIL 026900* 1987234 DDD YYYY YD * DATEUTIL 027000* 1995-10-20 DD MM YYYY Y-M-D * DATEUTIL 027100* 7 D D * DATEUTIL 027200* 7 ZD D * DATEUTIL 027300* 7 ZZD D * DATEUTIL 027400* 07 DD D * DATEUTIL 027500* 07 MM M * DATEUTIL 027600* 7.1.81 ZD ZM YY M.D.Y * DATEUTIL 027700* 7.1.81 ZD ZM YY D.M.Y * DATEUTIL 027800* * DATEUTIL 027900* AS YOU CAN SEE, THERE ARE A LOT OF DATE FORMATS THAT CAN BE * DATEUTIL 028000* REPRESENTED WITH THESE FORMAT COMBINATIONS. THERE ARE A FEW * DATEUTIL 028100* LIMITATIONS HOWEVER. FIRST, IN THE THE "DATE" FORMAT FIELD, * DATEUTIL 028200* THE LETTERS "Y", "M", AND "D" OBVIOUSLY HAVE SPECIAL * DATEUTIL 028300* SIGNIFICANCE. IF YOU WANTED TO INCLUDE THE ABSOLUTE TEXT OF * DATEUTIL 028400* A WORD LIKE "DAY", YOU WOULD NOT GET THE RESULTS YOU WANTED. * DATEUTIL 028500* THE "D" IN "DAY" WOULD GET CONVERTED TO THE "DAY" COMPONENT * DATEUTIL 028600* OF THE DATE, AND THE "Y" IN "DAY" WOULD GET CONVERTED TO THE * DATEUTIL 028700* "YEAR" PORTION OF THE DATE. "DAY" COULD END UP LOOKING LIKE * DATEUTIL 028800* "13A1991"! * DATEUTIL 028900* * DATEUTIL 029000* THE OTHER LIMITATION IS THAT BOTH THE DATE FIELD AND THE * DATEUTIL 029100* DATE FORMAT FIELD ARE 20 BYTES LONG. THAT DOES LIMIT HOW * DATEUTIL 029200* BIG YOU CAN MAKE YOUR DATE OR YOUR DATE FORMAT. ALSO, SINCE * DATEUTIL 029300* "D", "M", AND "Y" ARE USUALLY EXPANDED INTO SOMETHING BIGGER * DATEUTIL 029400* IN THE ACTUAL DATE, A DATE FORMAT FIELD WHICH IS 15 TO 20 * DATEUTIL 029500* BYTES LONG MAY WELL CREATE A DATE THAT IS TRUNCATED IN SOME * DATEUTIL 029600* WAY. * DATEUTIL 029700* * DATEUTIL 029800* REGARDLESS OF THE OUTPUT DATE FORMAT, IT WILL BE A LEFT * DATEUTIL 029900* JUSTIFIED PIC X(20) FIELD. IT WILL BE UP TO THE CALLING * DATEUTIL 030000* PROGRAM TO PLACE THE DATE INTO WHAT EVER FIELDS ARE NECESSARY.* DATEUTIL 030100***************************************************************** DATEUTIL 030200* DATEUTIL PROCESSING IN ISPF * DATEUTIL 030300* * DATEUTIL 030400* IF YOU NEED TO PERFORM ADVANCED DATE PROCESSING FROM A CLIST, * DATEUTIL 030500* REXX EXEC, OR PROGRAM IN AN ISPF ENVIRONMENT, YOU CAN SEND * DATEUTIL 030600* YOUR INPUT AND RECEIVE YOUR OUTPUT VIA ISPF SHARED POOL * DATEUTIL 030700* VARIABLES AND CALL DATEUTIL VIA THE ISPEXEC SELECT SERVICE. * DATEUTIL 030800* * DATEUTIL 030900* WHEN CALLING DATEUTIL YOUR SYNTAX MUST BE: * DATEUTIL 031000* * DATEUTIL 031100* ISPEXEC SELECT PGM(DATEUTIL) PARM(ISPF) * DATEUTIL 031200* * DATEUTIL 031300* THE PARM OF "ISPF" IS VERY IMPORTANT. THAT IS HOW DATEUTIL * DATEUTIL 031400* KNOWS TO DO IT'S INPUT AND OUTPUT WITH ISPF SHARED POOL * DATEUTIL 031500* VARIABLES INSTEAD OF THE LINKAGE SECTION PROCESSING IN DIRECT * DATEUTIL 031600* COBOL-TO-COBOL PROCESSING. * DATEUTIL 031700* * DATEUTIL 031800* BEFORE CALLING DATEUTIL, YOU WILL NEED TO SET SOME VARIABLES * DATEUTIL 031900* TO CERTAIN VALUES AND THEN VPUT THEM INTO THE SHARED POOL. * DATEUTIL 032000* WHEN THE PROGRAM IS FINISHED PROCESSING, YOU NEED TO CHECK * DATEUTIL 032100* THE RETURN CODE, AND THEN VGET EITHER THE RESULT VARIABLE YOU * DATEUTIL 032200* DESIRE, OR THE ERROR MESSAGE VARIABLE IF THE RETURN CODE FROM * DATEUTIL 032300* DATEUTIL INDICATED THAT AN ERROR OCCURRED. * DATEUTIL 032400* * DATEUTIL 032500* THE VARIABLES ARE DESCRIBED ABOVE ALONG WITH THE COPY BOOK * DATEUTIL 032600* DATA ELEMENTS THAT THEY MIRROR. YOU NEED TO POPULATE THE * DATEUTIL 032700* VARIABLES WITH THE SAME VALUES THAT YOU WOULD THE DATA * DATEUTIL 032800* ELEMENTS. * DATEUTIL 032801***************************************************************** DATEUTIL 032802 DATEUTIL 032803/************************* REVISIONS **************************** DATEUTIL 032804** PUT INTO PRODUCTION * D. LEIGH & W. WISEMAN * * DATEUTIL 032810** EST PRD 3/16/92 * VERSION 1.00 * * DATEUTIL 032820***************************************************************** DATEUTIL 032821** 799 FUNDING SOURCE ENHANCEMENT * A17322 * DAVID LEIGH * DQA17322 032830** 1. I PUT THE BLANK LINES BACK INTO THE PROGRAM WHICH * DQA17322 032831** WENDY HAD REMOVED TO ENHABLE THE PROGRAM TO PASS * DQA17322 032832** REFCHECK (ARRRRRRGH!) * DQA17322 032833** 2. THE PROGRAM WAS HAVING SOME PROBLEMS IN THAT WHEN IT * DQA17322 032834** WAS CALLED REPEATEDLY FROM ANOTHER COBOL PROGRAM, THE * DQA17322 032835** PRIOR RETURN CODE WAS BEING RETAINED, EVEN THOUGH THE * DQA17322 032836** RESULTS WERE CORRECT. THIS SIMPLY INVOLVED * DQA17322 032837** INITIALIZING THE RETURN CODE FOR EACH PROGRAM * DQA17322 032838** EXECUTION. * DQA17322 032840** ESTIMATED PRODUCTION MOVE: 9/18/1992 * VERSION 2.00 * DQA17322 032900***************************************************************** DATEUTIL 053400**----------+----------------------------------------------------*TIF20115 053500** A20115 ³ 97/05/10 ³ 2.01 ³ DAVID LEIGH, TOM IOWA *TIF20115 053600**----------+----------------------------------------------------*TIF20115 053700** ³ YEAR 2000: *TIF20115 053800** ³ DUE TO THE UNIQUE ABILITY OF DATEUTIL TO BE CALLED*TIF20115 053900** ³ FROM ISPF, DTSEDIT WAS NOT USED TO CALCULATE THE *TIF20115 054000** ³ CENTURY. TESTED FOR Y2K COMPLIANCE. *TIF20115 054100** ³----------------------------------------------------*TIF20115 054200** ³ DATE UTILITY ENHANCEMENT: *TIF20115 054300** ³ I ADDED THE CAPABILITY TO PASS 1 OF 54 FORMAT *TIF20115 054400** ³ CODES TO THE PROGRAM TO PERMIT AUTOMATIC DATE *TIF20115 054500** ³ FORMATS AS WELL AS THE "BUILD YOUR OWN" VARIETY. *TIF20115 054600** ³ I ALSO ADDED THE ABILITY TO PASS A "SWITCH" YEAR *TIF20115 054700** ³ INTO THE PROGRAM WHICH PERMITS DATEUTIL TO DETER- *TIF20115 054800** ³ MINE THE CENTURY BASED ON THE DECADE DATE. THE *TIF20115 054900** ³ DEFAULT IS 50, BUT ANY 2 DIGIT YEAR CAN BE PASSED *TIF20115 055000** ³ IN IF NECESSARY. DAVID LEIGH *TIF20115 033000/**************************************************************** DATEUTIL 033100* E N V I R O N M E N T D I V I S I O N * DATEUTIL 033200***************************************************************** DATEUTIL 033300 ENVIRONMENT DIVISION. DATEUTIL 033400 DATEUTIL 033500 INPUT-OUTPUT SECTION. DATEUTIL 033600 DATEUTIL 033700 FILE-CONTROL. DATEUTIL 033800 DATEUTIL 033900/**************************************************************** DATEUTIL 034000* D A T A D I V I S I O N * DATEUTIL 034100***************************************************************** DATEUTIL 034200 DATA DIVISION. DATEUTIL 034300 DATEUTIL 034400 FILE SECTION. DATEUTIL 034500 DATEUTIL 034600/**************************************************************** DATEUTIL 034700* W O R K I N G - S T O R A G E S E C T I O N * DATEUTIL 034800***************************************************************** DATEUTIL 034900 WORKING-STORAGE SECTION. DATEUTIL 057002 01 A-STANDARD-PROGRAM-ID PIC X(27) VALUE TIE20115 057010 'UNIPAC/DATEUTIL/970510-2.01'. TIE20115 035600/**************************************************************** DATEUTIL 035700* C O N S T A N T S * DATEUTIL 035800***************************************************************** DATEUTIL 035900 01 CONSTANTS. DATEUTIL 057500 05 C-SWITCH-YEAR-DEFAULT PIC 9(02) VALUE 50. DQF20115 036300 05 C-ISPF PIC X(07) VALUE 'ISPLINK'. DATEUTIL 036400 DATEUTIL 036500 05 C-ISPF-CONSTANTS. DATEUTIL 036600 10 C-ISPF-SERVICES-AND-PARAMETERS. DATEUTIL 036700 15 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. DATEUTIL 036800 15 C-CONTROL PIC X(08) VALUE 'CONTROL '. DATEUTIL 036900 15 C-VGET PIC X(08) VALUE 'VGET '. DATEUTIL 037000 15 C-VPUT PIC X(08) VALUE 'VPUT '. DATEUTIL 037100 15 C-LIST-OPTION PIC X(08) VALUE 'LIST '. DATEUTIL 037200 15 C-ERRORS-OPTION PIC X(08) VALUE 'ERRORS '. DATEUTIL 037300 15 C-RETURN-OPTION PIC X(08) VALUE 'RETURN '. DATEUTIL 037400 15 C-SHARED-OPTION PIC X(08) VALUE 'SHARED '. DATEUTIL 037500 DATEUTIL 037600 10 C-MESSAGE-VARIABLE-NAME PIC X(08) VALUE 'DUMSG '. DATEUTIL 037700 10 C-MESSAGE-VARIABLE-L PIC S9(06) COMP VALUE +120. DATEUTIL 037800 10 C-MESSAGE-VARIABLE-F PIC X(8) VALUE 'CHAR '. DATEUTIL 059200***************************************************************** DQF20115 038000* NOTE: THE ORDER OF THE ISPF VARIABLE NAMES IN THE "VALUE" * DATEUTIL 038100* CLAUSE OF THE NEXT DATA ELEMENT "C-ISPF-VARIABLE-NAMES" * DATEUTIL 038200* MUST MATCH THE ORDER OF THE ELEMENTARY ITEMS DEFINED * DATEUTIL 038300* IN "C-ISPF-VARIABLE-LENGTHS", "C-ISPF-VARIABLE-FORMATS",* DATEUTIL 059700* "C-ISPF-VARIABLES", AND "W-ISPF-VARIABLES" AND THE * DQF20115 059800* "DATEUTIL" COPY BOOK MEMBER!!!!!!!!!!!!!!!!!!!!! * DQF20115 038500***************************************************************** DATEUTIL 038600 10 C-ISPF-VARIABLE-NAMES. DATEUTIL 038700 15 FILLER PIC X(33) VALUE DATEUTIL 038800 '(DUFUNC DUNUMBER DUDATE1 DUDY1FMT'. DATEUTIL 060300 15 FILLER PIC X(36) VALUE DQF20115 060400 ' DUMO1FMT DUYR1FMT DUYR1SWT DUDT1FCD'. DATEUTIL 038900 15 FILLER PIC X(35) VALUE DATEUTIL 060600 ' DUDT1FMT DUDATE2 DUDY2FMT DUMO2FMT'. DQF20115 039100 15 FILLER PIC X(37) VALUE DATEUTIL 060800 ' DUYR2FMT DUYR2SWT DUDT2FCD DUDT2FMT)'. DQF20115 039300 DATEUTIL 039400 10 C-ISPF-VARIABLE-LENGTHS COMP. DATEUTIL 039500 15 C-DU-FUNCTION-L PIC S9(06) VALUE +10. DATEUTIL 061200 15 C-DU-NUMBER-L PIC S9(06) VALUE +8. DQF20115 039700 15 C-DU-DATE-1-L PIC S9(06) VALUE +20. DATEUTIL 039800 15 C-DU-DAY-1-FORMAT-L PIC S9(06) VALUE +3. DATEUTIL 039900 15 C-DU-MONTH-1-FORMAT-L PIC S9(06) VALUE +5. DATEUTIL 040000 15 C-DU-YEAR-1-FORMAT-L PIC S9(06) VALUE +4. DATEUTIL 061700 15 C-DU-YEAR-1-SWITCH-L PIC S9(06) VALUE +2. DQF20115 061800 15 C-DU-DATE-1-FMTCDE-L PIC S9(06) VALUE +2. DATEUTIL 040100 15 C-DU-DATE-1-FORMAT-L PIC S9(06) VALUE +20. DATEUTIL 040200 15 C-DU-DATE-2-L PIC S9(06) VALUE +20. DATEUTIL 040300 15 C-DU-DAY-2-FORMAT-L PIC S9(06) VALUE +3. DATEUTIL 040400 15 C-DU-MONTH-2-FORMAT-L PIC S9(06) VALUE +5. DATEUTIL 040500 15 C-DU-YEAR-2-FORMAT-L PIC S9(06) VALUE +4. DATEUTIL 062400 15 C-DU-YEAR-2-SWITCH-L PIC S9(06) VALUE +2. DQF20115 062500 15 C-DU-DATE-2-FMTCDE-L PIC S9(06) VALUE +2. DQF20115 040600 15 C-DU-DATE-2-FORMAT-L PIC S9(06) VALUE +20. DATEUTIL 040700 DATEUTIL 040800 10 C-ISPF-VARIABLE-FORMATS. DATEUTIL 040900 15 C-DU-FUNCTION-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041000 15 C-DU-NUMBER-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041100 15 C-DU-DATE-1-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041200 15 C-DU-DAY-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041300 15 C-DU-MONTH-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041400 15 C-DU-YEAR-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 063500 15 C-DU-YEAR-1-SWITCH-F PIC X(8) VALUE 'CHAR '. DQF20115 063600 15 C-DU-DATE-1-FMTCDE-F PIC X(8) VALUE 'CHAR '. DQF20115 041500 15 C-DU-DATE-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041600 15 C-DU-DATE-2-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041700 15 C-DU-DAY-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041800 15 C-DU-MONTH-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 041900 15 C-DU-YEAR-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 064200 15 C-DU-YEAR-2-SWITCH-F PIC X(8) VALUE 'CHAR '. DQF20115 064300 15 C-DU-DATE-2-FMTCDE-F PIC X(8) VALUE 'CHAR '. DQF20115 042000 15 C-DU-DATE-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 042100 DATEUTIL 042200/**************************************************************** DATEUTIL 042300* S W I T C H E S * DATEUTIL 042400***************************************************************** DATEUTIL 042500 01 SWITCHES. DATEUTIL 042800 05 S-ISPF-SWITCH PIC X(01) VALUE 'N'. DATEUTIL 042900 88 S-INVOKED-FROM-ISPF VALUE 'Y'. DATEUTIL 043000 05 S-LEAP-YEAR-SWITCH PIC X(01) VALUE 'N'. DATEUTIL 043100 88 S-NOT-A-LEAP-YEAR VALUE 'N'. DATEUTIL 043200 88 S-IS-A-LEAP-YEAR VALUE 'Y'. DATEUTIL 065500 DQF20115 043300/**************************************************************** DATEUTIL 043400* W O R K A R E A S * DATEUTIL 043500***************************************************************** DATEUTIL 043600 01 WORK-AREAS. DATEUTIL 044000 05 W-RETURN-CODE PIC S9(08) VALUE +0 COMP. DATEUTIL 066100 05 W-TALLY PIC S9(08) VALUE +0 COMP. DQF20115 044100 05 W-QUOTIENT PIC S9(08) VALUE +0 COMP. DATEUTIL 044300 05 W-REMAINDER PIC S9(08) VALUE +0 COMP. DATEUTIL 044310 88 W-A-LEAP-YEAR-REMAINDER VALUE +0. DATEUTIL 044400 05 W-NUMBER PIC S9(08) VALUE +0 COMP. DATEUTIL 044500 DATEUTIL 044600 05 W-MONTH-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 044700 05 W-YEAR-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 044800 05 W-DAY-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 044900 DATEUTIL 045000 05 W-MONTH-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 045100 05 W-YEAR-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 045200 05 W-DAY-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 067400 05 W-ABSOLUTE-DAY PIC S9(07) COMP-3 VALUE +0. DQF20115 045300 DATEUTIL 045400 05 W-ISPF-SERVICE PIC X(08) VALUE SPACES. DATEUTIL 045500 05 W-HOLD-FUNCTION PIC X(10) VALUE SPACES. DATEUTIL 067800 05 W-SWITCH-YEAR PIC 9(02) VALUE 50. DQF20115 067900 05 W-FORMAT-CODE PIC 9(02) VALUE ZEROS. DQF20115 068000 88 W-YYYY-FORMAT VALUE 01 THRU 15, DQF20115 068100 31 THRU 35, DQF20115 068200 41 THRU 45, DQF20115 068300 51 THRU 52. DQF20115 068400 88 W-YY-FORMAT VALUE 16 THRU 30, DQF20115 068500 36 THRU 40, DQF20115 068600 46 THRU 50. DQF20115 068700 88 W-MM-FORMAT VALUE 01 THRU 10, DQF20115 068800 16 THRU 25. DQF20115 068900 88 W-MMM-FORMAT VALUE 31 THRU 50. DQF20115 069000 88 W-MONTH-FORMAT VALUE 51 THRU 52. DQF20115 069100 88 W-D-FORMAT VALUE 53. DQF20115 069200 88 W-DAY-FORMAT VALUE 54. DQF20115 069300 88 W-DD-FORMAT VALUE 01 THRU 10, DQF20115 069400 16 THRU 25, DQF20115 069500 31 THRU 50, 52. DQF20115 069600 88 W-ZD-FORMAT VALUE 51. DQF20115 069700 88 W-DDD-FORMAT VALUE 11 THRU 15, DQF20115 069800 26 THRU 30. DQF20115 069900 05 W-HOLD-NUMBER PIC 9(08) VALUE ZEROS. DQF20115 070000 05 W-NUMBER-ARRAY REDEFINES W-HOLD-NUMBER PIC X(08). DQF20115 045800 05 FILLER REDEFINES W-HOLD-NUMBER DATEUTIL 070200 OCCURS 8 TIMES DQF20115 046000 INDEXED BY W-NUM-NDX1 W-NUM-NDX2. DATEUTIL 046100 10 W-NUMBER-ARRAY-BYTE PIC X(01). DATEUTIL 046200 05 W-HOLD-DATE PIC X(20) VALUE SPACES. DATEUTIL 046300 05 W-HOLD-DAY-FORMAT PIC X(03) VALUE SPACES. DATEUTIL 046400 05 W-HOLD-MONTH-FORMAT PIC X(05) VALUE SPACES. DATEUTIL 046500 05 W-HOLD-YEAR-FORMAT PIC X(04) VALUE SPACES. DATEUTIL 046600 05 W-HOLD-DATE-FORMAT PIC X(20) VALUE SPACES. DATEUTIL 046700 DATEUTIL 046800 05 W-SYSDATE. DATEUTIL 046900 10 W-SYSDATE-DECADE PIC 9(02) VALUE ZEROS. DATEUTIL 047000 10 W-SYSDATE-DDD PIC 9(03) VALUE ZEROS. DATEUTIL 047100 DATEUTIL 047200 05 W-HOLD-JULIAN PIC 9(07) VALUE ZEROS. DATEUTIL 047300 05 FILLER REDEFINES W-HOLD-JULIAN. DATEUTIL 047400 10 W-HOLD-JULIAN-YEAR PIC 9(04). DATEUTIL 047500 10 FILLER REDEFINES W-HOLD-JULIAN-YEAR. DATEUTIL 047600 15 W-HOLD-JULIAN-CENTURY PIC 9(02). DATEUTIL 047700 15 W-HOLD-JULIAN-DECADE PIC 9(02). DATEUTIL 047800 10 W-HOLD-JULIAN-DDD PIC 9(03). DATEUTIL 047900 05 FILLER REDEFINES W-HOLD-JULIAN DATEUTIL 048000 OCCURS 7 TIMES DATEUTIL 048100 INDEXED BY W-HOLD-JULIAN-NDX. DATEUTIL 048200 10 W-HOLD-JULIAN-BYTE PIC X(01). DATEUTIL 048300 DATEUTIL 048400 05 W-WORK-JULIAN PIC 9(07) VALUE ZEROS. DATEUTIL 048500 05 FILLER REDEFINES W-WORK-JULIAN. DATEUTIL 048600 10 W-JULIAN-YEAR PIC 9(04). DATEUTIL 048700 10 FILLER REDEFINES W-JULIAN-YEAR. DATEUTIL 048800 15 W-JULIAN-CENTURY PIC 9(02). DATEUTIL 048900 15 W-JULIAN-DECADE PIC 9(02). DATEUTIL 049000 10 W-JULIAN-DDD PIC 9(03). DATEUTIL 049100 05 FILLER REDEFINES W-WORK-JULIAN DATEUTIL 049200 OCCURS 7 TIMES DATEUTIL 049300 INDEXED BY W-JULIAN-NDX. DATEUTIL 049400 10 W-JULIAN-BYTE PIC X(01). DATEUTIL 049500 DATEUTIL 049600 05 W-WORK-MONTH PIC X(09) VALUE SPACES. DATEUTIL 049700 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 049800 10 W-WORK-MMM PIC X(03). DATEUTIL 049900 10 FILLER PIC X(06). DATEUTIL 050000 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 050100 10 W-WORK-MM PIC 9(02). DATEUTIL 050200 10 FILLER PIC X(07). DATEUTIL 050300 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 050400 10 W-WORK-ZM PIC Z9. DATEUTIL 050500 10 FILLER PIC X(07). DATEUTIL 050600 05 FILLER REDEFINES W-WORK-MONTH DATEUTIL 050700 OCCURS 9 TIMES DATEUTIL 050800 INDEXED BY W-MONTH-NDX. DATEUTIL 050900 10 W-MONTH-ARRAY-BYTE PIC X(01). DATEUTIL 051000 DATEUTIL 051100 05 W-WORK-DAY PIC X(09) VALUE SPACES. DATEUTIL 051200 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 051300 10 W-WORK-DAY-AB2 PIC X(02). DATEUTIL 051400 10 FILLER PIC X(07). DATEUTIL 051500 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 051600 10 W-WORK-DAY-AB3 PIC X(03). DATEUTIL 051700 10 FILLER PIC X(06). DATEUTIL 051800 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 051900 10 W-WORK-DDD PIC 9(03). DATEUTIL 052000 10 FILLER PIC X(06). DATEUTIL 052100 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 052200 10 W-WORK-ZZD PIC ZZ9. DATEUTIL 052300 10 FILLER PIC X(06). DATEUTIL 052400 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 052500 10 W-WORK-DD PIC 9(02). DATEUTIL 052600 10 FILLER PIC X(07). DATEUTIL 052700 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 052800 10 W-WORK-ZD PIC Z9. DATEUTIL 052900 10 FILLER PIC X(07). DATEUTIL 053000 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 053100 10 W-WORK-D PIC 9(01). DATEUTIL 053200 10 FILLER PIC X(08). DATEUTIL 053300 05 FILLER REDEFINES W-WORK-DAY DATEUTIL 053400 OCCURS 9 TIMES DATEUTIL 053500 INDEXED BY W-DAY-NDX1 DATEUTIL 053510 W-DAY-NDX2. DATEUTIL 053600 10 W-DAY-ARRAY-BYTE PIC X(01). DATEUTIL 053700 DATEUTIL 053800 05 W-WORK-YEAR. DATEUTIL 053900 10 W-WORK-CENTURY PIC 9(02) VALUE ZEROS. DATEUTIL 054000 10 W-WORK-DECADE PIC 9(02) VALUE ZEROS. DATEUTIL 054100 05 W-WORK-YEAR-NUM REDEFINES W-WORK-YEAR PIC 9(04). DATEUTIL 054200 05 FILLER REDEFINES W-WORK-YEAR DATEUTIL 054300 OCCURS 4 TIMES DATEUTIL 054400 INDEXED BY W-YEAR-NDX1 DATEUTIL 054500 W-YEAR-NDX2. DATEUTIL 054600 10 W-YEAR-ARRAY-BYTE PIC X(01). DATEUTIL 054700 DATEUTIL 054800 05 W-WORK-ARRAY PIC X(20) VALUE SPACES. DATEUTIL 054900 05 W-ARRAY REDEFINES W-WORK-ARRAY DATEUTIL 055000 OCCURS 20 TIMES DATEUTIL 055100 INDEXED BY W-ARRAY-NDX1 DATEUTIL 055200 W-ARRAY-NDX2. DATEUTIL 055300 10 W-ARRAY-BYTE PIC X(01). DATEUTIL 079800 DQF20115 056000/**************************************************************** DATEUTIL 056100* T A B L E S * DATEUTIL 056200***************************************************************** DATEUTIL 056300 01 TABLES. DATEUTIL 157700 05 T-MON-TABLE-AREA. DATEUTIL 157800 10 FILLER PIC X(21) VALUE '001031001031JANUARY '. DATEUTIL 157900 10 FILLER PIC X(21) VALUE '032059032060FEBRUARY '. DATEUTIL 158000 10 FILLER PIC X(21) VALUE '060090061091MARCH '. DATEUTIL 158100 10 FILLER PIC X(21) VALUE '091120092121APRIL '. DATEUTIL 158200 10 FILLER PIC X(21) VALUE '121151122152MAY '. DATEUTIL 158300 10 FILLER PIC X(21) VALUE '152181153182JUNE '. DATEUTIL 158400 10 FILLER PIC X(21) VALUE '182212183213JULY '. DATEUTIL 158500 10 FILLER PIC X(21) VALUE '213243214244AUGUST '. DATEUTIL 158600 10 FILLER PIC X(21) VALUE '244273245274SEPTEMBER'. DATEUTIL 158700 10 FILLER PIC X(21) VALUE '274304275305OCTOBER '. DATEUTIL 158800 10 FILLER PIC X(21) VALUE '305334306335NOVEMBER '. DATEUTIL 158900 10 FILLER PIC X(21) VALUE '335365336366DECEMBER '. DATEUTIL 159000 DATEUTIL 159100 05 T-MON-TABLE REDEFINES T-MON-TABLE-AREA DATEUTIL 159200 OCCURS 12 TIMES DATEUTIL 159300 INDEXED BY T-MON-NDX. DATEUTIL 159400 10 T-MON-JUL-BEGIN PIC 9(03). DATEUTIL 159500 10 T-MON-JUL-END PIC 9(03). DATEUTIL 159600 10 T-MON-JUL-LEAP-BEGIN PIC 9(03). DATEUTIL 159700 10 T-MON-JUL-LEAP-END PIC 9(03). DATEUTIL 159800 10 T-MON-NAME. DATEUTIL 159900 15 T-MON-NAME-ABBR PIC X(03). DATEUTIL 160000 15 FILLER PIC X(06). DATEUTIL 160100 DATEUTIL 160200 05 T-DAY-TABLE-AREA. DATEUTIL 160300 10 FILLER PIC X(09) VALUE 'MONDAY '. DATEUTIL 160400 10 FILLER PIC X(09) VALUE 'TUESDAY '. DATEUTIL 160500 10 FILLER PIC X(09) VALUE 'WEDNESDAY'. DATEUTIL 160600 10 FILLER PIC X(09) VALUE 'THURSDAY '. DATEUTIL 160700 10 FILLER PIC X(09) VALUE 'FRIDAY '. DATEUTIL 160800 10 FILLER PIC X(09) VALUE 'SATURDAY '. DATEUTIL 160900 10 FILLER PIC X(09) VALUE 'SUNDAY '. DATEUTIL 161000 DATEUTIL 161100 05 T-DAY-TABLE REDEFINES T-DAY-TABLE-AREA DATEUTIL 161200 OCCURS 7 TIMES DATEUTIL 161300 INDEXED BY T-DAY-NDX. DATEUTIL 161400 10 T-DAY-NAME. DATEUTIL 161500 15 T-DAY-NAME-ABBR PIC X(02). DATEUTIL 161600 15 FILLER PIC X(07). DATEUTIL 161700/**************************************************************** DATEUTIL 161800* L I N K A G E S E C T I O N * DATEUTIL 161900***************************************************************** DATEUTIL 162000 LINKAGE SECTION. DATEUTIL 162100 01 L-PARM. DATEUTIL 162200 COPY DATEUTIL. DATEUTIL 162300 10 FILLER REDEFINES DU-DATE-2-FORMAT DATEUTIL 162400 OCCURS 20 TIMES DATEUTIL 162500 INDEXED BY L-FORMAT-NDX. DATEUTIL 162600 15 L-FORMAT-BYTE PIC X(01). DATEUTIL 162700 05 FILLER REDEFINES DATEUTIL-WORK-AREA. DATEUTIL 162800 10 FILLER PIC X(02). DATEUTIL 162900 10 L-ISPF-FUNCTION PIC X(04). DATEUTIL 163000 88 L-CALLED-FROM-ISPF VALUE 'ISPF'. DATEUTIL 085700 10 FILLER PIC X(122). DQF20115 163200 PROCEDURE DIVISION USING L-PARM. DATEUTIL 163300***************************************************************** DATEUTIL 163400* P R O C E D U R E D I V I S I O N * DATEUTIL 163500***************************************************************** DATEUTIL 163600***************************************************************** DATEUTIL 163700* S0000-CONTROL * DATEUTIL 163800* THIS SECTION CONTROLS THE MAIN PROCESSING OF THE PROGRAM. * DATEUTIL 163900***************************************************************** DATEUTIL 164000 S0000-CONTROL SECTION. DATEUTIL 164100 DATEUTIL 164200 PERFORM S1000-INITIALIZATION. DATEUTIL 164300 DATEUTIL 164400 PERFORM S2000-MAINLINE. DATEUTIL 164500 DATEUTIL 164600 PERFORM S3000-FINALIZATION. DATEUTIL 164700 DATEUTIL 164800 S0000-EXIT. DATEUTIL 164900 EXIT. DATEUTIL 165000/**************************************************************** DATEUTIL 165100* S1000-INITIALIZATION * DATEUTIL 165200* THIS SECTION DEALS WITH THE INPUT PASSED BY THE USER. IF THE * DATEUTIL 165300* PROGRAM IS BEING CALLED FROM AN ISPF ENVIRONMENT, THE ISPF * DATEUTIL 165400* INITIALIZATION PROCESS IS INVOKED. THE INPUT DATE IS PARSED * DATEUTIL 165500* OR THE SYSTEM DATE IS RETRIEVED AS THE INPUT DATE. * DATEUTIL 165600***************************************************************** DATEUTIL 165700 S1000-INITIALIZATION SECTION. DATEUTIL 165800 DATEUTIL 165801 INITIALIZE W-RETURN-CODE. DQA17322 165810 DATEUTIL 165900 IF L-CALLED-FROM-ISPF DATEUTIL 166000 PERFORM S1100-ISPF-INITIALIZATION DATEUTIL 166100 END-IF. DATEUTIL 166200 DATEUTIL 166300 IF DU-FUNCTION = 'SYSTEM' OR DU-DATE-1 = SPACES DATEUTIL 089200 PERFORM S1200-GET-SYSTEM-DATE DQF20115 166500 ELSE DATEUTIL 089400 IF DU-DATE-1-VALID-CODE DQF20115 089500 MOVE DU-DATE-1-FORMAT-CODE TO W-FORMAT-CODE DQF20115 089600 PERFORM S1300-CONVERT-FORMAT-CODE DQF20115 089700 ELSE DQF20115 089800 MOVE DU-DAY-1-FORMAT TO W-HOLD-DAY-FORMAT DQF20115 089900 MOVE DU-MONTH-1-FORMAT TO W-HOLD-MONTH-FORMAT DQF20115 090000 MOVE DU-YEAR-1-FORMAT TO W-HOLD-YEAR-FORMAT DQF20115 090100 MOVE DU-DATE-1-FORMAT TO W-HOLD-DATE-FORMAT DQF20115 090200 END-IF DQF20115 090300 MOVE DU-DATE-1 TO W-HOLD-DATE DQF20115 090400 IF DU-YEAR-1-SWITCH IS NUMERIC DQF20115 090500 IF DU-YEAR-2-SWITCH IS NOT NUMERIC DQF20115 090600 MOVE W-SWITCH-YEAR TO DQF20115 090700 DU-YEAR-2-SWITCH-NUM DQF20115 090800 END-IF DQF20115 090900 MOVE DU-YEAR-1-SWITCH-NUM TO W-SWITCH-YEAR DQF20115 091000 END-IF DQF20115 167100 PERFORM S9100-PARSE-DATE DATEUTIL 167200 PERFORM S9200-CONVERT-TO-JULIAN DATEUTIL 167300 END-IF. DATEUTIL 167400 DATEUTIL 167410 IF DU-DATE-2 > SPACES DATEUTIL 167420 IF DU-FUNCTION = SPACES DATEUTIL 167430 MOVE 'BETWEEN' TO DU-FUNCTION DATEUTIL 167440 END-IF DATEUTIL 167450 END-IF. DATEUTIL 167460 DATEUTIL 167470 IF DU-FUNCTION = SPACES OR 'SYSTEM' DATEUTIL 167480 MOVE 'CONVERT' TO DU-FUNCTION DATEUTIL 167490 END-IF. DATEUTIL 167491 DATEUTIL 167500 S1000-EXIT. DATEUTIL 167600 EXIT. DATEUTIL 167700/**************************************************************** DATEUTIL 167800* S1100-ISPF-INITIALIZATION * DATEUTIL 167900* THIS SECTION INVOKES ISPF SERVICES TO ESTABLISH ADDRESSABILITY* DATEUTIL 168000* TO ISPF OF CERTAIN WORKING STORAGE AREAS. IT THEN INVOKES * DATEUTIL 168100* PROCESSING TO RETRIEVE THE ISPF VARIABLES INTO THE WORKING * DATEUTIL 168200* STORAGE AREAS. * DATEUTIL 168300***************************************************************** DATEUTIL 168400 S1100-ISPF-INITIALIZATION SECTION. DATEUTIL 168500 DATEUTIL 168600 SET S-INVOKED-FROM-ISPF TO TRUE. DATEUTIL 168700 DATEUTIL 168800 CALL C-ISPF USING C-CONTROL C-ERRORS-OPTION C-RETURN-OPTION. DATEUTIL 168900 DATEUTIL 169000 CALL C-ISPF USING C-VDEFINE C-ISPF-VARIABLE-NAMES, DATEUTIL 169100 DATEUTIL-WORK-AREA, DATEUTIL 169200 C-ISPF-VARIABLE-FORMATS, DATEUTIL 169300 C-ISPF-VARIABLE-LENGTHS, DATEUTIL 169400 C-LIST-OPTION. DATEUTIL 169500 DATEUTIL 169600 IF RETURN-CODE > 4 DATEUTIL 169700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 169800 STRING 'DU2000-ISPF "VDEFINE" FAILED. PROGRAM OR ' DATEUTIL 169900 'ISPF PROBLEM. ' DATEUTIL 170000 DELIMITED BY SIZE DATEUTIL 170100 INTO DATEUTIL-MESSAGE DATEUTIL 170200 MOVE +2000 TO W-RETURN-CODE DATEUTIL 170300 PERFORM S3000-FINALIZATION DATEUTIL 170400 ELSE DATEUTIL 170500 MOVE C-VGET TO W-ISPF-SERVICE DATEUTIL 170600 MOVE SPACES TO DATEUTIL-WORK-AREA DATEUTIL 170700 PERFORM S9300-ISPF-VGET-VPUT DATEUTIL 170800 IF DU-FUNCTION = 'INCREMENT' OR 'DECREMENT' DATEUTIL 170900 MOVE DU-NUMBER TO W-NUMBER-ARRAY DATEUTIL 096000 SET W-NUM-NDX2 TO +8 DQF20115 096100 PERFORM VARYING W-NUM-NDX1 FROM +8 BY -1 DQF20115 171200 UNTIL W-NUM-NDX1 < +1 DATEUTIL 171300 EVALUATE TRUE DATEUTIL 171400 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 171500 IS NUMERIC DATEUTIL 171600 MOVE W-NUMBER-ARRAY-BYTE (W-NUM-NDX1)DATEUTIL 171700 TO W-NUMBER-ARRAY-BYTE (W-NUM-NDX2)DATEUTIL 171800 SET W-NUM-NDX2 DOWN BY +1 DATEUTIL 171900 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 172000 = ' ' DATEUTIL 172100 CONTINUE DATEUTIL 172200 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 172300 = LOW-VALUES DATEUTIL 172400 CONTINUE DATEUTIL 172500 WHEN OTHER DATEUTIL 172600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 172700 STRING 'DU2037-THE INCREMENT OR ' DATEUTIL 172800 'DECREMENT NUMBER MUST BE ' DATEUTIL 172900 'A POSITIVE INTEGER VALUE.' DATEUTIL 173000 DELIMITED BY SIZE DATEUTIL 173100 INTO DATEUTIL-MESSAGE DATEUTIL 173200 MOVE +2037 TO W-RETURN-CODE DATEUTIL 173300 PERFORM S3000-FINALIZATION DATEUTIL 173400 END-EVALUATE DATEUTIL 173500 END-PERFORM DATEUTIL 173600 PERFORM VARYING W-NUM-NDX2 FROM W-NUM-NDX2 BY -1 DATEUTIL 173700 UNTIL W-NUM-NDX2 < +1 DATEUTIL 173800 MOVE '0' TO W-NUMBER-ARRAY-BYTE (W-NUM-NDX2) DATEUTIL 173900 END-PERFORM DATEUTIL 174000 MOVE W-HOLD-NUMBER TO DU-NUMBER DATEUTIL 174100 END-IF DATEUTIL 174200 END-IF. DATEUTIL 174300 DATEUTIL 099400 IF DU-YEAR-1-SWITCH = '0 ' OR DQF20115 099500 '1 ' OR DQF20115 099600 '2 ' OR DQF20115 099700 '3 ' OR DQF20115 099800 '4 ' OR DQF20115 099900 '5 ' OR DQF20115 100000 '6 ' OR DQF20115 100100 '7 ' OR DQF20115 100200 '8 ' OR DQF20115 100300 '9 ' DQF20115 100400 INSPECT DU-YEAR-1-SWITCH REPLACING ALL SPACES BY ZEROS DQF20115 100500 COMPUTE DU-YEAR-1-SWITCH-NUM = DU-YEAR-1-SWITCH-NUM / 10 DQF20115 100600 END-IF. DQF20115 100700 DQF20115 100800 IF DU-DATE-1-FORMAT-CODE-A = '1 ' OR DQF20115 100900 '2 ' OR DQF20115 101000 '3 ' OR DQF20115 101100 '4 ' OR DQF20115 101200 '5 ' OR DQF20115 101300 '6 ' OR DQF20115 101400 '7 ' OR DQF20115 101500 '8 ' OR DQF20115 101600 '9 ' DQF20115 101700 INSPECT DU-DATE-1-FORMAT-CODE-A DQF20115 101800 REPLACING ALL SPACES BY ZEROS DQF20115 101900 COMPUTE DU-DATE-1-FORMAT-CODE = DQF20115 102000 DU-DATE-1-FORMAT-CODE / 10 DQF20115 102100 END-IF. DQF20115 102200 DQF20115 102300 IF DU-YEAR-2-SWITCH = '0 ' OR DQF20115 102400 '1 ' OR DQF20115 102500 '2 ' OR DQF20115 102600 '3 ' OR DQF20115 102700 '4 ' OR DQF20115 102800 '5 ' OR DQF20115 102900 '6 ' OR DQF20115 103000 '7 ' OR DQF20115 103100 '8 ' OR DQF20115 103200 '9 ' DQF20115 103300 INSPECT DU-YEAR-2-SWITCH REPLACING ALL SPACES BY ZEROS DQF20115 103400 COMPUTE DU-YEAR-2-SWITCH-NUM = DU-YEAR-2-SWITCH-NUM / 10 DQF20115 103500 END-IF. DQF20115 103600 DQF20115 103700 IF DU-DATE-2-FORMAT-CODE-A = '1 ' OR DQF20115 103800 '2 ' OR DQF20115 103900 '3 ' OR DQF20115 104000 '4 ' OR DQF20115 104100 '5 ' OR DQF20115 104200 '6 ' OR DQF20115 104300 '7 ' OR DQF20115 104400 '8 ' OR DQF20115 104500 '9 ' DQF20115 104600 INSPECT DU-DATE-2-FORMAT-CODE-A DQF20115 104700 REPLACING ALL SPACES BY ZEROS DQF20115 104800 COMPUTE DU-DATE-2-FORMAT-CODE = DQF20115 104900 DU-DATE-2-FORMAT-CODE / 10 DQF20115 105000 END-IF. DQF20115 105100 DQF20115 174400 S1100-EXIT. DATEUTIL 105300 EXIT. DQF20115 105400/**************************************************************** DQF20115 105500* S1200-GET-SYSTEM-DATE * DQF20115 105600* THIS SECTION RETRIEVES THE SYSTEM DATE AND SETS DEFAULT * DQF20115 105700* FUNCTIONS IF NECESSARY. IT ALSO SETS FORMAT FIELDS BASED ON * DQF20115 105800* THE SYSTEM DATE BEING A JULIAN DATE. * DQF20115 105900***************************************************************** DQF20115 106000 S1200-GET-SYSTEM-DATE SECTION. DQF20115 106100 DQF20115 106200 ACCEPT W-SYSDATE FROM DAY. DQF20115 106300 DQF20115 106400 IF W-SYSDATE-DECADE < 90 DQF20115 106500 MOVE '20' TO W-JULIAN-CENTURY DQF20115 106600 W-WORK-CENTURY DQF20115 106700 ELSE DQF20115 106800 MOVE '19' TO W-JULIAN-CENTURY DQF20115 106900 W-WORK-CENTURY DQF20115 107000 END-IF. DQF20115 107100 DQF20115 107200 MOVE W-SYSDATE-DDD TO W-JULIAN-DDD DQF20115 107300 W-WORK-DDD. DQF20115 107400 DQF20115 107500 MOVE W-SYSDATE-DECADE TO W-JULIAN-DECADE DQF20115 107600 W-WORK-DECADE. DQF20115 107700 DQF20115 107800 MOVE W-WORK-JULIAN TO W-WORK-ARRAY DQF20115 107900 DU-DATE-1. DQF20115 108000 DQF20115 108100 MOVE 'DDD' TO DU-DAY-1-FORMAT. DQF20115 108200 MOVE SPACES TO DU-MONTH-1-FORMAT. DQF20115 108300 MOVE 'YYYY' TO DU-YEAR-1-FORMAT. DQF20115 108400 MOVE 'YD' TO DU-DATE-1-FORMAT. DQF20115 108500 DQF20115 108600 S1200-EXIT. DQF20115 108700 EXIT. DQF20115 108800/*****************************************************************DQF20115 108900* S1300-CONVERT-FORMAT-CODE *DQF20115 109000* THIS SECTION CONVERTS AN INPUT FORMAT "CODE" INTO ITS REAL *DQF20115 109100* FORMAT VALUES IN THE W-HOLD FIELDS. *DQF20115 109200******************************************************************DQF20115 109300 S1300-CONVERT-FORMAT-CODE SECTION. DQF20115 109400 DQF20115 109500 EVALUATE W-FORMAT-CODE DQF20115 109600 WHEN 1 DQF20115 109700 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DQF20115 109800 WHEN 2 DQF20115 109900 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DQF20115 110000 WHEN 3 DQF20115 110100 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DQF20115 110200 WHEN 4 DQF20115 110300 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DQF20115 110400 WHEN 5 DQF20115 110500 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DQF20115 110600 WHEN 6 DQF20115 110700 MOVE 'M-D-Y' TO W-HOLD-DATE-FORMAT DQF20115 110800 WHEN 7 DQF20115 110900 MOVE 'M.D.Y' TO W-HOLD-DATE-FORMAT DQF20115 111000 WHEN 8 DQF20115 111100 MOVE 'M/D/Y' TO W-HOLD-DATE-FORMAT DQF20115 111200 WHEN 9 DQF20115 111300 MOVE 'M D Y' TO W-HOLD-DATE-FORMAT DQF20115 111400 WHEN 10 DQF20115 111500 MOVE 'MDY' TO W-HOLD-DATE-FORMAT DQF20115 111600 WHEN 11 DQF20115 111700 MOVE 'Y-D' TO W-HOLD-DATE-FORMAT DQF20115 111800 WHEN 12 DQF20115 111900 MOVE 'Y.D' TO W-HOLD-DATE-FORMAT DQF20115 112000 WHEN 13 DQF20115 112100 MOVE 'Y/D' TO W-HOLD-DATE-FORMAT DQF20115 112200 WHEN 14 DQF20115 112300 MOVE 'Y D' TO W-HOLD-DATE-FORMAT DQF20115 112400 WHEN 15 DQF20115 112500 MOVE 'YD' TO W-HOLD-DATE-FORMAT DQF20115 112600 WHEN 16 DQF20115 112700 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DQF20115 112800 WHEN 17 DQF20115 112900 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DQF20115 113000 WHEN 18 DQF20115 113100 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DQF20115 113200 WHEN 19 DQF20115 113300 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DQF20115 113400 WHEN 20 DQF20115 113500 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DQF20115 113600 WHEN 21 DQF20115 113700 MOVE 'M-D-Y' TO W-HOLD-DATE-FORMAT DQF20115 113800 WHEN 22 DQF20115 113900 MOVE 'M.D.Y' TO W-HOLD-DATE-FORMAT DQF20115 114000 WHEN 23 DQF20115 114100 MOVE 'M/D/Y' TO W-HOLD-DATE-FORMAT DQF20115 114200 WHEN 24 DQF20115 114300 MOVE 'M D Y' TO W-HOLD-DATE-FORMAT DQF20115 114400 WHEN 25 DQF20115 114500 MOVE 'MDY' TO W-HOLD-DATE-FORMAT DQF20115 114600 WHEN 26 DQF20115 114700 MOVE 'Y-D' TO W-HOLD-DATE-FORMAT DQF20115 114800 WHEN 27 DQF20115 114900 MOVE 'Y.D' TO W-HOLD-DATE-FORMAT DQF20115 115000 WHEN 28 DQF20115 115100 MOVE 'Y/D' TO W-HOLD-DATE-FORMAT DQF20115 115200 WHEN 29 DQF20115 115300 MOVE 'Y D' TO W-HOLD-DATE-FORMAT DQF20115 115400 WHEN 30 DQF20115 115500 MOVE 'YD' TO W-HOLD-DATE-FORMAT DQF20115 115600 WHEN 31 DQF20115 115700 MOVE 'D-M-Y' TO W-HOLD-DATE-FORMAT DQF20115 115800 WHEN 32 DQF20115 115900 MOVE 'D.M.Y' TO W-HOLD-DATE-FORMAT DQF20115 116000 WHEN 33 DQF20115 116100 MOVE 'D/M/Y' TO W-HOLD-DATE-FORMAT DQF20115 116200 WHEN 34 DQF20115 116300 MOVE 'D M Y' TO W-HOLD-DATE-FORMAT DQF20115 116400 WHEN 35 DQF20115 116500 MOVE 'DMY' TO W-HOLD-DATE-FORMAT DQF20115 116600 WHEN 36 DQF20115 116700 MOVE 'D-M-Y' TO W-HOLD-DATE-FORMAT DQF20115 116800 WHEN 37 DQF20115 116900 MOVE 'D.M.Y' TO W-HOLD-DATE-FORMAT DQF20115 117000 WHEN 38 DQF20115 117100 MOVE 'D/M/Y' TO W-HOLD-DATE-FORMAT DQF20115 117200 WHEN 39 DQF20115 117300 MOVE 'D M Y' TO W-HOLD-DATE-FORMAT DQF20115 117400 WHEN 40 DQF20115 117500 MOVE 'DMY' TO W-HOLD-DATE-FORMAT DQF20115 117600 WHEN 41 DQF20115 117700 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DQF20115 117800 WHEN 42 DQF20115 117900 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DQF20115 118000 WHEN 43 DQF20115 118100 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DQF20115 118200 WHEN 44 DQF20115 118300 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DQF20115 118400 WHEN 45 DQF20115 118500 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DQF20115 118600 WHEN 46 DQF20115 118700 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DQF20115 118800 WHEN 47 DQF20115 118900 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DQF20115 119000 WHEN 48 DQF20115 119100 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DQF20115 119200 WHEN 49 DQF20115 119300 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DQF20115 119400 WHEN 50 DQF20115 119500 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DQF20115 119600 WHEN 51 DQF20115 119700 MOVE 'M D, Y' TO W-HOLD-DATE-FORMAT DQF20115 119800 WHEN 52 DQF20115 119900 MOVE 'M D, Y' TO W-HOLD-DATE-FORMAT DQF20115 120000 WHEN 53 DQF20115 120100 MOVE 'D' TO W-HOLD-DATE-FORMAT DQF20115 120200 WHEN 54 DQF20115 120300 MOVE 'D' TO W-HOLD-DATE-FORMAT DQF20115 120400 WHEN OTHER DQF20115 120500 STRING 'DU2038-INVALID FORMAT CODE PASSED. CODE ' DQF20115 120600 'PASSED WAS: ' DQF20115 120700 W-FORMAT-CODE DQF20115 120800 DELIMITED BY SIZE DQF20115 120900 INTO DATEUTIL-MESSAGE DQF20115 121000 MOVE +2038 TO W-RETURN-CODE DQF20115 121100 PERFORM S3000-FINALIZATION DQF20115 121200 END-EVALUATE. DQF20115 121300 DQF20115 121400 EVALUATE TRUE DQF20115 121500 WHEN W-YYYY-FORMAT DQF20115 121600 MOVE 'YYYY' TO W-HOLD-YEAR-FORMAT DQF20115 121700 WHEN W-YY-FORMAT DQF20115 121800 MOVE 'YY' TO W-HOLD-YEAR-FORMAT DQF20115 121900 WHEN OTHER DQF20115 122000 MOVE SPACES TO W-HOLD-YEAR-FORMAT DQF20115 122100 END-EVALUATE. DQF20115 122200 DQF20115 122300 EVALUATE TRUE DQF20115 122400 WHEN W-MM-FORMAT DQF20115 122500 MOVE 'MM' TO W-HOLD-MONTH-FORMAT DQF20115 122600 WHEN W-MMM-FORMAT DQF20115 122700 MOVE 'MMM' TO W-HOLD-MONTH-FORMAT DQF20115 122800 WHEN W-MONTH-FORMAT DQF20115 122900 MOVE 'MONTH' TO W-HOLD-MONTH-FORMAT DQF20115 123000 WHEN OTHER DQF20115 123100 MOVE SPACES TO W-HOLD-MONTH-FORMAT DQF20115 123200 END-EVALUATE. DQF20115 123300 DQF20115 123400 EVALUATE TRUE DQF20115 123500 WHEN W-D-FORMAT DQF20115 123600 MOVE 'D' TO W-HOLD-DAY-FORMAT DQF20115 123700 WHEN W-DD-FORMAT DQF20115 123800 MOVE 'DD' TO W-HOLD-DAY-FORMAT DQF20115 123900 WHEN W-DDD-FORMAT DQF20115 124000 MOVE 'DDD' TO W-HOLD-DAY-FORMAT DQF20115 124100 WHEN W-DAY-FORMAT DQF20115 124200 MOVE 'DAY' TO W-HOLD-DAY-FORMAT DQF20115 124300 WHEN W-ZD-FORMAT DQF20115 124400 MOVE 'ZD' TO W-HOLD-DAY-FORMAT DQF20115 124500 WHEN OTHER DQF20115 124600 MOVE SPACES TO W-HOLD-DAY-FORMAT DQF20115 124700 END-EVALUATE. DQF20115 124800 DQF20115 124900 S1300-EXIT. DQF20115 174500 EXIT. DATEUTIL 174600/**************************************************************** DATEUTIL 174700* S2000-MAINLINE * DATEUTIL 174800* THIS SECTION DIRECTS THE PROCESSING TO PARTICULAR SUB-ROUTINES* DATEUTIL 174900* BASED ON THE FUNCTION WHICH THE USER REQUESTED. * DATEUTIL 175000***************************************************************** DATEUTIL 175100 S2000-MAINLINE SECTION. DATEUTIL 175200 DATEUTIL 175300 EVALUATE TRUE DATEUTIL 175400 WHEN DU-FUNCTION = 'CONVERT' DATEUTIL 175500 PERFORM S4000-CONVERT DATEUTIL 175600 WHEN DU-FUNCTION = 'BETWEEN' DATEUTIL 175700 PERFORM S5000-BETWEEN DATEUTIL 175800 WHEN DU-FUNCTION = 'INCREMENT' DATEUTIL 175900 PERFORM S6000-INCREMENT DATEUTIL 176000 WHEN DU-FUNCTION = 'DECREMENT' DATEUTIL 176100 PERFORM S7000-DECREMENT DATEUTIL 176200 WHEN OTHER DATEUTIL 176300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 176400 STRING 'DU2001-FUNCTION COULD NOT BE DETERMINED ' DATEUTIL 176500 'OR FUNCTION SPECIFIED WAS INVALID.' DATEUTIL 176600 DELIMITED BY SIZE DATEUTIL 176700 INTO DATEUTIL-MESSAGE DATEUTIL 176800 MOVE +2001 TO W-RETURN-CODE DATEUTIL 176900 PERFORM S3000-FINALIZATION DATEUTIL 177000 END-EVALUATE. DATEUTIL 177100 DATEUTIL 177200 S2000-EXIT. DATEUTIL 177300 EXIT. DATEUTIL 177400/**************************************************************** DATEUTIL 177500* S3000-FINALIZATION * DATEUTIL 177600* THIS SECTION DOES THREE THINGS. * DATEUTIL 177700* FIRST IT RETURNS THE RESULTS TO THE ISPF SHARED VARIABLE POOL * DATEUTIL 177800* IF THIS IS AN ISPF INVOKED PROCESS. * DATEUTIL 177900* SECOND, IT SETS THE RETURN CODE FOR THE PROGRAM. * DATEUTIL 178000* THIRD, IT RETURNS CONTROL TO THE CALLING PROGRAM. * DATEUTIL 178100***************************************************************** DATEUTIL 178200 S3000-FINALIZATION SECTION. DATEUTIL 178300 DATEUTIL 178400 IF S-INVOKED-FROM-ISPF DATEUTIL 178500 MOVE C-VPUT TO W-ISPF-SERVICE DATEUTIL 178600 PERFORM S9300-ISPF-VGET-VPUT DATEUTIL 178700 END-IF. DATEUTIL 178800 DATEUTIL 178900 MOVE W-RETURN-CODE TO RETURN-CODE. DATEUTIL 179000 DATEUTIL 179100 GOBACK. DATEUTIL 179200 DATEUTIL 179300 S3000-EXIT. DATEUTIL 179400 EXIT. DATEUTIL 179500/**************************************************************** DATEUTIL 183100* S4000-CONVERT * DATEUTIL 183200* THIS PROCESS CONVERTS THE JULIAN WORK DATE INTO THE FORMAT * DATEUTIL 183300* WHICH THE USER WANTS FOR DATE 2. * DATEUTIL 183400***************************************************************** DATEUTIL 183500 S4000-CONVERT SECTION. DATEUTIL 183600 DATEUTIL 130700**** DQF20115 130800**** SEE IF THE DATE 2 FORMAT IS ONE OF THE AUTOMATIC ONES **** DQF20115 130900**** DQF20115 131000 IF DU-DATE-2-VALID-CODE DQF20115 131100 MOVE DU-DATE-2-FORMAT-CODE TO W-FORMAT-CODE DQF20115 131200 PERFORM S1300-CONVERT-FORMAT-CODE DQF20115 131300 MOVE W-HOLD-DAY-FORMAT TO DU-DAY-2-FORMAT DQF20115 131400 MOVE W-HOLD-MONTH-FORMAT TO DU-MONTH-2-FORMAT DQF20115 131500 MOVE W-HOLD-YEAR-FORMAT TO DU-YEAR-2-FORMAT DQF20115 131600 MOVE W-HOLD-DATE-FORMAT TO DU-DATE-2-FORMAT DQF20115 131700 END-IF. DQF20115 131800 DQF20115 131900**** DQF20115 183700**** MAKE SURE WE HAVE THE NEEDED FORMAT 2 COMPONENTS **** DATEUTIL 132100**** DQF20115 183800 IF (DU-DAY-2-FORMAT = SPACES AND DATEUTIL 183900 DU-MONTH-2-FORMAT = SPACES AND DATEUTIL 184000 DU-YEAR-2-FORMAT = SPACES) OR DATEUTIL 184100 (DU-DATE-2-FORMAT = SPACES) DATEUTIL 184200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 184300 STRING 'DU2036-AT LEAST ONE "DAY", "MONTH", OR "YEAR" ' DATEUTIL 184400 ' FORMAT COMPONENT AND ONE "DATE" FORMAT MUST ' DATEUTIL 132900 'BE SPECIFIED FOR "DATE 2".' DQF20115 184600 DELIMITED BY SIZE DATEUTIL 184700 INTO DATEUTIL-MESSAGE DATEUTIL 184800 MOVE +2036 TO W-RETURN-CODE DATEUTIL 184900 PERFORM S3000-FINALIZATION DATEUTIL 185000 END-IF. DATEUTIL 185100 DATEUTIL 133600**** DQF20115 185200**** INITIALIZE THE WORK DATES **** DATEUTIL 133800**** DQF20115 185300 MOVE SPACES TO W-WORK-MONTH DATEUTIL 185400 W-WORK-DAY DATEUTIL 185500 W-WORK-YEAR. DATEUTIL 185600 DATEUTIL 134300**** DQF20115 185700**** LOAD THE DAY COMPONENT INTO THE WORK DATE **** DATEUTIL 134500**** DQF20115 185800 EVALUATE DU-DAY-2-FORMAT DATEUTIL 185900 WHEN 'DDD' DATEUTIL 186000 MOVE W-JULIAN-DDD TO W-WORK-DDD DATEUTIL 186100 MOVE +3 TO W-DAY-LENGTH DATEUTIL 186200 WHEN 'ZZD' DATEUTIL 186300 MOVE W-JULIAN-DDD TO W-WORK-DDD DATEUTIL 186400 MOVE +3 TO W-DAY-LENGTH DATEUTIL 186500 WHEN 'DD' DATEUTIL 186600 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 186700 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 186800 SET T-MON-NDX TO +1 DATEUTIL 186900 IF S-IS-A-LEAP-YEAR DATEUTIL 187000 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 187100 AT END PERFORM 1 TIMES DATEUTIL 187200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 187300 STRING 'DU2002-"' W-JULIAN-DDD DATEUTIL 187400 '" IS NOT A VALID DAY IN ' DATEUTIL 187500 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 187600 DELIMITED BY SIZE DATEUTIL 187700 INTO DATEUTIL-MESSAGE DATEUTIL 187800 MOVE +2002 TO W-RETURN-CODE DATEUTIL 187900 PERFORM S3000-FINALIZATION DATEUTIL 188000 END-PERFORM DATEUTIL 188100 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 188200 W-JULIAN-DDD OR DATEUTIL 188300 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 188400 W-JULIAN-DDD) AND DATEUTIL 188500 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 188600 W-JULIAN-DDD OR DATEUTIL 188700 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 188800 W-JULIAN-DDD) DATEUTIL 188900 COMPUTE W-WORK-DD = DATEUTIL 189000 W-JULIAN-DDD DATEUTIL 189100 - T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 189200 + 1 DATEUTIL 189300 END-SEARCH DATEUTIL 189400 ELSE DATEUTIL 189500 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 189600 AT END PERFORM 1 TIMES DATEUTIL 189700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 189800 STRING 'DU2003-"' W-JULIAN-DDD DATEUTIL 189900 '" IS NOT A VALID DAY IN ' DATEUTIL 190000 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 190100 DELIMITED BY SIZE DATEUTIL 190200 INTO DATEUTIL-MESSAGE DATEUTIL 190300 MOVE +2003 TO W-RETURN-CODE DATEUTIL 190400 PERFORM S3000-FINALIZATION DATEUTIL 190500 END-PERFORM DATEUTIL 190600 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 190700 W-JULIAN-DDD OR DATEUTIL 190800 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 190900 W-JULIAN-DDD) AND DATEUTIL 191000 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 191100 W-JULIAN-DDD OR DATEUTIL 191200 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 191300 W-JULIAN-DDD) DATEUTIL 191400 COMPUTE W-WORK-DD = DATEUTIL 191500 W-JULIAN-DDD DATEUTIL 191600 - T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 191700 + 1 DATEUTIL 191800 END-SEARCH DATEUTIL 191900 END-IF DATEUTIL 192000 MOVE +2 TO W-DAY-LENGTH DATEUTIL 192100 WHEN 'ZD' DATEUTIL 192200 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 192300 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 192400 SET T-MON-NDX TO +1 DATEUTIL 192500 IF S-IS-A-LEAP-YEAR DATEUTIL 192600 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 192700 AT END PERFORM 1 TIMES DATEUTIL 192800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 192900 STRING 'DU2002-"' W-JULIAN-DDD DATEUTIL 193000 '" IS NOT A VALID DAY IN ' DATEUTIL 193100 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 193200 DELIMITED BY SIZE DATEUTIL 193300 INTO DATEUTIL-MESSAGE DATEUTIL 193400 MOVE +2002 TO W-RETURN-CODE DATEUTIL 193500 PERFORM S3000-FINALIZATION DATEUTIL 193600 END-PERFORM DATEUTIL 193700 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 193800 W-JULIAN-DDD OR DATEUTIL 193900 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 194000 W-JULIAN-DDD) AND DATEUTIL 194100 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 194200 W-JULIAN-DDD OR DATEUTIL 194300 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 194400 W-JULIAN-DDD) DATEUTIL 194500 COMPUTE W-WORK-DD = DATEUTIL 194600 W-JULIAN-DDD DATEUTIL 194700 - T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 194800 + 1 DATEUTIL 194900 END-SEARCH DATEUTIL 195000 ELSE DATEUTIL 195100 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 195200 AT END PERFORM 1 TIMES DATEUTIL 195300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 195400 STRING 'DU2003-"' W-JULIAN-DDD DATEUTIL 195500 '" IS NOT A VALID DAY IN ' DATEUTIL 195600 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 195700 DELIMITED BY SIZE DATEUTIL 195800 INTO DATEUTIL-MESSAGE DATEUTIL 195900 MOVE +2003 TO W-RETURN-CODE DATEUTIL 196000 PERFORM S3000-FINALIZATION DATEUTIL 196100 END-PERFORM DATEUTIL 196200 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 196300 W-JULIAN-DDD OR DATEUTIL 196400 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 196500 W-JULIAN-DDD) AND DATEUTIL 196600 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 196700 W-JULIAN-DDD OR DATEUTIL 196800 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 196900 W-JULIAN-DDD) DATEUTIL 197000 COMPUTE W-WORK-DD = DATEUTIL 197100 W-JULIAN-DDD DATEUTIL 197200 - T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 197300 + 1 DATEUTIL 197400 END-SEARCH DATEUTIL 197500 END-IF DATEUTIL 197600 MOVE +2 TO W-DAY-LENGTH DATEUTIL 197700 WHEN 'DAY' DATEUTIL 146600 PERFORM S4100-FIND-DAY-OF-WEEK DQF20115 200200 SET T-DAY-NDX TO W-WORK-D DATEUTIL 200300 MOVE T-DAY-NAME (T-DAY-NDX) TO W-WORK-DAY DATEUTIL 200400 PERFORM VARYING W-DAY-NDX1 FROM +9 BY -1 DATEUTIL 200500 UNTIL W-DAY-ARRAY-BYTE (W-DAY-NDX1) > SPACE DATEUTIL 200600 END-PERFORM DATEUTIL 200700 SET W-DAY-LENGTH TO W-DAY-NDX1 DATEUTIL 200800 WHEN 'DA' DATEUTIL 147400 PERFORM S4100-FIND-DAY-OF-WEEK DQF20115 203300 SET T-DAY-NDX TO W-WORK-D DATEUTIL 203400 MOVE T-DAY-NAME-ABBR (T-DAY-NDX) TO W-WORK-DAY-AB2 DATEUTIL 203500 MOVE +2 TO W-DAY-LENGTH DATEUTIL 203600 WHEN 'D' DATEUTIL 147900 PERFORM S4100-FIND-DAY-OF-WEEK DQF20115 206100 MOVE +1 TO W-DAY-LENGTH DATEUTIL 206200 WHEN SPACES CONTINUE DATEUTIL 206300 WHEN OTHER DATEUTIL 206400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 206500 STRING 'DU2007-"' DU-DAY-2-FORMAT '" IS NOT ' DATEUTIL 206600 'A VALID DAY FORMAT. VALID FORMATS ARE ' DATEUTIL 206700 '"D", "DD", "DDD", "DA", AND "DAY".' DATEUTIL 206800 DELIMITED BY SIZE DATEUTIL 206900 INTO DATEUTIL-MESSAGE DATEUTIL 207000 MOVE +2007 TO W-RETURN-CODE DATEUTIL 207100 PERFORM S3000-FINALIZATION DATEUTIL 207200 END-EVALUATE. DATEUTIL 207300 DATEUTIL 149300**** DQF20115 207400**** LOAD THE MONTH COMPONENT INTO THE WORK MONTH **** DATEUTIL 149500**** DQF20115 207500 EVALUATE DU-MONTH-2-FORMAT DATEUTIL 207600 WHEN 'MM' DATEUTIL 207700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 207800 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 207900 SET T-MON-NDX TO +1 DATEUTIL 208000 IF S-IS-A-LEAP-YEAR DATEUTIL 208100 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 208200 AT END PERFORM 1 TIMES DATEUTIL 208300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 208400 STRING 'DU2008-"' W-JULIAN-DDD DATEUTIL 208500 '" IS NOT A VALID DAY IN ' DATEUTIL 208600 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 208700 DELIMITED BY SIZE DATEUTIL 208800 INTO DATEUTIL-MESSAGE DATEUTIL 208900 MOVE +2008 TO W-RETURN-CODE DATEUTIL 209000 PERFORM S3000-FINALIZATION DATEUTIL 209100 END-PERFORM DATEUTIL 209200 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 209300 W-JULIAN-DDD OR DATEUTIL 209400 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 209500 W-JULIAN-DDD) AND DATEUTIL 209600 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 209700 W-JULIAN-DDD OR DATEUTIL 209800 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 209900 W-JULIAN-DDD) DATEUTIL 210000 SET W-WORK-MM TO T-MON-NDX DATEUTIL 210100 END-SEARCH DATEUTIL 210200 ELSE DATEUTIL 210300 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 210400 AT END PERFORM 1 TIMES DATEUTIL 210500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 210600 STRING 'DU2009-"' W-JULIAN-DDD DATEUTIL 210700 '" IS NOT A VALID DAY IN ' DATEUTIL 210800 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 210900 DELIMITED BY SIZE DATEUTIL 211000 INTO DATEUTIL-MESSAGE DATEUTIL 211100 MOVE +2009 TO W-RETURN-CODE DATEUTIL 211200 PERFORM S3000-FINALIZATION DATEUTIL 211300 END-PERFORM DATEUTIL 211400 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 211500 W-JULIAN-DDD OR DATEUTIL 211600 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 211700 W-JULIAN-DDD) AND DATEUTIL 211800 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 211900 W-JULIAN-DDD OR DATEUTIL 212000 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 212100 W-JULIAN-DDD) DATEUTIL 212200 SET W-WORK-MM TO T-MON-NDX DATEUTIL 212300 END-SEARCH DATEUTIL 212400 END-IF DATEUTIL 212500 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 212600 WHEN 'ZM' DATEUTIL 212700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 212800 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 212900 SET T-MON-NDX TO +1 DATEUTIL 213000 IF S-IS-A-LEAP-YEAR DATEUTIL 213100 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 213200 AT END PERFORM 1 TIMES DATEUTIL 213300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 213400 STRING 'DU2008-"' W-JULIAN-DDD DATEUTIL 213500 '" IS NOT A VALID DAY IN ' DATEUTIL 213600 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 213700 DELIMITED BY SIZE DATEUTIL 213800 INTO DATEUTIL-MESSAGE DATEUTIL 213900 MOVE +2008 TO W-RETURN-CODE DATEUTIL 214000 PERFORM S3000-FINALIZATION DATEUTIL 214100 END-PERFORM DATEUTIL 214200 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 214300 W-JULIAN-DDD OR DATEUTIL 214400 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 214500 W-JULIAN-DDD) AND DATEUTIL 214600 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 214700 W-JULIAN-DDD OR DATEUTIL 214800 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 214900 W-JULIAN-DDD) DATEUTIL 215000 SET W-WORK-MM TO T-MON-NDX DATEUTIL 215100 END-SEARCH DATEUTIL 215200 ELSE DATEUTIL 215300 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 215400 AT END PERFORM 1 TIMES DATEUTIL 215500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 215600 STRING 'DU2009-"' W-JULIAN-DDD DATEUTIL 215700 '" IS NOT A VALID DAY IN ' DATEUTIL 215800 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 215900 DELIMITED BY SIZE DATEUTIL 216000 INTO DATEUTIL-MESSAGE DATEUTIL 216100 MOVE +2009 TO W-RETURN-CODE DATEUTIL 216200 PERFORM S3000-FINALIZATION DATEUTIL 216300 END-PERFORM DATEUTIL 216400 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 216500 W-JULIAN-DDD OR DATEUTIL 216600 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 216700 W-JULIAN-DDD) AND DATEUTIL 216800 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 216900 W-JULIAN-DDD OR DATEUTIL 217000 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 217100 W-JULIAN-DDD) DATEUTIL 217200 SET W-WORK-MM TO T-MON-NDX DATEUTIL 217300 END-SEARCH DATEUTIL 217400 END-IF DATEUTIL 217500 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 217600 WHEN 'MONTH' DATEUTIL 217700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 217800 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 217900 SET T-MON-NDX TO +1 DATEUTIL 218000 IF S-IS-A-LEAP-YEAR DATEUTIL 218100 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 218200 AT END PERFORM 1 TIMES DATEUTIL 218300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 218400 STRING 'DU2010-"' W-JULIAN-DDD DATEUTIL 218500 '" IS NOT A VALID DAY IN ' DATEUTIL 218600 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 218700 DELIMITED BY SIZE DATEUTIL 218800 INTO DATEUTIL-MESSAGE DATEUTIL 218900 MOVE +2010 TO W-RETURN-CODE DATEUTIL 219000 PERFORM S3000-FINALIZATION DATEUTIL 219100 END-PERFORM DATEUTIL 219200 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 219300 W-JULIAN-DDD OR DATEUTIL 219400 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 219500 W-JULIAN-DDD) AND DATEUTIL 219600 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 219700 W-JULIAN-DDD OR DATEUTIL 219800 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 219900 W-JULIAN-DDD) DATEUTIL 220000 MOVE T-MON-NAME (T-MON-NDX) TO DATEUTIL 220100 W-WORK-MONTH DATEUTIL 220200 END-SEARCH DATEUTIL 220300 ELSE DATEUTIL 220400 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 220500 AT END PERFORM 1 TIMES DATEUTIL 220600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 220700 STRING 'DU2011-"' W-JULIAN-DDD DATEUTIL 220800 '" IS NOT A VALID DAY IN ' DATEUTIL 220900 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 221000 DELIMITED BY SIZE DATEUTIL 221100 INTO DATEUTIL-MESSAGE DATEUTIL 221200 MOVE +2011 TO W-RETURN-CODE DATEUTIL 221300 PERFORM S3000-FINALIZATION DATEUTIL 221400 END-PERFORM DATEUTIL 221500 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 221600 W-JULIAN-DDD OR DATEUTIL 221700 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 221800 W-JULIAN-DDD) AND DATEUTIL 221900 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 222000 W-JULIAN-DDD OR DATEUTIL 222100 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 222200 W-JULIAN-DDD) DATEUTIL 222300 MOVE T-MON-NAME (T-MON-NDX) TO DATEUTIL 222400 W-WORK-MONTH DATEUTIL 222500 END-SEARCH DATEUTIL 222600 END-IF DATEUTIL 222700 PERFORM VARYING W-MONTH-NDX FROM +9 BY -1 DATEUTIL 222800 UNTIL W-MONTH-ARRAY-BYTE (W-MONTH-NDX) > SPACE DATEUTIL 222900 END-PERFORM DATEUTIL 223000 SET W-MONTH-LENGTH TO W-MONTH-NDX DATEUTIL 223100 WHEN 'MMM' DATEUTIL 223200 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 223300 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 223400 SET T-MON-NDX TO +1 DATEUTIL 223500 IF S-IS-A-LEAP-YEAR DATEUTIL 223600 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 223700 AT END PERFORM 1 TIMES DATEUTIL 223800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 223900 STRING 'DU2012-"' W-JULIAN-DDD DATEUTIL 224000 '" IS NOT A VALID DAY IN ' DATEUTIL 224100 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 224200 DELIMITED BY SIZE DATEUTIL 224300 INTO DATEUTIL-MESSAGE DATEUTIL 224400 MOVE +2012 TO W-RETURN-CODE DATEUTIL 224500 PERFORM S3000-FINALIZATION DATEUTIL 224600 END-PERFORM DATEUTIL 224700 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 224800 W-JULIAN-DDD OR DATEUTIL 224900 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 225000 W-JULIAN-DDD) AND DATEUTIL 225100 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 225200 W-JULIAN-DDD OR DATEUTIL 225300 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 225400 W-JULIAN-DDD) DATEUTIL 225500 MOVE T-MON-NAME-ABBR (T-MON-NDX) TO DATEUTIL 225600 W-WORK-MMM DATEUTIL 225700 END-SEARCH DATEUTIL 225800 ELSE DATEUTIL 225900 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 226000 AT END PERFORM 1 TIMES DATEUTIL 226100 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 226200 STRING 'DU2013-"' W-JULIAN-DDD DATEUTIL 226300 '" IS NOT A VALID DAY IN ' DATEUTIL 226400 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 226500 DELIMITED BY SIZE DATEUTIL 226600 INTO DATEUTIL-MESSAGE DATEUTIL 226700 MOVE +2013 TO W-RETURN-CODE DATEUTIL 226800 PERFORM S3000-FINALIZATION DATEUTIL 226900 END-PERFORM DATEUTIL 227000 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 227100 W-JULIAN-DDD OR DATEUTIL 227200 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 227300 W-JULIAN-DDD) AND DATEUTIL 227400 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 227500 W-JULIAN-DDD OR DATEUTIL 227600 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 227700 W-JULIAN-DDD) DATEUTIL 227800 MOVE T-MON-NAME-ABBR (T-MON-NDX) TO DATEUTIL 227900 W-WORK-MMM DATEUTIL 228000 END-SEARCH DATEUTIL 228100 END-IF DATEUTIL 228200 MOVE +3 TO W-MONTH-LENGTH DATEUTIL 228300 WHEN SPACES CONTINUE DATEUTIL 228400 WHEN OTHER DATEUTIL 228500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 228600 STRING 'DU2014-"' DU-MONTH-2-FORMAT '" IS NOT ' DATEUTIL 228700 'A VALID MONTH FORMAT. IT MUST BE: ' DATEUTIL 228800 '"MM", "MMM", OR "MONTH".' DATEUTIL 228900 DELIMITED BY SIZE DATEUTIL 229000 INTO DATEUTIL-MESSAGE DATEUTIL 229100 MOVE +2014 TO W-RETURN-CODE DATEUTIL 229200 PERFORM S3000-FINALIZATION DATEUTIL 229300 END-EVALUATE. DATEUTIL 229400 DATEUTIL 171600**** DQF20115 229500**** LOAD THE YEAR COMPONENT INTO THE WORK YEAR **** DATEUTIL 171800**** DQF20115 229600 EVALUATE DU-YEAR-2-FORMAT DATEUTIL 229700 WHEN 'YY' DATEUTIL 229800 MOVE W-JULIAN-DECADE TO W-WORK-DECADE DATEUTIL 229900 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 230000 SET W-YEAR-NDX1 TO +3 DATEUTIL 230100 WHEN 'YYYY' DATEUTIL 230200 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 230300 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 230400 SET W-YEAR-NDX1 TO +1 DATEUTIL 230500 WHEN SPACES CONTINUE DATEUTIL 230600 WHEN OTHER DATEUTIL 230700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 230800 STRING 'DU2015-"' DU-YEAR-2-FORMAT '" IS NOT ' DATEUTIL 230900 'A VALID YEAR FORMAT. IT MUST BE: ' DATEUTIL 231000 '"YY" OR "YYYY".' DATEUTIL 231100 DELIMITED BY SIZE DATEUTIL 231200 INTO DATEUTIL-MESSAGE DATEUTIL 231300 MOVE +2015 TO W-RETURN-CODE DATEUTIL 231400 PERFORM S3000-FINALIZATION DATEUTIL 231500 END-EVALUATE. DATEUTIL 231600 DATEUTIL 231700 MOVE SPACES TO W-WORK-ARRAY. DATEUTIL 231800 SET W-ARRAY-NDX1 TO +1. DATEUTIL 231900 DATEUTIL 174300**** DQF20115 232000**** LOAD THE VARIOUS COMPONENTS INTO THE DATE 2 DATE **** DATEUTIL 174500**** DQF20115 232100 PERFORM VARYING L-FORMAT-NDX FROM +1 BY +1 DATEUTIL 232200 UNTIL L-FORMAT-NDX > +20 DATEUTIL 232300 OR W-ARRAY-NDX1 > +20 DATEUTIL 232400 EVALUATE TRUE DATEUTIL 232500 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'D' DATEUTIL 232600 PERFORM VARYING W-DAY-NDX1 DATEUTIL 232700 FROM +1 BY +1 DATEUTIL 232800 UNTIL W-DAY-NDX1 > W-DAY-LENGTH DATEUTIL 232900 OR W-ARRAY-NDX1 > +20 DATEUTIL 233000 EVALUATE DU-DAY-2-FORMAT DATEUTIL 233100 WHEN 'ZD' DATEUTIL 233200 IF W-DAY-NDX1 = +1 AND DATEUTIL 233300 W-DAY-ARRAY-BYTE DATEUTIL 233400 (W-DAY-NDX1) = '0' DATEUTIL 233500 SET W-DAY-NDX1 UP BY +1 DATEUTIL 233600 END-IF DATEUTIL 233700 MOVE W-DAY-ARRAY-BYTE DATEUTIL 233800 (W-DAY-NDX1) DATEUTIL 233900 TO W-ARRAY-BYTE DATEUTIL 234000 (W-ARRAY-NDX1) DATEUTIL 234100 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 234200 WHEN 'ZZD' DATEUTIL 234300 IF W-DAY-NDX1 = +1 AND DATEUTIL 234400 W-DAY-ARRAY-BYTE DATEUTIL 234500 (W-DAY-NDX1) = '0' DATEUTIL 234600 SET W-DAY-NDX1 UP BY +1 DATEUTIL 234700 END-IF DATEUTIL 234800 IF W-DAY-NDX1 = +2 AND DATEUTIL 234900 W-DAY-ARRAY-BYTE DATEUTIL 235000 (W-DAY-NDX1) = '0' AND DATEUTIL 235100 W-DAY-ARRAY-BYTE DATEUTIL 235200 (1) = '0' DATEUTIL 235300 SET W-DAY-NDX1 UP BY +1 DATEUTIL 235400 END-IF DATEUTIL 235500 MOVE W-DAY-ARRAY-BYTE DATEUTIL 235600 (W-DAY-NDX1) DATEUTIL 235700 TO W-ARRAY-BYTE DATEUTIL 235800 (W-ARRAY-NDX1) DATEUTIL 235900 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 236000 WHEN OTHER DATEUTIL 236100 MOVE W-DAY-ARRAY-BYTE DATEUTIL 236200 (W-DAY-NDX1) DATEUTIL 236300 TO W-ARRAY-BYTE DATEUTIL 236400 (W-ARRAY-NDX1) DATEUTIL 236500 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 236600 END-EVALUATE DATEUTIL 236700 END-PERFORM DATEUTIL 236800 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'Y' DATEUTIL 236900 SET W-YEAR-NDX2 TO W-YEAR-NDX1 DATEUTIL 237000 PERFORM VARYING W-YEAR-NDX1 DATEUTIL 237100 FROM W-YEAR-NDX1 BY +1 DATEUTIL 237200 UNTIL W-YEAR-NDX1 > W-YEAR-LENGTH DATEUTIL 237300 OR W-ARRAY-NDX1 > +20 DATEUTIL 237400 MOVE W-YEAR-ARRAY-BYTE (W-YEAR-NDX1) DATEUTIL 237500 TO W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 237600 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 237700 END-PERFORM DATEUTIL 237800 SET W-YEAR-NDX1 TO W-YEAR-NDX2 DATEUTIL 237900 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'M' DATEUTIL 238000 PERFORM VARYING W-MONTH-NDX DATEUTIL 238100 FROM +1 BY +1 DATEUTIL 238200 UNTIL W-MONTH-NDX > W-MONTH-LENGTH DATEUTIL 238300 OR W-ARRAY-NDX1 > +20 DATEUTIL 238400 EVALUATE DU-MONTH-2-FORMAT DATEUTIL 238500 WHEN 'ZM' DATEUTIL 238600 IF W-MONTH-NDX = +1 AND DATEUTIL 238700 W-MONTH-ARRAY-BYTE DATEUTIL 238800 (W-MONTH-NDX) = '0' DATEUTIL 238900 SET W-MONTH-NDX UP BY +1 DATEUTIL 239000 END-IF DATEUTIL 239100 MOVE W-MONTH-ARRAY-BYTE DATEUTIL 239200 (W-MONTH-NDX) DATEUTIL 239300 TO W-ARRAY-BYTE DATEUTIL 239400 (W-ARRAY-NDX1) DATEUTIL 239500 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 239600 WHEN OTHER DATEUTIL 239700 MOVE W-MONTH-ARRAY-BYTE DATEUTIL 239800 (W-MONTH-NDX) DATEUTIL 239900 TO W-ARRAY-BYTE DATEUTIL 240000 (W-ARRAY-NDX1) DATEUTIL 240100 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 240200 END-EVALUATE DATEUTIL 240300 END-PERFORM DATEUTIL 240400 WHEN OTHER DATEUTIL 240500 MOVE L-FORMAT-BYTE (L-FORMAT-NDX) TO DATEUTIL 240600 W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 240700 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 240800 END-EVALUATE DATEUTIL 240900 END-PERFORM. DATEUTIL 241000 DATEUTIL 241200 MOVE W-WORK-ARRAY TO DU-DATE-2. DATEUTIL 241300 DATEUTIL 241400 S4000-EXIT. DATEUTIL 241500 EXIT. DATEUTIL 184000/*****************************************************************DQF20115 184100** S4100-FIND-DAY-OF-WEEK **DQF20115 184200** THIS SECTION IS USED TO DETERMINE THE DAY OF THE WEEK FOR **DQF20115 184300** THIS PARTICULAR JULIAN DATE. IT USES THE BASIC CONCEPT THAT **DQF20115 184400** 0001-01-01 IS DAY 1 IN "ABSOLUTE DAYS". THE ABSOLUTE DAY IS **DQF20115 184500** DETERMINED AND THEN PUT THROUGH THE FORMULA: **DQF20115 184600** **DQF20115 184700** ABSDAY - (ABSDAY-1) / 7 * 7 **DQF20115 184800** **DQF20115 184900** NOTE THAT THE DIVISION IS INTEGER-ONLY DIVISION USING **DQF20115 185000** TRUNCATION AND NOT ROUNDING. **DQF20115 185100******************************************************************DQF20115 185200 S4100-FIND-DAY-OF-WEEK SECTION. DQF20115 185300 DQF20115 185400 MOVE ZERO TO W-ABSOLUTE-DAY DQF20115 185500 W-WORK-YEAR-NUM. DQF20115 185600 DQF20115 185700 COMPUTE W-NUMBER = W-JULIAN-YEAR - 1. DQF20115 185800 DQF20115 185900 PERFORM W-NUMBER TIMES DQF20115 186000 ADD +1 TO W-WORK-YEAR-NUM DQF20115 186100 PERFORM S9000-DETERMINE-LEAP-YEAR DQF20115 186200 IF S-IS-A-LEAP-YEAR DQF20115 186300 ADD +366 TO W-ABSOLUTE-DAY DQF20115 186400 ELSE DQF20115 186500 ADD +365 TO W-ABSOLUTE-DAY DQF20115 186600 END-IF DQF20115 186700 END-PERFORM. DQF20115 186800 DQF20115 186900 COMPUTE W-ABSOLUTE-DAY = W-ABSOLUTE-DAY DQF20115 187000 + W-JULIAN-DDD. DQF20115 187100 DQF20115 187200 COMPUTE W-WORK-D = (W-ABSOLUTE-DAY - DQF20115 187300 (W-ABSOLUTE-DAY - 1) DQF20115 187400 / 7 * 7). DQF20115 187500 DQF20115 187600 S4100-EXIT. DQF20115 187700 EXIT. DQF20115 241600/**************************************************************** DATEUTIL 241700* S5000-BETWEEN * DATEUTIL 241800* THIS SECTION CALCULATES THE NUMBER OF DAYS BETWEEN TWO DATES. * DATEUTIL 241900***************************************************************** DATEUTIL 242000 S5000-BETWEEN SECTION. DATEUTIL 242100 DATEUTIL 242200 MOVE W-WORK-JULIAN TO W-HOLD-JULIAN. DATEUTIL 242300 MOVE ZEROS TO W-WORK-JULIAN. DATEUTIL 188600 DQF20115 188700**** DQF20115 188800**** SEE IF THE DATE 2 FORMAT IS ONE OF THE AUTOMATIC ONES **** DQF20115 188900**** DQF20115 189000 IF DU-DATE-2-VALID-CODE DQF20115 189100 MOVE DU-DATE-2-FORMAT-CODE TO W-FORMAT-CODE DQF20115 189200 PERFORM S1300-CONVERT-FORMAT-CODE DQF20115 189300 MOVE W-HOLD-DAY-FORMAT TO DU-DAY-2-FORMAT DQF20115 189400 MOVE W-HOLD-MONTH-FORMAT TO DU-MONTH-2-FORMAT DQF20115 189500 MOVE W-HOLD-YEAR-FORMAT TO DU-YEAR-2-FORMAT DQF20115 189600 MOVE W-HOLD-DATE-FORMAT TO DU-DATE-2-FORMAT DQF20115 189700 END-IF. DQF20115 189800 DQF20115 189900 IF DU-YEAR-2-SWITCH IS NUMERIC DQF20115 190000 MOVE DU-YEAR-2-SWITCH-NUM TO W-SWITCH-YEAR DQF20115 190100 END-IF. DQF20115 242400 DATEUTIL 242500 MOVE DU-DATE-2 TO W-HOLD-DATE. DATEUTIL 242600 MOVE DU-DAY-2-FORMAT TO W-HOLD-DAY-FORMAT. DATEUTIL 242700 MOVE DU-MONTH-2-FORMAT TO W-HOLD-MONTH-FORMAT. DATEUTIL 242800 MOVE DU-YEAR-2-FORMAT TO W-HOLD-YEAR-FORMAT. DATEUTIL 242900 MOVE DU-DATE-2-FORMAT TO W-HOLD-DATE-FORMAT. DATEUTIL 243000 DATEUTIL 243100 PERFORM S9100-PARSE-DATE. DATEUTIL 243200 DATEUTIL 243300 PERFORM S9200-CONVERT-TO-JULIAN. DATEUTIL 243400 DATEUTIL 191300 MOVE +0 TO W-TALLY. DQF20115 243600 DATEUTIL 243700 IF W-HOLD-JULIAN > W-WORK-JULIAN DATEUTIL 243800 PERFORM VARYING W-HOLD-JULIAN-NDX FROM +1 BY +1 DATEUTIL 243900 UNTIL W-HOLD-JULIAN-NDX > +7 DATEUTIL 244000 SET W-ARRAY-NDX1 TO W-HOLD-JULIAN-NDX DATEUTIL 244100 MOVE W-HOLD-JULIAN-BYTE (W-HOLD-JULIAN-NDX) DATEUTIL 244200 TO W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 244300 END-PERFORM DATEUTIL 244400 MOVE W-WORK-JULIAN TO W-HOLD-JULIAN DATEUTIL 244500 PERFORM VARYING W-JULIAN-NDX FROM +1 BY +1 DATEUTIL 244600 UNTIL W-JULIAN-NDX > +7 DATEUTIL 244700 SET W-ARRAY-NDX1 TO W-JULIAN-NDX DATEUTIL 244800 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 244900 TO W-JULIAN-BYTE (W-JULIAN-NDX) DATEUTIL 245000 END-PERFORM DATEUTIL 245100 END-IF. DATEUTIL 245200 DATEUTIL 245300 PERFORM UNTIL W-HOLD-JULIAN = W-WORK-JULIAN DATEUTIL 245400 IF W-HOLD-JULIAN-YEAR < W-JULIAN-YEAR DATEUTIL 245500 MOVE W-HOLD-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 245600 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 245700 IF S-IS-A-LEAP-YEAR DATEUTIL 245800 PERFORM UNTIL W-HOLD-JULIAN-DDD > 366 DATEUTIL 245900 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 193800 W-TALLY DQF20115 246100 END-PERFORM DATEUTIL 246200 ELSE DATEUTIL 246300 PERFORM UNTIL W-HOLD-JULIAN-DDD > 365 DATEUTIL 246400 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 194300 W-TALLY DQF20115 246600 END-PERFORM DATEUTIL 246700 END-IF DATEUTIL 246800 ADD 1 TO W-HOLD-JULIAN-YEAR DATEUTIL 246900 MOVE 1 TO W-HOLD-JULIAN-DDD DATEUTIL 247000 ELSE DATEUTIL 247100 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 195000 W-TALLY DQF20115 247300 END-IF DATEUTIL 247400 END-PERFORM. DATEUTIL 247500 DATEUTIL 247600 MOVE SPACES TO DATEUTIL-WORK-AREA. DATEUTIL 195500 MOVE W-TALLY TO DU-NUMBER. DQF20115 247800 DATEUTIL 247900 S5000-EXIT. DATEUTIL 248000 EXIT. DATEUTIL 248100/**************************************************************** DATEUTIL 248200* S6000-INCREMENT * DATEUTIL 248300* THIS SECTION INCREMENTS THE INPUT DATE BY THE NUMBER IN THE * DATEUTIL 248400* INPUT NUMBER FIELD. * DATEUTIL 248500***************************************************************** DATEUTIL 248600 S6000-INCREMENT SECTION. DATEUTIL 248700 DATEUTIL 248800 IF DU-NUMBER < 1 DATEUTIL 248900 MOVE DU-FUNCTION TO W-HOLD-FUNCTION DATEUTIL 249000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 249100 STRING 'DU2034-THE NUMBER MUST BE GREATER THAN ' DATEUTIL 249200 'ZERO FOR THE "' W-HOLD-FUNCTION DATEUTIL 249300 '" FUNCTION.' DATEUTIL 249400 DELIMITED BY SIZE DATEUTIL 249500 INTO DATEUTIL-MESSAGE DATEUTIL 249600 MOVE +2034 TO W-RETURN-CODE DATEUTIL 249700 PERFORM S3000-FINALIZATION DATEUTIL 249800 END-IF. DATEUTIL 249900 DATEUTIL 250000 MOVE W-JULIAN-YEAR TO W-WORK-YEAR. DATEUTIL 250100 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 250200 DATEUTIL 250300 PERFORM DU-NUMBER TIMES DATEUTIL 250400 ADD +1 TO W-JULIAN-DDD DATEUTIL 250500 IF S-IS-A-LEAP-YEAR DATEUTIL 250600 IF W-JULIAN-DDD > 366 DATEUTIL 250700 MOVE 1 TO W-JULIAN-DDD DATEUTIL 250800 ADD +1 TO W-JULIAN-YEAR DATEUTIL 250900 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 251000 END-IF DATEUTIL 251100 ELSE DATEUTIL 251200 IF W-JULIAN-DDD > 365 DATEUTIL 251300 MOVE 1 TO W-JULIAN-DDD DATEUTIL 251400 ADD +1 TO W-JULIAN-YEAR DATEUTIL 251500 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 251600 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 251700 END-IF DATEUTIL 251800 END-IF DATEUTIL 251900 END-PERFORM. DATEUTIL 199800 DQF20115 252000 PERFORM S4000-CONVERT. DATEUTIL 252100 DATEUTIL 252200 S6000-EXIT. DATEUTIL 252300 EXIT. DATEUTIL 252400/**************************************************************** DATEUTIL 252500* S7000-DECREMENT * DATEUTIL 252600* THIS SECTION DECREMENTS THE INPUT DATE BY THE NUMBER IN THE * DATEUTIL 252700* INPUT NUMBER FIELD. * DATEUTIL 252800***************************************************************** DATEUTIL 252900 S7000-DECREMENT SECTION. DATEUTIL 253000 DATEUTIL 253100 IF DU-NUMBER < 1 DATEUTIL 253200 MOVE DU-FUNCTION TO W-HOLD-FUNCTION DATEUTIL 253300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 253400 STRING 'DU2035-THE NUMBER MUST BE GREATER THAN ' DATEUTIL 253500 'ZERO FOR THE "' W-HOLD-FUNCTION DATEUTIL 253600 '" FUNCTION.' DATEUTIL 253700 DELIMITED BY SIZE DATEUTIL 253800 INTO DATEUTIL-MESSAGE DATEUTIL 253900 MOVE +2035 TO W-RETURN-CODE DATEUTIL 254000 PERFORM S3000-FINALIZATION DATEUTIL 254100 END-IF. DATEUTIL 254200 DATEUTIL 254300 MOVE W-JULIAN-YEAR TO W-WORK-YEAR. DATEUTIL 254400 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 254500 DATEUTIL 254600 PERFORM DU-NUMBER TIMES DATEUTIL 254700 SUBTRACT +1 FROM W-JULIAN-DDD DATEUTIL 254800 IF S-IS-A-LEAP-YEAR DATEUTIL 254900 IF W-JULIAN-DDD = 0 DATEUTIL 255000 MOVE 365 TO W-JULIAN-DDD DATEUTIL 255100 SUBTRACT +1 FROM W-JULIAN-YEAR DATEUTIL 255200 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 255300 END-IF DATEUTIL 255400 ELSE DATEUTIL 255500 IF W-JULIAN-DDD = 0 DATEUTIL 255600 SUBTRACT +1 FROM W-JULIAN-YEAR DATEUTIL 255700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 255800 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 255900 IF S-IS-A-LEAP-YEAR DATEUTIL 256000 MOVE 366 TO W-JULIAN-DDD DATEUTIL 256100 ELSE DATEUTIL 256200 MOVE 365 TO W-JULIAN-DDD DATEUTIL 256300 END-IF DATEUTIL 256400 END-IF DATEUTIL 256500 END-IF DATEUTIL 256600 END-PERFORM. DATEUTIL 204600 DQF20115 256700 PERFORM S4000-CONVERT. DATEUTIL 256800 DATEUTIL 256900 S7000-EXIT. DATEUTIL 257000 EXIT. DATEUTIL 257100/**************************************************************** DATEUTIL 257200* S9000-DETERMINE-LEAP-YEAR * DATEUTIL 257300* THIS SECTION SETS A SWITCH TO LET THE CALLING SECTION KNOW * DATEUTIL 257400* IF THE YEAR IT'S DEALING WITH IS A LEAP YEAR OR NOT. * DATEUTIL 257500***************************************************************** DATEUTIL 257600 S9000-DETERMINE-LEAP-YEAR SECTION. DATEUTIL 257700 DATEUTIL 257800 IF W-WORK-YEAR IS NUMERIC DATEUTIL 257900 IF W-WORK-DECADE = 00 DATEUTIL 258000 DIVIDE W-WORK-YEAR-NUM BY 400 DATEUTIL 258100 GIVING W-QUOTIENT DATEUTIL 258200 REMAINDER W-REMAINDER DATEUTIL 258300 ELSE DATEUTIL 258400 DIVIDE W-WORK-YEAR-NUM BY 4 DATEUTIL 258500 GIVING W-QUOTIENT DATEUTIL 258600 REMAINDER W-REMAINDER DATEUTIL 258700 END-IF DATEUTIL 258800 ELSE DATEUTIL 258900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 259000 STRING 'DU2016-"' W-WORK-YEAR '" IS NOT ' DATEUTIL 259100 'A VALID YEAR VALUE. IT MUST BE ' DATEUTIL 207200 'NUMERIC IN THE RANGE OF "0001-9999".' DQF20115 259300 DELIMITED BY SIZE DATEUTIL 259400 INTO DATEUTIL-MESSAGE DATEUTIL 259500 MOVE +2016 TO W-RETURN-CODE DATEUTIL 259600 PERFORM S3000-FINALIZATION DATEUTIL 259700 END-IF. DATEUTIL 259800 DATEUTIL 259900 IF W-A-LEAP-YEAR-REMAINDER DATEUTIL 260000 SET S-IS-A-LEAP-YEAR TO TRUE DATEUTIL 260100 ELSE DATEUTIL 260200 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 260300 END-IF. DATEUTIL 260400 DATEUTIL 260500 S9000-EXIT. DATEUTIL 260600 EXIT. DATEUTIL 260700/**************************************************************** DATEUTIL 260800* S9100-PARSE-DATE * DATEUTIL 260900* THIS SECTION PARSES THE INPUT DATE (DATE 1 USUALLY, BUT IT * DATEUTIL 261000* COULD BE DATE 2 FOR THE BETWEEN FUNCTION) AND PUTS EACH * DATEUTIL 261100* COMPONENT OF THE DATE INTO INDIVIDUAL WORK FIELDS FOR THE * DATEUTIL 261200* DAY, MONTH, AND YEAR. * DATEUTIL 261300***************************************************************** DATEUTIL 261400 S9100-PARSE-DATE SECTION. DATEUTIL 261500 DATEUTIL 261600 MOVE W-HOLD-DATE-FORMAT TO W-WORK-ARRAY. DATEUTIL 261700 SET W-ARRAY-NDX1 TO +1. DATEUTIL 261800 MOVE SPACES TO W-WORK-DAY DATEUTIL 261900 W-WORK-MONTH DATEUTIL 262000 W-WORK-YEAR. DATEUTIL 262100 DATEUTIL 210200**** DQF20115 262200**** FIND POSITION OF THE YEAR COMPONENT IN THE FORMAT FIELD **** DATEUTIL 210400**** DQF20115 262300 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 262400 AT END PERFORM 1 TIMES DATEUTIL 262500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 262600 STRING 'DU2017-THE DATE FORMAT MUST CONTAIN ' DATEUTIL 262700 'A "YEAR" REFERENCE OF SOME TYPE. ' DATEUTIL 262800 'SPECIFY IT WITH A "Y" IN THE FORMAT.' DATEUTIL 262900 DELIMITED BY SIZE DATEUTIL 263000 INTO DATEUTIL-MESSAGE DATEUTIL 263100 MOVE +2017 TO W-RETURN-CODE DATEUTIL 263200 PERFORM S3000-FINALIZATION DATEUTIL 263300 END-PERFORM DATEUTIL 263400 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'Y' DATEUTIL 263500 SET W-YEAR-BYTE TO W-ARRAY-NDX1 DATEUTIL 263600 END-SEARCH. DATEUTIL 263700 DATEUTIL 263800 SET W-ARRAY-NDX1 TO +1. DATEUTIL 263900 DATEUTIL 212200**** DQF20115 264000**** FIND POSITION OF THE MONTH COMPONENT IN THE DATE FORMAT **** DATEUTIL 212400**** DQF20115 264100 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 264200 AT END PERFORM 1 TIMES DATEUTIL 264300 IF W-HOLD-DAY-FORMAT = 'DDD' OR 'ZZD' DATEUTIL 264400 NEXT SENTENCE DATEUTIL 264500 ELSE DATEUTIL 264600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 264700 STRING 'DU2018-THE DATE FORMAT ' DATEUTIL 264800 'MUST CONTAIN A "MONTH" ' DATEUTIL 264900 'REFERENCE OF SOME TYPE. ' DATEUTIL 265000 'SPECIFY IT WITH A "M" IN ' DATEUTIL 265100 'THE FORMAT.' DATEUTIL 265200 DELIMITED BY SIZE DATEUTIL 265300 INTO DATEUTIL-MESSAGE DATEUTIL 265400 MOVE +2018 TO W-RETURN-CODE DATEUTIL 265500 PERFORM S3000-FINALIZATION DATEUTIL 265600 END-IF DATEUTIL 265700 END-PERFORM DATEUTIL 265800 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'M' DATEUTIL 265900 SET W-MONTH-BYTE TO W-ARRAY-NDX1 DATEUTIL 266000 END-SEARCH. DATEUTIL 266100 DATEUTIL 266200 SET W-ARRAY-NDX1 TO +1. DATEUTIL 266300 DATEUTIL 214800**** DQF20115 266400**** FIND THE POSITION OF THE DAY COMPONENT IN THE DATE FORMAT ** DATEUTIL 215000**** DQF20115 266500 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 266600 AT END PERFORM 1 TIMES DATEUTIL 266700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 266800 STRING 'DU2019-THE DATE FORMAT MUST CONTAIN ' DATEUTIL 266900 'A "DAY" REFERENCE OF SOME TYPE. ' DATEUTIL 267000 'SPECIFY IT WITH A "D" IN THE FORMAT.' DATEUTIL 267100 DELIMITED BY SIZE DATEUTIL 267200 INTO DATEUTIL-MESSAGE DATEUTIL 267300 MOVE +2019 TO W-RETURN-CODE DATEUTIL 267400 PERFORM S3000-FINALIZATION DATEUTIL 267500 END-PERFORM DATEUTIL 267600 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'D' DATEUTIL 267700 SET W-DAY-BYTE TO W-ARRAY-NDX1 DATEUTIL 267800 END-SEARCH. DATEUTIL 267900 DATEUTIL 268000 MOVE SPACES TO W-WORK-ARRAY. DATEUTIL 268100 MOVE W-HOLD-DATE TO W-WORK-ARRAY. DATEUTIL 268200 DATEUTIL 216900**** DQF20115 268300**** CHECK THE DAY FORMAT FOR VALIDITY **** DATEUTIL 217100**** DQF20115 268400 EVALUATE W-HOLD-DAY-FORMAT DATEUTIL 268500 WHEN 'DD' DATEUTIL 268600 MOVE +2 TO W-DAY-LENGTH DATEUTIL 268700 WHEN 'ZD' DATEUTIL 268800 MOVE +2 TO W-DAY-LENGTH DATEUTIL 268900 WHEN 'DDD' DATEUTIL 269000 MOVE +3 TO W-DAY-LENGTH DATEUTIL 269100 WHEN 'ZZD' DATEUTIL 269200 MOVE +3 TO W-DAY-LENGTH DATEUTIL 269300 WHEN OTHER DATEUTIL 269400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 269500 STRING 'DU2020-THE INPUT "DAY" FORMAT MAY ONLY BE ' DATEUTIL 269600 '"DD", "DDD", "ZD", OR "ZZD".' DATEUTIL 269700 DELIMITED BY SIZE DATEUTIL 269800 INTO DATEUTIL-MESSAGE DATEUTIL 269900 MOVE +2020 TO W-RETURN-CODE DATEUTIL 270000 PERFORM S3000-FINALIZATION DATEUTIL 270100 END-EVALUATE. DATEUTIL 270200 DATEUTIL 219100**** DQF20115 270300**** CHECK THE YEAR FORMAT FOR VALIDITY **** DATEUTIL 219300**** DQF20115 270400 EVALUATE W-HOLD-YEAR-FORMAT DATEUTIL 270500 WHEN 'YY' DATEUTIL 270700 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 270800 SET W-YEAR-NDX1 TO +3 DATEUTIL 270900 WHEN 'YYYY' DATEUTIL 271000 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 271100 SET W-YEAR-NDX1 TO +1 DATEUTIL 271200 WHEN OTHER DATEUTIL 271300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 271400 STRING 'DU2021-THE INPUT "YEAR" FORMAT MAY ONLY ' DATEUTIL 271500 'BE "YY" OR "YYYY".' DATEUTIL 271600 DELIMITED BY SIZE DATEUTIL 271700 INTO DATEUTIL-MESSAGE DATEUTIL 271800 MOVE +2021 TO W-RETURN-CODE DATEUTIL 271900 PERFORM S3000-FINALIZATION DATEUTIL 272000 END-EVALUATE. DATEUTIL 272100 DATEUTIL 221100**** DQF20115 272200**** CHECK THE MONTH FORMAT FOR VALIDITY **** DATEUTIL 221300**** DQF20115 272300 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 272400 WHEN 'MM' DATEUTIL 272500 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 272600 WHEN 'ZM' DATEUTIL 272700 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 272800 WHEN 'MMM' DATEUTIL 272900 MOVE +3 TO W-MONTH-LENGTH DATEUTIL 273000 WHEN 'MONTH' DATEUTIL 273100 MOVE +9 TO W-MONTH-LENGTH DATEUTIL 273200 WHEN OTHER DATEUTIL 273300 IF W-HOLD-DAY-FORMAT = 'DDD' DATEUTIL 273400 NEXT SENTENCE DATEUTIL 273500 ELSE DATEUTIL 273600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 273700 STRING 'DU2022-THE INPUT "MONTH" FORMAT MAY ' DATEUTIL 273800 'ONLY BE "MM", "MMM" OR "MONTH".' DATEUTIL 273900 DELIMITED BY SIZE DATEUTIL 274000 INTO DATEUTIL-MESSAGE DATEUTIL 274100 MOVE +2022 TO W-RETURN-CODE DATEUTIL 274200 PERFORM S3000-FINALIZATION DATEUTIL 274300 END-IF DATEUTIL 274400 END-EVALUATE. DATEUTIL 274500 DATEUTIL 274600 SET W-ARRAY-NDX2 TO +1. DATEUTIL 274700 DATEUTIL 223900**** DQF20115 274800**** PARSE THE DATE AND SEPARATE IT INTO INDIVIDUAL COMPONENTS ** DATEUTIL 224100**** DQF20115 274900 PERFORM VARYING W-ARRAY-NDX1 FROM +1 BY +1 DATEUTIL 275000 UNTIL W-ARRAY-NDX1 > +20 DATEUTIL 275100 OR W-ARRAY-NDX2 > +20 DATEUTIL 275200 EVALUATE W-ARRAY-NDX2 DATEUTIL 275300 WHEN W-DAY-BYTE DATEUTIL 275400 PERFORM S9110-PARSE-DATE-DAY DATEUTIL 275410 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 275500 WHEN W-MONTH-BYTE DATEUTIL 275600 PERFORM S9120-PARSE-DATE-MONTH DATEUTIL 275610 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 275700 WHEN W-YEAR-BYTE DATEUTIL 275800 PERFORM S9130-PARSE-DATE-YEAR DATEUTIL 275810 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 275900 END-EVALUATE DATEUTIL 276100 SET W-ARRAY-NDX2 UP BY +1 DATEUTIL 276200 END-PERFORM. DATEUTIL 276300 DATEUTIL 276400 S9100-EXIT. DATEUTIL 276500 EXIT. DATEUTIL 276600/**************************************************************** DATEUTIL 276700* S9110-PARSE-DATE-DAY * DATEUTIL 276800* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "DAY" * DATEUTIL 276900* PORTION OF THE DATE. * DATEUTIL 277000***************************************************************** DATEUTIL 277100 S9110-PARSE-DATE-DAY SECTION. DATEUTIL 277200 DATEUTIL 277300 PERFORM VARYING W-DAY-NDX1 FROM +1 BY +1 DATEUTIL 277400 UNTIL W-DAY-NDX1 > W-DAY-LENGTH OR DATEUTIL 277500 W-ARRAY-NDX1 > +20 OR DATEUTIL 277501 W-ARRAY-BYTE (W-ARRAY-NDX1) IS NOT NUMERIC DATEUTIL 277510 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 277520 W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 277521 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 277530 END-PERFORM. DATEUTIL 277531 DATEUTIL 277532 PERFORM VARYING W-DAY-NDX2 FROM W-DAY-LENGTH BY -1 DATEUTIL 277533 UNTIL W-DAY-NDX2 < +1 OR DATEUTIL 277534 W-DAY-ARRAY-BYTE (W-DAY-NDX2) IS NUMERIC DATEUTIL 277535 END-PERFORM. DATEUTIL 277540 DATEUTIL 277550 PERFORM VARYING W-DAY-NDX1 FROM W-DAY-LENGTH BY -1 DATEUTIL 277560 UNTIL W-DAY-NDX1 < +1 OR DATEUTIL 277570 W-DAY-ARRAY-BYTE (W-DAY-NDX1) IS NUMERIC DATEUTIL 277571 IF W-DAY-NDX2 > 0 DATEUTIL 277578 MOVE W-DAY-ARRAY-BYTE (W-DAY-NDX2) TO DATEUTIL 277579 W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 277581 MOVE '0' TO W-DAY-ARRAY-BYTE (W-DAY-NDX2) DATEUTIL 277590 SET W-DAY-NDX2 DOWN BY +1 DATEUTIL 277591 ELSE DATEUTIL 277592 MOVE '0' TO W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 277593 END-IF DATEUTIL 277594 END-PERFORM. DATEUTIL 277595 DATEUTIL 288300 S9110-EXIT. DATEUTIL 288400 EXIT. DATEUTIL 288500/**************************************************************** DATEUTIL 288600* S9120-PARSE-DATE-MONTH * DATEUTIL 288700* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "MONTH"* DATEUTIL 288800* PORTION OF THE DATE. * DATEUTIL 288900***************************************************************** DATEUTIL 289000 S9120-PARSE-DATE-MONTH SECTION. DATEUTIL 289100 DATEUTIL 289200 PERFORM VARYING W-MONTH-NDX DATEUTIL 289300 FROM +1 BY +1 DATEUTIL 289400 UNTIL W-MONTH-NDX > W-MONTH-LENGTH DATEUTIL 289600 OR W-ARRAY-NDX1 > +20 DATEUTIL 289610 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 289640 WHEN 'ZM' DATEUTIL 289650 IF W-MONTH-NDX = +1 DATEUTIL 289660 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS NUMERIC DATEUTIL 289670 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 289671 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289672 ELSE DATEUTIL 289673 MOVE '0' TO DATEUTIL 289674 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289676 END-IF DATEUTIL 289677 END-IF DATEUTIL 289678 IF W-MONTH-NDX = +2 DATEUTIL 289679 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS NUMERIC DATEUTIL 289680 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 289681 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289683 ELSE DATEUTIL 289684 MOVE W-MONTH-ARRAY-BYTE (W-MONTH-NDX - 1) DATEUTIL 289685 TO W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289687 MOVE '0' TO DATEUTIL 289688 W-MONTH-ARRAY-BYTE (W-MONTH-NDX - 1) DATEUTIL 289689 END-IF DATEUTIL 289690 END-IF DATEUTIL 289691 WHEN 'MONTH' DATEUTIL 289692 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS ALPHABETIC ANDDATEUTIL 289693 W-ARRAY-BYTE (W-ARRAY-NDX1) NOT = SPACE DATEUTIL 289694 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 289700 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289710 ELSE DATEUTIL 289720 SET W-MONTH-NDX TO W-MONTH-LENGTH DATEUTIL 289730 END-IF DATEUTIL 289740 WHEN OTHER DATEUTIL 289750 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 289760 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 289800 END-EVALUATE DATEUTIL 289900 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 289910 END-PERFORM. DATEUTIL 291900 DATEUTIL 292000 S9120-EXIT. DATEUTIL 292100 EXIT. DATEUTIL 292200/**************************************************************** DATEUTIL 292300* S9130-PARSE-DATE-YEAR * DATEUTIL 292400* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "YEAR" * DATEUTIL 292500* PORTION OF THE DATE. * DATEUTIL 292600***************************************************************** DATEUTIL 292700 S9130-PARSE-DATE-YEAR SECTION. DATEUTIL 292800 DATEUTIL 292900 PERFORM VARYING W-YEAR-NDX1 DATEUTIL 293000 FROM W-YEAR-NDX1 BY +1 DATEUTIL 293100 UNTIL W-YEAR-NDX1 > W-YEAR-LENGTH DATEUTIL 293200 OR W-ARRAY-NDX1 > +20 DATEUTIL 293300 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 293400 W-YEAR-ARRAY-BYTE (W-YEAR-NDX1) DATEUTIL 293500 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 293600 END-PERFORM. DATEUTIL 236200 DQF20115 236300 IF W-HOLD-YEAR-FORMAT = 'YY' DQF20115 236400 IF W-WORK-DECADE < W-SWITCH-YEAR DQF20115 236500 MOVE '20' TO W-WORK-CENTURY DQF20115 236600 ELSE DQF20115 236700 MOVE '19' TO W-WORK-CENTURY DQF20115 236800 END-IF DQF20115 236900 END-IF. DQF20115 237000 DQF20115 293800 S9130-EXIT. DATEUTIL 293900 EXIT. DATEUTIL 294000/**************************************************************** DATEUTIL 294100* S9200-CONVERT-TO-JULIAN * DATEUTIL 294200* CONVERT THE DATE PASSED TO THIS SECTION INTO A JULIAN DATE IN * DATEUTIL 294300* YYYYDDD FORMAT. * DATEUTIL 294400***************************************************************** DATEUTIL 294500 S9200-CONVERT-TO-JULIAN SECTION. DATEUTIL 294600 DATEUTIL 294700 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 294800 DATEUTIL 294900 MOVE W-WORK-CENTURY TO W-JULIAN-CENTURY. DATEUTIL 295000 MOVE W-WORK-DECADE TO W-JULIAN-DECADE. DATEUTIL 295100 DATEUTIL 295200 IF W-HOLD-DAY-FORMAT = 'DDD' OR 'ZZD' DATEUTIL 295300 IF ((W-WORK-DAY-AB3 > '001' OR DATEUTIL 295400 W-WORK-DAY-AB3 = '001') AND DATEUTIL 295500 (W-WORK-DAY-AB3 < '365' OR DATEUTIL 295600 W-WORK-DAY-AB3 = '365') AND DATEUTIL 295700 (S-NOT-A-LEAP-YEAR)) OR DATEUTIL 295800 ((W-WORK-DAY-AB3 > '001' OR DATEUTIL 295900 W-WORK-DAY-AB3 = '001') AND DATEUTIL 296000 (W-WORK-DAY-AB3 < '366' OR DATEUTIL 296100 W-WORK-DAY-AB3 = '366') AND DATEUTIL 296200 (S-IS-A-LEAP-YEAR)) DATEUTIL 296300 MOVE W-WORK-DDD TO W-JULIAN-DDD DATEUTIL 296400 GO TO S9200-EXIT DATEUTIL 296500 ELSE DATEUTIL 296600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 296700 STRING 'DU2023-"' W-WORK-DAY-AB2 '" IS AN INVALID ' DATEUTIL 296800 'JULIAN DAY FOR "' W-WORK-YEAR '".' DATEUTIL 296900 DELIMITED BY SIZE DATEUTIL 297000 INTO DATEUTIL-MESSAGE DATEUTIL 297100 MOVE +2023 TO W-RETURN-CODE DATEUTIL 297200 PERFORM S3000-FINALIZATION DATEUTIL 297300 ELSE DATEUTIL 297400 IF W-HOLD-DAY-FORMAT = 'DD' OR 'ZD' DATEUTIL 297500 IF W-WORK-DAY-AB2 IS NOT NUMERIC DATEUTIL 297600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 297700 STRING 'DU2024-THE INPUT DAY OF THE MONTH MUST ' DATEUTIL 297800 'BE NUMERIC.' DATEUTIL 297900 DELIMITED BY SIZE DATEUTIL 298000 INTO DATEUTIL-MESSAGE DATEUTIL 298100 MOVE +2024 TO W-RETURN-CODE DATEUTIL 298200 PERFORM S3000-FINALIZATION DATEUTIL 298300 END-IF DATEUTIL 298400 ELSE DATEUTIL 298500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 298600 STRING 'DU2025-THE ONLY VALID INPUT "DAY" FORMATS ' DATEUTIL 298700 'ARE "DD", "DDD", "ZD", OR "ZZD".' DATEUTIL 298800 DELIMITED BY SIZE DATEUTIL 298900 INTO DATEUTIL-MESSAGE DATEUTIL 299000 MOVE +2025 TO W-RETURN-CODE DATEUTIL 299100 PERFORM S3000-FINALIZATION DATEUTIL 299200 END-IF DATEUTIL 299300 END-IF. DATEUTIL 299400 DATEUTIL 299500 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 299600 WHEN 'MMM' DATEUTIL 299700 SET T-MON-NDX TO +1 DATEUTIL 299800 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 299900 AT END PERFORM 1 TIMES DATEUTIL 300000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 300100 STRING 'DU2026-"' W-WORK-MMM '" IS NOT A ' DATEUTIL 300200 'VALID 3 CHARACTER MONTH ' DATEUTIL 300300 'ABBREVIATION.' DATEUTIL 300400 DELIMITED BY SIZE DATEUTIL 300500 INTO DATEUTIL-MESSAGE DATEUTIL 300600 MOVE +2026 TO W-RETURN-CODE DATEUTIL 300700 PERFORM S3000-FINALIZATION DATEUTIL 300800 END-PERFORM DATEUTIL 300900 WHEN T-MON-NAME-ABBR (T-MON-NDX) = W-WORK-MMM DATEUTIL 301000 CONTINUE DATEUTIL 301100 END-SEARCH DATEUTIL 301200 WHEN 'MONTH' DATEUTIL 301300 SET T-MON-NDX TO +1 DATEUTIL 301400 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 301500 AT END PERFORM 1 TIMES DATEUTIL 301600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 301700 STRING 'DU2027-"' W-WORK-MONTH '" IS NOT ' DATEUTIL 301800 'A VALID MONTH NAME.' DATEUTIL 301900 DELIMITED BY SIZE DATEUTIL 302000 INTO DATEUTIL-MESSAGE DATEUTIL 302100 MOVE +2027 TO W-RETURN-CODE DATEUTIL 302200 PERFORM S3000-FINALIZATION DATEUTIL 302300 END-PERFORM DATEUTIL 302400 WHEN T-MON-NAME (T-MON-NDX) = W-WORK-MONTH DATEUTIL 302500 CONTINUE DATEUTIL 302600 END-SEARCH DATEUTIL 302700 WHEN 'MM' DATEUTIL 302800 IF W-WORK-MM < 1 OR W-WORK-MM > 12 DATEUTIL 302900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 303000 STRING 'DU2028-"' W-WORK-MM '" IS NOT ' DATEUTIL 303100 'A VALID MONTH NUMBER.' DATEUTIL 303200 DELIMITED BY SIZE DATEUTIL 303300 INTO DATEUTIL-MESSAGE DATEUTIL 303400 MOVE +2028 TO W-RETURN-CODE DATEUTIL 303500 PERFORM S3000-FINALIZATION DATEUTIL 303600 ELSE DATEUTIL 303700 SET T-MON-NDX TO W-WORK-MM DATEUTIL 303800 END-IF DATEUTIL 303900 WHEN 'ZM' DATEUTIL 304000 IF W-WORK-ZM < '01' OR W-WORK-ZM > '12' DATEUTIL 304100 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 304200 STRING 'DU2032-"' W-WORK-ZM '" IS NOT ' DATEUTIL 304300 'A VALID MONTH NUMBER.' DATEUTIL 304400 DELIMITED BY SIZE DATEUTIL 304500 INTO DATEUTIL-MESSAGE DATEUTIL 304600 MOVE +2032 TO W-RETURN-CODE DATEUTIL 304700 PERFORM S3000-FINALIZATION DATEUTIL 304800 ELSE DATEUTIL 304900 IF W-WORK-ZM > 9 DATEUTIL 305000 SET T-MON-NDX TO W-WORK-MM DATEUTIL 305100 ELSE DATEUTIL 305200 MOVE '0' TO DATEUTIL 305300 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 305400 SET T-MON-NDX TO W-WORK-MM DATEUTIL 305500 END-IF DATEUTIL 305600 END-IF DATEUTIL 305700 WHEN OTHER DATEUTIL 305800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 305900 STRING 'DU2033-THE ONLY VALID INPUT ' DATEUTIL 306000 '"MONTH" FORMATS ' DATEUTIL 306100 'ARE "MM", "MMM", "ZM", OR "MONTH".' DATEUTIL 306200 DELIMITED BY SIZE DATEUTIL 306300 INTO DATEUTIL-MESSAGE DATEUTIL 306400 MOVE +2033 TO W-RETURN-CODE DATEUTIL 306500 PERFORM S3000-FINALIZATION DATEUTIL 306600 END-EVALUATE. DATEUTIL 306700 DATEUTIL 306800 IF S-IS-A-LEAP-YEAR DATEUTIL 306900 COMPUTE W-JULIAN-DDD = T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 307000 + W-WORK-DD DATEUTIL 307100 - 1 DATEUTIL 307200 IF W-JULIAN-DDD > T-MON-JUL-LEAP-END (T-MON-NDX) DATEUTIL 307300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 307400 STRING 'DU2029-"' W-WORK-DD '" IS NOT ' DATEUTIL 307500 'A VALID DAY FOR MONTH: "' W-WORK-MONTH DATEUTIL 307600 '" IN "' W-WORK-YEAR '".' DATEUTIL 307700 DELIMITED BY SIZE DATEUTIL 307800 INTO DATEUTIL-MESSAGE DATEUTIL 307900 MOVE +2029 TO W-RETURN-CODE DATEUTIL 308000 PERFORM S3000-FINALIZATION DATEUTIL 308100 END-IF DATEUTIL 308200 ELSE DATEUTIL 308300 COMPUTE W-JULIAN-DDD = T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 308400 + W-WORK-DD DATEUTIL 308500 - 1 DATEUTIL 308600 IF W-JULIAN-DDD > T-MON-JUL-END (T-MON-NDX) DATEUTIL 308700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 308800 STRING 'DU2030-"' W-WORK-DD '" IS NOT ' DATEUTIL 308900 'A VALID DAY FOR MONTH: "' W-WORK-MONTH DATEUTIL 309000 '" IN "' W-WORK-YEAR '".' DATEUTIL 309100 DELIMITED BY SIZE DATEUTIL 309200 INTO DATEUTIL-MESSAGE DATEUTIL 309300 MOVE +2030 TO W-RETURN-CODE DATEUTIL 309400 PERFORM S3000-FINALIZATION DATEUTIL 309500 END-IF DATEUTIL 309600 END-IF. DATEUTIL 309700 DATEUTIL 309800 S9200-EXIT. DATEUTIL 309900 EXIT. DATEUTIL 310000/**************************************************************** DATEUTIL 310100* S9300-ISPF-VGET-VPUT * DATEUTIL 310200* THIS SECTION PERFORMS THE ISPF VARIABLE I/O INTO AND OUT OF * DATEUTIL 310300* THE PROGRAM. IF THE ACTION IS "OUTPUT" (VPUT), THE FINAL * DATEUTIL 310400* RETURN CODE IS CHECKED TO EITHER OUTPUT RESULTS OR AN ERROR * DATEUTIL 310500* MESSAGE. * DATEUTIL 310600***************************************************************** DATEUTIL 310700 S9300-ISPF-VGET-VPUT SECTION. DATEUTIL 310800 DATEUTIL 310900 IF W-RETURN-CODE = 0 DATEUTIL 311000 CALL C-ISPF USING W-ISPF-SERVICE C-ISPF-VARIABLE-NAMES, DATEUTIL 311100 C-SHARED-OPTION DATEUTIL 311200 IF RETURN-CODE > 8 DATEUTIL 311300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 311400 STRING 'DU2031-AN ISPF ' W-ISPF-SERVICE ' FAILED ' DATEUTIL 311500 'WITH A RETURN CODE GREATER THAN 8.' DATEUTIL 311600 DELIMITED BY SIZE DATEUTIL 311700 INTO DATEUTIL-MESSAGE DATEUTIL 311800 MOVE +2031 TO W-RETURN-CODE DATEUTIL 311900 PERFORM S3000-FINALIZATION DATEUTIL 312000 END-IF DATEUTIL 312100 ELSE DATEUTIL 312200 CALL C-ISPF USING C-VDEFINE C-MESSAGE-VARIABLE-NAME, DATEUTIL 312300 DATEUTIL-MESSAGE, DATEUTIL 312400 C-MESSAGE-VARIABLE-F, DATEUTIL 312500 C-MESSAGE-VARIABLE-L DATEUTIL 312600 CALL C-ISPF USING W-ISPF-SERVICE C-MESSAGE-VARIABLE-NAME DATEUTIL 312700 C-SHARED-OPTION DATEUTIL 312800 END-IF. DATEUTIL 312900 DATEUTIL 313000 S9300-EXIT. DATEUTIL 313100 EXIT. DATEUTIL ./ ADD NAME=DATEUTIX 000100 IDENTIFICATION DIVISION. DATEUTIL 000200 PROGRAM-ID. DATEUTIL. DATEUTIL 000300 AUTHOR. DAVID LEIGH DATEUTIL 000400 DATE-COMPILED. DATEUTIL 000500***************************************************************** DATEUTIL 000600* "DATEUTIL" IS A GENERIC DATE UTILITY. AS A COBOL2 PROGRAM, * DATEUTIL 000700* IT IS CALLABLE FROM OTHER COBOL2 PROGRAMS IN EITHER BATCH OR * DATEUTIL 000800* CICS. IT ALSO HAS AN ISPF COMPONENT WHICH ALLOWS IT TO BE * DATEUTIL 000900* CALLED FROM AN ISPF DIALOG (CLIST, REXX, OR PROGRAM) AND TO * DATEUTIL 001000* PASS PARAMETERS IN ISPF SHARED POOL VARIABLES. * DATEUTIL 001100* * DATEUTIL 001200* DATEUTIL USES A COPYBOOK BY THE SAME NAME TO CONVERSE WITH * DATEUTIL 001300* OTHER COBOL PROGRAMS. PARAMETERS ARE PLACED IN THE DATEUTIL * DATEUTIL 001400* COPYBOOK, DATEUTIL IS CALLED, AND DATEUTIL RETURNS THE RESULTS* DATEUTIL 001500* INTO THE DATEUTIL COPYBOOK. * DATEUTIL 001600***************************************************************** DATEUTIL 001700* THE COPYBOOK FORMAT IS AS FOLLOWS: * DATEUTIL 001800* * DATEUTIL 001900* 05 DATEUTIL-MESSAGE PIC X(120). * DATEUTIL 002000* 05 DATEUTIL-WORK-AREA REDEFINES DATEUTIL-MESSAGE. * DATEUTIL 002100* 10 DU-FUNCTION PIC X(10). * DATEUTIL 002200* 10 DU-NUMBER PIC 9(06). * DATEUTIL 002300* 10 DU-DATE-1 PIC X(20). * DATEUTIL 002400* 10 DU-DAY-1-FORMAT PIC X(03). * DATEUTIL 002500* 10 DU-MONTH-1-FORMAT PIC X(05). * DATEUTIL 002600* 10 DU-YEAR-1-FORMAT PIC X(04). * DATEUTIL 002700* 10 FILLER REDEFINES DU-YEAR-1-FORMAT. * DATEUTIL 002800* 10 FILLER PIC X(02). * DATEUTIL 002900* 10 DU-YEAR-1-SWITCH PIC 9(02). * DATEUTIL 003000* 10 DU-DATE-1-FORMAT PIC X(20). * DATEUTIL 003100* 10 FILLER REDEFINES DU-DATE-1-FORMAT. * DATEUTIL 003200* 15 DU-DATE-1-FORMAT-CODE PIC 9(02). * DATEUTIL 003300* 15 FILLER PIC X(18). * DATEUTIL 003400* 10 DU-DATE-2 PIC X(20). * DATEUTIL 003500* 10 DU-DAY-2-FORMAT PIC X(03). * DATEUTIL 003600* 10 DU-MONTH-2-FORMAT PIC X(05). * DATEUTIL 003700* 10 DU-YEAR-2-FORMAT PIC X(04). * DATEUTIL 003800* 10 FILLER REDEFINES DU-YEAR-2-FORMAT. * DATEUTIL 003900* 10 FILLER PIC X(02). * DATEUTIL 004000* 10 DU-YEAR-2-SWITCH PIC 9(02). * DATEUTIL 004100* 10 DU-DATE-2-FORMAT PIC X(20). * DATEUTIL 004200* 10 FILLER REDEFINES DU-DATE-2-FORMAT. * DATEUTIL 004300* 15 DU-DATE-2-FORMAT-CODE PIC 9(02). * DATEUTIL 004400* 15 FILLER PIC X(18). * DATEUTIL 004500***************************************************************** DATEUTIL 004600* THE INDIVIDUAL DATA ELEMENTS ARE USED AS FOLLOWS: * DATEUTIL 004700* * DATEUTIL 004800* DU-FUNCTION - THE DATE FUNCTION YOU WANT TO PERFORM * DATEUTIL 004900* SHOULD BE PLACED HERE. THE VALID * DATEUTIL 005000* ISPF: DUFUNC FUNCTIONS ARE: * DATEUTIL 005100* * DATEUTIL 005200* CONVERT - CONVERT THE INPUT DATE TO THE * DATEUTIL 005300* DATE-2 FORMAT AND PLACE THE * DATEUTIL 005400* RESULT IN DU-DATE-2. * DATEUTIL 005500* SYSTEM - RETURN THE SYSTEM DATE IN THE * DATEUTIL 005600* DATE-2 FORMAT IN THE FIELD * DATEUTIL 005700* NAMED DU-DATE-2. * DATEUTIL 005800* BETWEEN - CALCULATE THE NUMBER OF DAYS * DATEUTIL 005900* (ACTUAL CALENDAR DAYS) BETWEEN* DATEUTIL 006000* THE DATE IN DU-DATE-1 AND * DATEUTIL 006100* DU-DATE-2. EITHER DATE CAN BE* DATEUTIL 006200* "LARGER". * DATEUTIL 006300* INCREMENT - INCREMENT THE DATE IN * DATEUTIL 006400* DU-DATE-1 BY THE NUMBER IN * DATEUTIL 006500* DU-NUMBER AND PLACE THE RESULT* DATEUTIL 006600* IN DU-DATE-2 IN THE FORMAT * DATEUTIL 006700* SPECIFIED BY THE DATE-2 * DATEUTIL 006800* FORMAT. * DATEUTIL 006900* DECREMENT - DECREMENT THE DATE IN * DATEUTIL 007000* DU-DATE-1 BY THE NUMBER IN * DATEUTIL 007100* DU-NUMBER AND PLACE THE RESULT* DATEUTIL 007200* IN DU-DATE-2 IN THE FORMAT * DATEUTIL 007300* SPECIFIED BY THE DATE-2 * DATEUTIL 007400* FORMAT. * DATEUTIL 007500* * DATEUTIL 007600* IF THE FUNCTION IS LEFT BLANK AND * DATEUTIL 007700* DU-DATE-2 IS BLANK, THE FUNCTION THAT WILL* DATEUTIL 007800* BE EXECUTED IS "CONVERT". IF THE FUNCTION* DATEUTIL 007900* IS LEFT BLANK BUT DU-DATE-2 HAS A DATE IN * DATEUTIL 008000* IT, THE FUNCTION THAT WILL BE EXECUTED IS * DATEUTIL 008100* "BETWEEN". * DATEUTIL 008200* * DATEUTIL 008300* DU-NUMBER - THIS FIELD IS AN UN-SIGNED DISPLAY NUMERIC* DATEUTIL 008400* FIELD WHICH IS USED IN ONE OF TWO WAYS. * DATEUTIL 008500* ISPF: DUNUMBER IF THE FUNCTION IS "BETWEEN", DU-NUMBER * DATEUTIL 008600* WILL CONTAIN THE NUMBER OF DAYS WHICH WERE* DATEUTIL 008700* CALCULATED TO HAVE BEEN BEWTEEN DATE 1 AND* DATEUTIL 008800* DATE 2. IF THE FUNCTION IS "INCREMENT" OR* DATEUTIL 008900* "DECREMENT", DU-NUMBER MUST CONTAIN THE * DATEUTIL 009000* NUMBER OF DAYS BY WHICH DU-DATE-1 MUST BE * DATEUTIL 009100* INCREMENTED OR DECREMENTED. * DATEUTIL 009200* * DATEUTIL 009300* DU-DATE-1 - THIS FIELD CONTAINS THE INPUT TO THE * DATEUTIL 009400* "CONVERT", "INCREMENT" AND "DECREMENT" * DATEUTIL 009500* ISPF: DUDATE1 FUNCTIONS. IT CONTAINS ONE HALF OF THE * DATEUTIL 009600* INPUT DATES FOR THE "BETWEEN" FUNCTION. * DATEUTIL 009700* IF THIS FIELD IS LEFT BLANK, THE SYSTEM * DATEUTIL 009800* DATE WILL BE SUBSTITUTED FOR IT, AND ALL * DATEUTIL 009900* ALL REMAINING PROCESSING WILL OCCUR AS IF * DATEUTIL 010000* A JULIAN DATE THAT HAPPENS TO BE "TODAY" * DATEUTIL 010100* HAD BEEN ENTERED IN DU-DATE-1. * DATEUTIL 010200* * DATEUTIL 010300* DU-DAY-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 010400* THE "DAY" PORTION OF DU-DATE-1. THE * DATEUTIL 010500* ISPF: DUDY1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 010600* * DATEUTIL 010700* DD - THE 2 DIGIT DAY OF THE MONTH * DATEUTIL 010800* ZD - THE 2 DIGIT DAY OF THE MONTH WITH * DATEUTIL 010900* LEADING ZEROS SUPPRESSED * DATEUTIL 011000* DDD - THE 3 DIGIT DAY OF THE YEAR * DATEUTIL 011100* ZZD - THE 3 DIGIT DAY OF THE YEAR WITH * DATEUTIL 011200* LEADING ZEROS SUPPRESSED * DATEUTIL 011300* * DATEUTIL 011400* IF THE FUNCTION IS "SYSTEM" OR DU-DATE-1 * DATEUTIL 011500* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 011600* THIS FIELD NEED NOT BE SPECIFIED. * DATEUTIL 011700* * DATEUTIL 011800* DU-MONTH-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 011900* THE "MONTH" PORTION OF DU-DATE-1. THE * DATEUTIL 012000* ISPF: DUMO1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 012100* * DATEUTIL 012200* MM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 012300* ZM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 012400* (ZERO SUPPRESSED) * DATEUTIL 012500* MMM - THE 3 LETTER MONTH ABBREVIATION * DATEUTIL 012600* MONTH - THE FULL MONTH NAME * DATEUTIL 012700* * DATEUTIL 012800* IF THE FUNCTION IS "SYSTEM", OR DU-DATE-1 * DATEUTIL 012900* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 013000* OR DU-DATE-1 IS A JULIAN DATE, THIS FIELD * DATEUTIL 013100* NEED NOT BE SPECIFIED. * DATEUTIL 013200* * DATEUTIL 013300* DU-YEAR-1-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 013400* THE "YEAR" PORTION OF DU-DATE-1. THE * DATEUTIL 013500* ISPF: DUYR1FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 013600* * DATEUTIL 013700* YY - THE 2 DIGIT DECADE OF THE CENTURY * DATEUTIL 013800* YYYY - THE FULL FOUR DIGIT YEAR * DATEUTIL 013900* * DATEUTIL 014000* IF THE FUNCTION IS "SYSTEM" OR DU-DATE-1 * DATEUTIL 014100* IS ALLOWED TO DEFAULT TO THE SYSTEM DATE, * DATEUTIL 014200* THIS FIELD NEED NOT BE SPECIFIED. IF THE * DATEUTIL 014300* FORMAT IS "YY", "19" WILL ALWAYS BE * DATEUTIL 014400* ASSUMED TO BE THE CENTURY AND WILL BE * DATEUTIL 014500* USED IN ALL SUBSEQUENT PROCESSING * DATEUTIL 014600* THROUGHOUT THAT EXECUTION OF THE PROGRAM. * DATEUTIL 014700* * DATEUTIL 014800* DU-YEAR-1-SWITCH - THIS FIELD LETS YOU OVERRIDE THE YEAR * DATEUTIL 014900* WHICH IS USED TO DETERMINE WHETHER A 2 * DATEUTIL 015000* ISPF: DUYR1SWT DIGIT YEAR FALLS IN THE CENTURY "19" OR * DATEUTIL 015100* "20". THE DEFAULT FOR THE PROGRAM IS 50. * DATEUTIL 015200* CONSEQUENTLY, YOU WOULD MOVE "YY" TO * DATEUTIL 015300* DU-YEAR-1-FORMAT (OR PICK ONE OF THE 2 * DATEUTIL 015400* DIGIT YEAR FORMAT CODES) AND THEN MOVE * DATEUTIL 015500* YOUR "SWITCH YEAR", (E.G. "60") TO * DATEUTIL 015600* DU-YEAR-1-SWITCH. THEN, WHEN THE PROGRAM * DATEUTIL 015700* ENCOUNTERS YOUR TWO DIGIT YEAR, AND THE * DATEUTIL 015800* YEAR IS LESS THAN 60, THEN "20" WILL BE * DATEUTIL 015900* USED FOR THE CENTURY. OTHERWISE "19" * DATEUTIL 016000* WILL BE USED. * DATEUTIL 016100* * DATEUTIL 016200* DU-DATE-1-FORMAT - THIS FIELD DESCRIBES HOW THE "DAY", * DATEUTIL 016300* "MONTH", AND "YEAR" COMPONENTS ARE * DATEUTIL 016400* ISPF: DUDT1FMT ARRANGED IN DU-DATE-1 SO THAT THE PROGRAM * DATEUTIL 016500* CAN PROPERLY PARSE THE INPUT DATE FOR USE * DATEUTIL 016600* IN FURTHER PROGRAM PROCESSING. THE * DATEUTIL 016700* LETTERS "Y", "M", AND "D" ARE USED TO * DATEUTIL 016800* REPRESENT THE YEAR, MONTH, AND DAY * DATEUTIL 016900* COMPONENTS. EXAMPLES AND FURTHER * DATEUTIL 017000* EXPLANATION OF HOW THE DAY-FORMAT, * DATEUTIL 017100* MONTH-FORMAT, YEAR-FORMAT, AND * DATEUTIL 017200* DATE-FORMAT COMPONENTS WORK TOGETHER IS * DATEUTIL 017300* FOUND LATER ON IN THIS DOCUMENTATION AREA.* DATEUTIL 017400* * DATEUTIL 017500* DU-DATE-1-FORMAT-CODE - THIS FIELD PERMITS YOU TO SPECIFY A * DATEUTIL 017600* FORMAT FOR DU-DATE-1 VIA A NUMBER INSTEAD * DATEUTIL 017700* ISPF: DUDT1FCD THE "BUILD YOUR OWN" FORMAT. IF YOU USE * DATEUTIL 017800* DU-DATE-1-FORMAT-CODE, ANY VALUES IN: * DATEUTIL 017900* DU-DAY-1-FORMAT * DATEUTIL 018000* DU-MONTH-1-FORMAT * DATEUTIL 018100* DU-YEAR-1-FORMAT * DATEUTIL 018200* DU-DATE-1-FORMAT * DATEUTIL 018300* WILL BE OVERWRITTEN TO CONFORM TO THE * DATEUTIL 018400* VALUE IN THE FORMAT CODE FIELD. THE * DATEUTIL 018500* FORMAT CODE FIELD WILL ALSO BE OVER- * DATEUTIL 018600* WRITTEN WITH THE EXPANDED DATE FORMAT * DATEUTIL 018700* THAT THE CODE REPRESENTS. FOLLOWING IS * DATEUTIL 018800* THE CODE VALUES AND THE FORMATS WHICH * DATEUTIL 018900* THEY REPRESENT: * DATEUTIL 019000* 1 YYYY-MM-DD * DATEUTIL 019100* 2 YYYY.MM.DD * DATEUTIL 019200* 3 YYYY/MM/DD * DATEUTIL 019300* 4 YYYY MM DD * DATEUTIL 019400* 5 YYYYMMDD * DATEUTIL 019500* 6 MM-DD-YYYY * DATEUTIL 019600* 7 MM.DD.YYYY * DATEUTIL 019700* 8 MM/DD/YYYY * DATEUTIL 019800* 9 MM DD YYYY * DATEUTIL 019900* 10 MMDDYYYY * DATEUTIL 020000* 11 YYYY-DDD * DATEUTIL 020100* 12 YYYY.DDD * DATEUTIL 020200* 13 YYYY/DDD * DATEUTIL 020300* 14 YYYY DDD * DATEUTIL 020400* 15 YYYYDDD * DATEUTIL 020500* 16 YY-MM-DD * DATEUTIL 020600* 17 YY.MM.DD * DATEUTIL 020700* 18 YY/MM/DD * DATEUTIL 020800* 19 YY MM DD * DATEUTIL 020900* 20 YYMMDD * DATEUTIL 021000* 21 MM-DD-YY * DATEUTIL 021100* 22 MM.DD.YY * DATEUTIL 021200* 23 MM/DD/YY * DATEUTIL 021300* 24 MM DD YY * DATEUTIL 021400* 25 MMDDYY * DATEUTIL 021500* 26 YY-DDD * DATEUTIL 021600* 27 YY.DDD * DATEUTIL 021700* 28 YY/DDD * DATEUTIL 021800* 29 YY DDD * DATEUTIL 021900* 30 YYDDD * DATEUTIL 022000* 31 DD-MMM-YYYY * DATEUTIL 022100* 32 DD.MMM.YYYY * DATEUTIL 022200* 33 DD/MMM/YYYY * DATEUTIL 022300* 34 DD MMM YYYY * DATEUTIL 022400* 35 DDMMMYYYY * DATEUTIL 022500* 36 DD-MMM-YY * DATEUTIL 022600* 37 DD.MMM.YY * DATEUTIL 022700* 38 DD/MMM/YY * DATEUTIL 022800* 39 DD MMM YY * DATEUTIL 022900* 40 DDMMMYY * DATEUTIL 023000* 41 YYYY-MMM-DD * DATEUTIL 023100* 42 YYYY.MMM.DD * DATEUTIL 023200* 43 YYYY/MMM/DD * DATEUTIL 023300* 44 YYYY MMM DD * DATEUTIL 023400* 45 YYYYMMMDD * DATEUTIL 023500* 46 YY-MMM-DD * DATEUTIL 023600* 47 YY.MMM.DD * DATEUTIL 023700* 48 YY/MMM/DD * DATEUTIL 023800* 49 YY MMM DD * DATEUTIL 023900* 50 YYMMMDD * DATEUTIL 024000* 51 FULLMONTH ZD, YYYY * DATEUTIL 024100* 52 FULLMONTH DD, YYYY * DATEUTIL 024200* 53 DAY-OF-THE-WEEK * DATEUTIL 024300* * DATEUTIL 024400* DU-DATE-2 - THIS FIELD CONTAINS THE OUTPUT OF ALL THE * DATEUTIL 024500* DATE FUNCTIONS EXCEPT FOR "BETWEEN". IN * DATEUTIL 024600* ISPF: DUDATE2 THE "BETWEEN" FUNCTION, DU-DATE-2 IS ONE * DATEUTIL 024700* OF THE INPUT FIELDS. THE FORMAT OF THE * DATEUTIL 024800* THE DATE IS DETERMINED BY THE FORMAT * DATEUTIL 024900* SPECIFICATIONS IN DU-DAY-2-FORMAT, * DATEUTIL 025000* DU-MONTH-2-FORMAT, DU-YEAR-2-FORMAT, AND * DATEUTIL 025100* DU-DATE-2-FORMAT. * DATEUTIL 025200* * DATEUTIL 025300* DU-DAY-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 025400* THE "DAY" PORTION OF DU-DATE-2. THE * DATEUTIL 025500* ISPF: DUDY2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 025600* * DATEUTIL 025700* DD - THE 2 DIGIT DAY OF THE MONTH * DATEUTIL 025800* ZD - THE 2 DIGIT DAY OF THE MONTH WITH * DATEUTIL 025900* LEADING ZEROS SUPPRESSED * DATEUTIL 026000* DDD - THE 3 DIGIT DAY OF THE YEAR * DATEUTIL 026100* ZZD - THE 3 DIGIT DAY OF THE YEAR WITH * DATEUTIL 026200* LEADING ZEROS SUPPRESSED * DATEUTIL 026300* D - THE 1 DIGIT DAY OF THE WEEK * DATEUTIL 026400* (MONDAY IS 1) * DATEUTIL 026500* DA - THE 2 LETTER DAY OF THE WEEK ABBR. * DATEUTIL 026600* DAY - THE FULL DAY OF THE WEEK NAME * DATEUTIL 026700* * DATEUTIL 026800* IF THE FUNCTION IS "BETWEEN", YOU MAY * DATEUTIL 026900* NOT USE FORMATS "D", "DA" OR "DAY" SINCE * DATEUTIL 027000* THEY WILL NOT GIVE ENOUGH DATE TO PROVIDE * DATEUTIL 027100* AN EXACT DATE FOR CALCULATIONS. * DATEUTIL 027200* * DATEUTIL 027300* DU-MONTH-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 027400* THE "MONTH" PORTION OF DU-DATE-2. THE * DATEUTIL 027500* ISPF: DUMO2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 027600* * DATEUTIL 027700* MM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 027800* ZM - THE 2 DIGIT MONTH OF THE YEAR * DATEUTIL 027900* (ZERO SUPPRESSED) * DATEUTIL 028000* MMM - THE 3 LETTER MONTH ABBREVIATION * DATEUTIL 028100* MONTH - THE FULL MONTH NAME * DATEUTIL 028200* * DATEUTIL 028300* DU-YEAR-2-FORMAT - THIS FIELD CONTAINS THE FORMAT CODE FOR * DATEUTIL 028400* THE "YEAR" PORTION OF DU-DATE-2. THE * DATEUTIL 028500* ISPF: DUYR2FMT VALID FORMATS ARE AS FOLLOWS: * DATEUTIL 028600* * DATEUTIL 028700* YY - THE 2 DIGIT DECADE OF THE CENTURY * DATEUTIL 028800* YYYY - THE FULL FOUR DIGIT YEAR * DATEUTIL 028900* * DATEUTIL 029000* IF THE FUNCTION IS "BETWEEN" AND THE * DATEUTIL 029100* FORMAT IS "YY", THE CENTURY WILL ALWAYS * DATEUTIL 029200* BE ASSUMED TO BE "19". IF YOU WANT TO * DATEUTIL 029300* SPECIFY ANY OTHER CENTURY OTHER THAN "19",* DATEUTIL 029400* YOU MUST PROVIDE THE FULL 4 DIGIT YEAR. * DATEUTIL 029500* * DATEUTIL 029600* DU-YEAR-2-SWITCH - THIS FIELD LETS YOU OVERRIDE THE YEAR * DATEUTIL 029700* WHICH IS USED TO DETERMINE WHETHER A 2 * DATEUTIL 029800* ISPF: DUYR2SWT DIGIT YEAR FALLS IN THE CENTURY "19" OR * DATEUTIL 029900* "20". THE DEFAULT FOR THE PROGRAM IS 50. * DATEUTIL 030000* CONSEQUENTLY, YOU WOULD MOVE "YY" TO * DATEUTIL 030100* DU-YEAR-2-FORMAT (OR PICK ONE OF THE 2 * DATEUTIL 030200* DIGIT YEAR FORMAT CODES) AND THEN MOVE * DATEUTIL 030300* YOUR "SWITCH YEAR", (E.G. "60") TO * DATEUTIL 030400* DU-YEAR-2-SWITCH. THEN, WHEN THE PROGRAM * DATEUTIL 030500* ENCOUNTERS YOUR TWO DIGIT YEAR, AND THE * DATEUTIL 030600* YEAR IS LESS THAN 60, THEN "20" WILL BE * DATEUTIL 030700* USED FOR THE CENTURY. OTHERWISE "19" * DATEUTIL 030800* WILL BE USED. * DATEUTIL 030900* * DATEUTIL 031000* DU-DATE-2-FORMAT - THIS FIELD DESCRIBES HOW THE "DAY", * DATEUTIL 031100* "MONTH", AND "YEAR" COMPONENTS ARE * DATEUTIL 031200* ISPF: DUDT2FMT ARRANGED IN DU-DATE-2 SO THAT THE PROGRAM * DATEUTIL 031300* CAN PROPERLY PARSE THE INPUT DATE FOR USE * DATEUTIL 031400* IN "BETWEEN" PROCESSING, OR SO THE * DATEUTIL 031500* PROGRAM CAN CREATE THE OUTPUT DATE IN THE * DATEUTIL 031600* DESIRED FORMAT IN FIELD DU-DATE-2. THE * DATEUTIL 031700* LETTERS "Y", "M", AND "D" ARE USED TO * DATEUTIL 031800* REPRESENT THE YEAR, MONTH, AND DAY * DATEUTIL 031900* COMPONENTS. EXAMPLES AND FURTHER * DATEUTIL 032000* EXPLANATION OF HOW THE DAY-FORMAT, * DATEUTIL 032100* MONTH-FORMAT, YEAR-FORMAT, AND * DATEUTIL 032200* DATE-FORMAT COMPONENTS WORK TOGETHER IS * DATEUTIL 032300* FOUND LATER ON IN THIS DOCUMENTATION AREA.* DATEUTIL 032400* * DATEUTIL 032500* DU-DATE-2-FORMAT-CODE - THIS FIELD PERMITS YOU TO SPECIFY A * DATEUTIL 032600* FORMAT FOR DU-DATE-2 VIA A NUMBER INSTEAD * DATEUTIL 032700* ISPF: DUDT2FCD THE "BUILD YOUR OWN" FORMAT. IF YOU USE * DATEUTIL 032800* DU-DATE-2-FORMAT-CODE, ANY VALUES IN: * DATEUTIL 032900* DU-DAY-2-FORMAT * DATEUTIL 033000* DU-MONTH-2-FORMAT * DATEUTIL 033100* DU-YEAR-2-FORMAT * DATEUTIL 033200* DU-DATE-2-FORMAT * DATEUTIL 033300* WILL BE OVERWRITTEN TO CONFORM TO THE * DATEUTIL 033400* VALUE IN THE FORMAT CODE FIELD. THE * DATEUTIL 033500* FORMAT CODE FIELD WILL ALSO BE OVER- * DATEUTIL 033600* WRITTEN WITH THE EXPANDED DATE FORMAT * DATEUTIL 033700* THAT THE CODE REPRESENTS. FOLLOWING IS * DATEUTIL 033800* THE CODE VALUES AND THE FORMATS WHICH * DATEUTIL 033900* THEY REPRESENT: * DATEUTIL 034000* 1 YYYY-MM-DD * DATEUTIL 034100* 2 YYYY.MM.DD * DATEUTIL 034200* 3 YYYY/MM/DD * DATEUTIL 034300* 4 YYYY MM DD * DATEUTIL 034400* 5 YYYYMMDD * DATEUTIL 034500* 6 MM-DD-YYYY * DATEUTIL 034600* 7 MM.DD.YYYY * DATEUTIL 034700* 8 MM/DD/YYYY * DATEUTIL 034800* 9 MM DD YYYY * DATEUTIL 034900* 10 MMDDYYYY * DATEUTIL 035000* 11 YYYY-DDD * DATEUTIL 035100* 12 YYYY.DDD * DATEUTIL 035200* 13 YYYY/DDD * DATEUTIL 035300* 14 YYYY DDD * DATEUTIL 035400* 15 YYYYDDD * DATEUTIL 035500* 16 YY-MM-DD * DATEUTIL 035600* 17 YY.MM.DD * DATEUTIL 035700* 18 YY/MM/DD * DATEUTIL 035800* 19 YY MM DD * DATEUTIL 035900* 20 YYMMDD * DATEUTIL 036000* 21 MM-DD-YY * DATEUTIL 036100* 22 MM.DD.YY * DATEUTIL 036200* 23 MM/DD/YY * DATEUTIL 036300* 24 MM DD YY * DATEUTIL 036400* 25 MMDDYY * DATEUTIL 036500* 26 YY-DDD * DATEUTIL 036600* 27 YY.DDD * DATEUTIL 036700* 28 YY/DDD * DATEUTIL 036800* 29 YY DDD * DATEUTIL 036900* 30 YYDDD * DATEUTIL 037000* 31 DD-MMM-YYYY * DATEUTIL 037100* 32 DD.MMM.YYYY * DATEUTIL 037200* 33 DD/MMM/YYYY * DATEUTIL 037300* 34 DD MMM YYYY * DATEUTIL 037400* 35 DDMMMYYYY * DATEUTIL 037500* 36 DD-MMM-YY * DATEUTIL 037600* 37 DD.MMM.YY * DATEUTIL 037700* 38 DD/MMM/YY * DATEUTIL 037800* 39 DD MMM YY * DATEUTIL 037900* 40 DDMMMYY * DATEUTIL 038000* 41 YYYY-MMM-DD * DATEUTIL 038100* 42 YYYY.MMM.DD * DATEUTIL 038200* 43 YYYY/MMM/DD * DATEUTIL 038300* 44 YYYY MMM DD * DATEUTIL 038400* 45 YYYYMMMDD * DATEUTIL 038500* 46 YY-MMM-DD * DATEUTIL 038600* 47 YY.MMM.DD * DATEUTIL 038700* 48 YY/MMM/DD * DATEUTIL 038800* 49 YY MMM DD * DATEUTIL 038900* 50 YYMMMDD * DATEUTIL 039000* 51 FULLMONTH ZD, YYYY * DATEUTIL 039100* 52 FULLMONTH DD, YYYY * DATEUTIL 039200* 53 DAY-OF-THE-WEEK * DATEUTIL 039300* * DATEUTIL 039400* DATEUTIL-MESSAGE - THIS FIELD IS A REDEFINES OF THE ENTIRE * DATEUTIL 039500* DATEUTIL-WORK-AREA. IF THE DATEUTIL * DATEUTIL 039600* ISPF: DUMSG PROGRAM ENDS WITH AN INVALID USER RETURN * DATEUTIL 039700* CODE (ANYTHING GREATER THAN +1999), THEN * DATEUTIL 039800* THE DATEUTIL-WORK-AREA IS CLEARED OUT AND * DATEUTIL 039900* DATEUTIL-MESSAGE WILL CONTAIN AN ERROR * DATEUTIL 040000* MESSAGE INDICATING WHAT PROBLEM CAUSED * DATEUTIL 040100* DATEUTIL TO TERMINATE PROCESSING. IT IS * DATEUTIL 040200* A GOOD IDEA TO NOT USE DATEUTIL-WORK-AREA * DATEUTIL 040300* IN YOUR PROGRAM FOR ANYTHING BUT * DATEUTIL 040400* COMMUNICATING WITH DATEUTIL. THAT WAY, * DATEUTIL 040500* IF THERE IS A PROBLEM WITH DATEUTIL, AND * DATEUTIL 040600* DATEUTIL HAS OVERWRITTEN THE * DATEUTIL 040700* DATEUTIL-WORK-AREA WITH THE ERROR MESSAGE,* DATEUTIL 040800* AND YOU HAVE YOUR INPUT IN YOUR OWN WORK * DATEUTIL 040900* AREA, YOU WILL BE ABLE TO DISPLAY THE * DATEUTIL 041000* MESSAGE AND YOUR WORK AREAS TO HELP IN * DATEUTIL 041100* DEBUGGING THE PROBLEM. ADDITIONALLY, IT * DATEUTIL 041200* IS ALWAYS A GOOD IDEA TO INITIALIZE THE * DATEUTIL 041300* DATEUTIL-WORK-AREA BEFORE MOVING THINGS * DATEUTIL 041400* TO IT SO THAT YOU MAKE SURE THAT IN * DATEUTIL 041500* ADDITION TO YOUR PARAMETERS WHICH YOU ARE * DATEUTIL 041600* PASSING, THERE IS NOT SOME GARBAGE IN THE * DATEUTIL 041700* OTHER FIELDS. * DATEUTIL 041800***************************************************************** DATEUTIL 041900* BUILDING YOUR OWN DATE FORMATS! * DATEUTIL 042000* * DATEUTIL 042100* INSTEAD OF LIMITING YOU TO THE FINITE LIST OF DATE FORMATS * DATEUTIL 042200* WHICH YOU CAN PASS OR RECEIVE, DATEUTIL ALSO ALLOWS YOU TO * DATEUTIL 042300* BUILD YOUR OWN DATE INPUT AND OUTPUT FORMATS BY SPECIFYING A * DATEUTIL 042400* FORMAT FOR EACH COMPONENT OF THE DATE (THE DAY, MONTH, AND * DATEUTIL 042500* YEAR) AND THE OVERALL COMPOSITE FORMAT OF HOW THE COMPONENTS * DATEUTIL 042600* FIT TOGETHER. YOU CAN USE STANDARD FORMAT CODES FOR BOTH * DATEUTIL 042700* DATE 1 AND DATE 2 OR BUILD YOUR OWN FOR BOTH OR DO STANDARD * DATEUTIL 042800* FOR ONE AND "HOME BUILT" FOR THE OTHER. * DATEUTIL 042900* * DATEUTIL 043000* THE "DATE" FORMAT FIELD (EITHER FOR DATE-1 OR DATE-2) IS THE * DATEUTIL 043100* FORMAT OF THE ENTIRE DATE, AND THE "DAY", "MONTH", AND "YEAR" * DATEUTIL 043200* FORMAT FIELDS ARE THE FORMATS OF EACH OF THOSE COMPONENTS OF * DATEUTIL 043300* THE DATE. * DATEUTIL 043400* * DATEUTIL 043500* THE BEST WAY TO EXPLAIN HOW THIS WORKS IS PROBABLY BY SHOWING * DATEUTIL 043600* SOME EXAMPLES. WHAT FOLLOWS IS A LIST OF DATES AND HOW THEIR * DATEUTIL 043700* FORMATS WOULD BE REPRESENTED IN THE FORMAT FIELDS. * DATEUTIL 043800* * DATEUTIL 043900* DAY MONTH YEAR * DATEUTIL 044000* ACTUAL DATE FIELD FMT FMT FMT DATE FORMAT * DATEUTIL 044100* -------------------- --- ----- ---- -------------------- * DATEUTIL 044200* A THURSDAY IN APRIL DAY MONTH A D IN M * DATEUTIL 044300* 12/31/91 DD MM YY M/D/Y * DATEUTIL 044400* MARCH 5, 1985 ZD MONTH YYYY M D, Y * DATEUTIL 044500* 13 SEP 2001 DD MMM YYYY D M Y * DATEUTIL 044600* 1999...JULY...24 DD MONTH YYYY Y...M...D * DATEUTIL 044700* FRIDAY DAY D * DATEUTIL 044800* JANUARY MONTH M * DATEUTIL 044900* 1776 YYYY Y * DATEUTIL 045000* 91 YY Y * DATEUTIL 045100* 13/86 MM YY M/Y * DATEUTIL 045200* 1987234 DDD YYYY YD * DATEUTIL 045300* 1995-10-20 DD MM YYYY Y-M-D * DATEUTIL 045400* 7 D D * DATEUTIL 045500* 7 ZD D * DATEUTIL 045600* 7 ZZD D * DATEUTIL 045700* 07 DD D * DATEUTIL 045800* 07 MM M * DATEUTIL 045900* 7.1.81 ZD ZM YY M.D.Y * DATEUTIL 046000* 7.1.81 ZD ZM YY D.M.Y * DATEUTIL 046100* * DATEUTIL 046200* AS YOU CAN SEE, THERE ARE A LOT OF DATE FORMATS THAT CAN BE * DATEUTIL 046300* REPRESENTED WITH THESE FORMAT COMBINATIONS. THERE ARE A FEW * DATEUTIL 046400* LIMITATIONS HOWEVER. FIRST, IN THE THE "DATE" FORMAT FIELD, * DATEUTIL 046500* THE LETTERS "Y", "M", AND "D" OBVIOUSLY HAVE SPECIAL * DATEUTIL 046600* SIGNIFICANCE. IF YOU WANTED TO INCLUDE THE ABSOLUTE TEXT OF * DATEUTIL 046700* A WORD LIKE "DAY", YOU WOULD NOT GET THE RESULTS YOU WANTED. * DATEUTIL 046800* THE "D" IN "DAY" WOULD GET CONVERTED TO THE "DAY" COMPONENT * DATEUTIL 046900* OF THE DATE, AND THE "Y" IN "DAY" WOULD GET CONVERTED TO THE * DATEUTIL 047000* "YEAR" PORTION OF THE DATE. "DAY" COULD END UP LOOKING LIKE * DATEUTIL 047100* "13A1991"! * DATEUTIL 047200* * DATEUTIL 047300* THE OTHER LIMITATION IS THAT BOTH THE DATE FIELD AND THE * DATEUTIL 047400* DATE FORMAT FIELD ARE 20 BYTES LONG. THAT DOES LIMIT HOW * DATEUTIL 047500* BIG YOU CAN MAKE YOUR DATE OR YOUR DATE FORMAT. ALSO, SINCE * DATEUTIL 047600* "D", "M", AND "Y" ARE USUALLY EXPANDED INTO SOMETHING BIGGER * DATEUTIL 047700* IN THE ACTUAL DATE, A DATE FORMAT FIELD WHICH IS 15 TO 20 * DATEUTIL 047800* BYTES LONG MAY WELL CREATE A DATE THAT IS TRUNCATED IN SOME * DATEUTIL 047900* WAY. * DATEUTIL 048000* * DATEUTIL 048100* REGARDLESS OF THE OUTPUT DATE FORMAT, IT WILL BE A LEFT * DATEUTIL 048200* JUSTIFIED PIC X(20) FIELD. IT WILL BE UP TO THE CALLING * DATEUTIL 048300* PROGRAM TO PLACE THE DATE INTO WHAT EVER FIELDS ARE NECESSARY.* DATEUTIL 048400***************************************************************** DATEUTIL 048500* DATEUTIL PROCESSING IN ISPF * DATEUTIL 048600* * DATEUTIL 048700* IF YOU NEED TO PERFORM ADVANCED DATE PROCESSING FROM A CLIST, * DATEUTIL 048800* REXX EXEC, OR PROGRAM IN AN ISPF ENVIRONMENT, YOU CAN SEND * DATEUTIL 048900* YOUR INPUT AND RECEIVE YOUR OUTPUT VIA ISPF SHARED POOL * DATEUTIL 049000* VARIABLES AND CALL DATEUTIL VIA THE ISPEXEC SELECT SERVICE. * DATEUTIL 049100* * DATEUTIL 049200* WHEN CALLING DATEUTIL YOUR SYNTAX MUST BE: * DATEUTIL 049300* * DATEUTIL 049400* ISPEXEC SELECT PGM(DATEUTIL) PARM(ISPF) * DATEUTIL 049500* * DATEUTIL 049600* THE PARM OF "ISPF" IS VERY IMPORTANT. THAT IS HOW DATEUTIL * DATEUTIL 049700* KNOWS TO DO IT'S INPUT AND OUTPUT WITH ISPF SHARED POOL * DATEUTIL 049800* VARIABLES INSTEAD OF THE LINKAGE SECTION PROCESSING IN DIRECT * DATEUTIL 049900* COBOL-TO-COBOL PROCESSING. * DATEUTIL 050000* * DATEUTIL 050100* BEFORE CALLING DATEUTIL, YOU WILL NEED TO SET SOME VARIABLES * DATEUTIL 050200* TO CERTAIN VALUES AND THEN VPUT THEM INTO THE SHARED POOL. * DATEUTIL 050300* WHEN THE PROGRAM IS FINISHED PROCESSING, YOU NEED TO CHECK * DATEUTIL 050400* THE RETURN CODE, AND THEN VGET EITHER THE RESULT VARIABLE YOU * DATEUTIL 050500* DESIRE, OR THE ERROR MESSAGE VARIABLE IF THE RETURN CODE FROM * DATEUTIL 050600* DATEUTIL INDICATED THAT AN ERROR OCCURRED. * DATEUTIL 050700* * DATEUTIL 050800* THE VARIABLES ARE DESCRIBED ABOVE ALONG WITH THE COPY BOOK * DATEUTIL 050900* DATA ELEMENTS THAT THEY MIRROR. YOU NEED TO POPULATE THE * DATEUTIL 051000* VARIABLES WITH THE SAME VALUES THAT YOU WOULD THE DATA * DATEUTIL 051100* ELEMENTS. * DATEUTIL 051200***************************************************************** DATEUTIL 051300 DATEUTIL 051400/************************* REVISIONS **************************** DATEUTIL 051500** PUT INTO PRODUCTION * D. LEIGH & W. WISEMAN * * DATEUTIL 051600** EST PRD 3/16/92 * VERSION 1.00 * * DATEUTIL 051700***************************************************************** DATEUTIL 051800** 799 FUNDING SOURCE ENHANCEMENT * A17322 * DAVID LEIGH * DATEUTIL 051900** 1. I PUT THE BLANK LINES BACK INTO THE PROGRAM WHICH * DATEUTIL 052000** WENDY HAD REMOVED TO ENHABLE THE PROGRAM TO PASS * DATEUTIL 052100** REFCHECK (ARRRRRRGH!) * DATEUTIL 052200** 2. THE PROGRAM WAS HAVING SOME PROBLEMS IN THAT WHEN IT * DATEUTIL 052300** WAS CALLED REPEATEDLY FROM ANOTHER COBOL PROGRAM, THE * DATEUTIL 052400** PRIOR RETURN CODE WAS BEING RETAINED, EVEN THOUGH THE * DATEUTIL 052500** RESULTS WERE CORRECT. THIS SIMPLY INVOLVED * DATEUTIL 052600** INITIALIZING THE RETURN CODE FOR EACH PROGRAM * DATEUTIL 052700** EXECUTION. * DATEUTIL 052800** ESTIMATED PRODUCTION MOVE: 9/18/1992 * VERSION 2.00 * DATEUTIL 052900***************************************************************** DATEUTIL 052910** DATE UTILITY ENHANCEMENT * ?????? * DAVID LEIGH * DATEUTIL 052911** ESTIMATED PRODUCTION MOVE: ??/??/???? * VERSION 2.00 * DATEUTIL 052920** I ADDED THE CAPABILITY TO PASS 1 OF 53 FORMAT CODES TO * DATEUTIL 052930** THE PROGRAM TO PERMIT AUTOMATIC DATE FORMATS AS WELL AS * DATEUTIL 052940** THE "BUILD YOUR OWN" VARIETY. I ALSO ADDED THE ABILITY * DATEUTIL 052950** TO PASS A "SWITCH" YEAR INTO THE PROGRAM WHICH PERMITS * DATEUTIL 052960** DATEUTIL TO DETERMINE THE CENTURY BASED ON THE DECADE * DATEUTIL 052970** DATE. THE DEFAULT IS 50, BUT ANY 2 DIGIT YEAR CAN BE * DATEUTIL 052980** PASSED IN IF NECESSARY. * DATEUTIL 052993***************************************************************** DATEUTIL 053000/**************************************************************** DATEUTIL 053100* E N V I R O N M E N T D I V I S I O N * DATEUTIL 053200***************************************************************** DATEUTIL 053300 ENVIRONMENT DIVISION. DATEUTIL 053400 DATEUTIL 053500 INPUT-OUTPUT SECTION. DATEUTIL 053600 DATEUTIL 053700 FILE-CONTROL. DATEUTIL 053800 DATEUTIL 053900/**************************************************************** DATEUTIL 054000* D A T A D I V I S I O N * DATEUTIL 054100***************************************************************** DATEUTIL 054200 DATA DIVISION. DATEUTIL 054300 DATEUTIL 054400 FILE SECTION. DATEUTIL 054500 DATEUTIL 054600/**************************************************************** DATEUTIL 054700* W O R K I N G - S T O R A G E S E C T I O N * DATEUTIL 054800***************************************************************** DATEUTIL 054900 WORKING-STORAGE SECTION. DATEUTIL 055000/**************************************************************** DATEUTIL 055100* C O N S T A N T S * DATEUTIL 055200***************************************************************** DATEUTIL 055300 01 CONSTANTS. DATEUTIL 055400 05 C-SWITCH-YEAR-DEFAULT PIC 9(02) VALUE 50. DATEUTIL 055500 05 C-ISPF PIC X(07) VALUE 'ISPLINK'. DATEUTIL 055600 DATEUTIL 055700 05 C-ISPF-CONSTANTS. DATEUTIL 055800 10 C-ISPF-SERVICES-AND-PARAMETERS. DATEUTIL 055900 15 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. DATEUTIL 056000 15 C-CONTROL PIC X(08) VALUE 'CONTROL '. DATEUTIL 056100 15 C-VGET PIC X(08) VALUE 'VGET '. DATEUTIL 056200 15 C-VPUT PIC X(08) VALUE 'VPUT '. DATEUTIL 056300 15 C-LIST-OPTION PIC X(08) VALUE 'LIST '. DATEUTIL 056400 15 C-ERRORS-OPTION PIC X(08) VALUE 'ERRORS '. DATEUTIL 056500 15 C-RETURN-OPTION PIC X(08) VALUE 'RETURN '. DATEUTIL 056600 15 C-SHARED-OPTION PIC X(08) VALUE 'SHARED '. DATEUTIL 056700 DATEUTIL 056800 10 C-MESSAGE-VARIABLE-NAME PIC X(08) VALUE 'DUMSG '. DATEUTIL 056900 10 C-MESSAGE-VARIABLE-L PIC S9(06) COMP VALUE +120. DATEUTIL 057000 10 C-MESSAGE-VARIABLE-F PIC X(8) VALUE 'CHAR '. DATEUTIL 057100***************************************************************** DATEUTIL 057200* NOTE: THE ORDER OF THE ISPF VARIABLE NAMES IN THE "VALUE" * DATEUTIL 057300* CLAUSE OF THE NEXT DATA ELEMENT "C-ISPF-VARIABLE-NAMES" * DATEUTIL 057400* MUST MATCH THE ORDER OF THE ELEMENTARY ITEMS DEFINED * DATEUTIL 057500* IN "C-ISPF-VARIABLE-LENGTHS", "C-ISPF-VARIABLE-FORMATS",* DATEUTIL 057600* "C-ISPF-VARIABLES", AND "W-ISPF-VARIABLES" AND THE * DATEUTIL 057610* "DATEUTIL" COPY BOOK MEMBER!!!!!!!!!!!!!!!!!!!!! * DATEUTIL 057700***************************************************************** DATEUTIL 057800 10 C-ISPF-VARIABLE-NAMES. DATEUTIL 057900 15 FILLER PIC X(33) VALUE DATEUTIL 058000 '(DUFUNC DUNUMBER DUDATE1 DUDY1FMT'. DATEUTIL 058100 15 FILLER PIC X(36) VALUE DATEUTIL 058200 ' DUMO1FMT DUYR1FMT DUYR1SWT DUDT1FCD'. DATEUTIL 058300 15 FILLER PIC X(35) VALUE DATEUTIL 058400 ' DUDT1FMT DUDATE2 DUDY2FMT DUMO2FMT'. DATEUTIL 058500 15 FILLER PIC X(37) VALUE DATEUTIL 058600 ' DUYR2FMT DUYR2SWT DUDT2FCD DUDT2FMT)'. DATEUTIL 058700 DATEUTIL 058800 10 C-ISPF-VARIABLE-LENGTHS COMP. DATEUTIL 058900 15 C-DU-FUNCTION-L PIC S9(06) VALUE +10. DATEUTIL 059000 15 C-DU-NUMBER-L PIC S9(06) VALUE +6. DATEUTIL 059100 15 C-DU-DATE-1-L PIC S9(06) VALUE +20. DATEUTIL 059200 15 C-DU-DAY-1-FORMAT-L PIC S9(06) VALUE +3. DATEUTIL 059300 15 C-DU-MONTH-1-FORMAT-L PIC S9(06) VALUE +5. DATEUTIL 059400 15 C-DU-YEAR-1-FORMAT-L PIC S9(06) VALUE +4. DATEUTIL 059500 15 C-DU-YEAR-1-SWITCH-L PIC S9(06) VALUE +2. DATEUTIL 059700 15 C-DU-DATE-1-FMTCDE-L PIC S9(06) VALUE +2. DATEUTIL 059710 15 C-DU-DATE-1-FORMAT-L PIC S9(06) VALUE +20. DATEUTIL 059800 15 C-DU-DATE-2-L PIC S9(06) VALUE +20. DATEUTIL 059900 15 C-DU-DAY-2-FORMAT-L PIC S9(06) VALUE +3. DATEUTIL 060000 15 C-DU-MONTH-2-FORMAT-L PIC S9(06) VALUE +5. DATEUTIL 060100 15 C-DU-YEAR-2-FORMAT-L PIC S9(06) VALUE +4. DATEUTIL 060200 15 C-DU-YEAR-2-SWITCH-L PIC S9(06) VALUE +2. DATEUTIL 060400 15 C-DU-DATE-2-FMTCDE-L PIC S9(06) VALUE +2. DATEUTIL 060410 15 C-DU-DATE-2-FORMAT-L PIC S9(06) VALUE +20. DATEUTIL 060500 DATEUTIL 060600 10 C-ISPF-VARIABLE-FORMATS. DATEUTIL 060700 15 C-DU-FUNCTION-F PIC X(8) VALUE 'CHAR '. DATEUTIL 060800 15 C-DU-NUMBER-F PIC X(8) VALUE 'CHAR '. DATEUTIL 060900 15 C-DU-DATE-1-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061000 15 C-DU-DAY-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061100 15 C-DU-MONTH-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061200 15 C-DU-YEAR-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061300 15 C-DU-YEAR-1-SWITCH-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061500 15 C-DU-DATE-1-FMTCDE-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061510 15 C-DU-DATE-1-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061600 15 C-DU-DATE-2-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061700 15 C-DU-DAY-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061800 15 C-DU-MONTH-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 061900 15 C-DU-YEAR-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 062000 15 C-DU-YEAR-2-SWITCH-F PIC X(8) VALUE 'CHAR '. DATEUTIL 062200 15 C-DU-DATE-2-FMTCDE-F PIC X(8) VALUE 'CHAR '. DATEUTIL 062210 15 C-DU-DATE-2-FORMAT-F PIC X(8) VALUE 'CHAR '. DATEUTIL 062300 DATEUTIL 062400/**************************************************************** DATEUTIL 062500* S W I T C H E S * DATEUTIL 062600***************************************************************** DATEUTIL 062700 01 SWITCHES. DATEUTIL 062800 05 S-ISPF-SWITCH PIC X(01) VALUE 'N'. DATEUTIL 062900 88 S-INVOKED-FROM-ISPF VALUE 'Y'. DATEUTIL 063000 05 S-LEAP-YEAR-SWITCH PIC X(01) VALUE 'N'. DATEUTIL 063100 88 S-NOT-A-LEAP-YEAR VALUE 'N'. DATEUTIL 063200 88 S-IS-A-LEAP-YEAR VALUE 'Y'. DATEUTIL 063300 DATEUTIL 063400/**************************************************************** DATEUTIL 063500* W O R K A R E A S * DATEUTIL 063600***************************************************************** DATEUTIL 063700 01 WORK-AREAS. DATEUTIL 063800 05 W-RETURN-CODE PIC S9(08) VALUE +0 COMP. DATEUTIL 063900 05 W-QUOTIENT PIC S9(08) VALUE +0 COMP. DATEUTIL 064000 05 W-REMAINDER PIC S9(08) VALUE +0 COMP. DATEUTIL 064100 88 W-A-LEAP-YEAR-REMAINDER VALUE +0. DATEUTIL 064200 05 W-NUMBER PIC S9(08) VALUE +0 COMP. DATEUTIL 064300 DATEUTIL 064400 05 W-MONTH-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 064500 05 W-YEAR-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 064600 05 W-DAY-BYTE PIC S9(08) VALUE +0 COMP. DATEUTIL 064700 DATEUTIL 064800 05 W-MONTH-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 064900 05 W-YEAR-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 065000 05 W-DAY-LENGTH PIC S9(08) VALUE +0 COMP. DATEUTIL 065100 DATEUTIL 065200 05 W-ISPF-SERVICE PIC X(08) VALUE SPACES. DATEUTIL 065300 05 W-HOLD-FUNCTION PIC X(10) VALUE SPACES. DATEUTIL 065400 05 W-SWITCH-YEAR PIC 9(02) VALUE 50. DATEUTIL 065410 05 W-FORMAT-CODE PIC 9(02) VALUE ZEROS. DATEUTIL 065500 88 W-YYYY-FORMAT VALUE 01 THRU 15, DATEUTIL 065600 31 THRU 35, DATEUTIL 065700 41 THRU 45, DATEUTIL 065800 51 THRU 52. DATEUTIL 065900 88 W-YY-FORMAT VALUE 16 THRU 30, DATEUTIL 066000 36 THRU 40, DATEUTIL 066100 46 THRU 50. DATEUTIL 066200 88 W-MM-FORMAT VALUE 01 THRU 10, DATEUTIL 066300 16 THRU 25. DATEUTIL 066400 88 W-MMM-FORMAT VALUE 31 THRU 50. DATEUTIL 066500 88 W-MONTH-FORMAT VALUE 51 THRU 52. DATEUTIL 066600 88 W-DD-FORMAT VALUE 01 THRU 10, DATEUTIL 066700 16 THRU 25, DATEUTIL 066800 31 THRU 50, 52. DATEUTIL 066900 88 W-ZD-FORMAT VALUE 51. DATEUTIL 067000 88 W-DDD-FORMAT VALUE 11 THRU 15, DATEUTIL 067100 26 THRU 30. DATEUTIL 067200 88 W-DAY-FORMAT VALUE 53. DATEUTIL 067300 05 W-HOLD-NUMBER PIC 9(06) VALUE ZEROS. DATEUTIL 067400 05 W-NUMBER-ARRAY REDEFINES W-HOLD-NUMBER PIC X(06). DATEUTIL 067500 05 FILLER REDEFINES W-HOLD-NUMBER DATEUTIL 067600 OCCURS 6 TIMES DATEUTIL 067700 INDEXED BY W-NUM-NDX1 W-NUM-NDX2. DATEUTIL 067800 10 W-NUMBER-ARRAY-BYTE PIC X(01). DATEUTIL 067900 05 W-HOLD-DATE PIC X(20) VALUE SPACES. DATEUTIL 068000 05 W-HOLD-DAY-FORMAT PIC X(03) VALUE SPACES. DATEUTIL 068100 05 W-HOLD-MONTH-FORMAT PIC X(05) VALUE SPACES. DATEUTIL 068200 05 W-HOLD-YEAR-FORMAT PIC X(04) VALUE SPACES. DATEUTIL 068300 05 W-HOLD-DATE-FORMAT PIC X(20) VALUE SPACES. DATEUTIL 068400 DATEUTIL 068500 05 W-SYSDATE. DATEUTIL 068600 10 W-SYSDATE-DECADE PIC 9(02) VALUE ZEROS. DATEUTIL 068700 10 W-SYSDATE-DDD PIC 9(03) VALUE ZEROS. DATEUTIL 068800 DATEUTIL 068900 05 W-HOLD-JULIAN PIC 9(07) VALUE ZEROS. DATEUTIL 069000 05 FILLER REDEFINES W-HOLD-JULIAN. DATEUTIL 069100 10 W-HOLD-JULIAN-YEAR PIC 9(04). DATEUTIL 069200 10 FILLER REDEFINES W-HOLD-JULIAN-YEAR. DATEUTIL 069300 15 W-HOLD-JULIAN-CENTURY PIC 9(02). DATEUTIL 069400 15 W-HOLD-JULIAN-DECADE PIC 9(02). DATEUTIL 069500 10 W-HOLD-JULIAN-DDD PIC 9(03). DATEUTIL 069600 05 FILLER REDEFINES W-HOLD-JULIAN DATEUTIL 069700 OCCURS 7 TIMES DATEUTIL 069800 INDEXED BY W-HOLD-JULIAN-NDX. DATEUTIL 069900 10 W-HOLD-JULIAN-BYTE PIC X(01). DATEUTIL 070000 DATEUTIL 070100 05 W-WORK-JULIAN PIC 9(07) VALUE ZEROS. DATEUTIL 070200 05 FILLER REDEFINES W-WORK-JULIAN. DATEUTIL 070300 10 W-JULIAN-YEAR PIC 9(04). DATEUTIL 070400 10 FILLER REDEFINES W-JULIAN-YEAR. DATEUTIL 070500 15 W-JULIAN-CENTURY PIC 9(02). DATEUTIL 070600 15 W-JULIAN-DECADE PIC 9(02). DATEUTIL 070700 10 W-JULIAN-DDD PIC 9(03). DATEUTIL 070800 05 FILLER REDEFINES W-WORK-JULIAN DATEUTIL 070900 OCCURS 7 TIMES DATEUTIL 071000 INDEXED BY W-JULIAN-NDX. DATEUTIL 071100 10 W-JULIAN-BYTE PIC X(01). DATEUTIL 071200 DATEUTIL 071300 05 W-WORK-MONTH PIC X(09) VALUE SPACES. DATEUTIL 071400 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 071500 10 W-WORK-MMM PIC X(03). DATEUTIL 071600 10 FILLER PIC X(06). DATEUTIL 071700 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 071800 10 W-WORK-MM PIC 9(02). DATEUTIL 071900 10 FILLER PIC X(07). DATEUTIL 072000 05 FILLER REDEFINES W-WORK-MONTH. DATEUTIL 072100 10 W-WORK-ZM PIC Z9. DATEUTIL 072200 10 FILLER PIC X(07). DATEUTIL 072300 05 FILLER REDEFINES W-WORK-MONTH DATEUTIL 072400 OCCURS 9 TIMES DATEUTIL 072500 INDEXED BY W-MONTH-NDX. DATEUTIL 072600 10 W-MONTH-ARRAY-BYTE PIC X(01). DATEUTIL 072700 DATEUTIL 072800 05 W-WORK-DAY PIC X(09) VALUE SPACES. DATEUTIL 072900 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 073000 10 W-WORK-DAY-AB2 PIC X(02). DATEUTIL 073100 10 FILLER PIC X(07). DATEUTIL 073200 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 073300 10 W-WORK-DAY-AB3 PIC X(03). DATEUTIL 073400 10 FILLER PIC X(06). DATEUTIL 073500 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 073600 10 W-WORK-DDD PIC 9(03). DATEUTIL 073700 10 FILLER PIC X(06). DATEUTIL 073800 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 073900 10 W-WORK-ZZD PIC ZZ9. DATEUTIL 074000 10 FILLER PIC X(06). DATEUTIL 074100 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 074200 10 W-WORK-DD PIC 9(02). DATEUTIL 074300 10 FILLER PIC X(07). DATEUTIL 074400 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 074500 10 W-WORK-ZD PIC Z9. DATEUTIL 074600 10 FILLER PIC X(07). DATEUTIL 074700 05 FILLER REDEFINES W-WORK-DAY. DATEUTIL 074800 10 W-WORK-D PIC 9(01). DATEUTIL 074900 10 FILLER PIC X(08). DATEUTIL 075000 05 FILLER REDEFINES W-WORK-DAY DATEUTIL 075100 OCCURS 9 TIMES DATEUTIL 075200 INDEXED BY W-DAY-NDX1 DATEUTIL 075300 W-DAY-NDX2. DATEUTIL 075400 10 W-DAY-ARRAY-BYTE PIC X(01). DATEUTIL 075500 DATEUTIL 075600 05 W-WORK-YEAR. DATEUTIL 075700 10 W-WORK-CENTURY PIC 9(02) VALUE ZEROS. DATEUTIL 075800 10 W-WORK-DECADE PIC 9(02) VALUE ZEROS. DATEUTIL 075900 05 W-WORK-YEAR-NUM REDEFINES W-WORK-YEAR PIC 9(04). DATEUTIL 076000 05 FILLER REDEFINES W-WORK-YEAR DATEUTIL 076100 OCCURS 4 TIMES DATEUTIL 076200 INDEXED BY W-YEAR-NDX1 DATEUTIL 076300 W-YEAR-NDX2. DATEUTIL 076400 10 W-YEAR-ARRAY-BYTE PIC X(01). DATEUTIL 076500 DATEUTIL 076600 05 W-WORK-ARRAY PIC X(20) VALUE SPACES. DATEUTIL 076700 05 W-ARRAY REDEFINES W-WORK-ARRAY DATEUTIL 076800 OCCURS 20 TIMES DATEUTIL 076900 INDEXED BY W-ARRAY-NDX1 DATEUTIL 077000 W-ARRAY-NDX2. DATEUTIL 077100 10 W-ARRAY-BYTE PIC X(01). DATEUTIL 077200 DATEUTIL 077300/**************************************************************** DATEUTIL 077400* T A B L E S * DATEUTIL 077500***************************************************************** DATEUTIL 077600 01 TABLES. DATEUTIL 077700 05 T-YEARDAY-TABLE-AREA. DATEUTIL 077800 10 FILLER PIC X(05) VALUE '16006'. DATEUTIL 077900 10 FILLER PIC X(05) VALUE '16011'. DATEUTIL 078000 10 FILLER PIC X(05) VALUE '16022'. DATEUTIL 078100 10 FILLER PIC X(05) VALUE '16033'. DATEUTIL 078200 10 FILLER PIC X(05) VALUE '16044'. DATEUTIL 078300 10 FILLER PIC X(05) VALUE '16056'. DATEUTIL 078400 10 FILLER PIC X(05) VALUE '16067'. DATEUTIL 078500 10 FILLER PIC X(05) VALUE '16071'. DATEUTIL 078600 10 FILLER PIC X(05) VALUE '16082'. DATEUTIL 078700 10 FILLER PIC X(05) VALUE '16094'. DATEUTIL 078800 10 FILLER PIC X(05) VALUE '16105'. DATEUTIL 078900 10 FILLER PIC X(05) VALUE '16116'. DATEUTIL 079000 10 FILLER PIC X(05) VALUE '16127'. DATEUTIL 079100 10 FILLER PIC X(05) VALUE '16132'. DATEUTIL 079200 10 FILLER PIC X(05) VALUE '16143'. DATEUTIL 079300 10 FILLER PIC X(05) VALUE '16154'. DATEUTIL 079400 10 FILLER PIC X(05) VALUE '16165'. DATEUTIL 079500 10 FILLER PIC X(05) VALUE '16177'. DATEUTIL 079600 10 FILLER PIC X(05) VALUE '16181'. DATEUTIL 079700 10 FILLER PIC X(05) VALUE '16192'. DATEUTIL 079800 10 FILLER PIC X(05) VALUE '16203'. DATEUTIL 079900 10 FILLER PIC X(05) VALUE '16215'. DATEUTIL 080000 10 FILLER PIC X(05) VALUE '16226'. DATEUTIL 080100 10 FILLER PIC X(05) VALUE '16237'. DATEUTIL 080200 10 FILLER PIC X(05) VALUE '16241'. DATEUTIL 080300 10 FILLER PIC X(05) VALUE '16253'. DATEUTIL 080400 10 FILLER PIC X(05) VALUE '16264'. DATEUTIL 080500 10 FILLER PIC X(05) VALUE '16275'. DATEUTIL 080600 10 FILLER PIC X(05) VALUE '16286'. DATEUTIL 080700 10 FILLER PIC X(05) VALUE '16291'. DATEUTIL 080800 10 FILLER PIC X(05) VALUE '16302'. DATEUTIL 080900 10 FILLER PIC X(05) VALUE '16313'. DATEUTIL 081000 10 FILLER PIC X(05) VALUE '16324'. DATEUTIL 081100 10 FILLER PIC X(05) VALUE '16336'. DATEUTIL 081200 10 FILLER PIC X(05) VALUE '16347'. DATEUTIL 081300 10 FILLER PIC X(05) VALUE '16351'. DATEUTIL 081400 10 FILLER PIC X(05) VALUE '16362'. DATEUTIL 081500 10 FILLER PIC X(05) VALUE '16374'. DATEUTIL 081600 10 FILLER PIC X(05) VALUE '16385'. DATEUTIL 081700 10 FILLER PIC X(05) VALUE '16396'. DATEUTIL 081800 10 FILLER PIC X(05) VALUE '16407'. DATEUTIL 081900 10 FILLER PIC X(05) VALUE '16412'. DATEUTIL 082000 10 FILLER PIC X(05) VALUE '16423'. DATEUTIL 082100 10 FILLER PIC X(05) VALUE '16434'. DATEUTIL 082200 10 FILLER PIC X(05) VALUE '16445'. DATEUTIL 082300 10 FILLER PIC X(05) VALUE '16457'. DATEUTIL 082400 10 FILLER PIC X(05) VALUE '16461'. DATEUTIL 082500 10 FILLER PIC X(05) VALUE '16472'. DATEUTIL 082600 10 FILLER PIC X(05) VALUE '16483'. DATEUTIL 082700 10 FILLER PIC X(05) VALUE '16495'. DATEUTIL 082800 10 FILLER PIC X(05) VALUE '16506'. DATEUTIL 082900 10 FILLER PIC X(05) VALUE '16517'. DATEUTIL 083000 10 FILLER PIC X(05) VALUE '16521'. DATEUTIL 083100 10 FILLER PIC X(05) VALUE '16533'. DATEUTIL 083200 10 FILLER PIC X(05) VALUE '16544'. DATEUTIL 083300 10 FILLER PIC X(05) VALUE '16555'. DATEUTIL 083400 10 FILLER PIC X(05) VALUE '16566'. DATEUTIL 083500 10 FILLER PIC X(05) VALUE '16571'. DATEUTIL 083600 10 FILLER PIC X(05) VALUE '16582'. DATEUTIL 083700 10 FILLER PIC X(05) VALUE '16593'. DATEUTIL 083800 10 FILLER PIC X(05) VALUE '16604'. DATEUTIL 083900 10 FILLER PIC X(05) VALUE '16616'. DATEUTIL 084000 10 FILLER PIC X(05) VALUE '16627'. DATEUTIL 084100 10 FILLER PIC X(05) VALUE '16631'. DATEUTIL 084200 10 FILLER PIC X(05) VALUE '16642'. DATEUTIL 084300 10 FILLER PIC X(05) VALUE '16654'. DATEUTIL 084400 10 FILLER PIC X(05) VALUE '16665'. DATEUTIL 084500 10 FILLER PIC X(05) VALUE '16676'. DATEUTIL 084600 10 FILLER PIC X(05) VALUE '16687'. DATEUTIL 084700 10 FILLER PIC X(05) VALUE '16692'. DATEUTIL 084800 10 FILLER PIC X(05) VALUE '16703'. DATEUTIL 084900 10 FILLER PIC X(05) VALUE '16714'. DATEUTIL 085000 10 FILLER PIC X(05) VALUE '16725'. DATEUTIL 085100 10 FILLER PIC X(05) VALUE '16737'. DATEUTIL 085200 10 FILLER PIC X(05) VALUE '16741'. DATEUTIL 085300 10 FILLER PIC X(05) VALUE '16752'. DATEUTIL 085400 10 FILLER PIC X(05) VALUE '16763'. DATEUTIL 085500 10 FILLER PIC X(05) VALUE '16775'. DATEUTIL 085600 10 FILLER PIC X(05) VALUE '16786'. DATEUTIL 085700 10 FILLER PIC X(05) VALUE '16797'. DATEUTIL 085800 10 FILLER PIC X(05) VALUE '16801'. DATEUTIL 085900 10 FILLER PIC X(05) VALUE '16813'. DATEUTIL 086000 10 FILLER PIC X(05) VALUE '16824'. DATEUTIL 086100 10 FILLER PIC X(05) VALUE '16835'. DATEUTIL 086200 10 FILLER PIC X(05) VALUE '16846'. DATEUTIL 086300 10 FILLER PIC X(05) VALUE '16851'. DATEUTIL 086400 10 FILLER PIC X(05) VALUE '16862'. DATEUTIL 086500 10 FILLER PIC X(05) VALUE '16873'. DATEUTIL 086600 10 FILLER PIC X(05) VALUE '16884'. DATEUTIL 086700 10 FILLER PIC X(05) VALUE '16896'. DATEUTIL 086800 10 FILLER PIC X(05) VALUE '16907'. DATEUTIL 086900 10 FILLER PIC X(05) VALUE '16911'. DATEUTIL 087000 10 FILLER PIC X(05) VALUE '16922'. DATEUTIL 087100 10 FILLER PIC X(05) VALUE '16934'. DATEUTIL 087200 10 FILLER PIC X(05) VALUE '16945'. DATEUTIL 087300 10 FILLER PIC X(05) VALUE '16956'. DATEUTIL 087400 10 FILLER PIC X(05) VALUE '16967'. DATEUTIL 087500 10 FILLER PIC X(05) VALUE '16972'. DATEUTIL 087600 10 FILLER PIC X(05) VALUE '16983'. DATEUTIL 087700 10 FILLER PIC X(05) VALUE '16994'. DATEUTIL 087800 10 FILLER PIC X(05) VALUE '17005'. DATEUTIL 087900 10 FILLER PIC X(05) VALUE '17016'. DATEUTIL 088000 10 FILLER PIC X(05) VALUE '17027'. DATEUTIL 088100 10 FILLER PIC X(05) VALUE '17031'. DATEUTIL 088200 10 FILLER PIC X(05) VALUE '17042'. DATEUTIL 088300 10 FILLER PIC X(05) VALUE '17054'. DATEUTIL 088400 10 FILLER PIC X(05) VALUE '17065'. DATEUTIL 088500 10 FILLER PIC X(05) VALUE '17076'. DATEUTIL 088600 10 FILLER PIC X(05) VALUE '17087'. DATEUTIL 088700 10 FILLER PIC X(05) VALUE '17092'. DATEUTIL 088800 10 FILLER PIC X(05) VALUE '17103'. DATEUTIL 088900 10 FILLER PIC X(05) VALUE '17114'. DATEUTIL 089000 10 FILLER PIC X(05) VALUE '17125'. DATEUTIL 089100 10 FILLER PIC X(05) VALUE '17137'. DATEUTIL 089200 10 FILLER PIC X(05) VALUE '17141'. DATEUTIL 089300 10 FILLER PIC X(05) VALUE '17152'. DATEUTIL 089400 10 FILLER PIC X(05) VALUE '17163'. DATEUTIL 089500 10 FILLER PIC X(05) VALUE '17175'. DATEUTIL 089600 10 FILLER PIC X(05) VALUE '17186'. DATEUTIL 089700 10 FILLER PIC X(05) VALUE '17197'. DATEUTIL 089800 10 FILLER PIC X(05) VALUE '17201'. DATEUTIL 089900 10 FILLER PIC X(05) VALUE '17213'. DATEUTIL 090000 10 FILLER PIC X(05) VALUE '17224'. DATEUTIL 090100 10 FILLER PIC X(05) VALUE '17235'. DATEUTIL 090200 10 FILLER PIC X(05) VALUE '17246'. DATEUTIL 090300 10 FILLER PIC X(05) VALUE '17251'. DATEUTIL 090400 10 FILLER PIC X(05) VALUE '17262'. DATEUTIL 090500 10 FILLER PIC X(05) VALUE '17273'. DATEUTIL 090600 10 FILLER PIC X(05) VALUE '17284'. DATEUTIL 090700 10 FILLER PIC X(05) VALUE '17296'. DATEUTIL 090800 10 FILLER PIC X(05) VALUE '17307'. DATEUTIL 090900 10 FILLER PIC X(05) VALUE '17311'. DATEUTIL 091000 10 FILLER PIC X(05) VALUE '17322'. DATEUTIL 091100 10 FILLER PIC X(05) VALUE '17334'. DATEUTIL 091200 10 FILLER PIC X(05) VALUE '17345'. DATEUTIL 091300 10 FILLER PIC X(05) VALUE '17356'. DATEUTIL 091400 10 FILLER PIC X(05) VALUE '17367'. DATEUTIL 091500 10 FILLER PIC X(05) VALUE '17372'. DATEUTIL 091600 10 FILLER PIC X(05) VALUE '17383'. DATEUTIL 091700 10 FILLER PIC X(05) VALUE '17394'. DATEUTIL 091800 10 FILLER PIC X(05) VALUE '17405'. DATEUTIL 091900 10 FILLER PIC X(05) VALUE '17417'. DATEUTIL 092000 10 FILLER PIC X(05) VALUE '17421'. DATEUTIL 092100 10 FILLER PIC X(05) VALUE '17432'. DATEUTIL 092200 10 FILLER PIC X(05) VALUE '17443'. DATEUTIL 092300 10 FILLER PIC X(05) VALUE '17455'. DATEUTIL 092400 10 FILLER PIC X(05) VALUE '17466'. DATEUTIL 092500 10 FILLER PIC X(05) VALUE '17477'. DATEUTIL 092600 10 FILLER PIC X(05) VALUE '17481'. DATEUTIL 092700 10 FILLER PIC X(05) VALUE '17493'. DATEUTIL 092800 10 FILLER PIC X(05) VALUE '17504'. DATEUTIL 092900 10 FILLER PIC X(05) VALUE '17515'. DATEUTIL 093000 10 FILLER PIC X(05) VALUE '17526'. DATEUTIL 093100 10 FILLER PIC X(05) VALUE '17531'. DATEUTIL 093200 10 FILLER PIC X(05) VALUE '17542'. DATEUTIL 093300 10 FILLER PIC X(05) VALUE '17553'. DATEUTIL 093400 10 FILLER PIC X(05) VALUE '17564'. DATEUTIL 093500 10 FILLER PIC X(05) VALUE '17576'. DATEUTIL 093600 10 FILLER PIC X(05) VALUE '17587'. DATEUTIL 093700 10 FILLER PIC X(05) VALUE '17591'. DATEUTIL 093800 10 FILLER PIC X(05) VALUE '17602'. DATEUTIL 093900 10 FILLER PIC X(05) VALUE '17614'. DATEUTIL 094000 10 FILLER PIC X(05) VALUE '17625'. DATEUTIL 094100 10 FILLER PIC X(05) VALUE '17636'. DATEUTIL 094200 10 FILLER PIC X(05) VALUE '17647'. DATEUTIL 094300 10 FILLER PIC X(05) VALUE '17652'. DATEUTIL 094400 10 FILLER PIC X(05) VALUE '17663'. DATEUTIL 094500 10 FILLER PIC X(05) VALUE '17674'. DATEUTIL 094600 10 FILLER PIC X(05) VALUE '17685'. DATEUTIL 094700 10 FILLER PIC X(05) VALUE '17697'. DATEUTIL 094800 10 FILLER PIC X(05) VALUE '17701'. DATEUTIL 094900 10 FILLER PIC X(05) VALUE '17712'. DATEUTIL 095000 10 FILLER PIC X(05) VALUE '17723'. DATEUTIL 095100 10 FILLER PIC X(05) VALUE '17735'. DATEUTIL 095200 10 FILLER PIC X(05) VALUE '17746'. DATEUTIL 095300 10 FILLER PIC X(05) VALUE '17757'. DATEUTIL 095400 10 FILLER PIC X(05) VALUE '17761'. DATEUTIL 095500 10 FILLER PIC X(05) VALUE '17773'. DATEUTIL 095600 10 FILLER PIC X(05) VALUE '17784'. DATEUTIL 095700 10 FILLER PIC X(05) VALUE '17795'. DATEUTIL 095800 10 FILLER PIC X(05) VALUE '17806'. DATEUTIL 095900 10 FILLER PIC X(05) VALUE '17811'. DATEUTIL 096000 10 FILLER PIC X(05) VALUE '17822'. DATEUTIL 096100 10 FILLER PIC X(05) VALUE '17833'. DATEUTIL 096200 10 FILLER PIC X(05) VALUE '17844'. DATEUTIL 096300 10 FILLER PIC X(05) VALUE '17856'. DATEUTIL 096400 10 FILLER PIC X(05) VALUE '17867'. DATEUTIL 096500 10 FILLER PIC X(05) VALUE '17871'. DATEUTIL 096600 10 FILLER PIC X(05) VALUE '17882'. DATEUTIL 096700 10 FILLER PIC X(05) VALUE '17894'. DATEUTIL 096800 10 FILLER PIC X(05) VALUE '17905'. DATEUTIL 096900 10 FILLER PIC X(05) VALUE '17916'. DATEUTIL 097000 10 FILLER PIC X(05) VALUE '17927'. DATEUTIL 097100 10 FILLER PIC X(05) VALUE '17932'. DATEUTIL 097200 10 FILLER PIC X(05) VALUE '17943'. DATEUTIL 097300 10 FILLER PIC X(05) VALUE '17954'. DATEUTIL 097400 10 FILLER PIC X(05) VALUE '17965'. DATEUTIL 097500 10 FILLER PIC X(05) VALUE '17977'. DATEUTIL 097600 10 FILLER PIC X(05) VALUE '17981'. DATEUTIL 097700 10 FILLER PIC X(05) VALUE '17992'. DATEUTIL 097800 10 FILLER PIC X(05) VALUE '18003'. DATEUTIL 097900 10 FILLER PIC X(05) VALUE '18014'. DATEUTIL 098000 10 FILLER PIC X(05) VALUE '18025'. DATEUTIL 098100 10 FILLER PIC X(05) VALUE '18036'. DATEUTIL 098200 10 FILLER PIC X(05) VALUE '18047'. DATEUTIL 098300 10 FILLER PIC X(05) VALUE '18052'. DATEUTIL 098400 10 FILLER PIC X(05) VALUE '18063'. DATEUTIL 098500 10 FILLER PIC X(05) VALUE '18074'. DATEUTIL 098600 10 FILLER PIC X(05) VALUE '18085'. DATEUTIL 098700 10 FILLER PIC X(05) VALUE '18097'. DATEUTIL 098800 10 FILLER PIC X(05) VALUE '18101'. DATEUTIL 098900 10 FILLER PIC X(05) VALUE '18112'. DATEUTIL 099000 10 FILLER PIC X(05) VALUE '18123'. DATEUTIL 099100 10 FILLER PIC X(05) VALUE '18135'. DATEUTIL 099200 10 FILLER PIC X(05) VALUE '18146'. DATEUTIL 099300 10 FILLER PIC X(05) VALUE '18157'. DATEUTIL 099400 10 FILLER PIC X(05) VALUE '18161'. DATEUTIL 099500 10 FILLER PIC X(05) VALUE '18173'. DATEUTIL 099600 10 FILLER PIC X(05) VALUE '18184'. DATEUTIL 099700 10 FILLER PIC X(05) VALUE '18195'. DATEUTIL 099800 10 FILLER PIC X(05) VALUE '18206'. DATEUTIL 099900 10 FILLER PIC X(05) VALUE '18211'. DATEUTIL 100000 10 FILLER PIC X(05) VALUE '18222'. DATEUTIL 100100 10 FILLER PIC X(05) VALUE '18233'. DATEUTIL 100200 10 FILLER PIC X(05) VALUE '18244'. DATEUTIL 100300 10 FILLER PIC X(05) VALUE '18256'. DATEUTIL 100400 10 FILLER PIC X(05) VALUE '18267'. DATEUTIL 100500 10 FILLER PIC X(05) VALUE '18271'. DATEUTIL 100600 10 FILLER PIC X(05) VALUE '18282'. DATEUTIL 100700 10 FILLER PIC X(05) VALUE '18294'. DATEUTIL 100800 10 FILLER PIC X(05) VALUE '18305'. DATEUTIL 100900 10 FILLER PIC X(05) VALUE '18316'. DATEUTIL 101000 10 FILLER PIC X(05) VALUE '18327'. DATEUTIL 101100 10 FILLER PIC X(05) VALUE '18332'. DATEUTIL 101200 10 FILLER PIC X(05) VALUE '18343'. DATEUTIL 101300 10 FILLER PIC X(05) VALUE '18354'. DATEUTIL 101400 10 FILLER PIC X(05) VALUE '18365'. DATEUTIL 101500 10 FILLER PIC X(05) VALUE '18377'. DATEUTIL 101600 10 FILLER PIC X(05) VALUE '18381'. DATEUTIL 101700 10 FILLER PIC X(05) VALUE '18392'. DATEUTIL 101800 10 FILLER PIC X(05) VALUE '18403'. DATEUTIL 101900 10 FILLER PIC X(05) VALUE '18415'. DATEUTIL 102000 10 FILLER PIC X(05) VALUE '18426'. DATEUTIL 102100 10 FILLER PIC X(05) VALUE '18437'. DATEUTIL 102200 10 FILLER PIC X(05) VALUE '18441'. DATEUTIL 102300 10 FILLER PIC X(05) VALUE '18453'. DATEUTIL 102400 10 FILLER PIC X(05) VALUE '18464'. DATEUTIL 102500 10 FILLER PIC X(05) VALUE '18475'. DATEUTIL 102600 10 FILLER PIC X(05) VALUE '18486'. DATEUTIL 102700 10 FILLER PIC X(05) VALUE '18491'. DATEUTIL 102800 10 FILLER PIC X(05) VALUE '18502'. DATEUTIL 102900 10 FILLER PIC X(05) VALUE '18513'. DATEUTIL 103000 10 FILLER PIC X(05) VALUE '18524'. DATEUTIL 103100 10 FILLER PIC X(05) VALUE '18536'. DATEUTIL 103200 10 FILLER PIC X(05) VALUE '18547'. DATEUTIL 103300 10 FILLER PIC X(05) VALUE '18551'. DATEUTIL 103400 10 FILLER PIC X(05) VALUE '18562'. DATEUTIL 103500 10 FILLER PIC X(05) VALUE '18574'. DATEUTIL 103600 10 FILLER PIC X(05) VALUE '18585'. DATEUTIL 103700 10 FILLER PIC X(05) VALUE '18596'. DATEUTIL 103800 10 FILLER PIC X(05) VALUE '18607'. DATEUTIL 103900 10 FILLER PIC X(05) VALUE '18612'. DATEUTIL 104000 10 FILLER PIC X(05) VALUE '18623'. DATEUTIL 104100 10 FILLER PIC X(05) VALUE '18634'. DATEUTIL 104200 10 FILLER PIC X(05) VALUE '18645'. DATEUTIL 104300 10 FILLER PIC X(05) VALUE '18657'. DATEUTIL 104400 10 FILLER PIC X(05) VALUE '18661'. DATEUTIL 104500 10 FILLER PIC X(05) VALUE '18672'. DATEUTIL 104600 10 FILLER PIC X(05) VALUE '18683'. DATEUTIL 104700 10 FILLER PIC X(05) VALUE '18695'. DATEUTIL 104800 10 FILLER PIC X(05) VALUE '18706'. DATEUTIL 104900 10 FILLER PIC X(05) VALUE '18717'. DATEUTIL 105000 10 FILLER PIC X(05) VALUE '18721'. DATEUTIL 105100 10 FILLER PIC X(05) VALUE '18733'. DATEUTIL 105200 10 FILLER PIC X(05) VALUE '18744'. DATEUTIL 105300 10 FILLER PIC X(05) VALUE '18755'. DATEUTIL 105400 10 FILLER PIC X(05) VALUE '18766'. DATEUTIL 105500 10 FILLER PIC X(05) VALUE '18771'. DATEUTIL 105600 10 FILLER PIC X(05) VALUE '18782'. DATEUTIL 105700 10 FILLER PIC X(05) VALUE '18793'. DATEUTIL 105800 10 FILLER PIC X(05) VALUE '18804'. DATEUTIL 105900 10 FILLER PIC X(05) VALUE '18816'. DATEUTIL 106000 10 FILLER PIC X(05) VALUE '18827'. DATEUTIL 106100 10 FILLER PIC X(05) VALUE '18831'. DATEUTIL 106200 10 FILLER PIC X(05) VALUE '18842'. DATEUTIL 106300 10 FILLER PIC X(05) VALUE '18854'. DATEUTIL 106400 10 FILLER PIC X(05) VALUE '18865'. DATEUTIL 106500 10 FILLER PIC X(05) VALUE '18876'. DATEUTIL 106600 10 FILLER PIC X(05) VALUE '18887'. DATEUTIL 106700 10 FILLER PIC X(05) VALUE '18892'. DATEUTIL 106800 10 FILLER PIC X(05) VALUE '18903'. DATEUTIL 106900 10 FILLER PIC X(05) VALUE '18914'. DATEUTIL 107000 10 FILLER PIC X(05) VALUE '18925'. DATEUTIL 107100 10 FILLER PIC X(05) VALUE '18937'. DATEUTIL 107200 10 FILLER PIC X(05) VALUE '18941'. DATEUTIL 107300 10 FILLER PIC X(05) VALUE '18952'. DATEUTIL 107400 10 FILLER PIC X(05) VALUE '18963'. DATEUTIL 107500 10 FILLER PIC X(05) VALUE '18975'. DATEUTIL 107600 10 FILLER PIC X(05) VALUE '18986'. DATEUTIL 107700 10 FILLER PIC X(05) VALUE '18997'. DATEUTIL 107800 10 FILLER PIC X(05) VALUE '19001'. DATEUTIL 107900 10 FILLER PIC X(05) VALUE '19012'. DATEUTIL 108000 10 FILLER PIC X(05) VALUE '19023'. DATEUTIL 108100 10 FILLER PIC X(05) VALUE '19034'. DATEUTIL 108200 10 FILLER PIC X(05) VALUE '19045'. DATEUTIL 108300 10 FILLER PIC X(05) VALUE '19057'. DATEUTIL 108400 10 FILLER PIC X(05) VALUE '19061'. DATEUTIL 108500 10 FILLER PIC X(05) VALUE '19072'. DATEUTIL 108600 10 FILLER PIC X(05) VALUE '19083'. DATEUTIL 108700 10 FILLER PIC X(05) VALUE '19095'. DATEUTIL 108800 10 FILLER PIC X(05) VALUE '19106'. DATEUTIL 108900 10 FILLER PIC X(05) VALUE '19117'. DATEUTIL 109000 10 FILLER PIC X(05) VALUE '19121'. DATEUTIL 109100 10 FILLER PIC X(05) VALUE '19133'. DATEUTIL 109200 10 FILLER PIC X(05) VALUE '19144'. DATEUTIL 109300 10 FILLER PIC X(05) VALUE '19155'. DATEUTIL 109400 10 FILLER PIC X(05) VALUE '19166'. DATEUTIL 109500 10 FILLER PIC X(05) VALUE '19171'. DATEUTIL 109600 10 FILLER PIC X(05) VALUE '19182'. DATEUTIL 109700 10 FILLER PIC X(05) VALUE '19193'. DATEUTIL 109800 10 FILLER PIC X(05) VALUE '19204'. DATEUTIL 109900 10 FILLER PIC X(05) VALUE '19216'. DATEUTIL 110000 10 FILLER PIC X(05) VALUE '19227'. DATEUTIL 110100 10 FILLER PIC X(05) VALUE '19231'. DATEUTIL 110200 10 FILLER PIC X(05) VALUE '19242'. DATEUTIL 110300 10 FILLER PIC X(05) VALUE '19254'. DATEUTIL 110400 10 FILLER PIC X(05) VALUE '19265'. DATEUTIL 110500 10 FILLER PIC X(05) VALUE '19276'. DATEUTIL 110600 10 FILLER PIC X(05) VALUE '19287'. DATEUTIL 110700 10 FILLER PIC X(05) VALUE '19292'. DATEUTIL 110800 10 FILLER PIC X(05) VALUE '19303'. DATEUTIL 110900 10 FILLER PIC X(05) VALUE '19314'. DATEUTIL 111000 10 FILLER PIC X(05) VALUE '19325'. DATEUTIL 111100 10 FILLER PIC X(05) VALUE '19337'. DATEUTIL 111200 10 FILLER PIC X(05) VALUE '19341'. DATEUTIL 111300 10 FILLER PIC X(05) VALUE '19352'. DATEUTIL 111400 10 FILLER PIC X(05) VALUE '19363'. DATEUTIL 111500 10 FILLER PIC X(05) VALUE '19375'. DATEUTIL 111600 10 FILLER PIC X(05) VALUE '19386'. DATEUTIL 111700 10 FILLER PIC X(05) VALUE '19397'. DATEUTIL 111800 10 FILLER PIC X(05) VALUE '19401'. DATEUTIL 111900 10 FILLER PIC X(05) VALUE '19413'. DATEUTIL 112000 10 FILLER PIC X(05) VALUE '19424'. DATEUTIL 112100 10 FILLER PIC X(05) VALUE '19435'. DATEUTIL 112200 10 FILLER PIC X(05) VALUE '19446'. DATEUTIL 112300 10 FILLER PIC X(05) VALUE '19451'. DATEUTIL 112400 10 FILLER PIC X(05) VALUE '19462'. DATEUTIL 112500 10 FILLER PIC X(05) VALUE '19473'. DATEUTIL 112600 10 FILLER PIC X(05) VALUE '19484'. DATEUTIL 112700 10 FILLER PIC X(05) VALUE '19496'. DATEUTIL 112800 10 FILLER PIC X(05) VALUE '19507'. DATEUTIL 112900 10 FILLER PIC X(05) VALUE '19511'. DATEUTIL 113000 10 FILLER PIC X(05) VALUE '19522'. DATEUTIL 113100 10 FILLER PIC X(05) VALUE '19534'. DATEUTIL 113200 10 FILLER PIC X(05) VALUE '19545'. DATEUTIL 113300 10 FILLER PIC X(05) VALUE '19556'. DATEUTIL 113400 10 FILLER PIC X(05) VALUE '19567'. DATEUTIL 113500 10 FILLER PIC X(05) VALUE '19572'. DATEUTIL 113600 10 FILLER PIC X(05) VALUE '19583'. DATEUTIL 113700 10 FILLER PIC X(05) VALUE '19594'. DATEUTIL 113800 10 FILLER PIC X(05) VALUE '19605'. DATEUTIL 113900 10 FILLER PIC X(05) VALUE '19617'. DATEUTIL 114000 10 FILLER PIC X(05) VALUE '19621'. DATEUTIL 114100 10 FILLER PIC X(05) VALUE '19632'. DATEUTIL 114200 10 FILLER PIC X(05) VALUE '19643'. DATEUTIL 114300 10 FILLER PIC X(05) VALUE '19655'. DATEUTIL 114400 10 FILLER PIC X(05) VALUE '19666'. DATEUTIL 114500 10 FILLER PIC X(05) VALUE '19677'. DATEUTIL 114600 10 FILLER PIC X(05) VALUE '19681'. DATEUTIL 114700 10 FILLER PIC X(05) VALUE '19693'. DATEUTIL 114800 10 FILLER PIC X(05) VALUE '19704'. DATEUTIL 114900 10 FILLER PIC X(05) VALUE '19715'. DATEUTIL 115000 10 FILLER PIC X(05) VALUE '19726'. DATEUTIL 115100 10 FILLER PIC X(05) VALUE '19731'. DATEUTIL 115200 10 FILLER PIC X(05) VALUE '19742'. DATEUTIL 115300 10 FILLER PIC X(05) VALUE '19753'. DATEUTIL 115400 10 FILLER PIC X(05) VALUE '19764'. DATEUTIL 115500 10 FILLER PIC X(05) VALUE '19776'. DATEUTIL 115600 10 FILLER PIC X(05) VALUE '19787'. DATEUTIL 115700 10 FILLER PIC X(05) VALUE '19791'. DATEUTIL 115800 10 FILLER PIC X(05) VALUE '19802'. DATEUTIL 115900 10 FILLER PIC X(05) VALUE '19814'. DATEUTIL 116000 10 FILLER PIC X(05) VALUE '19825'. DATEUTIL 116100 10 FILLER PIC X(05) VALUE '19836'. DATEUTIL 116200 10 FILLER PIC X(05) VALUE '19847'. DATEUTIL 116300 10 FILLER PIC X(05) VALUE '19852'. DATEUTIL 116400 10 FILLER PIC X(05) VALUE '19863'. DATEUTIL 116500 10 FILLER PIC X(05) VALUE '19874'. DATEUTIL 116600 10 FILLER PIC X(05) VALUE '19885'. DATEUTIL 116700 10 FILLER PIC X(05) VALUE '19897'. DATEUTIL 116800 10 FILLER PIC X(05) VALUE '19901'. DATEUTIL 116900 10 FILLER PIC X(05) VALUE '19912'. DATEUTIL 117000 10 FILLER PIC X(05) VALUE '19923'. DATEUTIL 117100 10 FILLER PIC X(05) VALUE '19935'. DATEUTIL 117200 10 FILLER PIC X(05) VALUE '19946'. DATEUTIL 117300 10 FILLER PIC X(05) VALUE '19957'. DATEUTIL 117400 10 FILLER PIC X(05) VALUE '19961'. DATEUTIL 117500 10 FILLER PIC X(05) VALUE '19973'. DATEUTIL 117600 10 FILLER PIC X(05) VALUE '19984'. DATEUTIL 117700 10 FILLER PIC X(05) VALUE '19995'. DATEUTIL 117800 10 FILLER PIC X(05) VALUE '20006'. DATEUTIL 117900 10 FILLER PIC X(05) VALUE '20011'. DATEUTIL 118000 10 FILLER PIC X(05) VALUE '20022'. DATEUTIL 118100 10 FILLER PIC X(05) VALUE '20033'. DATEUTIL 118200 10 FILLER PIC X(05) VALUE '20044'. DATEUTIL 118300 10 FILLER PIC X(05) VALUE '20056'. DATEUTIL 118400 10 FILLER PIC X(05) VALUE '20067'. DATEUTIL 118500 10 FILLER PIC X(05) VALUE '20071'. DATEUTIL 118600 10 FILLER PIC X(05) VALUE '20082'. DATEUTIL 118700 10 FILLER PIC X(05) VALUE '20094'. DATEUTIL 118800 10 FILLER PIC X(05) VALUE '20105'. DATEUTIL 118900 10 FILLER PIC X(05) VALUE '20116'. DATEUTIL 119000 10 FILLER PIC X(05) VALUE '20127'. DATEUTIL 119100 10 FILLER PIC X(05) VALUE '20132'. DATEUTIL 119200 10 FILLER PIC X(05) VALUE '20143'. DATEUTIL 119300 10 FILLER PIC X(05) VALUE '20154'. DATEUTIL 119400 10 FILLER PIC X(05) VALUE '20165'. DATEUTIL 119500 10 FILLER PIC X(05) VALUE '20177'. DATEUTIL 119600 10 FILLER PIC X(05) VALUE '20181'. DATEUTIL 119700 10 FILLER PIC X(05) VALUE '20192'. DATEUTIL 119800 10 FILLER PIC X(05) VALUE '20203'. DATEUTIL 119900 10 FILLER PIC X(05) VALUE '20215'. DATEUTIL 120000 10 FILLER PIC X(05) VALUE '20226'. DATEUTIL 120100 10 FILLER PIC X(05) VALUE '20237'. DATEUTIL 120200 10 FILLER PIC X(05) VALUE '20241'. DATEUTIL 120300 10 FILLER PIC X(05) VALUE '20253'. DATEUTIL 120400 10 FILLER PIC X(05) VALUE '20264'. DATEUTIL 120500 10 FILLER PIC X(05) VALUE '20275'. DATEUTIL 120600 10 FILLER PIC X(05) VALUE '20286'. DATEUTIL 120700 10 FILLER PIC X(05) VALUE '20291'. DATEUTIL 120800 10 FILLER PIC X(05) VALUE '20302'. DATEUTIL 120900 10 FILLER PIC X(05) VALUE '20313'. DATEUTIL 121000 10 FILLER PIC X(05) VALUE '20324'. DATEUTIL 121100 10 FILLER PIC X(05) VALUE '20336'. DATEUTIL 121200 10 FILLER PIC X(05) VALUE '20347'. DATEUTIL 121300 10 FILLER PIC X(05) VALUE '20351'. DATEUTIL 121400 10 FILLER PIC X(05) VALUE '20362'. DATEUTIL 121500 10 FILLER PIC X(05) VALUE '20374'. DATEUTIL 121600 10 FILLER PIC X(05) VALUE '20385'. DATEUTIL 121700 10 FILLER PIC X(05) VALUE '20396'. DATEUTIL 121800 10 FILLER PIC X(05) VALUE '20407'. DATEUTIL 121900 10 FILLER PIC X(05) VALUE '20412'. DATEUTIL 122000 10 FILLER PIC X(05) VALUE '20423'. DATEUTIL 122100 10 FILLER PIC X(05) VALUE '20434'. DATEUTIL 122200 10 FILLER PIC X(05) VALUE '20445'. DATEUTIL 122300 10 FILLER PIC X(05) VALUE '20457'. DATEUTIL 122400 10 FILLER PIC X(05) VALUE '20461'. DATEUTIL 122500 10 FILLER PIC X(05) VALUE '20472'. DATEUTIL 122600 10 FILLER PIC X(05) VALUE '20483'. DATEUTIL 122700 10 FILLER PIC X(05) VALUE '20495'. DATEUTIL 122800 10 FILLER PIC X(05) VALUE '20506'. DATEUTIL 122900 10 FILLER PIC X(05) VALUE '20517'. DATEUTIL 123000 10 FILLER PIC X(05) VALUE '20521'. DATEUTIL 123100 10 FILLER PIC X(05) VALUE '20533'. DATEUTIL 123200 10 FILLER PIC X(05) VALUE '20544'. DATEUTIL 123300 10 FILLER PIC X(05) VALUE '20555'. DATEUTIL 123400 10 FILLER PIC X(05) VALUE '20566'. DATEUTIL 123500 10 FILLER PIC X(05) VALUE '20571'. DATEUTIL 123600 10 FILLER PIC X(05) VALUE '20582'. DATEUTIL 123700 10 FILLER PIC X(05) VALUE '20593'. DATEUTIL 123800 10 FILLER PIC X(05) VALUE '20604'. DATEUTIL 123900 10 FILLER PIC X(05) VALUE '20616'. DATEUTIL 124000 10 FILLER PIC X(05) VALUE '20627'. DATEUTIL 124100 10 FILLER PIC X(05) VALUE '20631'. DATEUTIL 124200 10 FILLER PIC X(05) VALUE '20642'. DATEUTIL 124300 10 FILLER PIC X(05) VALUE '20654'. DATEUTIL 124400 10 FILLER PIC X(05) VALUE '20665'. DATEUTIL 124500 10 FILLER PIC X(05) VALUE '20676'. DATEUTIL 124600 10 FILLER PIC X(05) VALUE '20687'. DATEUTIL 124700 10 FILLER PIC X(05) VALUE '20692'. DATEUTIL 124800 10 FILLER PIC X(05) VALUE '20703'. DATEUTIL 124900 10 FILLER PIC X(05) VALUE '20714'. DATEUTIL 125000 10 FILLER PIC X(05) VALUE '20725'. DATEUTIL 125100 10 FILLER PIC X(05) VALUE '20737'. DATEUTIL 125200 10 FILLER PIC X(05) VALUE '20741'. DATEUTIL 125300 10 FILLER PIC X(05) VALUE '20752'. DATEUTIL 125400 10 FILLER PIC X(05) VALUE '20763'. DATEUTIL 125500 10 FILLER PIC X(05) VALUE '20775'. DATEUTIL 125600 10 FILLER PIC X(05) VALUE '20786'. DATEUTIL 125700 10 FILLER PIC X(05) VALUE '20797'. DATEUTIL 125800 10 FILLER PIC X(05) VALUE '20801'. DATEUTIL 125900 10 FILLER PIC X(05) VALUE '20813'. DATEUTIL 126000 10 FILLER PIC X(05) VALUE '20824'. DATEUTIL 126100 10 FILLER PIC X(05) VALUE '20835'. DATEUTIL 126200 10 FILLER PIC X(05) VALUE '20846'. DATEUTIL 126300 10 FILLER PIC X(05) VALUE '20851'. DATEUTIL 126400 10 FILLER PIC X(05) VALUE '20862'. DATEUTIL 126500 10 FILLER PIC X(05) VALUE '20873'. DATEUTIL 126600 10 FILLER PIC X(05) VALUE '20884'. DATEUTIL 126700 10 FILLER PIC X(05) VALUE '20896'. DATEUTIL 126800 10 FILLER PIC X(05) VALUE '20907'. DATEUTIL 126900 10 FILLER PIC X(05) VALUE '20911'. DATEUTIL 127000 10 FILLER PIC X(05) VALUE '20922'. DATEUTIL 127100 10 FILLER PIC X(05) VALUE '20934'. DATEUTIL 127200 10 FILLER PIC X(05) VALUE '20945'. DATEUTIL 127300 10 FILLER PIC X(05) VALUE '20956'. DATEUTIL 127400 10 FILLER PIC X(05) VALUE '20967'. DATEUTIL 127500 10 FILLER PIC X(05) VALUE '20972'. DATEUTIL 127600 10 FILLER PIC X(05) VALUE '20983'. DATEUTIL 127700 10 FILLER PIC X(05) VALUE '20994'. DATEUTIL 127800 10 FILLER PIC X(05) VALUE '21005'. DATEUTIL 127900 10 FILLER PIC X(05) VALUE '21016'. DATEUTIL 128000 10 FILLER PIC X(05) VALUE '21027'. DATEUTIL 128100 10 FILLER PIC X(05) VALUE '21031'. DATEUTIL 128200 10 FILLER PIC X(05) VALUE '21042'. DATEUTIL 128300 10 FILLER PIC X(05) VALUE '21054'. DATEUTIL 128400 10 FILLER PIC X(05) VALUE '21065'. DATEUTIL 128500 10 FILLER PIC X(05) VALUE '21076'. DATEUTIL 128600 10 FILLER PIC X(05) VALUE '21087'. DATEUTIL 128700 10 FILLER PIC X(05) VALUE '21092'. DATEUTIL 128800 10 FILLER PIC X(05) VALUE '21103'. DATEUTIL 128900 10 FILLER PIC X(05) VALUE '21114'. DATEUTIL 129000 10 FILLER PIC X(05) VALUE '21125'. DATEUTIL 129100 10 FILLER PIC X(05) VALUE '21137'. DATEUTIL 129200 10 FILLER PIC X(05) VALUE '21141'. DATEUTIL 129300 10 FILLER PIC X(05) VALUE '21152'. DATEUTIL 129400 10 FILLER PIC X(05) VALUE '21163'. DATEUTIL 129500 10 FILLER PIC X(05) VALUE '21175'. DATEUTIL 129600 10 FILLER PIC X(05) VALUE '21186'. DATEUTIL 129700 10 FILLER PIC X(05) VALUE '21197'. DATEUTIL 129800 10 FILLER PIC X(05) VALUE '21201'. DATEUTIL 129900 10 FILLER PIC X(05) VALUE '21213'. DATEUTIL 130000 10 FILLER PIC X(05) VALUE '21224'. DATEUTIL 130100 10 FILLER PIC X(05) VALUE '21235'. DATEUTIL 130200 10 FILLER PIC X(05) VALUE '21246'. DATEUTIL 130300 10 FILLER PIC X(05) VALUE '21251'. DATEUTIL 130400 10 FILLER PIC X(05) VALUE '21262'. DATEUTIL 130500 10 FILLER PIC X(05) VALUE '21273'. DATEUTIL 130600 10 FILLER PIC X(05) VALUE '21284'. DATEUTIL 130700 10 FILLER PIC X(05) VALUE '21296'. DATEUTIL 130800 10 FILLER PIC X(05) VALUE '21307'. DATEUTIL 130900 10 FILLER PIC X(05) VALUE '21311'. DATEUTIL 131000 10 FILLER PIC X(05) VALUE '21322'. DATEUTIL 131100 10 FILLER PIC X(05) VALUE '21334'. DATEUTIL 131200 10 FILLER PIC X(05) VALUE '21345'. DATEUTIL 131300 10 FILLER PIC X(05) VALUE '21356'. DATEUTIL 131400 10 FILLER PIC X(05) VALUE '21367'. DATEUTIL 131500 10 FILLER PIC X(05) VALUE '21372'. DATEUTIL 131600 10 FILLER PIC X(05) VALUE '21383'. DATEUTIL 131700 10 FILLER PIC X(05) VALUE '21394'. DATEUTIL 131800 10 FILLER PIC X(05) VALUE '21405'. DATEUTIL 131900 10 FILLER PIC X(05) VALUE '21417'. DATEUTIL 132000 10 FILLER PIC X(05) VALUE '21421'. DATEUTIL 132100 10 FILLER PIC X(05) VALUE '21432'. DATEUTIL 132200 10 FILLER PIC X(05) VALUE '21443'. DATEUTIL 132300 10 FILLER PIC X(05) VALUE '21455'. DATEUTIL 132400 10 FILLER PIC X(05) VALUE '21466'. DATEUTIL 132500 10 FILLER PIC X(05) VALUE '21477'. DATEUTIL 132600 10 FILLER PIC X(05) VALUE '21481'. DATEUTIL 132700 10 FILLER PIC X(05) VALUE '21493'. DATEUTIL 132800 10 FILLER PIC X(05) VALUE '21504'. DATEUTIL 132900 10 FILLER PIC X(05) VALUE '21515'. DATEUTIL 133000 10 FILLER PIC X(05) VALUE '21526'. DATEUTIL 133100 10 FILLER PIC X(05) VALUE '21531'. DATEUTIL 133200 10 FILLER PIC X(05) VALUE '21542'. DATEUTIL 133300 10 FILLER PIC X(05) VALUE '21553'. DATEUTIL 133400 10 FILLER PIC X(05) VALUE '21564'. DATEUTIL 133500 10 FILLER PIC X(05) VALUE '21576'. DATEUTIL 133600 10 FILLER PIC X(05) VALUE '21587'. DATEUTIL 133700 10 FILLER PIC X(05) VALUE '21591'. DATEUTIL 133800 10 FILLER PIC X(05) VALUE '21602'. DATEUTIL 133900 10 FILLER PIC X(05) VALUE '21614'. DATEUTIL 134000 10 FILLER PIC X(05) VALUE '21625'. DATEUTIL 134100 10 FILLER PIC X(05) VALUE '21636'. DATEUTIL 134200 10 FILLER PIC X(05) VALUE '21647'. DATEUTIL 134300 10 FILLER PIC X(05) VALUE '21652'. DATEUTIL 134400 10 FILLER PIC X(05) VALUE '21663'. DATEUTIL 134500 10 FILLER PIC X(05) VALUE '21674'. DATEUTIL 134600 10 FILLER PIC X(05) VALUE '21685'. DATEUTIL 134700 10 FILLER PIC X(05) VALUE '21697'. DATEUTIL 134800 10 FILLER PIC X(05) VALUE '21701'. DATEUTIL 134900 10 FILLER PIC X(05) VALUE '21712'. DATEUTIL 135000 10 FILLER PIC X(05) VALUE '21723'. DATEUTIL 135100 10 FILLER PIC X(05) VALUE '21735'. DATEUTIL 135200 10 FILLER PIC X(05) VALUE '21746'. DATEUTIL 135300 10 FILLER PIC X(05) VALUE '21757'. DATEUTIL 135400 10 FILLER PIC X(05) VALUE '21761'. DATEUTIL 135500 10 FILLER PIC X(05) VALUE '21773'. DATEUTIL 135600 10 FILLER PIC X(05) VALUE '21784'. DATEUTIL 135700 10 FILLER PIC X(05) VALUE '21795'. DATEUTIL 135800 10 FILLER PIC X(05) VALUE '21806'. DATEUTIL 135900 10 FILLER PIC X(05) VALUE '21811'. DATEUTIL 136000 10 FILLER PIC X(05) VALUE '21822'. DATEUTIL 136100 10 FILLER PIC X(05) VALUE '21833'. DATEUTIL 136200 10 FILLER PIC X(05) VALUE '21844'. DATEUTIL 136300 10 FILLER PIC X(05) VALUE '21856'. DATEUTIL 136400 10 FILLER PIC X(05) VALUE '21867'. DATEUTIL 136500 10 FILLER PIC X(05) VALUE '21871'. DATEUTIL 136600 10 FILLER PIC X(05) VALUE '21882'. DATEUTIL 136700 10 FILLER PIC X(05) VALUE '21894'. DATEUTIL 136800 10 FILLER PIC X(05) VALUE '21905'. DATEUTIL 136900 10 FILLER PIC X(05) VALUE '21916'. DATEUTIL 137000 10 FILLER PIC X(05) VALUE '21927'. DATEUTIL 137100 10 FILLER PIC X(05) VALUE '21932'. DATEUTIL 137200 10 FILLER PIC X(05) VALUE '21943'. DATEUTIL 137300 10 FILLER PIC X(05) VALUE '21954'. DATEUTIL 137400 10 FILLER PIC X(05) VALUE '21965'. DATEUTIL 137500 10 FILLER PIC X(05) VALUE '21977'. DATEUTIL 137600 10 FILLER PIC X(05) VALUE '21981'. DATEUTIL 137700 10 FILLER PIC X(05) VALUE '21992'. DATEUTIL 137800 10 FILLER PIC X(05) VALUE '22003'. DATEUTIL 137900 10 FILLER PIC X(05) VALUE '22014'. DATEUTIL 138000 10 FILLER PIC X(05) VALUE '22025'. DATEUTIL 138100 10 FILLER PIC X(05) VALUE '22036'. DATEUTIL 138200 10 FILLER PIC X(05) VALUE '22047'. DATEUTIL 138300 10 FILLER PIC X(05) VALUE '22052'. DATEUTIL 138400 10 FILLER PIC X(05) VALUE '22063'. DATEUTIL 138500 10 FILLER PIC X(05) VALUE '22074'. DATEUTIL 138600 10 FILLER PIC X(05) VALUE '22085'. DATEUTIL 138700 10 FILLER PIC X(05) VALUE '22097'. DATEUTIL 138800 10 FILLER PIC X(05) VALUE '22101'. DATEUTIL 138900 10 FILLER PIC X(05) VALUE '22112'. DATEUTIL 139000 10 FILLER PIC X(05) VALUE '22123'. DATEUTIL 139100 10 FILLER PIC X(05) VALUE '22135'. DATEUTIL 139200 10 FILLER PIC X(05) VALUE '22146'. DATEUTIL 139300 10 FILLER PIC X(05) VALUE '22157'. DATEUTIL 139400 10 FILLER PIC X(05) VALUE '22161'. DATEUTIL 139500 10 FILLER PIC X(05) VALUE '22173'. DATEUTIL 139600 10 FILLER PIC X(05) VALUE '22184'. DATEUTIL 139700 10 FILLER PIC X(05) VALUE '22195'. DATEUTIL 139800 10 FILLER PIC X(05) VALUE '22206'. DATEUTIL 139900 10 FILLER PIC X(05) VALUE '22211'. DATEUTIL 140000 10 FILLER PIC X(05) VALUE '22222'. DATEUTIL 140100 10 FILLER PIC X(05) VALUE '22233'. DATEUTIL 140200 10 FILLER PIC X(05) VALUE '22244'. DATEUTIL 140300 10 FILLER PIC X(05) VALUE '22256'. DATEUTIL 140400 10 FILLER PIC X(05) VALUE '22267'. DATEUTIL 140500 10 FILLER PIC X(05) VALUE '22271'. DATEUTIL 140600 10 FILLER PIC X(05) VALUE '22282'. DATEUTIL 140700 10 FILLER PIC X(05) VALUE '22294'. DATEUTIL 140800 10 FILLER PIC X(05) VALUE '22305'. DATEUTIL 140900 10 FILLER PIC X(05) VALUE '22316'. DATEUTIL 141000 10 FILLER PIC X(05) VALUE '22327'. DATEUTIL 141100 10 FILLER PIC X(05) VALUE '22332'. DATEUTIL 141200 10 FILLER PIC X(05) VALUE '22343'. DATEUTIL 141300 10 FILLER PIC X(05) VALUE '22354'. DATEUTIL 141400 10 FILLER PIC X(05) VALUE '22365'. DATEUTIL 141500 10 FILLER PIC X(05) VALUE '22377'. DATEUTIL 141600 10 FILLER PIC X(05) VALUE '22381'. DATEUTIL 141700 10 FILLER PIC X(05) VALUE '22392'. DATEUTIL 141800 10 FILLER PIC X(05) VALUE '22403'. DATEUTIL 141900 10 FILLER PIC X(05) VALUE '22415'. DATEUTIL 142000 10 FILLER PIC X(05) VALUE '22426'. DATEUTIL 142100 10 FILLER PIC X(05) VALUE '22437'. DATEUTIL 142200 10 FILLER PIC X(05) VALUE '22441'. DATEUTIL 142300 10 FILLER PIC X(05) VALUE '22453'. DATEUTIL 142400 10 FILLER PIC X(05) VALUE '22464'. DATEUTIL 142500 10 FILLER PIC X(05) VALUE '22475'. DATEUTIL 142600 10 FILLER PIC X(05) VALUE '22486'. DATEUTIL 142700 10 FILLER PIC X(05) VALUE '22491'. DATEUTIL 142800 10 FILLER PIC X(05) VALUE '22502'. DATEUTIL 142900 10 FILLER PIC X(05) VALUE '22513'. DATEUTIL 143000 10 FILLER PIC X(05) VALUE '22524'. DATEUTIL 143100 10 FILLER PIC X(05) VALUE '22536'. DATEUTIL 143200 10 FILLER PIC X(05) VALUE '22547'. DATEUTIL 143300 10 FILLER PIC X(05) VALUE '22551'. DATEUTIL 143400 10 FILLER PIC X(05) VALUE '22562'. DATEUTIL 143500 10 FILLER PIC X(05) VALUE '22574'. DATEUTIL 143600 10 FILLER PIC X(05) VALUE '22585'. DATEUTIL 143700 10 FILLER PIC X(05) VALUE '22596'. DATEUTIL 143800 10 FILLER PIC X(05) VALUE '22607'. DATEUTIL 143900 10 FILLER PIC X(05) VALUE '22612'. DATEUTIL 144000 10 FILLER PIC X(05) VALUE '22623'. DATEUTIL 144100 10 FILLER PIC X(05) VALUE '22634'. DATEUTIL 144200 10 FILLER PIC X(05) VALUE '22645'. DATEUTIL 144300 10 FILLER PIC X(05) VALUE '22657'. DATEUTIL 144400 10 FILLER PIC X(05) VALUE '22661'. DATEUTIL 144500 10 FILLER PIC X(05) VALUE '22672'. DATEUTIL 144600 10 FILLER PIC X(05) VALUE '22683'. DATEUTIL 144700 10 FILLER PIC X(05) VALUE '22695'. DATEUTIL 144800 10 FILLER PIC X(05) VALUE '22706'. DATEUTIL 144900 10 FILLER PIC X(05) VALUE '22717'. DATEUTIL 145000 10 FILLER PIC X(05) VALUE '22721'. DATEUTIL 145100 10 FILLER PIC X(05) VALUE '22733'. DATEUTIL 145200 10 FILLER PIC X(05) VALUE '22744'. DATEUTIL 145300 10 FILLER PIC X(05) VALUE '22755'. DATEUTIL 145400 10 FILLER PIC X(05) VALUE '22766'. DATEUTIL 145500 10 FILLER PIC X(05) VALUE '22771'. DATEUTIL 145600 10 FILLER PIC X(05) VALUE '22782'. DATEUTIL 145700 10 FILLER PIC X(05) VALUE '22793'. DATEUTIL 145800 10 FILLER PIC X(05) VALUE '22804'. DATEUTIL 145900 10 FILLER PIC X(05) VALUE '22816'. DATEUTIL 146000 10 FILLER PIC X(05) VALUE '22827'. DATEUTIL 146100 10 FILLER PIC X(05) VALUE '22831'. DATEUTIL 146200 10 FILLER PIC X(05) VALUE '22842'. DATEUTIL 146300 10 FILLER PIC X(05) VALUE '22854'. DATEUTIL 146400 10 FILLER PIC X(05) VALUE '22865'. DATEUTIL 146500 10 FILLER PIC X(05) VALUE '22876'. DATEUTIL 146600 10 FILLER PIC X(05) VALUE '22887'. DATEUTIL 146700 10 FILLER PIC X(05) VALUE '22892'. DATEUTIL 146800 10 FILLER PIC X(05) VALUE '22903'. DATEUTIL 146900 10 FILLER PIC X(05) VALUE '22914'. DATEUTIL 147000 10 FILLER PIC X(05) VALUE '22925'. DATEUTIL 147100 10 FILLER PIC X(05) VALUE '22937'. DATEUTIL 147200 10 FILLER PIC X(05) VALUE '22941'. DATEUTIL 147300 10 FILLER PIC X(05) VALUE '22952'. DATEUTIL 147400 10 FILLER PIC X(05) VALUE '22963'. DATEUTIL 147500 10 FILLER PIC X(05) VALUE '22975'. DATEUTIL 147600 10 FILLER PIC X(05) VALUE '22986'. DATEUTIL 147700 10 FILLER PIC X(05) VALUE '22997'. DATEUTIL 147800 10 FILLER PIC X(05) VALUE '23001'. DATEUTIL 147900 10 FILLER PIC X(05) VALUE '23012'. DATEUTIL 148000 10 FILLER PIC X(05) VALUE '23023'. DATEUTIL 148100 10 FILLER PIC X(05) VALUE '23034'. DATEUTIL 148200 10 FILLER PIC X(05) VALUE '23045'. DATEUTIL 148300 10 FILLER PIC X(05) VALUE '23057'. DATEUTIL 148400 10 FILLER PIC X(05) VALUE '23061'. DATEUTIL 148500 10 FILLER PIC X(05) VALUE '23072'. DATEUTIL 148600 10 FILLER PIC X(05) VALUE '23083'. DATEUTIL 148700 10 FILLER PIC X(05) VALUE '23095'. DATEUTIL 148800 10 FILLER PIC X(05) VALUE '23106'. DATEUTIL 148900 10 FILLER PIC X(05) VALUE '23117'. DATEUTIL 149000 10 FILLER PIC X(05) VALUE '23121'. DATEUTIL 149100 10 FILLER PIC X(05) VALUE '23133'. DATEUTIL 149200 10 FILLER PIC X(05) VALUE '23144'. DATEUTIL 149300 10 FILLER PIC X(05) VALUE '23155'. DATEUTIL 149400 10 FILLER PIC X(05) VALUE '23166'. DATEUTIL 149500 10 FILLER PIC X(05) VALUE '23171'. DATEUTIL 149600 10 FILLER PIC X(05) VALUE '23182'. DATEUTIL 149700 10 FILLER PIC X(05) VALUE '23193'. DATEUTIL 149800 10 FILLER PIC X(05) VALUE '23204'. DATEUTIL 149900 10 FILLER PIC X(05) VALUE '23216'. DATEUTIL 150000 10 FILLER PIC X(05) VALUE '23227'. DATEUTIL 150100 10 FILLER PIC X(05) VALUE '23231'. DATEUTIL 150200 10 FILLER PIC X(05) VALUE '23242'. DATEUTIL 150300 10 FILLER PIC X(05) VALUE '23254'. DATEUTIL 150400 10 FILLER PIC X(05) VALUE '23265'. DATEUTIL 150500 10 FILLER PIC X(05) VALUE '23276'. DATEUTIL 150600 10 FILLER PIC X(05) VALUE '23287'. DATEUTIL 150700 10 FILLER PIC X(05) VALUE '23292'. DATEUTIL 150800 10 FILLER PIC X(05) VALUE '23303'. DATEUTIL 150900 10 FILLER PIC X(05) VALUE '23314'. DATEUTIL 151000 10 FILLER PIC X(05) VALUE '23325'. DATEUTIL 151100 10 FILLER PIC X(05) VALUE '23337'. DATEUTIL 151200 10 FILLER PIC X(05) VALUE '23341'. DATEUTIL 151300 10 FILLER PIC X(05) VALUE '23352'. DATEUTIL 151400 10 FILLER PIC X(05) VALUE '23363'. DATEUTIL 151500 10 FILLER PIC X(05) VALUE '23375'. DATEUTIL 151600 10 FILLER PIC X(05) VALUE '23386'. DATEUTIL 151700 10 FILLER PIC X(05) VALUE '23397'. DATEUTIL 151800 10 FILLER PIC X(05) VALUE '23401'. DATEUTIL 151900 10 FILLER PIC X(05) VALUE '23413'. DATEUTIL 152000 10 FILLER PIC X(05) VALUE '23424'. DATEUTIL 152100 10 FILLER PIC X(05) VALUE '23435'. DATEUTIL 152200 10 FILLER PIC X(05) VALUE '23446'. DATEUTIL 152300 10 FILLER PIC X(05) VALUE '23451'. DATEUTIL 152400 10 FILLER PIC X(05) VALUE '23462'. DATEUTIL 152500 10 FILLER PIC X(05) VALUE '23473'. DATEUTIL 152600 10 FILLER PIC X(05) VALUE '23484'. DATEUTIL 152700 10 FILLER PIC X(05) VALUE '23496'. DATEUTIL 152800 10 FILLER PIC X(05) VALUE '23507'. DATEUTIL 152900 10 FILLER PIC X(05) VALUE '23511'. DATEUTIL 153000 10 FILLER PIC X(05) VALUE '23522'. DATEUTIL 153100 10 FILLER PIC X(05) VALUE '23534'. DATEUTIL 153200 10 FILLER PIC X(05) VALUE '23545'. DATEUTIL 153300 10 FILLER PIC X(05) VALUE '23556'. DATEUTIL 153400 10 FILLER PIC X(05) VALUE '23567'. DATEUTIL 153500 10 FILLER PIC X(05) VALUE '23572'. DATEUTIL 153600 10 FILLER PIC X(05) VALUE '23583'. DATEUTIL 153700 10 FILLER PIC X(05) VALUE '23594'. DATEUTIL 153800 10 FILLER PIC X(05) VALUE '23605'. DATEUTIL 153900 10 FILLER PIC X(05) VALUE '23617'. DATEUTIL 154000 10 FILLER PIC X(05) VALUE '23621'. DATEUTIL 154100 10 FILLER PIC X(05) VALUE '23632'. DATEUTIL 154200 10 FILLER PIC X(05) VALUE '23643'. DATEUTIL 154300 10 FILLER PIC X(05) VALUE '23655'. DATEUTIL 154400 10 FILLER PIC X(05) VALUE '23666'. DATEUTIL 154500 10 FILLER PIC X(05) VALUE '23677'. DATEUTIL 154600 10 FILLER PIC X(05) VALUE '23681'. DATEUTIL 154700 10 FILLER PIC X(05) VALUE '23693'. DATEUTIL 154800 10 FILLER PIC X(05) VALUE '23704'. DATEUTIL 154900 10 FILLER PIC X(05) VALUE '23715'. DATEUTIL 155000 10 FILLER PIC X(05) VALUE '23726'. DATEUTIL 155100 10 FILLER PIC X(05) VALUE '23731'. DATEUTIL 155200 10 FILLER PIC X(05) VALUE '23742'. DATEUTIL 155300 10 FILLER PIC X(05) VALUE '23753'. DATEUTIL 155400 10 FILLER PIC X(05) VALUE '23764'. DATEUTIL 155500 10 FILLER PIC X(05) VALUE '23776'. DATEUTIL 155600 10 FILLER PIC X(05) VALUE '23787'. DATEUTIL 155700 10 FILLER PIC X(05) VALUE '23791'. DATEUTIL 155800 10 FILLER PIC X(05) VALUE '23802'. DATEUTIL 155900 10 FILLER PIC X(05) VALUE '23814'. DATEUTIL 156000 10 FILLER PIC X(05) VALUE '23825'. DATEUTIL 156100 10 FILLER PIC X(05) VALUE '23836'. DATEUTIL 156200 10 FILLER PIC X(05) VALUE '23847'. DATEUTIL 156300 10 FILLER PIC X(05) VALUE '23852'. DATEUTIL 156400 10 FILLER PIC X(05) VALUE '23863'. DATEUTIL 156500 10 FILLER PIC X(05) VALUE '23874'. DATEUTIL 156600 10 FILLER PIC X(05) VALUE '23885'. DATEUTIL 156700 10 FILLER PIC X(05) VALUE '23897'. DATEUTIL 156800 10 FILLER PIC X(05) VALUE '23901'. DATEUTIL 156900 10 FILLER PIC X(05) VALUE '23912'. DATEUTIL 157000 10 FILLER PIC X(05) VALUE '23923'. DATEUTIL 157100 10 FILLER PIC X(05) VALUE '23935'. DATEUTIL 157200 10 FILLER PIC X(05) VALUE '23946'. DATEUTIL 157300 10 FILLER PIC X(05) VALUE '23957'. DATEUTIL 157400 10 FILLER PIC X(05) VALUE '23961'. DATEUTIL 157500 10 FILLER PIC X(05) VALUE '23973'. DATEUTIL 157600 10 FILLER PIC X(05) VALUE '23984'. DATEUTIL 157700 10 FILLER PIC X(05) VALUE '23995'. DATEUTIL 157800 10 FILLER PIC X(05) VALUE '24006'. DATEUTIL 157900 10 FILLER PIC X(05) VALUE '24011'. DATEUTIL 158000 10 FILLER PIC X(05) VALUE '24022'. DATEUTIL 158100 10 FILLER PIC X(05) VALUE '24033'. DATEUTIL 158200 10 FILLER PIC X(05) VALUE '24044'. DATEUTIL 158300 10 FILLER PIC X(05) VALUE '24056'. DATEUTIL 158400 10 FILLER PIC X(05) VALUE '24067'. DATEUTIL 158500 10 FILLER PIC X(05) VALUE '24071'. DATEUTIL 158600 10 FILLER PIC X(05) VALUE '24082'. DATEUTIL 158700 10 FILLER PIC X(05) VALUE '24094'. DATEUTIL 158800 10 FILLER PIC X(05) VALUE '24105'. DATEUTIL 158900 10 FILLER PIC X(05) VALUE '24116'. DATEUTIL 159000 10 FILLER PIC X(05) VALUE '24127'. DATEUTIL 159100 10 FILLER PIC X(05) VALUE '24132'. DATEUTIL 159200 10 FILLER PIC X(05) VALUE '24143'. DATEUTIL 159300 10 FILLER PIC X(05) VALUE '24154'. DATEUTIL 159400 10 FILLER PIC X(05) VALUE '24165'. DATEUTIL 159500 10 FILLER PIC X(05) VALUE '24177'. DATEUTIL 159600 10 FILLER PIC X(05) VALUE '24181'. DATEUTIL 159700 10 FILLER PIC X(05) VALUE '24192'. DATEUTIL 159800 10 FILLER PIC X(05) VALUE '24203'. DATEUTIL 159900 10 FILLER PIC X(05) VALUE '24215'. DATEUTIL 160000 10 FILLER PIC X(05) VALUE '24226'. DATEUTIL 160100 10 FILLER PIC X(05) VALUE '24237'. DATEUTIL 160200 10 FILLER PIC X(05) VALUE '24241'. DATEUTIL 160300 10 FILLER PIC X(05) VALUE '24253'. DATEUTIL 160400 10 FILLER PIC X(05) VALUE '24264'. DATEUTIL 160500 10 FILLER PIC X(05) VALUE '24275'. DATEUTIL 160600 10 FILLER PIC X(05) VALUE '24286'. DATEUTIL 160700 10 FILLER PIC X(05) VALUE '24291'. DATEUTIL 160800 10 FILLER PIC X(05) VALUE '24302'. DATEUTIL 160900 10 FILLER PIC X(05) VALUE '24313'. DATEUTIL 161000 10 FILLER PIC X(05) VALUE '24324'. DATEUTIL 161100 10 FILLER PIC X(05) VALUE '24336'. DATEUTIL 161200 10 FILLER PIC X(05) VALUE '24347'. DATEUTIL 161300 10 FILLER PIC X(05) VALUE '24351'. DATEUTIL 161400 10 FILLER PIC X(05) VALUE '24362'. DATEUTIL 161500 10 FILLER PIC X(05) VALUE '24374'. DATEUTIL 161600 10 FILLER PIC X(05) VALUE '24385'. DATEUTIL 161700 10 FILLER PIC X(05) VALUE '24396'. DATEUTIL 161800 10 FILLER PIC X(05) VALUE '24407'. DATEUTIL 161900 10 FILLER PIC X(05) VALUE '24412'. DATEUTIL 162000 10 FILLER PIC X(05) VALUE '24423'. DATEUTIL 162100 10 FILLER PIC X(05) VALUE '24434'. DATEUTIL 162200 10 FILLER PIC X(05) VALUE '24445'. DATEUTIL 162300 10 FILLER PIC X(05) VALUE '24457'. DATEUTIL 162400 10 FILLER PIC X(05) VALUE '24461'. DATEUTIL 162500 10 FILLER PIC X(05) VALUE '24472'. DATEUTIL 162600 10 FILLER PIC X(05) VALUE '24483'. DATEUTIL 162700 10 FILLER PIC X(05) VALUE '24495'. DATEUTIL 162800 10 FILLER PIC X(05) VALUE '24506'. DATEUTIL 162900 10 FILLER PIC X(05) VALUE '24517'. DATEUTIL 163000 10 FILLER PIC X(05) VALUE '24521'. DATEUTIL 163100 10 FILLER PIC X(05) VALUE '24533'. DATEUTIL 163200 10 FILLER PIC X(05) VALUE '24544'. DATEUTIL 163300 10 FILLER PIC X(05) VALUE '24555'. DATEUTIL 163400 10 FILLER PIC X(05) VALUE '24566'. DATEUTIL 163500 10 FILLER PIC X(05) VALUE '24571'. DATEUTIL 163600 10 FILLER PIC X(05) VALUE '24582'. DATEUTIL 163700 10 FILLER PIC X(05) VALUE '24593'. DATEUTIL 163800 10 FILLER PIC X(05) VALUE '24604'. DATEUTIL 163900 10 FILLER PIC X(05) VALUE '24616'. DATEUTIL 164000 10 FILLER PIC X(05) VALUE '24627'. DATEUTIL 164100 10 FILLER PIC X(05) VALUE '24631'. DATEUTIL 164200 10 FILLER PIC X(05) VALUE '24642'. DATEUTIL 164300 10 FILLER PIC X(05) VALUE '24654'. DATEUTIL 164400 10 FILLER PIC X(05) VALUE '24665'. DATEUTIL 164500 10 FILLER PIC X(05) VALUE '24676'. DATEUTIL 164600 10 FILLER PIC X(05) VALUE '24687'. DATEUTIL 164700 10 FILLER PIC X(05) VALUE '24692'. DATEUTIL 164800 10 FILLER PIC X(05) VALUE '24703'. DATEUTIL 164900 10 FILLER PIC X(05) VALUE '24714'. DATEUTIL 165000 10 FILLER PIC X(05) VALUE '24725'. DATEUTIL 165100 10 FILLER PIC X(05) VALUE '24737'. DATEUTIL 165200 10 FILLER PIC X(05) VALUE '24741'. DATEUTIL 165300 10 FILLER PIC X(05) VALUE '24752'. DATEUTIL 165400 10 FILLER PIC X(05) VALUE '24763'. DATEUTIL 165500 10 FILLER PIC X(05) VALUE '24775'. DATEUTIL 165600 10 FILLER PIC X(05) VALUE '24786'. DATEUTIL 165700 10 FILLER PIC X(05) VALUE '24797'. DATEUTIL 165800 10 FILLER PIC X(05) VALUE '24801'. DATEUTIL 165900 10 FILLER PIC X(05) VALUE '24813'. DATEUTIL 166000 10 FILLER PIC X(05) VALUE '24824'. DATEUTIL 166100 10 FILLER PIC X(05) VALUE '24835'. DATEUTIL 166200 10 FILLER PIC X(05) VALUE '24846'. DATEUTIL 166300 10 FILLER PIC X(05) VALUE '24851'. DATEUTIL 166400 10 FILLER PIC X(05) VALUE '24862'. DATEUTIL 166500 10 FILLER PIC X(05) VALUE '24873'. DATEUTIL 166600 10 FILLER PIC X(05) VALUE '24884'. DATEUTIL 166700 10 FILLER PIC X(05) VALUE '24896'. DATEUTIL 166800 10 FILLER PIC X(05) VALUE '24907'. DATEUTIL 166900 10 FILLER PIC X(05) VALUE '24911'. DATEUTIL 167000 10 FILLER PIC X(05) VALUE '24922'. DATEUTIL 167100 10 FILLER PIC X(05) VALUE '24934'. DATEUTIL 167200 10 FILLER PIC X(05) VALUE '24945'. DATEUTIL 167300 10 FILLER PIC X(05) VALUE '24956'. DATEUTIL 167400 10 FILLER PIC X(05) VALUE '24967'. DATEUTIL 167500 10 FILLER PIC X(05) VALUE '24972'. DATEUTIL 167600 10 FILLER PIC X(05) VALUE '24983'. DATEUTIL 167700 10 FILLER PIC X(05) VALUE '24994'. DATEUTIL 167800 10 FILLER PIC X(05) VALUE '25005'. DATEUTIL 167900 10 FILLER PIC X(05) VALUE '25016'. DATEUTIL 168000 10 FILLER PIC X(05) VALUE '25027'. DATEUTIL 168100 10 FILLER PIC X(05) VALUE '25031'. DATEUTIL 168200 10 FILLER PIC X(05) VALUE '25042'. DATEUTIL 168300 10 FILLER PIC X(05) VALUE '25054'. DATEUTIL 168400 10 FILLER PIC X(05) VALUE '25065'. DATEUTIL 168500 10 FILLER PIC X(05) VALUE '25076'. DATEUTIL 168600 10 FILLER PIC X(05) VALUE '25087'. DATEUTIL 168700 10 FILLER PIC X(05) VALUE '25092'. DATEUTIL 168800 10 FILLER PIC X(05) VALUE '25103'. DATEUTIL 168900 10 FILLER PIC X(05) VALUE '25114'. DATEUTIL 169000 10 FILLER PIC X(05) VALUE '25125'. DATEUTIL 169100 10 FILLER PIC X(05) VALUE '25137'. DATEUTIL 169200 10 FILLER PIC X(05) VALUE '25141'. DATEUTIL 169300 10 FILLER PIC X(05) VALUE '25152'. DATEUTIL 169400 10 FILLER PIC X(05) VALUE '25163'. DATEUTIL 169500 10 FILLER PIC X(05) VALUE '25175'. DATEUTIL 169600 10 FILLER PIC X(05) VALUE '25186'. DATEUTIL 169700 10 FILLER PIC X(05) VALUE '25197'. DATEUTIL 169800 10 FILLER PIC X(05) VALUE '25201'. DATEUTIL 169900 10 FILLER PIC X(05) VALUE '25213'. DATEUTIL 170000 10 FILLER PIC X(05) VALUE '25224'. DATEUTIL 170100 10 FILLER PIC X(05) VALUE '25235'. DATEUTIL 170200 10 FILLER PIC X(05) VALUE '25246'. DATEUTIL 170300 10 FILLER PIC X(05) VALUE '25251'. DATEUTIL 170400 10 FILLER PIC X(05) VALUE '25262'. DATEUTIL 170500 10 FILLER PIC X(05) VALUE '25273'. DATEUTIL 170600 10 FILLER PIC X(05) VALUE '25284'. DATEUTIL 170700 10 FILLER PIC X(05) VALUE '25296'. DATEUTIL 170800 10 FILLER PIC X(05) VALUE '25307'. DATEUTIL 170900 10 FILLER PIC X(05) VALUE '25311'. DATEUTIL 171000 10 FILLER PIC X(05) VALUE '25322'. DATEUTIL 171100 10 FILLER PIC X(05) VALUE '25334'. DATEUTIL 171200 10 FILLER PIC X(05) VALUE '25345'. DATEUTIL 171300 10 FILLER PIC X(05) VALUE '25356'. DATEUTIL 171400 10 FILLER PIC X(05) VALUE '25367'. DATEUTIL 171500 10 FILLER PIC X(05) VALUE '25372'. DATEUTIL 171600 10 FILLER PIC X(05) VALUE '25383'. DATEUTIL 171700 10 FILLER PIC X(05) VALUE '25394'. DATEUTIL 171800 10 FILLER PIC X(05) VALUE '25405'. DATEUTIL 171900 10 FILLER PIC X(05) VALUE '25417'. DATEUTIL 172000 10 FILLER PIC X(05) VALUE '25421'. DATEUTIL 172100 10 FILLER PIC X(05) VALUE '25432'. DATEUTIL 172200 10 FILLER PIC X(05) VALUE '25443'. DATEUTIL 172300 10 FILLER PIC X(05) VALUE '25455'. DATEUTIL 172400 10 FILLER PIC X(05) VALUE '25466'. DATEUTIL 172500 10 FILLER PIC X(05) VALUE '25477'. DATEUTIL 172600 10 FILLER PIC X(05) VALUE '25481'. DATEUTIL 172700 10 FILLER PIC X(05) VALUE '25493'. DATEUTIL 172800 10 FILLER PIC X(05) VALUE '25504'. DATEUTIL 172900 10 FILLER PIC X(05) VALUE '25515'. DATEUTIL 173000 10 FILLER PIC X(05) VALUE '25526'. DATEUTIL 173100 10 FILLER PIC X(05) VALUE '25531'. DATEUTIL 173200 10 FILLER PIC X(05) VALUE '25542'. DATEUTIL 173300 10 FILLER PIC X(05) VALUE '25553'. DATEUTIL 173400 10 FILLER PIC X(05) VALUE '25564'. DATEUTIL 173500 10 FILLER PIC X(05) VALUE '25576'. DATEUTIL 173600 10 FILLER PIC X(05) VALUE '25587'. DATEUTIL 173700 10 FILLER PIC X(05) VALUE '25591'. DATEUTIL 173800 10 FILLER PIC X(05) VALUE '25602'. DATEUTIL 173900 10 FILLER PIC X(05) VALUE '25614'. DATEUTIL 174000 10 FILLER PIC X(05) VALUE '25625'. DATEUTIL 174100 10 FILLER PIC X(05) VALUE '25636'. DATEUTIL 174200 10 FILLER PIC X(05) VALUE '25647'. DATEUTIL 174300 10 FILLER PIC X(05) VALUE '25652'. DATEUTIL 174400 10 FILLER PIC X(05) VALUE '25663'. DATEUTIL 174500 10 FILLER PIC X(05) VALUE '25674'. DATEUTIL 174600 10 FILLER PIC X(05) VALUE '25685'. DATEUTIL 174700 10 FILLER PIC X(05) VALUE '25697'. DATEUTIL 174800 10 FILLER PIC X(05) VALUE '25701'. DATEUTIL 174900 10 FILLER PIC X(05) VALUE '25712'. DATEUTIL 175000 10 FILLER PIC X(05) VALUE '25723'. DATEUTIL 175100 10 FILLER PIC X(05) VALUE '25735'. DATEUTIL 175200 10 FILLER PIC X(05) VALUE '25746'. DATEUTIL 175300 10 FILLER PIC X(05) VALUE '25757'. DATEUTIL 175400 10 FILLER PIC X(05) VALUE '25761'. DATEUTIL 175500 10 FILLER PIC X(05) VALUE '25773'. DATEUTIL 175600 10 FILLER PIC X(05) VALUE '25784'. DATEUTIL 175700 10 FILLER PIC X(05) VALUE '25795'. DATEUTIL 175800 10 FILLER PIC X(05) VALUE '25806'. DATEUTIL 175900 10 FILLER PIC X(05) VALUE '25811'. DATEUTIL 176000 10 FILLER PIC X(05) VALUE '25822'. DATEUTIL 176100 10 FILLER PIC X(05) VALUE '25833'. DATEUTIL 176200 10 FILLER PIC X(05) VALUE '25844'. DATEUTIL 176300 10 FILLER PIC X(05) VALUE '25856'. DATEUTIL 176400 10 FILLER PIC X(05) VALUE '25867'. DATEUTIL 176500 10 FILLER PIC X(05) VALUE '25871'. DATEUTIL 176600 10 FILLER PIC X(05) VALUE '25882'. DATEUTIL 176700 10 FILLER PIC X(05) VALUE '25894'. DATEUTIL 176800 10 FILLER PIC X(05) VALUE '25905'. DATEUTIL 176900 10 FILLER PIC X(05) VALUE '25916'. DATEUTIL 177000 10 FILLER PIC X(05) VALUE '25927'. DATEUTIL 177100 10 FILLER PIC X(05) VALUE '25932'. DATEUTIL 177200 10 FILLER PIC X(05) VALUE '25943'. DATEUTIL 177300 10 FILLER PIC X(05) VALUE '25954'. DATEUTIL 177400 10 FILLER PIC X(05) VALUE '25965'. DATEUTIL 177500 10 FILLER PIC X(05) VALUE '25977'. DATEUTIL 177600 10 FILLER PIC X(05) VALUE '25981'. DATEUTIL 177700 10 FILLER PIC X(05) VALUE '25992'. DATEUTIL 177800 10 FILLER PIC X(05) VALUE '26003'. DATEUTIL 177900 DATEUTIL 178000 05 T-YEARDAY-TABLE REDEFINES T-YEARDAY-TABLE-AREA DATEUTIL 178100 OCCURS 1001 TIMES DATEUTIL 178200 ASCENDING KEY IS T-YEARDAY-YEAR DATEUTIL 178300 INDEXED BY T-YEARDAY-NDX. DATEUTIL 178400 10 T-YEARDAY-YEAR PIC X(04). DATEUTIL 178500 10 T-YEARDAY-DAY PIC X(01). DATEUTIL 178600 DATEUTIL 178700 05 T-MON-TABLE-AREA. DATEUTIL 178800 10 FILLER PIC X(21) VALUE '001031001031JANUARY '. DATEUTIL 178900 10 FILLER PIC X(21) VALUE '032059032060FEBRUARY '. DATEUTIL 179000 10 FILLER PIC X(21) VALUE '060090061091MARCH '. DATEUTIL 179100 10 FILLER PIC X(21) VALUE '091120092121APRIL '. DATEUTIL 179200 10 FILLER PIC X(21) VALUE '121151122152MAY '. DATEUTIL 179300 10 FILLER PIC X(21) VALUE '152181153182JUNE '. DATEUTIL 179400 10 FILLER PIC X(21) VALUE '182212183213JULY '. DATEUTIL 179500 10 FILLER PIC X(21) VALUE '213243214244AUGUST '. DATEUTIL 179600 10 FILLER PIC X(21) VALUE '244273245274SEPTEMBER'. DATEUTIL 179700 10 FILLER PIC X(21) VALUE '274304275305OCTOBER '. DATEUTIL 179800 10 FILLER PIC X(21) VALUE '305334306335NOVEMBER '. DATEUTIL 179900 10 FILLER PIC X(21) VALUE '335365336366DECEMBER '. DATEUTIL 180000 DATEUTIL 180100 05 T-MON-TABLE REDEFINES T-MON-TABLE-AREA DATEUTIL 180200 OCCURS 12 TIMES DATEUTIL 180300 INDEXED BY T-MON-NDX. DATEUTIL 180400 10 T-MON-JUL-BEGIN PIC 9(03). DATEUTIL 180500 10 T-MON-JUL-END PIC 9(03). DATEUTIL 180600 10 T-MON-JUL-LEAP-BEGIN PIC 9(03). DATEUTIL 180700 10 T-MON-JUL-LEAP-END PIC 9(03). DATEUTIL 180800 10 T-MON-NAME. DATEUTIL 180900 15 T-MON-NAME-ABBR PIC X(03). DATEUTIL 181000 15 FILLER PIC X(06). DATEUTIL 181100 DATEUTIL 181200 05 T-DAY-TABLE-AREA. DATEUTIL 181300 10 FILLER PIC X(09) VALUE 'MONDAY '. DATEUTIL 181400 10 FILLER PIC X(09) VALUE 'TUESDAY '. DATEUTIL 181500 10 FILLER PIC X(09) VALUE 'WEDNESDAY'. DATEUTIL 181600 10 FILLER PIC X(09) VALUE 'THURSDAY '. DATEUTIL 181700 10 FILLER PIC X(09) VALUE 'FRIDAY '. DATEUTIL 181800 10 FILLER PIC X(09) VALUE 'SATURDAY '. DATEUTIL 181900 10 FILLER PIC X(09) VALUE 'SUNDAY '. DATEUTIL 182000 DATEUTIL 182100 05 T-DAY-TABLE REDEFINES T-DAY-TABLE-AREA DATEUTIL 182200 OCCURS 7 TIMES DATEUTIL 182300 INDEXED BY T-DAY-NDX. DATEUTIL 182400 10 T-DAY-NAME. DATEUTIL 182500 15 T-DAY-NAME-ABBR PIC X(02). DATEUTIL 182600 15 FILLER PIC X(07). DATEUTIL 182700/**************************************************************** DATEUTIL 182800* L I N K A G E S E C T I O N * DATEUTIL 182900***************************************************************** DATEUTIL 183000 LINKAGE SECTION. DATEUTIL 183100 01 L-PARM. DATEUTIL 183200 COPY DATEUTIL. DATEUTIL 183300 10 FILLER REDEFINES DU-DATE-2-FORMAT DATEUTIL 183400 OCCURS 20 TIMES DATEUTIL 183500 INDEXED BY L-FORMAT-NDX. DATEUTIL 183600 15 L-FORMAT-BYTE PIC X(01). DATEUTIL 183700 05 FILLER REDEFINES DATEUTIL-WORK-AREA. DATEUTIL 183800 10 FILLER PIC X(02). DATEUTIL 183900 10 L-ISPF-FUNCTION PIC X(04). DATEUTIL 184000 88 L-CALLED-FROM-ISPF VALUE 'ISPF'. DATEUTIL 184100 10 FILLER PIC X(122). DATEUTIL 184200 PROCEDURE DIVISION USING L-PARM. DATEUTIL 184300***************************************************************** DATEUTIL 184400* P R O C E D U R E D I V I S I O N * DATEUTIL 184500***************************************************************** DATEUTIL 184600***************************************************************** DATEUTIL 184700* S0000-CONTROL * DATEUTIL 184800* THIS SECTION CONTROLS THE MAIN PROCESSING OF THE PROGRAM. * DATEUTIL 184900***************************************************************** DATEUTIL 185000 S0000-CONTROL SECTION. DATEUTIL 185100 DATEUTIL 185200 PERFORM S1000-INITIALIZATION. DATEUTIL 185300 DATEUTIL 185400 PERFORM S2000-MAINLINE. DATEUTIL 185500 DATEUTIL 185600 PERFORM S3000-FINALIZATION. DATEUTIL 185700 DATEUTIL 185800 S0000-EXIT. DATEUTIL 185900 EXIT. DATEUTIL 186000/**************************************************************** DATEUTIL 186100* S1000-INITIALIZATION * DATEUTIL 186200* THIS SECTION DEALS WITH THE INPUT PASSED BY THE USER. IF THE * DATEUTIL 186300* PROGRAM IS BEING CALLED FROM AN ISPF ENVIRONMENT, THE ISPF * DATEUTIL 186400* INITIALIZATION PROCESS IS INVOKED. THE INPUT DATE IS PARSED * DATEUTIL 186500* OR THE SYSTEM DATE IS RETRIEVED AS THE INPUT DATE. * DATEUTIL 186600***************************************************************** DATEUTIL 186700 S1000-INITIALIZATION SECTION. DATEUTIL 186800 DATEUTIL 186900 INITIALIZE W-RETURN-CODE. DATEUTIL 187000 DATEUTIL 187100 IF L-CALLED-FROM-ISPF DATEUTIL 187200 PERFORM S1100-ISPF-INITIALIZATION DATEUTIL 187300 END-IF. DATEUTIL 187410 DATEUTIL 187500 IF DU-FUNCTION = 'SYSTEM' OR DU-DATE-1 = SPACES DATEUTIL 187600 PERFORM S1200-GET-SYSTEM-DATE DATEUTIL 187700 ELSE DATEUTIL 187800 IF DU-DATE-1-VALID-CODE DATEUTIL 188000 MOVE DU-DATE-1-FORMAT-CODE TO W-FORMAT-CODE DATEUTIL 188100 PERFORM S1300-CONVERT-FORMAT-CODE DATEUTIL 188200 ELSE DATEUTIL 188300 MOVE DU-DAY-1-FORMAT TO W-HOLD-DAY-FORMAT DATEUTIL 188400 MOVE DU-MONTH-1-FORMAT TO W-HOLD-MONTH-FORMAT DATEUTIL 188500 MOVE DU-YEAR-1-FORMAT TO W-HOLD-YEAR-FORMAT DATEUTIL 188600 MOVE DU-DATE-1-FORMAT TO W-HOLD-DATE-FORMAT DATEUTIL 188700 END-IF DATEUTIL 188701 MOVE DU-DATE-1 TO W-HOLD-DATE DATEUTIL 188710 IF DU-YEAR-1-SWITCH IS NUMERIC DATEUTIL 188720 IF DU-YEAR-1-SWITCH > 0 DATEUTIL 188721 IF DU-YEAR-2-SWITCH IS NUMERIC DATEUTIL 188722 IF DU-YEAR-2-SWITCH = 0 DATEUTIL 188730 MOVE W-SWITCH-YEAR TO DU-YEAR-2-SWITCH DATEUTIL 188731 END-IF DATEUTIL 188732 ELSE DATEUTIL 188734 MOVE W-SWITCH-YEAR TO DU-YEAR-2-SWITCH DATEUTIL 188735 END-IF DATEUTIL 188736 MOVE DU-YEAR-1-SWITCH TO W-SWITCH-YEAR DATEUTIL 188740 END-IF DATEUTIL 188750 END-IF DATEUTIL 188900 PERFORM S9100-PARSE-DATE DATEUTIL 189000 PERFORM S9200-CONVERT-TO-JULIAN DATEUTIL 189100 END-IF. DATEUTIL 189200 DATEUTIL 189300 IF DU-DATE-2 > SPACES DATEUTIL 189400 IF DU-FUNCTION = SPACES DATEUTIL 189500 MOVE 'BETWEEN' TO DU-FUNCTION DATEUTIL 189600 END-IF DATEUTIL 189700 END-IF. DATEUTIL 189800 DATEUTIL 189900 IF DU-FUNCTION = SPACES OR 'SYSTEM' DATEUTIL 190000 MOVE 'CONVERT' TO DU-FUNCTION DATEUTIL 190100 END-IF. DATEUTIL 190200 DATEUTIL 190300 S1000-EXIT. DATEUTIL 190400 EXIT. DATEUTIL 190500/**************************************************************** DATEUTIL 190600* S1100-ISPF-INITIALIZATION * DATEUTIL 190700* THIS SECTION INVOKES ISPF SERVICES TO ESTABLISH ADDRESSABILITY* DATEUTIL 190800* TO ISPF OF CERTAIN WORKING STORAGE AREAS. IT THEN INVOKES * DATEUTIL 190900* PROCESSING TO RETRIEVE THE ISPF VARIABLES INTO THE WORKING * DATEUTIL 191000* STORAGE AREAS. * DATEUTIL 191100***************************************************************** DATEUTIL 191200 S1100-ISPF-INITIALIZATION SECTION. DATEUTIL 191300 DATEUTIL 191400 SET S-INVOKED-FROM-ISPF TO TRUE. DATEUTIL 191500 DATEUTIL 191600 CALL C-ISPF USING C-CONTROL C-ERRORS-OPTION C-RETURN-OPTION. DATEUTIL 191700 DATEUTIL 191800 CALL C-ISPF USING C-VDEFINE C-ISPF-VARIABLE-NAMES, DATEUTIL 191900 DATEUTIL-WORK-AREA, DATEUTIL 192000 C-ISPF-VARIABLE-FORMATS, DATEUTIL 192100 C-ISPF-VARIABLE-LENGTHS, DATEUTIL 192200 C-LIST-OPTION. DATEUTIL 192300 DATEUTIL 192400 IF RETURN-CODE > 4 DATEUTIL 192500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 192600 STRING 'DU2000-ISPF "VDEFINE" FAILED. PROGRAM OR ' DATEUTIL 192700 'ISPF PROBLEM. ' DATEUTIL 192800 DELIMITED BY SIZE DATEUTIL 192900 INTO DATEUTIL-MESSAGE DATEUTIL 193000 MOVE +2000 TO W-RETURN-CODE DATEUTIL 193100 PERFORM S3000-FINALIZATION DATEUTIL 193200 ELSE DATEUTIL 193300 MOVE C-VGET TO W-ISPF-SERVICE DATEUTIL 193400 MOVE SPACES TO DATEUTIL-WORK-AREA DATEUTIL 193500 PERFORM S9300-ISPF-VGET-VPUT DATEUTIL 193600 IF DU-FUNCTION = 'INCREMENT' OR 'DECREMENT' DATEUTIL 193700 MOVE DU-NUMBER TO W-NUMBER-ARRAY DATEUTIL 193800 SET W-NUM-NDX2 TO +6 DATEUTIL 193900 PERFORM VARYING W-NUM-NDX1 FROM +6 BY -1 DATEUTIL 194000 UNTIL W-NUM-NDX1 < +1 DATEUTIL 194100 EVALUATE TRUE DATEUTIL 194200 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 194300 IS NUMERIC DATEUTIL 194400 MOVE W-NUMBER-ARRAY-BYTE (W-NUM-NDX1)DATEUTIL 194500 TO W-NUMBER-ARRAY-BYTE (W-NUM-NDX2)DATEUTIL 194600 SET W-NUM-NDX2 DOWN BY +1 DATEUTIL 194700 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 194800 = ' ' DATEUTIL 194900 CONTINUE DATEUTIL 195000 WHEN W-NUMBER-ARRAY-BYTE (W-NUM-NDX1) DATEUTIL 195100 = LOW-VALUES DATEUTIL 195200 CONTINUE DATEUTIL 195300 WHEN OTHER DATEUTIL 195400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 195500 STRING 'DU2037-THE INCREMENT OR ' DATEUTIL 195600 'DECREMENT NUMBER MUST BE ' DATEUTIL 195700 'A POSITIVE INTEGER VALUE.' DATEUTIL 195800 DELIMITED BY SIZE DATEUTIL 195900 INTO DATEUTIL-MESSAGE DATEUTIL 196000 MOVE +2037 TO W-RETURN-CODE DATEUTIL 196100 PERFORM S3000-FINALIZATION DATEUTIL 196200 END-EVALUATE DATEUTIL 196300 END-PERFORM DATEUTIL 196400 PERFORM VARYING W-NUM-NDX2 FROM W-NUM-NDX2 BY -1 DATEUTIL 196500 UNTIL W-NUM-NDX2 < +1 DATEUTIL 196600 MOVE '0' TO W-NUMBER-ARRAY-BYTE (W-NUM-NDX2) DATEUTIL 196700 END-PERFORM DATEUTIL 196800 MOVE W-HOLD-NUMBER TO DU-NUMBER DATEUTIL 196900 END-IF DATEUTIL 197000 END-IF. DATEUTIL 197100 DATEUTIL 197120 IF DU-YEAR-1-SWITCH-A = '1 ' OR DATEUTIL 197130 '2 ' OR DATEUTIL 197140 '3 ' OR DATEUTIL 197150 '4 ' OR DATEUTIL 197160 '5 ' OR DATEUTIL 197170 '6 ' OR DATEUTIL 197180 '7 ' OR DATEUTIL 197190 '8 ' OR DATEUTIL 197191 '9 ' DATEUTIL 197192 INSPECT DU-YEAR-1-SWITCH-A REPLACING ALL SPACES BY ZEROS DATEUTIL 197193 COMPUTE DU-YEAR-1-SWITCH = DU-YEAR-1-SWITCH / 10 DATEUTIL 197194 END-IF. DATEUTIL 197195 DATEUTIL 197197 IF DU-DATE-1-FORMAT-CODE-A = '1 ' OR DATEUTIL 197198 '2 ' OR DATEUTIL 197199 '3 ' OR DATEUTIL 197200 '4 ' OR DATEUTIL 197201 '5 ' OR DATEUTIL 197202 '6 ' OR DATEUTIL 197203 '7 ' OR DATEUTIL 197204 '8 ' OR DATEUTIL 197205 '9 ' DATEUTIL 197206 INSPECT DU-DATE-1-FORMAT-CODE-A DATEUTIL 197207 REPLACING ALL SPACES BY ZEROS DATEUTIL 197208 COMPUTE DU-DATE-1-FORMAT-CODE = DATEUTIL 197209 DU-DATE-1-FORMAT-CODE / 10 DATEUTIL 197210 END-IF. DATEUTIL 197211 DATEUTIL 197213 IF DU-YEAR-2-SWITCH-A = '1 ' OR DATEUTIL 197214 '2 ' OR DATEUTIL 197215 '3 ' OR DATEUTIL 197216 '4 ' OR DATEUTIL 197217 '5 ' OR DATEUTIL 197218 '6 ' OR DATEUTIL 197219 '7 ' OR DATEUTIL 197220 '8 ' OR DATEUTIL 197221 '9 ' DATEUTIL 197222 INSPECT DU-YEAR-2-SWITCH-A REPLACING ALL SPACES BY ZEROS DATEUTIL 197223 COMPUTE DU-YEAR-2-SWITCH = DU-YEAR-2-SWITCH / 10 DATEUTIL 197224 END-IF. DATEUTIL 197225 DATEUTIL 197227 IF DU-DATE-2-FORMAT-CODE-A = '1 ' OR DATEUTIL 197228 '2 ' OR DATEUTIL 197229 '3 ' OR DATEUTIL 197230 '4 ' OR DATEUTIL 197231 '5 ' OR DATEUTIL 197232 '6 ' OR DATEUTIL 197233 '7 ' OR DATEUTIL 197234 '8 ' OR DATEUTIL 197235 '9 ' DATEUTIL 197236 INSPECT DU-DATE-2-FORMAT-CODE-A DATEUTIL 197237 REPLACING ALL SPACES BY ZEROS DATEUTIL 197238 COMPUTE DU-DATE-2-FORMAT-CODE = DATEUTIL 197239 DU-DATE-2-FORMAT-CODE / 10 DATEUTIL 197240 END-IF. DATEUTIL 197241 DATEUTIL 197250 S1100-EXIT. DATEUTIL 197300 EXIT. DATEUTIL 197400/**************************************************************** DATEUTIL 197500* S1200-GET-SYSTEM-DATE * DATEUTIL 197600* THIS SECTION RETRIEVES THE SYSTEM DATE AND SETS DEFAULT * DATEUTIL 197700* FUNCTIONS IF NECESSARY. IT ALSO SETS FORMAT FIELDS BASED ON * DATEUTIL 197800* THE SYSTEM DATE BEING A JULIAN DATE. * DATEUTIL 197900***************************************************************** DATEUTIL 198000 S1200-GET-SYSTEM-DATE SECTION. DATEUTIL 198100 DATEUTIL 198200 ACCEPT W-SYSDATE FROM DAY. DATEUTIL 198300 DATEUTIL 198310 IF W-SYSDATE-DECADE < 90 DATEUTIL 198311 MOVE '20' TO W-JULIAN-CENTURY DATEUTIL 198312 W-WORK-CENTURY DATEUTIL 198320 ELSE DATEUTIL 198400 MOVE '19' TO W-JULIAN-CENTURY DATEUTIL 198500 W-WORK-CENTURY DATEUTIL 198510 END-IF. DATEUTIL 198520 DATEUTIL 198600 MOVE W-SYSDATE-DDD TO W-JULIAN-DDD DATEUTIL 198700 W-WORK-DDD. DATEUTIL 198710 DATEUTIL 198800 MOVE W-SYSDATE-DECADE TO W-JULIAN-DECADE DATEUTIL 198900 W-WORK-DECADE. DATEUTIL 198910 DATEUTIL 199000 MOVE W-WORK-JULIAN TO W-WORK-ARRAY DATEUTIL 199100 DU-DATE-1. DATEUTIL 199110 DATEUTIL 199200 MOVE 'DDD' TO DU-DAY-1-FORMAT. DATEUTIL 199300 MOVE SPACES TO DU-MONTH-1-FORMAT. DATEUTIL 199400 MOVE 'YYYY' TO DU-YEAR-1-FORMAT. DATEUTIL 199500 MOVE 'YD' TO DU-DATE-1-FORMAT. DATEUTIL 199600 DATEUTIL 199700 S1200-EXIT. DATEUTIL 199800 EXIT. DATEUTIL 199900/*****************************************************************DATEUTIL 200000* S1300-CONVERT-FORMAT-CODE *DATEUTIL 200100* THIS SECTION CONVERTS AN INPUT FORMAT "CODE" INTO ITS REAL *DATEUTIL 200200* FORMAT VALUES IN THE W-HOLD FIELDS. *DATEUTIL 200300******************************************************************DATEUTIL 200400 S1300-CONVERT-FORMAT-CODE SECTION. DATEUTIL 200500 DATEUTIL 200600 EVALUATE W-FORMAT-CODE DATEUTIL 200700 WHEN 1 DATEUTIL 200800 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DATEUTIL 200900 WHEN 2 DATEUTIL 201000 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DATEUTIL 201100 WHEN 3 DATEUTIL 201200 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DATEUTIL 201300 WHEN 4 DATEUTIL 201400 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DATEUTIL 201500 WHEN 5 DATEUTIL 201600 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DATEUTIL 201700 WHEN 6 DATEUTIL 201800 MOVE 'M-D-Y' TO W-HOLD-DATE-FORMAT DATEUTIL 201900 WHEN 7 DATEUTIL 202000 MOVE 'M.D.Y' TO W-HOLD-DATE-FORMAT DATEUTIL 202100 WHEN 8 DATEUTIL 202200 MOVE 'M/D/Y' TO W-HOLD-DATE-FORMAT DATEUTIL 202300 WHEN 9 DATEUTIL 202400 MOVE 'M D Y' TO W-HOLD-DATE-FORMAT DATEUTIL 202500 WHEN 10 DATEUTIL 202600 MOVE 'MDY' TO W-HOLD-DATE-FORMAT DATEUTIL 202700 WHEN 11 DATEUTIL 202800 MOVE 'Y-D' TO W-HOLD-DATE-FORMAT DATEUTIL 202900 WHEN 12 DATEUTIL 203000 MOVE 'Y.D' TO W-HOLD-DATE-FORMAT DATEUTIL 203100 WHEN 13 DATEUTIL 203200 MOVE 'Y/D' TO W-HOLD-DATE-FORMAT DATEUTIL 203300 WHEN 14 DATEUTIL 203400 MOVE 'Y D' TO W-HOLD-DATE-FORMAT DATEUTIL 203500 WHEN 15 DATEUTIL 203600 MOVE 'YD' TO W-HOLD-DATE-FORMAT DATEUTIL 203700 WHEN 16 DATEUTIL 203800 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DATEUTIL 203900 WHEN 17 DATEUTIL 204000 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DATEUTIL 204100 WHEN 18 DATEUTIL 204200 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DATEUTIL 204300 WHEN 19 DATEUTIL 204400 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DATEUTIL 204500 WHEN 20 DATEUTIL 204600 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DATEUTIL 204700 WHEN 21 DATEUTIL 204800 MOVE 'M-D-Y' TO W-HOLD-DATE-FORMAT DATEUTIL 204900 WHEN 22 DATEUTIL 205000 MOVE 'M.D.Y' TO W-HOLD-DATE-FORMAT DATEUTIL 205100 WHEN 23 DATEUTIL 205200 MOVE 'M/D/Y' TO W-HOLD-DATE-FORMAT DATEUTIL 205300 WHEN 24 DATEUTIL 205400 MOVE 'M D Y' TO W-HOLD-DATE-FORMAT DATEUTIL 205500 WHEN 25 DATEUTIL 205600 MOVE 'MDY' TO W-HOLD-DATE-FORMAT DATEUTIL 205700 WHEN 26 DATEUTIL 205800 MOVE 'Y-D' TO W-HOLD-DATE-FORMAT DATEUTIL 205900 WHEN 27 DATEUTIL 206000 MOVE 'Y.D' TO W-HOLD-DATE-FORMAT DATEUTIL 206100 WHEN 28 DATEUTIL 206200 MOVE 'Y/D' TO W-HOLD-DATE-FORMAT DATEUTIL 206300 WHEN 29 DATEUTIL 206400 MOVE 'Y D' TO W-HOLD-DATE-FORMAT DATEUTIL 206500 WHEN 30 DATEUTIL 206600 MOVE 'YD' TO W-HOLD-DATE-FORMAT DATEUTIL 206700 WHEN 31 DATEUTIL 206800 MOVE 'D-M-Y' TO W-HOLD-DATE-FORMAT DATEUTIL 206900 WHEN 32 DATEUTIL 207000 MOVE 'D.M.Y' TO W-HOLD-DATE-FORMAT DATEUTIL 207100 WHEN 33 DATEUTIL 207200 MOVE 'D/M/Y' TO W-HOLD-DATE-FORMAT DATEUTIL 207300 WHEN 34 DATEUTIL 207400 MOVE 'D M Y' TO W-HOLD-DATE-FORMAT DATEUTIL 207500 WHEN 35 DATEUTIL 207600 MOVE 'DMY' TO W-HOLD-DATE-FORMAT DATEUTIL 207700 WHEN 36 DATEUTIL 207800 MOVE 'D-M-Y' TO W-HOLD-DATE-FORMAT DATEUTIL 207900 WHEN 37 DATEUTIL 208000 MOVE 'D.M.Y' TO W-HOLD-DATE-FORMAT DATEUTIL 208100 WHEN 38 DATEUTIL 208200 MOVE 'D/M/Y' TO W-HOLD-DATE-FORMAT DATEUTIL 208300 WHEN 39 DATEUTIL 208400 MOVE 'D M Y' TO W-HOLD-DATE-FORMAT DATEUTIL 208500 WHEN 40 DATEUTIL 208600 MOVE 'DMY' TO W-HOLD-DATE-FORMAT DATEUTIL 208700 WHEN 41 DATEUTIL 208800 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DATEUTIL 208900 WHEN 42 DATEUTIL 209000 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DATEUTIL 209100 WHEN 43 DATEUTIL 209200 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DATEUTIL 209300 WHEN 44 DATEUTIL 209400 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DATEUTIL 209500 WHEN 45 DATEUTIL 209600 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DATEUTIL 209700 WHEN 46 DATEUTIL 209800 MOVE 'Y-M-D' TO W-HOLD-DATE-FORMAT DATEUTIL 209900 WHEN 47 DATEUTIL 210000 MOVE 'Y.M.D' TO W-HOLD-DATE-FORMAT DATEUTIL 210100 WHEN 48 DATEUTIL 210200 MOVE 'Y/M/D' TO W-HOLD-DATE-FORMAT DATEUTIL 210300 WHEN 49 DATEUTIL 210400 MOVE 'Y M D' TO W-HOLD-DATE-FORMAT DATEUTIL 210500 WHEN 50 DATEUTIL 210600 MOVE 'YMD' TO W-HOLD-DATE-FORMAT DATEUTIL 210700 WHEN 51 DATEUTIL 210800 MOVE 'M D, Y' TO W-HOLD-DATE-FORMAT DATEUTIL 210900 WHEN 52 DATEUTIL 211000 MOVE 'M D, Y' TO W-HOLD-DATE-FORMAT DATEUTIL 211100 WHEN 53 DATEUTIL 211200 MOVE 'D' TO W-HOLD-DATE-FORMAT DATEUTIL 211300 WHEN OTHER DATEUTIL 211400 STRING 'DU2038-INVALID FORMAT CODE PASSED. CODE ' DATEUTIL 211500 'PASSED WAS: ' DATEUTIL 211600 W-FORMAT-CODE DATEUTIL 211700 DELIMITED BY SIZE DATEUTIL 211800 INTO DATEUTIL-MESSAGE DATEUTIL 211900 MOVE +2038 TO W-RETURN-CODE DATEUTIL 212000 PERFORM S3000-FINALIZATION DATEUTIL 212100 END-EVALUATE. DATEUTIL 212200 DATEUTIL 212300 EVALUATE TRUE DATEUTIL 212400 WHEN W-YYYY-FORMAT DATEUTIL 212500 MOVE 'YYYY' TO W-HOLD-YEAR-FORMAT DATEUTIL 212600 WHEN W-YY-FORMAT DATEUTIL 212700 MOVE 'YY' TO W-HOLD-YEAR-FORMAT DATEUTIL 212800 WHEN OTHER DATEUTIL 212900 MOVE SPACES TO W-HOLD-YEAR-FORMAT DATEUTIL 213000 END-EVALUATE. DATEUTIL 213100 DATEUTIL 213200 EVALUATE TRUE DATEUTIL 213300 WHEN W-MM-FORMAT DATEUTIL 213400 MOVE 'MM' TO W-HOLD-MONTH-FORMAT DATEUTIL 213500 WHEN W-MMM-FORMAT DATEUTIL 213600 MOVE 'MMM' TO W-HOLD-MONTH-FORMAT DATEUTIL 213700 WHEN W-MONTH-FORMAT DATEUTIL 213800 MOVE 'MONTH' TO W-HOLD-MONTH-FORMAT DATEUTIL 213900 WHEN OTHER DATEUTIL 214000 MOVE SPACES TO W-HOLD-MONTH-FORMAT DATEUTIL 214100 END-EVALUATE. DATEUTIL 214200 DATEUTIL 214300 EVALUATE TRUE DATEUTIL 214400 WHEN W-DD-FORMAT DATEUTIL 214500 MOVE 'DD' TO W-HOLD-DAY-FORMAT DATEUTIL 214600 WHEN W-DDD-FORMAT DATEUTIL 214700 MOVE 'DDD' TO W-HOLD-DAY-FORMAT DATEUTIL 214800 WHEN W-DAY-FORMAT DATEUTIL 214900 MOVE 'DAY' TO W-HOLD-DAY-FORMAT DATEUTIL 215000 WHEN W-ZD-FORMAT DATEUTIL 215100 MOVE 'ZD' TO W-HOLD-DAY-FORMAT DATEUTIL 215200 WHEN OTHER DATEUTIL 215300 MOVE SPACES TO W-HOLD-DAY-FORMAT DATEUTIL 215400 END-EVALUATE. DATEUTIL 215500 DATEUTIL 215600 S1300-EXIT. DATEUTIL 215700 EXIT. DATEUTIL 215830/**************************************************************** DATEUTIL 215900* S2000-MAINLINE * DATEUTIL 216000* THIS SECTION DIRECTS THE PROCESSING TO PARTICULAR SUB-ROUTINES* DATEUTIL 216100* BASED ON THE FUNCTION WHICH THE USER REQUESTED. * DATEUTIL 216200***************************************************************** DATEUTIL 216300 S2000-MAINLINE SECTION. DATEUTIL 216400 DATEUTIL 216500 EVALUATE TRUE DATEUTIL 216600 WHEN DU-FUNCTION = 'CONVERT' DATEUTIL 216700 PERFORM S4000-CONVERT DATEUTIL 216800 WHEN DU-FUNCTION = 'BETWEEN' DATEUTIL 216900 PERFORM S5000-BETWEEN DATEUTIL 217000 WHEN DU-FUNCTION = 'INCREMENT' DATEUTIL 217100 PERFORM S6000-INCREMENT DATEUTIL 217200 WHEN DU-FUNCTION = 'DECREMENT' DATEUTIL 217300 PERFORM S7000-DECREMENT DATEUTIL 217400 WHEN OTHER DATEUTIL 217500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 217600 STRING 'DU2001-FUNCTION COULD NOT BE DETERMINED ' DATEUTIL 217700 'OR FUNCTION SPECIFIED WAS INVALID.' DATEUTIL 217800 DELIMITED BY SIZE DATEUTIL 217900 INTO DATEUTIL-MESSAGE DATEUTIL 218000 MOVE +2001 TO W-RETURN-CODE DATEUTIL 218100 PERFORM S3000-FINALIZATION DATEUTIL 218200 END-EVALUATE. DATEUTIL 218300 DATEUTIL 218400 S2000-EXIT. DATEUTIL 218500 EXIT. DATEUTIL 218600/**************************************************************** DATEUTIL 218700* S3000-FINALIZATION * DATEUTIL 218800* THIS SECTION DOES THREE THINGS. * DATEUTIL 218900* FIRST IT RETURNS THE RESULTS TO THE ISPF SHARED VARIABLE POOL * DATEUTIL 219000* IF THIS IS AN ISPF INVOKED PROCESS. * DATEUTIL 219100* SECOND, IT SETS THE RETURN CODE FOR THE PROGRAM. * DATEUTIL 219200* THIRD, IT RETURNS CONTROL TO THE CALLING PROGRAM. * DATEUTIL 219300***************************************************************** DATEUTIL 219400 S3000-FINALIZATION SECTION. DATEUTIL 219500 DATEUTIL 219600 IF S-INVOKED-FROM-ISPF DATEUTIL 219700 MOVE C-VPUT TO W-ISPF-SERVICE DATEUTIL 219800 PERFORM S9300-ISPF-VGET-VPUT DATEUTIL 219900 END-IF. DATEUTIL 220000 DATEUTIL 220100 MOVE W-RETURN-CODE TO RETURN-CODE. DATEUTIL 220200 DATEUTIL 220300 GOBACK. DATEUTIL 220400 DATEUTIL 220500 S3000-EXIT. DATEUTIL 220600 EXIT. DATEUTIL 220700/**************************************************************** DATEUTIL 220800* S4000-CONVERT * DATEUTIL 220900* THIS PROCESS CONVERTS THE JULIAN WORK DATE INTO THE FORMAT * DATEUTIL 221000* WHICH THE USER WANTS FOR DATE 2. * DATEUTIL 221100***************************************************************** DATEUTIL 221200 S4000-CONVERT SECTION. DATEUTIL 221300 DATEUTIL 221310**** DATEUTIL 221400**** SEE IF THE DATE 2 FORMAT IS ONE OF THE AUTOMATIC ONES **** DATEUTIL 221410**** DATEUTIL 221411 IF DU-DATE-2-VALID-CODE DATEUTIL 221413 MOVE DU-DATE-2-FORMAT-CODE TO W-FORMAT-CODE DATEUTIL 221418 PERFORM S1300-CONVERT-FORMAT-CODE DATEUTIL 221419 MOVE W-HOLD-DAY-FORMAT TO DU-DAY-2-FORMAT DATEUTIL 221420 MOVE W-HOLD-MONTH-FORMAT TO DU-MONTH-2-FORMAT DATEUTIL 221421 MOVE W-HOLD-YEAR-FORMAT TO DU-YEAR-2-FORMAT DATEUTIL 221422 MOVE W-HOLD-DATE-FORMAT TO DU-DATE-2-FORMAT DATEUTIL 221430 END-IF. DATEUTIL 221431 DATEUTIL 221432**** DATEUTIL 221433**** MAKE SURE WE HAVE THE NEEDED FORMAT 2 COMPONENTS **** DATEUTIL 221440**** DATEUTIL 221500 IF (DU-DAY-2-FORMAT = SPACES AND DATEUTIL 221600 DU-MONTH-2-FORMAT = SPACES AND DATEUTIL 221700 DU-YEAR-2-FORMAT = SPACES) OR DATEUTIL 221800 (DU-DATE-2-FORMAT = SPACES) DATEUTIL 221900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 222000 STRING 'DU2036-AT LEAST ONE "DAY", "MONTH", OR "YEAR" ' DATEUTIL 222100 ' FORMAT COMPONENT AND ONE "DATE" FORMAT MUST ' DATEUTIL 222200 ' SPECIFIED FOR "DATE 2".' DATEUTIL 222300 DELIMITED BY SIZE DATEUTIL 222400 INTO DATEUTIL-MESSAGE DATEUTIL 222500 MOVE +2036 TO W-RETURN-CODE DATEUTIL 222600 PERFORM S3000-FINALIZATION DATEUTIL 222700 END-IF. DATEUTIL 222800 DATEUTIL 222810**** DATEUTIL 222900**** INITIALIZE THE WORK DATES **** DATEUTIL 222910**** DATEUTIL 223000 MOVE SPACES TO W-WORK-MONTH DATEUTIL 223100 W-WORK-DAY DATEUTIL 223200 W-WORK-YEAR. DATEUTIL 223300 DATEUTIL 223310**** DATEUTIL 223400**** LOAD THE DAY COMPONENT INTO THE WORK DATE **** DATEUTIL 223410**** DATEUTIL 223500 EVALUATE DU-DAY-2-FORMAT DATEUTIL 223600 WHEN 'DDD' DATEUTIL 223700 MOVE W-JULIAN-DDD TO W-WORK-DDD DATEUTIL 223800 MOVE +3 TO W-DAY-LENGTH DATEUTIL 223900 WHEN 'ZZD' DATEUTIL 224000 MOVE W-JULIAN-DDD TO W-WORK-DDD DATEUTIL 224100 MOVE +3 TO W-DAY-LENGTH DATEUTIL 224200 WHEN 'DD' DATEUTIL 224300 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 224400 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 224500 SET T-MON-NDX TO +1 DATEUTIL 224600 IF S-IS-A-LEAP-YEAR DATEUTIL 224700 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 224800 AT END PERFORM 1 TIMES DATEUTIL 224900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 225000 STRING 'DU2002-"' W-JULIAN-DDD DATEUTIL 225100 '" IS NOT A VALID DAY IN ' DATEUTIL 225200 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 225300 DELIMITED BY SIZE DATEUTIL 225400 INTO DATEUTIL-MESSAGE DATEUTIL 225500 MOVE +2002 TO W-RETURN-CODE DATEUTIL 225600 PERFORM S3000-FINALIZATION DATEUTIL 225700 END-PERFORM DATEUTIL 225800 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 225900 W-JULIAN-DDD OR DATEUTIL 226000 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 226100 W-JULIAN-DDD) AND DATEUTIL 226200 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 226300 W-JULIAN-DDD OR DATEUTIL 226400 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 226500 W-JULIAN-DDD) DATEUTIL 226600 COMPUTE W-WORK-DD = DATEUTIL 226700 W-JULIAN-DDD DATEUTIL 226800 - T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 226900 + 1 DATEUTIL 227000 END-SEARCH DATEUTIL 227100 ELSE DATEUTIL 227200 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 227300 AT END PERFORM 1 TIMES DATEUTIL 227400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 227500 STRING 'DU2003-"' W-JULIAN-DDD DATEUTIL 227600 '" IS NOT A VALID DAY IN ' DATEUTIL 227700 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 227800 DELIMITED BY SIZE DATEUTIL 227900 INTO DATEUTIL-MESSAGE DATEUTIL 228000 MOVE +2003 TO W-RETURN-CODE DATEUTIL 228100 PERFORM S3000-FINALIZATION DATEUTIL 228200 END-PERFORM DATEUTIL 228300 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 228400 W-JULIAN-DDD OR DATEUTIL 228500 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 228600 W-JULIAN-DDD) AND DATEUTIL 228700 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 228800 W-JULIAN-DDD OR DATEUTIL 228900 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 229000 W-JULIAN-DDD) DATEUTIL 229100 COMPUTE W-WORK-DD = DATEUTIL 229200 W-JULIAN-DDD DATEUTIL 229300 - T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 229400 + 1 DATEUTIL 229500 END-SEARCH DATEUTIL 229600 END-IF DATEUTIL 229700 MOVE +2 TO W-DAY-LENGTH DATEUTIL 229800 WHEN 'ZD' DATEUTIL 229900 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 230000 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 230100 SET T-MON-NDX TO +1 DATEUTIL 230200 IF S-IS-A-LEAP-YEAR DATEUTIL 230300 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 230400 AT END PERFORM 1 TIMES DATEUTIL 230500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 230600 STRING 'DU2002-"' W-JULIAN-DDD DATEUTIL 230700 '" IS NOT A VALID DAY IN ' DATEUTIL 230800 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 230900 DELIMITED BY SIZE DATEUTIL 231000 INTO DATEUTIL-MESSAGE DATEUTIL 231100 MOVE +2002 TO W-RETURN-CODE DATEUTIL 231200 PERFORM S3000-FINALIZATION DATEUTIL 231300 END-PERFORM DATEUTIL 231400 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 231500 W-JULIAN-DDD OR DATEUTIL 231600 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 231700 W-JULIAN-DDD) AND DATEUTIL 231800 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 231900 W-JULIAN-DDD OR DATEUTIL 232000 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 232100 W-JULIAN-DDD) DATEUTIL 232200 COMPUTE W-WORK-DD = DATEUTIL 232300 W-JULIAN-DDD DATEUTIL 232400 - T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 232500 + 1 DATEUTIL 232600 END-SEARCH DATEUTIL 232700 ELSE DATEUTIL 232800 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 232900 AT END PERFORM 1 TIMES DATEUTIL 233000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 233100 STRING 'DU2003-"' W-JULIAN-DDD DATEUTIL 233200 '" IS NOT A VALID DAY IN ' DATEUTIL 233300 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 233400 DELIMITED BY SIZE DATEUTIL 233500 INTO DATEUTIL-MESSAGE DATEUTIL 233600 MOVE +2003 TO W-RETURN-CODE DATEUTIL 233700 PERFORM S3000-FINALIZATION DATEUTIL 233800 END-PERFORM DATEUTIL 233900 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 234000 W-JULIAN-DDD OR DATEUTIL 234100 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 234200 W-JULIAN-DDD) AND DATEUTIL 234300 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 234400 W-JULIAN-DDD OR DATEUTIL 234500 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 234600 W-JULIAN-DDD) DATEUTIL 234700 COMPUTE W-WORK-DD = DATEUTIL 234800 W-JULIAN-DDD DATEUTIL 234900 - T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 235000 + 1 DATEUTIL 235100 END-SEARCH DATEUTIL 235200 END-IF DATEUTIL 235300 MOVE +2 TO W-DAY-LENGTH DATEUTIL 235400 WHEN 'DAY' DATEUTIL 235500 COMPUTE W-NUMBER = W-JULIAN-DDD - 1 DATEUTIL 235600 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 235700 SEARCH ALL T-YEARDAY-TABLE DATEUTIL 235800 AT END PERFORM 1 TIMES DATEUTIL 235900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 236000 STRING 'DU2004-"' W-WORK-YEAR DATEUTIL 236100 '" IS NOT IN THE RANGE OF ' DATEUTIL 236200 '"1600" THRU "2600".' DATEUTIL 236300 DELIMITED BY SIZE DATEUTIL 236400 INTO DATEUTIL-MESSAGE DATEUTIL 236500 MOVE +2004 TO W-RETURN-CODE DATEUTIL 236600 PERFORM S3000-FINALIZATION DATEUTIL 236700 END-PERFORM DATEUTIL 236800 WHEN T-YEARDAY-YEAR (T-YEARDAY-NDX) = DATEUTIL 236900 W-JULIAN-YEAR DATEUTIL 237000 MOVE T-YEARDAY-DAY (T-YEARDAY-NDX) TO DATEUTIL 237100 W-WORK-D DATEUTIL 237200 END-SEARCH DATEUTIL 237300 PERFORM W-NUMBER TIMES DATEUTIL 237400 ADD 1 TO W-WORK-D DATEUTIL 237500 IF W-WORK-D > 7 DATEUTIL 237600 SUBTRACT 7 FROM W-WORK-D DATEUTIL 237700 END-IF DATEUTIL 237800 END-PERFORM DATEUTIL 237900 SET T-DAY-NDX TO W-WORK-D DATEUTIL 238000 MOVE T-DAY-NAME (T-DAY-NDX) TO W-WORK-DAY DATEUTIL 238100 PERFORM VARYING W-DAY-NDX1 FROM +9 BY -1 DATEUTIL 238200 UNTIL W-DAY-ARRAY-BYTE (W-DAY-NDX1) > SPACE DATEUTIL 238300 END-PERFORM DATEUTIL 238400 SET W-DAY-LENGTH TO W-DAY-NDX1 DATEUTIL 238500 WHEN 'DA' DATEUTIL 238600 COMPUTE W-NUMBER = W-JULIAN-DDD - 1 DATEUTIL 238700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 238800 SEARCH ALL T-YEARDAY-TABLE DATEUTIL 238900 AT END PERFORM 1 TIMES DATEUTIL 239000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 239100 STRING 'DU2005-"' W-WORK-YEAR DATEUTIL 239200 '" IS NOT IN THE RANGE OF ' DATEUTIL 239300 '"1600" THRU "2600".' DATEUTIL 239400 DELIMITED BY SIZE DATEUTIL 239500 INTO DATEUTIL-MESSAGE DATEUTIL 239600 MOVE +2005 TO W-RETURN-CODE DATEUTIL 239700 PERFORM S3000-FINALIZATION DATEUTIL 239800 END-PERFORM DATEUTIL 239900 WHEN T-YEARDAY-YEAR (T-YEARDAY-NDX) = DATEUTIL 240000 W-JULIAN-YEAR DATEUTIL 240100 MOVE T-YEARDAY-DAY (T-YEARDAY-NDX) TO DATEUTIL 240200 W-WORK-D DATEUTIL 240300 END-SEARCH DATEUTIL 240400 PERFORM W-NUMBER TIMES DATEUTIL 240500 ADD 1 TO W-WORK-D DATEUTIL 240600 IF W-WORK-D > 7 DATEUTIL 240700 SUBTRACT 7 FROM W-WORK-D DATEUTIL 240800 END-IF DATEUTIL 240900 END-PERFORM DATEUTIL 241000 SET T-DAY-NDX TO W-WORK-D DATEUTIL 241100 MOVE T-DAY-NAME-ABBR (T-DAY-NDX) TO W-WORK-DAY-AB2 DATEUTIL 241200 MOVE +2 TO W-DAY-LENGTH DATEUTIL 241300 WHEN 'D' DATEUTIL 241400 COMPUTE W-NUMBER = W-JULIAN-DDD - 1 DATEUTIL 241500 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 241600 SEARCH ALL T-YEARDAY-TABLE DATEUTIL 241700 AT END PERFORM 1 TIMES DATEUTIL 241800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 241900 STRING 'DU2006-"' W-WORK-YEAR DATEUTIL 242000 '" IS NOT IN THE RANGE OF ' DATEUTIL 242100 '"1600" THRU "2600".' DATEUTIL 242200 DELIMITED BY SIZE DATEUTIL 242300 INTO DATEUTIL-MESSAGE DATEUTIL 242400 MOVE +2006 TO W-RETURN-CODE DATEUTIL 242500 PERFORM S3000-FINALIZATION DATEUTIL 242600 END-PERFORM DATEUTIL 242700 WHEN T-YEARDAY-YEAR (T-YEARDAY-NDX) = DATEUTIL 242800 W-JULIAN-YEAR DATEUTIL 242900 MOVE T-YEARDAY-DAY (T-YEARDAY-NDX) TO DATEUTIL 243000 W-WORK-D DATEUTIL 243100 END-SEARCH DATEUTIL 243200 PERFORM W-NUMBER TIMES DATEUTIL 243300 ADD 1 TO W-WORK-D DATEUTIL 243400 IF W-WORK-D > 7 DATEUTIL 243500 SUBTRACT 7 FROM W-WORK-D DATEUTIL 243600 END-IF DATEUTIL 243700 END-PERFORM DATEUTIL 243800 MOVE +1 TO W-DAY-LENGTH DATEUTIL 243900 WHEN SPACES CONTINUE DATEUTIL 244000 WHEN OTHER DATEUTIL 244100 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 244200 STRING 'DU2007-"' DU-DAY-2-FORMAT '" IS NOT ' DATEUTIL 244300 'A VALID DAY FORMAT. VALID FORMATS ARE ' DATEUTIL 244400 '"D", "DD", "DDD", "DA", AND "DAY".' DATEUTIL 244500 DELIMITED BY SIZE DATEUTIL 244600 INTO DATEUTIL-MESSAGE DATEUTIL 244700 MOVE +2007 TO W-RETURN-CODE DATEUTIL 244800 PERFORM S3000-FINALIZATION DATEUTIL 244900 END-EVALUATE. DATEUTIL 245000 DATEUTIL 245010**** DATEUTIL 245100**** LOAD THE MONTH COMPONENT INTO THE WORK MONTH **** DATEUTIL 245110**** DATEUTIL 245200 EVALUATE DU-MONTH-2-FORMAT DATEUTIL 245300 WHEN 'MM' DATEUTIL 245400 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 245500 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 245600 SET T-MON-NDX TO +1 DATEUTIL 245700 IF S-IS-A-LEAP-YEAR DATEUTIL 245800 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 245900 AT END PERFORM 1 TIMES DATEUTIL 246000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 246100 STRING 'DU2008-"' W-JULIAN-DDD DATEUTIL 246200 '" IS NOT A VALID DAY IN ' DATEUTIL 246300 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 246400 DELIMITED BY SIZE DATEUTIL 246500 INTO DATEUTIL-MESSAGE DATEUTIL 246600 MOVE +2008 TO W-RETURN-CODE DATEUTIL 246700 PERFORM S3000-FINALIZATION DATEUTIL 246800 END-PERFORM DATEUTIL 246900 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 247000 W-JULIAN-DDD OR DATEUTIL 247100 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 247200 W-JULIAN-DDD) AND DATEUTIL 247300 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 247400 W-JULIAN-DDD OR DATEUTIL 247500 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 247600 W-JULIAN-DDD) DATEUTIL 247700 SET W-WORK-MM TO T-MON-NDX DATEUTIL 247800 END-SEARCH DATEUTIL 247900 ELSE DATEUTIL 248000 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 248100 AT END PERFORM 1 TIMES DATEUTIL 248200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 248300 STRING 'DU2009-"' W-JULIAN-DDD DATEUTIL 248400 '" IS NOT A VALID DAY IN ' DATEUTIL 248500 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 248600 DELIMITED BY SIZE DATEUTIL 248700 INTO DATEUTIL-MESSAGE DATEUTIL 248800 MOVE +2009 TO W-RETURN-CODE DATEUTIL 248900 PERFORM S3000-FINALIZATION DATEUTIL 249000 END-PERFORM DATEUTIL 249100 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 249200 W-JULIAN-DDD OR DATEUTIL 249300 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 249400 W-JULIAN-DDD) AND DATEUTIL 249500 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 249600 W-JULIAN-DDD OR DATEUTIL 249700 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 249800 W-JULIAN-DDD) DATEUTIL 249900 SET W-WORK-MM TO T-MON-NDX DATEUTIL 250000 END-SEARCH DATEUTIL 250100 END-IF DATEUTIL 250200 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 250300 WHEN 'ZM' DATEUTIL 250400 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 250500 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 250600 SET T-MON-NDX TO +1 DATEUTIL 250700 IF S-IS-A-LEAP-YEAR DATEUTIL 250800 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 250900 AT END PERFORM 1 TIMES DATEUTIL 251000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 251100 STRING 'DU2008-"' W-JULIAN-DDD DATEUTIL 251200 '" IS NOT A VALID DAY IN ' DATEUTIL 251300 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 251400 DELIMITED BY SIZE DATEUTIL 251500 INTO DATEUTIL-MESSAGE DATEUTIL 251600 MOVE +2008 TO W-RETURN-CODE DATEUTIL 251700 PERFORM S3000-FINALIZATION DATEUTIL 251800 END-PERFORM DATEUTIL 251900 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 252000 W-JULIAN-DDD OR DATEUTIL 252100 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 252200 W-JULIAN-DDD) AND DATEUTIL 252300 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 252400 W-JULIAN-DDD OR DATEUTIL 252500 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 252600 W-JULIAN-DDD) DATEUTIL 252700 SET W-WORK-MM TO T-MON-NDX DATEUTIL 252800 END-SEARCH DATEUTIL 252900 ELSE DATEUTIL 253000 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 253100 AT END PERFORM 1 TIMES DATEUTIL 253200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 253300 STRING 'DU2009-"' W-JULIAN-DDD DATEUTIL 253400 '" IS NOT A VALID DAY IN ' DATEUTIL 253500 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 253600 DELIMITED BY SIZE DATEUTIL 253700 INTO DATEUTIL-MESSAGE DATEUTIL 253800 MOVE +2009 TO W-RETURN-CODE DATEUTIL 253900 PERFORM S3000-FINALIZATION DATEUTIL 254000 END-PERFORM DATEUTIL 254100 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 254200 W-JULIAN-DDD OR DATEUTIL 254300 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 254400 W-JULIAN-DDD) AND DATEUTIL 254500 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 254600 W-JULIAN-DDD OR DATEUTIL 254700 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 254800 W-JULIAN-DDD) DATEUTIL 254900 SET W-WORK-MM TO T-MON-NDX DATEUTIL 255000 END-SEARCH DATEUTIL 255100 END-IF DATEUTIL 255200 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 255300 WHEN 'MONTH' DATEUTIL 255400 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 255500 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 255600 SET T-MON-NDX TO +1 DATEUTIL 255700 IF S-IS-A-LEAP-YEAR DATEUTIL 255800 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 255900 AT END PERFORM 1 TIMES DATEUTIL 256000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 256100 STRING 'DU2010-"' W-JULIAN-DDD DATEUTIL 256200 '" IS NOT A VALID DAY IN ' DATEUTIL 256300 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 256400 DELIMITED BY SIZE DATEUTIL 256500 INTO DATEUTIL-MESSAGE DATEUTIL 256600 MOVE +2010 TO W-RETURN-CODE DATEUTIL 256700 PERFORM S3000-FINALIZATION DATEUTIL 256800 END-PERFORM DATEUTIL 256900 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 257000 W-JULIAN-DDD OR DATEUTIL 257100 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 257200 W-JULIAN-DDD) AND DATEUTIL 257300 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 257400 W-JULIAN-DDD OR DATEUTIL 257500 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 257600 W-JULIAN-DDD) DATEUTIL 257700 MOVE T-MON-NAME (T-MON-NDX) TO DATEUTIL 257800 W-WORK-MONTH DATEUTIL 257900 END-SEARCH DATEUTIL 258000 ELSE DATEUTIL 258100 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 258200 AT END PERFORM 1 TIMES DATEUTIL 258300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 258400 STRING 'DU2011-"' W-JULIAN-DDD DATEUTIL 258500 '" IS NOT A VALID DAY IN ' DATEUTIL 258600 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 258700 DELIMITED BY SIZE DATEUTIL 258800 INTO DATEUTIL-MESSAGE DATEUTIL 258900 MOVE +2011 TO W-RETURN-CODE DATEUTIL 259000 PERFORM S3000-FINALIZATION DATEUTIL 259100 END-PERFORM DATEUTIL 259200 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 259300 W-JULIAN-DDD OR DATEUTIL 259400 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 259500 W-JULIAN-DDD) AND DATEUTIL 259600 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 259700 W-JULIAN-DDD OR DATEUTIL 259800 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 259900 W-JULIAN-DDD) DATEUTIL 260000 MOVE T-MON-NAME (T-MON-NDX) TO DATEUTIL 260100 W-WORK-MONTH DATEUTIL 260200 END-SEARCH DATEUTIL 260300 END-IF DATEUTIL 260400 PERFORM VARYING W-MONTH-NDX FROM +9 BY -1 DATEUTIL 260500 UNTIL W-MONTH-ARRAY-BYTE (W-MONTH-NDX) > SPACE DATEUTIL 260600 END-PERFORM DATEUTIL 260700 SET W-MONTH-LENGTH TO W-MONTH-NDX DATEUTIL 260800 WHEN 'MMM' DATEUTIL 260900 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 261000 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 261100 SET T-MON-NDX TO +1 DATEUTIL 261200 IF S-IS-A-LEAP-YEAR DATEUTIL 261300 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 261400 AT END PERFORM 1 TIMES DATEUTIL 261500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 261600 STRING 'DU2012-"' W-JULIAN-DDD DATEUTIL 261700 '" IS NOT A VALID DAY IN ' DATEUTIL 261800 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 261900 DELIMITED BY SIZE DATEUTIL 262000 INTO DATEUTIL-MESSAGE DATEUTIL 262100 MOVE +2012 TO W-RETURN-CODE DATEUTIL 262200 PERFORM S3000-FINALIZATION DATEUTIL 262300 END-PERFORM DATEUTIL 262400 WHEN (T-MON-JUL-LEAP-BEGIN (T-MON-NDX) < DATEUTIL 262500 W-JULIAN-DDD OR DATEUTIL 262600 T-MON-JUL-LEAP-BEGIN (T-MON-NDX) = DATEUTIL 262700 W-JULIAN-DDD) AND DATEUTIL 262800 (T-MON-JUL-LEAP-END (T-MON-NDX) > DATEUTIL 262900 W-JULIAN-DDD OR DATEUTIL 263000 T-MON-JUL-LEAP-END (T-MON-NDX) = DATEUTIL 263100 W-JULIAN-DDD) DATEUTIL 263200 MOVE T-MON-NAME-ABBR (T-MON-NDX) TO DATEUTIL 263300 W-WORK-MMM DATEUTIL 263400 END-SEARCH DATEUTIL 263500 ELSE DATEUTIL 263600 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 263700 AT END PERFORM 1 TIMES DATEUTIL 263800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 263900 STRING 'DU2013-"' W-JULIAN-DDD DATEUTIL 264000 '" IS NOT A VALID DAY IN ' DATEUTIL 264100 'YEAR "' W-JULIAN-YEAR '".' DATEUTIL 264200 DELIMITED BY SIZE DATEUTIL 264300 INTO DATEUTIL-MESSAGE DATEUTIL 264400 MOVE +2013 TO W-RETURN-CODE DATEUTIL 264500 PERFORM S3000-FINALIZATION DATEUTIL 264600 END-PERFORM DATEUTIL 264700 WHEN (T-MON-JUL-BEGIN (T-MON-NDX) < DATEUTIL 264800 W-JULIAN-DDD OR DATEUTIL 264900 T-MON-JUL-BEGIN (T-MON-NDX) = DATEUTIL 265000 W-JULIAN-DDD) AND DATEUTIL 265100 (T-MON-JUL-END (T-MON-NDX) > DATEUTIL 265200 W-JULIAN-DDD OR DATEUTIL 265300 T-MON-JUL-END (T-MON-NDX) = DATEUTIL 265400 W-JULIAN-DDD) DATEUTIL 265500 MOVE T-MON-NAME-ABBR (T-MON-NDX) TO DATEUTIL 265600 W-WORK-MMM DATEUTIL 265700 END-SEARCH DATEUTIL 265800 END-IF DATEUTIL 265900 MOVE +3 TO W-MONTH-LENGTH DATEUTIL 266000 WHEN SPACES CONTINUE DATEUTIL 266100 WHEN OTHER DATEUTIL 266200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 266300 STRING 'DU2014-"' DU-MONTH-2-FORMAT '" IS NOT ' DATEUTIL 266400 'A VALID MONTH FORMAT. IT MUST BE: ' DATEUTIL 266500 '"MM", "MMM", OR "MONTH".' DATEUTIL 266600 DELIMITED BY SIZE DATEUTIL 266700 INTO DATEUTIL-MESSAGE DATEUTIL 266800 MOVE +2014 TO W-RETURN-CODE DATEUTIL 266900 PERFORM S3000-FINALIZATION DATEUTIL 267000 END-EVALUATE. DATEUTIL 267100 DATEUTIL 267110**** DATEUTIL 267200**** LOAD THE YEAR COMPONENT INTO THE WORK YEAR **** DATEUTIL 267210**** DATEUTIL 267300 EVALUATE DU-YEAR-2-FORMAT DATEUTIL 267400 WHEN 'YY' DATEUTIL 267500 MOVE W-JULIAN-DECADE TO W-WORK-DECADE DATEUTIL 267600 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 267700 SET W-YEAR-NDX1 TO +3 DATEUTIL 267800 WHEN 'YYYY' DATEUTIL 267900 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 268000 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 268100 SET W-YEAR-NDX1 TO +1 DATEUTIL 268200 WHEN SPACES CONTINUE DATEUTIL 268300 WHEN OTHER DATEUTIL 268400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 268500 STRING 'DU2015-"' DU-YEAR-2-FORMAT '" IS NOT ' DATEUTIL 268600 'A VALID YEAR FORMAT. IT MUST BE: ' DATEUTIL 268700 '"YY" OR "YYYY".' DATEUTIL 268800 DELIMITED BY SIZE DATEUTIL 268900 INTO DATEUTIL-MESSAGE DATEUTIL 269000 MOVE +2015 TO W-RETURN-CODE DATEUTIL 269100 PERFORM S3000-FINALIZATION DATEUTIL 269200 END-EVALUATE. DATEUTIL 269300 DATEUTIL 269400 MOVE SPACES TO W-WORK-ARRAY. DATEUTIL 269500 SET W-ARRAY-NDX1 TO +1. DATEUTIL 269600 DATEUTIL 269610**** DATEUTIL 269700**** LOAD THE VARIOUS COMPONENTS INTO THE DATE 2 DATE **** DATEUTIL 269710**** DATEUTIL 269800 PERFORM VARYING L-FORMAT-NDX FROM +1 BY +1 DATEUTIL 269900 UNTIL L-FORMAT-NDX > +20 DATEUTIL 270000 OR W-ARRAY-NDX1 > +20 DATEUTIL 270100 EVALUATE TRUE DATEUTIL 270200 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'D' DATEUTIL 270300 PERFORM VARYING W-DAY-NDX1 DATEUTIL 270400 FROM +1 BY +1 DATEUTIL 270500 UNTIL W-DAY-NDX1 > W-DAY-LENGTH DATEUTIL 270600 OR W-ARRAY-NDX1 > +20 DATEUTIL 270700 EVALUATE DU-DAY-2-FORMAT DATEUTIL 270800 WHEN 'ZD' DATEUTIL 270900 IF W-DAY-NDX1 = +1 AND DATEUTIL 271000 W-DAY-ARRAY-BYTE DATEUTIL 271100 (W-DAY-NDX1) = '0' DATEUTIL 271200 SET W-DAY-NDX1 UP BY +1 DATEUTIL 271300 END-IF DATEUTIL 271400 MOVE W-DAY-ARRAY-BYTE DATEUTIL 271500 (W-DAY-NDX1) DATEUTIL 271600 TO W-ARRAY-BYTE DATEUTIL 271700 (W-ARRAY-NDX1) DATEUTIL 271800 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 271900 WHEN 'ZZD' DATEUTIL 272000 IF W-DAY-NDX1 = +1 AND DATEUTIL 272100 W-DAY-ARRAY-BYTE DATEUTIL 272200 (W-DAY-NDX1) = '0' DATEUTIL 272300 SET W-DAY-NDX1 UP BY +1 DATEUTIL 272400 END-IF DATEUTIL 272500 IF W-DAY-NDX1 = +2 AND DATEUTIL 272600 W-DAY-ARRAY-BYTE DATEUTIL 272700 (W-DAY-NDX1) = '0' AND DATEUTIL 272800 W-DAY-ARRAY-BYTE DATEUTIL 272900 (1) = '0' DATEUTIL 273000 SET W-DAY-NDX1 UP BY +1 DATEUTIL 273100 END-IF DATEUTIL 273200 MOVE W-DAY-ARRAY-BYTE DATEUTIL 273300 (W-DAY-NDX1) DATEUTIL 273400 TO W-ARRAY-BYTE DATEUTIL 273500 (W-ARRAY-NDX1) DATEUTIL 273600 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 273700 WHEN OTHER DATEUTIL 273800 MOVE W-DAY-ARRAY-BYTE DATEUTIL 273900 (W-DAY-NDX1) DATEUTIL 274000 TO W-ARRAY-BYTE DATEUTIL 274100 (W-ARRAY-NDX1) DATEUTIL 274200 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 274300 END-EVALUATE DATEUTIL 274400 END-PERFORM DATEUTIL 274500 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'Y' DATEUTIL 274600 SET W-YEAR-NDX2 TO W-YEAR-NDX1 DATEUTIL 274700 PERFORM VARYING W-YEAR-NDX1 DATEUTIL 274800 FROM W-YEAR-NDX1 BY +1 DATEUTIL 274900 UNTIL W-YEAR-NDX1 > W-YEAR-LENGTH DATEUTIL 275000 OR W-ARRAY-NDX1 > +20 DATEUTIL 275100 MOVE W-YEAR-ARRAY-BYTE (W-YEAR-NDX1) DATEUTIL 275200 TO W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 275300 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 275400 END-PERFORM DATEUTIL 275500 SET W-YEAR-NDX1 TO W-YEAR-NDX2 DATEUTIL 275600 WHEN L-FORMAT-BYTE (L-FORMAT-NDX) = 'M' DATEUTIL 275700 PERFORM VARYING W-MONTH-NDX DATEUTIL 275800 FROM +1 BY +1 DATEUTIL 275900 UNTIL W-MONTH-NDX > W-MONTH-LENGTH DATEUTIL 276000 OR W-ARRAY-NDX1 > +20 DATEUTIL 276100 EVALUATE DU-MONTH-2-FORMAT DATEUTIL 276200 WHEN 'ZM' DATEUTIL 276300 IF W-MONTH-NDX = +1 AND DATEUTIL 276400 W-MONTH-ARRAY-BYTE DATEUTIL 276500 (W-MONTH-NDX) = '0' DATEUTIL 276600 SET W-MONTH-NDX UP BY +1 DATEUTIL 276700 END-IF DATEUTIL 276800 MOVE W-MONTH-ARRAY-BYTE DATEUTIL 276900 (W-MONTH-NDX) DATEUTIL 277000 TO W-ARRAY-BYTE DATEUTIL 277100 (W-ARRAY-NDX1) DATEUTIL 277200 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 277300 WHEN OTHER DATEUTIL 277400 MOVE W-MONTH-ARRAY-BYTE DATEUTIL 277500 (W-MONTH-NDX) DATEUTIL 277600 TO W-ARRAY-BYTE DATEUTIL 277700 (W-ARRAY-NDX1) DATEUTIL 277800 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 277900 END-EVALUATE DATEUTIL 278000 END-PERFORM DATEUTIL 278100 WHEN OTHER DATEUTIL 278200 MOVE L-FORMAT-BYTE (L-FORMAT-NDX) TO DATEUTIL 278300 W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 278400 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 278500 END-EVALUATE DATEUTIL 278600 END-PERFORM. DATEUTIL 278700 DATEUTIL 278800* MOVE SPACES TO DATEUTIL-WORK-AREA. DATEUTIL 278900 MOVE W-WORK-ARRAY TO DU-DATE-2. DATEUTIL 279000 DATEUTIL 279100 S4000-EXIT. DATEUTIL 279200 EXIT. DATEUTIL 279300/**************************************************************** DATEUTIL 279400* S5000-BETWEEN * DATEUTIL 279500* THIS SECTION CALCULATES THE NUMBER OF DAYS BETWEEN TWO DATES. * DATEUTIL 279600***************************************************************** DATEUTIL 279700 S5000-BETWEEN SECTION. DATEUTIL 279800 DATEUTIL 279900 MOVE W-WORK-JULIAN TO W-HOLD-JULIAN. DATEUTIL 280000 MOVE ZEROS TO W-WORK-JULIAN. DATEUTIL 280100 DATEUTIL 280101**** DATEUTIL 280102**** SEE IF THE DATE 2 FORMAT IS ONE OF THE AUTOMATIC ONES **** DATEUTIL 280103**** DATEUTIL 280104 IF DU-DATE-2-VALID-CODE DATEUTIL 280106 MOVE DU-DATE-2-FORMAT-CODE TO W-FORMAT-CODE DATEUTIL 280111 PERFORM S1300-CONVERT-FORMAT-CODE DATEUTIL 280112 MOVE W-HOLD-DAY-FORMAT TO DU-DAY-2-FORMAT DATEUTIL 280113 MOVE W-HOLD-MONTH-FORMAT TO DU-MONTH-2-FORMAT DATEUTIL 280114 MOVE W-HOLD-YEAR-FORMAT TO DU-YEAR-2-FORMAT DATEUTIL 280115 MOVE W-HOLD-DATE-FORMAT TO DU-DATE-2-FORMAT DATEUTIL 280130 END-IF. DATEUTIL 280131 DATEUTIL 280132 IF DU-YEAR-2-SWITCH IS NUMERIC DATEUTIL 280133 IF DU-YEAR-2-SWITCH > 0 DATEUTIL 280134 MOVE DU-YEAR-2-SWITCH TO W-SWITCH-YEAR DATEUTIL 280135 END-IF DATEUTIL 280136 END-IF. DATEUTIL 280140 DATEUTIL 280200 MOVE DU-DATE-2 TO W-HOLD-DATE. DATEUTIL 280300 MOVE DU-DAY-2-FORMAT TO W-HOLD-DAY-FORMAT. DATEUTIL 280400 MOVE DU-MONTH-2-FORMAT TO W-HOLD-MONTH-FORMAT. DATEUTIL 280500 MOVE DU-YEAR-2-FORMAT TO W-HOLD-YEAR-FORMAT. DATEUTIL 280600 MOVE DU-DATE-2-FORMAT TO W-HOLD-DATE-FORMAT. DATEUTIL 280700 DATEUTIL 280800 PERFORM S9100-PARSE-DATE. DATEUTIL 280900 DATEUTIL 281000 PERFORM S9200-CONVERT-TO-JULIAN. DATEUTIL 281100 DATEUTIL 281200 MOVE +0 TO TALLY. DATEUTIL 281300 DATEUTIL 281400 IF W-HOLD-JULIAN > W-WORK-JULIAN DATEUTIL 281500 PERFORM VARYING W-HOLD-JULIAN-NDX FROM +1 BY +1 DATEUTIL 281600 UNTIL W-HOLD-JULIAN-NDX > +7 DATEUTIL 281700 SET W-ARRAY-NDX1 TO W-HOLD-JULIAN-NDX DATEUTIL 281800 MOVE W-HOLD-JULIAN-BYTE (W-HOLD-JULIAN-NDX) DATEUTIL 281900 TO W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 282000 END-PERFORM DATEUTIL 282100 MOVE W-WORK-JULIAN TO W-HOLD-JULIAN DATEUTIL 282200 PERFORM VARYING W-JULIAN-NDX FROM +1 BY +1 DATEUTIL 282300 UNTIL W-JULIAN-NDX > +7 DATEUTIL 282400 SET W-ARRAY-NDX1 TO W-JULIAN-NDX DATEUTIL 282500 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) DATEUTIL 282600 TO W-JULIAN-BYTE (W-JULIAN-NDX) DATEUTIL 282700 END-PERFORM DATEUTIL 282800 END-IF. DATEUTIL 282900 DATEUTIL 283000 PERFORM UNTIL W-HOLD-JULIAN = W-WORK-JULIAN DATEUTIL 283100 IF W-HOLD-JULIAN-YEAR < W-JULIAN-YEAR DATEUTIL 283200 MOVE W-HOLD-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 283300 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 283400 IF S-IS-A-LEAP-YEAR DATEUTIL 283500 PERFORM UNTIL W-HOLD-JULIAN-DDD > 366 DATEUTIL 283600 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 283700 TALLY DATEUTIL 283800 END-PERFORM DATEUTIL 283900 ELSE DATEUTIL 284000 PERFORM UNTIL W-HOLD-JULIAN-DDD > 365 DATEUTIL 284100 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 284200 TALLY DATEUTIL 284300 END-PERFORM DATEUTIL 284400 END-IF DATEUTIL 284500 ADD 1 TO W-HOLD-JULIAN-YEAR DATEUTIL 284600 MOVE 1 TO W-HOLD-JULIAN-DDD DATEUTIL 284700 ELSE DATEUTIL 284800 ADD +1 TO W-HOLD-JULIAN-DDD DATEUTIL 284900 TALLY DATEUTIL 285000 END-IF DATEUTIL 285100 END-PERFORM. DATEUTIL 285200 DATEUTIL 285300 MOVE SPACES TO DATEUTIL-WORK-AREA. DATEUTIL 285400 MOVE TALLY TO DU-NUMBER. DATEUTIL 285500 DATEUTIL 285600 S5000-EXIT. DATEUTIL 285700 EXIT. DATEUTIL 285800/**************************************************************** DATEUTIL 285900* S6000-INCREMENT * DATEUTIL 286000* THIS SECTION INCREMENTS THE INPUT DATE BY THE NUMBER IN THE * DATEUTIL 286100* INPUT NUMBER FIELD. * DATEUTIL 286200***************************************************************** DATEUTIL 286300 S6000-INCREMENT SECTION. DATEUTIL 286400 DATEUTIL 286500 IF DU-NUMBER < 1 DATEUTIL 286600 MOVE DU-FUNCTION TO W-HOLD-FUNCTION DATEUTIL 286700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 286800 STRING 'DU2034-THE NUMBER MUST BE GREATER THAN ' DATEUTIL 286900 'ZERO FOR THE "' W-HOLD-FUNCTION DATEUTIL 287000 '" FUNCTION.' DATEUTIL 287100 DELIMITED BY SIZE DATEUTIL 287200 INTO DATEUTIL-MESSAGE DATEUTIL 287300 MOVE +2034 TO W-RETURN-CODE DATEUTIL 287400 PERFORM S3000-FINALIZATION DATEUTIL 287500 END-IF. DATEUTIL 287600 DATEUTIL 287700 MOVE W-JULIAN-YEAR TO W-WORK-YEAR. DATEUTIL 287800 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 287900 DATEUTIL 288000 PERFORM DU-NUMBER TIMES DATEUTIL 288100 ADD +1 TO W-JULIAN-DDD DATEUTIL 288200 IF S-IS-A-LEAP-YEAR DATEUTIL 288300 IF W-JULIAN-DDD > 366 DATEUTIL 288400 MOVE 1 TO W-JULIAN-DDD DATEUTIL 288500 ADD +1 TO W-JULIAN-YEAR DATEUTIL 288600 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 288700 END-IF DATEUTIL 288800 ELSE DATEUTIL 288900 IF W-JULIAN-DDD > 365 DATEUTIL 289000 MOVE 1 TO W-JULIAN-DDD DATEUTIL 289100 ADD +1 TO W-JULIAN-YEAR DATEUTIL 289200 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 289300 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 289400 END-IF DATEUTIL 289500 END-IF DATEUTIL 289600 END-PERFORM. DATEUTIL 289610 DATEUTIL 289700 PERFORM S4000-CONVERT. DATEUTIL 289800 DATEUTIL 289900 S6000-EXIT. DATEUTIL 290000 EXIT. DATEUTIL 290100/**************************************************************** DATEUTIL 290200* S7000-DECREMENT * DATEUTIL 290300* THIS SECTION DECREMENTS THE INPUT DATE BY THE NUMBER IN THE * DATEUTIL 290400* INPUT NUMBER FIELD. * DATEUTIL 290500***************************************************************** DATEUTIL 290600 S7000-DECREMENT SECTION. DATEUTIL 290700 DATEUTIL 290800 IF DU-NUMBER < 1 DATEUTIL 290900 MOVE DU-FUNCTION TO W-HOLD-FUNCTION DATEUTIL 291000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 291100 STRING 'DU2035-THE NUMBER MUST BE GREATER THAN ' DATEUTIL 291200 'ZERO FOR THE "' W-HOLD-FUNCTION DATEUTIL 291300 '" FUNCTION.' DATEUTIL 291400 DELIMITED BY SIZE DATEUTIL 291500 INTO DATEUTIL-MESSAGE DATEUTIL 291600 MOVE +2035 TO W-RETURN-CODE DATEUTIL 291700 PERFORM S3000-FINALIZATION DATEUTIL 291800 END-IF. DATEUTIL 291900 DATEUTIL 292000 MOVE W-JULIAN-YEAR TO W-WORK-YEAR. DATEUTIL 292100 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 292200 DATEUTIL 292300 PERFORM DU-NUMBER TIMES DATEUTIL 292400 SUBTRACT +1 FROM W-JULIAN-DDD DATEUTIL 292500 IF S-IS-A-LEAP-YEAR DATEUTIL 292600 IF W-JULIAN-DDD = 0 DATEUTIL 292700 MOVE 365 TO W-JULIAN-DDD DATEUTIL 292800 SUBTRACT +1 FROM W-JULIAN-YEAR DATEUTIL 292900 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 293000 END-IF DATEUTIL 293100 ELSE DATEUTIL 293200 IF W-JULIAN-DDD = 0 DATEUTIL 293300 SUBTRACT +1 FROM W-JULIAN-YEAR DATEUTIL 293400 MOVE W-JULIAN-YEAR TO W-WORK-YEAR DATEUTIL 293500 PERFORM S9000-DETERMINE-LEAP-YEAR DATEUTIL 293600 IF S-IS-A-LEAP-YEAR DATEUTIL 293700 MOVE 366 TO W-JULIAN-DDD DATEUTIL 293800 ELSE DATEUTIL 293900 MOVE 365 TO W-JULIAN-DDD DATEUTIL 294000 END-IF DATEUTIL 294100 END-IF DATEUTIL 294200 END-IF DATEUTIL 294300 END-PERFORM. DATEUTIL 294310 DATEUTIL 294400 PERFORM S4000-CONVERT. DATEUTIL 294500 DATEUTIL 294600 S7000-EXIT. DATEUTIL 294700 EXIT. DATEUTIL 294800/**************************************************************** DATEUTIL 294900* S9000-DETERMINE-LEAP-YEAR * DATEUTIL 295000* THIS SECTION SETS A SWITCH TO LET THE CALLING SECTION KNOW * DATEUTIL 295100* IF THE YEAR IT'S DEALING WITH IS A LEAP YEAR OR NOT. * DATEUTIL 295200***************************************************************** DATEUTIL 295300 S9000-DETERMINE-LEAP-YEAR SECTION. DATEUTIL 295400 DATEUTIL 295500 IF W-WORK-YEAR IS NUMERIC DATEUTIL 295600 IF W-WORK-DECADE = 00 DATEUTIL 295700 DIVIDE W-WORK-YEAR-NUM BY 400 DATEUTIL 295800 GIVING W-QUOTIENT DATEUTIL 295900 REMAINDER W-REMAINDER DATEUTIL 296000 ELSE DATEUTIL 296100 DIVIDE W-WORK-YEAR-NUM BY 4 DATEUTIL 296200 GIVING W-QUOTIENT DATEUTIL 296300 REMAINDER W-REMAINDER DATEUTIL 296400 END-IF DATEUTIL 296500 ELSE DATEUTIL 296600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 296700 STRING 'DU2016-"' W-WORK-YEAR '" IS NOT ' DATEUTIL 296800 'A VALID YEAR VALUE. IT MUST BE ' DATEUTIL 296900 'NUMERIC IN THE RANGE OF "1600-2600".' DATEUTIL 297000 DELIMITED BY SIZE DATEUTIL 297100 INTO DATEUTIL-MESSAGE DATEUTIL 297200 MOVE +2016 TO W-RETURN-CODE DATEUTIL 297300 PERFORM S3000-FINALIZATION DATEUTIL 297400 END-IF. DATEUTIL 297500 DATEUTIL 297600 IF W-A-LEAP-YEAR-REMAINDER DATEUTIL 297700 SET S-IS-A-LEAP-YEAR TO TRUE DATEUTIL 297800 ELSE DATEUTIL 297900 SET S-NOT-A-LEAP-YEAR TO TRUE DATEUTIL 298000 END-IF. DATEUTIL 298100 DATEUTIL 298200 S9000-EXIT. DATEUTIL 298300 EXIT. DATEUTIL 298400/**************************************************************** DATEUTIL 298500* S9100-PARSE-DATE * DATEUTIL 298600* THIS SECTION PARSES THE INPUT DATE (DATE 1 USUALLY, BUT IT * DATEUTIL 298700* COULD BE DATE 2 FOR THE BETWEEN FUNCTION) AND PUTS EACH * DATEUTIL 298800* COMPONENT OF THE DATE INTO INDIVIDUAL WORK FIELDS FOR THE * DATEUTIL 298900* DAY, MONTH, AND YEAR. * DATEUTIL 299000***************************************************************** DATEUTIL 299100 S9100-PARSE-DATE SECTION. DATEUTIL 299200 DATEUTIL 299300 MOVE W-HOLD-DATE-FORMAT TO W-WORK-ARRAY. DATEUTIL 299400 SET W-ARRAY-NDX1 TO +1. DATEUTIL 299500 MOVE SPACES TO W-WORK-DAY DATEUTIL 299600 W-WORK-MONTH DATEUTIL 299700 W-WORK-YEAR. DATEUTIL 299800 DATEUTIL 299810**** DATEUTIL 299900**** FIND POSITION OF THE YEAR COMPONENT IN THE FORMAT FIELD **** DATEUTIL 299910**** DATEUTIL 300000 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 300100 AT END PERFORM 1 TIMES DATEUTIL 300200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 300300 STRING 'DU2017-THE DATE FORMAT MUST CONTAIN ' DATEUTIL 300400 'A "YEAR" REFERENCE OF SOME TYPE. ' DATEUTIL 300500 'SPECIFY IT WITH A "Y" IN THE FORMAT.' DATEUTIL 300600 DELIMITED BY SIZE DATEUTIL 300700 INTO DATEUTIL-MESSAGE DATEUTIL 300800 MOVE +2017 TO W-RETURN-CODE DATEUTIL 300900 PERFORM S3000-FINALIZATION DATEUTIL 301000 END-PERFORM DATEUTIL 301100 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'Y' DATEUTIL 301200 SET W-YEAR-BYTE TO W-ARRAY-NDX1 DATEUTIL 301300 END-SEARCH. DATEUTIL 301400 DATEUTIL 301500 SET W-ARRAY-NDX1 TO +1. DATEUTIL 301600 DATEUTIL 301610**** DATEUTIL 301700**** FIND POSITION OF THE MONTH COMPONENT IN THE DATE FORMAT **** DATEUTIL 301710**** DATEUTIL 301800 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 301900 AT END PERFORM 1 TIMES DATEUTIL 302000 IF W-HOLD-DAY-FORMAT = 'DDD' OR 'ZZD' DATEUTIL 302100 NEXT SENTENCE DATEUTIL 302200 ELSE DATEUTIL 302300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 302400 STRING 'DU2018-THE DATE FORMAT ' DATEUTIL 302500 'MUST CONTAIN A "MONTH" ' DATEUTIL 302600 'REFERENCE OF SOME TYPE. ' DATEUTIL 302700 'SPECIFY IT WITH A "M" IN ' DATEUTIL 302800 'THE FORMAT.' DATEUTIL 302900 DELIMITED BY SIZE DATEUTIL 303000 INTO DATEUTIL-MESSAGE DATEUTIL 303100 MOVE +2018 TO W-RETURN-CODE DATEUTIL 303200 PERFORM S3000-FINALIZATION DATEUTIL 303300 END-IF DATEUTIL 303400 END-PERFORM DATEUTIL 303500 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'M' DATEUTIL 303600 SET W-MONTH-BYTE TO W-ARRAY-NDX1 DATEUTIL 303700 END-SEARCH. DATEUTIL 303800 DATEUTIL 303900 SET W-ARRAY-NDX1 TO +1. DATEUTIL 304000 DATEUTIL 304010**** DATEUTIL 304100**** FIND THE POSITION OF THE DAY COMPONENT IN THE DATE FORMAT ** DATEUTIL 304110**** DATEUTIL 304200 SEARCH W-ARRAY VARYING W-ARRAY-NDX1 DATEUTIL 304300 AT END PERFORM 1 TIMES DATEUTIL 304400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 304500 STRING 'DU2019-THE DATE FORMAT MUST CONTAIN ' DATEUTIL 304600 'A "DAY" REFERENCE OF SOME TYPE. ' DATEUTIL 304700 'SPECIFY IT WITH A "D" IN THE FORMAT.' DATEUTIL 304800 DELIMITED BY SIZE DATEUTIL 304900 INTO DATEUTIL-MESSAGE DATEUTIL 305000 MOVE +2019 TO W-RETURN-CODE DATEUTIL 305100 PERFORM S3000-FINALIZATION DATEUTIL 305200 END-PERFORM DATEUTIL 305300 WHEN W-ARRAY-BYTE (W-ARRAY-NDX1) = 'D' DATEUTIL 305400 SET W-DAY-BYTE TO W-ARRAY-NDX1 DATEUTIL 305500 END-SEARCH. DATEUTIL 305600 DATEUTIL 305700 MOVE SPACES TO W-WORK-ARRAY. DATEUTIL 305800 MOVE W-HOLD-DATE TO W-WORK-ARRAY. DATEUTIL 305900 DATEUTIL 305910**** DATEUTIL 306000**** CHECK THE DAY FORMAT FOR VALIDITY **** DATEUTIL 306010**** DATEUTIL 306100 EVALUATE W-HOLD-DAY-FORMAT DATEUTIL 306200 WHEN 'DD' DATEUTIL 306300 MOVE +2 TO W-DAY-LENGTH DATEUTIL 306400 WHEN 'ZD' DATEUTIL 306500 MOVE +2 TO W-DAY-LENGTH DATEUTIL 306600 WHEN 'DDD' DATEUTIL 306700 MOVE +3 TO W-DAY-LENGTH DATEUTIL 306800 WHEN 'ZZD' DATEUTIL 306900 MOVE +3 TO W-DAY-LENGTH DATEUTIL 307000 WHEN OTHER DATEUTIL 307100 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 307200 STRING 'DU2020-THE INPUT "DAY" FORMAT MAY ONLY BE ' DATEUTIL 307300 '"DD", "DDD", "ZD", OR "ZZD".' DATEUTIL 307400 DELIMITED BY SIZE DATEUTIL 307500 INTO DATEUTIL-MESSAGE DATEUTIL 307600 MOVE +2020 TO W-RETURN-CODE DATEUTIL 307700 PERFORM S3000-FINALIZATION DATEUTIL 307800 END-EVALUATE. DATEUTIL 307900 DATEUTIL 307910**** DATEUTIL 308000**** CHECK THE YEAR FORMAT FOR VALIDITY **** DATEUTIL 308010**** DATEUTIL 308100 EVALUATE W-HOLD-YEAR-FORMAT DATEUTIL 308200 WHEN 'YY' DATEUTIL 308400 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 308500 SET W-YEAR-NDX1 TO +3 DATEUTIL 308600 WHEN 'YYYY' DATEUTIL 308700 MOVE +4 TO W-YEAR-LENGTH DATEUTIL 308800 SET W-YEAR-NDX1 TO +1 DATEUTIL 308900 WHEN OTHER DATEUTIL 309000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 309100 STRING 'DU2021-THE INPUT "YEAR" FORMAT MAY ONLY ' DATEUTIL 309200 'BE "YY" OR "YYYY".' DATEUTIL 309300 DELIMITED BY SIZE DATEUTIL 309400 INTO DATEUTIL-MESSAGE DATEUTIL 309500 MOVE +2021 TO W-RETURN-CODE DATEUTIL 309600 PERFORM S3000-FINALIZATION DATEUTIL 309700 END-EVALUATE. DATEUTIL 309800 DATEUTIL 309810**** DATEUTIL 309900**** CHECK THE MONTH FORMAT FOR VALIDITY **** DATEUTIL 309910**** DATEUTIL 310000 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 310100 WHEN 'MM' DATEUTIL 310200 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 310300 WHEN 'ZM' DATEUTIL 310400 MOVE +2 TO W-MONTH-LENGTH DATEUTIL 310500 WHEN 'MMM' DATEUTIL 310600 MOVE +3 TO W-MONTH-LENGTH DATEUTIL 310700 WHEN 'MONTH' DATEUTIL 310800 MOVE +9 TO W-MONTH-LENGTH DATEUTIL 310900 WHEN OTHER DATEUTIL 311000 IF W-HOLD-DAY-FORMAT = 'DDD' DATEUTIL 311100 NEXT SENTENCE DATEUTIL 311200 ELSE DATEUTIL 311300 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 311400 STRING 'DU2022-THE INPUT "MONTH" FORMAT MAY ' DATEUTIL 311500 'ONLY BE "MM", "MMM" OR "MONTH".' DATEUTIL 311600 DELIMITED BY SIZE DATEUTIL 311700 INTO DATEUTIL-MESSAGE DATEUTIL 311800 MOVE +2022 TO W-RETURN-CODE DATEUTIL 311900 PERFORM S3000-FINALIZATION DATEUTIL 312000 END-IF DATEUTIL 312100 END-EVALUATE. DATEUTIL 312200 DATEUTIL 312300 SET W-ARRAY-NDX2 TO +1. DATEUTIL 312400 DATEUTIL 312410**** DATEUTIL 312500**** PARSE THE DATE AND SEPARATE IT INTO INDIVIDUAL COMPONENTS ** DATEUTIL 312510**** DATEUTIL 312600 PERFORM VARYING W-ARRAY-NDX1 FROM +1 BY +1 DATEUTIL 312700 UNTIL W-ARRAY-NDX1 > +20 DATEUTIL 312800 OR W-ARRAY-NDX2 > +20 DATEUTIL 312900 EVALUATE W-ARRAY-NDX2 DATEUTIL 313000 WHEN W-DAY-BYTE DATEUTIL 313100 PERFORM S9110-PARSE-DATE-DAY DATEUTIL 313200 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 313300 WHEN W-MONTH-BYTE DATEUTIL 313400 PERFORM S9120-PARSE-DATE-MONTH DATEUTIL 313500 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 313600 WHEN W-YEAR-BYTE DATEUTIL 313700 PERFORM S9130-PARSE-DATE-YEAR DATEUTIL 313800 SET W-ARRAY-NDX1 DOWN BY +1 DATEUTIL 313900 END-EVALUATE DATEUTIL 314000 SET W-ARRAY-NDX2 UP BY +1 DATEUTIL 314100 END-PERFORM. DATEUTIL 314200 DATEUTIL 314300 S9100-EXIT. DATEUTIL 314400 EXIT. DATEUTIL 314500/**************************************************************** DATEUTIL 314600* S9110-PARSE-DATE-DAY * DATEUTIL 314700* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "DAY" * DATEUTIL 314800* PORTION OF THE DATE. * DATEUTIL 314900***************************************************************** DATEUTIL 315000 S9110-PARSE-DATE-DAY SECTION. DATEUTIL 315100 DATEUTIL 315200 PERFORM VARYING W-DAY-NDX1 FROM +1 BY +1 DATEUTIL 315300 UNTIL W-DAY-NDX1 > W-DAY-LENGTH OR DATEUTIL 315400 W-ARRAY-NDX1 > +20 OR DATEUTIL 315500 W-ARRAY-BYTE (W-ARRAY-NDX1) IS NOT NUMERIC DATEUTIL 315600 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 315700 W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 315800 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 315900 END-PERFORM. DATEUTIL 316000 DATEUTIL 316100 PERFORM VARYING W-DAY-NDX2 FROM W-DAY-LENGTH BY -1 DATEUTIL 316200 UNTIL W-DAY-NDX2 < +1 OR DATEUTIL 316300 W-DAY-ARRAY-BYTE (W-DAY-NDX2) IS NUMERIC DATEUTIL 316400 END-PERFORM. DATEUTIL 316500 DATEUTIL 316600 PERFORM VARYING W-DAY-NDX1 FROM W-DAY-LENGTH BY -1 DATEUTIL 316700 UNTIL W-DAY-NDX1 < +1 OR DATEUTIL 316800 W-DAY-ARRAY-BYTE (W-DAY-NDX1) IS NUMERIC DATEUTIL 316900 IF W-DAY-NDX2 > 0 DATEUTIL 317000 MOVE W-DAY-ARRAY-BYTE (W-DAY-NDX2) TO DATEUTIL 317100 W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 317200 MOVE '0' TO W-DAY-ARRAY-BYTE (W-DAY-NDX2) DATEUTIL 317300 SET W-DAY-NDX2 DOWN BY +1 DATEUTIL 317400 ELSE DATEUTIL 317500 MOVE '0' TO W-DAY-ARRAY-BYTE (W-DAY-NDX1) DATEUTIL 317600 END-IF DATEUTIL 317700 END-PERFORM. DATEUTIL 317800 DATEUTIL 317900 S9110-EXIT. DATEUTIL 318000 EXIT. DATEUTIL 318100/**************************************************************** DATEUTIL 318200* S9120-PARSE-DATE-MONTH * DATEUTIL 318300* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "MONTH"* DATEUTIL 318400* PORTION OF THE DATE. * DATEUTIL 318500***************************************************************** DATEUTIL 318600 S9120-PARSE-DATE-MONTH SECTION. DATEUTIL 318700 DATEUTIL 318800 PERFORM VARYING W-MONTH-NDX DATEUTIL 318900 FROM +1 BY +1 DATEUTIL 319000 UNTIL W-MONTH-NDX > W-MONTH-LENGTH DATEUTIL 319100 OR W-ARRAY-NDX1 > +20 DATEUTIL 319200 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 319300 WHEN 'ZM' DATEUTIL 319400 IF W-MONTH-NDX = +1 DATEUTIL 319500 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS NUMERIC DATEUTIL 319600 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 319700 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 319800 ELSE DATEUTIL 319900 MOVE '0' TO DATEUTIL 320000 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 320100 END-IF DATEUTIL 320200 END-IF DATEUTIL 320300 IF W-MONTH-NDX = +2 DATEUTIL 320400 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS NUMERIC DATEUTIL 320500 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 320600 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 320700 ELSE DATEUTIL 320800 MOVE W-MONTH-ARRAY-BYTE (W-MONTH-NDX - 1) DATEUTIL 320900 TO W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 321000 MOVE '0' TO DATEUTIL 321100 W-MONTH-ARRAY-BYTE (W-MONTH-NDX - 1) DATEUTIL 321200 END-IF DATEUTIL 321300 END-IF DATEUTIL 321400 WHEN 'MONTH' DATEUTIL 321500 IF W-ARRAY-BYTE (W-ARRAY-NDX1) IS ALPHABETIC ANDDATEUTIL 321600 W-ARRAY-BYTE (W-ARRAY-NDX1) NOT = SPACE DATEUTIL 321700 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 321800 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 321900 ELSE DATEUTIL 322000 SET W-MONTH-NDX TO W-MONTH-LENGTH DATEUTIL 322100 END-IF DATEUTIL 322200 WHEN OTHER DATEUTIL 322300 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 322400 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 322500 END-EVALUATE DATEUTIL 322600 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 322700 END-PERFORM. DATEUTIL 322800 DATEUTIL 322900 S9120-EXIT. DATEUTIL 323000 EXIT. DATEUTIL 323100/**************************************************************** DATEUTIL 323200* S9130-PARSE-DATE-YEAR * DATEUTIL 323300* CALLED FROM PARSE DATE TO HANDLE THE REBUILDING OF THE "YEAR" * DATEUTIL 323400* PORTION OF THE DATE. * DATEUTIL 323500***************************************************************** DATEUTIL 323600 S9130-PARSE-DATE-YEAR SECTION. DATEUTIL 323700 DATEUTIL 323800 PERFORM VARYING W-YEAR-NDX1 DATEUTIL 323900 FROM W-YEAR-NDX1 BY +1 DATEUTIL 324000 UNTIL W-YEAR-NDX1 > W-YEAR-LENGTH DATEUTIL 324100 OR W-ARRAY-NDX1 > +20 DATEUTIL 324200 MOVE W-ARRAY-BYTE (W-ARRAY-NDX1) TO DATEUTIL 324300 W-YEAR-ARRAY-BYTE (W-YEAR-NDX1) DATEUTIL 324400 SET W-ARRAY-NDX1 UP BY +1 DATEUTIL 324500 END-PERFORM. DATEUTIL 324600 DATEUTIL 324601 IF W-WORK-DECADE < W-SWITCH-YEAR AND DATEUTIL 324602 W-HOLD-YEAR-FORMAT = 'YY' DATEUTIL 324604 MOVE '20' TO W-WORK-CENTURY DATEUTIL 324605 ELSE DATEUTIL 324606 MOVE '19' TO W-WORK-CENTURY DATEUTIL 324607 END-IF. DATEUTIL 324610 DATEUTIL 324700 S9130-EXIT. DATEUTIL 324800 EXIT. DATEUTIL 324900/**************************************************************** DATEUTIL 325000* S9200-CONVERT-TO-JULIAN * DATEUTIL 325100* CONVERT THE DATE PASSED TO THIS SECTION INTO A JULIAN DATE IN * DATEUTIL 325200* YYYYDDD FORMAT. * DATEUTIL 325300***************************************************************** DATEUTIL 325400 S9200-CONVERT-TO-JULIAN SECTION. DATEUTIL 325500 DATEUTIL 325600 PERFORM S9000-DETERMINE-LEAP-YEAR. DATEUTIL 325700 DATEUTIL 325800 MOVE W-WORK-CENTURY TO W-JULIAN-CENTURY. DATEUTIL 325900 MOVE W-WORK-DECADE TO W-JULIAN-DECADE. DATEUTIL 326000 DATEUTIL 326100 IF W-HOLD-DAY-FORMAT = 'DDD' OR 'ZZD' DATEUTIL 326200 IF ((W-WORK-DAY-AB3 > '001' OR DATEUTIL 326300 W-WORK-DAY-AB3 = '001') AND DATEUTIL 326400 (W-WORK-DAY-AB3 < '365' OR DATEUTIL 326500 W-WORK-DAY-AB3 = '365') AND DATEUTIL 326600 (S-NOT-A-LEAP-YEAR)) OR DATEUTIL 326700 ((W-WORK-DAY-AB3 > '001' OR DATEUTIL 326800 W-WORK-DAY-AB3 = '001') AND DATEUTIL 326900 (W-WORK-DAY-AB3 < '366' OR DATEUTIL 327000 W-WORK-DAY-AB3 = '366') AND DATEUTIL 327100 (S-IS-A-LEAP-YEAR)) DATEUTIL 327200 MOVE W-WORK-DDD TO W-JULIAN-DDD DATEUTIL 327300 GO TO S9200-EXIT DATEUTIL 327400 ELSE DATEUTIL 327500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 327600 STRING 'DU2023-"' W-WORK-DAY-AB2 '" IS AN INVALID ' DATEUTIL 327700 'JULIAN DAY FOR "' W-WORK-YEAR '".' DATEUTIL 327800 DELIMITED BY SIZE DATEUTIL 327900 INTO DATEUTIL-MESSAGE DATEUTIL 328000 MOVE +2023 TO W-RETURN-CODE DATEUTIL 328100 PERFORM S3000-FINALIZATION DATEUTIL 328200 ELSE DATEUTIL 328300 IF W-HOLD-DAY-FORMAT = 'DD' OR 'ZD' DATEUTIL 328400 IF W-WORK-DAY-AB2 IS NOT NUMERIC DATEUTIL 328500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 328600 STRING 'DU2024-THE INPUT DAY OF THE MONTH MUST ' DATEUTIL 328700 'BE NUMERIC.' DATEUTIL 328800 DELIMITED BY SIZE DATEUTIL 328900 INTO DATEUTIL-MESSAGE DATEUTIL 329000 MOVE +2024 TO W-RETURN-CODE DATEUTIL 329100 PERFORM S3000-FINALIZATION DATEUTIL 329200 END-IF DATEUTIL 329300 ELSE DATEUTIL 329400 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 329500 STRING 'DU2025-THE ONLY VALID INPUT "DAY" FORMATS ' DATEUTIL 329600 'ARE "DD", "DDD", "ZD", OR "ZZD".' DATEUTIL 329700 DELIMITED BY SIZE DATEUTIL 329800 INTO DATEUTIL-MESSAGE DATEUTIL 329900 MOVE +2025 TO W-RETURN-CODE DATEUTIL 330000 PERFORM S3000-FINALIZATION DATEUTIL 330100 END-IF DATEUTIL 330200 END-IF. DATEUTIL 330300 DATEUTIL 330400 EVALUATE W-HOLD-MONTH-FORMAT DATEUTIL 330500 WHEN 'MMM' DATEUTIL 330600 SET T-MON-NDX TO +1 DATEUTIL 330700 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 330800 AT END PERFORM 1 TIMES DATEUTIL 330900 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 331000 STRING 'DU2026-"' W-WORK-MMM '" IS NOT A ' DATEUTIL 331100 'VALID 3 CHARACTER MONTH ' DATEUTIL 331200 'ABBREVIATION.' DATEUTIL 331300 DELIMITED BY SIZE DATEUTIL 331400 INTO DATEUTIL-MESSAGE DATEUTIL 331500 MOVE +2026 TO W-RETURN-CODE DATEUTIL 331600 PERFORM S3000-FINALIZATION DATEUTIL 331700 END-PERFORM DATEUTIL 331800 WHEN T-MON-NAME-ABBR (T-MON-NDX) = W-WORK-MMM DATEUTIL 331900 CONTINUE DATEUTIL 332000 END-SEARCH DATEUTIL 332100 WHEN 'MONTH' DATEUTIL 332200 SET T-MON-NDX TO +1 DATEUTIL 332300 SEARCH T-MON-TABLE VARYING T-MON-NDX DATEUTIL 332400 AT END PERFORM 1 TIMES DATEUTIL 332500 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 332600 STRING 'DU2027-"' W-WORK-MONTH '" IS NOT ' DATEUTIL 332700 'A VALID MONTH NAME.' DATEUTIL 332800 DELIMITED BY SIZE DATEUTIL 332900 INTO DATEUTIL-MESSAGE DATEUTIL 333000 MOVE +2027 TO W-RETURN-CODE DATEUTIL 333100 PERFORM S3000-FINALIZATION DATEUTIL 333200 END-PERFORM DATEUTIL 333300 WHEN T-MON-NAME (T-MON-NDX) = W-WORK-MONTH DATEUTIL 333400 CONTINUE DATEUTIL 333500 END-SEARCH DATEUTIL 333600 WHEN 'MM' DATEUTIL 333700 IF W-WORK-MM < 1 OR W-WORK-MM > 12 DATEUTIL 333800 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 333900 STRING 'DU2028-"' W-WORK-MM '" IS NOT ' DATEUTIL 334000 'A VALID MONTH NUMBER.' DATEUTIL 334100 DELIMITED BY SIZE DATEUTIL 334200 INTO DATEUTIL-MESSAGE DATEUTIL 334300 MOVE +2028 TO W-RETURN-CODE DATEUTIL 334400 PERFORM S3000-FINALIZATION DATEUTIL 334500 ELSE DATEUTIL 334600 SET T-MON-NDX TO W-WORK-MM DATEUTIL 334700 END-IF DATEUTIL 334800 WHEN 'ZM' DATEUTIL 334900 IF W-WORK-ZM < '01' OR W-WORK-ZM > '12' DATEUTIL 335000 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 335100 STRING 'DU2032-"' W-WORK-ZM '" IS NOT ' DATEUTIL 335200 'A VALID MONTH NUMBER.' DATEUTIL 335300 DELIMITED BY SIZE DATEUTIL 335400 INTO DATEUTIL-MESSAGE DATEUTIL 335500 MOVE +2032 TO W-RETURN-CODE DATEUTIL 335600 PERFORM S3000-FINALIZATION DATEUTIL 335700 ELSE DATEUTIL 335800 IF W-WORK-ZM > 9 DATEUTIL 335900 SET T-MON-NDX TO W-WORK-MM DATEUTIL 336000 ELSE DATEUTIL 336100 MOVE '0' TO DATEUTIL 336200 W-MONTH-ARRAY-BYTE (W-MONTH-NDX) DATEUTIL 336300 SET T-MON-NDX TO W-WORK-MM DATEUTIL 336400 END-IF DATEUTIL 336500 END-IF DATEUTIL 336600 WHEN OTHER DATEUTIL 336700 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 336800 STRING 'DU2033-THE ONLY VALID INPUT ' DATEUTIL 336900 '"MONTH" FORMATS ' DATEUTIL 337000 'ARE "MM", "MMM", "ZM", OR "MONTH".' DATEUTIL 337100 DELIMITED BY SIZE DATEUTIL 337200 INTO DATEUTIL-MESSAGE DATEUTIL 337300 MOVE +2033 TO W-RETURN-CODE DATEUTIL 337400 PERFORM S3000-FINALIZATION DATEUTIL 337500 END-EVALUATE. DATEUTIL 337600 DATEUTIL 337700 IF S-IS-A-LEAP-YEAR DATEUTIL 337800 COMPUTE W-JULIAN-DDD = T-MON-JUL-LEAP-BEGIN (T-MON-NDX) DATEUTIL 337900 + W-WORK-DD DATEUTIL 338000 - 1 DATEUTIL 338100 IF W-JULIAN-DDD > T-MON-JUL-LEAP-END (T-MON-NDX) DATEUTIL 338200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 338300 STRING 'DU2029-"' W-WORK-DD '" IS NOT ' DATEUTIL 338400 'A VALID DAY FOR MONTH: "' W-WORK-MONTH DATEUTIL 338500 '" IN "' W-WORK-YEAR '".' DATEUTIL 338600 DELIMITED BY SIZE DATEUTIL 338700 INTO DATEUTIL-MESSAGE DATEUTIL 338800 MOVE +2029 TO W-RETURN-CODE DATEUTIL 338900 PERFORM S3000-FINALIZATION DATEUTIL 339000 END-IF DATEUTIL 339100 ELSE DATEUTIL 339200 COMPUTE W-JULIAN-DDD = T-MON-JUL-BEGIN (T-MON-NDX) DATEUTIL 339300 + W-WORK-DD DATEUTIL 339400 - 1 DATEUTIL 339500 IF W-JULIAN-DDD > T-MON-JUL-END (T-MON-NDX) DATEUTIL 339600 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 339700 STRING 'DU2030-"' W-WORK-DD '" IS NOT ' DATEUTIL 339800 'A VALID DAY FOR MONTH: "' W-WORK-MONTH DATEUTIL 339900 '" IN "' W-WORK-YEAR '".' DATEUTIL 340000 DELIMITED BY SIZE DATEUTIL 340100 INTO DATEUTIL-MESSAGE DATEUTIL 340200 MOVE +2030 TO W-RETURN-CODE DATEUTIL 340300 PERFORM S3000-FINALIZATION DATEUTIL 340400 END-IF DATEUTIL 340500 END-IF. DATEUTIL 340600 DATEUTIL 340700 S9200-EXIT. DATEUTIL 340800 EXIT. DATEUTIL 340900/**************************************************************** DATEUTIL 341000* S9300-ISPF-VGET-VPUT * DATEUTIL 341100* THIS SECTION PERFORMS THE ISPF VARIABLE I/O INTO AND OUT OF * DATEUTIL 341200* THE PROGRAM. IF THE ACTION IS "OUTPUT" (VPUT), THE FINAL * DATEUTIL 341300* RETURN CODE IS CHECKED TO EITHER OUTPUT RESULTS OR AN ERROR * DATEUTIL 341400* MESSAGE. * DATEUTIL 341500***************************************************************** DATEUTIL 341600 S9300-ISPF-VGET-VPUT SECTION. DATEUTIL 341700 DATEUTIL 341800 IF W-RETURN-CODE = 0 DATEUTIL 341900 CALL C-ISPF USING W-ISPF-SERVICE C-ISPF-VARIABLE-NAMES, DATEUTIL 342000 C-SHARED-OPTION DATEUTIL 342100 IF RETURN-CODE > 8 DATEUTIL 342200 MOVE SPACES TO DATEUTIL-MESSAGE DATEUTIL 342300 STRING 'DU2031-AN ISPF ' W-ISPF-SERVICE ' FAILED ' DATEUTIL 342400 'WITH A RETURN CODE GREATER THAN 8.' DATEUTIL 342500 DELIMITED BY SIZE DATEUTIL 342600 INTO DATEUTIL-MESSAGE DATEUTIL 342700 MOVE +2031 TO W-RETURN-CODE DATEUTIL 342800 PERFORM S3000-FINALIZATION DATEUTIL 342900 END-IF DATEUTIL 343000 ELSE DATEUTIL 343100 CALL C-ISPF USING C-VDEFINE C-MESSAGE-VARIABLE-NAME, DATEUTIL 343200 DATEUTIL-MESSAGE, DATEUTIL 343300 C-MESSAGE-VARIABLE-F, DATEUTIL 343400 C-MESSAGE-VARIABLE-L DATEUTIL 343500 CALL C-ISPF USING W-ISPF-SERVICE C-MESSAGE-VARIABLE-NAME DATEUTIL 343600 C-SHARED-OPTION DATEUTIL 343700 END-IF. DATEUTIL 343800 DATEUTIL 343900 S9300-EXIT. DATEUTIL 344000 EXIT. DATEUTIL ./ ADD NAME=DAYOWEEK 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. DAYOWEEK. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* REMARKS: * 000700* THIS PROGRAM WILL SET A RETURN CODE EQUAL TO THE CURRENT * 000800* DAY OF THE WEEK (E.G. MONDAY = 1, SUNDAY = 7) * 001900***************************************************************** 003700 ENVIRONMENT DIVISION. 003900 INPUT-OUTPUT SECTION. 004100 FILE-CONTROL. 006100 DATA DIVISION. 006300 FILE SECTION. 008300 WORKING-STORAGE SECTION. 017900 PROCEDURE DIVISION. 018000 018500 ACCEPT RETURN-CODE FROM DAY-OF-WEEK. 018600 019100 GOBACK. ./ ADD NAME=DAYRC 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. DAYRC. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 001100* RETURN DAY OF THE WEEK NUMBER AS THE RETURN CODE. * 001200* 1 IS MONDAY 7 IS SUNDAY * 001600***************************************************************** 033300 ENVIRONMENT DIVISION. 033500 INPUT-OUTPUT SECTION. 034200 DATA DIVISION. 163200 PROCEDURE DIVISION. 163201 ACCEPT RETURN-CODE FROM DAY-OF-WEEK. 164200 GOBACK. ./ ADD NAME=DB2CAF TITLE 'CAF Interface' * Calling sequence * Initialization: * CALL DB2CAFI,(plannameR3:54 pm.,subsystemR3:54 pm.),VL * planname CL8 * subsystem CL8 (optional, default DSN) * Termination: * CALL DB2CAFT * Return: * register 15: ReturnCode (from CAF) DB2CAFI CSECT * initialize CAF processing * initialize addressing COPY REGS STM R14,R12,12(R13) save registers BALR R11,0 base register USING *,R11 LA R15,SA A(save-area) ST R13,4(R15) backward ptr ST R15,8(R13) forward ptr LR R13,R15 A(new save-area) LM R1,R2,0(R1) load parameters * R1: A(planname); R2: A(subsystem) MVC PLANNAME,0(R1) planname LTR R1,R1 test whether 2 parameters passed BM *+10 no second parameter (subsystem) MVC SSID,0(R2) subsystem (default: DSN) * load CAF modules LOAD EP=DSNALI ST R0,LIALI LOAD EP=DSNHLI2 ST R0,LISQL * CONNECT L R15,LIALI A(DSNALI) CALL (15),(CONNECT,SSID,TECB,SECB,RIBPTR),VL BAL R14,CHECK BNZ EOP :error return * OPEN L R15,LIALI A(DSNALI) CALL (15),(OPEN,SSID,PLANNAME),VL BAL R14,CHECK B EOP terminate CHECK BALR R9,0 USING *,R9 * test CAF return code, display message if non-zero ST R14,CHECKSA save return address LTR R15,R15 CAF return code BZR R14 :no error BAL R14,CVT_CODE MVC CAF_MSG_R15,CODE LR R15,R0 N R15,=X'000000FF' BAL R14,CVT_CODE MVC CAF_MSG_R0,CODE TPUT CAF_MSG,CAF_MSG_L display message L R14,CHECKSA BR R14 CHECKSA DS A CAF_MSG DC C'CAF RC:' CAF_MSG_R15 DS CL4 return code DC C' REASON:' CAF_MSG_R0 DS CL4 reason code CAF_MSG_L EQU *-CAF_MSG message length CVT_CODE DS 0H * convert code (R15) to display format () CVD R15,D MVC CODE,=X'40212020' ED CODE,D+6 BR R14 CODE DS CL4 D DS 0D,PL8 LTORG DROP R9,R11 ENTRY DB2CAFT DB2CAFT DS 0D * terminate CAF processing * initialize addressing STM R14,R12,12(R13) save registers BALR R11,0 USING *,R11 LA R15,SA A(save-area) ST R13,4(R15) backward ptr ST R15,8(R13) forward ptr LR R13,R15 A(new save-area) * CLOSE L R15,LIALI A(DSNALI) CALL (15),(CLOSE,TERMOP),VL LTR R15,R15 BNZ EOP :error routine * DISCONNECT L R15,LIALI CALL (15),(DISCONNECT),VL LTR R15,R15 BNZ EOP :error routine DELETE EP=DSNALI DELETE EP=DSNHLI2 B EOP DROP R11 ENTRY DSNHLI DSNHLI DS 0D STM R14,R12,12(R13) BALR R10,0 USING *,R10 LA R15,SA ST R13,4(R15) ST R15,8(R13) LR R13,R15 L R15,LISQL A(DSNHLI2) BALR R14,R15 EOP DS 0H program end L R13,4(R13) restore A(old save-area) RETURN (14,12),RC=(15) SA DS 18A register save-area * entry-point addresses LIALI DS A A(DSNALI) LISQL DS A A(DSNHLI2) * constants CONNECT DC CL12'CONNECT' OPEN DC CL12'OPEN' CLOSE DC CL12'CLOSE' DISCONNECT DC CL12'DISCONNECT' SSID DC CL4'DSN' DB2 subsystem name (default) PLANNAME DC CL8' ' plan-name TERMOP DC CL4'SYNC' * CALL parameters TECB DC F'0' SECB DC F'0' RIBPTR DC A(0) END ./ ADD NAME=DB2SIZE 00001 * STARTOPT: 03/06/90 00003 * COMPOPT: LINECOUNT(60),XREF,VBREF,OFFSET,MAP,DATA(31),SEQ LV004 00004 * LINKOPT: XREF,LIST CL**5 00008 * ENDOPT: CL**5 00009 ****************************************************************** CL**4 00010 IDENTIFICATION DIVISION. CL**4 00011 ****************************************************************** CL**4 00012 PROGRAM-ID. DB2SIZE. CL**4 00013 INSTALLATION EDS - DSEC. CL**4 00014 AUTHOR. DON MCHDOGKINS CL**4 00015 DATE-WRITTEN. JUNE 29, 1990. CL**4 00016 DATE-COMPILED. CL**4 00017 CL**4 00018 CL**4 00019 *************************************************************** CL**4 00020 * PROGRAM NAME: DB2SIZE CL**4 00021 * CL**4 00022 * FUNCTION: THIS PROGRAM WILL CALCULATE THE SIZES NEEDED CL**4 00023 * FOR A TABLESPACE AND AN INDEX. CL**4 00024 * CL**4 00026 * CL**4 00027 * CL**4 00028 * ENTRY POINT: TOP-OF-PROGRAM - DB2SIZE CL**4 00029 * CL**4 00030 * EXITS NORMAL: CL**4 00031 * CL**4 00032 * EXITS ABNORMAL: ABORT SECTION CL**4 00033 * CL**4 00034 * RETURN CODES: NONE CL**4 00035 * CL**4 00038 * CL**4 00039 * CL**4 00040 * DATABASE ACCESS: CL**4 00041 * CL**4 00044 * CL**4 00045 * CL**4 00048 * CL**4 00061 *************************************************************** CL**4 00050 * CL**4 00051 *-------------------------------------------------------------- CL**4 00052 * MODIFICATION LOG CL**4 00053 *-------------------------------------------------------------- CL**4 00054 * INIT ! DATE ! COMMENTS CL**4 00055 *======!========!============================================== CL**4 00057 *______!________!______________________________________________ CL**4 00058 *______!________!______________________________________________ CL**4 00059 *______!________!______________________________________________ CL**4 00060 * CL**4 00061 *************************************************************** CL**4 00062 /************************************************************** CL**4 00063 ENVIRONMENT DIVISION. CL**4 00064 *************************************************************** CL**4 00065 CONFIGURATION SECTION. CL**4 00066 INPUT-OUTPUT SECTION. CL**4 00067 CL**4 00068 FILE-CONTROL. CL**4 00069 CL**4 00071 CL**4 00072 /************************************************************** CL**4 00073 DATA DIVISION. CL**4 00074 *************************************************************** CL**4 00075 CL**4 00076 FILE SECTION. CL**4 00077 CL**4 00078 *************************************************************** CL**4 00079 * O U T P U T F I L E S CL**4 00080 *************************************************************** CL**4 00081 CL**4 00082 CL**4 00091 CL**4 00092 /***************************************************************** CL**4 00093 WORKING-STORAGE SECTION. CL**4 00094 ****************************************************************** CL**4 00095 CL**4 00096 01 FILLER PIC X(40) VALUE CL**4 00097 'DB2SIZE WORKING STORAGE STARTS HERE'. CL**4 00098 CL**4 00099 CL**4 00100 ****************************************************************** CL**4 00101 * A C C U M U L A T O R S * CL**4 00102 ****************************************************************** CL**4 00103 CL**4 00114 01 ACCUMULATOR. CL**4 05 A-I PIC 99. 05 A-J PIC 99. 00108 CL**4 00109 CL**4 00110 ****************************************************************** CL**4 00111 * C O N S T A N T S * CL**4 00112 ****************************************************************** CL**4 00113 CL**4 00114 01 CONSTANTS. CL**4 05 C-PLAN PIC X(08) VALUE 'DB2SIZE '. 05 VDEFINE PIC X(08) VALUE 'VDEFINE '. 05 VGET PIC X(08) VALUE 'VGET '. 05 VPUT PIC X(08) VALUE 'VPUT '. 05 EDIF PIC X(08) VALUE 'EDIF '. 05 EDITSET PIC X(08) VALUE 'EDITSET '. 05 DISPLAYE PIC X(08) VALUE 'DISPLAY '. 05 EDIFPROF PIC X(08) VALUE 'EDIFPROF'. 05 SETMSG PIC X(08) VALUE 'SETMSG '. 05 CHAR PIC X(04) VALUE 'CHAR'. 05 FIXED PIC X(01) VALUE 'F'. 05 PROFILE PIC X(08) VALUE 'PROFILE '. 05 SHARED PIC X(08) VALUE 'SHARED '. 05 C-RETURN PIC X(08) VALUE '(RETURN)'. 05 C-ROWCOUNT PIC X(10) VALUE '(ROWCOUNT)'. 05 C-ROWLEN PIC X(08) VALUE '(ROWLEN)'. 05 C-VARCHAR PIC X(09) VALUE '(VARCHAR)'. 05 C-NULL PIC X(06) VALUE '(NULL)'. 05 C-PAGESIZE PIC X(10) VALUE '(PAGESIZE)'. 05 C-PCTFREE PIC X(09) VALUE '(PCTFREE)'. 05 C-FREEPAGE PIC X(10) VALUE '(FREEPAGE)'. 05 C-PAGEUSED PIC X(10) VALUE '(PAGEUSED)'. 05 C-RECPAGE PIC X(09) VALUE '(RECPAGE)'. 05 C-KBYTES PIC X(08) VALUE '(KBYTES)'. 05 C-TRKS PIC X(06) VALUE '(TRKS)'. 05 C-CYLS PIC X(06) VALUE '(CYLS)'. 05 C-LEVELS PIC X(08) VALUE '(LEVELS)'. 05 C-TYPEIND PIC X(09) VALUE '(TYPEIND)'. 05 C-TABLESPACE PIC X(01) VALUE 'T'. 05 SIZE007 PIC X(08) VALUE 'SIZE007 '. 05 C12 PIC S9(09) COMP VALUE +12. 05 C9 PIC S9(09) COMP VALUE +9. 05 C4 PIC S9(09) COMP VALUE +4. 05 C3 PIC S9(09) COMP VALUE +3. 05 C1 PIC S9(09) COMP VALUE +1. 05 C-HALF PIC S9V9 VALUE +0.5. 05 C-TRKS-3380 PIC S99 VALUE +10. 05 C-CYLS-3380 PIC S999 VALUE +150. 05 C-TRKS-3390 PIC S99 VALUE +12. 05 C-CYLS-3390 PIC S999 VALUE +180. 00132 CL**4 00133 CL**4 00134 ****************************************************************** CL**4 00135 * S W I T C H E S * CL**4 00136 ****************************************************************** CL**4 00137 CL**4 00138 *01 SWITCHES. CL**4 00139 CL**4 00154 CL**4 00155 ****************************************************************** CL**4 00156 * W O R K A R E A S * CL**4 00157 ****************************************************************** CL**4 00158 CL**4 00159 01 WORKAREAS. CL**4 05 V-TYPEIND PIC X(01). 05 V-ROWCOUNT PIC X(09). 05 N-ROWCOUNT REDEFINES V-ROWCOUNT PIC 9(09). 05 V-ROWLENGTH PIC X(04). 05 N-ROWLENGTH REDEFINES V-ROWLENGTH PIC 9(04). 05 V-VARCHAR PIC X(03). 05 N-VARCHAR REDEFINES V-VARCHAR PIC 9(03). 05 V-NULLCHAR PIC X(03). 05 N-NULLCHAR REDEFINES V-NULLCHAR PIC 9(03). 05 V-PAGESIZE PIC X(09). 05 N-PAGESIZE REDEFINES V-PAGESIZE PIC 9(09). 05 V-PCTFREE PIC X(09). 05 N-PCTFREE REDEFINES V-PCTFREE PIC 9(09). 05 V-FREEPAGE PIC X(09). 05 N-FREEPAGE REDEFINES V-FREEPAGE PIC 9(09). 05 V-PAGEUSED PIC ZZZZZZZZZZZ9. 05 W-PAGEUSED PIC 9(12). 05 W-REMAIN PIC 9(12). 05 V-TRKS PIC ZZZZZZZZ9. 05 W-TRKS PIC 9(09). 05 V-CYLS PIC ZZZZZZZZ9. 05 W-CYLS PIC 9(09). 05 V-LEVELS PIC 9. 05 V-KBYTES PIC ZZZZZZZZZZZ9. 05 W-KBYTES PIC 9(12). 05 V-RECPAGE PIC ZZZZZZZZ9. 05 V-RETURN PIC ZZZ9. 05 W-USEPAGE PIC 9(09). 05 W-RECPAGE PIC 9(09). 05 W-LEAF-PAGE PIC 9(09). 05 W-TEMP-PAGE PIC 9(09). CL**4 00159 01 TEMP-BUFFER PIC X(09). CL**4 01 TEMP-BUFFER-TABLE REDEFINES TEMP-BUFFER. 05 TEMP-BUFFER-CHAR PIC X(01) OCCURS 9 TIMES. 00159 01 HOLD-BUFFER PIC X(09). CL**4 01 HOLD-BUFFER-TABLE REDEFINES HOLD-BUFFER. 05 HOLD-BUFFER-CHAR PIC X(01) OCCURS 9 TIMES. 00159 01 TEMP4-BUFFER PIC X(04). CL**4 01 TEMP4-BUFFER-TABLE REDEFINES TEMP4-BUFFER. 05 TEMP4-BUFFER-CHAR PIC X(01) OCCURS 4 TIMES. 00159 01 HOLD4-BUFFER PIC X(04). CL**4 01 HOLD4-BUFFER-TABLE REDEFINES HOLD4-BUFFER. 05 HOLD4-BUFFER-CHAR PIC X(01) OCCURS 4 TIMES. 00195 CL**4 00159 01 TEMP3-BUFFER PIC X(03). CL**4 01 TEMP3-BUFFER-TABLE REDEFINES TEMP3-BUFFER. 05 TEMP3-BUFFER-CHAR PIC X(01) OCCURS 3 TIMES. 00159 01 HOLD3-BUFFER PIC X(03). CL**4 01 HOLD3-BUFFER-TABLE REDEFINES HOLD3-BUFFER. 05 HOLD3-BUFFER-CHAR PIC X(01) OCCURS 3 TIMES. 00195 CL**4 00389 CL**4 00155 ****************************************************************** CL**4 00156 * T A B L E S * CL**4 00157 ****************************************************************** CL**4 00158 CL**4 00391 CL**4 00392 /***************************************************************** CL**4 00393 * D A T A B A S E R E C O R D S (DCLGENS) * CL**4 00394 ****************************************************************** CL**4 00395 CL**4 00396 CL**4 00429 CL**4 00430 01 FILLER PIC X(48) VALUE CL**4 00431 'PROGRAM DB2SIZE WORKING STORAGE ENDS HERE'. CL**4 00432 CL**4 00433 CL**4 00434 /***************************************************************** CL**4 00435 PROCEDURE DIVISION. CL**4 00436 ****************************************************************** CL**4 00437 CL**4 00438 ****************************************************************** CL**4 00439 INITIALIZATION. CL**4 00440 ****************************************************************** CL**4 00441 CL**4 CALL 'ISPLINK' USING VDEFINE, C-RETURN, V-RETURN, CHAR, C4. CALL 'ISPLINK' USING VDEFINE, C-TYPEIND, V-TYPEIND, CHAR, C1. CALL 'ISPLINK' USING VDEFINE, C-LEVELS, V-LEVELS, CHAR, C1. CALL 'ISPLINK' USING VDEFINE, C-ROWCOUNT, V-ROWCOUNT, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-ROWLEN, V-ROWLENGTH, CHAR, C4. CALL 'ISPLINK' USING VDEFINE, C-VARCHAR, V-VARCHAR, CHAR, C3. CALL 'ISPLINK' USING VDEFINE, C-NULL, V-NULLCHAR, CHAR, C3. CALL 'ISPLINK' USING VDEFINE, C-PAGESIZE, V-PAGESIZE, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-PCTFREE, V-PCTFREE, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-FREEPAGE, V-FREEPAGE, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-PAGEUSED, V-PAGEUSED, CHAR, C12. CALL 'ISPLINK' USING VDEFINE, C-KBYTES, V-KBYTES, CHAR, C12. CALL 'ISPLINK' USING VDEFINE, C-RECPAGE, V-RECPAGE, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-TRKS, V-TRKS, CHAR, C9. CALL 'ISPLINK' USING VDEFINE, C-CYLS, V-CYLS, CHAR, C9. CALL 'ISPLINK' USING VGET, C-TYPEIND, PROFILE. CALL 'ISPLINK' USING VGET, C-ROWCOUNT, PROFILE. CALL 'ISPLINK' USING VGET, C-ROWLEN, PROFILE. CALL 'ISPLINK' USING VGET, C-VARCHAR, PROFILE. CALL 'ISPLINK' USING VGET, C-NULL, PROFILE. CALL 'ISPLINK' USING VGET, C-PAGESIZE, PROFILE. CALL 'ISPLINK' USING VGET, C-PCTFREE, PROFILE. CALL 'ISPLINK' USING VGET, C-FREEPAGE, PROFILE. 00438 ****************************************************************** CL**4 00439 MAINLINE. CL**4 00440 ****************************************************************** CL**4 00441 CL**4 PERFORM S0100-MAIN-PROCESS. 00438 ****************************************************************** CL**4 00439 FINALIZATION. CL**4 00440 ****************************************************************** CL**4 00441 CL**4 MOVE ZERO TO V-RETURN. 00441 CL**4 CALL 'ISPLINK' USING VPUT, C-RETURN, PROFILE. CALL 'ISPLINK' USING VPUT, C-TRKS, PROFILE. CALL 'ISPLINK' USING VPUT, C-CYLS, PROFILE. CALL 'ISPLINK' USING VPUT, C-PAGEUSED, PROFILE. CALL 'ISPLINK' USING VPUT, C-RECPAGE, PROFILE. CALL 'ISPLINK' USING VPUT, C-KBYTES, PROFILE. CALL 'ISPLINK' USING VPUT, C-LEVELS, PROFILE. GOBACK. 01109 CL**4 ****************************************************************** CL**4 *S0100-MAIN-PROCESS CL**4 ****************************************************************** CL**4 CL**4 S0100-MAIN-PROCESS SECTION. PERFORM S0200-PARSE-DATA. IF V-TYPEIND = C-TABLESPACE THEN PERFORM S0300-CALC-TABLESPACE ELSE PERFORM S0400-CALC-INDEX. DIVIDE C-TRKS-3380 INTO W-PAGEUSED GIVING W-TRKS REMAINDER W-REMAIN. IF W-REMAIN > 0 THEN COMPUTE W-TRKS = W-TRKS + 1. DIVIDE 15 INTO W-TRKS GIVING W-CYLS REMAINDER W-REMAIN. IF W-REMAIN > 0 THEN COMPUTE W-CYLS = W-CYLS + 1. MOVE W-TRKS TO V-TRKS. MOVE W-CYLS TO V-CYLS. 01112 S0100-EXIT. CL**4 EXIT. 01109 CL**4 ****************************************************************** CL**4 *S0200-PARSE-DATA CL**4 * CL**4 * DESCRIPTION: - PARSE THE NINE CHARACTER DATA FOR NUMERICS AND CL**4 * STORE IN NUMERIC FIELD CL**4 ****************************************************************** CL**4 CL**4 S0200-PARSE-DATA SECTION. MOVE V-PCTFREE TO TEMP-BUFFER. MOVE 10 TO A-J. MOVE ZERO TO HOLD-BUFFER. PERFORM VARYING A-I FROM 9 BY -1 UNTIL A-I = 0 IF TEMP-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP-BUFFER-CHAR(A-I) TO HOLD-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD-BUFFER TO N-PCTFREE. MOVE V-FREEPAGE TO TEMP-BUFFER. MOVE 10 TO A-J. MOVE ZERO TO HOLD-BUFFER. PERFORM VARYING A-I FROM 9 BY -1 UNTIL A-I = 0 IF TEMP-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP-BUFFER-CHAR(A-I) TO HOLD-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD-BUFFER TO N-FREEPAGE MOVE V-ROWCOUNT TO TEMP-BUFFER. MOVE 10 TO A-J. MOVE ZERO TO HOLD-BUFFER. PERFORM VARYING A-I FROM 9 BY -1 UNTIL A-I = 0 IF TEMP-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP-BUFFER-CHAR(A-I) TO HOLD-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD-BUFFER TO N-ROWCOUNT MOVE V-ROWLENGTH TO TEMP4-BUFFER. MOVE 5 TO A-J. MOVE ZERO TO HOLD4-BUFFER. PERFORM VARYING A-I FROM 4 BY -1 UNTIL A-I = 0 IF TEMP4-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP4-BUFFER-CHAR(A-I) TO HOLD4-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD4-BUFFER TO N-ROWLENGTH. MOVE V-VARCHAR TO TEMP3-BUFFER. MOVE 4 TO A-J. MOVE ZERO TO HOLD3-BUFFER. PERFORM VARYING A-I FROM 3 BY -1 UNTIL A-I = 0 IF TEMP3-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP3-BUFFER-CHAR(A-I) TO HOLD3-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD3-BUFFER TO N-VARCHAR. MOVE V-NULLCHAR TO TEMP3-BUFFER. MOVE 4 TO A-J. MOVE ZERO TO HOLD3-BUFFER. PERFORM VARYING A-I FROM 3 BY -1 UNTIL A-I = 0 IF TEMP3-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP3-BUFFER-CHAR(A-I) TO HOLD3-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD3-BUFFER TO N-NULLCHAR. MOVE V-PAGESIZE TO TEMP-BUFFER. MOVE 10 TO A-J. MOVE ZERO TO HOLD-BUFFER. PERFORM VARYING A-I FROM 9 BY -1 UNTIL A-I = 0 IF TEMP-BUFFER-CHAR(A-I) > SPACES THEN COMPUTE A-J = A-J - 1 MOVE TEMP-BUFFER-CHAR(A-I) TO HOLD-BUFFER-CHAR(A-J) END-IF END-PERFORM. MOVE HOLD-BUFFER TO N-PAGESIZE. 01112 S0200-EXIT. CL**4 EXIT. 01109 CL**4 ****************************************************************** CL**4 *S0300-CALC-TABLESPACE CL**4 * CL**4 * DESCRIPTION: CALULATE THE SPACE NEEDED FOR A TABLSPACE CL**4 * CL**4 ****************************************************************** CL**4 CL**4 S0300-CALC-TABLESPACE SECTION. COMPUTE N-ROWLENGTH = 2 * N-VARCHAR + 8 + N-NULLCHAR + N-ROWLENGTH. COMPUTE W-USEPAGE ROUNDED = 4074 * (100 - N-PCTFREE) / 100 - C-HALF. IF W-USEPAGE < N-ROWLENGTH THEN CALL 'ISPLINK' USING SETMSG SIZE007 MOVE +1000 TO V-RETURN CALL 'ISPLINK' USING VPUT, C-RETURN, PROFILE GOBACK END-IF. COMPUTE W-RECPAGE ROUNDED = W-USEPAGE / N-ROWLENGTH - C-HALF. IF W-RECPAGE > 127 THEN MOVE 127 TO W-RECPAGE. DIVIDE W-RECPAGE INTO N-ROWCOUNT GIVING W-PAGEUSED REMAINDER W-REMAIN. IF W-REMAIN > 0 THEN COMPUTE W-PAGEUSED = 3 + W-PAGEUSED ELSE COMPUTE W-PAGEUSED = 2 + W-PAGEUSED. IF N-FREEPAGE > 0 THEN COMPUTE W-PAGEUSED ROUNDED = W-PAGEUSED * (1 + N-FREEPAGE) / N-FREEPAGE - C-HALF. COMPUTE W-KBYTES = W-PAGEUSED * N-PAGESIZE. MOVE W-KBYTES TO V-KBYTES. MOVE W-RECPAGE TO V-RECPAGE. MOVE W-PAGEUSED TO V-PAGEUSED. 01112 S0300-EXIT. CL**4 EXIT. 01109 CL**4 ****************************************************************** CL**4 *S0400-CALC-INDEX CL**4 * CL**4 * DESCRIPTION: CALULATE THE SPACE NEEDED FOR AN INDEX CL**4 * CL**4 ****************************************************************** CL**4 CL**4 S0400-CALC-INDEX SECTION. COMPUTE N-ROWLENGTH = 2 * N-NULLCHAR + N-ROWLENGTH. IF N-PAGESIZE = 1 THEN COMPUTE W-RECPAGE ROUNDED = (4050 * (100 - N-PCTFREE) / 100) / (N-ROWLENGTH + 4) - C-HALF ELSE COMPUTE W-RECPAGE ROUNDED = ((100 - N-PCTFREE) / 100) * (4067 - N-PAGESIZE * (N-ROWLENGTH + 21)) / (N-ROWLENGTH + 4) - C-HALF. DIVIDE W-RECPAGE INTO N-ROWCOUNT GIVING W-LEAF-PAGE REMAINDER W-REMAIN. IF W-REMAIN > 0 THEN COMPUTE W-LEAF-PAGE = W-LEAF-PAGE + 1. MOVE W-LEAF-PAGE TO W-TEMP-PAGE. MOVE 1 TO V-LEVELS. PERFORM UNTIL W-TEMP-PAGE = 1 DIVIDE W-RECPAGE INTO W-TEMP-PAGE GIVING W-TEMP-PAGE REMAINDER W-REMAIN END-DIVIDE IF W-REMAIN > 0 THEN COMPUTE W-TEMP-PAGE = W-TEMP-PAGE + 1 END-IF COMPUTE W-LEAF-PAGE = W-TEMP-PAGE + W-LEAF-PAGE COMPUTE V-LEVELS = V-LEVELS + 1 END-PERFORM. COMPUTE W-LEAF-PAGE = W-LEAF-PAGE + 2. IF N-FREEPAGE > 0 THEN COMPUTE W-LEAF-PAGE ROUNDED = (W-LEAF-PAGE * (1 + N-FREEPAGE) / N-FREEPAGE) - C-HALF. COMPUTE W-KBYTES = W-LEAF-PAGE * 4. MOVE W-KBYTES TO V-KBYTES. MOVE W-RECPAGE TO V-RECPAGE. MOVE W-LEAF-PAGE TO W-PAGEUSED. MOVE W-LEAF-PAGE TO V-PAGEUSED. 01112 S0300-EXIT. CL**4 EXIT. ./ ADD NAME=DB2TABL ****************************************************************** * I D E N T I F I C A T I O N D I V I S I O N * ****************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. DB2TABL. AUTHOR. DAVE LEIGH. DATE-WRITTEN. NOVEMBER 1, 1989. DATE-COMPILED. ****************************************************************** * PROGRAM NAME: DB2TABL * * * * FUNCTION: THIS PROGRAM IS PART OF AN ISPF-BASED DB2 TABLE * * LOAD UTILITY WHICH MAKES USE OF THE DB2 SAMPLE * * PROGRAM DSNTEP2. DSNTEP2 PROVIDES "BATCH SPUFI" * * CAPABILITIES. THIS PROGRAM CREATES "INSERT" SQL * * STATEMENTS FROM AN ISPF TABLE ($$$$D2TL) AND A * * LOAD DATASET. THESE ARE THEN PASSED TO THE DSNTEP2 * * PROGRAM FOR PROCESSING. * * * * THIS PROGRAM WILL ISSUE ISPF CALLS TO "TBSKIP" * * THROUGH THE ISPF TABLE. * * * * INPUTS: USER ENTERED INFORMATION IN AN ISPF TABLE. * * INFILE - DATASET OF LOAD DATA. * * * * OUTPUTS: OUTFILE - DATASET OF SQL INSERT STATEMENTS. * * * * EXITS NORMAL: S3000-FINALIZATION * * * * EXITS ABNORMAL: NONE * * * * SWITCHES: S-FILE-SWITCH - EOF INFILE SWITCH. * * * * TABLES: NONE * * * * COPY MEMBERS: NONE * * * *--------------------------------------------------------------- * * MODIFICATION LOG * *--------------------------------------------------------------- * * INIT . DATE . COMMENTS * *======¬========¬=============================================== * ****************************************************************** /***************************************************************** * E N V I R O N M E N T D I V I S I O N * ****************************************************************** ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. IBM-370. OBJECT-COMPUTER. IBM-370. / INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT IN-LOAD-FILE ASSIGN INFILE FILE STATUS IS W-FILE-STATUS-IN. SELECT OUT-SQL-INSERT ASSIGN OUTFILE FILE STATUS IS W-FILE-STATUS-OUT. DATA DIVISION. FILE SECTION. /**************************************************************** ***************************************************************** ** ** ** IN-LOAD-FILE FILE CONTAINS THE DATA TO BE LOADED INTO DB2 ** ** ** ***************************************************************** ***************************************************************** FD IN-LOAD-FILE BLOCK CONTAINS 0 RECORDS RECORD CONTAINS 0 LABEL RECORDS ARE STANDARD DATA RECORD IS IN-LOAD-FILE-RECORD. 01 IN-LOAD-FILE-RECORD PIC X(32767). /**************************************************************** ***************************************************************** ** ** ** OUT-SQL-INSERT CONTAINS THE CREATED SQL INSERT STATEMENTS. ** ** ** ***************************************************************** ***************************************************************** FD OUT-SQL-INSERT BLOCK CONTAINS 0 RECORDS RECORDING MODE IS F LABEL RECORDS ARE STANDARD DATA RECORD IS OUT-SQL-INSERT-RECORD. 01 OUT-SQL-INSERT-RECORD PIC X(80). /***************************************************************** * W O R K I N G - S T O R A G E S E C T I O N * ****************************************************************** WORKING-STORAGE SECTION. 01 WS-START PIC X(45) VALUE '**** DB2TABL WORKING-STORAGE STARTS HERE ****'. ****************************************************************** * A C C U M U L A T O R S * ****************************************************************** 01 A-ACCUMULATORS. 05 FILLER PIC X(24) VALUE '.ACCUMULATORS START HERE'. 05 A-ISPF-CALLS-MADE PIC S9(09) COMP-3 VALUE +0. 05 A-ISPF-CALLS-MADE-DIS PIC 9(09) VALUE 0. 05 A-RECORDS-READ-INCR PIC S9(09) COMP-3 VALUE +0. 88 A-DISPLAY-RECORD-COUNT VALUE +100. 05 A-RECORDS-READ PIC S9(09) COMP-3 VALUE +0. 05 A-RECORDS-READ-DIS PIC 9(09) VALUE 0. 05 A-RECORDS-WRITTEN PIC S9(09) COMP-3 VALUE +0. 05 A-RECORDS-WRITTEN-DIS PIC 9(09) VALUE 0. ****************************************************************** * C O N S T A N T S * ****************************************************************** 01 C-CONSTANTS. 05 FILLER PIC X(21) VALUE '.CONSTANTS START HERE'. *** RETURN CODES *** 05 C-NORMAL-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0. 05 C-OK-RETURN-CODE PIC S9(08) COMP SYNC VALUE +4. 05 C-PASSABLE-RETURN-CODE PIC S9(08) COMP SYNC VALUE +8. 05 C-END-TABLE-RETURN-CODE PIC S9(08) COMP SYNC VALUE +8. *** MESSAGES *** 05 C-NO-MESSAGE PIC X(50) VALUE '=================================================='. *** ISPF VARIABLE FIELD LENGTHS FOR VDEFINES *** 05 C-KEY-LEN PIC S9(06) COMP SYNC VALUE +1. 05 C-LRECL-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-DB2DBASE-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-TVNAME-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-COL1-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-COL2-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-FLEN-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-DB2SCALE-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-NULLS-LEN PIC S9(06) COMP SYNC VALUE +8. 05 C-FIELD-LEN PIC S9(06) COMP SYNC VALUE +18. 05 C-TYPE-LEN PIC S9(06) COMP SYNC VALUE +18. 05 C-DEFAULT-LEN PIC S9(06) COMP SYNC VALUE +50. *** ISPF VARIABLE FIELD NAME LITERALS *** 05 C-TVNAME PIC X(08) VALUE '(TVNAME)'. 05 C-LRECL PIC X(07) VALUE '(LRECL)'. 05 C-KEY PIC X(05) VALUE '(KEY)'. 05 C-COL1 PIC X(06) VALUE '(COL1)'. 05 C-COL2 PIC X(06) VALUE '(COL2)'. 05 C-FLEN PIC X(06) VALUE '(FLEN)'. 05 C-DB2SCALE PIC X(10) VALUE '(DB2SCALE)'. 05 C-DB2DBASE PIC X(10) VALUE '(DB2DBASE)'. 05 C-NULLS PIC X(07) VALUE '(NULLS)'. 05 C-FIELD PIC X(07) VALUE '(FIELD)'. 05 C-TYPE PIC X(06) VALUE '(TYPE)'. 05 C-DEFAULT PIC X(09) VALUE '(DEFAULT)'. *** ISPF OPERATION NAMES AND PARAMETERS *** 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 05 C-VGET PIC X(08) VALUE 'VGET '. 05 C-TBSKIP PIC X(08) VALUE 'TBSKIP '. 05 C-TBTOP PIC X(08) VALUE 'TBTOP '. 05 C-CHAR PIC X(08) VALUE 'CHAR '. 05 C-ISPF-TABLE PIC X(08) VALUE '$$$$D2TL'. *** VARIABLES TO VGET/VPUT *** 05 C-VGET-VPUT-VARIABLES. 10 FILLER PIC X(23) VALUE '(LRECL TVNAME DB2DBASE)'. *** MISCELLANEOUS *** 05 C-FILE-MAX PIC S9(08) COMP VALUE +32767. 05 C-MAX-TABLE-ENTRIES PIC S9(08) COMP VALUE +400. 05 C-ALPHA-MAX PIC S9(08) COMP VALUE +10. 05 C-DIGITS-MAX PIC S9(08) COMP VALUE +18. 05 C-ULTIMATE-COLUMN PIC S9(08) COMP VALUE +72. 05 C-FIELD-END PIC X(10) VALUE ') VALUES ('. 05 C-TIMESTAMP PIC X(09) VALUE 'TIMESTAMP'. 05 C-ISPF PIC X(08) VALUE 'ISPLINK '. 05 C-DATE PIC X(05) VALUE 'DATE('. 05 C-TIME PIC X(05) VALUE 'TIME('. 05 C-CHAR-DEFAULT PIC X(04) VALUE ','' '''. 05 C-INSERT-END PIC X(02) VALUE ');'. 05 C-LEFT-PAREN PIC X(01) VALUE '('. 05 C-YES PIC X(01) VALUE 'Y'. 05 C-NO PIC X(01) VALUE 'N'. 05 C-DECIMAL PIC X(01) VALUE '.'. 05 C-PERIOD PIC X(01) VALUE '.'. 05 C-PLUS PIC X(01) VALUE '+'. 05 C-MINUS PIC X(01) VALUE '-'. 05 C-COMMA PIC X(01) VALUE ','. 05 C-QUOTE PIC X(01) VALUE ''''. ****************************************************************** * S W I T C H E S * ****************************************************************** 01 S-SWITCHES. 05 FILLER PIC X(20) VALUE '.SWITCHES START HERE'. 05 S-FILE-SWITCH PIC X(01) VALUE 'N'. 88 S-END-OF-INPUT-FILE VALUE 'Y'. 88 S-STILL-MORE-RECORDS VALUE 'N'. 05 S-ARRAY-SWITCH PIC X(01) VALUE 'N'. 88 S-VALUE-NOT-FOUND VALUE 'N'. 88 S-PACKED-VALUE-FOUND VALUE 'Y'. 88 S-NUMERIC-VALUE-FOUND VALUE 'Y'. ****************************************************************** * W O R K - A R E A S * ****************************************************************** 01 W-WORK-AREAS. 05 FILLER PIC X(22) VALUE '.WORK AREAS START HERE'. *** INPUT RECORD ARRAY *** 05 FILLER PIC X(17) VALUE '.INPUT FILE BEGIN'. 05 W-INPUT-FILE PIC X(32767) VALUE SPACES. 05 W-INPUT-FILE-TABLE REDEFINES W-INPUT-FILE. 10 W-INPUT-FILE-BYTE PIC X(01) OCCURS 32767 TIMES INDEXED BY W-INPUT-FILE-NDX. 05 FILLER PIC X(15) VALUE '.INPUT FILE END'. *** FIELD WORKING AREAS *** 05 W-SIGNED-NUMERIC PIC S9(18) SIGN IS LEADING SEPARATE. 05 W-NUMERIC PIC S9(18) COMP-3 VALUE +0. 05 W-ALPHA-HOLD REDEFINES W-NUMERIC. 10 W-ALPHA-BYTE PIC X(01) OCCURS 10 TIMES INDEXED BY W-ALPHA-NDX-1 W-ALPHA-NDX-2. 05 W-TALLY PIC S9(08) COMP-3 VALUE +0. 88 W-MINUS-FOUND VALUE +1 THRU +32767. 88 W-DATE-FOUND VALUE +1 THRU +32767. 88 W-TIME-FOUND VALUE +1 THRU +32767. 88 W-TIMESTAMP-FOUND VALUE +1 THRU +32767. 88 W-PENULTIMATE-COLUMN VALUE +71. 88 W-ULTIMATE-COLUMN VALUE +72. 88 W-MATCHED-QUOTE-PAIR VALUE +2. 88 W-NO-QUOTES-FOUND VALUE +0. 05 W-SIGN PIC X(01) VALUE SPACES. 05 W-HOLD PIC X(32767) VALUE SPACES. 05 W-ARRAY REDEFINES W-HOLD. 10 W-BYTE PIC X(01) OCCURS 32767 TIMES INDEXED BY W-NDX-1 W-NDX-2. *** WORKING-STORAGE BUCKETS FOR ISPF VARIABLES *** 05 W-TVNAME PIC X(08) VALUE SPACES. 05 W-DB2DBASE PIC X(08) VALUE SPACES. 05 W-LRECL PIC X(08) VALUE SPACES. 05 W-LRECL-ARRAY REDEFINES W-LRECL. 10 W-LRECL-BYTE PIC X(01) OCCURS 8 TIMES INDEXED BY W-LRECL-NDX-1 W-LRECL-NDX-2. 05 W-LRECL-NUM PIC S9(08) COMP VALUE +0. 05 W-KEY PIC X(01) VALUE SPACES. 05 W-COL1 PIC X(08) VALUE SPACES. 05 W-COL2 PIC X(08) VALUE SPACES. 05 W-FLEN PIC X(08) VALUE SPACES. 05 W-DB2SCALE PIC X(08) VALUE SPACES. 05 W-NULLS PIC X(08) VALUE SPACES. 88 W-NOT-NULL VALUE 'NOT NULL'. 05 W-FIELD PIC X(18) VALUE SPACES. 05 W-TYPE PIC X(18) VALUE SPACES. 88 W-CHARACTER-TYPE VALUE 'LONG VARCHAR ' 'VARCHAR ' 'CHAR '. 88 W-NUMERIC-TYPE VALUE 'INTEGER ' 'SMALLINT ' 'FLOAT ' 'DECIMAL '. 88 W-DATE-TYPE VALUE 'DATE '. 88 W-TIME-TYPE VALUE 'TIME '. 88 W-TIMESTAMP-TYPE VALUE 'TIMESTMP '. 05 W-DEFAULT PIC X(50) VALUE SPACES. *** MISCELLANEOUS *** 05 W-FILE-STATUS-IN PIC X(02) VALUE SPACES. 05 W-FILE-STATUS-OUT PIC X(02) VALUE SPACES. 05 W-ISPF-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0. 05 W-INPUT-FILE-LENGTH PIC S9(06) COMP SYNC VALUE +0. 05 W-SUB-1 PIC S9(06) COMP SYNC VALUE +0. 05 W-DISPLAY-RETURN-CODE PIC 9(08) VALUE ZEROS. 05 W-ISPF-CALL PIC 9(07) VALUE ZEROS. 05 W-PARM PIC X(80) VALUE SPACES. 05 W-TABLE-READ-TYPE PIC X(08) VALUE SPACES. 05 W-COMMA PIC X(01) VALUE SPACES. ****************************************************************** * P R I N T L I N E S * ****************************************************************** 01 P-PRINT-LINES. 05 FILLER PIC X(23) VALUE '.PRINT LINES START HERE'. 05 P-PRINT-HEADER-1. 10 FILLER PIC X(12) VALUE 'INSERT INTO '. 10 P-DB2-VIEW PIC X(59) VALUE SPACES. 10 FILLER PIC X(09) VALUE SPACES. 05 P-PRINT-HEADER-2. 10 P-FIELD PIC X(18) VALUE SPACES. 10 P-SQL-DELIMITER PIC X(10) VALUE SPACES. 10 FILLER PIC X(52) VALUE SPACES. 05 P-PRINT-DETAIL. 10 P-VALUE PIC X(72) VALUE SPACES. 10 P-VALUE-TABLE REDEFINES P-VALUE. 15 P-VALUE-BYTE PIC X(01) OCCURS 72 TIMES INDEXED BY P-VALUE-NDX. 10 FILLER PIC X(08) VALUE SPACES. ****************************************************************** * T A B L E S * * CAUTION !!!! SOME TABLE VALUES ARE NON-DISPLAYABLE HEX VALUES. * * BE CAREFUL WHAT YOU CHANGE OR WHAT MASS CHANGES ARE MADE. * ****************************************************************** 01 T-TABLES. 05 FILLER PIC X(18) VALUE '.TABLES START HERE'. 05 T-PACKED-END-VALUES. 10 FILLER PIC X(30) VALUE '????????????<(.*).%_?@''"??????'. 05 T-PACKED-END-AREA REDEFINES T-PACKED-END-VALUES. 10 T-PACKED-END-TABLE OCCURS 30 TIMES ASCENDING KEY IS W-END-BYTE INDEXED BY T-END-NDX. 15 W-END-BYTE PIC X(01). 05 T-ISPF-TABLE-AREA. 10 T-ISPF-TABLE OCCURS 300 TIMES INDEXED BY T-ISPF-NDX. 15 T-ISPF-FIELD PIC X(18). 15 T-ISPF-COL1 PIC X(08). 15 T-ISPF-COL1-ARRAY REDEFINES T-ISPF-COL1. 20 T-ISPF-COL1-BYTE PIC X(01) OCCURS 8 TIMES INDEXED BY T-COL1-NDX-1 T-COL1-NDX-2. 15 T-ISPF-COL1-NUM PIC S9(08) COMP-3. 15 T-ISPF-COL2 PIC X(08). 15 T-ISPF-COL2-ARRAY REDEFINES T-ISPF-COL2. 20 T-ISPF-COL2-BYTE PIC X(01) OCCURS 8 TIMES INDEXED BY T-COL2-NDX-1 T-COL2-NDX-2. 15 T-ISPF-COL2-NUM PIC S9(08) COMP-3. 15 T-ISPF-FLEN PIC X(08). 15 T-ISPF-FLEN-ARRAY REDEFINES T-ISPF-FLEN. 20 T-ISPF-FLEN-BYTE PIC X(01) OCCURS 8 TIMES INDEXED BY T-FLEN-NDX-1 T-FLEN-NDX-2. 15 T-ISPF-FLEN-NUM PIC S9(08) COMP-3. 15 T-ISPF-TYPE PIC X(18). 15 T-ISPF-KEY PIC X(01). 15 T-ISPF-DEFAULT PIC X(50). 15 T-ISPF-DB2SCALE PIC X(08). 15 T-ISPF-DB2SCALE-ARRAY REDEFINES T-ISPF-DB2SCALE. 20 T-ISPF-DB2SCALE-BYTE PIC X(01) OCCURS 8 TIMES INDEXED BY T-DB2SCALE-NDX-1 T-DB2SCALE-NDX-2. 15 T-ISPF-DB2SCALE-NUM PIC S9(08) COMP-3. 15 T-ISPF-NULLS PIC X(08). 01 WS-END PIC X(43) VALUE '**** DB2TABL WORKING-STORAGE ENDS HERE ****'. LINKAGE SECTION. ****************************************************************** * L I N K A G E * ****************************************************************** 01 L-LINKAGE. 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 05 L-PARM PIC X(80). 01 WS-END PIC X(43) VALUE '**** DB2TABL WORKING-STORAGE ENDS HERE ****'. PROCEDURE DIVISION. ****************************************************************** * P R O C E D U R E D I V I S I O N * ****************************************************************** /***************************************************************** * S0000-DRIVER * * PERFORMED BY: * * FUNCTIONS: THIS ROUTINE CONTROLS THE WHOLE PROGRAM. * ****************************************************************** S0000-DRIVER SECTION. * DISPLAY '~~~ AT SECTION 0000'. PERFORM S1000-INITIALIZATION. PERFORM S2000-MAINLINE. PERFORM S3000-FINALIZATION. S0000-EXIT. EXIT. /***************************************************************** * S1000-INITIALIZATION * * PERFORMED BY: S0000-CONTROL * * FUNCTIONS: POINTS TO ISPF VARIABLES VIA "VDEFINE" SERVICE. * ****************************************************************** S1000-INITIALIZATION SECTION. * DISPLAY '~~~ AT SECTION 1000'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 1 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-KEY W-KEY C-CHAR C-KEY-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 2 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-COL1 W-COL1 C-CHAR C-COL1-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 3 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-COL2 W-COL2 C-CHAR C-COL2-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 4 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-FLEN W-FLEN C-CHAR C-FLEN-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 5 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DB2SCALE W-DB2SCALE C-CHAR C-DB2SCALE-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 6 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-NULLS W-NULLS C-CHAR C-NULLS-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 7 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-FIELD W-FIELD C-CHAR C-FIELD-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 8 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-TYPE W-TYPE C-CHAR C-TYPE-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 9 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DEFAULT W-DEFAULT C-CHAR C-DEFAULT-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 10 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-LRECL W-LRECL C-CHAR C-LRECL-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 11 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-TVNAME W-TVNAME C-CHAR C-TVNAME-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 12 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-DB2DBASE W-DB2DBASE C-CHAR C-DB2DBASE-LEN. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. PERFORM S4600-VGET. SET S-VALUE-NOT-FOUND TO TRUE. SET W-LRECL-NDX-2 TO C-LRECL-LEN. PERFORM VARYING W-LRECL-NDX-1 FROM C-LRECL-LEN BY -1 UNTIL S-NUMERIC-VALUE-FOUND OR W-LRECL-NDX-1 = +0 IF W-LRECL-BYTE (W-LRECL-NDX-1) IS NUMERIC SET S-NUMERIC-VALUE-FOUND TO TRUE END-IF END-PERFORM. SET W-LRECL-NDX-1 UP BY +1. PERFORM VARYING W-LRECL-NDX-1 FROM W-LRECL-NDX-1 BY -1 UNTIL W-LRECL-NDX-1 = +0 MOVE W-LRECL-BYTE (W-LRECL-NDX-1) TO W-LRECL-BYTE (W-LRECL-NDX-2) SET W-LRECL-NDX-2 DOWN BY +1 END-PERFORM. PERFORM VARYING W-LRECL-NDX-2 FROM W-LRECL-NDX-2 BY -1 UNTIL W-LRECL-NDX-2 = +0 MOVE ZERO TO W-LRECL-BYTE (W-LRECL-NDX-2) END-PERFORM. IF W-LRECL IS NUMERIC MOVE W-LRECL TO W-LRECL-NUM END-IF. STRING W-DB2DBASE C-PERIOD W-TVNAME SPACE C-LEFT-PAREN SPACES DELIMITED BY SIZE INTO P-DB2-VIEW. PERFORM S2500-LOAD-ISPF-TABLE. OPEN INPUT IN-LOAD-FILE OUTPUT OUT-SQL-INSERT. PERFORM S2200-READ-INPUT-FILE. S1000-EXIT. EXIT. /***************************************************************** * S2000-MAINLINE * * PERFORMED BY: S0000-CONTROL * * FUNCTIONS: THIS ROUTINE DOES THE PROCESSING FOR EACH ISPF * * ROW. * ****************************************************************** S2000-MAINLINE SECTION. * DISPLAY '~~~ AT SECTION 2000'. PERFORM UNTIL S-END-OF-INPUT-FILE MOVE SPACES TO W-COMMA PERFORM S2100-WRITE-HEADERS PERFORM VARYING T-ISPF-NDX FROM +1 BY +1 UNTIL T-ISPF-FIELD (T-ISPF-NDX) = SPACES OR T-ISPF-NDX > C-MAX-TABLE-ENTRIES MOVE SPACES TO W-HOLD P-PRINT-DETAIL SET W-NDX-1 TO +0 SET P-VALUE-NDX TO +0 MOVE T-ISPF-TYPE (T-ISPF-NDX) TO W-TYPE MOVE T-ISPF-NULLS (T-ISPF-NDX) TO W-NULLS EVALUATE TRUE WHEN W-NUMERIC-TYPE AND W-NOT-NULL PERFORM S4000-NUMERIC WHEN W-DATE-TYPE AND W-NOT-NULL PERFORM S4100-DATE WHEN W-TIME-TYPE AND W-NOT-NULL PERFORM S4200-TIME WHEN W-TIMESTAMP-TYPE AND W-NOT-NULL PERFORM S4300-TIMESTAMP WHEN W-CHARACTER-TYPE AND W-NOT-NULL PERFORM S4400-CHARACTER WHEN OTHER DISPLAY '*** UNKNOWN TYPE OF ' 'DB2 FIELD. CURRENT ' 'ROW OF ISPF TABLE IS ' ' AS FOLLOWS ***' DISPLAY 'FIELD=' T-ISPF-FIELD (T-ISPF-NDX) DISPLAY 'COL1=' T-ISPF-COL1 (T-ISPF-NDX) DISPLAY 'COL2=' T-ISPF-COL2 (T-ISPF-NDX) DISPLAY 'TYPE=' T-ISPF-TYPE (T-ISPF-NDX) DISPLAY 'KEY=' T-ISPF-KEY (T-ISPF-NDX) DISPLAY 'FLEN=' T-ISPF-FLEN (T-ISPF-NDX) DISPLAY 'DB2SCALE=' T-ISPF-DB2SCALE (T-ISPF-NDX) DISPLAY 'NULLS=' T-ISPF-NULLS (T-ISPF-NDX) DISPLAY 'DEFAULT=' T-ISPF-DEFAULT (T-ISPF-NDX) DISPLAY '*** SUBSTITUTING CHA' 'RACTER DEFAULT ***' MOVE C-CHAR-DEFAULT TO P-VALUE END-EVALUATE MOVE P-PRINT-DETAIL TO OUT-SQL-INSERT-RECORD PERFORM S2400-WRITE MOVE C-COMMA TO W-COMMA END-PERFORM MOVE C-INSERT-END TO P-PRINT-DETAIL MOVE P-PRINT-DETAIL TO OUT-SQL-INSERT-RECORD PERFORM S2400-WRITE PERFORM S2200-READ-INPUT-FILE END-PERFORM. S2000-EXIT. EXIT. /***************************************************************** * S2100-WRITE-HEADERS * * THIS ROUTINE WRITES THE HEADERS OF EACH INSERT STATEMENT. * ****************************************************************** S2100-WRITE-HEADERS SECTION. * DISPLAY '~~~ AT SECTION 2100'. MOVE SPACES TO OUT-SQL-INSERT-RECORD. MOVE P-PRINT-HEADER-1 TO OUT-SQL-INSERT-RECORD. PERFORM S2400-WRITE. PERFORM VARYING T-ISPF-NDX FROM +1 BY +1 UNTIL T-ISPF-FIELD (T-ISPF-NDX) = SPACES OR T-ISPF-NDX > C-MAX-TABLE-ENTRIES IF T-ISPF-NULLS (T-ISPF-NDX) = 'NOT NULL' OR (T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0) MOVE SPACES TO P-FIELD MOVE T-ISPF-FIELD (T-ISPF-NDX) TO P-FIELD END-IF SET T-ISPF-NDX UP BY +1 IF T-ISPF-FIELD (T-ISPF-NDX) = SPACES OR T-ISPF-NDX > C-MAX-TABLE-ENTRIES MOVE C-FIELD-END TO P-SQL-DELIMITER ELSE MOVE SPACES TO P-SQL-DELIMITER MOVE C-COMMA TO P-SQL-DELIMITER END-IF SET T-ISPF-NDX DOWN BY +1 MOVE SPACES TO OUT-SQL-INSERT-RECORD MOVE P-PRINT-HEADER-2 TO OUT-SQL-INSERT-RECORD PERFORM S2400-WRITE END-PERFORM. S2100-EXIT. EXIT. /***************************************************************** * S2200-READ-INPUT-FILE * * THIS ROUTINE READS THE INPUT LOAD FILE. * ****************************************************************** S2200-READ-INPUT-FILE SECTION. * DISPLAY '~~~ AT SECTION 2200'. READ IN-LOAD-FILE INTO W-INPUT-FILE AT END SET S-END-OF-INPUT-FILE TO TRUE. IF S-STILL-MORE-RECORDS ADD +1 TO A-RECORDS-READ A-RECORDS-READ-INCR IF A-DISPLAY-RECORD-COUNT MOVE A-RECORDS-READ TO A-RECORDS-READ-DIS DISPLAY '*** WORKING ON RECORD # ' A-RECORDS-READ-DIS MOVE ZEROS TO A-RECORDS-READ-INCR END-IF END-IF. S2200-EXIT. EXIT. /***************************************************************** * S2300-READ-ISPF-TABLE * * THIS ROUTINE READS THE ISPF TABLE. * ****************************************************************** S2300-READ-ISPF-TABLE SECTION. * DISPLAY '~~~ AT SECTION 2300'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 13 TO W-ISPF-CALL. CALL C-ISPF USING W-TABLE-READ-TYPE C-ISPF-TABLE. MOVE RETURN-CODE TO W-ISPF-RETURN-CODE. IF RETURN-CODE > C-END-TABLE-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S2300-EXIT. EXIT. /***************************************************************** * S2400-WRITE * * THIS ROUTINE WRITES THE OUTPUT RECORD. * ****************************************************************** S2400-WRITE SECTION. * DISPLAY '~~~ AT SECTION 2400'. WRITE OUT-SQL-INSERT-RECORD. ADD +1 TO A-RECORDS-WRITTEN. S2400-EXIT. EXIT. /***************************************************************** * S2500-LOAD-ISPF-TABLE * * THIS ROUTINE INITIALIZES AND THEN LOADS A WORKING STORAGE * * TABLE WITH A COPY OF AN ISPF TABLE TO SAVE ON RUNTIME BY NOT * * HAVING TO CALL ISPLINK FOR EVERY TABLE READ. * ****************************************************************** S2500-LOAD-ISPF-TABLE SECTION. * DISPLAY '~~~ AT SECTION 2500'. INITIALIZE T-ISPF-TABLE-AREA. MOVE C-TBTOP TO W-TABLE-READ-TYPE. MOVE ZERO TO W-ISPF-RETURN-CODE. PERFORM S2300-READ-ISPF-TABLE. MOVE C-TBSKIP TO W-TABLE-READ-TYPE. PERFORM S2300-READ-ISPF-TABLE. PERFORM VARYING T-ISPF-NDX FROM +1 BY +1 UNTIL W-ISPF-RETURN-CODE = C-END-TABLE-RETURN-CODE OR T-ISPF-NDX > C-MAX-TABLE-ENTRIES MOVE W-KEY TO T-ISPF-KEY (T-ISPF-NDX) MOVE W-COL1 TO T-ISPF-COL1 (T-ISPF-NDX) MOVE W-COL2 TO T-ISPF-COL2 (T-ISPF-NDX) MOVE W-FLEN TO T-ISPF-FLEN (T-ISPF-NDX) MOVE W-DB2SCALE TO T-ISPF-DB2SCALE (T-ISPF-NDX) MOVE W-NULLS TO T-ISPF-NULLS (T-ISPF-NDX) MOVE W-FIELD TO T-ISPF-FIELD (T-ISPF-NDX) MOVE W-TYPE TO T-ISPF-TYPE (T-ISPF-NDX) MOVE W-DEFAULT TO T-ISPF-DEFAULT (T-ISPF-NDX) * DISPLAY W-KEY * DISPLAY W-COL1 * DISPLAY W-COL2 * DISPLAY W-FLEN * DISPLAY W-DB2SCALE * DISPLAY W-NULLS * DISPLAY W-FIELD * DISPLAY W-TYPE * DISPLAY W-DEFAULT * DISPLAY T-ISPF-KEY (T-ISPF-NDX) * DISPLAY T-ISPF-COL1 (T-ISPF-NDX) * DISPLAY T-ISPF-COL2 (T-ISPF-NDX) * DISPLAY T-ISPF-FLEN (T-ISPF-NDX) * DISPLAY T-ISPF-DB2SCALE (T-ISPF-NDX) * DISPLAY T-ISPF-NULLS (T-ISPF-NDX) * DISPLAY T-ISPF-FIELD (T-ISPF-NDX) * DISPLAY T-ISPF-TYPE (T-ISPF-NDX) * DISPLAY T-ISPF-DEFAULT (T-ISPF-NDX) SET S-VALUE-NOT-FOUND TO TRUE SET T-COL1-NDX-2 TO C-COL1-LEN PERFORM VARYING T-COL1-NDX-1 FROM C-COL1-LEN BY -1 UNTIL S-NUMERIC-VALUE-FOUND OR T-COL1-NDX-1 = +0 IF T-ISPF-COL1-BYTE (T-ISPF-NDX T-COL1-NDX-1) IS NUMERIC SET S-NUMERIC-VALUE-FOUND TO TRUE END-IF END-PERFORM SET T-COL1-NDX-1 UP BY +1 PERFORM VARYING T-COL1-NDX-1 FROM T-COL1-NDX-1 BY -1 UNTIL T-COL1-NDX-1 = +0 MOVE T-ISPF-COL1-BYTE (T-ISPF-NDX T-COL1-NDX-1) TO T-ISPF-COL1-BYTE (T-ISPF-NDX T-COL1-NDX-2) SET T-COL1-NDX-2 DOWN BY +1 END-PERFORM PERFORM VARYING T-COL1-NDX-2 FROM T-COL1-NDX-2 BY -1 UNTIL T-COL1-NDX-2 = +0 MOVE ZERO TO T-ISPF-COL1-BYTE (T-ISPF-NDX T-COL1-NDX-2) END-PERFORM IF T-ISPF-COL1 (T-ISPF-NDX) IS NUMERIC MOVE T-ISPF-COL1 (T-ISPF-NDX) TO T-ISPF-COL1-NUM (T-ISPF-NDX) END-IF SET S-VALUE-NOT-FOUND TO TRUE SET T-COL2-NDX-2 TO C-COL2-LEN PERFORM VARYING T-COL2-NDX-1 FROM C-COL2-LEN BY -1 UNTIL S-NUMERIC-VALUE-FOUND OR T-COL2-NDX-1 = +0 IF T-ISPF-COL2-BYTE (T-ISPF-NDX T-COL2-NDX-1) IS NUMERIC SET S-NUMERIC-VALUE-FOUND TO TRUE END-IF END-PERFORM SET T-COL2-NDX-1 UP BY +1 PERFORM VARYING T-COL2-NDX-1 FROM T-COL2-NDX-1 BY -1 UNTIL T-COL2-NDX-1 = +0 MOVE T-ISPF-COL2-BYTE (T-ISPF-NDX T-COL2-NDX-1) TO T-ISPF-COL2-BYTE (T-ISPF-NDX T-COL2-NDX-2) SET T-COL2-NDX-2 DOWN BY +1 END-PERFORM PERFORM VARYING T-COL2-NDX-2 FROM T-COL2-NDX-2 BY -1 UNTIL T-COL2-NDX-2 = +0 MOVE ZERO TO T-ISPF-COL2-BYTE (T-ISPF-NDX T-COL2-NDX-2) END-PERFORM IF T-ISPF-COL2 (T-ISPF-NDX) IS NUMERIC MOVE T-ISPF-COL2 (T-ISPF-NDX) TO T-ISPF-COL2-NUM (T-ISPF-NDX) END-IF SET S-VALUE-NOT-FOUND TO TRUE SET T-FLEN-NDX-2 TO C-FLEN-LEN PERFORM VARYING T-FLEN-NDX-1 FROM C-FLEN-LEN BY -1 UNTIL S-NUMERIC-VALUE-FOUND OR T-FLEN-NDX-1 = +0 IF T-ISPF-FLEN-BYTE (T-ISPF-NDX T-FLEN-NDX-1) IS NUMERIC SET S-NUMERIC-VALUE-FOUND TO TRUE END-IF END-PERFORM SET T-FLEN-NDX-1 UP BY +1 PERFORM VARYING T-FLEN-NDX-1 FROM T-FLEN-NDX-1 BY -1 UNTIL T-FLEN-NDX-1 = +0 MOVE T-ISPF-FLEN-BYTE (T-ISPF-NDX T-FLEN-NDX-1) TO T-ISPF-FLEN-BYTE (T-ISPF-NDX T-FLEN-NDX-2) SET T-FLEN-NDX-2 DOWN BY +1 END-PERFORM PERFORM VARYING T-FLEN-NDX-2 FROM T-FLEN-NDX-2 BY -1 UNTIL T-FLEN-NDX-2 = +0 MOVE ZERO TO T-ISPF-FLEN-BYTE (T-ISPF-NDX T-FLEN-NDX-2) END-PERFORM IF T-ISPF-FLEN (T-ISPF-NDX) IS NUMERIC MOVE T-ISPF-FLEN (T-ISPF-NDX) TO T-ISPF-FLEN-NUM (T-ISPF-NDX) END-IF SET S-VALUE-NOT-FOUND TO TRUE SET T-DB2SCALE-NDX-2 TO C-DB2SCALE-LEN PERFORM VARYING T-DB2SCALE-NDX-1 FROM C-DB2SCALE-LEN BY -1 UNTIL S-NUMERIC-VALUE-FOUND OR T-DB2SCALE-NDX-1 = +0 IF T-ISPF-DB2SCALE-BYTE (T-ISPF-NDX T-DB2SCALE-NDX-1) IS NUMERIC SET S-NUMERIC-VALUE-FOUND TO TRUE END-IF END-PERFORM SET T-DB2SCALE-NDX-1 UP BY +1 PERFORM VARYING T-DB2SCALE-NDX-1 FROM T-DB2SCALE-NDX-1 BY -1 UNTIL T-DB2SCALE-NDX-1 = +0 MOVE T-ISPF-DB2SCALE-BYTE (T-ISPF-NDX T-DB2SCALE-NDX-1) TO T-ISPF-DB2SCALE-BYTE (T-ISPF-NDX T-DB2SCALE-NDX-2) SET T-DB2SCALE-NDX-2 DOWN BY +1 END-PERFORM PERFORM VARYING T-DB2SCALE-NDX-2 FROM T-DB2SCALE-NDX-2 BY -1 UNTIL T-DB2SCALE-NDX-2 = +0 MOVE ZERO TO T-ISPF-DB2SCALE-BYTE (T-ISPF-NDX T-DB2SCALE-NDX-2) END-PERFORM IF T-ISPF-DB2SCALE (T-ISPF-NDX) IS NUMERIC MOVE T-ISPF-DB2SCALE (T-ISPF-NDX) TO T-ISPF-DB2SCALE-NUM (T-ISPF-NDX) END-IF * DISPLAY T-ISPF-COL1-NUM (T-ISPF-NDX) * DISPLAY T-ISPF-COL2-NUM (T-ISPF-NDX) * DISPLAY T-ISPF-FLEN-NUM (T-ISPF-NDX) * DISPLAY T-ISPF-DB2SCALE-NUM (T-ISPF-NDX) PERFORM S2300-READ-ISPF-TABLE END-PERFORM. S2500-EXIT. EXIT. /***************************************************************** * S3000-FINALIZATION * * PERFORMED BY: S0000-CONTROL * * FUNCTIONS: THIS ROUTINE CLOSES FILES AND DISPLAYS CONTROL * * INFORMATION. * ****************************************************************** S3000-FINALIZATION SECTION. * DISPLAY '~~~ AT SECTION 3000'. CLOSE IN-LOAD-FILE OUT-SQL-INSERT. MOVE A-ISPF-CALLS-MADE TO A-ISPF-CALLS-MADE-DIS. MOVE A-RECORDS-READ TO A-RECORDS-READ-DIS. MOVE A-RECORDS-WRITTEN TO A-RECORDS-WRITTEN-DIS. DISPLAY '***********************************************'. DISPLAY '* DB2TABL PROGRAM DISPLAYS *'. DISPLAY '***********************************************'. DISPLAY '* ISPF CALLS = ' A-ISPF-CALLS-MADE-DIS. DISPLAY '* RECORDS READ = ' A-RECORDS-READ-DIS. DISPLAY '* RECORDS WRITTEN = ' A-RECORDS-WRITTEN-DIS. DISPLAY '***********************************************'. GOBACK. S3000-EXIT. EXIT. /***************************************************************** * S4000-NUMERIC * * THIS ROUTINE PROCESSES ALL NUMERIC FIELDS. * ****************************************************************** S4000-NUMERIC SECTION. * DISPLAY '~~~ AT SECTION 4000'. SET W-ALPHA-NDX-1 TO +0. MOVE LOW-VALUES TO W-ALPHA-HOLD. IF T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0 PERFORM VARYING W-INPUT-FILE-NDX FROM T-ISPF-COL1-NUM (T-ISPF-NDX) BY +1 UNTIL W-INPUT-FILE-NDX > T-ISPF-COL2-NUM (T-ISPF-NDX) SET W-NDX-1 UP BY +1 SET W-ALPHA-NDX-1 UP BY +1 MOVE W-INPUT-FILE-BYTE (W-INPUT-FILE-NDX) TO W-ALPHA-BYTE (W-ALPHA-NDX-1) W-BYTE (W-NDX-1) SET W-NDX-2 TO W-NDX-1 END-PERFORM ELSE MOVE T-ISPF-DEFAULT (T-ISPF-NDX) TO W-HOLD W-ALPHA-HOLD PERFORM VARYING W-NDX-1 FROM C-FILE-MAX BY -1 UNTIL W-BYTE (W-NDX-1) > SPACES OR W-NDX-1 = +0 SET W-NDX-2 TO W-NDX-1 END-PERFORM END-IF. SET W-ALPHA-NDX-2 TO C-ALPHA-MAX. SET S-VALUE-NOT-FOUND TO TRUE. PERFORM VARYING W-ALPHA-NDX-1 FROM C-ALPHA-MAX BY -1 UNTIL S-PACKED-VALUE-FOUND OR W-ALPHA-NDX-1 = +0 SEARCH ALL T-PACKED-END-TABLE AT END SET S-VALUE-NOT-FOUND TO TRUE WHEN W-END-BYTE (T-END-NDX) = W-ALPHA-BYTE (W-ALPHA-NDX-1) SET S-PACKED-VALUE-FOUND TO TRUE END-SEARCH END-PERFORM. SET W-ALPHA-NDX-1 UP BY +1. PERFORM VARYING W-ALPHA-NDX-1 FROM W-ALPHA-NDX-1 BY -1 UNTIL W-ALPHA-NDX-1 = +0 MOVE W-ALPHA-BYTE (W-ALPHA-NDX-1) TO W-ALPHA-BYTE (W-ALPHA-NDX-2) SET W-ALPHA-NDX-2 DOWN BY +1 END-PERFORM. PERFORM VARYING W-ALPHA-NDX-2 FROM W-ALPHA-NDX-2 BY -1 UNTIL W-ALPHA-NDX-2 = +0 MOVE LOW-VALUES TO W-ALPHA-BYTE (W-ALPHA-NDX-2) END-PERFORM. IF W-NUMERIC IS NUMERIC MOVE W-NUMERIC TO W-SIGNED-NUMERIC MOVE W-SIGNED-NUMERIC TO W-HOLD END-IF. SET P-VALUE-NDX TO +1. MOVE W-COMMA TO P-VALUE-BYTE (P-VALUE-NDX). SET P-VALUE-NDX UP BY +1. MOVE W-BYTE (1) TO P-VALUE-BYTE (P-VALUE-NDX). COMPUTE W-TALLY = C-DIGITS-MAX - T-ISPF-DB2SCALE-NUM (T-ISPF-NDX) + 1 PERFORM VARYING W-NDX-1 FROM +2 BY +1 UNTIL W-NDX-1 > C-DIGITS-MAX IF W-NDX-1 = W-TALLY COMPUTE W-TALLY = T-ISPF-FLEN-NUM (T-ISPF-NDX) - T-ISPF-DB2SCALE-NUM (T-ISPF-NDX) PERFORM VARYING W-NDX-1 FROM W-NDX-1 BY +1 UNTIL W-NDX-1 > C-DIGITS-MAX SET P-VALUE-NDX UP BY +1 MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) SUBTRACT +1 FROM W-TALLY IF W-TALLY = +0 AND W-NDX-1 < C-DIGITS-MAX SET P-VALUE-NDX UP BY +1 MOVE C-DECIMAL TO P-VALUE-BYTE (P-VALUE-NDX) END-IF END-PERFORM END-IF END-PERFORM. S4000-EXIT. EXIT. /***************************************************************** * S4100-DATE * * THIS ROUTINE PROCESSES ALL DATE TIME AND TIMESTAMP FIELDS * ****************************************************************** S4100-DATE SECTION. * DISPLAY '~~~ AT SECTION 4100'. IF T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0 PERFORM VARYING W-INPUT-FILE-NDX FROM T-ISPF-COL1-NUM (T-ISPF-NDX) BY +1 UNTIL W-INPUT-FILE-NDX > T-ISPF-COL2-NUM (T-ISPF-NDX) SET W-NDX-1 UP BY +1 MOVE W-INPUT-FILE-BYTE (W-INPUT-FILE-NDX) TO W-BYTE (W-NDX-1) SET W-NDX-2 TO W-NDX-1 END-PERFORM ELSE MOVE T-ISPF-DEFAULT (T-ISPF-NDX) TO W-HOLD END-IF. MOVE ZEROS TO W-TALLY. INSPECT W-HOLD TALLYING W-TALLY FOR ALL C-DATE. IF W-DATE-FOUND STRING W-COMMA W-HOLD DELIMITED BY SIZE INTO P-VALUE ELSE SET P-VALUE-NDX TO +1 MOVE W-COMMA TO P-VALUE-BYTE (P-VALUE-NDX) SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) PERFORM VARYING W-NDX-1 FROM +1 BY +1 UNTIL W-NDX-1 > W-NDX-2 SET P-VALUE-NDX UP BY +1 MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) END-PERFORM SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) END-IF. S4100-EXIT. EXIT. /***************************************************************** * S4200-TIME * * THIS ROUTINE PROCESSES ALL TIME FIELDS. * ****************************************************************** S4200-TIME SECTION. * DISPLAY '~~~ AT SECTION 4200'. IF T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0 PERFORM VARYING W-INPUT-FILE-NDX FROM T-ISPF-COL1-NUM (T-ISPF-NDX) BY +1 UNTIL W-INPUT-FILE-NDX > T-ISPF-COL2-NUM (T-ISPF-NDX) SET W-NDX-1 UP BY +1 MOVE W-INPUT-FILE-BYTE (W-INPUT-FILE-NDX) TO W-BYTE (W-NDX-1) SET W-NDX-2 TO W-NDX-1 END-PERFORM ELSE MOVE T-ISPF-DEFAULT (T-ISPF-NDX) TO W-HOLD END-IF. MOVE ZEROS TO W-TALLY. INSPECT W-HOLD TALLYING W-TALLY FOR ALL C-TIME. IF W-TIME-FOUND STRING W-COMMA W-HOLD DELIMITED BY SIZE INTO P-VALUE ELSE SET P-VALUE-NDX TO +1 MOVE W-COMMA TO P-VALUE-BYTE (P-VALUE-NDX) SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) PERFORM VARYING W-NDX-1 FROM +1 BY +1 UNTIL W-NDX-1 > W-NDX-2 SET P-VALUE-NDX UP BY +1 MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) END-PERFORM SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) END-IF. S4200-EXIT. EXIT. /***************************************************************** * S4300-TIMESTAMP * * THIS ROUTINE PROCESSES ALL TIMESTAMP FIELDS. * ****************************************************************** S4300-TIMESTAMP SECTION. * DISPLAY '~~~ AT SECTION 4300'. IF T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0 PERFORM VARYING W-INPUT-FILE-NDX FROM T-ISPF-COL1-NUM (T-ISPF-NDX) BY +1 UNTIL W-INPUT-FILE-NDX > T-ISPF-COL2-NUM (T-ISPF-NDX) SET W-NDX-1 UP BY +1 MOVE W-INPUT-FILE-BYTE (W-INPUT-FILE-NDX) TO W-BYTE (W-NDX-1) SET W-NDX-2 TO W-NDX-1 END-PERFORM ELSE MOVE T-ISPF-DEFAULT (T-ISPF-NDX) TO W-HOLD END-IF. MOVE ZEROS TO W-TALLY. INSPECT W-HOLD TALLYING W-TALLY FOR ALL C-TIMESTAMP. IF W-TIMESTAMP-FOUND STRING W-COMMA W-HOLD DELIMITED BY SIZE INTO P-VALUE ELSE SET P-VALUE-NDX TO +1 MOVE W-COMMA TO P-VALUE-BYTE (P-VALUE-NDX) SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) PERFORM VARYING W-NDX-1 FROM +1 BY +1 UNTIL W-NDX-1 > W-NDX-2 SET P-VALUE-NDX UP BY +1 MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) END-PERFORM SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) END-IF. S4300-EXIT. EXIT. /***************************************************************** * S4400-CHARACTER * * THIS ROUTINE PROCESSES ALL CHARACTER FIELDS. * ****************************************************************** S4400-CHARACTER SECTION. * DISPLAY '~~~ AT SECTION 4400'. IF T-ISPF-COL1-NUM (T-ISPF-NDX) > +0 AND T-ISPF-COL2-NUM (T-ISPF-NDX) > +0 PERFORM VARYING W-INPUT-FILE-NDX FROM T-ISPF-COL1-NUM (T-ISPF-NDX) BY +1 UNTIL W-INPUT-FILE-NDX > T-ISPF-COL2-NUM (T-ISPF-NDX) SET W-NDX-1 UP BY +1 MOVE W-INPUT-FILE-BYTE (W-INPUT-FILE-NDX) TO W-BYTE (W-NDX-1) SET W-NDX-2 TO W-NDX-1 END-PERFORM ELSE MOVE T-ISPF-DEFAULT (T-ISPF-NDX) TO W-HOLD PERFORM VARYING W-NDX-1 FROM C-FILE-MAX BY -1 UNTIL W-BYTE (W-NDX-1) > SPACES OR W-NDX-1 = +0 SET W-NDX-2 TO W-NDX-1 END-PERFORM END-IF. SET P-VALUE-NDX TO +1. MOVE W-COMMA TO P-VALUE-BYTE (P-VALUE-NDX). MOVE ZEROS TO W-TALLY. INSPECT W-HOLD TALLYING W-TALLY FOR LEADING C-QUOTE. IF W-TALLY > +1 DISPLAY '*** VALUE FOR FIELD: ' T-ISPF-FIELD (T-ISPF-NDX) DISPLAY '*** CONTAINS AMBIGUOUS QUOTES ***' DISPLAY '*** USING SPACES INSTEAD ***' DISPLAY '*** DEFAULT = ' T-ISPF-DEFAULT (T-ISPF-NDX) DISPLAY '*** COL1 = ' T-ISPF-COL1 (T-ISPF-NDX) DISPLAY '*** COL2 = ' T-ISPF-COL2 (T-ISPF-NDX) MOVE C-CHAR-DEFAULT TO P-VALUE GO TO S4400-EXIT. INSPECT W-HOLD TALLYING W-TALLY FOR ALL C-QUOTE AFTER INITIAL C-QUOTE. IF W-MATCHED-QUOTE-PAIR OR W-NO-QUOTES-FOUND SET P-VALUE-NDX UP BY +1 MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX) ELSE DISPLAY '*** VALUE FOR FIELD: ' T-ISPF-FIELD (T-ISPF-NDX) DISPLAY '*** CONTAINS AMBIGUOUS QUOTES ***' DISPLAY '*** USING SPACES INSTEAD ***' DISPLAY '*** DEFAULT = ' T-ISPF-DEFAULT (T-ISPF-NDX) DISPLAY '*** COL1 = ' T-ISPF-COL1 (T-ISPF-NDX) DISPLAY '*** COL2 = ' T-ISPF-COL2 (T-ISPF-NDX) MOVE C-CHAR-DEFAULT TO P-VALUE GO TO S4400-EXIT. SET W-TALLY TO P-VALUE-NDX. PERFORM VARYING W-NDX-1 FROM +1 BY +1 UNTIL W-NDX-1 > W-NDX-2 SET P-VALUE-NDX UP BY +1 ADD +1 TO W-TALLY IF W-ULTIMATE-COLUMN AND W-NDX-1 > W-NDX-2 AND W-BYTE (W-NDX-1) NOT = C-QUOTE MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) MOVE P-PRINT-DETAIL TO OUT-SQL-INSERT-RECORD PERFORM S2400-WRITE MOVE SPACES TO P-PRINT-DETAIL SET P-VALUE-NDX TO +0 MOVE ZEROS TO W-TALLY ELSE IF W-ULTIMATE-COLUMN AND W-NDX-1 = W-NDX-2 AND W-BYTE (W-NDX-1) NOT = C-QUOTE MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) MOVE P-PRINT-DETAIL TO OUT-SQL-INSERT-RECORD PERFORM S2400-WRITE MOVE SPACES TO P-PRINT-DETAIL ELSE IF W-BYTE (W-NDX-1) NOT = C-QUOTE MOVE W-BYTE (W-NDX-1) TO P-VALUE-BYTE (P-VALUE-NDX) END-IF END-IF END-IF IF W-BYTE (W-NDX-1) = C-QUOTE SET P-VALUE-NDX DOWN BY +1 SUBTRACT +1 FROM W-TALLY END-IF END-PERFORM. SET P-VALUE-NDX UP BY +1. MOVE C-QUOTE TO P-VALUE-BYTE (P-VALUE-NDX). S4400-EXIT. EXIT. /***************************************************************** * S4600-VGET * * PERFORMED BY: S2000-MAINLINE * * FUNCTIONS: THIS ROUTINE "VGETS" THE NECESSARY VARIABLES. * ****************************************************************** S4600-VGET SECTION. * DISPLAY '~~~ AT SECTION 4600'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 14 TO W-ISPF-CALL. CALL C-ISPF USING C-VGET C-VGET-VPUT-VARIABLES. IF RETURN-CODE > C-PASSABLE-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S4600-EXIT. EXIT. /***************************************************************** * S5000-ISPF-RETURN-CODE-CHECK * * PERFORMED BY: S1000-INITIALIZATION * * FUNCTIONS: THIS ROUTINE CHECKS THE RETURN CODE FROM ANY * * CALL TO ISPF AND DISPLAYS ABEND MESSAGES IF ANY. * ****************************************************************** S5000-ISPF-RETURN-CODE-CHECK SECTION. * DISPLAY '~~~ AT SECTION 5000'. MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE. MOVE A-ISPF-CALLS-MADE TO A-ISPF-CALLS-MADE-DIS. DISPLAY '********** DB2TABL ABEND INFO ***********'. DISPLAY '*============= ISPF ABEND ==============*'. DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *'. DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *'. DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *'. DISPLAY '* # ISPF CALLS MADE WERE : ' A-ISPF-CALLS-MADE-DIS ' *'. DISPLAY '*****************************************'. PERFORM S3000-FINALIZATION. S5000-EXIT. ./ ADD NAME=DTSEDIT 000100 IDENTIFICATION DIVISION. DTSEDIT 000200 PROGRAM-ID. DTSEDIT. DTSEDIT 000300******************************************************************OWNERID 000400** DO NOT COPY!! **OWNERID 000500** THIS DOCUMENT CONTAINS TRADE SECRET INFORMATION, THE **OWNERID 000600** EXPRESSION OF WHICH IS AN UNPUBLISHED WORK FULLY PROTECTED **OWNERID 000700** BY THE UNITED STATES COPYRIGHT LAWS AND IS CONSIDERED A **OWNERID 000800** TRADE SECRET OWNED BY UNIPAC SERVICE CORPORATION, **OWNERID 000900** 3015 SOUTH PARKER ROAD, SUITE 400, AURORA, COLORADO 80014. **OWNERID 001000** ALL RIGHTS, TITLE, INTEREST AND OWNERSHIP ARE RESERVED BY **OWNERID 001100** UNIPAC SERVICE CORPORATION. THIS DOCUMENT CANNOT BE **OWNERID 001200** ACQUIRED, COPIED, MODIFIED OR USED IN ANY MANNER WHATSOEVER **OWNERID 001300** WITHOUT THE EXPRESS WRITTEN CONSENT OF UNIPAC SERVICE **OWNERID 001400** CORPORATION. **OWNERID 001500******************************************************************OWNERID 001600 AUTHOR. UNIPAC SERVICE CORPORATION. DTSEDIT 001700 DATE-WRITTEN. 07/19/96. DTSEDIT 001800 DATE-COMPILED. DTSEDIT 001900******************************************************************DTSEDIT 002000** PROGRAM DOCUMENTATION **DTSEDIT 002100** **DTSEDIT 002200** PROGRAM FUNCTION **DTSEDIT 002300** THIS MODULE WILL BE USED BE ALL PROGRAMS THAT REQUIRE **DTSEDIT 002400** DATE CALCULATIONS, MANIPULATIONS, AND/OR REFORMATTING. **DTSEDIT 002500** **DTSEDIT 002600** PROGRAM FLOW **DTSEDIT 002700** A100-INITALIZE **DTSEDIT 002800** CLEARS OUT TABLES, HOLD AREAS, AND THE DATE RETURN **DTSEDIT 002900** SECTION OF THE LINKAGE AREA. **DTSEDIT 003000** B100-DATE-VALID-CONV **DTSEDIT 003100** IF A DATE VALIDATION/CONVERSION IS SELECTED THIS **DTSEDIT 003200** SECTION IS PERFORMED. THE INPUT DATE IS VALIDATED **DTSEDIT 003300** AND (IF REQUIRED) REFORMATTED INTO THE SPECIFIED **DTSEDIT 003310** OUTPUT FORMAT. **DTSEDIT 003400** C100-DATE-CALCULATION **DTSEDIT 003500** IF A DATE CALCULATION IS SELECTED THIS SECTION IS **DTSEDIT 003600** PERFORMED. THE INPUT DATE(S) ARE VALIDATED, THEN **DTSEDIT 003700** THE DESIRED CALCULATION IS PERFORMED, AND THEN THE **DTSEDIT 003800** NEW DATE(S) (IF REQUIRED) ARE REFORMATED INTO THE **DTSEDIT 003900** SPECIFIED OUTPUT FORMAT(S). **DTSEDIT 004000** Z100-FINALIZATION **DTSEDIT 004100** POPULATES THE RETURN CODE AND RETURN MESSAGE AREAS **DTSEDIT 004200** OF THE LINKAGE SECTION. **DTSEDIT 004300** STOP RUN. **DTSEDIT 004400** **DTSEDIT 004500** LINKAGE COPYBOOKS **DTSEDIT 004600** DTLEDIT - LAYOUT FOR LINKAGE SECTION TO DTSEDIT. **DTSEDIT 004700** **DTSEDIT 004800** SOURCE COPYBOOKS **DTSEDIT 004900** DTICC - CALCULATES THE CENTURY FOR A GIVEN DATE **DTSEDIT 005000** DTICCBD - CALCULATES THE CENTURY FOR A GIVEN BIRTHDATE **DTSEDIT 005100** **DTSEDIT 005200** CALLED MODULES **DTSEDIT 005300** NONE **DTSEDIT 005400** **DTSEDIT 005500** NOTES **DTSEDIT 005600** DOCUMENTATION CAN BE FOUND IN THE STANDARDS LIBRARY. **DTSEDIT 005900** **DTSEDIT 006000******************************************************************DTSEDIT 006100** REVISIONS: **DTSEDIT 006200** INITIAL CODING AND DESIGN * A20115 * S. MCRAE * **DTSEDIT 006300** VERSION 1.00 * EST PRD 07/19/96 **DTSEDIT 006400** INITIAL CODING AND DEVELOPMENT OF THE COMMON DATE ROUTINE**DTSEDIT 006400**----------+----------------------------------------------------*KVB20115 006500** A20115 | 96/12/13 | 1.01 | KRISTIN HARVEY *KVB20115 006600**----------+----------------------------------------------------*KVB20115 006700** | ADDING TEMPORARY CODE FOR YEAR 2000 FOR USE IN **KVB20115 006800** | INTERMEDIATE CALCULATIONS OF THE CENTURY. **KVB20115 006900**----------+----------------------------------------------------*KVB20115 007000** A20115 | 97/05/10 | 1.02 | TOM IOWA *TIE20115 007100**----------+----------------------------------------------------*TIE20115 007200** | TO COMPLY WITH STANDARDS, CHANGED EXIT PROGRAM *TIE20115 007300** | TO GOBACK. CHANGES DENOTED BY TIE20115. **TIE20115 007400**----------+----------------------------------------------------*TIE20115 006500******************************************************************DTSEDIT 006600 ENVIRONMENT DIVISION. DTSEDIT 006700 CONFIGURATION SECTION. DTSEDIT 006800 DATA DIVISION. DTSEDIT 006900******************************************************************DTSEDIT 007000** W O R K I N G S T O R A G E *DTSEDIT 007100******************************************************************DTSEDIT 007200 WORKING-STORAGE SECTION. DTSEDIT 007300 01 A-STANDARD-PROGRAM-ID PIC X(26) VALUE DTSEDIT 008400 'UNIPAC/DTSEDIT/970510-1.02'. TIE20115 007500******************************************************************DTSEDIT 007600** H O L D / M I S C E L L A N E O U S PREFIX HLD *DTSEDIT 007700******************************************************************DTSEDIT 007800 01 HOLD-AREAS. DTSEDIT 007900 05 HLD-DATE PIC X(10) VALUE SPACES. DTSEDIT 008000 05 HLD-DATE-GREG-RDFN REDEFINES HLD-DATE. DTSEDIT 008100 10 HLD-GREG-DATE. DTSEDIT 008200 15 HLD-GREG-DATE-CCYY. DTSEDIT 008300 20 HLD-GREG-DATE-CC PIC 9(02). DTSEDIT 008400 20 HLD-GREG-DATE-YY PIC 9(02). DTSEDIT 008500 15 HLD-GREG-DATE-MM PIC 9(02). DTSEDIT 008600 15 HLD-GREG-DATE-DD PIC 9(02). DTSEDIT 008700 10 FILLER PIC X(02). DTSEDIT 008800 05 HLD-DATE-SHORT-RDFN REDEFINES HLD-DATE. DTSEDIT 008900 10 HLD-SHORT-DATE PIC 9(06). DTSEDIT 009000 10 FILLER PIC X(04). DTSEDIT 009100 05 HLD-DATE-JULN-RDFN REDEFINES HLD-DATE. DTSEDIT 009200 10 HLD-JULN-DATE. DTSEDIT 009300 15 HLD-JULN-DATE-YEAR. DTSEDIT 009400 20 HLD-JULN-DATE-CC PIC 9(02). DTSEDIT 009500 20 HLD-JULN-DATE-YY PIC 9(02). DTSEDIT 009600 15 HLD-JULN-DATE-YEAR-RDFN DTSEDIT 009700 REDEFINES HLD-JULN-DATE-YEAR. DTSEDIT 009800 20 HLD-JULN-DATE-CCYY PIC 9(04). DTSEDIT 009900 15 HLD-JULN-DATE-DDD PIC 9(03). DTSEDIT 010000 10 FILLER PIC X(03). DTSEDIT 010100 05 HLD-DATE-ISO-RDFN REDEFINES HLD-DATE. DTSEDIT 010200 10 HLD-ISO-DATE-CCYY PIC 9(04). DTSEDIT 010300 10 HLD-ISO-DATE-DASH-1 PIC X(01). DTSEDIT 010400 10 HLD-ISO-DATE-MM PIC 9(02). DTSEDIT 010500 10 HLD-ISO-DATE-DASH-2 PIC X(01). DTSEDIT 010600 10 HLD-ISO-DATE-DD PIC 9(02). DTSEDIT 010610 05 HLD-DATE-USA-RDFN REDEFINES HLD-DATE. DTSEDIT 010640 10 HLD-USA-DATE-MM PIC 9(02). DTSEDIT 010650 10 HLD-USA-DATE-SLASH-1 PIC X(01). DTSEDIT 010660 10 HLD-USA-DATE-DD PIC 9(02). DTSEDIT 010670 10 HLD-USA-DATE-SLASH-2 PIC X(01). DTSEDIT 010680 10 HLD-USA-DATE-CCYY PIC 9(04). DTSEDIT 010690 05 HLD-TEMP-GREG-DATE. DTSEDIT 010700 10 HLD-TEMP-GREG-CCYY PIC 9(04). DTSEDIT 010800 10 HLD-TEMP-GREG-MM PIC 9(02). DTSEDIT 010900 10 HLD-TEMP-GREG-DD PIC 9(02). DTSEDIT 012100******************************************************************DTSEDIT 012200** F L A G S / S W I T C H E S PREFIX FLG *DTSEDIT 012300******************************************************************DTSEDIT 012400 01 FLAGS. DTSEDIT 012500 05 FLG-FUNC-REQ-CODE PIC X(03). DTSEDIT 012600 88 FUNC-DATE-VALID-CONV VALUE '020'. DTSEDIT 012700 88 FUNC-DATE-CALC VALUE '030'. DTSEDIT 012800 05 FLG-IN-DATE-FRMT PIC X(02). DTSEDIT 012900 88 FRMT-IN-GREG-DATE VALUE '01'. DTSEDIT 013000 88 FRMT-IN-JULN-DATE VALUE '02'. DTSEDIT 013100 88 FRMT-IN-ISO-DATE VALUE '03'. DTSEDIT 013110 88 FRMT-IN-USA-DATE VALUE '04'. DTSEDIT 013200 88 FRMT-IN-SHORT-DATE VALUE '05'. DTSEDIT 013300 88 FRMT-IN-BRTH-DATE VALUE '06'. DTSEDIT 013400 05 FLG-OUT-DATE-FRMT PIC X(02). DTSEDIT 013500 88 FRMT-OUT-GREG-DATE VALUE '01'. DTSEDIT 013600 88 FRMT-OUT-JULN-DATE VALUE '02'. DTSEDIT 013700 88 FRMT-OUT-ISO-DATE VALUE '03'. DTSEDIT 013800 05 FLG-CALC-REQ-CODE PIC X(03). DTSEDIT 013900 88 CALC-DAYS-BETWEEN VALUE '001'. DTSEDIT 013910 88 CALC-MONTHS-BETWEEN VALUE '002'. DTSEDIT 014000 88 CALC-DAY-OF-WEEK VALUE '003'. DTSEDIT 014100 88 CALC-QTR-BEG-END VALUE '004'. DTSEDIT 014200 88 CALC-DAYS-FUTURE VALUE '005'. DTSEDIT 014300 88 CALC-DAYS-PAST VALUE '006'. DTSEDIT 014310 88 CALC-WEEKDAYS-FUTURE VALUE '007'. DTSEDIT 014320 88 CALC-WEEKDAYS-PAST VALUE '008'. DTSEDIT 014400 88 CALC-MONTHS-FUTURE VALUE '009'. DTSEDIT 014500 88 CALC-MONTHS-PAST VALUE '010'. DTSEDIT 014600 88 CALC-YEARS-FUTURE VALUE '011'. DTSEDIT 014700 88 CALC-YEARS-PAST VALUE '012'. DTSEDIT 014800 88 CALC-LAST-DAY-MM VALUE '013'. DTSEDIT 014900 88 CALC-ALPHA-MONTH VALUE '014'. DTSEDIT 015000 88 CALC-STND-YEAR-SPAN VALUE '015'. DTSEDIT 015010 88 CALC-BEGIN-NEXT-MONTH VALUE '016'. DTSEDIT 015100 05 FLG-LEAP-YEAR PIC X(01). DTSEDIT 015200 88 NON-LEAP-YEAR VALUE 'N'. DTSEDIT 015300 88 LEAP-YEAR VALUE 'Y'. DTSEDIT 015400******************************************************************DTSEDIT 015500** L I T E R A L S PREFIX LIT *DTSEDIT 015600******************************************************************DTSEDIT 015700 01 LITERALS. DTSEDIT 015800 05 LIT-LEAP-YEAR-DATA. DTSEDIT 015900 10 FILLER PIC X(17) VALUE 'JANUARY 0131000'. DTSEDIT 016000 10 FILLER PIC X(17) VALUE 'FEBRUARY 0129031'. DTSEDIT 016100 10 FILLER PIC X(17) VALUE 'MARCH 0131060'. DTSEDIT 016200 10 FILLER PIC X(17) VALUE 'APRIL 0130091'. DTSEDIT 016300 10 FILLER PIC X(17) VALUE 'MAY 0131121'. DTSEDIT 016400 10 FILLER PIC X(17) VALUE 'JUNE 0130152'. DTSEDIT 016500 10 FILLER PIC X(17) VALUE 'JULY 0131182'. DTSEDIT 016600 10 FILLER PIC X(17) VALUE 'AUGUST 0131213'. DTSEDIT 016700 10 FILLER PIC X(17) VALUE 'SEPTEMBER 0130244'. DTSEDIT 016800 10 FILLER PIC X(17) VALUE 'OCTOBER 0131274'. DTSEDIT 016900 10 FILLER PIC X(17) VALUE 'NOVEMBER 0130305'. DTSEDIT 017000 10 FILLER PIC X(17) VALUE 'DECEMBER 0131335'. DTSEDIT 017100 05 LIT-NON-LEAP-YEAR-DATA. DTSEDIT 017200 10 FILLER PIC X(17) VALUE 'JANUARY 0131000'. DTSEDIT 017300 10 FILLER PIC X(17) VALUE 'FEBRUARY 0128031'. DTSEDIT 017400 10 FILLER PIC X(17) VALUE 'MARCH 0131059'. DTSEDIT 017500 10 FILLER PIC X(17) VALUE 'APRIL 0130090'. DTSEDIT 017600 10 FILLER PIC X(17) VALUE 'MAY 0131120'. DTSEDIT 017700 10 FILLER PIC X(17) VALUE 'JUNE 0130151'. DTSEDIT 017800 10 FILLER PIC X(17) VALUE 'JULY 0131181'. DTSEDIT 017900 10 FILLER PIC X(17) VALUE 'AUGUST 0131212'. DTSEDIT 018000 10 FILLER PIC X(17) VALUE 'SEPTEMBER 0130243'. DTSEDIT 018100 10 FILLER PIC X(17) VALUE 'OCTOBER 0131273'. DTSEDIT 018200 10 FILLER PIC X(17) VALUE 'NOVEMBER 0130304'. DTSEDIT 018300 10 FILLER PIC X(17) VALUE 'DECEMBER 0131334'. DTSEDIT 018400 05 LIT-DAY-OF-WEEK-DATA. DTSEDIT 018500 10 FILLER PIC X(10) VALUE 'FRIDAY '. DTSEDIT 018600 10 FILLER PIC X(10) VALUE 'SATURDAY '. DTSEDIT 018700 10 FILLER PIC X(10) VALUE 'SUNDAY '. DTSEDIT 018800 10 FILLER PIC X(10) VALUE 'MONDAY '. DTSEDIT 018900 10 FILLER PIC X(10) VALUE 'TUESDAY '. DTSEDIT 019000 10 FILLER PIC X(10) VALUE 'WEDNESDAY '. DTSEDIT 019100 10 FILLER PIC X(10) VALUE 'THURSDAY '. DTSEDIT 019200 05 LIT-QTR-BEG-END-DATA. DTSEDIT 019300 10 FILLER PIC X(08) VALUE '01010331'. DTSEDIT 019400 10 FILLER PIC X(08) VALUE '01010331'. DTSEDIT 019500 10 FILLER PIC X(08) VALUE '01010331'. DTSEDIT 019600 10 FILLER PIC X(08) VALUE '04010630'. DTSEDIT 019700 10 FILLER PIC X(08) VALUE '04010630'. DTSEDIT 019800 10 FILLER PIC X(08) VALUE '04010630'. DTSEDIT 019900 10 FILLER PIC X(08) VALUE '07010930'. DTSEDIT 020000 10 FILLER PIC X(08) VALUE '07010930'. DTSEDIT 020100 10 FILLER PIC X(08) VALUE '07010930'. DTSEDIT 020200 10 FILLER PIC X(08) VALUE '10011231'. DTSEDIT 020300 10 FILLER PIC X(08) VALUE '10011231'. DTSEDIT 020400 10 FILLER PIC X(08) VALUE '10011231'. DTSEDIT 020500******************************************************************DTSEDIT 020600** S U B S C R I P T S PREFIX SUB *DTSEDIT 020700******************************************************************DTSEDIT 020800 01 SUBSCRIPTS COMP. DTSEDIT 020900 05 SUB-MM PIC S9(04) VALUE ZEROS. DTSEDIT 021000 05 SUB-DAY PIC S9(04) VALUE ZEROS. DTSEDIT 021100 05 SUB-QTR PIC S9(04) VALUE ZEROS. DTSEDIT 021200******************************************************************DTSEDIT 021300** W O R K A R E A S PREFIX WRK *DTSEDIT 021400******************************************************************DTSEDIT 021500 01 WORK-AREAS. DTSEDIT 021600 05 WRK-RETURN-CODE PIC X(03) VALUE ZEROS. DTSEDIT 021700 05 WRK-RMDR PIC 9(05) VALUE ZEROS. DTSEDIT 021800 05 WRK-DAYS PIC 9(05) VALUE ZEROS. DTSEDIT 021900 05 WRK-NUMBER PIC 9(09) VALUE ZEROS. DTSEDIT 022000 05 WRK-SAVE-YEAR PIC 9(05) VALUE ZEROS. DTSEDIT 022100 05 WRK-JULN-YEAR-LNGTH PIC 9(03) VALUE ZEROS. DTSEDIT 022200 05 WRK-NUMBER-DAYS PIC 9(09) VALUE ZEROS. DTSEDIT 022300 05 WRK-NUMBER-DAYS-1 PIC 9(09) VALUE ZEROS. DTSEDIT 022400 05 WRK-NUMBER-DAYS-2 PIC 9(09) VALUE ZEROS. DTSEDIT 022401 05 WRK-LEAP-YEAR-CCYY PIC 9(04) VALUE ZEROS. DTSEDIT 022410 05 WRK-TEMP-CCYY PIC 9(04) VALUE ZEROS. DTSEDIT 022420 05 WRK-TEMP-DATE. DTSEDIT 022430 10 WRK-TEMP-GREG. DTSEDIT 022440 15 WRK-TEMP-GREG-YEAR. DTSEDIT 022450 20 WRK-TEMP-GREG-CC PIC 9(02). DTSEDIT 022460 20 WRK-TEMP-GREG-YY PIC 9(02). DTSEDIT 022470 15 WRK-TEMP-GREG-YEAR-RDFN DTSEDIT 022480 REDEFINES WRK-TEMP-GREG-YEAR. DTSEDIT 022490 20 WRK-TEMP-GREG-CCYY PIC 9(04). DTSEDIT 022491 15 WRK-TEMP-GREG-MM PIC 9(02). DTSEDIT 022492 15 WRK-TEMP-GREG-DD PIC 9(02). DTSEDIT 022493 10 WRK-TEMP-FILLER PIC X(02). DTSEDIT 022494 05 WRK-CNT PIC S9(05) COMP-3. DTSEDIT 022500******************************************************************DTSEDIT 022600** T A B L E S PREFIX TBL *DTSEDIT 022700******************************************************************DTSEDIT 022800 01 TABLES. DTSEDIT 022900 05 TBL-VALID-DATES. DTSEDIT 023000 10 TBL-VALID-DATES-ENTRY OCCURS 12 TIMES. DTSEDIT 023100 15 TBL-ALPHA-MONTH PIC X(10). DTSEDIT 023200 15 TBL-FIRST-DAY-OF-MONTH PIC 9(02). DTSEDIT 023300 15 TBL-LAST-DAY-OF-MONTH PIC 9(02). DTSEDIT 023400 15 TBL-JULN-DAY PIC 9(03). DTSEDIT 023500 05 TBL-DAY-OF-WEEK. DTSEDIT 023600 10 TBL-DAY-OF-WEEK-ENTRY OCCURS 7 TIMES. DTSEDIT 023700 15 TBL-ALPHA-WEEKDAY PIC X(10). DTSEDIT 023800 05 TBL-QTR-BEG-END-DATES. DTSEDIT 023900 10 TBL-QTR-BEG-END-ENTRY OCCURS 12 TIMES. DTSEDIT 024000 15 TBL-QTR-BEG-MM PIC 9(02). DTSEDIT 024100 15 TBL-QTR-BEG-DD PIC 9(02). DTSEDIT 024200 15 TBL-QTR-END-MM PIC 9(02). DTSEDIT 024300 15 TBL-QTR-END-DD PIC 9(02). DTSEDIT 024400******************************************************************DTSEDIT 024500** C O P Y B O O K S - FILES *DTSEDIT 024600******************************************************************DTSEDIT 024700 COPY DTWCC. DTSEDIT 024800******************************************************************DTSEDIT 024900** L I N K A G E *DTSEDIT 025000******************************************************************DTSEDIT 025100 LINKAGE SECTION. DTSEDIT 025200 COPY DTLEDIT. DTSEDIT 025300******************************************************************DTSEDIT 025400* PROCEDURE DIVISION. *DTSEDIT 025500******************************************************************DTSEDIT 025600 PROCEDURE DIVISION USING LNK-DT-AREA. DTSEDIT 025700******************************************************************DTSEDIT 025800 A000-MAIN-ROUTINE SECTION. DTSEDIT 025900******************************************************************DTSEDIT 026000* THIS SECTION CONTROLS THE MAIN PROCESSING OF THE MODULE *DTSEDIT 026100******************************************************************DTSEDIT 026200 PERFORM A100-INITIALIZATION. DTSEDIT 026300 MOVE LNK-DT-FUNC-REQ TO FLG-FUNC-REQ-CODE. DTSEDIT 026400 DTSEDIT 026500 EVALUATE TRUE DTSEDIT 026600 WHEN FUNC-DATE-VALID-CONV DTSEDIT 026700 PERFORM B100-DATE-VALID-CONV DTSEDIT 026800 WHEN FUNC-DATE-CALC DTSEDIT 026900 PERFORM C100-DATE-CALCULATION DTSEDIT 027000 WHEN OTHER DTSEDIT 027100 MOVE '030' TO WRK-RETURN-CODE DTSEDIT 027200 END-EVALUATE. DTSEDIT 027300 PERFORM Z100-FINALIZATION. DTSEDIT 027400 DTSEDIT 027500 A000-EXIT. DTSEDIT 030100 GOBACK. TIE20115 027700******************************************************************DTSEDIT 027800 A100-INITIALIZATION SECTION. DTSEDIT 027900******************************************************************DTSEDIT 028000* THIS SECTION INITALIZES THE WORK AREAS AND THE RETURN CODES *DTSEDIT 028100* USED IN THIS MODULE. *DTSEDIT 028200******************************************************************DTSEDIT 028300 MOVE ZEROS TO WRK-RETURN-CODE. DTSEDIT 028400 MOVE SPACES TO HOLD-AREAS. DTSEDIT 028500 MOVE SPACES TO TABLES. DTSEDIT 028600 MOVE SPACES TO LNK-DT-OUTPUT-SECT. DTSEDIT 028700 DTSEDIT 028800 A100-EXIT. DTSEDIT 028900 EXIT. DTSEDIT 029000******************************************************************DTSEDIT 029100 B100-DATE-VALID-CONV SECTION. DTSEDIT 029200******************************************************************DTSEDIT 029300* THIS SECTION PERFORMS THE CONVERSTION OF DATES FROM ONE FORMAT*DTSEDIT 029400* TO ANOTHER. EVERY DATE WILL FIRST BE VALIDATED AND THEN *DTSEDIT 029500* CONVERTED. *DTSEDIT 029600******************************************************************DTSEDIT 029700 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 029800 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 029900 PERFORM V100-VALIDATE-DATE. DTSEDIT 030000 DTSEDIT 030100* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 030200 IF WRK-RETURN-CODE = ZEROS DTSEDIT 030300 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT DTSEDIT 030400 PERFORM V200-REFORMAT-DATE DTSEDIT 030500 IF WRK-RETURN-CODE = '000' DTSEDIT 030600 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 030700 ELSE DTSEDIT 030800 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 030900 END-IF DTSEDIT 031000 END-IF. DTSEDIT 031100 DTSEDIT 031200 B100-EXIT. DTSEDIT 031300 EXIT. DTSEDIT 031400******************************************************************DTSEDIT 031500 C100-DATE-CALCULATION SECTION. DTSEDIT 031600******************************************************************DTSEDIT 031700* THIS SECTION PERFORMS MANIPULATIONS ON THE DATE(S) GIVEN. *DTSEDIT 031800******************************************************************DTSEDIT 031900 MOVE LNK-DT-CALC-REQ TO FLG-CALC-REQ-CODE. DTSEDIT 032000 DTSEDIT 032100 EVALUATE TRUE DTSEDIT 032200 WHEN CALC-DAYS-BETWEEN DTSEDIT 032300 PERFORM C110-CALCULATE-DAYS-BETWEEN DTSEDIT 032310 WHEN CALC-MONTHS-BETWEEN DTSEDIT 032320 PERFORM C120-CALCULATE-MONTHS-BETWEEN DTSEDIT 032400 WHEN CALC-DAY-OF-WEEK DTSEDIT 032500 PERFORM C130-CALCULATE-DAY-OF-WEEK DTSEDIT 032600 WHEN CALC-QTR-BEG-END DTSEDIT 032700 PERFORM C140-CALCULATE-QTR-BEG-END DTSEDIT 032800 WHEN CALC-DAYS-FUTURE DTSEDIT 032900 WHEN CALC-DAYS-PAST DTSEDIT 033000 PERFORM C150-CALC-DAYS-FUTURE-PAST DTSEDIT 033010 WHEN CALC-WEEKDAYS-FUTURE DTSEDIT 033030 WHEN CALC-WEEKDAYS-PAST DTSEDIT 033040 PERFORM C160-CALC-WEEKDAYS-FUTURE-PAST DTSEDIT 033100 WHEN CALC-MONTHS-FUTURE DTSEDIT 033200 WHEN CALC-MONTHS-PAST DTSEDIT 033300 PERFORM C170-CALC-MONTHS-FUTURE-PAST DTSEDIT 033400 WHEN CALC-YEARS-FUTURE DTSEDIT 033500 WHEN CALC-YEARS-PAST DTSEDIT 033600 PERFORM C180-CALC-YEARS-FUTURE-PAST DTSEDIT 033700 WHEN CALC-LAST-DAY-MM DTSEDIT 033800 PERFORM C190-CALCULATE-LAST-DAY-MM DTSEDIT 033900 WHEN CALC-ALPHA-MONTH DTSEDIT 034000 PERFORM C200-CALCULATE-ALPHA-MONTH DTSEDIT 034100 WHEN CALC-STND-YEAR-SPAN DTSEDIT 034200 PERFORM C210-CALCULATE-STND-YEAR-SPAN DTSEDIT 034210 WHEN CALC-BEGIN-NEXT-MONTH DTSEDIT 034220 PERFORM C220-CALC-BEGIN-NEXT-MONTH DTSEDIT 034300 WHEN OTHER DTSEDIT 034400 MOVE '040' TO WRK-RETURN-CODE DTSEDIT 034500 END-EVALUATE. DTSEDIT 034600 DTSEDIT 034700 C100-EXIT. DTSEDIT 034800 EXIT. DTSEDIT 034900******************************************************************DTSEDIT 035000 C110-CALCULATE-DAYS-BETWEEN SECTION. DTSEDIT 035100******************************************************************DTSEDIT 035200* THIS SECTION DETERMINES THE NUMBER OF DAYS BETWEEN TWO DATES. *DTSEDIT 035300* BOTH DATES WILL BE VALIDATED PRIOR TO CALCULATIONS TO ENSURE *DTSEDIT 035400* THAT THEY ARE VALID DATES. WARNING: IF INPUT-1-DATE IS *DTSEDIT 035410* GREATER THAN INPUT-2-DATE, THE RESULTING DAYS BETWEEN WILL BE *DTSEDIT 035420* NEGATIVE. IF ABSOLUTE DAYS BETWEEN IS NEEDED, MAKE SURE THAT *DTSEDIT 035430* THE DATE IN INPUT-1-DATE IS LESS THAN OR EQUAL TO INPUT-2-DATE.*DTSEDIT 035500******************************************************************DTSEDIT 035600* VALIDATE THE FIRST INPUT DATE *DTSEDIT 035700 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 035800 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 035900 PERFORM V100-VALIDATE-DATE. DTSEDIT 036000 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 036100 GO TO C110-EXIT DTSEDIT 036200 END-IF. DTSEDIT 036300 DTSEDIT 036400* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 036500 PERFORM V300-EQUATION-FORMAT DTSEDIT 036600 MOVE WRK-NUMBER-DAYS TO WRK-NUMBER-DAYS-1 DTSEDIT 036700 DTSEDIT 036800* VALIDATE THE SECOND INPUT-DATE *DTSEDIT 036900 MOVE LNK-DT-INPUT-2-DATE TO HLD-DATE. DTSEDIT 037000 MOVE LNK-DT-INPUT-2-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 037100 PERFORM V100-VALIDATE-DATE. DTSEDIT 037200 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 037300 GO TO C110-EXIT DTSEDIT 037400 END-IF. DTSEDIT 037500 DTSEDIT 037600* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 037700 PERFORM V300-EQUATION-FORMAT DTSEDIT 037800 MOVE WRK-NUMBER-DAYS TO WRK-NUMBER-DAYS-2 DTSEDIT 037900 DTSEDIT 037910* WILL RETURN A NEGATIVE DAYS BETWEEN IS INPUT-1-DATE IS GREATER *DTSEDIT 037920* THAN INPUT-2-DATE *DTSEDIT 038000 COMPUTE WRK-CNT = WRK-NUMBER-DAYS-2 DTSEDIT 038100 - WRK-NUMBER-DAYS-1 DTSEDIT 038200 DTSEDIT 038300 MOVE WRK-CNT TO LNK-DT-DAY-CNT. DTSEDIT 038400 DTSEDIT 038500 C110-EXIT. DTSEDIT 038600 EXIT. DTSEDIT 038610******************************************************************DTSEDIT 038620 C120-CALCULATE-MONTHS-BETWEEN SECTION. DTSEDIT 038630******************************************************************DTSEDIT 038640* THIS SECTION DETERMINES THE NUMBER OF MONTHS BETWEEN TWO DATES.*DTSEDIT 038650* BOTH DATES WILL BE VALIDATED PRIOR TO CALCULATIONS TO ENSURE *DTSEDIT 038660* THAT THEY ARE VALID DATES. MORE APPROPRIATELY THIS DETERMINES *DTSEDIT 038670* THE NUMBER OF MONTH ENDS BETWEEN TWO DATES. THE NUMBER OF *DTSEDIT 038680* MONTHS RETURNED WILL ALWAYS BE A POSITIVE VALUE REGARDLESS AS *DTSEDIT 038690* TO WHICH DATE IS GREATER. *DTSEDIT 038691******************************************************************DTSEDIT 038692* VALIDATE THE FIRST INPUT DATE *DTSEDIT 038693 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 038694 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 038695 PERFORM V100-VALIDATE-DATE. DTSEDIT 038696 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 038697 GO TO C120-EXIT DTSEDIT 038698 END-IF. DTSEDIT 038699 DTSEDIT 038700* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 038701* REFORMAT THE SECOND DATE TO ENSURE THAT IT IS GREGORIAN FORMAT *DTSEDIT 038702 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 038703 PERFORM V200-REFORMAT-DATE. DTSEDIT 038704 MOVE HLD-GREG-DATE TO HLD-TEMP-GREG-DATE. DTSEDIT 038706 DTSEDIT 038707* VALIDATE THE SECOND INPUT-DATE *DTSEDIT 038708 MOVE LNK-DT-INPUT-2-DATE TO HLD-DATE. DTSEDIT 038709 MOVE LNK-DT-INPUT-2-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 038710 PERFORM V100-VALIDATE-DATE. DTSEDIT 038711 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 038712 GO TO C120-EXIT DTSEDIT 038713 END-IF. DTSEDIT 038714 DTSEDIT 038715* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 038716* REFORMAT THE SECOND DATE TO ENSURE THAT IT IS GREGORIAN FORMAT *DTSEDIT 038717 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 038718 PERFORM V200-REFORMAT-DATE. DTSEDIT 038719 MOVE HLD-GREG-DATE TO WRK-TEMP-DATE. DTSEDIT 038721 DTSEDIT 038722* DOES NOT MATTER WHICH DATE IS GREATER *DTSEDIT 038723 IF HLD-TEMP-GREG-DATE < HLD-GREG-DATE DTSEDIT 038724 COMPUTE WRK-CNT = WRK-TEMP-GREG-CCYY - HLD-TEMP-GREG-CCYYDTSEDIT 038725 COMPUTE WRK-CNT = (WRK-CNT * 12) + DTSEDIT 038726 (WRK-TEMP-GREG-MM - HLD-TEMP-GREG-MM) DTSEDIT 038727 ELSE DTSEDIT 038728 COMPUTE WRK-CNT = HLD-TEMP-GREG-CCYY - WRK-TEMP-GREG-CCYYDTSEDIT 038729 COMPUTE WRK-CNT = (WRK-CNT * 12) + DTSEDIT 038730 (HLD-TEMP-GREG-MM - WRK-TEMP-GREG-MM) DTSEDIT 038731 END-IF. DTSEDIT 038733 DTSEDIT 038734 MOVE WRK-CNT TO LNK-DT-MONTH-CNT. DTSEDIT 038735 DTSEDIT 038736 C120-EXIT. DTSEDIT 038737 EXIT. DTSEDIT 038740******************************************************************DTSEDIT 038800 C130-CALCULATE-DAY-OF-WEEK SECTION. DTSEDIT 038900******************************************************************DTSEDIT 039000* THIS SECTION DETERMINES THE DAY OF THE WEEK FOR AN INPUTTED *DTSEDIT 039100* DATE. THE INPUTTED DATE WILL FIRST BE VALIDATED TO ENSURE *DTSEDIT 039200* THAT IT IS A VALID DATE. *DTSEDIT 039300******************************************************************DTSEDIT 039400* VALIDATE THE INPUT DATE *DTSEDIT 039500 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 039600 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 039700 PERFORM V100-VALIDATE-DATE. DTSEDIT 039800 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 039900 GO TO C130-EXIT DTSEDIT 040000 END-IF. DTSEDIT 040100 DTSEDIT 040200* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 040290 PERFORM V300-EQUATION-FORMAT. DTSEDIT 040291 DIVIDE WRK-NUMBER-DAYS BY 7 DTSEDIT 040292 GIVING WRK-NUMBER REMAINDER WRK-RMDR. DTSEDIT 040293 DTSEDIT 040294* THE WEEK DAY OF 00/00/0000 IS A FRIDAY THEREFORE A RMDR OF *DTSEDIT 040295* 0 IS A FRIDAY, 1 IS A SATURDAY, 2 IS A SUNDAY, ETC.. *DTSEDIT 040296 MOVE LIT-DAY-OF-WEEK-DATA TO TBL-DAY-OF-WEEK. DTSEDIT 040297 COMPUTE SUB-DAY = WRK-RMDR + 1. DTSEDIT 040298 MOVE TBL-ALPHA-WEEKDAY (SUB-DAY) TO LNK-DT-OUTPUT-ALPHA. DTSEDIT 040299 DTSEDIT 041300 C130-EXIT. DTSEDIT 041400 EXIT. DTSEDIT 041500******************************************************************DTSEDIT 041600 C140-CALCULATE-QTR-BEG-END SECTION. DTSEDIT 041700******************************************************************DTSEDIT 041800* THIS SECTION DETERMINES THE BEGINNING AND ENDING DATES OF THE *DTSEDIT 041900* OF THE QUARTER THAT THE INPUT DATE IS IN. THE INPUT DATE WILL *DTSEDIT 042000* FIRST BE VALIDATED TO ENSURE THAT IT IS A VALID DATE. *DTSEDIT 042100******************************************************************DTSEDIT 042200* VALIDATE THE INPUT DATE *DTSEDIT 042300 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 042400 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 042500 PERFORM V100-VALIDATE-DATE. DTSEDIT 042600 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 042700 GO TO C140-EXIT DTSEDIT 042800 END-IF. DTSEDIT 042900 DTSEDIT 043000* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 043100 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 043200 PERFORM V200-REFORMAT-DATE. DTSEDIT 043300 DTSEDIT 043400* DATES ARE IN THE GREGORIAN FORMAT *DTSEDIT 043500 MOVE LIT-QTR-BEG-END-DATA TO TBL-QTR-BEG-END-DATES.DTSEDIT 043600 MOVE HLD-GREG-DATE-MM TO SUB-QTR. DTSEDIT 043700 DTSEDIT 043800 MOVE SPACES TO WRK-TEMP-DATE. DTSEDIT 043900 MOVE HLD-GREG-DATE-CCYY TO WRK-TEMP-GREG-CCYY. DTSEDIT 044000 MOVE TBL-QTR-BEG-MM (SUB-QTR) TO WRK-TEMP-GREG-MM. DTSEDIT 044100 MOVE TBL-QTR-BEG-DD (SUB-QTR) TO WRK-TEMP-GREG-DD. DTSEDIT 044200 DTSEDIT 044300* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 044400 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 044500 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 044600 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 044700 PERFORM V200-REFORMAT-DATE. DTSEDIT 044800 IF WRK-RETURN-CODE = '000' DTSEDIT 044900 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 045000 ELSE DTSEDIT 045100 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 045200 END-IF. DTSEDIT 045300 DTSEDIT 045400 MOVE SPACES TO WRK-TEMP-DATE. DTSEDIT 045500 MOVE HLD-GREG-DATE-CCYY TO WRK-TEMP-GREG-CCYY. DTSEDIT 045600 MOVE TBL-QTR-END-MM (SUB-QTR) TO WRK-TEMP-GREG-MM. DTSEDIT 045700 MOVE TBL-QTR-END-DD (SUB-QTR) TO WRK-TEMP-GREG-DD. DTSEDIT 045800 DTSEDIT 045900* REFORMAT FOR THE OUTPUT 2 AND PLACE IN THE RETURN AREA *DTSEDIT 046000 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 046100 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 046200 MOVE LNK-DT-OUTPUT-2-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 046300 PERFORM V200-REFORMAT-DATE. DTSEDIT 046400 IF WRK-RETURN-CODE = '000' DTSEDIT 046500 MOVE HLD-DATE TO LNK-DT-OUTPUT-2-DATE DTSEDIT 046600 ELSE DTSEDIT 046700 MOVE SPACES TO LNK-DT-OUTPUT-2-DATE DTSEDIT 046800 END-IF. DTSEDIT 046900 DTSEDIT 047000 C140-EXIT. DTSEDIT 047100 EXIT. DTSEDIT 047200******************************************************************DTSEDIT 047300 C150-CALC-DAYS-FUTURE-PAST SECTION. DTSEDIT 047400******************************************************************DTSEDIT 047500* THIS SECTION CALCULATES A DATE 'X' DAYS INTO THE FUTURE/PAST, *DTSEDIT 047600* WHERE 'X' IS USER SUPPLIED AND SO IS THE BASE DATE. THE BASE *DTSEDIT 047700* DATE WILL BE VALIDATED PRIOR TO MANIPULATIONS. 'X' DAYS CAN *DTSEDIT 047710* CONTAIN A NEGATIVE VALUE. FOR READABLITY TRY NOT TO USE THIS *DTSEDIT 047720* ABILITY UNLESS NECESSARY. *DTSEDIT 047800******************************************************************DTSEDIT 047900* VALIDATE THE INPUT DATE *DTSEDIT 048000 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 048100 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 048200 PERFORM V100-VALIDATE-DATE. DTSEDIT 048300 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 048400 GO TO C150-EXIT DTSEDIT 048500 END-IF. DTSEDIT 048600 DTSEDIT 048700* VALIDATE THE NUMBER OF DAYS TO BE INCREASED/DECREASED *DTSEDIT 048800 MOVE LNK-DT-DAY-CNT TO WRK-CNT. DTSEDIT 048900 IF WRK-CNT NOT NUMERIC DTSEDIT 049000 MOVE '051' TO WRK-RETURN-CODE DTSEDIT 049100 GO TO C150-EXIT DTSEDIT 049200 END-IF. DTSEDIT 049300 DTSEDIT 049400* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 049500 PERFORM V300-EQUATION-FORMAT. DTSEDIT 049600 EVALUATE TRUE DTSEDIT 049700 WHEN CALC-DAYS-FUTURE DTSEDIT 049800 COMPUTE WRK-NUMBER-DAYS = WRK-NUMBER-DAYS DTSEDIT 049900 + WRK-CNT DTSEDIT 050000 WHEN CALC-DAYS-PAST DTSEDIT 050100 COMPUTE WRK-NUMBER-DAYS = WRK-NUMBER-DAYS DTSEDIT 050200 - WRK-CNT DTSEDIT 050300 END-EVALUATE. DTSEDIT 050400 DTSEDIT 050500* DECODE THE EQUATION FORMATED DATE INTO A JULIAN DATE *DTSEDIT 050600 PERFORM V400-EQUATION-DECODE DTSEDIT 050700 DTSEDIT 050800* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 050900 MOVE '02' TO FLG-IN-DATE-FRMT. DTSEDIT 051000 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 051100 PERFORM V200-REFORMAT-DATE. DTSEDIT 051200 IF WRK-RETURN-CODE = '000' DTSEDIT 051300 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 051400 ELSE DTSEDIT 051500 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 051600 END-IF. DTSEDIT 051700 DTSEDIT 051800 C150-EXIT. DTSEDIT 051900 EXIT. DTSEDIT 051910******************************************************************DTSEDIT 051920 C160-CALC-WEEKDAYS-FUTURE-PAST SECTION. DTSEDIT 051930******************************************************************DTSEDIT 051940* THIS SECTION CALCULATES A DATE 'X' WORKING DAYS IN THE FUTURE/ *DTSEDIT 051941* PAST (IT DOES NOT TAKE INTO ACCOUNT HOLIDAYS, IT ONLY EXCLUDES *DTSEDIT 051942* THE WEEKEND IN ITS CALCULATION). 'X' IS USER SUPPLIED AND SO *DTSEDIT 051950* IS THE BASE DATE. THE BASE DATE WILL BE VALIDATED PRIOR TO *DTSEDIT 051960* MANIPULATIONS. 'X' DAYS CAN CONTAIN A NEGATIVE VALUE, HOWEVER,*DTSEDIT 051970* FOR READABLITY, TRY NOT TO USE THIS ABILITY UNLESS NECESSARY. *DTSEDIT 051990******************************************************************DTSEDIT 051991* VALIDATE THE INPUT DATE *DTSEDIT 051992 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 051993 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 051994 PERFORM V100-VALIDATE-DATE. DTSEDIT 051995 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 051996 GO TO C160-EXIT DTSEDIT 051997 END-IF. DTSEDIT 051998 DTSEDIT 051999* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 052000 PERFORM V300-EQUATION-FORMAT. DTSEDIT 052003 DTSEDIT 052004* DETERMINE THE DAY OF THE WEEK THE BASE DATE IS. USING 1 TO *DTSEDIT 052005* REPRESENT A FRIDAY, 2 IS A SATURDAY, 3 IS A SUNDAY, ETC... *DTSEDIT 052006 DIVIDE WRK-NUMBER-DAYS BY 7 DTSEDIT 052007 GIVING WRK-NUMBER REMAINDER WRK-RMDR. DTSEDIT 052009 COMPUTE SUB-DAY = WRK-RMDR + 1. DTSEDIT 052010 MOVE LIT-DAY-OF-WEEK-DATA TO TBL-DAY-OF-WEEK. DTSEDIT 052011 DTSEDIT 052012* VALIDATE THE NUMBER OF DAYS TO BE INCREASED/DECREASED *DTSEDIT 052013 MOVE LNK-DT-DAY-CNT TO WRK-CNT. DTSEDIT 052014 IF WRK-CNT NOT NUMERIC DTSEDIT 052015 MOVE '051' TO WRK-RETURN-CODE DTSEDIT 052016 GO TO C160-EXIT DTSEDIT 052017 END-IF. DTSEDIT 052018 DTSEDIT 052019* FIND NUMBER OF WEEKS TO BE SPANNED (5 DAY WEEKS) *DTSEDIT 052020 DIVIDE WRK-CNT BY 5 DTSEDIT 052021 GIVING WRK-NUMBER REMAINDER WRK-RMDR. DTSEDIT 052022 DTSEDIT 052023* CONVERT TO DAYS *DTSEDIT 052024 COMPUTE WRK-DAYS = WRK-NUMBER * 7. DTSEDIT 052025 DTSEDIT 052026 IF (WRK-CNT < 0 AND CALC-WEEKDAYS-FUTURE) DTSEDIT 052027 OR (WRK-CNT > 0 AND CALC-WEEKDAYS-PAST) DTSEDIT 052028 PERFORM UNTIL WRK-RMDR = 0 DTSEDIT 052029 IF SUB-DAY < 0 DTSEDIT 052030 MOVE 7 TO SUB-DAY DTSEDIT 052031 END-IF DTSEDIT 052032 EVALUATE TBL-ALPHA-WEEKDAY (SUB-DAY) DTSEDIT 052033 WHEN 'MONDAY ' DTSEDIT 052034 SUBTRACT 3 FROM SUB-DAY DTSEDIT 052035 ADD 3 TO WRK-DAYS DTSEDIT 052036 WHEN 'SUNDAY ' DTSEDIT 052037 SUBTRACT 2 FROM SUB-DAY DTSEDIT 052038 ADD 2 TO WRK-DAYS DTSEDIT 052039 WHEN OTHER DTSEDIT 052040 SUBTRACT 1 FROM SUB-DAY DTSEDIT 052041 ADD 1 TO WRK-DAYS DTSEDIT 052042 END-EVALUATE DTSEDIT 052043 SUBTRACT 1 FROM WRK-RMDR DTSEDIT 052044 END-PERFORM DTSEDIT 052045 SUBTRACT WRK-DAYS FROM WRK-NUMBER-DAYS DTSEDIT 052046 ELSE DTSEDIT 052047 PERFORM UNTIL WRK-RMDR = 0 DTSEDIT 052048 IF SUB-DAY > 7 DTSEDIT 052049 MOVE 1 TO SUB-DAY DTSEDIT 052050 END-IF DTSEDIT 052051 EVALUATE TBL-ALPHA-WEEKDAY (SUB-DAY) DTSEDIT 052052 WHEN 'FRIDAY ' DTSEDIT 052053 ADD 3 TO SUB-DAY DTSEDIT 052054 ADD 3 TO WRK-DAYS DTSEDIT 052055 WHEN 'SATURDAY ' DTSEDIT 052056 ADD 2 TO SUB-DAY DTSEDIT 052057 ADD 2 TO WRK-DAYS DTSEDIT 052058 WHEN OTHER DTSEDIT 052059 ADD 1 TO SUB-DAY DTSEDIT 052060 ADD 1 TO WRK-DAYS DTSEDIT 052061 END-EVALUATE DTSEDIT 052062 SUBTRACT 1 FROM WRK-RMDR DTSEDIT 052063 END-PERFORM DTSEDIT 052064 ADD WRK-DAYS TO WRK-NUMBER-DAYS DTSEDIT 052065 END-IF. DTSEDIT 052066 DTSEDIT 052076* DECODE THE EQUATION FORMATED DATE INTO A JULIAN DATE *DTSEDIT 052077 PERFORM V400-EQUATION-DECODE DTSEDIT 052078 DTSEDIT 052079* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 052080 MOVE '02' TO FLG-IN-DATE-FRMT. DTSEDIT 052081 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 052082 PERFORM V200-REFORMAT-DATE. DTSEDIT 052083 IF WRK-RETURN-CODE = '000' DTSEDIT 052084 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 052085 ELSE DTSEDIT 052086 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 052087 END-IF. DTSEDIT 052088 DTSEDIT 052089 C160-EXIT. DTSEDIT 052090 EXIT. DTSEDIT 052091******************************************************************DTSEDIT 052100 C170-CALC-MONTHS-FUTURE-PAST SECTION. DTSEDIT 052200******************************************************************DTSEDIT 052300* THIS SECTION CALCULATES A DATE 'X' MONTHS INTO THE FUTURE/PAST,*DTSEDIT 052400* WHERE 'X' IS USER SUPPLIED AND SO IS THE BASE DATE. THE BASE *DTSEDIT 052410* DATE WILL BE VALIDATED PRIOR TO MANIPULATIONS. 'X' MONTHS CAN *DTSEDIT 052420* CONTAIN A NEGATIVE VALUE. FOR READABLITY TRY NOT TO USE THIS *DTSEDIT 052430* ABILITY UNLESS NECESSARY. *DTSEDIT 052600******************************************************************DTSEDIT 052700* VALIDATE THE INPUT DATE *DTSEDIT 052800 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 052900 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 053000 PERFORM V100-VALIDATE-DATE. DTSEDIT 053100 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 053200 GO TO C170-EXIT DTSEDIT 053300 END-IF. DTSEDIT 053400 DTSEDIT 053500* VALIDATE THE NUMBER OF MONTHS TO BE INCREASED/DECREASED *DTSEDIT 053600 MOVE LNK-DT-MONTH-CNT TO WRK-CNT DTSEDIT 053700 IF WRK-CNT NOT NUMERIC DTSEDIT 053800 MOVE '051' TO WRK-RETURN-CODE DTSEDIT 053900 GO TO C170-EXIT DTSEDIT 054000 END-IF. DTSEDIT 054100 DTSEDIT 054200* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 054300 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 054400 PERFORM V200-REFORMAT-DATE. DTSEDIT 054500 DTSEDIT 054600* DATES ARE NOW IN THE GREGORIAN DATE FORMAT *DTSEDIT 054700 MOVE HLD-DATE TO WRK-TEMP-DATE. DTSEDIT 054800 DIVIDE WRK-CNT BY 12 DTSEDIT 054900 GIVING WRK-NUMBER REMAINDER WRK-RMDR. DTSEDIT 055000 EVALUATE TRUE ALSO TRUE DTSEDIT 055100 WHEN CALC-MONTHS-FUTURE ALSO WRK-CNT >= 0 DTSEDIT 055110 WHEN CALC-MONTHS-PAST ALSO WRK-CNT < 0 DTSEDIT 055200 ADD WRK-NUMBER TO WRK-TEMP-GREG-CCYY DTSEDIT 055300 ADD WRK-RMDR TO WRK-TEMP-GREG-MM DTSEDIT 055400 IF WRK-TEMP-GREG-MM > 12 DTSEDIT 055500 ADD 1 TO WRK-TEMP-GREG-CCYY DTSEDIT 055600 SUBTRACT 12 FROM WRK-TEMP-GREG-MM DTSEDIT 055700 END-IF DTSEDIT 055801 WHEN CALC-MONTHS-FUTURE ALSO WRK-CNT < 0 DTSEDIT 055810 WHEN CALC-MONTHS-PAST ALSO WRK-CNT >= 0 DTSEDIT 055900 IF WRK-RMDR >= WRK-TEMP-GREG-MM DTSEDIT 056000 ADD 1 TO WRK-NUMBER DTSEDIT 056100 ADD 12 TO WRK-TEMP-GREG-MM DTSEDIT 056200 END-IF DTSEDIT 056300 SUBTRACT WRK-NUMBER FROM WRK-TEMP-GREG-CCYY DTSEDIT 056400 SUBTRACT WRK-RMDR FROM WRK-TEMP-GREG-MM DTSEDIT 056500 END-EVALUATE. DTSEDIT 056600 DTSEDIT 056700* ENSURE DATE COMPUTED IS STILL VALID *DTSEDIT 056800 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 056900 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 057000 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 057100 DTSEDIT 057200 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 057300 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 057400 MOVE TBL-LAST-DAY-OF-MONTH (SUB-MM) DTSEDIT 057500 TO HLD-GREG-DATE-DD DTSEDIT 057600 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 057700 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 057800 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 057900 GO TO C170-EXIT DTSEDIT 058000 END-IF DTSEDIT 058100 END-IF. DTSEDIT 058200 DTSEDIT 058300* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 058400 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 058500 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 058600 PERFORM V200-REFORMAT-DATE. DTSEDIT 058700 IF WRK-RETURN-CODE = '000' DTSEDIT 058800 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 058900 ELSE DTSEDIT 059000 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 059100 END-IF. DTSEDIT 059200 DTSEDIT 059300 C170-EXIT. DTSEDIT 059400 EXIT. DTSEDIT 059500******************************************************************DTSEDIT 059600 C180-CALC-YEARS-FUTURE-PAST SECTION. DTSEDIT 059700******************************************************************DTSEDIT 059800* THIS SECTION CALCULATES A DATE 'X' YEARS INTO THE FUTURE/PAST, *DTSEDIT 059900* WHERE 'X' IS USER SUPPLIED AND SO IS THE BASE DATE. THE BASE *DTSEDIT 059910* DATE WILL BE VALIDATED PRIOR TO MANIPULATIONS. 'X' YEARS CAN *DTSEDIT 059920* CONTAIN A NEGATIVE VALUE. FOR READABLITY TRY NOT TO USE THIS *DTSEDIT 059930* ABILITY UNLESS NECESSARY. *DTSEDIT 060100******************************************************************DTSEDIT 060200* VALIDATE THE INPUT DATE *DTSEDIT 060300 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 060400 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 060500 PERFORM V100-VALIDATE-DATE. DTSEDIT 060600 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 060700 GO TO C180-EXIT DTSEDIT 060800 END-IF. DTSEDIT 060900 DTSEDIT 061000* VALIDATE THE NUMBER OF YEARS TO BE INCREASED/DECREASED *DTSEDIT 061100 MOVE LNK-DT-YEAR-CNT TO WRK-CNT DTSEDIT 061200 IF WRK-CNT NOT NUMERIC DTSEDIT 061300 MOVE '051' TO WRK-RETURN-CODE DTSEDIT 061400 GO TO C180-EXIT DTSEDIT 061500 END-IF. DTSEDIT 061600 DTSEDIT 061700* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 061800 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 061900 PERFORM V200-REFORMAT-DATE. DTSEDIT 062000 DTSEDIT 062100* DATES ARE NOW IN THE GREGORIAN DATE FORMAT *DTSEDIT 062200 MOVE HLD-DATE TO WRK-TEMP-DATE. DTSEDIT 062300 EVALUATE TRUE DTSEDIT 062400 WHEN CALC-YEARS-FUTURE DTSEDIT 062500 ADD WRK-CNT TO WRK-TEMP-GREG-CCYY DTSEDIT 062600 WHEN CALC-YEARS-PAST DTSEDIT 062700 SUBTRACT WRK-CNT FROM WRK-TEMP-GREG-CCYY DTSEDIT 062800 END-EVALUATE. DTSEDIT 062900 DTSEDIT 063000* ENSURE DATE COMPUTED IS STILL VALID *DTSEDIT 063100 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 063200 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 063300 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 063400 DTSEDIT 063500 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 063600 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 063700 MOVE TBL-LAST-DAY-OF-MONTH (SUB-MM) DTSEDIT 063800 TO HLD-GREG-DATE-DD DTSEDIT 063900 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 064000 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 064100 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 064200 GO TO C180-EXIT DTSEDIT 064300 END-IF DTSEDIT 064400 END-IF. DTSEDIT 064500 DTSEDIT 064600* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 064700 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 064800 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 064900 PERFORM V200-REFORMAT-DATE. DTSEDIT 065000 IF WRK-RETURN-CODE = '000' DTSEDIT 065100 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 065200 ELSE DTSEDIT 065300 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 065400 END-IF. DTSEDIT 065500 DTSEDIT 065600 C180-EXIT. DTSEDIT 065700 EXIT. DTSEDIT 065800******************************************************************DTSEDIT 065900 C190-CALCULATE-LAST-DAY-MM SECTION. DTSEDIT 066000******************************************************************DTSEDIT 066100* THIS SECTION CALCULATES THE LAST DAY OF THE MONTH FOR A GIVEN *DTSEDIT 066200* DATE. THE INPUTED DATE WILL BE VALIDATED TO ENSURE THAT IT IS *DTSEDIT 066300* A VALID DATE. *DTSEDIT 066400******************************************************************DTSEDIT 066500* VALIDATE THE INPUT DATE *DTSEDIT 066600 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 066700 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 066800 PERFORM V100-VALIDATE-DATE. DTSEDIT 066900 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 067000 GO TO C190-EXIT DTSEDIT 067100 END-IF. DTSEDIT 067200 DTSEDIT 067300* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 067400 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 067500 PERFORM V200-REFORMAT-DATE. DTSEDIT 067600 DTSEDIT 067700* DATES ARE NOW IN THE GREGORIAN DATE FORMAT *DTSEDIT 067800 MOVE HLD-GREG-DATE-MM TO SUB-MM. DTSEDIT 067900 MOVE TBL-LAST-DAY-OF-MONTH (SUB-MM) TO HLD-GREG-DATE-DD. DTSEDIT 068000 DTSEDIT 068100* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 068200 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 068300 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 068400 PERFORM V200-REFORMAT-DATE. DTSEDIT 068500 IF WRK-RETURN-CODE = '000' DTSEDIT 068600 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 068700 ELSE DTSEDIT 068800 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 068900 END-IF. DTSEDIT 069000 DTSEDIT 069100 C190-EXIT. DTSEDIT 069200 EXIT. DTSEDIT 069300******************************************************************DTSEDIT 069400 C200-CALCULATE-ALPHA-MONTH SECTION. DTSEDIT 069500******************************************************************DTSEDIT 069600* THIS SECTION CONVERTS AN INPUTTED MONTH TO ITS ALPHABETICAL *DTSEDIT 069700* REPRESENTATION OF THE MONTH. THE INPUT NUMERIC MONTH WILL BE *DTSEDIT 069800* VALIDATED TO ENSURE THAT IT IS BETWEEN 1 AND 12. *DTSEDIT 069900******************************************************************DTSEDIT 070000* VALIDATE THE INPUTTED NUMERIC MONTH *DTSEDIT 070100 MOVE LNK-DT-INPUT-MONTH TO WRK-CNT DTSEDIT 070200 IF WRK-CNT NUMERIC DTSEDIT 070300 IF WRK-CNT < 1 DTSEDIT 070400 OR WRK-CNT > 12 DTSEDIT 070500 MOVE '052' TO WRK-RETURN-CODE DTSEDIT 070600 GO TO C200-EXIT DTSEDIT 070700 END-IF DTSEDIT 070800 ELSE DTSEDIT 070900 MOVE '051' TO WRK-RETURN-CODE DTSEDIT 071000 GO TO C200-EXIT DTSEDIT 071100 END-IF. DTSEDIT 071200 DTSEDIT 071300* DETERMINE THE ALPHABETICAL REPRESENTAION OF THE MONTH *DTSEDIT 071400 MOVE LIT-LEAP-YEAR-DATA TO TBL-VALID-DATES. DTSEDIT 071500 MOVE WRK-CNT TO SUB-MM. DTSEDIT 071600 MOVE TBL-ALPHA-MONTH (SUB-MM) TO LNK-DT-OUTPUT-ALPHA. DTSEDIT 071700 DTSEDIT 071800 C200-EXIT. DTSEDIT 071900 EXIT. DTSEDIT 072000******************************************************************DTSEDIT 072100 C210-CALCULATE-STND-YEAR-SPAN SECTION. DTSEDIT 072200******************************************************************DTSEDIT 072300* THIS SECTION DETERMINES THE UNIPAC STANDARD YEAR SPAN FOR *DTSEDIT 072400* VALID DATES. IT WILL CALCULATE 10 YEARS IN THE FUTURE AND 15 *DTSEDIT 072500* YEARS IN THE PAST FROM AN INPUTTED DATE. IT WILL ALSO ENSURE *DTSEDIT 072510* THAT THE DATES RETURNED ARE VALID. *DTSEDIT 072600******************************************************************DTSEDIT 072700* VALIDATE THE INPUT DATE *DTSEDIT 072800 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 072900 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 073000 PERFORM V100-VALIDATE-DATE. DTSEDIT 073100 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 073200 GO TO C210-EXIT DTSEDIT 073300 END-IF. DTSEDIT 073400 DTSEDIT 073480* DATE IS EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 073490 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 073491 PERFORM V200-REFORMAT-DATE. DTSEDIT 073492 DTSEDIT 073493* DATE IS NOW IN GREGORIAN FORMAT. COMPUTE 15 YEARS IN THE PAST *DTSEDIT 073494 MOVE HLD-DATE TO WRK-TEMP-DATE. DTSEDIT 073497 SUBTRACT +15 FROM WRK-TEMP-GREG-CCYY. DTSEDIT 073501 DTSEDIT 073502* ENSURE DATE COMPUTED IS STILL VALID *DTSEDIT 073503 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 073504 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 073505 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 073506 DTSEDIT 073507 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 073508 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 073509 MOVE TBL-LAST-DAY-OF-MONTH (SUB-MM) DTSEDIT 073510 TO HLD-GREG-DATE-DD DTSEDIT 073511 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 073512 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 073513 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 073514 GO TO C210-EXIT DTSEDIT 073515 END-IF DTSEDIT 073516 END-IF. DTSEDIT 073517 DTSEDIT 073518* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 073519 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 073520 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 073521 PERFORM V200-REFORMAT-DATE. DTSEDIT 073522 IF WRK-RETURN-CODE = '000' DTSEDIT 073523 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 073524 ELSE DTSEDIT 073525 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 073526 END-IF. DTSEDIT 077400 DTSEDIT 077410* COMPUTE 10 YEARS IN THE FUTURE (25 YEARS FROM THE PAST DATE). *DTSEDIT 077440 ADD +25 TO WRK-TEMP-GREG-CCYY. DTSEDIT 077450 DTSEDIT 077460* ENSURE DATE COMPUTED IS STILL VALID *DTSEDIT 077470 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 077480 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 077490 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 077491 DTSEDIT 077492 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 077493 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 077494 MOVE TBL-LAST-DAY-OF-MONTH (SUB-MM) DTSEDIT 077495 TO HLD-GREG-DATE-DD DTSEDIT 077496 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 077497 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 077498 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 077499 GO TO C210-EXIT DTSEDIT 077500 END-IF DTSEDIT 077501 END-IF. DTSEDIT 077502 DTSEDIT 077503* REFORMAT FOR THE OUTPUT 2 AND PLACE IN THE RETURN AREA *DTSEDIT 077504 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 077505 MOVE LNK-DT-OUTPUT-2-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 077506 PERFORM V200-REFORMAT-DATE. DTSEDIT 077507 IF WRK-RETURN-CODE = '000' DTSEDIT 077508 MOVE HLD-DATE TO LNK-DT-OUTPUT-2-DATE DTSEDIT 077509 ELSE DTSEDIT 077510 MOVE SPACES TO LNK-DT-OUTPUT-2-DATE DTSEDIT 077511 END-IF. DTSEDIT 077512 DTSEDIT 077520 C210-EXIT. DTSEDIT 077600 EXIT. DTSEDIT 077700******************************************************************DTSEDIT 077800 C220-CALC-BEGIN-NEXT-MONTH SECTION. DTSEDIT 077900******************************************************************DTSEDIT 078000* THIS SECTION CALCULATES THE BEGIN OF THE NEXT MONTH WHERE THE *DTSEDIT 078100* THE BASE DATE IS USER SUPPLIED. THE BASE DATE WILL BE *DTSEDIT 078200* VALIDATED PRIOR TO MANIPULATIONS. *DTSEDIT 078500******************************************************************DTSEDIT 078600* VALIDATE THE INPUT DATE *DTSEDIT 078700 MOVE LNK-DT-INPUT-1-DATE TO HLD-DATE. DTSEDIT 078800 MOVE LNK-DT-INPUT-1-FRMT TO FLG-IN-DATE-FRMT. DTSEDIT 078900 PERFORM V100-VALIDATE-DATE. DTSEDIT 079000 IF WRK-RETURN-CODE NOT = '000' DTSEDIT 079100 GO TO C220-EXIT DTSEDIT 079200 END-IF. DTSEDIT 079300 DTSEDIT 080100* DATES ARE EITHER IN GREG OR JULIAN FORMAT AT THIS TIME *DTSEDIT 080200 MOVE '01' TO FLG-OUT-DATE-FRMT. DTSEDIT 080300 PERFORM V200-REFORMAT-DATE. DTSEDIT 080400 DTSEDIT 080500* DATES ARE NOW IN THE GREGORIAN DATE FORMAT *DTSEDIT 080600 MOVE HLD-DATE TO WRK-TEMP-DATE. DTSEDIT 080601 MOVE 01 TO WRK-TEMP-GREG-DD. DTSEDIT 080610 ADD 1 TO WRK-TEMP-GREG-MM. DTSEDIT 080611 DTSEDIT 080620 IF WRK-TEMP-GREG-MM > 12 DTSEDIT 080630 ADD 1 TO WRK-TEMP-GREG-CCYY DTSEDIT 080640 MOVE 1 TO WRK-TEMP-GREG-MM DTSEDIT 080650 END-IF. DTSEDIT 080660 MOVE WRK-TEMP-DATE TO HLD-DATE. DTSEDIT 080702 DTSEDIT 080719* REFORMAT FOR THE OUTPUT 1 AND PLACE IN THE RETURN AREA *DTSEDIT 080720 MOVE '01' TO FLG-IN-DATE-FRMT. DTSEDIT 080721 MOVE LNK-DT-OUTPUT-1-FRMT TO FLG-OUT-DATE-FRMT. DTSEDIT 080722 PERFORM V200-REFORMAT-DATE. DTSEDIT 080723 IF WRK-RETURN-CODE = '000' DTSEDIT 080724 MOVE HLD-DATE TO LNK-DT-OUTPUT-1-DATE DTSEDIT 080725 ELSE DTSEDIT 080726 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE DTSEDIT 080727 END-IF. DTSEDIT 080728 DTSEDIT 080729 C220-EXIT. DTSEDIT 080730 EXIT. DTSEDIT 080740******************************************************************DTSEDIT 080800 V100-VALIDATE-DATE SECTION. DTSEDIT 080900******************************************************************DTSEDIT 081000* VALIDATES THE DATE IN THE HLD-DATE FIELD IN THE FORMAT OF *DTSEDIT 081100* THE FLG-IN-DATE-FRMT. *DTSEDIT 081200******************************************************************DTSEDIT 081300 EVALUATE TRUE DTSEDIT 081400 WHEN FRMT-IN-SHORT-DATE DTSEDIT 081500 PERFORM V110-VALIDATE-SHORT-DATE DTSEDIT 081600 WHEN FRMT-IN-BRTH-DATE DTSEDIT 081700 PERFORM V120-VALIDATE-BRTH-DATE DTSEDIT 081800 WHEN FRMT-IN-ISO-DATE DTSEDIT 081900 PERFORM V130-VALIDATE-ISO-DATE DTSEDIT 081910 WHEN FRMT-IN-USA-DATE DTSEDIT 081920 PERFORM V140-VALIDATE-USA-DATE DTSEDIT 082000 WHEN FRMT-IN-GREG-DATE DTSEDIT 082100 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 082200 WHEN FRMT-IN-JULN-DATE DTSEDIT 082300 PERFORM V160-VALIDATE-JULN-DATE DTSEDIT 082400 WHEN OTHER DTSEDIT 082500 MOVE '011' TO WRK-RETURN-CODE DTSEDIT 082600 END-EVALUATE. DTSEDIT 082700 DTSEDIT 082800 V100-EXIT. DTSEDIT 082900 EXIT. DTSEDIT 083000******************************************************************DTSEDIT 083100 V110-VALIDATE-SHORT-DATE SECTION. DTSEDIT 083200******************************************************************DTSEDIT 083300* THIS SECTION VALIDATES A SHORT DATE (YYMMDD). *DTSEDIT 083400******************************************************************DTSEDIT 106400 IF HLD-SHORT-DATE = ZERO DTSEDIT 106500 MOVE '022' TO WRK-RETURN-CODE KVB20115 106600 MOVE ZERO TO LNK-DT-OUTPUT-1-DATE KVB20115 106700 GO TO V110-EXIT KVB20115 106800 ELSE KVB20115 106900 MOVE HLD-SHORT-DATE TO CC-INPUT-DATE KVB20115 107000 END-IF. KVB20115 083600 PERFORM Y5000-CALCULATE-CC. DTSEDIT 083700 IF CC-RETURN-CODE = ZEROS DTSEDIT 083800 MOVE CC-RETURN-DATE TO HLD-GREG-DATE DTSEDIT 083900 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 084000 ELSE DTSEDIT 084100 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 107700 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE KVB20115 084200 END-IF. DTSEDIT 084300 DTSEDIT 084400 V110-EXIT. DTSEDIT 084500 EXIT. DTSEDIT 084600******************************************************************DTSEDIT 084700 V120-VALIDATE-BRTH-DATE SECTION. DTSEDIT 084800******************************************************************DTSEDIT 084900* THIS SECTION VALIDATES A SHORT BIRTH DATE (YYMMDD). *DTSEDIT 085000******************************************************************DTSEDIT 108700 IF HLD-SHORT-DATE = ZERO DTSEDIT 108800 MOVE '022' TO WRK-RETURN-CODE KVB20115 108900 MOVE ZERO TO LNK-DT-OUTPUT-1-DATE KVB20115 109000 GO TO V120-EXIT KVB20115 109100 ELSE KVB20115 109200 MOVE HLD-SHORT-DATE TO CC-INPUT-DATE KVB20115 109300 END-IF. KVB20115 085200 PERFORM Y5050-CALCULATE-CC-BIRTH-DATE. DTSEDIT 085300 IF CC-RETURN-CODE = ZEROS DTSEDIT 085400 MOVE CC-RETURN-DATE TO HLD-GREG-DATE DTSEDIT 085500 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 085600 ELSE DTSEDIT 085700 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 110000 MOVE SPACES TO LNK-DT-OUTPUT-1-DATE KVB20115 085800 END-IF. DTSEDIT 085900 DTSEDIT 086000 V120-EXIT. DTSEDIT 086100 EXIT. DTSEDIT 086200******************************************************************DTSEDIT 086300 V130-VALIDATE-ISO-DATE SECTION. DTSEDIT 086400******************************************************************DTSEDIT 086500* THIS SECTION VALIDATES A ISO DATE (CCYY-MM-DD). *DTSEDIT 086600******************************************************************DTSEDIT 086700 IF HLD-ISO-DATE-DASH-1 NOT = '-' DTSEDIT 086800 OR HLD-ISO-DATE-DASH-2 NOT = '-' DTSEDIT 086900 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 087000 ELSE DTSEDIT 087100 MOVE SPACES TO WRK-TEMP-DATE DTSEDIT 087200 MOVE HLD-ISO-DATE-CCYY TO WRK-TEMP-GREG-CCYY DTSEDIT 087300 MOVE HLD-ISO-DATE-MM TO WRK-TEMP-GREG-MM DTSEDIT 087400 MOVE HLD-ISO-DATE-DD TO WRK-TEMP-GREG-DD DTSEDIT 087500 MOVE WRK-TEMP-DATE TO HLD-DATE DTSEDIT 087600 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 087700 END-IF. DTSEDIT 087800 DTSEDIT 087900 V130-EXIT. DTSEDIT 088000 EXIT. DTSEDIT 088010******************************************************************DTSEDIT 088020 V140-VALIDATE-USA-DATE SECTION. DTSEDIT 088030******************************************************************DTSEDIT 088040* THIS SECTION VALIDATES A USA DATE (MM/DD/CCYY). *DTSEDIT 088050******************************************************************DTSEDIT 088060 IF HLD-USA-DATE-SLASH-1 NOT = '/' DTSEDIT 088070 OR HLD-USA-DATE-SLASH-2 NOT = '/' DTSEDIT 088080 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 088090 ELSE DTSEDIT 088091 MOVE SPACES TO WRK-TEMP-DATE DTSEDIT 088092 MOVE HLD-USA-DATE-MM TO WRK-TEMP-GREG-MM DTSEDIT 088093 MOVE HLD-USA-DATE-DD TO WRK-TEMP-GREG-DD DTSEDIT 088094 MOVE HLD-USA-DATE-CCYY TO WRK-TEMP-GREG-CCYY DTSEDIT 088095 MOVE WRK-TEMP-DATE TO HLD-DATE DTSEDIT 088096 PERFORM V150-VALIDATE-GREG-DATE DTSEDIT 088097 END-IF. DTSEDIT 088098 DTSEDIT 088099 V130-EXIT. DTSEDIT 088100 EXIT. DTSEDIT 088110******************************************************************DTSEDIT 088200 V150-VALIDATE-GREG-DATE SECTION. DTSEDIT 088300******************************************************************DTSEDIT 088400* THIS SECTION VALIDATES A GREGORIAN DATE (CCYYMMDD). *DTSEDIT 088500******************************************************************DTSEDIT 088600 IF HLD-GREG-DATE NOT NUMERIC DTSEDIT 088700 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 088800 GO TO V150-EXIT DTSEDIT 088900 END-IF. DTSEDIT 089000 DTSEDIT 089100 IF HLD-GREG-DATE-MM >= 1 DTSEDIT 089200 AND HLD-GREG-DATE-MM <= 12 DTSEDIT 089300 MOVE HLD-GREG-DATE-CCYY TO WRK-LEAP-YEAR-CCYY DTSEDIT 089400 PERFORM V600-PROCESS-LEAP-YEAR DTSEDIT 089500 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 089600 IF HLD-GREG-DATE-DD >= TBL-FIRST-DAY-OF-MONTH (SUB-MM) DTSEDIT 089700 AND HLD-GREG-DATE-DD <= TBL-LAST-DAY-OF-MONTH (SUB-MM) DTSEDIT 089800 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 089900 ELSE DTSEDIT 090000 MOVE '022' TO WRK-RETURN-CODE DTSEDIT 116300 MOVE HLD-GREG-DATE TO LNK-DT-OUTPUT-1-DATE KVB20115 090100 END-IF DTSEDIT 090200 ELSE DTSEDIT 090300 MOVE '022' TO WRK-RETURN-CODE DTSEDIT 116700 MOVE HLD-GREG-DATE TO LNK-DT-OUTPUT-1-DATE KVB20115 090400 END-IF. DTSEDIT 090500 DTSEDIT 090600 V150-EXIT. DTSEDIT 090700 EXIT. DTSEDIT 090800******************************************************************DTSEDIT 090900 V160-VALIDATE-JULN-DATE SECTION. DTSEDIT 091000******************************************************************DTSEDIT 091100* THIS SECTION VALIDATES A JULIAN DATE (CCYYDDD). *DTSEDIT 091200******************************************************************DTSEDIT 091300 IF HLD-JULN-DATE NUMERIC DTSEDIT 091400 MOVE HLD-JULN-DATE-CCYY TO WRK-LEAP-YEAR-CCYY DTSEDIT 091500 PERFORM V600-PROCESS-LEAP-YEAR DTSEDIT 091600 COMPUTE WRK-JULN-YEAR-LNGTH = TBL-JULN-DAY (12) DTSEDIT 091700 + TBL-LAST-DAY-OF-MONTH (12) DTSEDIT 091800 IF HLD-JULN-DATE-DDD >= 1 DTSEDIT 091900 AND HLD-JULN-DATE-DDD <= WRK-JULN-YEAR-LNGTH DTSEDIT 092000 MOVE '000' TO WRK-RETURN-CODE DTSEDIT 092100 ELSE DTSEDIT 092200 MOVE '022' TO WRK-RETURN-CODE DTSEDIT 092300 END-IF DTSEDIT 092400 ELSE DTSEDIT 092500 MOVE '021' TO WRK-RETURN-CODE DTSEDIT 092600 END-IF. DTSEDIT 092700 DTSEDIT 092800 V160-EXIT. DTSEDIT 092900 EXIT. DTSEDIT 093000******************************************************************DTSEDIT 093100 V200-REFORMAT-DATE SECTION. DTSEDIT 093200******************************************************************DTSEDIT 093300* THIS SECTION REFORMATES A DATE FOR OUTPUT *DTSEDIT 093400******************************************************************DTSEDIT 093500 IF FRMT-IN-JULN-DATE DTSEDIT 093600 EVALUATE TRUE DTSEDIT 093700 WHEN FRMT-OUT-JULN-DATE DTSEDIT 093800 CONTINUE DTSEDIT 093900 WHEN FRMT-OUT-GREG-DATE DTSEDIT 094000 WHEN FRMT-OUT-ISO-DATE DTSEDIT 094100 PERFORM V210-REFORMAT-JULN-DATE DTSEDIT 094200 WHEN OTHER DTSEDIT 094300 MOVE '012' TO WRK-RETURN-CODE DTSEDIT 094400 END-EVALUATE DTSEDIT 094500 ELSE DTSEDIT 094600 EVALUATE TRUE DTSEDIT 094700 WHEN FRMT-OUT-JULN-DATE DTSEDIT 094800 PERFORM V220-REFORMAT-GREG-DATE DTSEDIT 094900 WHEN FRMT-OUT-GREG-DATE DTSEDIT 095000 CONTINUE DTSEDIT 095100 WHEN FRMT-OUT-ISO-DATE DTSEDIT 095200 MOVE HLD-DATE TO WRK-TEMP-DATE DTSEDIT 095400 MOVE WRK-TEMP-GREG-CCYY TO HLD-ISO-DATE-CCYY DTSEDIT 095500 MOVE '-' TO HLD-ISO-DATE-DASH-1 DTSEDIT 095600 MOVE WRK-TEMP-GREG-MM TO HLD-ISO-DATE-MM DTSEDIT 095700 MOVE '-' TO HLD-ISO-DATE-DASH-2 DTSEDIT 095800 MOVE WRK-TEMP-GREG-DD TO HLD-ISO-DATE-DD DTSEDIT 095900 WHEN OTHER DTSEDIT 096000 MOVE '012' TO WRK-RETURN-CODE DTSEDIT 096100 END-EVALUATE DTSEDIT 096200 END-IF. DTSEDIT 096300 DTSEDIT 096400 V200-EXIT. DTSEDIT 096500 EXIT. DTSEDIT 096600******************************************************************DTSEDIT 096700 V210-REFORMAT-JULN-DATE SECTION. DTSEDIT 096800******************************************************************DTSEDIT 096900* THIS SECTION REFORMATES A JULIAN DATE TO A GREGORIAN DATE *DTSEDIT 097000* OR A ISO STYLE GREGORIAN DATE *DTSEDIT 097100******************************************************************DTSEDIT 097200 MOVE SPACES TO WRK-TEMP-DATE. DTSEDIT 097300 MOVE HLD-JULN-DATE-CCYY TO WRK-TEMP-GREG-CCYY DTSEDIT 097400 WRK-LEAP-YEAR-CCYY. DTSEDIT 097500 PERFORM V600-PROCESS-LEAP-YEAR. DTSEDIT 097600 MOVE 1 TO SUB-MM. DTSEDIT 097700 PERFORM DTSEDIT 097800 UNTIL HLD-JULN-DATE-DDD <= (TBL-JULN-DAY (SUB-MM) DTSEDIT 097900 + TBL-LAST-DAY-OF-MONTH (SUB-MM)) DTSEDIT 098000 ADD 1 TO SUB-MM DTSEDIT 098100 END-PERFORM. DTSEDIT 098200 DTSEDIT 098300 MOVE SUB-MM TO WRK-TEMP-GREG-MM. DTSEDIT 098400 COMPUTE WRK-TEMP-GREG-DD = HLD-JULN-DATE-DDD DTSEDIT 098500 - TBL-JULN-DAY (SUB-MM). DTSEDIT 098600 DTSEDIT 098800 EVALUATE TRUE DTSEDIT 098900 WHEN FRMT-OUT-GREG-DATE DTSEDIT 099000 MOVE WRK-TEMP-DATE TO HLD-DATE DTSEDIT 099100 WHEN FRMT-OUT-ISO-DATE DTSEDIT 099200 MOVE WRK-TEMP-GREG-CCYY TO HLD-ISO-DATE-CCYY DTSEDIT 099300 MOVE '-' TO HLD-ISO-DATE-DASH-1 DTSEDIT 099400 MOVE WRK-TEMP-GREG-MM TO HLD-ISO-DATE-MM DTSEDIT 099500 MOVE '-' TO HLD-ISO-DATE-DASH-2 DTSEDIT 099600 MOVE WRK-TEMP-GREG-DD TO HLD-ISO-DATE-DD DTSEDIT 099700 END-EVALUATE. DTSEDIT 099800 V210-EXIT. DTSEDIT 099900 EXIT. DTSEDIT 100000******************************************************************DTSEDIT 100100 V220-REFORMAT-GREG-DATE SECTION. DTSEDIT 100200******************************************************************DTSEDIT 100300* THIS SECTION REFORMATES A GREGORIAN DATE TO A JULIAN DATE *DTSEDIT 100400******************************************************************DTSEDIT 100500 MOVE HLD-DATE TO WRK-TEMP-DATE. DTSEDIT 100600 MOVE SPACES TO HLD-DATE. DTSEDIT 100700 MOVE WRK-TEMP-GREG-CCYY TO HLD-JULN-DATE-CCYY DTSEDIT 100800 WRK-LEAP-YEAR-CCYY. DTSEDIT 100900 PERFORM V600-PROCESS-LEAP-YEAR. DTSEDIT 101000 MOVE WRK-TEMP-GREG-MM TO SUB-MM. DTSEDIT 101100 COMPUTE HLD-JULN-DATE-DDD = WRK-TEMP-GREG-DD DTSEDIT 101200 + TBL-JULN-DAY (SUB-MM). DTSEDIT 101300 DTSEDIT 101400 V220-EXIT. DTSEDIT 101500 EXIT. DTSEDIT 101610******************************************************************DTSEDIT 101700 V300-EQUATION-FORMAT SECTION. DTSEDIT 101800******************************************************************DTSEDIT 101900* THIS SECTIONS CONVERTS THE GREGORIAN OR JULIAN DATE INTO THE *DTSEDIT 102000* NUMBER OF DAYS SINCE THE BEGINNING OF A.D. (00/00/0000) *DTSEDIT 102100******************************************************************DTSEDIT 102200 EVALUATE TRUE DTSEDIT 102300 WHEN FRMT-IN-JULN-DATE DTSEDIT 102400 MOVE HLD-JULN-DATE-CCYY TO WRK-TEMP-CCYY DTSEDIT 102500 COMPUTE WRK-NUMBER-DAYS = (WRK-TEMP-CCYY DTSEDIT 102600 * 365.25) DTSEDIT 102700 + HLD-JULN-DATE-DDD DTSEDIT 103000 IF LEAP-YEAR DTSEDIT 103100 SUBTRACT 1 FROM WRK-NUMBER-DAYS DTSEDIT 103200 END-IF DTSEDIT 103300 WHEN OTHER DTSEDIT 103400 MOVE HLD-GREG-DATE-CCYY TO WRK-TEMP-CCYY DTSEDIT 103700 MOVE HLD-GREG-DATE-MM TO SUB-MM DTSEDIT 103800 COMPUTE WRK-NUMBER-DAYS = (WRK-TEMP-CCYY DTSEDIT 103900 * 365.25) DTSEDIT 104000 + TBL-JULN-DAY (SUB-MM) DTSEDIT 104100 + HLD-GREG-DATE-DD DTSEDIT 104200 IF LEAP-YEAR DTSEDIT 104300 SUBTRACT 1 FROM WRK-NUMBER-DAYS DTSEDIT 104400 END-IF DTSEDIT 104500 END-EVALUATE. DTSEDIT 104600 DTSEDIT 104700 V300-EXIT. DTSEDIT 104800 EXIT. DTSEDIT 104900******************************************************************DTSEDIT 105000 V400-EQUATION-DECODE SECTION. DTSEDIT 105100******************************************************************DTSEDIT 105200* THIS SECTIONS CONVERTS THE NUMBER OF DAYS SINCE THE BEGINNING *DTSEDIT 105300* OF A.D. (00/00/0000) TO THE JULIAN DATE FORMAT *DTSEDIT 105400******************************************************************DTSEDIT 105500 COMPUTE WRK-SAVE-YEAR = WRK-NUMBER-DAYS / 365.25. DTSEDIT 105600 COMPUTE WRK-NUMBER = WRK-SAVE-YEAR * 365.25. DTSEDIT 105700 COMPUTE WRK-DAYS = WRK-NUMBER-DAYS - WRK-NUMBER. DTSEDIT 105800 DTSEDIT 105900 MOVE SPACES TO HLD-DATE. DTSEDIT 106000 MOVE WRK-SAVE-YEAR TO HLD-JULN-DATE-CCYY DTSEDIT 106200 WRK-LEAP-YEAR-CCYY. DTSEDIT 106210 PERFORM V600-PROCESS-LEAP-YEAR DTSEDIT 106300 IF LEAP-YEAR DTSEDIT 106400 ADD 1 TO WRK-DAYS DTSEDIT 106500 END-IF. DTSEDIT 106600 MOVE WRK-DAYS TO HLD-JULN-DATE-DDD. DTSEDIT 106700 DTSEDIT 106800 V400-EXIT. DTSEDIT 106900 EXIT. DTSEDIT 107000******************************************************************DTSEDIT 107100 V600-PROCESS-LEAP-YEAR SECTION. DTSEDIT 107200******************************************************************DTSEDIT 107300* THIS SECTION DETERMINES WHETHER OR NOT THE DATE LIES WITH IN *DTSEDIT 107400* A LEAP YEAR. IT ALSO SETS UP THE TABLES THAT SHOW THE *DTSEDIT 107500* THE BEGINNING AND ENDING DATES OF EACH MONTH. *DTSEDIT 107600******************************************************************DTSEDIT 107700 MOVE ZEROS TO WRK-RMDR DTSEDIT 107800 WRK-NUMBER. DTSEDIT 107900 MOVE 'N' TO FLG-LEAP-YEAR. DTSEDIT 108000 DTSEDIT 108100 DIVIDE WRK-LEAP-YEAR-CCYY BY 4 DTSEDIT 108200 GIVING WRK-NUMBER REMAINDER WRK-RMDR. DTSEDIT 108300 DTSEDIT 108400 IF WRK-RMDR = ZEROS DTSEDIT 108500 MOVE 'Y' TO FLG-LEAP-YEAR DTSEDIT 108600 END-IF. DTSEDIT 108700 DTSEDIT 108800 IF LEAP-YEAR DTSEDIT 108900 MOVE LIT-LEAP-YEAR-DATA TO TBL-VALID-DATES DTSEDIT 109000 ELSE DTSEDIT 109100 MOVE LIT-NON-LEAP-YEAR-DATA TO TBL-VALID-DATES DTSEDIT 109200 END-IF. DTSEDIT 109300 DTSEDIT 109400 V600-EXIT. DTSEDIT 109500 EXIT. DTSEDIT 109600******************************************************************DTSEDIT 109700* Y5000-CALCULATE-CC SECTION. *DTSEDIT 109800* THIS SECTION CALCULATES THE CENTURY FOR A SHORT DATE *DTSEDIT 109900******************************************************************DTSEDIT 110000 COPY DTICC. DTSEDIT 110100******************************************************************DTSEDIT 110200* Y5050-CALCULATE-BIRTH-DATE-CC SECTION. *DTSEDIT 110300* THIS SECTION CALCULATES THE CENTURY FOR A BIRTH DATE *DTSEDIT 110400******************************************************************DTSEDIT 110500 COPY DTICCBD. DTSEDIT 110600******************************************************************DTSEDIT 110700 Z100-FINALIZATION SECTION. DTSEDIT 110800******************************************************************DTSEDIT 110900* THIS SECTION IS THE WRAP UP OF THE MODULE. IT HANDLES ALL *DTSEDIT 111000* RETURNABLE DATA AND POPULATES THE ERROR FIELDS IF NEEDED. *DTSEDIT 111100******************************************************************DTSEDIT 111200 EVALUATE WRK-RETURN-CODE DTSEDIT 111300 WHEN '000' DTSEDIT 111400 MOVE 'REQUEST COMPLETED - NO ERRORS' DTSEDIT 111500 TO LNK-DT-RETURN-MESSAGE DTSEDIT 111600 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 111700 WHEN '011' DTSEDIT 111800 STRING 'INVALID INPUT FORMAT CODE - ' DTSEDIT 111900 DELIMITED BY SIZE DTSEDIT 112000 FLG-IN-DATE-FRMT DELIMITED BY SIZE DTSEDIT 112100 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 112200 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 112300 WHEN '012' DTSEDIT 112400 STRING 'INVALID OUTPUT FORMAT CODE - ' DTSEDIT 112500 DELIMITED BY SIZE DTSEDIT 112600 FLG-OUT-DATE-FRMT DELIMITED BY SIZE DTSEDIT 112700 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 112800 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 112900 WHEN '021' DTSEDIT 113000 STRING 'INPUT DATE IS NOT NUMERIC - ' DTSEDIT 113100 DELIMITED BY SIZE DTSEDIT 113200 HLD-DATE DELIMITED BY SIZE DTSEDIT 113300 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 113400 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 113500 WHEN '022' DTSEDIT 113600 STRING 'INPUT DATE IS INVALID - ' DTSEDIT 113700 DELIMITED BY SIZE DTSEDIT 113800 HLD-DATE DELIMITED BY SIZE DTSEDIT 113900 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 114000 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 114100 WHEN '030' DTSEDIT 114200 STRING 'INVALID FUNCTION REQUESTED - ' DTSEDIT 114300 DELIMITED BY SIZE DTSEDIT 114400 FLG-FUNC-REQ-CODE DELIMITED BY SIZE DTSEDIT 114500 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 114600 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 114700 WHEN '040' DTSEDIT 114800 STRING 'INVALID CALCULATION REQUESTED - ' DTSEDIT 114900 DELIMITED BY SIZE DTSEDIT 115000 FLG-CALC-REQ-CODE DELIMITED BY SIZE DTSEDIT 115100 INTO LNK-DT-RETURN-MESSAGE DTSEDIT 115200 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 115300 WHEN '051' DTSEDIT 115400 STRING 'NON-NUMERIC IN A NUMBER FIELD - ' DTSEDIT 115500 DELIMITED BY SIZE INTO LNK-DT-RETURN-MESSAGE DTSEDIT 115800 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 115900 WHEN '052' DTSEDIT 116000 STRING 'INVALID NUMERIC IN A NUMBER FIELD - ' DTSEDIT 116100 DELIMITED BY SIZE INTO LNK-DT-RETURN-MESSAGE DTSEDIT 116400 MOVE WRK-RETURN-CODE TO LNK-DT-RETURN-CODE DTSEDIT 116500 END-EVALUATE. DTSEDIT 116600 DTSEDIT 116700 Z100-EXIT. DTSEDIT 116800 EXIT. DTSEDIT ./ ADD NAME=DTSEDITI 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. SLSTTTT. 000300******************************************************************OWNERID 000400** DO NOT COPY!! **OWNERID 000500** THIS DOCUMENT CONTAINS TRADE SECRET INFORMATION, THE **OWNERID 000600** EXPRESSION OF WHICH IS AN UNPUBLISHED WORK FULLY PROTECTED **OWNERID 000700** BY THE UNITED STATES COPYRIGHT LAWS AND IS CONSIDERED A **OWNERID 000800** TRADE SECRET OWNED BY UNIPAC SERVICE CORPORATION, **OWNERID 000900** 3015 SOUTH PARKER ROAD, SUITE 400, AURORA, COLORADO 80014. **OWNERID 001000** ALL RIGHTS, TITLE, INTEREST AND OWNERSHIP ARE RESERVED BY **OWNERID 001100** UNIPAC SERVICE CORPORATION. THIS DOCUMENT CANNOT BE **OWNERID 001200** ACQUIRED, COPIED, MODIFIED OR USED IN ANY MANNER WHATSOEVER **OWNERID 001300** WITHOUT THE EXPRESS WRITTEN CONSENT OF UNIPAC SERVICE **OWNERID 001400** CORPORATION. **OWNERID 001500******************************************************************OWNERID 001600 AUTHOR. UNIPAC SERVICE CORPORATION. 001700 DATE-WRITTEN. XX/XX/97. 001800 DATE-COMPILED. 001900****************************************************************** 002000** PROGRAM DOCUMENTATION ** 002100** ** 002200** PROGRAM FUNCTION ** 002300** THIS MODULE IS AN ON-LINE SCREEN WHICH DIRECTLY ACCESSES ** 002400** THE COMMON DATE EDIT ROUTINE (DTSEDIT). THIS SCREEN CAN ** 002410** BE USED FOR THE TESTING OF THE ROUTINE AS WELL AS ** 002420** CONFIRMATION ON HOW THE ROUTINE WORKS. ** 002500** ** 002600** PROGRAM FLOW ** 002700** STOP RUN. ** 002800** ** 002900** LINKED PROGRAMS ** 003000** SLSMSG2 - COMMON MESSAGE ROUTINE ** 003001** SLSTIP2 - TRANSACTION INITIALIZATION ROUTINE ** 003020** ** 003030** CALLED PROGRAMS ** 003040** DTSEDIT - COMMON DATE EDIT ROUTINE ** 003100** ** 003200** SOURCE COPYBOOKS ** 003500** AN7RTN2 - AUDIT ROUTINE 7 ** 003510** ** 003900** NOTES ** 004001** DOCUMENTATION OF THE DTSEDIT DATE ROUTINE CAN BE FOUND ** 004002** IN THE STANDARDS LIBRARY. ** 004003** ** 004004****************************************************************** 004005** REVISIONS: ** 004006** INITAL CODING * A20115 * S. MCRAE * ** 004007** VERSION 1.00 * EST PRD XX/XX/97 * ** 004008** INITAL CODING FOR THIS TESING SCREEN OF THE COMMON DATE ** 004009** DATE EDIT ROUTINE ** 020800****************************************************************** 020900 ENVIRONMENT DIVISION. 021000 DATA DIVISION. 021001****************************************************************** 021002** W O R K I N G S T O R A G E * 021003****************************************************************** 021004 WORKING-STORAGE SECTION. 021005 01 A-STANDARD-PROGRAM-ID PIC X(26) VALUE 021006 'UNIPAC/DTOTEST/XXXX97-1.00'. 021007****************************************************************** 021008** C A L L E D P R O G R A M S * 021009****************************************************************** 021010 01 CALLED-PROGRAMS. 021011 05 C-DTSEDIT PIC X(08) VALUE 'DTSEDIT '. 021012****************************************************************** 021013** S U B S C R I P T S PREFIX SUB * 021015****************************************************************** 021016 01 SUBSCRIPTS USAGE IS COMP. 021017 05 SUB-ERR PIC S9(03) VALUE +0. 021018 05 SUB-I PIC S9(03) VALUE +0. 021019 05 SUB-I1 PIC S9(03) VALUE +0. 021020 05 SUB-MSG PIC S9(03) VALUE +0. 021021 05 SUB-CNT PIC 9(03) VALUE 0. 021022 05 SUB-RTRN PIC 9(03) VALUE 0. 021023****************************************************************** 021024** H O L D A R E A S PREFIX HLD * 021025****************************************************************** 021026 01 HOLD-AREAS. 021027 05 HLD-MESSAGE-DISPLAY. 021028 10 HLD-MSG-NUMBER PIC X(07) VALUE SPACES. 021029 10 FILLER PIC X(01) VALUE SPACES. 021030 10 HLD-MSG-TEXT PIC X(31) VALUE SPACES. 021031 05 HLD-TEMP-NUMBER-2 PIC 9(02) VALUE ZEROS. 021032 05 HLD-TEMP-NUMBER-3 PIC 9(03) VALUE ZEROS. 021033 05 HLD-TEMP-NUMBER-5 PIC S9(05) VALUE ZEROS. 021034 05 HLD-NUMERIC PIC S9(05) VALUE ZEROS. 021035 05 HLD-NUMERIC-UNSIGNED PIC 9(05) VALUE ZEROS. 021036 05 HLD-ALPHA-GROUP. 021037 10 HLD-ALPHA PIC X(01) OCCURS 5 TIMES. 021038 05 HLD-RTRN-GROUP. 021039 10 HLD-RTRN PIC X(01) OCCURS 6 TIMES. 021040****************************************************************** 021041** P R O G R A M F L A G S PREFIX FLG * 021042****************************************************************** 021043 01 PROGRAM-FLAGS. SL 021044 05 FLG-END-OF-PROCESS PIC X(01) VALUE 'N'. SL 021045****************************************************************** 021046** T A B L E S PREFIX TBL * 021047****************************************************************** 021048 01 TABLE-ERROR. 021049 05 TBL-ERR PIC X(03) OCCURS 9 TIMES. 021050 01 TABLE-MESSAGE. 021051 05 TBL-MSG PIC X(39) OCCURS 9 TIMES. 021052****************************************************************** 021053** P R O G R A M P O I N T E R S * 021054****************************************************************** 021055 01 PROGRAM-POINTERS. 021056 05 LNK-POINTER USAGE IS POINTER. 021158****************************************************************** 021159** C O P Y B O O K S - FILES * 021160****************************************************************** 021161 01 MESSAGE-AREA. 021162 COPY MSGLNK. 021163 COPY AN7WS. 021170 COPY DTLEDIT. 021171 COPY SLSSTIB. 021172 COPY SLSSSFT. 021173****************************************************************** 021174** C O P Y B O O K S - MAPS * 021175****************************************************************** 021176 COPY DTMTEST. 021177 01 FILLER PIC X(19) VALUE 021178 'END OF SYMBOLIC MAP'. 021179****************************************************************** 021180** L I N K A G E * 021181****************************************************************** 021182 LINKAGE SECTION. 021183 COPY SLSSTUA. 021187 EJECT 021188****************************************************************** 021189* PROCEDURE DIVISION. * 021190****************************************************************** 048000 PROCEDURE DIVISION. 048030****************************************************************** 048200 A000-MAIN-CONTROL SECTION. 048210****************************************************************** 048220* THIS SECTION CONTROLS THE MAIN PROCESSING OF THE MODULE * 048230****************************************************************** 048900 EXEC CICS IGNORE CONDITION 049000 MAPFAIL 049100 END-EXEC. 049200 PERFORM A100-INITIALIZE. 049210 049300 IF FLG-END-OF-PROCESS NOT = 'Y' 049400 EVALUATE TIB-STATUS 049410 WHEN 'A' 049420 WHEN 'B' 049700 PERFORM B100-PROCESS-NEW-SCREEN 049701 WHEN 'C' 049900 PERFORM B200-PROCESS-MAP 049910 END-EVALUATE 049920 END-IF. 049930 050100 PERFORM Z100-RETURN-TO-CICS. 050110 050200 A000-EXIT. 050300 EXIT. 050400****************************************************************** 050500 A100-INITIALIZE SECTION. 050510****************************************************************** 050520* THIS SETS UP THE CICS AREA TO BEGIN PROCESSING THE MAP * 050530****************************************************************** 050531 INITIALIZE TABLE-ERROR. 050540 INITIALIZE TABLE-MESSAGE. 051400 MOVE SPACES TO DTLNK-LINKAGE-SECT. 051500 051800 PERFORM R100-RECEIVE-MAP. 051810 MOVE 'XXXX,X' TO TIB-INQUIRY-MASK. 051820 MOVE 'SLSTTTT' TO TIB-PROGRAM-ID. 052000 PERFORM L200-LINK-TO-SLSTIP-ROUTINE. 052002 IF TIB-ERROR-NUMBER = 0 052003 NEXT SENTENCE 052004 ELSE 052005 ADD 1 TO SUB-ERR 052006 MOVE TIB-ERROR-NUMBER TO TBL-ERR (SUB-ERR) 052007 PERFORM E100-ERROR-MESSAGE-ROUTINE 052008 PERFORM S100-SEND-MAP-ERASE 052010 MOVE 'Y' TO FLG-END-OF-PROCESS 052020 END-IF. 054220 054300 EXEC CICS ADDRESS 054400 TCTUA (ADDRESS OF TERMINAL-USER-AREA) 054500 END-EXEC. 054600 055500 A100-EXIT. 055600 EXIT. 057100****************************************************************** 057200 B100-PROCESS-NEW-SCREEN SECTION. 057300****************************************************************** 057400* THIS PREPARES THE SCREEN TO RECIEVE INPUT FROM THE USER * 057500****************************************************************** 057600 MOVE LOW-VALUES TO MTST1O. 057700 MOVE EIBTRNID TO INQ01O. 057800 PERFORM M300-MOVE-UNDERSCORES. 061900 062000 EVALUATE TIB-STATUS 062010 WHEN 'A' 062020 PERFORM S100-SEND-MAP-ERASE 062030 WHEN 'B' 062400 PERFORM S200-SEND-MAP-DATAONLY 062410 END-EVALUATE. 062420 062500 B100-EXIT. 062600 EXIT. 062700****************************************************************** 062800 B200-PROCESS-MAP SECTION. 062810****************************************************************** 062820* THIS RECIEVES INPUT FORM THE MAP THAT THE USER ENTERED * 062830****************************************************************** 062900 PERFORM M100-MOVE-MAP-TO-DTLNK. 062901 MOVE LOW-VALUES TO MTST1O. 062902 MOVE EIBTRNID TO INQ01O. 062903 IF DTLNK-FUNC-REQ = '000' 062904 MOVE '030' TO DTLNK-FUNC-REQ 062905 MOVE '011' TO DTLNK-CALC-REQ 062906 MOVE 13 TO DTLNK-INPUT-MONTH 062907 END-IF. 062920 CALL C-DTSEDIT USING DTLNK-AREA. 063100 PERFORM M200-MOVE-DTLNK-TO-MAP. 066000 PERFORM S200-SEND-MAP-DATAONLY. 066100 B200-EXIT. 066200 EXIT. 066201****************************************************************** 066202 E100-ERROR-MESSAGE-ROUTINE SECTION. 066203****************************************************************** 066204* THIS DISPLAYS ERROR MESSAGES FROM THE SLSSTIP2 COMMON ROUTINE * 066205****************************************************************** 066206 MOVE ZERO TO SUB-MSG. 066207 IF SUB-ERR > 8 066208 MOVE 431 TO TBL-ERR (08). 066209 066210 PERFORM E200-MOVE-ERRORS-TO-TABLE 066211 VARYING SUB-ERR FROM 1 BY 1 066212 UNTIL (SUB-ERR > 8) 066213 OR (TBL-ERR (SUB-ERR) = SPACES). 066214 066228 MOVE TBL-MSG (01) TO ERR101O. 066229 MOVE TBL-MSG (02) TO ERR201O. 066230 MOVE TBL-MSG (03) TO ERR301O. 066231 MOVE TBL-MSG (04) TO ERR401O. 066232 MOVE TBL-MSG (05) TO ERR501O. 066233 MOVE TBL-MSG (06) TO ERR601O. 066234 MOVE TBL-MSG (07) TO ERR701O. 066235 MOVE TBL-MSG (08) TO ERR801O. 066236 E100-EXIT. 066237 EXIT. 066238****************************************************************** 066239 E200-MOVE-ERRORS-TO-TABLE SECTION. 066240****************************************************************** 066241* THIS MOVE THE ERRORS ON THE ERROR TABLE TO THE MESSAGE TABLE * 066242****************************************************************** 066243 MOVE 'ERR ' TO MESSAGE-KEY-PGM. 066244 MOVE TBL-ERR (SUB-ERR) TO MESSAGE-KEY-NO. 066245 PERFORM L100-LINK-TO-MESSAGE-ROUTINE. 066246 ADD 1 TO SUB-MSG. 066247 MOVE HLD-MESSAGE-DISPLAY TO TBL-MSG (SUB-MSG). 066248 E200-EXIT. 066249 EXIT. 066256****************************************************************** 066257 L100-LINK-TO-MESSAGE-ROUTINE SECTION. 066258****************************************************************** 066259* THIS SECTIONS LINKS TO THE MESSAGE ROUTINE PROGRAM, SLSMSG2 * 066260****************************************************************** 066261 EXEC CICS LINK 066262 PROGRAM ('SLSMSG2') 066263 COMMAREA (MESSAGE-AREA) 066264 LENGTH (LENGTH OF MESSAGE-AREA) 066265 END-EXEC. 066266 MOVE MESSAGE-KEY TO HLD-MSG-NUMBER. 066267 MOVE MESSAGE-TEXT TO HLD-MSG-TEXT. 066270 L100-EXIT. 066300 EXIT. 177100****************************************************************** 177200 L200-LINK-TO-SLSTIP-ROUTINE SECTION. 177210****************************************************************** 177220* THIS SECTION LINKS TO THE COMMON ROUTINE SLSTIP2 * 177230****************************************************************** 177300 EXEC CICS LINK 177400 PROGRAM ('SLSTIP2') 177500 COMMAREA (TRANS-INITIALIZATION-BLOCK) 177600 LENGTH (LENGTH OF TRANS-INITIALIZATION-BLOCK) 177700 END-EXEC. 177800 L200-EXIT. 177900 EXIT. 178900****************************************************************** 185500 M100-MOVE-MAP-TO-DTLNK SECTION. 185510****************************************************************** 185520* THIS SECTION MOVES THE INPUT FROM THE SCREEN TO THE LINKAGE * 185521* SECTION OF THE DTSEDIT PROGRAM. FIRST ALL NUMERIC FIELDS ARE * 185522* RIGHT JUSTIFIED PRIOR TO MOVING THEM THE DATE LINK AREA. * 185530****************************************************************** 185600 MOVE RQFUNCI TO AN7-CURRENT-WORD. 185601 PERFORM Y100-AUDIT-NUMBER7. 185602 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-3. 185603 MOVE HLD-TEMP-NUMBER-3 TO DTLNK-FUNC-REQ. 185604 185610 MOVE RQCALCI TO AN7-CURRENT-WORD. 185620 PERFORM Y100-AUDIT-NUMBER7. 185621 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-3. 185622 MOVE HLD-TEMP-NUMBER-3 TO DTLNK-CALC-REQ. 185630 185700 MOVE IN1FRMTI TO AN7-CURRENT-WORD. 185701 PERFORM Y100-AUDIT-NUMBER7. 185702 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-2. 185703 MOVE HLD-TEMP-NUMBER-2 TO DTLNK-INPUT-1-FRMT. 185704 185710 MOVE IN1DATEI TO DTLNK-INPUT-1-DATE. 185720 MOVE IN2FRMTI TO AN7-CURRENT-WORD. 185721 PERFORM Y100-AUDIT-NUMBER7. 185722 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-2. 185723 MOVE HLD-TEMP-NUMBER-2 TO DTLNK-INPUT-2-FRMT. 185724 185730 MOVE IN2DATEI TO DTLNK-INPUT-2-DATE. 185740 MOVE INMNTHI TO AN7-CURRENT-WORD. 185741 PERFORM Y100-AUDIT-NUMBER7. 185742 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-2. 185743 MOVE HLD-TEMP-NUMBER-2 TO DTLNK-INPUT-MONTH. 185744 185750 MOVE DAYCNTI TO AN7-CURRENT-WORD. 185751 PERFORM Y100-AUDIT-NUMBER7. 185752 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-5. 185753 MOVE HLD-TEMP-NUMBER-5 TO DTLNK-DAY-CNT. 185754 185760 MOVE MTHCNTI TO AN7-CURRENT-WORD. 185761 PERFORM Y100-AUDIT-NUMBER7. 185762 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-5. 185763 MOVE HLD-TEMP-NUMBER-5 TO DTLNK-MONTH-CNT. 185764 185770 MOVE YRCNTI TO AN7-CURRENT-WORD. 185771 PERFORM Y100-AUDIT-NUMBER7. 185772 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-5. 185773 MOVE HLD-TEMP-NUMBER-5 TO DTLNK-YEAR-CNT. 185774 185775 MOVE OU1FRMTI TO AN7-CURRENT-WORD. 185776 PERFORM Y100-AUDIT-NUMBER7. 185777 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-2. 185778 MOVE HLD-TEMP-NUMBER-2 TO DTLNK-OUTPUT-1-FRMT. 185779 185780 MOVE OU2FRMTI TO AN7-CURRENT-WORD. 185781 PERFORM Y100-AUDIT-NUMBER7. 185782 MOVE AN7-COMP-NUMBER TO HLD-TEMP-NUMBER-2. 185790 MOVE HLD-TEMP-NUMBER-2 TO DTLNK-OUTPUT-2-FRMT. 192900 M100-EXIT. 193000 EXIT. 193010****************************************************************** 193020 M200-MOVE-DTLNK-TO-MAP SECTION. 193021****************************************************************** 193022* THIS SECTION MOVES THE DATE RETURNED IN THE LINKAGE SECTION OF * 193023* THE DTSEDIT PROGRAM TO THE MAP * 193024****************************************************************** 193025 IF DTLNK-FUNC-REQ NOT = ZEROS 193026 MOVE DTLNK-FUNC-REQ TO RQFUNCO 193027 ELSE 193028 MOVE ALL '_' TO RQFUNCO 193029 END-IF. 193030 193040 IF DTLNK-CALC-REQ NOT = ZEROS 193092 MOVE DTLNK-CALC-REQ TO RQCALCO 193093 ELSE 193094 MOVE ALL '_' TO RQCALCO 193095 END-IF. 193096 193097 IF DTLNK-INPUT-1-FRMT NOT = ZEROS 193098 MOVE DTLNK-INPUT-1-FRMT TO IN1FRMTO 193099 ELSE 193100 MOVE ALL '_' TO IN1FRMTO 193101 END-IF. 193102 193103 IF DTLNK-INPUT-1-DATE NOT = SPACES 193104 MOVE DTLNK-INPUT-1-DATE TO IN1DATEO 193105 ELSE 193106 MOVE ALL '_' TO IN1DATEO 193107 END-IF. 193108 193109 IF DTLNK-INPUT-2-FRMT NOT = ZEROS 193110 MOVE DTLNK-INPUT-2-FRMT TO IN2FRMTO 193111 ELSE 193112 MOVE ALL '_' TO IN2FRMTO 193113 END-IF. 193114 193115 IF DTLNK-INPUT-2-DATE NOT = SPACES 193116 MOVE DTLNK-INPUT-2-DATE TO IN2DATEO 193117 ELSE 193118 MOVE ALL '_' TO IN2DATEO 193119 END-IF. 193120 193121 IF DTLNK-INPUT-MONTH NOT = ZEROS 193122 MOVE DTLNK-INPUT-MONTH TO INMNTHO 193123 ELSE 193124 MOVE ALL '_' TO INMNTHO 193125 END-IF. 193126 193128 MOVE DTLNK-DAY-CNT TO HLD-NUMERIC. 193129 PERFORM V100-DISPLAY-NUMERIC. 193130 IF HLD-RTRN-GROUP = SPACES 193131 IF DTLNK-FUNC-REQ = '030' 193132 AND (DTLNK-CALC-REQ = '001' 193133 OR DTLNK-CALC-REQ = '004' 193134 OR DTLNK-CALC-REQ = '005') 193135 MOVE ' 0' TO DAYCNTO 193136 ELSE 193137 MOVE ALL '_' TO DAYCNTO 193138 END-IF 193139 ELSE 193140 MOVE HLD-RTRN-GROUP TO DAYCNTO 193141 END-IF. 193142 193143 MOVE DTLNK-MONTH-CNT TO HLD-NUMERIC. 193144 PERFORM V100-DISPLAY-NUMERIC. 193145 IF HLD-RTRN-GROUP = SPACES 193146 IF DTLNK-FUNC-REQ = '030' 193147 AND (DTLNK-CALC-REQ = '006' 193148 OR DTLNK-CALC-REQ = '007') 193149 MOVE ' 0' TO MTHCNTO 193150 ELSE 193151 MOVE ALL '_' TO MTHCNTO 193152 END-IF 193153 ELSE 193154 MOVE HLD-RTRN-GROUP TO MTHCNTO 193155 END-IF. 193156 193157 MOVE DTLNK-YEAR-CNT TO HLD-NUMERIC. 193158 PERFORM V100-DISPLAY-NUMERIC. 193159 IF HLD-RTRN-GROUP = SPACES 193160 IF DTLNK-FUNC-REQ = '030' 193161 AND (DTLNK-CALC-REQ = '008' 193162 OR DTLNK-CALC-REQ = '009') 193163 MOVE ' 0' TO YRCNTO 193164 ELSE 193165 MOVE ALL '_' TO YRCNTO 193166 END-IF 193167 ELSE 193168 MOVE HLD-RTRN-GROUP TO YRCNTO 193169 END-IF. 193170 193171 IF DTLNK-OUTPUT-1-FRMT NOT = ZEROS 193172 MOVE DTLNK-OUTPUT-1-FRMT TO OU1FRMTO 193173 ELSE 193174 MOVE ALL '_' TO OU1FRMTO 193175 END-IF. 193176 193177 IF DTLNK-OUTPUT-1-DATE NOT = ZEROS 193178 MOVE DTLNK-OUTPUT-1-DATE TO OU1DATEO 193179 END-IF. 193180 193181 IF DTLNK-OUTPUT-2-FRMT NOT = ZEROS 193182 MOVE DTLNK-OUTPUT-2-FRMT TO OU2FRMTO 193183 ELSE 193184 MOVE ALL '_' TO OU2FRMTO 193185 END-IF. 193186 193187 IF DTLNK-OUTPUT-2-DATE NOT = ZEROS 193188 MOVE DTLNK-OUTPUT-2-DATE TO OU2DATEO 193189 END-IF. 193190 193191 IF DTLNK-OUTPUT-ALPHA NOT = ZEROS 193192 MOVE DTLNK-OUTPUT-ALPHA TO OUALPHAO 193193 END-IF. 193194 193195 MOVE DTLNK-RETURN-CODE TO RTNCDO. 193196 MOVE DTLNK-RETURN-MESSAGE TO RTNMSGO. 193197 M200-EXIT. 193198 EXIT. 193199****************************************************************** 193200 M300-MOVE-UNDERSCORES SECTION. 193201****************************************************************** 193202* THIS SECTION MOVES UNDERSCORES TO THE INPUTTABLE FIELDS ON THE * 193203* MAP * 193204****************************************************************** 193205 MOVE ALL '_' TO RQFUNCO 193206 RQCALCO 193207 IN1FRMTO 193210 IN1DATEO 193300 IN2FRMTO 193400 IN2DATEO 193500 INMNTHO 193900 OU1FRMTO 194000 OU2FRMTO 194010 DAYCNTO 194020 MTHCNTO 194030 YRCNTO. 194100 M300-EXIT. 194200 EXIT. 214000****************************************************************** 214100 R100-RECEIVE-MAP SECTION. 214110****************************************************************** 214120* THIS SECTION RECIEVES THE MAP * 214140****************************************************************** 214200 EXEC CICS RECEIVE 214300 MAPSET('DTMTEST') 214400 MAP('MTST1') 214500 END-EXEC. 214600 R100-EXIT. 214700 EXIT. 214800****************************************************************** 229600 S100-SEND-MAP-ERASE SECTION. 229610****************************************************************** 229620* THIS SECTION ERASES THE SCREEN AND REDISPLAYS THE MAP * 229630****************************************************************** 229700 EXEC CICS SEND 229800 MAPSET ('DTMTEST') 229900 MAP ('MTST1') 229910 ERASE 230100 FREEKB 230200 END-EXEC. 230300 S100-EXIT. 230400 EXIT. 230500****************************************************************** 230600 S200-SEND-MAP-DATAONLY SECTION. 230610****************************************************************** 230620* THIS SECTION ERASES ALL THE UNPROTECTED FIELDS ON THE MAP AND * 230621* RE POPULATES THOSE FIELDS. * 230630****************************************************************** 230700 EXEC CICS SEND 230800 MAPSET ('DTMTEST') 230900 MAP ('MTST1') 231000 DATAONLY 231200 FREEKB 231300 END-EXEC. 231400 S200-EXIT. 231500 EXIT. 231510****************************************************************** 231520 V100-DISPLAY-NUMERIC SECTION. 231530****************************************************************** 231540* THIS SECTION WILL DISPLAY A SIGNED NUMERIC FIELD IN AN * 231550* ALPHA-NUMERIC FIELD ON THE MAP. * 231560****************************************************************** 231570 MOVE HLD-NUMERIC TO HLD-NUMERIC-UNSIGNED. 231571 MOVE HLD-NUMERIC-UNSIGNED TO HLD-ALPHA-GROUP. 231580 MOVE 1 TO SUB-CNT 231581 MOVE ZERO TO SUB-RTRN 231590 231591 PERFORM 231592 UNTIL SUB-CNT > 5 231593 OR HLD-ALPHA (SUB-CNT) NOT = ZERO 231595 ADD 1 TO SUB-RTRN 231596 MOVE SPACES TO HLD-RTRN (SUB-RTRN) 231597 ADD 1 TO SUB-CNT 231598 END-PERFORM. 231599 231600 ADD 1 TO SUB-RTRN. 231601 IF HLD-NUMERIC < 0 231602 MOVE '-' TO HLD-RTRN (SUB-RTRN) 231603 ELSE 231604 MOVE SPACES TO HLD-RTRN (SUB-RTRN) 231605 END-IF. 231606 231607 PERFORM 231608 UNTIL SUB-CNT > 5 231609 ADD 1 TO SUB-RTRN 231610 MOVE HLD-ALPHA (SUB-CNT) TO HLD-RTRN (SUB-RTRN) 231611 ADD 1 TO SUB-CNT 231612 END-PERFORM. 231613 231614 V100-EXIT. 231615 EXIT. 231620****************************************************************** 231700*Y100-AUDIT-NUMBER7 SECTION. 231800****************************************************************** 231900* THIS SECTION RIGHT JUSTIFIES NUMBERS IN AN ALPHA-NUMERIC FIELD * 232000****************************************************************** 232100 COPY AN7RTN2. 441102****************************************************************** 441103 Z100-RETURN-TO-CICS SECTION. 441104****************************************************************** 441105* THIS SECTION RETURNS CONTROL TO CICS * 441106****************************************************************** 441107 EXEC CICS RETURN 441108 END-EXEC. 441109 Z100-EXIT. 441110 EXIT. 441111****************************************************************** 441112 Z200-DUMMY-STOP-RUN SECTION. 441113****************************************************************** 441114* THIS SECTION SHOULD NEVER BE REACHED. * 441115****************************************************************** 441116 STOP RUN. 441117 Z200-EXIT. 441118 EXIT. 441119****************************************************************** ./ ADD NAME=EVFINFO 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. EVFINFO. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* REMARKS: * 000700* THIS PROGRAM IS USED TO LOAD AN ISPF TABLE WITH EVF TABLE * 000800* DATA. * 000900***************************************************************** 001000/**************************************************************** 001100* E N V I R O N M E N T D I V I S I O N * 001200***************************************************************** 001300 ENVIRONMENT DIVISION. 001400 001500 INPUT-OUTPUT SECTION. 001600 001700 FILE-CONTROL. 001800 001900 COPY EVFSELD. 002000/**************************************************************** 002100* D A T A D I V I S I O N * 002200***************************************************************** 002300 DATA DIVISION. 002400 002500 FILE SECTION. 002600 002700 COPY EVFFD. 002800/**************************************************************** 002900* W O R K I N G - S T O R A G E S E C T I O N * 003000***************************************************************** 003100 WORKING-STORAGE SECTION. 003200***************************************************************** 003300* A C C U M U L A T O R S * 003400***************************************************************** 003500 01 ACCUMULATORS. 003600 05 FILLER PIC X(13) VALUE 003700 'ACCUMULATORS:'. 003800/**************************************************************** 003900* C O N S T A N T S * 004000***************************************************************** 004100 01 CONSTANTS. 004200 05 FILLER PIC X(10) VALUE 004300 'CONSTANTS:'. 004400 05 C-NULL-PLACE-HOLDER PIC X(01) VALUE ' '. 004500 05 C-ISPF-CONSTANTS. 004600 10 C-ISPF-SERVICES-AND-PARAMETERS. 004700 15 C-ISPF PIC X(07) VALUE 'ISPLINK'. 004800 15 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 004900 15 C-CONTROL PIC X(08) VALUE 'CONTROL '. 005000 15 C-TBCREATE PIC X(08) VALUE 'TBCREATE'. 005100 15 C-NOWRITE PIC X(08) VALUE 'NOWRITE '. 005300 15 C-SHARE PIC X(08) VALUE 'SHARE '. 005410 15 C-TBMOD PIC X(08) VALUE 'TBMOD '. 005500 15 C-TBTOP PIC X(08) VALUE 'TBTOP '. 005600 15 C-TBSKIP PIC X(08) VALUE 'TBSKIP '. 005700 15 C-TBEND PIC X(08) VALUE 'TBEND '. 005800 15 C-ERRORS PIC X(08) VALUE 'ERRORS '. 005900 15 C-RETURN PIC X(08) VALUE 'RETURN '. 006000 15 C-LIST PIC X(08) VALUE 'LIST '. 006200 15 C-TEMP-HEADERS PIC X(08) VALUE 'TEMPHDRS'. 006300 15 C-TEMP-HEADERS-KEYS PIC X(18) VALUE 006400 '(EVFCOID EVFTABLE)'. 006500 15 C-TEMP-HEADERS-NAMES. 006600 20 FILLER PIC X(34) VALUE 006700 '(EVFDESC EVFKEYH EVFDATAH EVFEDITF'. 006800 20 FILLER PIC X(35) VALUE 006900 ' EVFEEXIT EVFDFLTF EVFPKEYF EVFADDF'. 007000 20 FILLER PIC X(36) VALUE 007100 ' EVFHEADD EVFHEADU EVFMASKD EVFMASKU'. 007200 20 FILLER PIC X(36) VALUE 007300 ' EVFCNTLD EVFCNTLU EVFNAMED EVFNAMEU'. 007400 20 FILLER PIC X(25) VALUE 007500 ' EVFCHGF EVFDELF EVFMASK)'. 007600 15 C-TEMP-ROWS PIC X(08) VALUE 'TEMPROWS'. 007700 15 C-TEMP-ROWS-KEYS PIC X(08) VALUE '(EVFKEY)'. 007800 15 C-TEMP-ROWS-NAMES PIC X(25) VALUE 007900 '(EVFDATA EVFDATE EVFUSER)'. 008000**************************************************************** 008100* NOTE: THE ORDER OF THE ISPF VARIABLE NAMES IN THE "VALUE" * 008200* CLAUSE OF THE NEXT DATA ELEMENT "C-ISPF-VARIABLE-NAMES" * 008300* MUST MATCH THE ORDER OF THE ELEMENTARY ITEMS DEFINED * 008400* IN "C-ISPF-VARIABLE-LENGTHS", "C-ISPF-VARIABLE-FORMATS",* 008500* "C-ISPF-VARIABLES", AND "W-ISPF-VARIABLES". * 008600***************************************************************** 008700 10 C-ISPF-VARIABLE-NAMES. 008800 15 FILLER PIC X(40) VALUE 008900 '(EVFCOID EVFTABLE EVFKEY EVFDATE EVFUSER'. 009000 15 FILLER PIC X(42) VALUE 009100 ' EVFDELF EVFDATA EVFKEYH EVFDATAH EVFEDITF'. 009200 15 FILLER PIC X(44) VALUE 009300 ' EVFEEXIT EVFDFLTF EVFPKEYF EVFADDF EVFHEADD'. 009400 15 FILLER PIC X(45) VALUE 009500 ' EVFHEADU EVFMASKD EVFMASKU EVFCNTLD EVFCNTLU'. 009600 15 FILLER PIC X(43) VALUE 009700 ' EVFNAMED EVFNAMEU EVFCHGF EVFMASK EVFDESC)'. 009800 009900 10 C-ISPF-VARIABLE-LENGTHS COMP. 010000 15 C-EVF-COID-L PIC S9(06) VALUE +5. EV 010100 15 C-EVF-TBL-ID-L PIC S9(06) VALUE +10. EV 010200 15 C-EVF-TBL-KEY-L PIC S9(06) VALUE +10. EV 010300 15 C-EVF-DATE-L PIC S9(06) VALUE +8. EV 010400 15 C-EVF-USER-ID-L PIC S9(06) VALUE +5. EV 010500 15 C-EVF-DELETE-FLAG-L PIC S9(06) VALUE +1. EV 010600 15 C-EVF-VAR-DATA-L PIC S9(06) VALUE +40. EV 010700 15 C-EVF-KEY-HEADER-L PIC S9(06) VALUE +40. EV 010800 15 C-EVF-DATA-HEADER-L PIC S9(06) VALUE +40. EV 010900 15 C-EVF-EDIT-FLAG-L PIC S9(06) VALUE +1. EV 011000 15 C-EVF-EDIT-EXIT-L PIC S9(06) VALUE +8. EV 011100 15 C-EVF-DEFAULT-FLAG-L PIC S9(06) VALUE +1. EV 011200 15 C-EVF-PROT-KEY-FLAG-L PIC S9(06) VALUE +1. EV 011300 15 C-EVF-ADD-FLAG-L PIC S9(06) VALUE +1. EV 011400 15 C-EVF-HEAD-UPD-DATE-L PIC S9(06) VALUE +8. EV 011500 15 C-EVF-HEAD-UPD-USER-L PIC S9(06) VALUE +5. EV 011600 15 C-EVF-MASK-UPD-DATE-L PIC S9(06) VALUE +8. EV 011700 15 C-EVF-MASK-UPD-USER-L PIC S9(06) VALUE +5. EV 011800 15 C-EVF-CNTL-UPD-DATE-L PIC S9(06) VALUE +8. EV 011900 15 C-EVF-CNTL-UPD-USER-L PIC S9(06) VALUE +5. EV 012000 15 C-EVF-NAME-UPD-DATE-L PIC S9(06) VALUE +8. EV 012100 15 C-EVF-NAME-UPD-USER-L PIC S9(06) VALUE +5. EV 012200 15 C-EVF-CHANGE-FLAG-L PIC S9(06) VALUE +1. EV 012300 15 C-EVF-MASK-L PIC S9(06) VALUE +40. EV 012400 15 C-EVF-DESC-L PIC S9(06) VALUE +40. EV 012500 012600 10 C-ISPF-VARIABLE-FORMATS. 012700 15 C-EVF-COID-F PIC X(8) VALUE 'CHAR '. EV 012800 15 C-EVF-TBL-ID-F PIC X(8) VALUE 'CHAR '. EV 012900 15 C-EVF-TBL-KEY-F PIC X(8) VALUE 'CHAR '. EV 013000 15 C-EVF-DATE-F PIC X(8) VALUE 'CHAR '. EV 013100 15 C-EVF-USER-ID-F PIC X(8) VALUE 'CHAR '. EV 013200 15 C-EVF-DEL-FLAG-F PIC X(8) VALUE 'CHAR '. EV 013300 15 C-EVF-VAR-DATA-F PIC X(8) VALUE 'CHAR '. EV 013400 15 C-EVF-KEY-HEADER-F PIC X(8) VALUE 'CHAR '. EV 013500 15 C-EVF-DATA-HEADER-F PIC X(8) VALUE 'CHAR '. EV 013600 15 C-EVF-EDIT-FLAG-F PIC X(8) VALUE 'CHAR '. EV 013700 15 C-EVF-EDIT-EXIT-F PIC X(8) VALUE 'CHAR '. EV 013800 15 C-EVF-DEFAULT-FLAG-F PIC X(8) VALUE 'CHAR '. EV 013900 15 C-EVF-PROT-KEY-FLAG-F PIC X(8) VALUE 'CHAR '. EV 014000 15 C-EVF-ADD-FLAG-F PIC X(8) VALUE 'CHAR '. EV 014100 15 C-EVF-HEAD-UPD-DATE-F PIC X(8) VALUE 'CHAR '. EV 014200 15 C-EVF-HEAD-UPD-USER-F PIC X(8) VALUE 'CHAR '. EV 014300 15 C-EVF-MASK-UPD-DATE-F PIC X(8) VALUE 'CHAR '. EV 014400 15 C-EVF-MASK-UPD-USER-F PIC X(8) VALUE 'CHAR '. EV 014500 15 C-EVF-CNTL-UPD-DATE-F PIC X(8) VALUE 'CHAR '. EV 014600 15 C-EVF-CNTL-UPD-USER-F PIC X(8) VALUE 'CHAR '. EV 014700 15 C-EVF-NAME-UPD-DATE-F PIC X(8) VALUE 'CHAR '. EV 014800 15 C-EVF-NAME-UPD-USER-F PIC X(8) VALUE 'CHAR '. EV 014900 15 C-EVF-CHANGE-FLAG-F PIC X(8) VALUE 'CHAR '. EV 015000 15 C-EVF-MASK-F PIC X(8) VALUE 'CHAR '. EV 015100 15 C-EVF-DESC-F PIC X(8) VALUE 'CHAR '. EV 015200/**************************************************************** 015300* S W I T C H E S * 015400***************************************************************** 015500 01 SWITCHES. 015600 05 FILLER PIC X(09) VALUE 015700 'SWITCHES:'. 015800 015900 05 S-EVF-FILE-OPEN-SWITCH PIC X(01) VALUE 'N'. 016000 88 S-EVF-FILE-IS-OPEN VALUE 'Y'. 016100 05 S-EVF-END-OF-FILE-SWITCH PIC X(01) VALUE 'N'. 016200 88 S-EVF-END-OF-FILE VALUE 'Y'. 016400 05 S-EVF-ROW-ACCESS-SWITCH PIC X(01) VALUE 'N'. 016500 88 S-EVF-TABLE-ROW-FOUND VALUE 'Y'. 016600 88 S-EVF-TABLE-ROW-NOT-FOUND VALUE 'N'. 016700/**************************************************************** 016800* W O R K A R E A S * 016900***************************************************************** 017000 01 WORK-AREAS. 017100 05 FILLER PIC X(11) VALUE 017200 'WORK AREAS:'. 017300 017400 05 W-RETURN-CODE PIC S9(08) COMP VALUE +0. 017500 017600 05 W-PARM-PARSE-AREA. 017700 10 W-PARM-PARSE-TABLE OCCURS 3 TIMES 017800 INDEXED BY W-PARM-NDX. 017900 15 W-VARIABLE PIC X(10). 018000 15 W-VALUE PIC X(10). 018100 018110 05 W-UNCONVERTED-DATE PIC 9(07). 018120 05 FILLER REDEFINES W-UNCONVERTED-DATE. 018130 10 FILLER PIC X(01). 018140 10 W-UNCONVERTED-YY PIC X(02). 018141 10 W-UNCONVERTED-MM PIC X(02). 018142 10 W-UNCONVERTED-DD PIC X(02). 018143 05 W-CONVERTED-DATE. 018146 10 W-CONVERTED-YY PIC X(02). 018147 10 FILLER PIC X(01) VALUE '/'. 018148 10 W-CONVERTED-MM PIC X(02). 018149 10 FILLER PIC X(01) VALUE '/'. 018150 10 W-CONVERTED-DD PIC X(02). 018160 018200 05 W-HOLD-VALUES. 018300 10 W-READ-TYPE PIC X(10) VALUE SPACES. 018400 88 W-HEADER-READ VALUE 'HEADER'. 018500 88 W-DATA-READ VALUE 'DATA'. 018600 10 W-COID-VALUE PIC X(05) VALUE SPACES. 018700 10 W-TABLE-NAME PIC X(10) VALUE SPACES. 018800 018900 05 W-ISPF-VARIABLES. 019000 10 W-EVF-COID PIC X(05) VALUE SPACES. EV 019100 10 W-EVF-TBL-ID PIC X(10) VALUE SPACES. EV 019200 10 W-EVF-TBL-KEY PIC X(10) VALUE SPACES. EV 019300 10 W-EVF-DATE PIC X(08) VALUE SPACES. EV 019400 10 W-EVF-USER-ID PIC X(05) VALUE SPACES. EV 019500 10 W-EVF-DEL-FLAG PIC X(01) VALUE SPACES. EV 019600 10 W-EVF-VAR-DATA PIC X(40) VALUE SPACES. EV 019700 10 W-EVF-KEY-HEADER PIC X(40) VALUE SPACES. EV 019800 10 W-EVF-DATA-HEADER PIC X(40) VALUE SPACES. EV 019900 10 W-EVF-EDIT-FLAG PIC X(01) VALUE SPACES. EV 020000 10 W-EVF-EDIT-EXIT PIC X(08) VALUE SPACES. EV 020100 10 W-EVF-DEFAULT-FLAG PIC X(01) VALUE SPACES. EV 020200 10 W-EVF-PROT-KEY-FLAG PIC X(01) VALUE SPACES. EV 020300 10 W-EVF-ADD-FLAG PIC X(01) VALUE SPACES. EV 020400 10 W-EVF-HEAD-UPD-DATE PIC X(08) VALUE SPACES. EV 020500 10 W-EVF-HEAD-UPD-USER PIC X(05) VALUE SPACES. EV 020600 10 W-EVF-MASK-UPD-DATE PIC X(08) VALUE SPACES. EV 020700 10 W-EVF-MASK-UPD-USER PIC X(05) VALUE SPACES. EV 020800 10 W-EVF-CNTL-UPD-DATE PIC X(08) VALUE SPACES. EV 020900 10 W-EVF-CNTL-UPD-USER PIC X(05) VALUE SPACES. EV 021000 10 W-EVF-NAME-UPD-DATE PIC X(08) VALUE SPACES. EV 021100 10 W-EVF-NAME-UPD-USER PIC X(05) VALUE SPACES. EV 021200 10 W-EVF-CHANGE-FLAG PIC X(01) VALUE SPACES. EV 021300 10 W-EVF-MASK PIC X(40) VALUE SPACES. EV 021400 10 W-EVF-DESC PIC X(40) VALUE SPACES. EV 021500 021600 05 W-T940CNTL-DATA-AREA. 021700 10 W-EVF-CNTL-EDIT-FLAG PIC X(01) VALUE SPACES. EV 021800 10 W-EVF-CNTL-EDIT-EXIT PIC X(08) VALUE SPACES. EV 021900 10 W-EVF-CNTL-DFLT-FLAG PIC X(01) VALUE SPACES. EV 022000 10 W-EVF-CNTL-PKEY-FLAG PIC X(01) VALUE SPACES. EV 022100 10 W-EVF-CNTL-ADD-FLAG PIC X(01) VALUE SPACES. EV 022200 10 W-EVF-CNTL-CHANGE-FLAG PIC X(01) VALUE SPACES. EV 022300 10 W-EVF-CNTL-DELETE-FLAG PIC X(01) VALUE SPACES. EV 022400 10 FILLER PIC X(26) VALUE SPACES. EV 022500 COPY FLSTAT. 022600 COPY EVFWS. 022700/**************************************************************** 022800* P R I N T L I N E S * 022900***************************************************************** 023000 01 PRINT-LINES. 023100 05 FILLER PIC X(12) VALUE 023200 'PRINT LINES:'. 023300/**************************************************************** 023400* T A B L E S * 023500***************************************************************** 023600 01 TABLES. 023700 05 FILLER PIC X(07) VALUE 023800 'TABLES:'. 023900/**************************************************************** 024000* L I N K A G E S E C T I O N * 024100***************************************************************** 024200 LINKAGE SECTION. 024300 01 L-PARM-AREA. 024400 05 L-PARM-LENGTH PIC S9(04) COMP. 024500 05 L-PARM-DATA. 024600 10 L-PARM-BYTE OCCURS 1 TO 100 TIMES 024700 DEPENDING ON L-PARM-LENGTH 024800 PIC X(01). 025100/**************************************************************** 025200* P R O C E D U R E D I V I S I O N * 025300***************************************************************** 025400 PROCEDURE DIVISION USING L-PARM-AREA. 025500***************************************************************** 025600* S0000-CONTROL * 025700***************************************************************** 025800 S0000-CONTROL SECTION. 025900 026000 PERFORM S1000-INITIALIZATION. 026100 026200 PERFORM S2000-MAIN-PROCESS. 026300 026400 PERFORM S3000-FINALIZATION. 026500 026600 MOVE W-RETURN-CODE TO RETURN-CODE. 026700 GOBACK. 026800 026900 S0000-EXIT. 027000 EXIT. 027100/**************************************************************** 027200* S1000-INITIALIZATION * 027300***************************************************************** 027400 S1000-INITIALIZATION SECTION. 027500 027600 PERFORM S1100-PARSE-PARM. 027700 027800 IF W-RETURN-CODE = +0 027900 PERFORM S1200-ISPF-INITIALIZATION 028000 IF W-RETURN-CODE = +0 028100 PERFORM S1300-OPEN-EVFILE 028200 IF W-RETURN-CODE = +0 028300 PERFORM S4000-POSITIONING-READ 028400 END-IF 028500 END-IF 028600 END-IF. 028700 028800 S1000-EXIT. 028900 EXIT. 029000/**************************************************************** 029100* S1100-PARSE-PARM * 029200***************************************************************** 029300 S1100-PARSE-PARM SECTION. 029400 029500 IF L-PARM-LENGTH > +0 029510 INITIALIZE W-PARM-PARSE-AREA 029600 UNSTRING L-PARM-DATA 029700 DELIMITED BY ALL '=' OR ALL ' ' OR ALL ',' 029800 INTO W-VARIABLE (1) W-VALUE (1) 029900 W-VARIABLE (2) W-VALUE (2) 030000 W-VARIABLE (3) W-VALUE (3) 030100 END-UNSTRING 030200 PERFORM VARYING W-PARM-NDX FROM +1 BY +1 030300 UNTIL W-PARM-NDX > +3 030310 OR W-VARIABLE (W-PARM-NDX) = SPACES 030400 OR W-RETURN-CODE > +0 030500 EVALUATE W-VARIABLE (W-PARM-NDX) 030600 WHEN 'TYPE' 030700 MOVE W-VALUE (W-PARM-NDX) TO 030800 W-READ-TYPE 030900 WHEN 'COID' 030910 IF W-VALUE (W-PARM-NDX) = '*DFLT' 031000 MOVE LOW-VALUES TO 031100 W-COID-VALUE 031101 ELSE 031110 MOVE W-VALUE (W-PARM-NDX) TO 031120 W-COID-VALUE 031130 END-IF 031200 WHEN 'TABLE' 031300 MOVE W-VALUE (W-PARM-NDX) TO 031400 W-TABLE-NAME 031500 WHEN OTHER 031600 MOVE +2000 TO W-RETURN-CODE 031700 END-EVALUATE 031800 END-PERFORM 031900 IF (W-HEADER-READ) OR 032000 (W-DATA-READ AND 032100 W-COID-VALUE NOT = SPACES AND 032200 W-TABLE-NAME > SPACES) 032300 NEXT SENTENCE 032400 ELSE 032500 MOVE +2001 TO W-RETURN-CODE 032600 END-IF 032700 ELSE 032800 MOVE +2002 TO W-RETURN-CODE 032900 END-IF. 033000 033100 S1100-EXIT. 033200 EXIT. 033300/**************************************************************** 033400* S1200-ISPF-INITIALIZATION * 033500***************************************************************** 033600 S1200-ISPF-INITIALIZATION SECTION. 033700 033800 CALL C-ISPF USING C-CONTROL C-ERRORS C-RETURN. 033900 IF RETURN-CODE > +4 034000 MOVE RETURN-CODE TO W-RETURN-CODE 034100 END-IF. 034200 034300 CALL C-ISPF USING C-VDEFINE C-ISPF-VARIABLE-NAMES, 034400 W-ISPF-VARIABLES, 034500 C-ISPF-VARIABLE-FORMATS, 034600 C-ISPF-VARIABLE-LENGTHS, 034700 C-LIST. 034800 IF RETURN-CODE > +4 034900 MOVE RETURN-CODE TO W-RETURN-CODE 035000 END-IF. 035100 035200 IF W-HEADER-READ 035300 CALL C-ISPF USING C-TBEND C-TEMP-HEADERS 035400 IF RETURN-CODE > +12 035500 MOVE RETURN-CODE TO W-RETURN-CODE 035600 END-IF 035700 CALL C-ISPF USING C-TBCREATE C-TEMP-HEADERS, 035800 C-TEMP-HEADERS-KEYS, 035900 C-TEMP-HEADERS-NAMES, 036000 C-NOWRITE, 036010 C-NULL-PLACE-HOLDER, 036020 C-NULL-PLACE-HOLDER, 036100 C-SHARE 036200 END-CALL 036210 IF RETURN-CODE > +4 036300 MOVE RETURN-CODE TO W-RETURN-CODE 036400 END-IF 036500 ELSE 036600 CALL C-ISPF USING C-TBEND C-TEMP-ROWS 036700 IF RETURN-CODE > +12 036800 MOVE RETURN-CODE TO W-RETURN-CODE 036900 END-IF 037000 CALL C-ISPF USING C-TBCREATE C-TEMP-ROWS, 037100 C-TEMP-ROWS-KEYS, 037200 C-TEMP-ROWS-NAMES, 037300 C-NOWRITE, 037310 C-NULL-PLACE-HOLDER, 037320 C-NULL-PLACE-HOLDER, 037400 C-SHARE 037410 END-CALL 037500 IF RETURN-CODE > +4 037600 MOVE RETURN-CODE TO W-RETURN-CODE 037700 END-IF 037800 END-IF. 037900 038000 IF W-RETURN-CODE > +0 038100 MOVE +2003 TO W-RETURN-CODE 038200 END-IF. 038300 038400 S1200-EXIT. 038500 EXIT. 038600/**************************************************************** 038700* S1300-OPEN-EVFILE * 038800***************************************************************** 038900 S1300-OPEN-EVFILE SECTION. 039000 039100 OPEN INPUT EVF-FILE-D. 039200 039300 IF (NOT SUCCESSFUL) 039400 MOVE +2004 TO W-RETURN-CODE 039500 ELSE 039600 SET S-EVF-FILE-IS-OPEN TO TRUE 039700 END-IF. 039800 039900 S1300-EXIT. 040000 EXIT. 040100/**************************************************************** 040200* S2000-MAIN-PROCESS * 040300***************************************************************** 040400 S2000-MAIN-PROCESS SECTION. 040500 040600 IF W-DATA-READ 041391 PERFORM S9000-LOAD-ROWS-TABLE 041392 UNTIL W-RETURN-CODE > +0 041393 OR S-EVF-END-OF-FILE 041394 OR EVF-COID NOT = W-COID-VALUE 041395 OR EVF-TBL-ID NOT = W-TABLE-NAME 041400 ELSE 041401 PERFORM S7000-LOAD-HEADER-TABLE 041402 UNTIL W-RETURN-CODE > +0 041403 OR S-EVF-END-OF-FILE 041404 PERFORM S8000-UPDATE-HEADER-TABLE 042100 END-IF. 042200 042300 S2000-EXIT. 042400 EXIT. 042500/**************************************************************** 042600* S3000-FINALIZATION * 042700***************************************************************** 042800 S3000-FINALIZATION SECTION. 042900 043000 IF S-EVF-FILE-IS-OPEN 043100 CLOSE EVF-FILE-D 043200 IF (NOT SUCCESSFUL) 043300 MOVE +2006 TO W-RETURN-CODE 043400 END-IF 043500 END-IF. 043600 043700 S3000-EXIT. 043800 EXIT. 043900/**************************************************************** 044000* S4000-POSITIONING-READ * 044100***************************************************************** 044200 S4000-POSITIONING-READ SECTION. 044300 044400 IF W-DATA-READ 044500 MOVE W-COID-VALUE TO EVF-KEY-COID-FDD 044600 MOVE W-TABLE-NAME TO EVF-TBL-ID-FDD 044700 MOVE LOW-VALUES TO EVF-TBL-KEY-FDD 044800 START EVF-FILE-D 044900 KEY IS > EVF-ISAM-KEY-FDD 045000 INVALID KEY 045100 MOVE +2007 TO W-RETURN-CODE 045200 END-START 045300 END-IF. 045400 045500 PERFORM S5000-SEQUENTIAL-READ. 045600 045700 S4000-EXIT. 045800 EXIT. 045900/**************************************************************** 046000* S5000-SEQUENTIAL-READ * 046100***************************************************************** 046200 S5000-SEQUENTIAL-READ SECTION. 046300 046400 READ EVF-FILE-D NEXT RECORD INTO EVF-REC 046500 AT END 046600 SET S-EVF-END-OF-FILE TO TRUE 046700 END-READ. 046800 046900 S5000-EXIT. 047000 EXIT. 047100/**************************************************************** 047200* S6000-RANDOM-READ * 047300***************************************************************** 047400 S6000-RANDOM-READ SECTION. 047500 047600 READ EVF-FILE-D INTO EVF-REC 047700 KEY IS EVF-ISAM-KEY-FDD 047800 INVALID KEY 047900 SET S-EVF-TABLE-ROW-NOT-FOUND TO TRUE 048000 NOT INVALID KEY 048100 SET S-EVF-TABLE-ROW-FOUND TO TRUE 048200 END-READ. 048300 048400 S6000-EXIT. 048500 EXIT. 048600/**************************************************************** 048700* S7000-LOAD-HEADER-TABLE * 048800***************************************************************** 048900 S7000-LOAD-HEADER-TABLE SECTION. 049000 049100 IF EVF-TBL-KEY = LOW-VALUES 049200 INITIALIZE W-ISPF-VARIABLES 049210 UNSTRING EVF-VAR-DATA 049220 DELIMITED BY ALL ',' OR ALL LOW-VALUES 049230 INTO W-EVF-KEY-HEADER 049240 W-EVF-DATA-HEADER 049250 END-UNSTRING 049300 IF EVF-COID = LOW-VALUES 049400 MOVE '*DFLT' TO W-EVF-COID 049500 ELSE 049600 MOVE EVF-COID TO W-EVF-COID EV 049610 END-IF 049700 MOVE EVF-TBL-ID TO W-EVF-TBL-ID EV 049800 MOVE EVF-VAR-DATA TO W-EVF-DESC EV 049810 MOVE EVF-DATE TO W-UNCONVERTED-DATE 049820 MOVE W-UNCONVERTED-YY TO W-CONVERTED-YY 049830 MOVE W-UNCONVERTED-MM TO W-CONVERTED-MM 049840 MOVE W-UNCONVERTED-DD TO W-CONVERTED-DD 049850 MOVE W-CONVERTED-DATE TO W-EVF-HEAD-UPD-DATE EV 050000 MOVE EVF-USER-ID TO W-EVF-HEAD-UPD-USER EV 050100 CALL C-ISPF USING C-TBMOD C-TEMP-HEADERS 050200 END-IF. 050300 050400 PERFORM S5000-SEQUENTIAL-READ. 050500 050600 S7000-EXIT. 050700 EXIT. 050800/**************************************************************** 050900* S8000-UPDATE-HEADER-TABLE * 051000***************************************************************** 051100 S8000-UPDATE-HEADER-TABLE SECTION. 051200 051300 CALL C-ISPF USING C-TBTOP C-TEMP-HEADERS. 051400 IF RETURN-CODE > +4 051500 MOVE +2008 TO W-RETURN-CODE 051600 END-IF. 051700 051800 CALL C-ISPF USING C-TBSKIP C-TEMP-HEADERS. 051900 052000 PERFORM UNTIL RETURN-CODE > +4 052100 MOVE 'T940CNTL' TO EVF-TBL-ID-FDD 052200 MOVE LOW-VALUES TO EVF-KEY-COID-FDD 052300 MOVE W-EVF-TBL-ID TO EVF-TBL-KEY-FDD EV 052400 PERFORM S6000-RANDOM-READ 052500 IF S-EVF-TABLE-ROW-FOUND 052600 MOVE EVF-VAR-DATA TO W-T940CNTL-DATA-AREA 052700 MOVE W-EVF-CNTL-EDIT-FLAG TO W-EVF-EDIT-FLAG EV 052800 MOVE W-EVF-CNTL-EDIT-EXIT TO W-EVF-EDIT-EXIT EV 052900 MOVE W-EVF-CNTL-DFLT-FLAG TO W-EVF-DEFAULT-FLAG EV 053000 MOVE W-EVF-CNTL-PKEY-FLAG TO W-EVF-PROT-KEY-FLAG EV 053100 MOVE W-EVF-CNTL-ADD-FLAG TO W-EVF-ADD-FLAG EV 053200 MOVE W-EVF-CNTL-CHANGE-FLAG TO W-EVF-CHANGE-FLAG EV 053300 MOVE W-EVF-CNTL-DELETE-FLAG TO W-EVF-DEL-FLAG EV 053400 MOVE EVF-DATE TO W-UNCONVERTED-DATE 053405 MOVE W-UNCONVERTED-YY TO W-CONVERTED-YY 053406 MOVE W-UNCONVERTED-MM TO W-CONVERTED-MM 053407 MOVE W-UNCONVERTED-DD TO W-CONVERTED-DD 053413 MOVE W-CONVERTED-DATE TO W-EVF-CNTL-UPD-DATE EV 053414 MOVE EVF-USER-ID TO W-EVF-CNTL-UPD-USER EV 053415 ELSE 053417 MOVE SPACES TO W-EVF-EDIT-FLAG EV 053418 W-EVF-EDIT-EXIT EV 053419 W-EVF-DEFAULT-FLAG EV 053420 W-EVF-PROT-KEY-FLAG EV 053430 W-EVF-ADD-FLAG EV 053440 W-EVF-CHANGE-FLAG EV 053450 W-EVF-DEL-FLAG EV 053500 W-EVF-CNTL-UPD-DATE EV 053510 W-EVF-CNTL-UPD-USER EV 053600 END-IF 053700 MOVE 'T940NAME' TO EVF-TBL-ID-FDD 053800 PERFORM S6000-RANDOM-READ 053900 IF S-EVF-TABLE-ROW-FOUND 053901 MOVE EVF-VAR-DATA TO W-EVF-DESC 053910 MOVE EVF-DATE TO W-UNCONVERTED-DATE 053920 MOVE W-UNCONVERTED-YY TO W-CONVERTED-YY 053930 MOVE W-UNCONVERTED-MM TO W-CONVERTED-MM 053940 MOVE W-UNCONVERTED-DD TO W-CONVERTED-DD 053950 MOVE W-CONVERTED-DATE TO W-EVF-NAME-UPD-DATE EV 053960 MOVE EVF-USER-ID TO W-EVF-NAME-UPD-USER EV 053970 ELSE 053990 MOVE SPACES TO W-EVF-NAME-UPD-DATE EV 054000 W-EVF-NAME-UPD-USER EV 054300 END-IF 054400 MOVE 'T940MASK' TO EVF-TBL-ID-FDD 054500 PERFORM S6000-RANDOM-READ 054600 IF S-EVF-TABLE-ROW-FOUND 054610 MOVE EVF-VAR-DATA TO W-EVF-MASK 054620 MOVE EVF-DATE TO W-UNCONVERTED-DATE 054630 MOVE W-UNCONVERTED-YY TO W-CONVERTED-YY 054640 MOVE W-UNCONVERTED-MM TO W-CONVERTED-MM 054650 MOVE W-UNCONVERTED-DD TO W-CONVERTED-DD 054660 MOVE W-CONVERTED-DATE TO W-EVF-MASK-UPD-DATE EV 054670 MOVE EVF-USER-ID TO W-EVF-MASK-UPD-USER EV 054680 ELSE 054690 MOVE SPACES TO W-EVF-MASK EV 054700 W-EVF-MASK-UPD-DATE EV 054800 W-EVF-MASK-UPD-USER EV 055000 END-IF 055100 CALL C-ISPF USING C-TBMOD C-TEMP-HEADERS 055110 CALL C-ISPF USING C-TBSKIP C-TEMP-HEADERS 055200 END-PERFORM. 057300 057400 S8000-EXIT. 057500 EXIT. 057600/**************************************************************** 057700* S9000-LOAD-ROWS-TABLE * 057800***************************************************************** 057900 S9000-LOAD-ROWS-TABLE SECTION. 058000 058080 MOVE EVF-VAR-DATA TO W-EVF-VAR-DATA. EV 058081 MOVE EVF-TBL-KEY TO W-EVF-TBL-KEY. EV 058082 MOVE EVF-DATE TO W-UNCONVERTED-DATE. 058083 MOVE W-UNCONVERTED-YY TO W-CONVERTED-YY. 058084 MOVE W-UNCONVERTED-MM TO W-CONVERTED-MM. 058085 MOVE W-UNCONVERTED-DD TO W-CONVERTED-DD. 058086 MOVE W-CONVERTED-DATE TO W-EVF-DATE. EV 058087 MOVE EVF-USER-ID TO W-EVF-USER-ID. EV 058092 CALL C-ISPF USING C-TBMOD C-TEMP-ROWS. 058094 058095 PERFORM S5000-SEQUENTIAL-READ. 058200 058300 S9000-EXIT. 058400 EXIT. ./ ADD NAME=FINDIT IDENTIFICATION DIVISION. PROGRAM-ID. TESTPGM. AUTHOR. DAVE LEIGH DATE-COMPILED. ENVIRONMENT DIVISION. INPUT-OUTPUT SECTION. FILE-CONTROL. SELECT INPUT-FILE ASSIGN TO INFILE. * SELECT OUTPUT-FILE ASSIGN TO OUTFILE. DATA DIVISION. FILE SECTION. FD INPUT-FILE RECORD CONTAINS 80 CHARACTERS BLOCK CONTAINS 0 RECORDS LABEL RECORDS ARE STANDARD RECORDING MODE IS F DATA RECORD IS INPUT-RECORD. 01 INPUT-RECORD PIC X(80). WORKING-STORAGE SECTION. 01 A-RECORDS-FOUND PIC S9(08) COMP SYNC VALUE +0. LINKAGE SECTION. 01 LINKAGE-AREA. 05 L-PARM-LENGTH PIC S9(04) COMP. 05 L-SEARCH-STRING PIC X(100). PROCEDURE DIVISION USING LINKAGE-AREA. OPEN INPUT INPUT-FILE. SLS5249 READ INPUT-FILE AT END GO TO GETOUT. PERFORM UNTIL L-PARM-LENGTH = +0 SLS5249 INSPECT INPUT-RECORD SLS5249 REPLACING ALL 'a' BY 'A' ALL 'b' BY 'B' ALL 'c' BY 'C' ALL 'd' BY 'D' ALL 'e' BY 'E' ALL 'f' BY 'F' ALL 'g' BY 'G' ALL 'h' BY 'H' ALL 'i' BY 'I' ALL 'j' BY 'J' ALL 'k' BY 'K' ALL 'l' BY 'L' ALL 'm' BY 'M' ALL 'n' BY 'N' ALL 'o' BY 'O' ALL 'p' BY 'P' ALL 'q' BY 'Q' ALL 'r' BY 'R' ALL 's' BY 'S' ALL 't' BY 'T' ALL 'u' BY 'U' ALL 'v' BY 'V' ALL 'w' BY 'W' ALL 'x' BY 'X' ALL 'y' BY 'Y' ALL 'z' BY 'Z' MOVE +0 TO TALLY INSPECT INPUT-RECORD SLS5249 TALLYING TALLY FOR ALL L-SEARCH-STRING(1:L-PARM-LENGTH) IF TALLY > +0 ADD +1 TO A-RECORDS-FOUND DISPLAY INPUT-RECORD END-IF READ INPUT-FILE AT END GO TO GETOUT END-READ END-PERFORM. SLS5249 GETOUT. CLOSE INPUT-FILE IF A-RECORDS-FOUND = +0 DISPLAY 'COULD NOT FIND: ' L-SEARCH-STRING(1:L-PARM-LENGTH) END-IF. GOBACK. ./ ADD NAME=GENSYNS 000200 IDENTIFICATION DIVISION. 000300 PROGRAM-ID. GENSYNS. 000400 AUTHOR. DAVE LEIGH 000500 DATE-COMPILED. 000800/***************************************************************** 000900** E N V I R O N M E N T D I V I S I O N ** 001000****************************************************************** 001100 ENVIRONMENT DIVISION. 001200 001300 INPUT-OUTPUT SECTION. 001400 001500 FILE-CONTROL. 001600 001700 SELECT OUTPUT-CREATE-FILE ASSIGN TO OUTCREAT. 001600 SELECT INPUT-RELATE-FILE ASSIGN TO RELATE. 001800 001900/***************************************************************** 002000** D A T A D I V I S I O N ** 002100****************************************************************** 002200 DATA DIVISION. 002300 002400 FILE SECTION. 002500 002500 FD INPUT-RELATE-FILE 002700 RECORDING MODE IS F 002800 RECORD CONTAINS 80 CHARACTERS 002900 BLOCK CONTAINS 0 RECORDS 002900 DATA RECORD IS INPUT-RELATE-RECORD. 003000 003100 01 INPUT-RELATE-RECORD PIC X(80). 003200 003300 FD OUTPUT-CREATE-FILE 003400 RECORDING MODE IS F 003500 RECORD CONTAINS 80 CHARACTERS 003600 BLOCK CONTAINS 0 RECORDS 003000 DATA RECORD IS OUTPUT-CREATE-RECORD. 003100 003200 01 OUTPUT-CREATE-RECORD PIC X(80). 003300 003400/***************************************************************** 003500** W O R K I N G - S T O R A G E S E C T I O N ** 003600****************************************************************** 003700 WORKING-STORAGE SECTION. 003800 003900/***************************************************************** 004700** A C C U M U L A T O R S ** 004100****************************************************************** 004200 01 ACCUMULATORS. 005000 05 A-INPUT-RECORDS-READ PIC S9(04) COMP VALUE +0. 005100 88 A-NO-RECORDS-READ VALUE +0. 004300 05 A-INPUT-ROWS-FETCHED PIC S9(04) COMP VALUE +0. 004400 88 A-NO-ROWS-FETCHED VALUE +0. 004500 004600/***************************************************************** 005600** C O N S T A N T S ** 005700****************************************************************** 005800 01 CONSTANTS. 005900 05 C-ERROR-TEXT-LEN PIC S9(08) COMP VALUE +120. 006000 006100/***************************************************************** 004700** S W I T C H E S ** 004800****************************************************************** 004900 01 SWITCHES. 006500 05 S-END-OF-DB2-INPUT-SWITCH PIC X(01) VALUE "Y". 006600 88 S-END-OF-DB2-INPUT VALUE "N". 005200 88 S-MORE-ROWS-TO-FETCH VALUE "Y". 006800 05 S-END-OF-FILE-INPUT-SWITCH PIC X(01) VALUE "Y". 006900 88 S-END-OF-FILE-INPUT VALUE "N". 007000 88 S-MORE-RECORDS-TO-READ VALUE "Y". 005300 005400/**************************************************************** 005500* W O R K A R E A S * 005600***************************************************************** 005700 01 WORK-AREAS. 005800 05 W-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0. 005810 88 W-BAD-PARM VALUE +2000. 007800 05 W-INPUT-RECORD. 007900 10 W-USER-DOMAIN PIC X(08). 008000 10 W-APPL-DOMAIN PIC X(08). 008100 10 FILLER PIC X(64). 006000 05 W-CREATE-RECORD PIC X(80). 006100 05 W-HOLD-RECORD PIC X(80). 006200 05 W-FETCH-INCREMENT PIC S9(08) COMP SYNC. 006300 05 W-SYNC-INCREMENT PIC 9(04) VALUE 0. 006400 05 W-PARM-VALUE1 PIC X(08) VALUE SPACES. 006500 88 W-THIS-IS-A-CREATE-REQUEST VALUE "CREATE". 006600 88 W-THIS-IS-A-DROP-REQUEST VALUE "DROP". 006700 05 W-PARM-VALUE2 PIC X(08) VALUE SPACES. 006900 88 W-PROCESS-ALL-IDS VALUE "ALL". 006910 05 W-PARM-VALUE3 PIC X(08) VALUE SPACES. 006920 88 W-PLATINUM-DRIVER-USED VALUE "PLATINUM". 006930 88 W-DSNTIAD-USED VALUE "DSNTIAD". 009400 05 W-DSNTIAR-AREA. 009500 10 ERROR-LEN PIC S9(04) COMP VALUE +960. 009600 10 W-ERROR-TEXT PIC X(120) OCCURS 8 TIMES 009700 INDEXED BY W-ERR-NDX. 007000 007100/*********************************************************** 007200* SQLCA -- DB2 COMMUNICATION AREA 007300************************************************************ 007400 EXEC SQL INCLUDE SQLCA END-EXEC. 007500****************************************************************** 007600* DCLGEN TABLE(SYSIBM.SYSSYNONYMS) * 010500* LIBRARY(D@UDAL.STR.COPYLIB(SYSSYNON)) * 007800* APOST * 007900* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 008000****************************************************************** 008100 EXEC SQL DECLARE SYSIBM.SYSSYNONYMS TABLE 008200 ( NAME VARCHAR(18) NOT NULL, 008300 CREATOR CHAR(8) NOT NULL, 008400 TBNAME VARCHAR(18) NOT NULL, 008500 TBCREATOR CHAR(8) NOT NULL, 008600 IBMREQD CHAR(1) NOT NULL, 008700 CREATEDBY CHAR(8) NOT NULL 008800 ) END-EXEC. 008900****************************************************************** 009000* COBOL DECLARATION FOR TABLE SYSIBM.SYSSYNONYMS * 009100****************************************************************** 009200 01 DCLSYSSYNONYMS. 009300 10 NAME. 009400 49 NAME-LEN PIC S9(4) USAGE COMP. 009500 49 NAME-TEXT PIC X(18). 009600 10 CREATOR PIC X(8). 009700 10 TBNAME. 009800 49 TBNAME-LEN PIC S9(4) USAGE COMP. 009900 49 TBNAME-TEXT PIC X(18). 010000 10 TBCREATOR PIC X(8). 010100 10 IBMREQD PIC X(1). 010200****************************************************************** 010300* DCLGEN TABLE(PTI.PTRCS_APLDOM_0200) * 013200* LIBRARY(D@UDAL.STR.COPYLIB(PLATADOM)) * 010500* APOST * 010600* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 010700****************************************************************** 010800 EXEC SQL DECLARE PTI.PTRCS_APLDOM_0200 TABLE 010900 ( NAME CHAR(8) NOT NULL, 011000 DB2ID CHAR(4) NOT NULL, 011100 DEPT CHAR(8) NOT NULL, 011200 QUALIFIER CHAR(8) NOT NULL, 011300 OBJNAME VARCHAR(18) NOT NULL, 011400 OBJTYPE CHAR(2) NOT NULL, 011500 UPDATE_USER CHAR(8) NOT NULL, 011600 UPDATE_DATE DATE NOT NULL, 011700 IMPLEMENTED TIMESTAMP NOT NULL, 011800 AUTHS VARCHAR(25) NOT NULL, 011900 PENDING VARCHAR(25) NOT NULL 012000 ) END-EXEC. 012100****************************************************************** 012200* COBOL DECLARATION FOR TABLE PTI.PTRCS_APLDOM_0200 * 012300****************************************************************** 012400 01 DCLPTRCS-APLDOM-0200. 012500 10 NAME PIC X(8). 012600 10 DB2ID PIC X(4). 012700 10 DEPT PIC X(8). 012800 10 QUALIFIER PIC X(8). 012900 10 OBJNAME. 013000 49 OBJNAME-LEN PIC S9(4) USAGE COMP. 013100 49 OBJNAME-TEXT PIC X(18). 013200 10 OBJTYPE PIC X(2). 013300 10 UPDATE-USER PIC X(8). 013400 10 UPDATE-DATE PIC X(10). 013500 10 IMPLEMENTED PIC X(26). 013600 10 AUTHS. 013700 49 AUTHS-LEN PIC S9(4) USAGE COMP. 013800 49 AUTHS-TEXT PIC X(25). 013900 10 PENDING. 014000 49 PENDING-LEN PIC S9(4) USAGE COMP. 014100 49 PENDING-TEXT PIC X(25). 014200****************************************************************** 014300* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 11 * 014400****************************************************************** 014500 10 CREATEDBY PIC X(8). 014600****************************************************************** 014700* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 36 * 014800****************************************************************** 014900 015000****************************************************************** 015100* DCLGEN TABLE(PTI.PTRCS_USRDOM_0200) * 018000* LIBRARY(D@UDAL.STR.COPYLIB(PLATUDOM)) * 015300* ACTION(REPLACE) * 015400* APOST * 015500* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 015600****************************************************************** 015700 EXEC SQL DECLARE PTI.PTRCS_USRDOM_0200 TABLE 015800 ( NAME CHAR(8) NOT NULL, 015900 DB2ID CHAR(4) NOT NULL, 016000 DEPT CHAR(8) NOT NULL, 016100 AUTHID CHAR(8) NOT NULL, 016200 DESCRIPTION VARCHAR(25) NOT NULL, 016300 PENDING CHAR(1) NOT NULL, 016400 UPDATE_USER CHAR(8) NOT NULL, 016500 UPDATE_DATE DATE NOT NULL, 016600 IMPLEMENTED TIMESTAMP NOT NULL 016700 ) END-EXEC. 016800****************************************************************** 016900* COBOL DECLARATION FOR TABLE PTI.PTRCS_USRDOM_0200 * 017000****************************************************************** 017100 01 DCLPTRCS-USRDOM-0200. 017200 10 NAME PIC X(8). 017300 10 DB2ID PIC X(4). 017400 10 DEPT PIC X(8). 017500 10 AUTHID PIC X(8). 017600 10 DESCRIPTION. 017700 49 DESCRIPTION-LEN PIC S9(4) USAGE COMP. 017800 49 DESCRIPTION-TEXT PIC X(25). 017900 10 PENDING PIC X(1). 018000 10 UPDATE-USER PIC X(8). 018100 10 UPDATE-DATE PIC X(10). 018200 10 IMPLEMENTED PIC X(26). 018300****************************************************************** 018400* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 9 * 018500****************************************************************** 018600 018700/**************************************************************** 018800* DB2 CURSOR DECLARES * 018900***************************************************************** 019000 019100****************************************************************** 019200** CREATE SYNONYM CURSOR ** 019300****************************************************************** 019400 EXEC SQL DECLARE SYNONYM_CURSOR CURSOR FOR 019500 SELECT 019600 'CREATE SYNONYM ' ³³ A.OBJNAME ³³ 019700- ' FOR ' ³³ A.QUALIFIER ³³ '.' ³³ A.OBJNAME ³³ ';' 019800 FROM PTI.PTRCS_APLDOM_0200 A 022700 WHERE (NAME = :W-APPL-DOMAIN 020200 AND (OBJTYPE = 'V' OR OBJTYPE= 'T') 020200 AND OBJNAME NOT LIKE '%*') 020300 AND NOT EXISTS 020400 (SELECT * 020500 FROM SYSIBM.SYSSYNONYMS B 020600 WHERE CREATOR = :AUTHID 020700 AND B.NAME = A.OBJNAME) 020710 AND NOT EXISTS 020720 (SELECT * 020730 FROM SYSIBM.SYSTABLES C 020740 WHERE CREATOR = :AUTHID 020750 AND C.NAME = A.OBJNAME) 020800 END-EXEC. 020900****************************************************************** 021000** DROP SYNONYM CURSOR ** 021100****************************************************************** 021200 EXEC SQL DECLARE DROP_SYNONYM CURSOR FOR 021300 SELECT 'DROP SYNONYM ' ³³ NAME ³³ ';' 021400 FROM SYSIBM.SYSSYNONYMS 021500 WHERE CREATOR = :AUTHID 021600 END-EXEC. 021700****************************************************************** 021800** INPUT DRIVER CURSOR OF ALL USER ID'S ** 021900****************************************************************** 022000 EXEC SQL DECLARE ALL_USER_IDS CURSOR FOR 022100 SELECT AUTHID, 022110 DESCRIPTION 022200 FROM PTI.PTRCS_USRDOM_0200 025600 WHERE NAME = :W-USER-DOMAIN 022500 END-EXEC. 022600****************************************************************** 022700** INPUT DRIVER CURSOR FOR ONE USER ID ONLY ** 022800****************************************************************** 022900 EXEC SQL DECLARE USER_ID CURSOR FOR 022910 SELECT AUTHID, 022920 DESCRIPTION 023100 FROM PTI.PTRCS_USRDOM_0200 026500 WHERE NAME = :W-USER-DOMAIN 023400 AND AUTHID = :W-PARM-VALUE2 023500 END-EXEC. 023600/***************************************************************** 023700** L I N K A G E S E C T I O N ** 023800****************************************************************** 023900 LINKAGE SECTION. 024000 01 LINKAGE-AREA. 024100 05 L-PARM-LENGTH PIC S9(04) COMP. 024200 05 L-PARM-VALUE PIC X(100). 024300/***************************************************************** 024400** P R O C E D U R E D I V I S I O N ** 024500****************************************************************** 024600 PROCEDURE DIVISION USING LINKAGE-AREA. 024700****************************************************************** 024800** S0000-CONTROL ** 024900** THIS SECTION IS THE DRIVER WHICH CONTROLS THE PROCESSING OF ** 025000** ALL THE SECTIONS AT THE HIGHEST LEVEL AND THEN ISSUES THE ** 025100** GOBACK. ** 025200****************************************************************** 025300 S0000-CONTROL SECTION. 025400 025500 PERFORM S1000-INITIALIZATION. 025600 025700 PERFORM S2000-MAIN-PROCESS 029000 UNTIL S-END-OF-FILE-INPUT 025801 OR W-BAD-PARM. 025900 026000 PERFORM S3000-FINALIZATION. 026100 026200 S0000-EXIT. 026300 EXIT. 026400/***************************************************************** 026500** S1000-INITIALIZATION ** 026600** THIS SECTION PERFORMS INITIALIZATION FUNCTIONS. THOSE ** 026700** INCLUDE OPENING THE VARIABLE FILE, DOING A PRIMING FETCH, ** 026800** AND SETTING THE ISPF ERROR ENCOUNTER RESPONSE TO "RETURN". ** 026900****************************************************************** 027000 S1000-INITIALIZATION SECTION. 027100 027200 IF L-PARM-LENGTH > +0 027300 UNSTRING L-PARM-VALUE DELIMITED BY ALL SPACES OR 027310 ALL LOW-VALUES 027400 INTO W-PARM-VALUE1 027500 W-PARM-VALUE2 027510 W-PARM-VALUE3 027600 END-UNSTRING 028000 ELSE 028100 DISPLAY "*** NOTE: DEFAULT PROCESS OPTIONS USED ***" 028200 SET W-THIS-IS-A-CREATE-REQUEST TO TRUE 028300 SET W-PROCESS-ALL-IDS TO TRUE 028310 SET W-PLATINUM-DRIVER-USED TO TRUE 028400 END-IF. 028500 028600 DISPLAY "*** PROCESS OPTIONS USED ***". 028700 DISPLAY "ACTION: " W-PARM-VALUE1. 028800 DISPLAY " ON: " W-PARM-VALUE2. 028810 DISPLAY " BY: " W-PARM-VALUE3. 028820 DISPLAY "****************************". 028900 029000 IF (NOT W-THIS-IS-A-CREATE-REQUEST AND 029100 NOT W-THIS-IS-A-DROP-REQUEST) OR 029200 (NOT W-PLATINUM-DRIVER-USED AND 029300 NOT W-DSNTIAD-USED) 029310 SET W-BAD-PARM TO TRUE 029500 ELSE 033100 OPEN INPUT INPUT-RELATE-FILE 029600 OPEN OUTPUT OUTPUT-CREATE-FILE 033300 PERFORM S4000-READ-RELATE-FILE 030000 END-IF. 030100 030200 S1000-EXIT. 030300 EXIT. 030400/***************************************************************** 030500** S2000-MAIN-PROCESS ** 030600****************************************************************** 030700 S2000-MAIN-PROCESS SECTION. 030800 034300 DISPLAY "USER DOMAIN: " W-USER-DOMAIN. 034400 DISPLAY "APPL DOMAIN: " W-APPL-DOMAIN. 034500 DISPLAY "************ ". 034600 034510 MOVE W-CREATE-RECORD TO W-HOLD-RECORD. 034511 034520 MOVE SPACES TO W-CREATE-RECORD. 034521 MOVE "--*********************************" TO W-CREATE-RECORD. 034522 PERFORM S9999-WRITE-OUTPUT-FILE. 034523 034524 MOVE SPACES TO W-CREATE-RECORD. 034530 STRING "--* USER DOMAIN: " DELIMITED BY SIZE 034540 W-USER-DOMAIN DELIMITED BY SIZE 034560 INTO W-CREATE-RECORD 034570 END-STRING. 034580 PERFORM S9999-WRITE-OUTPUT-FILE. 034581 034582 MOVE SPACES TO W-CREATE-RECORD. 034582 STRING "--* APPL DOMAIN: " DELIMITED BY SIZE 034583 W-APPL-DOMAIN DELIMITED BY SIZE 034584 INTO W-CREATE-RECORD 034585 END-STRING. 034586 PERFORM S9999-WRITE-OUTPUT-FILE. 034587 034589 MOVE SPACES TO W-CREATE-RECORD. 034590 MOVE "--*********************************" TO W-CREATE-RECORD. 034591 PERFORM S9999-WRITE-OUTPUT-FILE. 034592 034590 MOVE W-HOLD-RECORD TO W-CREATE-RECORD. 034600 034700 SET S-MORE-ROWS-TO-FETCH TO TRUE. 031100 034900 PERFORM S6000-OPEN-INPUT-CURSOR. 031300 035100 PERFORM S6100-FETCH-INPUT-ROW. 031500 035300 PERFORM S2100-MAIN-CURSOR-LOOP 035400 UNTIL S-END-OF-DB2-INPUT. 031700 035600 PERFORM S6200-CLOSE-INPUT-CURSOR. 031900 035800 PERFORM S4000-READ-RELATE-FILE. 032100 032200 S2000-EXIT. 032300 EXIT. 032400/***************************************************************** 036300** S2100-MAIN-CURSOR-LOOP ** 036400****************************************************************** 036500 S2100-MAIN-CURSOR-LOOP SECTION. 036600 036700 MOVE +0 TO SQLCODE 036800 W-FETCH-INCREMENT. 036900 037000 PERFORM S5000-OPEN-CATALOG-CURSOR. 037100 037200 PERFORM S5100-FETCH-CATALOG-ROW. 037300 037400 PERFORM S5100-FETCH-CATALOG-ROW UNTIL SQLCODE NOT = +0. 037500 037600 PERFORM S5200-CLOSE-CATALOG-CURSOR. 037700 037800 PERFORM S6100-FETCH-INPUT-ROW. 037900 038000 S2100-EXIT. 038100 EXIT. 038200/***************************************************************** 032500** S3000-FINALIZATION ** 032600****************************************************************** 032700 S3000-FINALIZATION SECTION. 032800 032900 IF NOT W-RETURN-CODE = +2000 033000 CLOSE OUTPUT-CREATE-FILE 033100 END-IF. 033200 IF W-RETURN-CODE < +0 COMPUTE W-RETURN-CODE = W-RETURN-CODE * -1 END-IF. 033200 IF W-RETURN-CODE > +0 DISPLAY "RETURN CODE = " W-RETURN-CODE 036000 IF NOT W-RETURN-CODE = +2000 039900 AND NOT SQLCODE = +0 040000 CALL "DSNTIAR" USING SQLCA, 040100 W-DSNTIAR-AREA, 040200 C-ERROR-TEXT-LEN 040300 IF RETURN-CODE = +0 THEN 040400 DISPLAY "***" 040500 DISPLAY "*** DB2 ERROR TEXT FOLLOWS" 040600 DISPLAY "***" 040700 PERFORM VARYING W-ERR-NDX 040800 FROM +1 BY +1 UNTIL W-ERR-NDX > +8 040900 DISPLAY W-ERROR-TEXT (W-ERR-NDX) 041000 END-PERFORM 041100 ELSE 041200 DISPLAY "DSNTIAR RETURN CODE = " RETURN-CODE 041210 END-IF 041220 MOVE W-RETURN-CODE TO RETURN-CODE 041300 CALL "ILBOABN0" USING RETURN-CODE END-IF. 033400 033500 GOBACK. 033600 033700 S3000-EXIT. 033800 EXIT. 033900/***************************************************************** 042100** S4000-READ-RELATE-FILE ** 042200** ** 044000****************************************************************** 042400 S4000-READ-RELATE-FILE SECTION. 044200 042600 READ INPUT-RELATE-FILE 042700 INTO W-INPUT-RECORD 042800 AT END 042900 SET S-END-OF-FILE-INPUT TO TRUE. 043000 043100 IF S-MORE-RECORDS-TO-READ 043200 ADD +1 TO A-INPUT-RECORDS-READ 043300 END-IF. 043400 043500 S4000-EXIT. 043600 EXIT. 043700/***************************************************************** 043800** S5000-OPEN-CATALOG-CURSOR. ** 043900** 1. ** 044000****************************************************************** 044100 S5000-OPEN-CATALOG-CURSOR SECTION. 044200 034500 IF W-THIS-IS-A-DROP-REQUEST 034600 EXEC SQL OPEN DROP_SYNONYM 034700 END-EXEC 034800 ELSE 034900 EXEC SQL OPEN SYNONYM_CURSOR 035000 END-EXEC 035100 END-IF. 035200 035300 EVALUATE SQLCODE 035400 035500 WHEN +0 035600 CONTINUE 035700 035800 WHEN OTHER 038700 DISPLAY "EXEC SQL CATALOG OPEN BAD SQLCODE" 036000 MOVE SQLCODE TO W-RETURN-CODE 045810 PERFORM S3000-FINALIZATION 036100 036200 END-EVALUATE. 036300 046200 S5000-EXIT. 036500 EXIT. 036600/***************************************************************** 046500** S5100-FETCH-CATALOG-ROW ** 036800** 1. ** 036900****************************************************************** 046800 S5100-FETCH-CATALOG-ROW SECTION. 037100 037200 ADD +1 TO W-FETCH-INCREMENT. 037300 037400 IF W-THIS-IS-A-DROP-REQUEST 037500 EXEC SQL FETCH DROP_SYNONYM 037600 INTO :W-CREATE-RECORD 037700 END-EXEC 037800 ELSE 037900 EXEC SQL FETCH SYNONYM_CURSOR 038000 INTO :W-CREATE-RECORD 038100 END-EXEC 038200 END-IF. 038300 038400 EVALUATE SQLCODE 038500 038600 WHEN +0 038700 IF W-FETCH-INCREMENT > +1 038800 CONTINUE 038900 ELSE 039000 MOVE W-CREATE-RECORD TO W-HOLD-RECORD 039100 MOVE SPACES TO W-CREATE-RECORD 039200 STRING "SET CURRENT SQLID = '" DELIMITED BY SIZE 039300 AUTHID DELIMITED BY SPACE 039400 "';" DELIMITED BY SIZE 039500 INTO W-CREATE-RECORD 039600 END-STRING 039700 PERFORM S9999-WRITE-OUTPUT-FILE 039800 MOVE W-HOLD-RECORD TO W-CREATE-RECORD 039900 END-IF 040000 PERFORM S9999-WRITE-OUTPUT-FILE 040100 040200 WHEN +100 040300 IF W-FETCH-INCREMENT = +1 040400 MOVE SPACES TO W-CREATE-RECORD 040500 STRING "-- NO SYNONYMS TO PROCESS FOR: " 040510 DELIMITED BY SIZE 040600 AUTHID DELIMITED BY SPACES 040610 "-" DELIMITED BY SIZE 040700 DESCRIPTION-TEXT DELIMITED BY LOW-VALUES 040800 INTO W-CREATE-RECORD 040900 END-STRING 041000 PERFORM S9999-WRITE-OUTPUT-FILE 041100 END-IF 041200 041300 WHEN OTHER 044600 DISPLAY "EXEC SQL CATALOG FETCH BAD SQLCODE" 041500 MOVE SQLCODE TO W-RETURN-CODE 051510 PERFORM S3000-FINALIZATION 041600 041700 END-EVALUATE. 041800 051900 S5100-EXIT. 042000 EXIT. 042100/***************************************************************** 052200** S5200-CLOSE-CATALOG-CURSOR ** 042300** 1. ** 042400****************************************************************** 052500 S5200-CLOSE-CATALOG-CURSOR SECTION. 042600 042700 IF W-THIS-IS-A-DROP-REQUEST 042800 EXEC SQL CLOSE DROP_SYNONYM 042900 END-EXEC 043000 ELSE 043100 EXEC SQL CLOSE SYNONYM_CURSOR 043200 END-EXEC 043300 END-IF. 043400 043500 EVALUATE SQLCODE 043600 043700 WHEN +0 043800 IF W-FETCH-INCREMENT > +1 043900 ADD 5 TO W-SYNC-INCREMENT 044000 MOVE SPACES TO W-CREATE-RECORD 044010 IF W-PLATINUM-DRIVER-USED 044100 STRING ".SYNC " DELIMITED BY SIZE 044200 W-SYNC-INCREMENT DELIMITED BY SIZE 044300 " 'USER: " DELIMITED BY SIZE 044310 AUTHID DELIMITED BY SPACES 044320 "-" DELIMITED BY SIZE 044340 DESCRIPTION-TEXT 044350 DELIMITED BY LOW-VALUES 044500 "'" DELIMITED BY SIZE 044600 INTO W-CREATE-RECORD 044700 END-STRING 044710 ELSE 044711 MOVE "COMMIT;" TO W-CREATE-RECORD 044720 END-IF 044800 PERFORM S9999-WRITE-OUTPUT-FILE 044900 END-IF 045000 045100 WHEN OTHER 049300 DISPLAY "EXEC SQL CATALOG CLOSE BAD SQLCODE" 045300 MOVE SQLCODE TO W-RETURN-CODE 056010 PERFORM S3000-FINALIZATION 045400 045500 END-EVALUATE. 045600 056400 S5200-EXIT. 045800 EXIT. 045900/***************************************************************** 056700** S6000-OPEN-INPUT-CURSOR ** 046100** 1. ** 046200****************************************************************** 057000 S6000-OPEN-INPUT-CURSOR SECTION. 046400 046500 IF W-PROCESS-ALL-IDS 046600 EXEC SQL OPEN ALL_USER_IDS 046700 END-EXEC 046800 ELSE 046900 EXEC SQL OPEN USER_ID 047000 END-EXEC 047100 END-IF. 047200 047300 EVALUATE SQLCODE 047400 047500 WHEN +0 047600 CONTINUE 047700 047800 WHEN OTHER 052200 DISPLAY "EXEC SQL INPUT OPEN BAD SQLCODE" 058610 MOVE SQLCODE TO W-RETURN-CODE 058620 PERFORM S3000-FINALIZATION 048000 048100 END-EVALUATE. 048200 059000 S6000-EXIT. 048400 EXIT. 048500/***************************************************************** 059300** S6100-FETCH-INPUT-ROW ** 048700****************************************************************** 059500 S6100-FETCH-INPUT-ROW SECTION. 048900 048910 INITIALIZE DCLPTRCS-USRDOM-0200. 048920 049000 IF W-PROCESS-ALL-IDS 049100 EXEC SQL FETCH ALL_USER_IDS 049101 INTO :AUTHID, 049102 :DESCRIPTION 049110 END-EXEC 049120 ELSE 049130 EXEC SQL FETCH USER_ID 049131 INTO :AUTHID, 049132 :DESCRIPTION 049140 END-EXEC 049150 END-IF. 049170 049172 ADD +1 TO A-INPUT-ROWS-FETCHED. 049198 049199 EVALUATE SQLCODE 049200 049210 WHEN +0 049230 CONTINUE 049297 049298 WHEN +100 061900 SET S-END-OF-DB2-INPUT TO TRUE 049308 049309 WHEN OTHER 056100 DISPLAY "EXEC SQL INPUT FETCH BAD SQLCODE" 049311 MOVE SQLCODE TO W-RETURN-CODE 062310 PERFORM S3000-FINALIZATION 049312 049313 END-EVALUATE. 049400 062700 S6100-EXIT. 049600 EXIT. 049700/***************************************************************** 063000** S6200-CLOSE-INPUT-CURSOR ** 049900** 1. ** 050000****************************************************************** 063300 S6200-CLOSE-INPUT-CURSOR SECTION. 050200 050300 IF W-PROCESS-ALL-IDS 050400 EXEC SQL CLOSE ALL_USER_IDS 050500 END-EXEC 050600 ELSE 050700 EXEC SQL CLOSE USER_ID 050800 END-EXEC 050900 END-IF. 051000 051100 EVALUATE SQLCODE 051200 051300 WHEN +0 051400 IF A-NO-ROWS-FETCHED 051500 MOVE +2001 TO W-RETURN-CODE 051600 DISPLAY "NO INPUT ROWS SELECTED TO PROCESS" 052600 END-IF 052700 052800 WHEN OTHER 059300 DISPLAY "EXEC SQL INPUT CLOSE BAD SQLCODE" 053000 MOVE SQLCODE TO W-RETURN-CODE 065310 PERFORM S3000-FINALIZATION 053100 053200 END-EVALUATE. 053300 065700 S6200-EXIT. 053500 EXIT. 053600/***************************************************************** 053700** S9999-WRITE-OUTPUT-FILE ** 053800** 1. ** 053900****************************************************************** 054000 S9999-WRITE-OUTPUT-FILE SECTION. 054100 054200 WRITE OUTPUT-CREATE-RECORD FROM W-CREATE-RECORD. 054300 054400 S9999-EXIT. 054500 EXIT. ./ ADD NAME=GENUID 000100 IDENTIFICATION DIVISION. GENUID 000200 PROGRAM-ID. GENUID. GENUID 000300******************************************************************GENUID 000400 AUTHOR. UNIPAC SERVICE CORPORATION. GENUID 000500 DATE-WRITTEN. MAY 1996. GENUID 000600 DATE-COMPILED. GENUID 000700******************************************************************GENUID 000800** PROGRAM DOCUMENTATION: **GENUID 000801** THIS SUBROUTINE WILL GENERATE A 6 BYTE ALPHANUMERIC VALUE **GENUID 000802** BASED ON THE SYSTEM TIMESTAMP THAT WILL BE USED TO POPULATE **GENUID 000803** THE "INCREMENTAL COUNTER" FIELD OF THE COMMONLINE UNIQUE ID **GENUID 000804** TABLE. **GENUID 000900******************************************************************GENUID 000810**--------------------------------------------------------------**GENUID 000820**-------------------------- REVISIONS -----------------------**GENUID 000830**--------------------------------------------------------------**GENUID 000840** PR NBR ³ PRD DATE ³ VERSION ³ PROGRAMMER **GENUID 000841**--------------------------------------------------------------**GENUID 000850** A22647 ³ 96/09/13 ³ 1.00 ³ M.E.FOX **GENUID 000851**--------------------------------------------------------------**GENUID 000860** ³ COMMONLINE EFT IMPLEMENTATION - ORIGINAL INSTALL **GENUID 002110**--------------------------------------------------------------**GENUID 002120** A23922 ³ 97/12/05 ³ 1.01 ³ AL MACDONALD **ODA23922 002140**--------------------------------------------------------------**ODA23922 002150** ³ COMMONLINE RESPONSE FILE PROJECT - ADDED BETTER **ODA23922 002160** ³ ERROR CHECKING. **ODA23922 002700**--------------------------------------------------------------**WDA24057 002800** A24057 ³ 97/12/23 ³ 1.02 ³ DAVID WEAVER (EMER) **WDA24057 002900**--------------------------------------------------------------**WDA24057 003000** ³ PROVIDE VALID UNIQUE IDENTIFIER TO THE CALLING **WDA24057 003100** ³ PROGRAM BY USING A THE DE DEFINED SERVICER ID IN **WDA24057 003200** ³ THE PARTY-ID FIELD. **WDA24057 003210**--------------------------------------------------------------**WDA24057 003220** A24057 ³ 98/02/06 ³ 1.02 ³ DAVID WEAVER **WDA24057 003230**--------------------------------------------------------------**WDA24057 003240** ³ MOVE FROM EMER TO PROD. **WDA24057 000900******************************************************************GENUID 000910** PROGRAM TITLE: **GENUID 000911** GENERATE COMMONLINE INCREMENTAL COUNTER AND UPDATE THE **GENUID 000920** COMMONLINE UNIQUE ID TABLE AS INDICATED. **GENUID 000921** **GENUID 000930** PROGRAM FUNCTION: **GENUID 000940** THIS SUBROUTINE WILL GENERATE A 6 BYTE ALPHANUMERIC VALUE, **GENUID 000941** BASED ON THE SYSTEM TIMESTAMP, THAT WILL BE USED TO POPULATE **GENUID 000942** THE "INCREMENTAL COUNTER" FIELD OF THE COMMONLINE UNIQUE ID **GENUID 000943** TABLE. **GENUID 000944** **GENUID 000950** PROGRAM FLOW: **GENUID 000951** **GENUID 000952** DRIVER FILES: **GENUID 000953** **GENUID 000954** FILES ACCESSED: **GENUID 000955** **GENUID 000956** DB2 TABLES ACCESSED: **GENUID 000957** NTE15R01 **GENUID 000958** **GENUID 000959** SOURCE COPYBOOKS: **GENUID 000960** NONE **GENUID 000961** **GENUID 000962** CONTROL CARD DESCRIPTION: **GENUID 000963** **GENUID 000964** CALLED MODULES: **GENUID 000965** NONE **GENUID 000966** **GENUID 000967** PROGRAM NOTES: **GENUID 005100** THIS PROGRAM WAS NOT USED UPON ITS ORIGINAL INSTALL, NOW IS **GENUID 005200** USED BY LOB0630 FOR THE COMMONLINE RESPONSE FILE PROJECT. **GENUID 000980******************************************************************GENUID 001000 ENVIRONMENT DIVISION. GENUID 001100 CONFIGURATION SECTION. GENUID 001200 SPECIAL-NAMES. C01 IS TOP-OF-PAGE. GENUID 001300 INPUT-OUTPUT SECTION. GENUID 001400 FILE-CONTROL. GENUID 001500******************************************************************GENUID 001600 DATA DIVISION. GENUID 001700 FILE SECTION. GENUID 001800 WORKING-STORAGE SECTION. GENUID 007301 01 A-STANDARD-PROGRAM-ID PIC X(26) VALUE WDA24057 007310 'UNIPAC/GENUID /980206-1.02'. WDA24057 001900 01 MISC-STUFF. GENUID 002000 05 DUMMY-VALUE PIC 9(07). GENUID 002100 05 SUCCESSFUL-UPDATE-FLAG PIC X(01) VALUE 'N'. GENUID 006710 05 FLG-UNIQUE PIC X(01) VALUE 'N'. ODA23922 006720 05 FLG-DB2-ERROR PIC X(01) VALUE 'N'. ODA23922 002200 01 TIMESTAMP-AREA. GENUID 002300 05 H-DB2-TIMESTAMP PIC X(26). GENUID 002400 05 THIS REDEFINES H-DB2-TIMESTAMP. GENUID 002500 10 FILLER PIC X(20). GENUID 002600 10 WS-MICROSECONDS PIC 9(06). GENUID 002700 01 ALPHANUMERIC-VALUES-TABLE. GENUID 002800 05 FILLER PIC X(01) VALUE '0'. GENUID 002900 05 FILLER PIC X(01) VALUE '1'. GENUID 003000 05 FILLER PIC X(01) VALUE '2'. GENUID 003100 05 FILLER PIC X(01) VALUE '3'. GENUID 003200 05 FILLER PIC X(01) VALUE '4'. GENUID 003300 05 FILLER PIC X(01) VALUE '5'. GENUID 003400 05 FILLER PIC X(01) VALUE '6'. GENUID 003500 05 FILLER PIC X(01) VALUE '7'. GENUID 003600 05 FILLER PIC X(01) VALUE '8'. GENUID 003700 05 FILLER PIC X(01) VALUE '9'. GENUID 003800 05 FILLER PIC X(01) VALUE 'A'. GENUID 003900 05 FILLER PIC X(01) VALUE 'B'. GENUID 004000 05 FILLER PIC X(01) VALUE 'C'. GENUID 004100 05 FILLER PIC X(01) VALUE 'D'. GENUID 004200 05 FILLER PIC X(01) VALUE 'E'. GENUID 004300 05 FILLER PIC X(01) VALUE 'F'. GENUID 004400 05 FILLER PIC X(01) VALUE 'G'. GENUID 004500 05 FILLER PIC X(01) VALUE 'H'. GENUID 004600 05 FILLER PIC X(01) VALUE 'I'. GENUID 004700 05 FILLER PIC X(01) VALUE 'J'. GENUID 004800 05 FILLER PIC X(01) VALUE 'K'. GENUID 004900 05 FILLER PIC X(01) VALUE 'L'. GENUID 005000 05 FILLER PIC X(01) VALUE 'M'. GENUID 005100 05 FILLER PIC X(01) VALUE 'N'. GENUID 005200 05 FILLER PIC X(01) VALUE 'O'. GENUID 005300 05 FILLER PIC X(01) VALUE 'P'. GENUID 005400 05 FILLER PIC X(01) VALUE 'Q'. GENUID 005500 05 FILLER PIC X(01) VALUE 'R'. GENUID 005600 05 FILLER PIC X(01) VALUE 'S'. GENUID 005700 05 FILLER PIC X(01) VALUE 'T'. GENUID 005800 05 FILLER PIC X(01) VALUE 'U'. GENUID 005900 05 FILLER PIC X(01) VALUE 'V'. GENUID 006000 05 FILLER PIC X(01) VALUE 'W'. GENUID 006100 05 FILLER PIC X(01) VALUE 'X'. GENUID 006200 05 FILLER PIC X(01) VALUE 'Y'. GENUID 006300 05 FILLER PIC X(01) VALUE 'Z'. GENUID 006500 01 ALPHANUMERIC-VALUES-TABLE-RED REDEFINES GENUID 006600 ALPHANUMERIC-VALUES-TABLE. GENUID 006700 05 ALPHANUMERIC-VALUE PIC X(01) OCCURS 36 TIMES. GENUID 006900 01 ALPHANUMERIC-TABLE-SUB PIC 9(02) COMP-3. GENUID 007100 01 UNIQUE-ID-TABLE. GENUID 007200 05 FILLER PIC X(01) VALUE SPACES. GENUID 007300 05 FILLER PIC X(01) VALUE SPACES. GENUID 007400 05 FILLER PIC X(01) VALUE SPACES. GENUID 007500 05 FILLER PIC X(01) VALUE SPACES. GENUID 007600 05 FILLER PIC X(01) VALUE SPACES. GENUID 007700 05 FILLER PIC X(01) VALUE SPACES. GENUID 007900 01 UNIQUE-ID-TABLE-RED REDEFINES UNIQUE-ID-TABLE. GENUID 008000 05 UNIQUE-ID-TABLE-VALUE PIC X(01) OCCURS 6 TIMES. GENUID 008200 01 UNIQUE-ID-TABLE-RED2 REDEFINES UNIQUE-ID-TABLE-RED. GENUID 008300 05 UNIQUE-ID-VALUE PIC X(06). GENUID 008600 01 UNIQUE-ID-TABLE-SUB PIC 9(02) COMP-3. GENUID 008800 01 UNIQUE-ID-AREA PIC X(06). GENUID 012601 01 HLD-UNIQUE-ID. ODA23922 012602 05 HLD-UNIQUE-PARTY-ID PIC X(06). ODA23922 012603 05 HLD-UNIQUE-PARTY-BR PIC X(04). ODA23922 014200 05 HLD-UNIQUE-SYS-ID PIC X(01). WDA24057 012610 05 HLD-UNIQUE-INCR-CNTR PIC X(06). ODA23922 012660 05 HLD-LN-SEQ-NBR PIC X(02). ODA23922 014500 01 HLD-ED-SVCR PIC X(06). WDA24057 014600 01 HLD-LOAN-SEQ-NBR PIC X(02). WDA24057 008900******************************************************************GENUID 009000*DB2/SQL COMMUNICATION AREA GENUID 009100 EXEC SQL GENUID 009200 INCLUDE SQLCA GENUID 009300 END-EXEC. GENUID 009400******************************************************************GENUID 009500*DB2/SQL TIMESTAMP INFORMATION GENUID 009600 EXEC SQL GENUID 009700 INCLUDE UTL20R02 GENUID 009800 END-EXEC. GENUID 009900******************************************************************GENUID 010500* COMMONLINE TABLES GENUID 010600******************************************************************GENUID 010700 EXEC SQL GENUID 010800 INCLUDE NTE15R01 GENUID 010900 END-EXEC. GENUID 011300******************************************************************GENUID 011400 LINKAGE SECTION. GENUID 017500 COPY GENUIDLK. WDA24057 017510 WDA24057 017520*DB2/SQL GLOBAL ERROR RECORDS WDA24057 017530 EXEC SQL WDA24057 017540 INCLUDE EP00D01 WDA24057 017550 END-EXEC. WDA24057 017551 WDA24057 017560 EXEC SQL WDA24057 017570 INCLUDE EP00D02 WDA24057 017580 END-EXEC. WDA24057 011800******************************************************************GENUID 017700 PROCEDURE DIVISION USING GEN-UNIQUE-ID-LINK EP00D01 EP00D02. WDA24057 012000******************************************************************GENUID 012100 A000-MAINLINE-ROUTINE SECTION. GENUID 018000 IF GEN-UNIQUE-PROCESSING-PARM NOT = 'AU' WDA24057 015810 GO TO A101-EXIT-PROGRAM ODA23922 015811 END-IF. ODA23922 018300 MOVE 'N' TO SUCCESSFUL-UPDATE-FLAG. WDA24057 015812 MOVE 'N' TO FLG-UNIQUE. ODA23922 018500 MOVE GEN-UNIQUE-PARTY-ID TO HLD-ED-SVCR. WDA24057 018600 MOVE GEN-UNIQUE-LOAN-SEQ-NBR TO HLD-LOAN-SEQ-NBR. WDA24057 015813 PERFORM B100-DO-UID UNTIL FLG-UNIQUE = 'Y'. ODA23922 015814 IF FLG-DB2-ERROR NOT = 'Y' ODA23922 016403 PERFORM B300-UPDATE-UID-TABLE. ODA23922 019700 MOVE SQLCA TO EP00-SQLCA. WDA24057 016410 A101-EXIT-PROGRAM. ODA23922 019900 GOBACK. WDA24057 013300 A000-EXIT. GENUID 016700 EXIT. ODA23922 016800******************************************************************ODA23922 016801 B100-DO-UID SECTION. ODA23922 016802 PERFORM B200-ASSIGN-UID ODA23922 016803 VARYING UNIQUE-ID-TABLE-SUB FROM 1 BY 1 ODA23922 016804 UNTIL UNIQUE-ID-TABLE-SUB > 6. ODA23922 016805 PERFORM B210-CHECK-FOR-UNIQUENESS. ODA23922 016806 B100-EXIT. ODA23922 013400 EXIT. GENUID 013500******************************************************************GENUID 013600 B200-ASSIGN-UID SECTION. GENUID 013700 PERFORM R700-SET-TIMESTAMP. GENUID 013800 DIVIDE WS-MICROSECONDS BY 36 GIVING DUMMY-VALUE GENUID 013900 REMAINDER ALPHANUMERIC-TABLE-SUB. GENUID 014000 ADD 1 TO ALPHANUMERIC-TABLE-SUB. GENUID 014100 MOVE ALPHANUMERIC-VALUE (ALPHANUMERIC-TABLE-SUB) GENUID 014200 TO UNIQUE-ID-TABLE-VALUE (UNIQUE-ID-TABLE-SUB). GENUID 014300 B200-EXIT. GENUID 014400 EXIT. GENUID 014500******************************************************************GENUID 017801 B210-CHECK-FOR-UNIQUENESS SECTION. ODA23922 017803 EXEC SQL ODA23922 017804 SELECT CL_PARTY_ID, ODA23922 017805 CL_PARTY_BR, ODA23922 017806 CL_SYS_ID, ODA23922 017807 CL_INCR_CNTR, ODA23922 017808 CL_LN_SEQ_NBR ODA23922 017809 INTO :HLD-UNIQUE-PARTY-ID, ODA23922 017810 :HLD-UNIQUE-PARTY-BR, ODA23922 017811 :HLD-UNIQUE-SYS-ID, ODA23922 017812 :HLD-UNIQUE-INCR-CNTR, ODA23922 017813 :HLD-LN-SEQ-NBR ODA23922 017814 FROM NTE15V_COMMONLINE ODA23922 023400 WHERE CL_PARTY_ID = :HLD-ED-SVCR WDA24057 017816 AND CL_PARTY_BR = '0000' ODA23922 017817 AND CL_SYS_ID = 'M' ODA23922 017818 AND CL_INCR_CNTR = :UNIQUE-ID-VALUE ODA23922 023800 AND CL_LN_SEQ_NBR = :HLD-LOAN-SEQ-NBR WDA24057 017820 END-EXEC. ODA23922 017821 ODA23922 017822 IF SQLCODE = +100 ODA23922 017823 MOVE 'Y' TO FLG-UNIQUE ODA23922 017824 GO TO B210-EXIT ODA23922 017825 ELSE ODA23922 017826 IF SQLCODE = 0 ODA23922 017829 GO TO B210-EXIT ODA23922 017830 ELSE ODA23922 017831 MOVE 'Y' TO FLG-UNIQUE ODA23922 017832 MOVE 'Y' TO FLG-DB2-ERROR ODA23922 017833 END-IF ODA23922 017834 END-IF. ODA23922 017835 B210-EXIT. ODA23922 017836 EXIT. ODA23922 017840******************************************************************ODA23922 014600 B300-UPDATE-UID-TABLE SECTION. GENUID 025600 MOVE GEN-UNIQUE-NOTE-ID TO NOTE-ID OF NTE15R01. WDA24057 025700 MOVE GEN-UNIQUE-PARTY-ID TO CL-PARTY-ID OF NTE15R01. WDA24057 025800 MOVE '0000' TO CL-PARTY-BR OF NTE15R01, WDA24057 025810 GEN-UNIQUE-PARTY-BRANCH. WDA24057 025900 MOVE 'M' TO CL-SYS-ID OF NTE15R01, WDA24057 025910 GEN-UNIQUE-SYS-ID. WDA24057 026000 MOVE UNIQUE-ID-VALUE TO CL-INCR-CNTR OF NTE15R01, WDA24057 026100 GEN-UNIQUE-INCR-CTR. WDA24057 026200 MOVE GEN-UNIQUE-LOAN-SEQ-NBR TO CL-LN-SEQ-NBR OF NTE15R01. WDA24057 026300 MOVE GEN-UNIQUE-PROGRAM-ID TO LST-UPDT-USERID OF NTE15R01. WDA24057 015400 EXEC SQL GENUID 015500 SET :H-DB2-TIMESTAMP = CURRENT TIMESTAMP GENUID 015600 END-EXEC. GENUID 015700 MOVE H-DB2-TIMESTAMP TO LST-UPDT-TMESTMP OF NTE15R01. GENUID 015800 EXEC SQL GENUID 015900 INSERT INTO NTE15V_COMMONLINE GENUID 016000 (NOTE_ID, GENUID 016100 CL_PARTY_ID, GENUID 016200 CL_PARTY_BR, GENUID 016300 CL_SYS_ID, GENUID 016400 CL_INCR_CNTR, GENUID 016500 CL_LN_SEQ_NBR, GENUID 016600 LST_UPDT_USERID, GENUID 016700 LST_UPDT_TMESTMP) GENUID 016800 VALUES GENUID 016900 (:NTE15R01.NOTE-ID, GENUID 017000 :NTE15R01.CL-PARTY-ID, GENUID 017100 :NTE15R01.CL-PARTY-BR, GENUID 017200 :NTE15R01.CL-SYS-ID, GENUID 017300 :NTE15R01.CL-INCR-CNTR, GENUID 017400 :NTE15R01.CL-LN-SEQ-NBR, GENUID 017500 :NTE15R01.LST-UPDT-USERID, GENUID 017600 :NTE15R01.LST-UPDT-TMESTMP) GENUID 017700 END-EXEC. GENUID 017900 PERFORM B305-CHECK-FOR-DUPLICATE-UID GENUID 018000 UNTIL SUCCESSFUL-UPDATE-FLAG = 'Y'. GENUID 018100 B300-EXIT. GENUID 018200 EXIT. GENUID 018300******************************************************************GENUID 018400 B305-CHECK-FOR-DUPLICATE-UID SECTION. GENUID 018600 IF SQLCODE = 0 GENUID 018700 MOVE 'Y' TO SUCCESSFUL-UPDATE-FLAG GENUID 018800 GO TO B305-EXIT. GENUID 018900 IF SQLCODE = -803 GENUID 019000 PERFORM B200-ASSIGN-UID GENUID 019100 VARYING UNIQUE-ID-TABLE-SUB FROM 1 BY 1 GENUID 019200 UNTIL UNIQUE-ID-TABLE-SUB > 6 GENUID 030100 MOVE UNIQUE-ID-VALUE TO CL-INCR-CNTR OF NTE15R01 WDA24057 030200 GEN-UNIQUE-INCR-CTR WDA24057 019300 EXEC SQL GENUID 019400 INSERT INTO NTE15V_COMMONLINE GENUID 019500 (NOTE_ID, GENUID 019600 CL_PARTY_ID, GENUID 019700 CL_PARTY_BR, GENUID 019800 CL_SYS_ID, GENUID 019900 CL_INCR_CNTR, GENUID 020000 CL_LN_SEQ_NBR, GENUID 020100 LST_UPDT_USERID, GENUID 020200 LST_UPDT_TMESTMP) GENUID 020300 VALUES GENUID 020400 (:NTE15R01.NOTE-ID, GENUID 020500 :NTE15R01.CL-PARTY-ID, GENUID 020600 :NTE15R01.CL-PARTY-BR, GENUID 020700 :NTE15R01.CL-SYS-ID, GENUID 020800 :NTE15R01.CL-INCR-CNTR, GENUID 020900 :NTE15R01.CL-LN-SEQ-NBR, GENUID 021000 :NTE15R01.LST-UPDT-USERID, GENUID 021100 :NTE15R01.LST-UPDT-TMESTMP) GENUID 021200 END-EXEC GENUID 021300 ELSE GENUID 024500 MOVE 'Y' TO SUCCESSFUL-UPDATE-FLAG ODA23922 024510 END-IF. ODA23922 021500 B305-EXIT. GENUID 021600 EXIT. GENUID 021700******************************************************************GENUID 021800 R700-SET-TIMESTAMP SECTION. GENUID 021900 EXEC SQL GENUID 022000 SET :H-DB2-TIMESTAMP = CURRENT TIMESTAMP GENUID 022100 END-EXEC. GENUID 022300 R700-EXIT. GENUID 022400 EXIT. GENUID ./ ADD NAME=GETDOW 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. TSTDOWN. 000300 AUTHOR. C BREHM. 000400 DATE-WRITTEN. 000500 DATE-COMPILED. 000600****************************************************************** 000700 ENVIRONMENT DIVISION. 000800****************************************************************** 000900 CONFIGURATION SECTION. 001000****************************************************************** 001100 INPUT-OUTPUT SECTION. 001200****************************************************************** 001300 FILE-CONTROL. 001400 SELECT CARD-FILE 001500 ASSIGN TO SYS010-UR-2520R-S-CARDFIL. 001600****************************************************************** 001700 DATA DIVISION. 001800****************************************************************** 001900 FILE SECTION. 002000 FD CARD-FILE 002100 LABEL RECORDS ARE OMITTED 002200 RECORD CONTAINS 80 CHARACTERS 002300 RECORDING MODE IS F 002400 BLOCK CONTAINS 0 RECORDS 002500 DATA RECORD IS CARD-RECORD. 002600 01 CARD-RECORD PIC X(80). 002700****************************************************************** 002800 WORKING-STORAGE SECTION. 002900 01 FLAGS-WORK-AREAS. 003000 05 EOF-CARD-FLAG PIC X(01) VALUE 'N'. 003010 05 LEAP-FLAG PIC X(01) VALUE 'N'. 003020 05 PRE-GREGORIAN-FLAG PIC X(01) VALUE 'N'. 003100 01 STORAGE-AREAS. 003200 05 THE-DATE. 003300 10 MONTH PIC 9(02) VALUE 0. 003400 10 THE-DAY PIC 9(02) VALUE 0. 003500 10 YEAR PIC 9(04) VALUE 0. 003600 10 THE-YEAR REDEFINES YEAR. 003700 15 CENTURY PIC 9(02). 003800 15 DECADE PIC 9(02). 004300 05 RANGE PIC 9(02) VALUE 0. 004400 05 DAY-OF-THE-WEEK PIC 9(02) VALUE 0. 004410 05 FINAL-DOW PIC 9(02) VALUE 0. 004420 05 START-DOW PIC 9(02) VALUE 0. 004421 05 START-DOM PIC 9(02) VALUE 0. 004422 05 DOM PIC 9(02) VALUE 0. 004430 05 ADDON PIC 9(02) VALUE 0. 004431 05 HOLD-DECADE PIC 9(02) VALUE 0. 004440 05 MM-SUB PIC 9(02) VALUE 0. 004450 05 C-POS PIC 9(01) VALUE 0. 004460 05 D-POS PIC 9(01) VALUE 0. 004500 05 DIFF PIC S9(02) VALUE +0. 004700 05 P-DAY PIC X(03) VALUE SPACES. 004710 05 P-JUL PIC X(03) VALUE SPACES. 006000 05 MULTIPLIER PIC S9(03)V9(02) VALUE 0. 006100 05 MULT REDEFINES MULTIPLIER. 006200 10 MULT-WHOLE PIC S9(03). 006300 10 MULT-TENTHS PIC 9(02). 006400 05 JUL-DAYS PIC 9(03) VALUE 0. 006900 01 MONTH-TABLE-VALUES PIC X(36) VALUE 007000 '000031059090120151181212243273304334'. 007100 01 MONTH-TABLE-DAYS REDEFINES MONTH-TABLE-VALUES. 007200 05 MONTH-DAYS PIC 9(03) OCCURS 12 TIMES. 007210 01 MONTH-POSITION-VALUES PIC X(14) VALUE 007220 '14472573614673'. 007230 01 MONTH-POS-TABLE REDEFINES MONTH-POSITION-VALUES. 007240 05 MONTH-POS PIC 9(01) OCCURS 14 TIMES. 007250 01 CALENDAR-TABLE-VALUES. 007251 05 CLDR-HORZ. 007260 10 FILLER PIC X(07) VALUE '7123456'. 007270 10 FILLER PIC X(07) VALUE '6712345'. 007280 10 FILLER PIC X(07) VALUE '5671234'. 007290 10 FILLER PIC X(07) VALUE '4567123'. 007291 10 FILLER PIC X(07) VALUE '3456712'. 007292 10 FILLER PIC X(07) VALUE '2345671'. 007293 10 FILLER PIC X(07) VALUE '1234567'. 007294 05 CLDR-POSITION-HORZ REDEFINES CLDR-HORZ OCCURS 7 TIMES. 007296 10 CLDR-POSITION-VERT OCCURS 7 TIMES. 007297 15 CLDR-TABLE-ELEMENT 007298 PIC 9(01). 007300 01 CARD-REC. 007400 05 CARD-DATE. 007500 10 CARD-MM PIC X(02). 007600 10 FILLER PIC X(01). 007700 10 CARD-DD PIC X(02). 007800 10 FILLER PIC X(01). 007900 10 CARD-YY PIC X(04). 008000 05 FILLER PIC X(70). 008200****************************************************************** 008300 PROCEDURE DIVISION. 008400****************************************************************** 008500 A000-MAIN-CONTROL SECTION. 008600 PERFORM A100-OPEN-FILE. 008700 PERFORM R100-READ-CARD-FILE. 008800 PERFORM B100-PROCESS 008900 UNTIL EOF-CARD-FLAG = 'Y'. 009000 A007-END-OF-JOB. 009100 PERFORM Z000-END-OF-JOB. 009200 STOP RUN. 009300 A009-EXIT. 009400 EXIT. 009500****************************************************************** 009600 A100-OPEN-FILE SECTION. 009700 OPEN INPUT CARD-FILE. 009800 A109-EXIT. 009900 EXIT. 010000****************************************************************** 010100 B100-PROCESS SECTION. 010200 MOVE CARD-MM TO MONTH. 010300 MOVE CARD-DD TO THE-DAY. 010400 MOVE CARD-YY TO YEAR. 010500 PERFORM B300-FIND-START-DOW. 010510 PERFORM B120-FIND-START-DOM. 010610 IF (THE-DAY = 01) 010620 COMPUTE FINAL-DOW = (START-DOW + START-DOM) - 1 010630 ELSE 010640 MOVE 1 TO DOM 010650 COMPUTE ADDON = (7 - START-DOM) + 1 010660 PERFORM UNTIL DOM + ADDON > THE-DAY 010670 ADD 7 TO DOM 010680 END-PERFORM 010690 COMPUTE DIFF = THE-DAY - DOM 010691 COMPUTE FINAL-DOW = (START-DOW + START-DOM + DIFF) - 1. 010692 IF (FINAL-DOW > 7) 010693 PERFORM UNTIL FINAL-DOW < 8 010694 SUBTRACT 7 FROM FINAL-DOW 010695 END-PERFORM. 010700 PERFORM B110-GET-JULIAN. 010710 MOVE FINAL-DOW TO DAY-OF-THE-WEEK. 010800 PERFORM B200-FIND-DAY. 010810 MOVE JUL-DAYS TO P-JUL. 010900 DISPLAY 'DATE=' CARD-DATE ' DOW=' P-DAY ' JUL=' P-JUL. 011000 PERFORM R100-READ-CARD-FILE. 011100 B109-EXIT. 011200 EXIT. 011300****************************************************************** 011400 B110-GET-JULIAN SECTION. 011401 MOVE MONTH-DAYS (MONTH) TO JUL-DAYS. 011431 IF (JUL-DAYS > 59) 011432 AND (LEAP-FLAG = 'Y') 011440 ADD 1 TO JUL-DAYS. 012200 ADD THE-DAY TO JUL-DAYS. 012300 B119-EXIT. 012400 EXIT. 012500****************************************************************** 012510 B120-FIND-START-DOM SECTION. 012520 PERFORM B130-FIND-LEAP-YEAR. 012521 IF (LEAP-FLAG = 'Y') 012522 AND (MONTH = 01 OR 02) 012523 EVALUATE MONTH 012524 WHEN 01 012525 MOVE 13 TO MM-SUB 012526 WHEN 02 012527 MOVE 14 TO MM-SUB 012528 END-EVALUATE 012529 ELSE 012530 MOVE MONTH TO MM-SUB. 012531 MOVE MONTH-POS (MM-SUB) TO START-DOM. 012532 B129-EXIT. 012540 EXIT. 012550****************************************************************** 012560 B130-FIND-LEAP-YEAR SECTION. 012561 MOVE 'N' TO LEAP-FLAG. 012562 IF (DECADE = 00) 012563 COMPUTE MULTIPLIER = CENTURY / 4 012564 IF (MULT-TENTHS = 0) 012565 MOVE 'Y' TO LEAP-FLAG 012566 END-IF 012567 ELSE 012568 COMPUTE MULTIPLIER = YEAR / 4 012569 IF (MULT-TENTHS = 0) 012570 MOVE 'Y' TO LEAP-FLAG 012571 END-IF 012572 END-IF. 012573 B139-EXIT. 012580 EXIT. 012590****************************************************************** 012600 B200-FIND-DAY SECTION. 012700 IF (DAY-OF-THE-WEEK = 1) 012800 MOVE 'MON' TO P-DAY 012900 GO TO B209-EXIT. 013000 IF (DAY-OF-THE-WEEK = 2) 013100 MOVE 'TUE' TO P-DAY 013200 GO TO B209-EXIT. 013300 IF (DAY-OF-THE-WEEK = 3) 013400 MOVE 'WED' TO P-DAY 013500 GO TO B209-EXIT. 013600 IF (DAY-OF-THE-WEEK = 4) 013700 MOVE 'THU' TO P-DAY 013800 GO TO B209-EXIT. 013900 IF (DAY-OF-THE-WEEK = 5) 014000 MOVE 'FRI' TO P-DAY 014100 GO TO B209-EXIT. 014200 IF (DAY-OF-THE-WEEK = 6) 014300 MOVE 'SAT' TO P-DAY 014400 GO TO B209-EXIT. 014500 IF (DAY-OF-THE-WEEK = 7) 014600 MOVE 'SUN' TO P-DAY 014700 GO TO B209-EXIT. 014800 DISPLAY 'DAY OF WEEK OUT-OF-RANGE ' CARD-DATE. 014900 B209-EXIT. 015000 EXIT. 015100****************************************************************** 015200 B300-FIND-START-DOW SECTION. 015300 PERFORM B310-FIND-CENTURY. 015400 PERFORM B330-FIND-DECADE. 015500 MOVE CLDR-TABLE-ELEMENT (C-POS D-POS) TO START-DOW. 015600 B309-EXIT. 015700 EXIT. 015800****************************************************************** 015900 B310-FIND-CENTURY SECTION. 015910 MOVE 'N' TO PRE-GREGORIAN-FLAG. 016000 IF (YEAR < 1582) 016100 MOVE 'Y' TO PRE-GREGORIAN-FLAG 016200 ELSE 016300 IF (THE-DATE < 10151582) 016400 PERFORM B320-ADJUST-TO-JULIAN 016500 END-IF 016600 END-IF. 016610 IF (CENTURY = 05 OR 12 OR 16 OR 20 OR 24 OR 28) 016620 MOVE 1 TO C-POS 016630 GO TO B319-EXIT. 016640 IF (CENTURY = 06 OR 13) 016650 MOVE 2 TO C-POS 016660 GO TO B319-EXIT. 016670 IF (CENTURY = 00 OR 07 OR 14 OR 17 OR 21 OR 25) 016680 MOVE 3 TO C-POS 016690 GO TO B319-EXIT. 016691 IF (CENTURY = 01 OR 08) 016692 OR ((CENTURY = 15) 016693 AND (PRE-GREGORIAN-FLAG = 'Y')) 016694 MOVE 4 TO C-POS 016695 GO TO B319-EXIT. 016696 IF (CENTURY = 02 OR 09 OR 18 OR 22 OR 26) 016697 MOVE 5 TO C-POS 016698 GO TO B319-EXIT. 016699 IF (CENTURY = 03 OR 10) 016700 MOVE 6 TO C-POS 016701 GO TO B319-EXIT. 016702 IF (CENTURY = 04 OR 11 OR 19 OR 23 OR 27) 016703 OR ((CENTURY = 15) 016704 AND (PRE-GREGORIAN-FLAG = 'N')) 016705 MOVE 7 TO C-POS 016706 GO TO B319-EXIT. 016707 DISPLAY '***CENTURY OF INPUT DATE OUT-OF-RANGE'. 016708 CALL 'CANCEL'. 016710 B319-EXIT. 016800 EXIT. 016900****************************************************************** 017000 B320-ADJUST-TO-JULIAN SECTION. 017100 IF (MONTH NOT = 10) 017200 MOVE 'Y' TO PRE-GREGORIAN-FLAG 017210 ELSE 017300 IF (THE-DAY < 05) 017400 MOVE 'Y' TO PRE-GREGORIAN-FLAG 017500 ELSE 017501 ADD 10 TO THE-DAY 017510 END-IF 017520 END-IF. 017700 B329-EXIT. 017800 EXIT. 017900****************************************************************** 018000 B330-FIND-DECADE SECTION. 018004 IF (DECADE > 27) 018005 COMPUTE MULTIPLIER = DECADE / 28 018006 COMPUTE RANGE = MULT-WHOLE * 28 018007 COMPUTE HOLD-DECADE = DECADE - RANGE 018008 ELSE 018009 MOVE DECADE TO HOLD-DECADE. 018011 IF (HOLD-DECADE = 00 OR 06 OR 17 OR 23) 018020 MOVE 1 TO D-POS 018030 GO TO B339-EXIT. 018040 IF (HOLD-DECADE = 01 OR 07 OR 12 OR 18) 018050 MOVE 2 TO D-POS 018060 GO TO B339-EXIT. 018070 IF (HOLD-DECADE = 02 OR 13 OR 19 OR 24) 018080 MOVE 3 TO D-POS 018081 GO TO B339-EXIT. 018090 IF (HOLD-DECADE = 03 OR 08 OR 14 OR 25) 018091 MOVE 4 TO D-POS 018092 GO TO B339-EXIT. 018093 IF (HOLD-DECADE = 09 OR 15 OR 20 OR 26) 018094 MOVE 5 TO D-POS 018095 GO TO B339-EXIT. 018096 IF (HOLD-DECADE = 04 OR 10 OR 21 OR 27) 018097 MOVE 6 TO D-POS 018098 GO TO B339-EXIT. 018099 IF (HOLD-DECADE = 05 OR 11 OR 16 OR 22) 018100 MOVE 7 TO D-POS 018101 GO TO B339-EXIT. 018103 DISPLAY '***DECADE OF INPUT DATE OUT-OF-RANGE'. 018104 CALL 'CANCEL'. 018110 B339-EXIT. 018200 EXIT. 018300****************************************************************** 018400 R100-READ-CARD-FILE SECTION. 018500 READ CARD-FILE INTO CARD-REC 018600 AT END 018700 MOVE 'Y' TO EOF-CARD-FLAG. 018800 R199-EXIT. 018900 EXIT. 019000****************************************************************** 019100 Z000-END-OF-JOB SECTION. 019200 CLOSE CARD-FILE. 019300 Z009-EXIT. 019400 EXIT. 019500****************************************************************** ./ ADD NAME=HEX2DECP 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. HEX2DECP. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* "HEX2DECP" TAKES A HEX VALUE AS A PARM. IT RETURNS THE * 000700* DECIMAL VALUE IN THE ISPF SHARED POOL VARIABLE DECNUM * 033000/**************************************************************** 033100* E N V I R O N M E N T D I V I S I O N * 033200***************************************************************** 033300 ENVIRONMENT DIVISION. 033400 033500 INPUT-OUTPUT SECTION. 033600 033700 FILE-CONTROL. 033800 033900/**************************************************************** 034000* D A T A D I V I S I O N * 034100***************************************************************** 034200 DATA DIVISION. 034300 034400 FILE SECTION. 034500 034600/**************************************************************** 034700* W O R K I N G - S T O R A G E S E C T I O N * 034800***************************************************************** 034900 WORKING-STORAGE SECTION. 035600/**************************************************************** 035700* C O N S T A N T S * 035800***************************************************************** 035900 01 CONSTANTS. 036000 05 FILLER PIC X(10) VALUE 036100 'CONSTANTS:'. 036200 036390 05 C-HEX-10 PIC X(01) VALUE 'A'. 036391 05 C-HEX-11 PIC X(01) VALUE 'B'. 036392 05 C-HEX-12 PIC X(01) VALUE 'C'. 036393 05 C-HEX-13 PIC X(01) VALUE 'D'. 036394 05 C-HEX-14 PIC X(01) VALUE 'E'. 036395 05 C-HEX-15 PIC X(01) VALUE 'F'. 036401 05 C-ISPF PIC X(07) VALUE 'ISPLINK'. 036405 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 036406 05 C-CONTROL PIC X(08) VALUE 'CONTROL '. 036408 05 C-VPUT PIC X(08) VALUE 'VPUT '. 036409 05 C-LIST-OPTION PIC X(08) VALUE 'LIST '. 036410 05 C-ERRORS-OPTION PIC X(08) VALUE 'ERRORS '. 036411 05 C-RETURN-OPTION PIC X(08) VALUE 'RETURN '. 036412 05 C-SHARED-OPTION PIC X(08) VALUE 'SHARED '. 036424 05 C-ISPF-VARIABLE-NAME PIC X(08) VALUE 'DECNUM '. 036432 05 C-ISPF-VARIABLE-LENGTH PIC S9(06) COMP VALUE +10. 036446 05 C-ISPF-VARIABLE-FORMAT PIC X(8) VALUE 'CHAR '. 043600 01 WORK-AREAS. 043700 05 FILLER PIC X(12) VALUE 043800 'WORK AREAS:'. 043900 044000 05 W-HEX-AREA PIC X(08) VALUE ZEROS. 044100 05 W-HEX-ARRAY REDEFINES W-HEX-AREA 044300 OCCURS 8 TIMES 044310 INDEXED BY W-HEX-NDX-1 044320 W-HEX-NDX-2. 044400 10 W-HEX-BYTE PIC X(01). 044410 05 W-DECIMAL-NUMBER PIC 9(10) VALUE ZEROS. 044420 05 W-DECIMAL-DIGIT PIC 9(02). 162000 LINKAGE SECTION. 162100 01 L-PARM-AREA. 162700 05 L-PARM-LENGTH PIC S9(04) COMP. 162710 05 L-PARM PIC X(100). 162730 05 L-PARM-ARRAY REDEFINES L-PARM 162740 OCCURS 100 TIMES 162750 INDEXED BY L-PARM-NDX. 162770 10 L-PARM-BYTE PIC X(01). 163200 PROCEDURE DIVISION USING L-PARM-AREA. 163300***************************************************************** 163400* P R O C E D U R E D I V I S I O N * 163500***************************************************************** 163600 IF L-PARM-LENGTH = +0 163610 MOVE +12 TO RETURN-CODE 163700 GO TO PROGRAM-END 163800 END-IF. 163900 169000 CALL C-ISPF USING C-VDEFINE C-ISPF-VARIABLE-NAME, 169100 W-DECIMAL-NUMBER, 169200 C-ISPF-VARIABLE-FORMAT, 169300 C-ISPF-VARIABLE-LENGTH. 169310 169400 IF RETURN-CODE > +4 169410 MOVE +16 TO RETURN-CODE 169420 GO TO PROGRAM-END 169430 END-IF. 169500 169521 COMPUTE TALLY = L-PARM-LENGTH - 1. 169530 169540 PERFORM VARYING L-PARM-NDX FROM +1 BY +1 169541 UNTIL L-PARM-NDX > L-PARM-LENGTH 169542 EVALUATE L-PARM-BYTE (L-PARM-NDX) 169543 WHEN C-HEX-10 169544 MOVE +10 TO W-DECIMAL-DIGIT 169545 WHEN C-HEX-11 169546 MOVE +11 TO W-DECIMAL-DIGIT 169547 WHEN C-HEX-12 169548 MOVE +12 TO W-DECIMAL-DIGIT 169549 WHEN C-HEX-13 169550 MOVE +13 TO W-DECIMAL-DIGIT 169551 WHEN C-HEX-14 169552 MOVE +14 TO W-DECIMAL-DIGIT 169553 WHEN C-HEX-15 169554 MOVE +15 TO W-DECIMAL-DIGIT 169555 WHEN OTHER 169556 MOVE L-PARM-BYTE (L-PARM-NDX) TO 169557 W-DECIMAL-DIGIT 169558 END-EVALUATE 169559 COMPUTE W-DECIMAL-NUMBER = 169560 W-DECIMAL-NUMBER + 169561 (W-DECIMAL-DIGIT * 169562 (+16 ** TALLY)) 169563 SUBTRACT +1 FROM TALLY 169570 END-PERFORM. 169600 312600 CALL C-ISPF USING C-VPUT C-ISPF-VARIABLE-NAME, 312700 C-SHARED-OPTION 312710 312800 IF RETURN-CODE > +4 312900 MOVE +20 TO RETURN-CODE 313000 GO TO PROGRAM-END 313100 END-IF. 313200 313400 PROGRAM-END. 313500 GOBACK. ./ ADD NAME=ISPFTALR 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. ISPFTALR. 000300 AUTHOR. DAVID LEIGH 000400 DATE-COMPILED. 000500****************************************************************** 000600** DO NOT COPY!! ** 000700** THIS DOCUMENT CONTAINS TRADE SECRET INFORMATION, THE ** 000800** EXPRESSION OF WHICH IS AN UNPUBLISHED WORK FULLY PROTECTED ** 000900** BY THE UNITED STATES COPYRIGHT LAWS AND IS CONSIDERED A ** 001000** TRADE SECRET OWNED BY UNIPAC SERVICE CORPORATION, ** 001100** 3015 SOUTH PARKER ROAD, SUITE 400, AURORA, COLORADO 80014. ** 001200** ALL RIGHTS, TITLE, INTEREST AND OWNERSHIP ARE RESERVED BY ** 001300** UNIPAC SERVICE CORPORATION. THIS DOCUMENT CANNOT BE ** 001400** ACQUIRED, COPIED, MODIFIED OR USED IN ANY MANNER WHATSOEVER ** 001500** WITHOUT THE EXPRESS WRITTEN CONSENT OF UNIPAC SERVICE ** 001600** CORPORATION. ** 001700****************************************************************** 001800****************************************************************** 001900** PROGRAM DOCUMENTATION ** 002000** ** 002100** PROGRAM TITLE - ISPFTALR - ISPF FILE TAILORING PROGRAM ** 002200** ** 002300** PROGRAM FUNCTION - THIS PROGRAM INVOKES ISPF SERVICES TO ** 002400** PERFORM FILE TAILORING TO CREATE CUSTOM OUTPUT FILES ** 002500** BASED ON AN ISPF SKELETON AND VARIABLES PASSED TO ** 002600** THE PROGRAM IN AN INPUT FILE, AND OPTIONALLY AN ISPF ** 002700** TABLE CREATED FROM ANOTHER INPUT FILE. ** 002800** ** 002900** THESE CUSTOM OUTPUT FILES ARE COMMONLY CUSTOM JCL ** 003000** WHICH MUST CHANGE BASED ON VARIABLES PASSED TO IT, ** 003100** BUT THEY ARE NOT LIMITED TO JCL FILES. ISPFTALR ** 003200** INVOKES ISPF SERVICES TO PUT THE INPUT VARIABLES ** 003300** INTO THE ISPF SHARED VARIABLE POOL AND, OPTIONALLY ** 003400** THE TABLEIN INPUT FILE INTO AN ISPF TABLE AND TO ** 003500** PERFORM THE ACTUAL FILE TAILORING. ** 003600** ** 003700** PROGRAM FLOW ** 003800** ** 003900** CONTROL SECTION ** 004000** 1) PERFORM INITIALIZATION FOR VARIABLE FILE ** 004100** 2) PERFORM MAINLINE FOR VARIABLE FILE ** 004200** 3) PERFORM INITIALIZATION FOR TABLEIN FILE (OPTIONAL) ** 004300** 4) PERFORM MAINLINE FOR TABLIN FILE (OPTIONAL) ** 004400** 5) PERFORM FILE TAILORING SECTION ** 004500** 6) PERFORM FINALIZATION ** 004600** ** 004700** INITIALIZATION OF VARIABLE FILE ** 004800** 1) INITIALIZE SOME WORKING STORAGE ** 004900** 2) DO SOME ISPF INITIALIZATION ** 005000** 3) OPEN AND READ THE INPUT FILE ** 005100** ** 005200** MAINLINE INPUT READ LOOP OF VARIABLE FILE ** 005300** 1) STORE OFF THE RESERVED VARIABLE VALUES ** 005400** 2) PARSE THE TABLE KEY AND NON-KEY COLUMNS NAMES ** 005500** 3) DETERMINE THE INPUT VARIABLE VALUE LENGTH ** 005600** 4) STORE TABLE KEY AND NON-KEY POSITION, LENGTH INFO ** 005700** 5) DEFINE THE VARIABLE TO ISPF ** 005800** 6) "VPUT" IT INTO THE SHARED POOL ** 005900** 7) READ ANOTHER RECORD ** 006000** ** 006100** INITIALIZATION OF TABLEIN FILE IF USING A TABLE ** 006200** 1) CREATE "TBCREATE" PARAMETERS ** 006300** 2) CALL ISPF TO CREATE THE TABLE ** 006400** 3) OPEN THE FILE AND DO A PRIMING READ ** 006500** ** 006600** MAINLINE INPUT READ LOOP OF TABLEIN FILE IF USING A TABLE ** 006700** 1) SPLIT THE RECORD INTO THE APPROPRIATE FIELDS ** 006800** 2) "TBADD" THE ROW ** 006900** 3) READ ANOTHER RECORD ** 007000** ** 007100** FILE TAILORING SECTION ** 007200** 1) DELETE THE FUNCTION POOL VARIABLES ** 007300** 3) "LIBDEF" TO THE SKELETON LIBRARY ** 007400** 3) PERFORM THE FILE TAILORING ** 007500** ** 007600** FINALIZATION ** 007700** 1) FINAL DISPLAYS. ** 007800** 2) CLOSE THE INPUT FILE ** 007900** 3) SET THE ISPF RETURN CODE VARIABLE ** 008000** ** 008100** DRIVER FILE ** 008200** -VARIABLE ** 008300** THIS FILE CONTAINS THE NAMES OF THE VARIABLES TO BE ** 008400** DEFINED AND THE VALUES TO BE ASSIGNED TO THEM. IT ALSO ** 008500** SPECIFIES THE INPUT SKELETON AND THE OUTPUT MEMBER. ** 008600** ** 008700** FILES ACCESSED ** 008800** -VARIABLE IS READ SEQUENTIALLY. ** 008900** ** 009000** -TABLEIN IS READ SEQUENTIALLY IF USING A TABLE. ** 009100** ** 009200** -ISPFILE IS THE OUTPUT DD FOR THE TAILORED SKELETON FILE. ** 009300** ISPF SERVICES PERFORM THE WRITES TO THIS FILE. NO FD IS ** 009400** REQUIRED FOR IT. ** 009500** ** 009600** SOURCE COPYBOOKS ** 009700** N/A ** 009800** ** 009900** CONTROL CARD DESCRIPTION - VARIABLE ** 010000** ** 010100** COLUMNS DESCRIPTION ** 010200** ------- --------------------------------------------- ** 010300** 01-08 VARIABLE NAME. THIS NAME WILL BE DEFINED IN ** 010400** THE ISPF SHARED VARIABLE POOL. THERE ARE ** 010500** SEVERAL "RESERVED" VARIABLES WHOSE NAMES ** 010600** DENOTE A SPECIAL FUNCTION: ** 010700** "ISPSLIB" - THE NAME OF THE SKELETON LIBRARY ** 010800** "SLIBMBR" - THE SKELETON MEMBER IN THIS PDS ** 010900** "OUTMBR" - THE OUTPUT MEMBER NAME IF ISPFILE ** 011000** IS DEFINED AS A PDS. ** 011100** "TABLEDEF" - THE NAME OF AN ISPF TABLE TO ** 011200** CREATE DYNAMICALLY. ** 011300** "TABLEKEY" - THE NAMES OF KEY COLUMNS FOR THIS ** 011400** NEWLY CREATED TABLE SEPARATED BY ** 011500** COMMAS. ** 011600** "TABLECOL" - THE NAMES OF NON-KEY COLUMNS FOR ** 011700** THIS NEWLY CREATED TABLE SEPARATED** 011800** BY COMMAS, ** 011900** PLEASE ALSO NOTE THAT "ZISPFRC" SHOULD NOT BE ** 012000** USED AS AN INPUT VARIABLE AS IT HAS A SPECIAL ** 012100** FUNCTION IN THIS PROGRAM. ** 012200** 09-80 THIS CONTAINS THE VALUE TO BE ASSIGNED TO THE ** 012300** VARIABLE. TRAILING BLANKS WILL BE REMOVED. ** 012400** ** 012500** NOTE: THESE RESERVED VARIABLE LINES CAN BE IN THE INPUT ** 012600** FILE IN ANY ORDER, BUT THEY NEED TO COME BEFORE ** 012700** THE NON-RESERVED VARIABLE LINES. ADDITIONALLY, ** 012800** FOR TABLES, THE TABLEKEY AND TABLECOL VARIABLES ** 012900** HAVE AN "ARRAY" OF INDIVIDUAL TABLE FIELD NAMES AS ** 013000** THEIR "VALUES". EACH INDIVIDUAL FIELD NAME MUST ** 013100** HAVE ITS OWN NON-RESERVED VARIABLE LINE AFTER THE ** 013200** TABLEKEY AND TABLECOL LINES. THE VALUE FOR THIS ** 013300** LINE WILL BE 2 NUMBER SEPARATED BY A COMMA THE ** 013400** FIRST NUMBER INDICATES THE POSITION IN WHICH THE ** 013500** DATA FOR THIS FIELD CAN BE FOUND IN THE INPUT ** 013600** TABLE RECORD. THE SECOND NUMBER INDICATES THE ** 013700** LENGTH OF THIS FIELD ON THE INPUT TABLE RECORD. ** 013800** ** 013900** NOTE: REGARDLESS OF VARIABLE OR TABLE FIELD CONTENT, THEY** 014000** WILL BE DEFINED AS "CHARACTER" FIELDS/VARIABLES TO ** 014100** ISPF. THIS DOES NOT PRECLUDE FIELDS WHICH ACTUALLY** 014200** CONTAIN NUMERIC VALUES FROM BEING USED IN ** 014300** ARITHMETIC EXPRESSIONS WITHIN THE SKELETON ITSELF. ** 014400** ** 014500** CALLED MODULES ** 014600** -'ISPLINK' ** 014700** THIS IS ISPF AND IS USED TO INVOKE ALL ISPF SERVICES. ** 014800** ** 014900** PROGRAM NOTES ** 015000** N/A ** 015100****************************************************************** 015200/***************************************************************** 015300** E N V I R O N M E N T D I V I S I O N ** 015400****************************************************************** 015500 ENVIRONMENT DIVISION. 015600 015700 INPUT-OUTPUT SECTION. 015800 015900 FILE-CONTROL. 016000 016100 SELECT INPUT-VARIABLE-FILE ASSIGN TO VARIABLE. 016200 016300 SELECT INPUT-TABLE-FILE ASSIGN TO TABLEIN. 016400 016500/***************************************************************** 016600** D A T A D I V I S I O N ** 016700****************************************************************** 016800 DATA DIVISION. 016900 017000 FILE SECTION. 017100 017200****************************************************************** 017300** THIS IS THE INPUT FILE OF VARIABLES AND VALUES ** 017400****************************************************************** 017500 FD INPUT-VARIABLE-FILE 017600 RECORDING MODE IS F 017700 RECORD CONTAINS 80 CHARACTERS 017800 BLOCK CONTAINS 0 RECORDS 017900 DATA RECORD IS INPUT-VARIABLE-RECORD. 018000 018100 01 INPUT-VARIABLE-RECORD. 018200 05 INPUT-VARIABLE-NAME PIC X(08). 018300 05 INPUT-COMMENT-GROUP REDEFINES 018400 INPUT-VARIABLE-NAME. 018500 10 INPUT-COMMENT-BYTE PIC X(01). 018600 88 INPUT-RECORD-IS-A-COMMENT VALUE '*'. 018700 10 FILLER PIC X(07). 018800 05 INPUT-VARIABLE-VALUE PIC X(72). 018900 05 INPUT-VARIABLE-ARRAY REDEFINES 019000 INPUT-VARIABLE-VALUE OCCURS 72 TIMES 019100 INDEXED BY INPUT-NDX. 019200 10 INPUT-VARIABLE-BYTE PIC X(01). 019300 019400****************************************************************** 019500** THIS IS THE INPUT FILE OF TABLE ROW RECORDS ** 019600****************************************************************** 019700 FD INPUT-TABLE-FILE 019800 RECORDING MODE IS F 019900 RECORD CONTAINS 80 CHARACTERS 020000 BLOCK CONTAINS 0 RECORDS 020100 DATA RECORD IS INPUT-TABLE-RECORD. 020200 020300 01 INPUT-TABLE-RECORD PIC X(80). 020400 020500/***************************************************************** 020600** W O R K I N G - S T O R A G E S E C T I O N ** 020700****************************************************************** 020800 WORKING-STORAGE SECTION. 020900 01 A-STANDARD-PROGRAM-ID PIC X(27) VALUE 021000 'UNIPAC/ISPFTALR/940629-1.00'. 021100 021200/***************************************************************** 021300** C O U N T E R S ** 021400****************************************************************** 021500 01 COUNTERS. 021600 05 C-TOTAL-VAR-RECS-READ PIC S9(08) COMP SYNC VALUE +0. 021700 05 C-TOTAL-TAB-RECS-READ PIC S9(08) COMP SYNC VALUE +0. 021800 05 C-SYMBOLIC-VAR-RECS-READ PIC S9(08) COMP SYNC VALUE +0. 021900 05 C-ISPF-CALLS-EXECUTED PIC S9(08) COMP SYNC VALUE +0. 022000 05 C-VARIABLES-DEFINED PIC S9(08) COMP SYNC VALUE +0. 022100 022200/***************************************************************** 022300** F L A G S ** 022400****************************************************************** 022500 01 FLAGS. 022600 05 F-END-OF-VAR-FILE-SWITCH PIC X(01) VALUE 'Y'. 022700 88 F-END-OF-VAR-FILE VALUE 'N'. 022800 88 F-MORE-VAR-RECS-TO-READ VALUE 'Y'. 022900 05 F-END-OF-TAB-FILE-SWITCH PIC X(01) VALUE 'Y'. 023000 88 F-END-OF-TAB-FILE VALUE 'N'. 023100 88 F-MORE-TAB-RECS-TO-READ VALUE 'Y'. 023200 05 F-KEY-SWITCH PIC X(01) VALUE 'N'. 023300 88 F-KEY-NOT-FOUND VALUE 'N'. 023400 88 F-KEY-FOUND VALUE 'Y'. 023500 05 F-COL-SWITCH PIC X(01) VALUE 'N'. 023600 88 F-COL-NOT-FOUND VALUE 'N'. 023700 88 F-COL-FOUND VALUE 'Y'. 023800 023900/***************************************************************** 024000** L I T E R A L S ** 024100****************************************************************** 024200 01 LITERALS. 024300 05 L-ISPF PIC X(08) VALUE 'ISPLINK '. 024400 05 L-ZISPFRC PIC X(08) VALUE 'ZISPFRC '. 024500 05 L-ISPF-SKELETON-LIBRARY PIC X(08) VALUE 'ISPSLIB '. 024600 05 L-ISPF-SKELETON-MEMBER PIC X(08) VALUE 'SLIBMBR '. 024700 05 L-ISPF-OUTPUT-MEMBER PIC X(08) VALUE 'OUTMBR '. 024800 05 L-ISPF-TABLE-NAME PIC X(08) VALUE 'TABLEDEF'. 024900 05 L-ISPF-TABLE-KEYS PIC X(08) VALUE 'TABLEKEY'. 025000 05 L-ISPF-TABLE-COLUMNS PIC X(08) VALUE 'TABLECOL'. 025100 05 L-VDEFINE PIC X(08) VALUE 'VDEFINE '. 025200 05 L-VDELETE PIC X(08) VALUE 'VDELETE '. 025300 05 L-TBCREATE PIC X(08) VALUE 'TBCREATE'. 025400 05 L-NOWRITE PIC X(08) VALUE 'NOWRITE '. 025500 05 L-SHARE PIC X(08) VALUE 'SHARE '. 025600 05 L-TBADD PIC X(08) VALUE 'TBADD '. 025700 05 L-TBOPEN PIC X(08) VALUE 'TBOPEN '. 025800 05 L-ALL-VARIABLES PIC X(08) VALUE '* '. 025900 05 L-LIBDEF PIC X(08) VALUE 'LIBDEF '. 026000 05 L-ISPSLIB PIC X(08) VALUE 'ISPSLIB '. 026100 05 L-DATASET PIC X(08) VALUE 'DATASET '. 026200 05 L-CONTROL PIC X(08) VALUE 'CONTROL '. 026300 05 L-FTOPEN PIC X(08) VALUE 'FTOPEN '. 026400 05 L-FTINCL PIC X(08) VALUE 'FTINCL '. 026500 05 L-FTCLOSE PIC X(08) VALUE 'FTCLOSE '. 026600 05 L-TEMP PIC X(08) VALUE 'TEMP '. 026700 05 L-VPUT PIC X(08) VALUE 'VPUT '. 026800 05 L-SHARED PIC X(08) VALUE 'SHARED '. 026900 05 L-ERRORS PIC X(08) VALUE 'ERRORS '. 027000 05 L-RETURN PIC X(08) VALUE 'RETURN '. 027100 05 L-CHARACTER PIC X(08) VALUE 'CHAR '. 027200 05 L-NULL-PLACE-HOLDER PIC X(01) VALUE ' '. 027300 05 L-COMMA PIC X(01) VALUE ','. 027400 05 L-LEFT-PAREN PIC X(01) VALUE '('. 027500 05 L-RIGHT-PAREN PIC X(01) VALUE ')'. 027600 027700/***************************************************************** 027800** H O L D A R E A S ** 027900****************************************************************** 028000 01 HOLD-AREAS. 028100 05 H-RETURN-CODE PIC 9(04) VALUE 0. 028200 88 H-GOOD-RETURN-CODE VALUE 0. 028300 88 H-FATAL-RETURN-CODE VALUE 5 THRU 9999. 028400 05 FILLER REDEFINES H-RETURN-CODE. 028500 10 H-RETURN-CODE-PREFIX PIC 9(02). 028600 88 H-VDEFINE-RC VALUE 20. 028700 88 H-VDELETE-RC VALUE 21. 028800 88 H-LIBDEF-RC VALUE 22. 028900 88 H-CONTROL-RC VALUE 23. 029000 88 H-FTOPEN-RC VALUE 24. 029100 88 H-FTINCL-RC VALUE 25. 029200 88 H-FTCLOSE-RC VALUE 26. 029300 88 H-VPUT-RC VALUE 27. 029400 88 H-TBCREATE-RC VALUE 28. 029500 88 H-TBADD-RC VALUE 29. 029600 88 H-MISC-BAD-RC VALUE 30. 029700 10 H-RETURN-CODE-SUFFIX PIC 9(02). 029800 88 H-ACCEPTABLE-RETURN-CODE VALUE 0 THRU 4. 029900 88 H-NO-SLIB-SPECIFIED VALUE 10. 030000 88 H-NO-SLIBMBR-SPECIFIED VALUE 20. 030100 88 H-MISSING-DEFINES VALUE 30. 030200 88 H-MISSING-TABLE-COLS VALUE 40. 030300 88 H-MISSING-TABLE-DEF VALUE 40. 030400 030500 05 H-ISPF-SKELETON-LIBRARY-AREA. 030600 10 FILLER PIC S9(06) COMP VALUE +1. 030700 10 FILLER PIC S9(06) COMP VALUE +0. 030800 10 H-ISPF-SKELETON-LIBRARY PIC X(50) VALUE SPACES. 030900 88 H-NO-SKELETON-LIB-SPECIFIED VALUE SPACES. 031000 031100 05 H-ISPF-TABLE-NAME PIC X(08) VALUE SPACES. 031200 88 H-THERE-IS-A-TABLE VALUE 'A' THRU 'Z9999999'. 031300 031400 05 H-TABLE-KEYS-AREA PIC X(74) VALUE SPACES. 031500 05 H-TABLE-KEYS-STRING PIC X(74) VALUE SPACES. 031600 05 H-TABLE-COLS-AREA PIC X(74) VALUE SPACES. 031700 05 H-TABLE-COLS-STRING PIC X(74) VALUE SPACES. 031800 031900 05 H-AREA-PREFIX PIC X(01) VALUE SPACE. 032000 05 H-POS PIC S9(4) COMP. 032100 05 H-LEN PIC S9(4) COMP. 032200 032300 05 H-ISPF-TABLE-KEY-COUNT PIC S9(08) COMP VALUE +0. 032400 88 H-THERE-ARE-KEYS VALUE +1 THRU +36. 032500 032600 05 H-ISPF-TABLE-KEY-ARRAY-AREA. 032700 10 H-ISPF-TABLE-KEY-ARRAY OCCURS 36 TIMES 032800 INDEXED BY H-TABLE-KEY-NDX. 032900 15 H-TABLE-KEY PIC X(08). 033000 15 H-TABLE-KEY-VAL PIC X(80). 033100 15 H-TABLE-KEY-POS-CHAR PIC X(02) JUST RIGHT. 033200 15 H-TABLE-KEY-POS REDEFINES 033300 H-TABLE-KEY-POS-CHAR PIC 9(02). 033400 15 H-TABLE-KEY-LEN-CHAR PIC X(02) JUST RIGHT. 033500 15 H-TABLE-KEY-LEN REDEFINES 033600 H-TABLE-KEY-LEN-CHAR PIC 9(02). 033700 033800 05 H-ISPF-TABLE-COL-COUNT PIC S9(08) COMP VALUE +0. 033900 88 H-THERE-ARE-COLUMNS VALUE +1 THRU +36. 034000 034100 05 H-ISPF-TABLE-COL-ARRAY-AREA. 034200 10 H-ISPF-TABLE-COL-ARRAY OCCURS 36 TIMES 034300 INDEXED BY H-TABLE-COL-NDX. 034400 15 H-TABLE-COL PIC X(08). 034500 15 H-TABLE-COL-VAL PIC X(80). 034600 15 H-TABLE-COL-POS-CHAR PIC X(02) JUST RIGHT. 034700 15 H-TABLE-COL-POS REDEFINES 034800 H-TABLE-COL-POS-CHAR PIC 9(02). 034900 15 H-TABLE-COL-LEN-CHAR PIC X(02) JUST RIGHT. 035000 15 H-TABLE-COL-LEN REDEFINES 035100 H-TABLE-COL-LEN-CHAR PIC 9(02). 035200 035300 05 H-VARIABLE-LENGTH PIC S9(08) COMP VALUE +72. 035400 05 H-ZISPFRC-LENGTH PIC S9(08) COMP VALUE +8. 035500 05 H-ZISPFRC. 035600 10 H-ZISPFRC-CODE PIC X(04) VALUE SPACES. 035700 10 FILLER PIC X(04) VALUE SPACES. 035800 05 H-ISPF-SKELETON-MEMBER PIC X(08) VALUE SPACES. 035900 88 H-NO-SKELETON-MEMBER-SPECIFIED VALUE SPACES. 036000 05 H-ISPF-OUTPUT-MEMBER PIC X(08) VALUE SPACES. 036100 88 H-NO-OUTPUT-MEMBER-SPECIFIED VALUE SPACES. 036200 036300/***************************************************************** 036400** P R O C E D U R E D I V I S I O N ** 036500****************************************************************** 036600 PROCEDURE DIVISION. 036700****************************************************************** 036800** S0000-CONTROL ** 036900** THIS SECTION IS THE DRIVER WHICH CONTROLS THE PROCESSING OF ** 037000** ALL THE SECTIONS AT THE HIGHEST LEVEL. ** 037100****************************************************************** 037200 S0000-CONTROL SECTION. 037300 037400 PERFORM S1000-INITIALIZATION. 037500 037600 PERFORM S2000-MAIN-PROCESS 037700 UNTIL F-END-OF-VAR-FILE 037800 OR H-FATAL-RETURN-CODE. 037900 038000 IF H-THERE-IS-A-TABLE AND 038100 (H-THERE-ARE-KEYS OR 038200 H-THERE-ARE-COLUMNS) 038300 PERFORM S1100-TABLE-INITIALIZATION 038400 PERFORM S2100-TABLE-MAINLINE 038500 UNTIL F-END-OF-TAB-FILE 038600 OR H-FATAL-RETURN-CODE 038700 END-IF. 038800 038900 IF H-ISPF-SKELETON-LIBRARY > SPACES AND 039000 H-ISPF-SKELETON-MEMBER > SPACES AND NOT 039100 H-FATAL-RETURN-CODE 039200 PERFORM S4500-FILE-TAILOR 039300 ELSE 039400 SET H-MISC-BAD-RC TO TRUE 039500 IF H-NO-SKELETON-MEMBER-SPECIFIED 039600 SET H-NO-SLIBMBR-SPECIFIED TO TRUE 039700 END-IF 039800 IF H-NO-SKELETON-LIB-SPECIFIED 039900 SET H-NO-SLIB-SPECIFIED TO TRUE 040000 END-IF 040100 END-IF. 040200 040300 PERFORM S3000-FINALIZATION. 040400 040500 S0000-EXIT. 040600 EXIT. 040700/***************************************************************** 040800** S1000-INITIALIZATION ** 040900** THIS SECTION PERFORMS THESE INITIALIZATION FUNCTIONS: ** 041000** 1. INITIALIZE SEVERAL WORKING STORAGE AREAS ** 041100** 2. SET ISPF CONTROLS ** 041200** 3. DEFINE THE SPECIAL ZISPFRC VARIABLE TO PASS RETURN CODES ** 041300** 4. OPEN THE VARIABLE INPUT FILE AND DO A PRIMING READ ** 041400****************************************************************** 041500 S1000-INITIALIZATION SECTION. 041600 041700 INITIALIZE H-ISPF-TABLE-KEY-COUNT 041800 H-ISPF-TABLE-KEY-ARRAY-AREA 041900 H-TABLE-KEYS-AREA 042000 H-ISPF-TABLE-COL-COUNT 042100 H-ISPF-TABLE-COL-ARRAY-AREA 042200 H-TABLE-COLS-AREA. 042300 042400 SET H-CONTROL-RC TO TRUE. 042500 CALL L-ISPF USING L-CONTROL L-ERRORS L-RETURN. 042600 PERFORM S4200-ISPF-CALL-CHECK. 042700 042800 SET H-VDEFINE-RC TO TRUE. 042900 CALL L-ISPF USING L-VDEFINE 043000 L-ZISPFRC 043100 H-ZISPFRC 043200 L-CHARACTER 043300 H-ZISPFRC-LENGTH. 043400 PERFORM S4200-ISPF-CALL-CHECK. 043500 043600 OPEN INPUT INPUT-VARIABLE-FILE. 043700 043800 PERFORM S4000-READ-VARIABLE-FILE. 043900 044000 S1000-EXIT. 044100 EXIT. 044200/***************************************************************** 044300** S1100-TABLE-INITIALIZATION ** 044400** THIS SECTION PERFORMS THE INITIALIZATION NECESSARY TO READ ** 044500** THE INPUT TABLE FILE AND LOAD THE CONTENTS INTO AN ISPF ** 044600** TABLE. IT DOES THE FOLLOWING FUNCTIONS: ** 044700** 1. CREATE PARAMETERS TO PASS TO ISPF OF THE TABLE KEYS AND ** 044800** COLUMNS WHICH NEED TO BE DEFINED. ** 044900** 2. "TBCREATE" THE ISPF TABLE. ** 045000** 3. OPEN THE INPUT TABLE FILE AND DO A PRIMING READ. ** 045100****************************************************************** 045200 S1100-TABLE-INITIALIZATION SECTION. 045300 045400 IF H-THERE-ARE-KEYS 045500 MOVE L-LEFT-PAREN TO H-AREA-PREFIX 045600 PERFORM VARYING H-TABLE-KEY-NDX FROM +1 BY +1 045700 UNTIL H-TABLE-KEY-NDX > H-ISPF-TABLE-KEY-COUNT 045800 STRING H-TABLE-KEYS-AREA DELIMITED BY SPACE 045900 H-AREA-PREFIX DELIMITED BY SPACE 046000 H-TABLE-KEY (H-TABLE-KEY-NDX) 046100 DELIMITED BY SPACE 046200 INTO H-TABLE-KEYS-STRING 046300 END-STRING 046400 MOVE L-COMMA TO H-AREA-PREFIX 046500 MOVE H-TABLE-KEYS-STRING TO H-TABLE-KEYS-AREA 046600 END-PERFORM 046700 STRING H-TABLE-KEYS-AREA DELIMITED BY SPACE 046800 L-RIGHT-PAREN DELIMITED BY SPACE 046900 INTO H-TABLE-KEYS-STRING 047000 END-STRING 047100 MOVE H-TABLE-KEYS-STRING TO H-TABLE-KEYS-AREA 047200 END-IF. 047300 047400 IF H-THERE-ARE-COLUMNS 047500 MOVE L-LEFT-PAREN TO H-AREA-PREFIX 047600 PERFORM VARYING H-TABLE-COL-NDX FROM +1 BY +1 047700 UNTIL H-TABLE-COL-NDX > H-ISPF-TABLE-COL-COUNT 047800 STRING H-TABLE-COLS-AREA DELIMITED BY SPACE 047900 H-AREA-PREFIX DELIMITED BY SPACE 048000 H-TABLE-COL (H-TABLE-COL-NDX) 048100 DELIMITED BY SPACE 048200 INTO H-TABLE-COLS-STRING 048300 END-STRING 048400 MOVE L-COMMA TO H-AREA-PREFIX 048500 MOVE H-TABLE-COLS-STRING TO H-TABLE-COLS-AREA 048600 END-PERFORM 048700 STRING H-TABLE-COLS-AREA DELIMITED BY SPACE 048800 L-RIGHT-PAREN DELIMITED BY SPACE 048900 INTO H-TABLE-COLS-STRING 049000 END-STRING 049100 MOVE H-TABLE-COLS-STRING TO H-TABLE-COLS-AREA 049200 END-IF. 049300 049400 SET H-TBCREATE-RC TO TRUE. 049500 CALL L-ISPF USING L-TBCREATE 049600 H-ISPF-TABLE-NAME 049700 H-TABLE-KEYS-AREA 049800 H-TABLE-COLS-AREA 049900 L-NOWRITE 050000 L-NULL-PLACE-HOLDER 050100 L-NULL-PLACE-HOLDER 050200 L-NULL-PLACE-HOLDER. 050300 PERFORM S4200-ISPF-CALL-CHECK. 050400 050500 OPEN INPUT INPUT-TABLE-FILE. 050600 050700 PERFORM S4100-READ-TABLE-FILE. 050800 050900 S1100-EXIT. 051000 EXIT. 051100/***************************************************************** 051200** S2000-MAIN-PROCESS ** 051300** THIS IS THE MAINLINE SECTION WHICH IS EXECUTED FOR EACH ** 051400** RECORD READ FROM THE INPUT VARIABLE FILE. THE PROCESSING ** 051500** FOR EACH RECORD IS AS FOLLOWS: ** 051600** 1. STORE THE VALUES IF THE FOLLOWING "RESERVED" VARIABLES ** 051700** INTO SPECIAL WORKING STORAGE ELEMENTS: ** 051800** "ISPSLIB", "SLIBMBR", "OUTMBR", "TABLEDEF". ** 051900** 2. IF THIS IS EITHER THE "TABLEKEY" OR "TABLECOL" RESERVED ** 052000** VARIABLE, IT'S VALUE IS PARSED VIA UNSTRING TO STORE THE ** 052100** "ATOMIC" VALUES INTO ARRAY ELEMENTS. ** 052200** 3. DETERMINE THE LENGTH OF THE VARIABLE. THIS IS NECESSARY ** 052300** OR ISPF WILL ASSUME THAT THE VARIABLE IS 72 BYTES LONG AND** 052400** THE TRAILING BLANKS WILL BE MAINTAINED. ** 052500** 4. IF TABLE KEYS HAVE BEEN DEFINED AND/OR TABLE COLUMNS HAVE ** 052600** BEEN DEFINED, CHECK TO SEE IF THIS VARIABLE NAME IS ONE OF** 052700** THOSE KEYS OR COLUMNS. IF SO, THE VALUE IS NOT TO BE ** 052800** STORED IN THE ISPF SHARED POOL, RATHER THE VALUE IS REALLY** 052900** THE POSITION AND LENGTH OF THIS VARIABLE IN THE TABLE ** 053000** INPUT FILE. IF THIS IS THE CASE, STORE THE POSITION AND ** 053100** LENGTH AWAY FOR LATER USE. ** 053200** 5. DEFINE ACTUAL VARIABLES TO ISPF AS A FUNCTION VARIABLE ** 053300** WITH THE VDEFINE STATEMENT. ** 053400** 6. VPUT THE VARIABLE INTO THE THE SHARED POOL. THE REASON ** 053500** WE DON'T USE THE FUNCTION POOL VARIABLES FOR THE FILE ** 053600** TAILORING IS THAT THEY ALL POINT TO THE SAME WORKING ** 053700** STORAGE FIELD (INPUT-VARIABLE-VALUE) TO CONTAIN THE VALUE.** 053800** CONSEQUENTLY, BY THE TIME THE PROGRAM IS FINISHED, EACH ** 053900** FUNCTION POOL VARIABLE CONTAINS THE VALUE OF THE LAST ** 054000** VARIABLE DEFINED. THE SHARED POOL VARIABLE RETAINS ITS ** 054100** VALUE PROPERLY, HOWEVER. ** 054200** 7. READ THE NEXT RECORD. ** 054300****************************************************************** 054400 S2000-MAIN-PROCESS SECTION. 054500 054600 IF INPUT-RECORD-IS-A-COMMENT 054700 DISPLAY 'COMMENT: ' INPUT-VARIABLE-RECORD 054800 ELSE 054900 ADD +1 TO C-SYMBOLIC-VAR-RECS-READ 055000 055100 EVALUATE INPUT-VARIABLE-NAME 055200 055300 WHEN L-ISPF-SKELETON-LIBRARY 055400 MOVE INPUT-VARIABLE-VALUE 055500 TO H-ISPF-SKELETON-LIBRARY 055600 055700 WHEN L-ISPF-SKELETON-MEMBER 055800 MOVE INPUT-VARIABLE-VALUE 055900 TO H-ISPF-SKELETON-MEMBER 056000 056100 WHEN L-ISPF-OUTPUT-MEMBER 056200 MOVE INPUT-VARIABLE-VALUE 056300 TO H-ISPF-OUTPUT-MEMBER 056400 056500 WHEN L-ISPF-TABLE-NAME 056600 MOVE INPUT-VARIABLE-VALUE 056700 TO H-ISPF-TABLE-NAME 056800 056900 WHEN L-ISPF-TABLE-KEYS 057000 UNSTRING INPUT-VARIABLE-VALUE 057100 DELIMITED BY ALL L-COMMA OR ALL SPACES 057200 INTO H-TABLE-KEY (1) 057300 H-TABLE-KEY (2) 057400 H-TABLE-KEY (3) 057500 H-TABLE-KEY (4) 057600 H-TABLE-KEY (5) 057700 H-TABLE-KEY (6) 057800 H-TABLE-KEY (7) 057900 H-TABLE-KEY (8) 057910 H-TABLE-KEY (9) 057920 H-TABLE-KEY (10) 057930 H-TABLE-KEY (11) 057940 H-TABLE-KEY (12) 057950 H-TABLE-KEY (13) 057960 H-TABLE-KEY (14) 057970 H-TABLE-KEY (15) 057980 H-TABLE-KEY (16) 057990 H-TABLE-KEY (17) 057991 H-TABLE-KEY (18) 057992 H-TABLE-KEY (19) 057993 H-TABLE-KEY (20) 057994 H-TABLE-KEY (21) 057995 H-TABLE-KEY (22) 057996 H-TABLE-KEY (23) 057997 H-TABLE-KEY (24) 057998 H-TABLE-KEY (25) 057999 H-TABLE-KEY (26) 058000 H-TABLE-KEY (27) 058001 H-TABLE-KEY (28) 058002 H-TABLE-KEY (29) 058003 H-TABLE-KEY (30) 058004 H-TABLE-KEY (31) 058005 H-TABLE-KEY (32) 058006 H-TABLE-KEY (33) 058007 H-TABLE-KEY (34) 058008 H-TABLE-KEY (35) 058009 H-TABLE-KEY (36) 058000 TALLYING H-ISPF-TABLE-KEY-COUNT 058100 END-UNSTRING 058200 058300 WHEN L-ISPF-TABLE-COLUMNS 058400 UNSTRING INPUT-VARIABLE-VALUE 058500 DELIMITED BY ALL L-COMMA OR ALL SPACES 058600 INTO H-TABLE-COL (1) 058700 H-TABLE-COL (2) 058800 H-TABLE-COL (3) 058900 H-TABLE-COL (4) 059000 H-TABLE-COL (5) 059100 H-TABLE-COL (6) 059200 H-TABLE-COL (7) 059300 H-TABLE-COL (8) 059310 H-TABLE-COL (9) 059320 H-TABLE-COL (10) 059330 H-TABLE-COL (11) 059340 H-TABLE-COL (12) 059350 H-TABLE-COL (13) 059360 H-TABLE-COL (14) 059370 H-TABLE-COL (15) 059380 H-TABLE-COL (16) 059390 H-TABLE-COL (17) 059391 H-TABLE-COL (18) 059392 H-TABLE-COL (19) 059393 H-TABLE-COL (20) 059394 H-TABLE-COL (21) 059395 H-TABLE-COL (22) 059396 H-TABLE-COL (23) 059397 H-TABLE-COL (24) 059398 H-TABLE-COL (25) 059399 H-TABLE-COL (26) 059400 H-TABLE-COL (27) 059401 H-TABLE-COL (28) 059402 H-TABLE-COL (29) 059403 H-TABLE-COL (30) 059404 H-TABLE-COL (31) 059405 H-TABLE-COL (32) 059406 H-TABLE-COL (33) 059407 H-TABLE-COL (34) 059408 H-TABLE-COL (35) 059409 H-TABLE-COL (36) 059400 TALLYING H-ISPF-TABLE-COL-COUNT 059500 END-UNSTRING 059600 END-EVALUATE 059700 059800 PERFORM VARYING INPUT-NDX FROM +72 BY -1 059900 UNTIL INPUT-VARIABLE-BYTE (INPUT-NDX) > SPACES 060000 OR INPUT-NDX < +2 060100 END-PERFORM 060200 060300 SET H-VARIABLE-LENGTH TO INPUT-NDX 060400 060500 IF H-THERE-ARE-KEYS 060600 SET H-TABLE-KEY-NDX TO +1 060700 SEARCH H-ISPF-TABLE-KEY-ARRAY 060800 VARYING H-TABLE-KEY-NDX 060900 AT END 061000 SET F-KEY-NOT-FOUND TO TRUE 061100 WHEN H-TABLE-KEY (H-TABLE-KEY-NDX) = 061200 INPUT-VARIABLE-NAME 061300 SET F-KEY-FOUND TO TRUE 061400 END-SEARCH 061500 END-IF 061600 061700 IF H-THERE-ARE-COLUMNS AND 061800 F-KEY-NOT-FOUND 061900 SET H-TABLE-COL-NDX TO +1 062000 SEARCH H-ISPF-TABLE-COL-ARRAY 062100 VARYING H-TABLE-COL-NDX 062200 AT END 062300 SET F-COL-NOT-FOUND TO TRUE 062400 WHEN H-TABLE-COL (H-TABLE-COL-NDX) = 062500 INPUT-VARIABLE-NAME 062600 SET F-COL-FOUND TO TRUE 062700 END-SEARCH 062800 END-IF 062900 063000 EVALUATE TRUE 063100 063200 WHEN H-THERE-ARE-KEYS AND F-KEY-FOUND 063300 PERFORM S4300-STORE-TABLE-KEY-POSLEN 063400 063500 WHEN H-THERE-ARE-COLUMNS AND F-COL-FOUND 063600 PERFORM S4400-STORE-TABLE-COL-POSLEN 063700 063800 WHEN OTHER 063900 SET H-VDEFINE-RC TO TRUE 064000 CALL L-ISPF USING L-VDEFINE 064100 INPUT-VARIABLE-NAME 064200 INPUT-VARIABLE-VALUE 064300 L-CHARACTER 064400 H-VARIABLE-LENGTH 064500 PERFORM S4200-ISPF-CALL-CHECK 064600 SET H-VPUT-RC TO TRUE 064700 CALL L-ISPF USING L-VPUT 064800 INPUT-VARIABLE-NAME 064900 L-SHARED 065000 PERFORM S4200-ISPF-CALL-CHECK 065100 065200 END-EVALUATE 065300 065400 DISPLAY 'VARIABLE: "' INPUT-VARIABLE-NAME '" = "' 065500 INPUT-VARIABLE-VALUE '"' 065600 ADD +1 TO C-VARIABLES-DEFINED 065700 END-IF. 065800 065900 PERFORM S4000-READ-VARIABLE-FILE. 066000 066100 S2000-EXIT. 066200 EXIT. 066300/***************************************************************** 066400** S2100-TABLE-MAINLINE ** 066500** THIS SECTION PERFORMS THE ITERATIVE PROCESSING NECESSARY FOR ** 066600** EACH TABLE FILE INPUT RECORD WHICH NEEDS TO BECOME A TABLE ** 066700** ROW. ITS FUNCTIONS ARE AS FOLLOWS: ** 066800** 1. FOR EACH DEFINED KEY AND COLUMN MOVE THE APPROPRIATE AREA ** 066900** OF THE RECORD INTO AN ARRAY FIELD. ** 067000** 2. CALL ISPF TO ADD A NEW ROW TO THE TABLE. ** 067100** 3. READ THE NEXT INPUT RECORD. ** 067200****************************************************************** 067300 S2100-TABLE-MAINLINE SECTION. 067400 067500 PERFORM VARYING H-TABLE-KEY-NDX FROM +1 BY +1 067600 UNTIL H-TABLE-KEY-NDX > H-ISPF-TABLE-KEY-COUNT 067700 MOVE INPUT-TABLE-RECORD 067800 (H-TABLE-KEY-POS (H-TABLE-KEY-NDX): 067900 H-TABLE-KEY-LEN (H-TABLE-KEY-NDX)) 068000 TO H-TABLE-KEY-VAL (H-TABLE-KEY-NDX) 068100 END-PERFORM. 068200 068300 PERFORM VARYING H-TABLE-COL-NDX FROM +1 BY +1 068400 UNTIL H-TABLE-COL-NDX > H-ISPF-TABLE-COL-COUNT 068500 MOVE INPUT-TABLE-RECORD 068600 (H-TABLE-COL-POS (H-TABLE-COL-NDX): 068700 H-TABLE-COL-LEN (H-TABLE-COL-NDX)) 068800 TO H-TABLE-COL-VAL (H-TABLE-COL-NDX) 068900 END-PERFORM. 069000 069100 SET H-TBADD-RC TO TRUE. 069200 CALL L-ISPF USING L-TBADD 069300 H-ISPF-TABLE-NAME. 069400 PERFORM S4200-ISPF-CALL-CHECK. 069500 069600 PERFORM S4100-READ-TABLE-FILE. 069700 069800 S2100-EXIT. 069900 EXIT. 070000/***************************************************************** 070100** S3000-FINALIZATION ** 070200** THIS SECTION CONTROLS THE FINAL PROCESSING FOR EITHER GOOD OR** 070300** BAD EXECUTIONS. IF A FATAL ERROR OCCURS MID-STREAM, THIS ** 070400** SECTION WILL BE PERFORMED TO GET OUT. THAT IS WHY IT HAS THE** 070500** GOBACK AT THE END. ** 070600** ** 070700** IS DISPLAYS THE ACCUMULATORS, CLOSES THE INPUT FILE, MOVES ** 070800** THE RETURN CODE AND "GOES BACK". ** 070900****************************************************************** 071000 S3000-FINALIZATION SECTION. 071100 071200 DISPLAY 'C-TOTAL-TAB-RECS-READ: ' 071300 C-TOTAL-TAB-RECS-READ. 071400 071500 DISPLAY 'C-TOTAL-VAR-RECS-READ: ' 071600 C-TOTAL-VAR-RECS-READ. 071700 071800 DISPLAY 'C-SYMBOLIC-VAR-RECS-READ: ' 071900 C-SYMBOLIC-VAR-RECS-READ. 072000 072100 DISPLAY 'C-VARIABLES-DEFINED: ' 072200 C-VARIABLES-DEFINED. 072300 072400 IF C-VARIABLES-DEFINED NOT = C-SYMBOLIC-VAR-RECS-READ 072500 DISPLAY '*** NOTE ***' 072600 DISPLAY 'THE SAME NUMBER OF VARIABLES WAS NOT DEFINED ' 072700 'AS WAS READ!' 072800 SET H-MISC-BAD-RC TO TRUE 072900 SET H-MISSING-DEFINES TO TRUE 073000 END-IF. 073100 073200 DISPLAY 'C-ISPF-CALLS-EXECUTED: ' 073300 C-ISPF-CALLS-EXECUTED. 073400 073500 DISPLAY ' '. 073600 DISPLAY 'PROGRAM RETURN CODE = ' H-RETURN-CODE. 073700 073800 IF H-ACCEPTABLE-RETURN-CODE 073900 SET H-GOOD-RETURN-CODE TO TRUE 074000 END-IF. 074100 074200 MOVE H-RETURN-CODE TO H-ZISPFRC-CODE. 074300 074400 SET H-VPUT-RC TO TRUE. 074500 CALL L-ISPF USING L-VPUT 074600 L-ZISPFRC 074700 L-SHARED. 074800 074900 IF H-THERE-IS-A-TABLE 075000 CLOSE INPUT-TABLE-FILE 075100 END-IF. 075200 CLOSE INPUT-VARIABLE-FILE. 075300 075400 GOBACK. 075500 075600 S3000-EXIT. 075700 EXIT. 075800/***************************************************************** 075900** S4000-READ-VARIABLE-FILE ** 076000** THIS SECTION SIMPLY READS THE NEXT INPUT VARIABLE FILE ** 076100** RECORD AND INCREMENTS THE READ COUNTER. ** 076200****************************************************************** 076300 S4000-READ-VARIABLE-FILE SECTION. 076400 076500 READ INPUT-VARIABLE-FILE 076600 AT END 076700 SET F-END-OF-VAR-FILE TO TRUE 076800 END-READ. 076900 077000 IF F-MORE-VAR-RECS-TO-READ 077100 ADD +1 TO C-TOTAL-VAR-RECS-READ 077200 END-IF. 077300 077400 S4000-EXIT. 077500 EXIT. 077600/***************************************************************** 077700** S4100-READ-TABLE-FILE ** 077800** THIS SECTION SIMPLY READS THE NEXT INPUT TABLE FILE ** 077900** RECORD AND INCREMENTS THE READ COUNTER. ** 078000****************************************************************** 078100 S4100-READ-TABLE-FILE SECTION. 078200 078300 READ INPUT-TABLE-FILE 078400 AT END 078500 SET F-END-OF-TAB-FILE TO TRUE 078600 END-READ. 078700 078800 IF F-MORE-TAB-RECS-TO-READ 078900 ADD +1 TO C-TOTAL-TAB-RECS-READ 079000 END-IF. 079100 079200 S4100-EXIT. 079300 EXIT. 079400/***************************************************************** 079500** S4200-ISPF-CALL-CHECK ** 079600** THIS SECTION IS CALLED AFTER EACH ISPF CALL TO CENTRALIZE ** 079700** THE PROCESSING NECESSARY TO DO ERROR CHECKING AND COUNTING ** 079800** THE NUMBER OF ISPF EXECUTIONS. ** 079900** ** 080000** FIRST WE SAVE THE RETURN CODE FROM THE ISPF CALL. THEN WE ** 080100** ADD ONE TO THE ISPF CALL ACCUMULATOR. IF THE RETURN CODE ** 080200** WAS GOOD, WE RETURN TO THE SECTION WHICH PERFORMED THIS ONE. ** 080300** ** 080400** IF THE RETURN CODE IS NOT ACCEPTABLE, SERVICE-SPECIFIC ** 080500** DISPLAYS ARE DONE AND FINALIZATION IS CALLED IN ORDER TO GET ** 080600** OUT. ** 080700****************************************************************** 080800 S4200-ISPF-CALL-CHECK SECTION. 080900 081000 MOVE RETURN-CODE TO H-RETURN-CODE-SUFFIX. 081100 ADD +1 TO C-ISPF-CALLS-EXECUTED. 081200 081300 IF H-ACCEPTABLE-RETURN-CODE 081400 SET H-GOOD-RETURN-CODE TO TRUE 081500 ELSE 081600 EVALUATE TRUE 081700 WHEN H-VDEFINE-RC 081800 DISPLAY 'ISPF SERVICE: VDEFINE' 081900 WHEN H-VDELETE-RC 082000 DISPLAY 'ISPF SERVICE: VDELETE' 082100 WHEN H-TBCREATE-RC 082200 DISPLAY 'ISPF SERVICE: TBCREATE' 082300 WHEN H-TBADD-RC 082400 DISPLAY 'ISPF SERVICE: TBADD' 082500 WHEN H-LIBDEF-RC 082600 DISPLAY 'ISPF SERVICE: LIBDEF' 082700 WHEN H-CONTROL-RC 082800 DISPLAY 'ISPF SERVICE: CONTROL' 082900 WHEN H-FTOPEN-RC 083000 DISPLAY 'ISPF SERVICE: FTOPEN' 083100 WHEN H-FTINCL-RC 083200 DISPLAY 'ISPF SERVICE: FTINCL' 083300 WHEN H-FTCLOSE-RC 083400 DISPLAY 'ISPF SERVICE: FTCLOSE' 083500 WHEN H-VPUT-RC 083600 DISPLAY 'ISPF SERVICE: VPUT' 083700 END-EVALUATE 083800 DISPLAY 'ISPF CALL INSTANCE: ' C-ISPF-CALLS-EXECUTED 083900 DISPLAY 'ISPF RC: ' H-RETURN-CODE-SUFFIX 084000 PERFORM S3000-FINALIZATION 084100 END-IF. 084200 084300 S4200-EXIT. 084400 EXIT. 084500/***************************************************************** 084600** S4300-STORE-TABLE-KEY-POSLEN ** 084700** AS A NON-RESERVED VARIABLE NAME IS READ IN AND IT IS FOUND ** 084800** TO ACTUALLY BE A KEY FIELD IN THE TABLE DEFINITION (BASED ON ** 084900** THE CONTENTS OF THE "TABLEKEY" RECORD READ PREVIOUSLY), THIS ** 085000** SECTION IS CALLED TO PARSE AND STORE ITS VALUE AS POSITION ** 085100** AND LENGTH INFORMATION FOR THIS FIELD AND TO "VDEFINE" THE ** 085200** VARIABLE TO ISPF. ITS VALUE IS NOT VPUT. ** 085300****************************************************************** 085400 S4300-STORE-TABLE-KEY-POSLEN SECTION. 085500 085600 MOVE ALL ZEROS TO H-TABLE-KEY-POS (H-TABLE-KEY-NDX) 085700 H-TABLE-KEY-LEN (H-TABLE-KEY-NDX). 085800 085900 UNSTRING INPUT-VARIABLE-VALUE 086000 DELIMITED BY ALL L-COMMA OR ALL SPACES 086100 INTO H-TABLE-KEY-POS-CHAR (H-TABLE-KEY-NDX) 086200 H-TABLE-KEY-LEN-CHAR (H-TABLE-KEY-NDX) 086300 END-UNSTRING. 086400 086310 INSPECT H-TABLE-KEY-POS-CHAR (H-TABLE-KEY-NDX) 086320 REPLACING ALL SPACES BY ZEROS. 086321 086330 INSPECT H-TABLE-KEY-LEN-CHAR (H-TABLE-KEY-NDX) 086340 REPLACING ALL SPACES BY ZEROS. 086400 086500 MOVE H-TABLE-KEY-LEN (H-TABLE-KEY-NDX) TO H-VARIABLE-LENGTH. 086600 SET H-VDEFINE-RC TO TRUE. 086700 CALL L-ISPF USING L-VDEFINE 086800 H-TABLE-KEY (H-TABLE-KEY-NDX) 086900 H-TABLE-KEY-VAL (H-TABLE-KEY-NDX) 087000 L-CHARACTER 087100 H-VARIABLE-LENGTH 087200 PERFORM S4200-ISPF-CALL-CHECK. 087300 087301 DISPLAY 'TABLE KEY COLUMN: "' 087302 H-TABLE-KEY (H-TABLE-KEY-NDX) 087303 '" WILL BE EXTRACTED BEGINNING AT POSITION: "' 087310 H-TABLE-KEY-POS-CHAR (H-TABLE-KEY-NDX) 087311 '" FOR A LENGTH OF: "' 087320 H-TABLE-KEY-LEN-CHAR (H-TABLE-KEY-NDX) 087330 '"'. 087340 087400 S4300-EXIT. 087500 EXIT. 087600/***************************************************************** 087700** S4400-STORE-TABLE-COL-POSLEN ** 087800** AS A NON-RESERVED VARIABLE NAME IS READ IN AND IT IS FOUND ** 087900** TO ACTUALLY BE A NON-KEY FIELD (JUST A COLUMN) IN THE TABLE ** 088000** DEFINITION (BASED ON THE CONTENTS OF THE "TABLEKEY" RECORD ** 088100** READ PREVIOUSLY), THIS SECTION IS CALLED TO PARSE AND STORE ** 088200** ITS VALUE AS POSITION AND LENGTH INFORMATION FOR THIS FIELD ** 088300** AND TO "VDEFINE" THE VARIABLE TO ISPF. ITS VALUE IS NOT ** 088400** VPUT. ** 088500****************************************************************** 088600 S4400-STORE-TABLE-COL-POSLEN SECTION. 088700 088800 MOVE ALL ZEROS TO H-TABLE-COL-POS (H-TABLE-COL-NDX) 088900 H-TABLE-COL-LEN (H-TABLE-COL-NDX). 089000 089100 UNSTRING INPUT-VARIABLE-VALUE 089200 DELIMITED BY ALL L-COMMA OR ALL SPACES 089300 INTO H-TABLE-COL-POS-CHAR (H-TABLE-COL-NDX) 089400 H-TABLE-COL-LEN-CHAR (H-TABLE-COL-NDX) 089500 END-UNSTRING. 089600 089510 INSPECT H-TABLE-COL-POS-CHAR (H-TABLE-COL-NDX) 089520 REPLACING ALL SPACES BY ZEROS. 089521 089530 INSPECT H-TABLE-COL-LEN-CHAR (H-TABLE-COL-NDX) 089540 REPLACING ALL SPACES BY ZEROS. 089600 089700 MOVE H-TABLE-COL-LEN (H-TABLE-COL-NDX) TO H-VARIABLE-LENGTH. 089800 SET H-VDEFINE-RC TO TRUE. 089900 CALL L-ISPF USING L-VDEFINE 090000 H-TABLE-COL (H-TABLE-COL-NDX) 090100 H-TABLE-COL-VAL (H-TABLE-COL-NDX) 090200 L-CHARACTER 090300 H-VARIABLE-LENGTH 090400 PERFORM S4200-ISPF-CALL-CHECK. 090500 090510 DISPLAY 'TABLE COLUMN: "' 090520 H-TABLE-COL (H-TABLE-COL-NDX) 090530 '" WILL BE EXTRACTED BEGINNING AT POSITION: "' 090540 H-TABLE-COL-POS-CHAR (H-TABLE-COL-NDX) 090550 '" FOR A LENGTH OF: "' 090560 H-TABLE-COL-LEN-CHAR (H-TABLE-COL-NDX) 090570 '"'. 090580 090600 S4400-EXIT. 090700 EXIT. 090800/***************************************************************** 090900** S4500-FILE-TAILOR ** 091000** THIS SECTION IS EXECUTED CONDITIONALLY IF ALL THE VARIABLE ** 091100** DEFINING AND "PUTTING" HAS HAPPENED SUCCESSUFULLY AND THE ** 091200** SKELETON LIBRARY NAME AND THE MEMBER NAME TO TAILOR WERE ALSO** 091300** BOTH RECEIVED. ** 091400** ** 091500** THE FIRST THING WE DO IS TO DELETE THE FUNCTION VARIABLES WE ** 091600** "VDEFINED". THAT WAY, WHEN THE FILE TAILORING GOES AFTER ** 091700** VARIABLES OF A SPECIFIC NAME, THE FIRST ONES IT WILL ** 091800** ENCOUNTER WILL BE THE ONES IN THE SHARED POOL. ** 091900** ** 092000** THEN WE "LIBDEF" TO THE ISPF SKELETON LIBRARY WHICH WAS ** 092100** PASSED IN THE INPUT VARIABLE STREAM. ONCE ALL OF THIS HAS ** 092200** BEEN DONE SUCCESSFULLY, WE FILE TAILOR THE MEMBER, WHICH WAS ** 092300** ALSO SPECIFIED IN THE INPUT VARIABLE STREAM. ** 092400****************************************************************** 092500 S4500-FILE-TAILOR SECTION. 092600 092700 SET H-VDELETE-RC TO TRUE. 092800 CALL L-ISPF USING L-VDELETE 092900 L-ALL-VARIABLES. 093000 PERFORM S4200-ISPF-CALL-CHECK. 093100 093200 SET H-LIBDEF-RC TO TRUE. 093300 CALL L-ISPF USING L-LIBDEF 093400 L-ISPSLIB 093500 L-DATASET 093600 H-ISPF-SKELETON-LIBRARY-AREA. 093700 PERFORM S4200-ISPF-CALL-CHECK. 093800 093900 SET H-FTOPEN-RC TO TRUE. 094000 CALL L-ISPF USING L-FTOPEN. 094100 PERFORM S4200-ISPF-CALL-CHECK. 094200 094300 SET H-FTINCL-RC TO TRUE. 094400 CALL L-ISPF USING L-FTINCL 094500 H-ISPF-SKELETON-MEMBER. 094600 PERFORM S4200-ISPF-CALL-CHECK. 094700 094800 SET H-FTCLOSE-RC TO TRUE. 094900 IF H-NO-OUTPUT-MEMBER-SPECIFIED 095000 CALL L-ISPF USING L-FTCLOSE 095100 ELSE 095200 CALL L-ISPF USING L-FTCLOSE 095300 H-ISPF-OUTPUT-MEMBER 095400 END-IF. 095500 PERFORM S4200-ISPF-CALL-CHECK. 095600 095700 S4500-EXIT. 095800 EXIT. ./ ADD NAME=ISPFTEST 000100 IDENTIFICATION DIVISION. 000500 PROGRAM-ID. ISPFTEST. 000600 AUTHOR. DAVE LEIGH 000700 DATE-COMPILED. 000800***************************************************************** 000900* REMARKS: * 001000* THIS PROGRAM IS USED TO TEST ISPF FUNCTIONALITY IN A * 001100* COBOL PROGRAM. * 001200***************************************************************** 001300/**************************************************************** 001400* E N V I R O N M E N T D I V I S I O N * 001500***************************************************************** 001600 ENVIRONMENT DIVISION. 001700 001800 INPUT-OUTPUT SECTION. 001900 002000 FILE-CONTROL. 002100 002200/**************************************************************** 002300* D A T A D I V I S I O N * 002400***************************************************************** 002500 DATA DIVISION. 002600 002700 FILE SECTION. 002800 002900/**************************************************************** 003000* W O R K I N G - S T O R A G E S E C T I O N * 003100***************************************************************** 003200 WORKING-STORAGE SECTION. 003300***************************************************************** 003400* A C C U M U L A T O R S * 003500***************************************************************** 003600 01 ACCUMULATORS. 003700 05 FILLER PIC X(13) VALUE 003800 'ACCUMULATORS:'. 003900/**************************************************************** 004000* C O N S T A N T S * 004100***************************************************************** 004200 01 CONSTANTS. 004300 05 FILLER PIC X(10) VALUE 004400 'CONSTANTS:'. 004500 05 C-NULL-PLACE-HOLDER PIC X(01) VALUE ' '. 004600 05 C-ISPF-CONSTANTS. 004700 10 C-ISPF-SERVICES-AND-PARAMETERS. 004800 15 C-ISPF PIC X(07) VALUE 'ISPLINK'. 004900 15 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 005000 15 C-VGET PIC X(08) VALUE 'VGET '. 005100 15 C-LMINIT PIC X(08) VALUE 'LMINIT '. 005200 15 C-LMOPEN PIC X(08) VALUE 'LMOPEN '. 005300 15 C-LMCLOSE PIC X(08) VALUE 'LMCLOSE '. 005400 15 C-LMFREE PIC X(08) VALUE 'LMFREE '. 005500 15 C-LMGET PIC X(08) VALUE 'LMGET '. 005600 15 C-LMMLIST PIC X(08) VALUE 'LMMLIST '. 005700 15 C-LMMFIND PIC X(08) VALUE 'LMMFIND '. 005800 15 C-CONTROL PIC X(08) VALUE 'CONTROL '. 005900 15 C-ERRORS PIC X(08) VALUE 'ERRORS '. 006000 15 C-RETURN PIC X(08) VALUE 'RETURN '. 006100 15 C-LIST-OPTION PIC X(08) VALUE 'LIST '. 006200 15 C-DDNAME PIC X(08) VALUE 'SYSPROC '. 006300 15 C-MOVE-MODE PIC X(08) VALUE 'MOVE '. 006400 15 C-JCL-MAX-LINE-LENGTH PIC S9(06) COMP VALUE +80. 006500 10 C-ISPF-VARIABLE-NAMES. 006600 15 C-DATAID PIC X(08) VALUE 'PROCDID '. 006700 15 C-ZERRMSG PIC X(08) VALUE 'ZERRMSG '. 006800 15 C-ZERRLM PIC X(08) VALUE 'ZERRLM '. 006900 10 C-ISPF-VARIABLE-LENGTHS COMP. 007000 15 C-DATAID-L PIC S9(06) VALUE +8. 007100 15 C-ZERRMSG-L PIC S9(06) VALUE +8. 007200 15 C-ZERRLM-L PIC S9(06) VALUE +512. 007300 10 C-ISPF-VARIABLE-FORMATS. 007400 15 C-DATAID-F PIC X(08) VALUE 'CHAR '. 007500 15 C-ZERRMSG-F PIC X(08) VALUE 'CHAR '. 007600 15 C-ZERRLM-F PIC X(08) VALUE 'CHAR '. 007700/**************************************************************** 007800* S W I T C H E S * 007900***************************************************************** 008000 01 SWITCHES. 008100 05 FILLER PIC X(09) VALUE 008200 'SWITCHES:'. 008300/**************************************************************** 008400* W O R K A R E A S * 008500***************************************************************** 008600 01 WORK-AREAS. 008700 05 FILLER PIC X(11) VALUE 008800 'WORK AREAS:'. 008900 05 W-ISPF-VARIABLES. 009000 10 W-DATAID PIC X(08) VALUE SPACES. 009100 10 W-ZERRMSG PIC X(08) VALUE SPACES. 009200 10 W-ZERRLM PIC X(512) VALUE SPACES. 009300/**************************************************************** 009400* P R I N T L I N E S * 009500***************************************************************** 009600 01 PRINT-LINES. 009700 05 FILLER PIC X(12) VALUE 009800 'PRINT LINES:'. 009900/**************************************************************** 010000* T A B L E S * 010100***************************************************************** 010200 01 TABLES. 010300 05 FILLER PIC X(07) VALUE 010400 'TABLES:'. 010500/**************************************************************** 010600* P R O C E D U R E D I V I S I O N * 010700***************************************************************** 010800 PROCEDURE DIVISION. 010900***************************************************************** 011000* S0000-CONTROL * 011100***************************************************************** 011200 S0000-CONTROL SECTION. 011300 011400 PERFORM S1000-INITIALIZATION. 011500 DISPLAY '~~~1~~~ ' RETURN-CODE. 011600 011700 PERFORM S2000-MAIN-PROCESS. 011800 DISPLAY '~~~2~~~ ' RETURN-CODE. 011900 012000 PERFORM S3000-FINALIZATION. 012100 DISPLAY '~~~3~~~ ' RETURN-CODE. 012200 012300 GOBACK. 012400 012500 S0000-EXIT. 012600 EXIT. 012700/**************************************************************** 012800* S1000-INITIALIZATION * 012900***************************************************************** 013000 S1000-INITIALIZATION SECTION. 013100 013200 CALL C-ISPF USING C-CONTROL C-ERRORS C-RETURN. 013300 013400 CALL C-ISPF USING C-VDEFINE 013500 C-DATAID W-DATAID C-DATAID-F C-DATAID-L. 013600 CALL C-ISPF USING C-VDEFINE 013700 C-ZERRMSG W-ZERRMSG C-ZERRMSG-F C-ZERRMSG-L. 013800 CALL C-ISPF USING C-VDEFINE 013900 C-ZERRLM W-ZERRLM C-ZERRLM-F C-ZERRLM-L. 014000 014100 IF RETURN-CODE > 4 014200 DISPLAY 'VDEFINE RETURN CODE = ' RETURN-CODE 014300 CALL C-ISPF USING C-VGET C-ZERRMSG 014400 CALL C-ISPF USING C-VGET C-ZERRLM 014500 DISPLAY W-ZERRMSG ' ' W-ZERRLM 014600 PERFORM S3000-FINALIZATION 014700 END-IF. 014800 DISPLAY '~~~10~~~ ' RETURN-CODE. 014900 015000 015100 S1000-EXIT. 015200 EXIT. 015300/**************************************************************** 015400* S2000-MAIN-PROCESS * 015500***************************************************************** 015600 S2000-MAIN-PROCESS SECTION. 015700 015800 DISPLAY 'C-DATAID ' C-DATAID. 015900 DISPLAY 'W-DATAID ' W-DATAID. 016000 CALL C-ISPF USING C-LMINIT C-DATAID, 016100 C-NULL-PLACE-HOLDER, 016200 C-NULL-PLACE-HOLDER, 016300 C-NULL-PLACE-HOLDER, 016400 C-NULL-PLACE-HOLDER, 016500 C-NULL-PLACE-HOLDER, 016600 C-NULL-PLACE-HOLDER, 016700 C-NULL-PLACE-HOLDER, 016800 C-DDNAME. 016900 DISPLAY 'RETURN-CODE ' RETURN-CODE. 017000 DISPLAY 'C-DATAID ' C-DATAID. 017100 DISPLAY 'W-DATAID ' W-DATAID. 017200 017300 S2000-EXIT. 017400 EXIT. 017500/**************************************************************** 017600* S3000-FINALIZATION * 017700***************************************************************** 017800 S3000-FINALIZATION SECTION. 017900 018000 EXIT. 018100 018200 S3000-EXIT. 018300 EXIT. ./ ADD NAME=JCLXREFX 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. JCLXREFX. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* REMARKS: * 000700* THIS PROGRAM READS THROUGH A PDS LIBRARY OF JCL AND CREATES* 000800* A FLAT FILE OF DATASET AND PROGRAM USAGE INFORMATION WHICH * 000900* CAN BE USED AS A CROSS REFERENCE. * 001000* * 001100* THE INFORMATION IT PROVIDES IS AT THE DDNAME LEVEL IF THAT * 001200* DDNAME CONTAINS A DATASET. THE INFORMATION INCLUDES: * 001300* * 001400* +++ FIELD +++ +++ LENGTH +++ * 001500* EXECUTE JCL MEMBER NAME 8 * 001600* EXECUTE JCL JOB NAME 8 * 001700* STEP NAME 8 * 001800* PROGRAM NAME 8 * 001900* PROC NAME 8 * 002000* PROC LIB MEMBER NAME 8 * 002100* DDNAME 8 * 002200* DATASET NAME 50 * 002300* DATASET DISPOSITION 20 * 002400***************************************************************** 002500************************ EXAMPLE JCL **************************** 002600* //STEP01 EXEC PGM=JCLXREFX * 002700* //STEPLIB DD DSN=D@UDAL.STR.LOADLIB, * 002800* // DISP=(SHR,KEEP,KEEP) * 002900* // DD DSN=SYS1.COB2LIB, * 003000* // DISP=(SHR,KEEP,KEEP) * 003100* //PROCLIBS DD DSN=SYS1.PARMLIB(DYNALLOC), * 003200* // DISP=(SHR,KEEP,KEEP) * 003300* //JCLLIB DD DSN=USC10.STR.JCLLIB, * 003400* // DISP=(SHR,KEEP,KEEP) * 003500* //XREFOUT DD DSN=D@UDAL.OUTPUT(+1), * 003600* // DISP=(NEW,CATLG,DELETE), * 003700* // UNIT=DISK,VOL=SER=WRK005, * 003800* // SPACE=(CYL,(1,1),RLSE), * 003900* // DCB=(T.GDG.MODEL,RECFM=FB,LRECL=255, * 004000* // BLKSIZE=23460) * 004100* //SYSPROC DD DSN=SYS2.ISPF.ISPCLIB.D91136, * 004200* // DISP=(SHR,KEEP,KEEP) * 004300* //ISPPROF DD DSN=D@UDAL.BATCH.ISPF.ISPPROF, * 004400* // DISP=(SHR,KEEP,KEEP) * 004500* //ISPTLIB DD DSN=SYS2.ISPF.ISPTLIB.D91136, * 004600* // DISP=(SHR,KEEP,KEEP) * 004700* //ISPLLIB DD DSN=SYS2.ISPF.ISPLLIB.D91136, * 004800* // DISP=(SHR,KEEP,KEEP) * 004900* //ISPPLIB DD DSN=SYS2.ISPF.ISPPLIB.D91136, * 005000* // DISP=(SHR,KEEP,KEEP) * 005100* //ISPMLIB DD DSN=SYS2.ISPF.ISPMLIB.D91136, * 005200* // DISP=(SHR,KEEP,KEEP) * 005300* //ISPSLIB DD DSN=SYS2.ISPF.ISPSLIB.D91136, * 005400* // DISP=(SHR,KEEP,KEEP) * 005500* //SYSTSPRT DD SYSOUT=* * 005600* //ISPLOG DD SYSOUT=*,DCB=(LRECL=121,BLKSIZE=23474) * 005700* //SYSUDUMP DD SYSOUT=* * 005800* //SYSDBOUT DD SYSOUT=* * 005900* //SYSABOUT DD SYSOUT=* * 006000* //SYSOUT DD SYSOUT=* * 006100* //SYSOUD DD SYSOUT=* * 006200***************************************************************** 006300/**************************************************************** 006400* E N V I R O N M E N T D I V I S I O N * 006500***************************************************************** 006600 ENVIRONMENT DIVISION. 006700 006800 INPUT-OUTPUT SECTION. 006900 007000 FILE-CONTROL. 007100 007200 SELECT PROCLIBS-INPUT-FILE ASSIGN TO PROCLIBS. 007300 007400 SELECT XREF-OUTPUT-FILE ASSIGN TO XREFOUT. 007500 007600/**************************************************************** 007700* D A T A D I V I S I O N * 007800***************************************************************** 007900 DATA DIVISION. 008000 008100 FILE SECTION. 008200 008300 FD PROCLIBS-INPUT-FILE 008400 RECORD CONTAINS 80 CHARACTERS 008500 BLOCK CONTAINS 0 RECORDS 008600 LABEL RECORDS ARE STANDARD 008700 RECORDING MODE IS F 008800 DATA RECORD IS PROCLIBS-INPUT-RECORD. 008900 009000 01 PROCLIBS-INPUT-RECORD PIC X(80). 009100 009200 FD XREF-OUTPUT-FILE 009300 RECORD CONTAINS 255 CHARACTERS 009400 BLOCK CONTAINS 0 RECORDS 009500 LABEL RECORDS ARE STANDARD 009600 RECORDING MODE IS F 009700 DATA RECORD IS XREF-OUTPUT-RECORD. 009800 009900 01 XREF-OUTPUT-RECORD. 010000 05 XO-JCL-MEMBER-NAME PIC X(08). 010100 05 FILLER PIC X(01). 010200 05 XO-JCL-JOB-NAME PIC X(08). 010300 05 FILLER PIC X(01). 010400 05 XO-STEP-NAME PIC X(08). 010500 05 FILLER PIC X(01). 010600 05 XO-PROGRAM-NAME PIC X(08). 010700 05 FILLER PIC X(01). 010800 05 XO-PROC-NAME PIC X(08). 010900 05 FILLER PIC X(01). 011000 05 XO-PROCLIB-MEMBER-NAME PIC X(08). 011100 05 FILLER PIC X(01). 011200 05 XO-DD-NAME PIC X(08). 011300 05 FILLER PIC X(01). 011400 05 XO-DATASET-NAME PIC X(50). 011500 05 FILLER PIC X(01). 011600 05 XO-DATASET-DISPOSITION. 011700 10 XO-DATASET-DISP-1 PIC X(05). 011800 10 FILLER PIC X(01). 011900 10 XO-DATASET-DISP-2 PIC X(07). 012000 10 FILLER PIC X(01). 012100 10 XO-DATASET-DISP-3 PIC X(07). 012200 05 FILLER PIC X(120). 012300 012400/**************************************************************** 012500* W O R K I N G - S T O R A G E S E C T I O N * 012600***************************************************************** 012700 WORKING-STORAGE SECTION. 012800***************************************************************** 012900* A C C U M U L A T O R S * 013000***************************************************************** 013100 01 ACCUMULATORS. 013200 05 FILLER PIC X(13) VALUE 013300 'ACCUMULATORS:'. 013400/**************************************************************** 013500* C O N S T A N T S * 013600***************************************************************** 013700 01 CONSTANTS. 013800 05 FILLER PIC X(10) VALUE 013900 'CONSTANTS:'. 014000 05 C-ISPF PIC X(07) VALUE 'ISPLINK'. 014100 05 C-COMMA PIC X(01) VALUE ','. 014200 05 C-DDNAME-DELIMITER PIC X(04) VALUE 'DDN='. 014300 05 C-DATASET-DELIMITER PIC X(04) VALUE 'DSN='. 014400 05 C-NULL-PLACE-HOLDER PIC X(01) VALUE ' '. 014500 05 C-ISPF-CONSTANTS. 014600 10 C-ISPF-SERVICES-AND-PARAMETERS. 014700 15 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 014800 15 C-CONTROL PIC X(08) VALUE 'CONTROL '. 014900 15 C-VGET PIC X(08) VALUE 'VGET '. 015000 15 C-LMINIT PIC X(08) VALUE 'LMINIT '. 015100 15 C-LMOPEN PIC X(08) VALUE 'LMOPEN '. 015200 15 C-LMCLOSE PIC X(08) VALUE 'LMCLOSE '. 015300 15 C-LMFREE PIC X(08) VALUE 'LMFREE '. 015400 15 C-LMGET PIC X(08) VALUE 'LMGET '. 015500 15 C-LMMLIST PIC X(08) VALUE 'LMMLIST '. 015600 15 C-LMMFIND PIC X(08) VALUE 'LMMFIND '. 015700 15 C-LIST-OPTION PIC X(08) VALUE 'LIST '. 015800 15 C-FREE-OPTION PIC X(08) VALUE 'FREE '. 015900 15 C-ERRORS-OPTION PIC X(08) VALUE 'ERRORS '. 016000 15 C-RETURN-OPTION PIC X(08) VALUE 'RETURN '. 016100 15 C-JCL-DDNAME PIC X(08) VALUE 'JCLLIB '. 016200 15 C-PROC-DDNAME PIC X(08) VALUE 'PROCLIBS'. 016300 15 C-INVAR-MODE PIC X(08) VALUE 'INVAR '. 016400 15 C-JCL-MAX-LINE-LENGTH PIC S9(06) COMP VALUE +80. 016500***************************************************************** 016600* NOTE: THE ORDER OF THE ISPF VARIABLE NAMES IN THE "VALUE" * 016700* CLAUSE OF THE NEXT DATA ELEMENT "C-ISPF-VARIABLE-NAMES" * 016800* MUST MATCH THE ORDER OF THE ELEMENTARY ITEMS DEFINED * 016900* IN "C-ISPF-VARIABLE-LENGTHS", "C-ISPF-VARIABLE-FORMATS",* 017000* "C-ISPF-VARIABLES", AND "W-ISPF-VARIABLES". * 017100***************************************************************** 017200 10 C-ISPF-VARIABLE-NAMES. 017300 15 FILLER PIC X(41) VALUE 017400 '(PROCDID PROCDSN PROCMBR PROCLINE JCLDID '. 017500 15 FILLER PIC X(37) VALUE 017600 'JCLDSN JCLMBR JCLLINE ZERRMSG ZERRLM '. 017700 15 FILLER PIC X(17) VALUE 017800 'PROCLLEN JCLLLEN)'. 017900 10 C-ISPF-VARIABLES. 018000 15 C-PROCLIB-DATAID PIC X(08) VALUE 'PROCDID '. 018100 15 C-PROCLIB-DSN PIC X(08) VALUE 'PROCDSN '. 018200 15 C-PROCLIB-MEMBER PIC X(08) VALUE 'PROCMBR '. 018300 15 C-PROC-DATA-LINE PIC X(08) VALUE 'PROCLINE'. 018400 15 C-JCLLIB-DATAID PIC X(08) VALUE 'JCLDID '. 018500 15 C-JCLLIB-DSN PIC X(08) VALUE 'JCLDSN '. 018600 15 C-JCLLIB-MEMBER PIC X(08) VALUE 'JCLMBR '. 018700 15 C-JCL-DATA-LINE PIC X(08) VALUE 'JCLLINE '. 018800 15 C-ZERRMSG PIC X(08) VALUE 'ZERRMSG '. 018900 15 C-ZERRLM PIC X(08) VALUE 'ZERRLM '. 019000 15 C-PROC-LINE-LENGTH PIC X(08) VALUE 'PROCLLEN'. 019100 15 C-JCL-LINE-LENGTH PIC X(08) VALUE 'JCLLLEN '. 019200 10 C-ISPF-VARIABLE-LENGTHS COMP. 019300 15 C-PROCLIB-DATAID-L PIC S9(06) VALUE +8. 019400 15 C-PROCLIB-DSN-L PIC S9(06) VALUE +50. 019500 15 C-PROCLIB-MEMBER-L PIC S9(06) VALUE +8. 019600 15 C-PROC-DATA-LINE-L PIC S9(06) VALUE +80. 019700 15 C-JCLLIB-DATAID-L PIC S9(06) VALUE +8. 019800 15 C-JCLLIB-DSN-L PIC S9(06) VALUE +50. 019900 15 C-JCLLIB-MEMBER-L PIC S9(06) VALUE +8. 020000 15 C-JCL-DATA-LINE-L PIC S9(06) VALUE +80. 020100 15 C-ZERRMSG-L PIC S9(06) VALUE +8. 020200 15 C-ZERRLM-L PIC S9(06) VALUE +512. 020300 15 C-PROC-LINE-LENGTH-L PIC S9(06) VALUE +8. 020400 15 C-JCL-LINE-LENGTH-L PIC S9(06) VALUE +8. 020500 10 C-ISPF-VARIABLE-FORMATS. 020600 15 C-PROCLIB-DATAID-F PIC X(08) VALUE 'CHAR '. 020700 15 C-PROCLIB-DSN-F PIC X(08) VALUE 'CHAR '. 020800 15 C-PROCLIB-MEMBER-F PIC X(08) VALUE 'CHAR '. 020900 15 C-PROC-DATA-LINE-F PIC X(08) VALUE 'CHAR '. 021000 15 C-JCLLIB-DATAID-F PIC X(08) VALUE 'CHAR '. 021100 15 C-JCLLIB-DSN-F PIC X(08) VALUE 'CHAR '. 021200 15 C-JCLLIB-MEMBER-F PIC X(08) VALUE 'CHAR '. 021300 15 C-JCL-DATA-LINE-F PIC X(08) VALUE 'CHAR '. 021400 15 C-ZERRMSG-F PIC X(08) VALUE 'CHAR '. 021500 15 C-ZERRLM-F PIC X(08) VALUE 'CHAR '. 021600 15 C-PROC-LINE-LENGTH-F PIC X(08) VALUE 'CHAR '. 021700 15 C-JCL-LINE-LENGTH-F PIC X(08) VALUE 'CHAR '. 021800/**************************************************************** 021900* S W I T C H E S * 022000***************************************************************** 022100 01 SWITCHES. 022200 05 FILLER PIC X(09) VALUE 022300 'SWITCHES:'. 022400 05 S-EOF-PROCLIBS PIC X(01) VALUE 'N'. 022500 88 S-NO-MORE-PROC-DEFINITIONS VALUE 'Y'. 022600 05 S-EOD-JCLLIB PIC X(01) VALUE 'N'. 022700 88 S-NO-MORE-JCL-MEMBERS VALUE 'Y'. 022800 05 S-VALID-JOB-SWITCH PIC X(01) VALUE 'N'. 022900 88 S-JOB-NAME-IS-VALID VALUE 'Y'. 023000 88 S-JOB-NAME-IS-NOT-VALID VALUE 'N'. 023100/**************************************************************** 023200* W O R K A R E A S * 023300***************************************************************** 023400 01 WORK-AREAS. 023500 05 FILLER PIC X(11) VALUE 023600 'WORK AREAS:'. 023700 05 W-DDNAME PIC X(08) VALUE SPACES. 023800 05 W-DATASET PIC X(50) VALUE SPACES. 023900 05 W-CURRENT-PROCLIB-DD PIC X(08) VALUE SPACES. 024000 05 W-CURRENT-PROCLIB-DD-BYTE REDEFINES 024100 W-CURRENT-PROCLIB-DD OCCURS 8 TIMES 024200 INDEXED BY W-CPD-NDX. 024300 10 FILLER PIC X(01). 024400 05 W-JOBPARM-TALLY PIC S9(03) COMP-3. 024500 88 W-A-JOBPARM-STATEMENT-IS-FOUND VALUE +1 THRU +999. 024600 05 W-EXEC-TALLY PIC S9(03) COMP-3. 024700 88 W-AN-EXEC-STATEMENT-IS-FOUND VALUE +1 THRU +999. 024800 05 W-UNSTRING-AREA. 024900 10 W-UNSTRING-INPUT-LINE PIC X(80) VALUE SPACES. 025000 10 W-UNSTRING-POINTER PIC S9(05) COMP-3 VALUE +0. 025100 10 W-UNSTRING-TALLY PIC S9(05) COMP-3 VALUE +0. 025200 05 W-ISPF-VARIABLES. 025300 10 W-PROCLIB-DATAID PIC X(08) VALUE SPACES. 025400 10 W-PROCLIB-DSN PIC X(50) VALUE SPACES. 025500 10 W-PROCLIB-MEMBER PIC X(08) VALUE SPACES. 025600 10 W-PROC-DATA-LINE PIC X(80) VALUE SPACES. 025700 10 W-JCLLIB-DATAID PIC X(08) VALUE SPACES. 025800 10 W-JCLLIB-DSN PIC X(50) VALUE SPACES. 025900 10 W-JCLLIB-MEMBER PIC X(08) VALUE SPACES. 026000 10 W-JCL-DATA-LINE PIC X(80) VALUE SPACES. 026100 10 W-ZERRMSG PIC X(08) VALUE SPACES. 026200 10 W-ZERRLM PIC X(512) VALUE SPACES. 026300 10 W-PROC-LINE-LENGTH PIC X(08) VALUE SPACES. 026400 10 W-JCL-LINE-LENGTH PIC X(08) VALUE SPACES. 026500/**************************************************************** 026600* P R I N T L I N E S * 026700***************************************************************** 026800 01 PRINT-LINES. 026900 05 FILLER PIC X(12) VALUE 027000 'PRINT LINES:'. 027100/**************************************************************** 027200* T A B L E S * 027300***************************************************************** 027400 01 TABLES. 027500 05 FILLER PIC X(07) VALUE 027600 'TABLES:'. 027700 027800 05 T-PROCLIB-TABLE-SIZE PIC S9(05) COMP-3 VALUE +100. 027900 05 T-PROCLIB-INFORMATION. 028000 10 T-PROCLIB-TABLE OCCURS 100 TIMES 028100 INDEXED BY T-PROCLIB-NDX. 028200 15 T-PROCLIB-DDNAME PIC X(08). 028300 15 T-PROCLIB-DATASET PIC X(50). 028400 028500 05 T-PARSE-TABLE-SIZE PIC S9(05) COMP-3 VALUE +10. 028600 05 T-PARSE-AREA. 028700 10 T-PARSE-TABLE OCCURS 10 TIMES 028800 INDEXED BY T-PARSE-NDX1 028900 T-PARSE-NDX2. 029000 15 T-PARSE-DATA PIC X(80). 029100 15 T-PARSE-DELIMITER PIC X(80). 029200 029300 05 T-PARM-TABLE-SIZE PIC S9(05) COMP-3 VALUE +10. 029400 05 T-PARM-AREA. 029500 10 T-PARM-TABLE OCCURS 10 TIMES 029600 INDEXED BY T-PARM-NDX1 029700 T-PARM-NDX2. 029800 15 T-PARM PIC X(50). 029900 15 T-PARM-BYTE REDEFINES T-PARM 030000 OCCURS 50 TIMES 030100 INDEXED BY T-PARM-BYTE-NDX1 030200 T-PARM-BYTE-NDX2. 030300 20 FILLER PIC X(01). 030400 030500 05 T-JCL-TABLE-SIZE PIC S9(05) COMP-3 VALUE +1000. 030600 05 T-CURRENT-JCL. 030700 10 T-JCL-TABLE OCCURS 1000 TIMES 030800 INDEXED BY T-JCL-NDX1 030900 T-JCL-NDX2 031000 T-JCL-NDX-LAST. 031100 15 T-JCL-DATA-LINE PIC X(80). 031200 15 T-JCL-BYTE REDEFINES T-JCL-DATA-LINE 031300 OCCURS 80 TIMES 031400 INDEXED BY T-JCL-BYTE-NDX1 031500 T-JCL-BYTE-NDX2. 031600 20 FILLER PIC X(01). 031700 031800 05 T-PROC-TABLE-SIZE PIC S9(05) COMP-3 VALUE +1000. 031900 05 T-CURRENT-PROC. 032000 10 T-PROC-TABLE OCCURS 1000 TIMES 032100 INDEXED BY T-PROC-NDX1 032200 T-PROC-NDX2 032300 T-PROC-NDX-LAST. 032400 15 T-PROC-DATA-LINE PIC X(80). 032500 15 T-PROC-BYTE REDEFINES T-PROC-DATA-LINE 032600 OCCURS 80 TIMES 032700 INDEXED BY T-PROC-BYTE-NDX1 032800 T-PROC-BYTE-NDX2. 032900 20 FILLER PIC X(01). 033000 033100 05 T-INPROC-SUB-TABLE-SIZE PIC S9(05) COMP-3 VALUE +255. 033200 05 T-INSTREAM-PROC-SUBSCRIPT-AREA. 033300 10 FILLER OCCURS 255 TIMES 033400 INDEXED BY T-INPROC-NDX. 033500 15 T-INSTREAM-PROC-SUB PIC S9(08) COMP. 033600/**************************************************************** 033700* P R O C E D U R E D I V I S I O N * 033800***************************************************************** 033900 PROCEDURE DIVISION. 034000***************************************************************** 034100* S0000-CONTROL * 034200***************************************************************** 034300 S0000-CONTROL SECTION. 034400 034500 PERFORM S1000-INITIALIZATION. 034600 034610 DISPLAY ' MEMBER JOB STEP ' 034620 'PROGRAM PROC PROCMBR DD DATASET'. 034700 PERFORM S2000-PROCESS-JCL UNTIL S-NO-MORE-JCL-MEMBERS. 034800 034900 PERFORM S3000-FINALIZATION. 035000 035100 GOBACK. 035200 035300 S0000-EXIT. 035400 EXIT. 035500/**************************************************************** 035600* S1000-INITIALIZATION * 035700* - OPEN FILES * 035800* - LOAD THE PROCLIB TABLE WITH PROC DD AND DATASET NAMES * 035900* - ESTABLISH ADDRESSABILITY TO THE ISPF VARIABLES * 036000* - USE ISPF "LM" FACILITIES TO INITIALIZE THE PROCESSING OF * 036100* THE EXECUTE JCL LIBRARY TO BE PROCESSED. * 036200* - USE ISPF "LM" FACILITIES TO POINT TO THE FIRST MEMBER. * 036300***************************************************************** 036400 S1000-INITIALIZATION SECTION. 036500 036600 OPEN INPUT PROCLIBS-INPUT-FILE. 036700 OPEN OUTPUT XREF-OUTPUT-FILE. 036800 036900 READ PROCLIBS-INPUT-FILE 037000 AT END 037100 SET S-NO-MORE-PROC-DEFINITIONS TO TRUE 037200 END-READ. 037300 037400 MOVE SPACES TO T-PROCLIB-INFORMATION. 037500 037600 PERFORM VARYING T-PROCLIB-NDX FROM +1 BY +1 037700 UNTIL S-NO-MORE-PROC-DEFINITIONS 037800 OR T-PROCLIB-NDX > T-PROCLIB-TABLE-SIZE 037900 MOVE SPACES TO T-PARSE-AREA 038000 UNSTRING PROCLIBS-INPUT-RECORD 038100 DELIMITED BY C-DDNAME-DELIMITER OR 038200 C-DATASET-DELIMITER OR 038300 ALL C-COMMA OR 038400 ALL SPACES 038500 INTO T-PARSE-DATA (1) 038600 DELIMITER IN T-PARSE-DELIMITER (1) 038700 T-PARSE-DATA (2) 038800 DELIMITER IN T-PARSE-DELIMITER (2) 038900 T-PARSE-DATA (3) 039000 DELIMITER IN T-PARSE-DELIMITER (3) 039100 T-PARSE-DATA (4) 039200 DELIMITER IN T-PARSE-DELIMITER (4) 039300 T-PARSE-DATA (5) 039400 DELIMITER IN T-PARSE-DELIMITER (5) 039500 T-PARSE-DATA (6) 039600 DELIMITER IN T-PARSE-DELIMITER (6) 039700 T-PARSE-DATA (7) 039800 DELIMITER IN T-PARSE-DELIMITER (7) 039900 T-PARSE-DATA (8) 040000 DELIMITER IN T-PARSE-DELIMITER (8) 040100 T-PARSE-DATA (9) 040200 DELIMITER IN T-PARSE-DELIMITER (9) 040300 T-PARSE-DATA (10) 040400 DELIMITER IN T-PARSE-DELIMITER (10) 040500 PERFORM VARYING T-PARSE-NDX1 FROM +1 BY +1 040600 UNTIL T-PARSE-NDX1 > T-PARSE-TABLE-SIZE 040700 SET T-PARSE-NDX2 TO T-PARSE-NDX1 040800 IF T-PARSE-NDX1 > +1 040900 SET T-PARSE-NDX2 DOWN BY +1 041000 END-IF 041100 EVALUATE TRUE 041200 WHEN T-PARSE-DELIMITER (T-PARSE-NDX2) = 041300 C-DDNAME-DELIMITER 041400 MOVE T-PARSE-DATA (T-PARSE-NDX1) TO 041500 T-PROCLIB-DDNAME (T-PROCLIB-NDX) 041600 WHEN T-PARSE-DELIMITER (T-PARSE-NDX2) = 041700 C-DATASET-DELIMITER 041800 MOVE T-PARSE-DATA (T-PARSE-NDX1) TO 041900 T-PROCLIB-DATASET (T-PROCLIB-NDX) 042000 END-EVALUATE 042100 END-PERFORM 042200 READ PROCLIBS-INPUT-FILE 042300 AT END 042400 SET S-NO-MORE-PROC-DEFINITIONS TO TRUE 042500 END-READ 042600 END-PERFORM. 042700 042800 DISPLAY '*************************************************'. 042900 DISPLAY '* THE FOLLOWING PROCLIB CONCATENATIONS WERE *'. 043000 DISPLAY '* USED IN THE PROCESSING OF THIS JCL LIBRARY. *'. 043100 DISPLAY '*************************************************'. 043200 043300 PERFORM VARYING T-PROCLIB-NDX FROM +1 BY +1 043400 UNTIL T-PROCLIB-NDX > T-PROCLIB-TABLE-SIZE 043500 IF T-PROCLIB-DDNAME (T-PROCLIB-NDX) = SPACES 043600 SET T-PROCLIB-NDX TO T-PROCLIB-TABLE-SIZE 043700 ELSE 043800 MOVE SPACES TO W-DATASET 043900 STRING T-PROCLIB-DATASET (T-PROCLIB-NDX) 044000 C-COMMA 044100 DELIMITED BY SPACES 044200 INTO W-DATASET 044300 IF T-PROCLIB-DDNAME (T-PROCLIB-NDX) NOT = 044400 W-DDNAME 044500 DISPLAY ' ' 044600 MOVE T-PROCLIB-DDNAME (T-PROCLIB-NDX) TO 044700 W-DDNAME 044800 DISPLAY '//' W-DDNAME ' DD DSN=' 044900 W-DATASET 045000 ELSE 045100 DISPLAY '// DD DSN=' 045200 W-DATASET 045300 END-IF 045400 DISPLAY '// DISP=(SHR,KEEP,KEEP)' 045500 END-IF 045600 END-PERFORM. 045700 045800 CLOSE PROCLIBS-INPUT-FILE. 045900 046000 CALL C-ISPF USING C-CONTROL C-ERRORS-OPTION C-RETURN-OPTION. 046100 046200 CALL C-ISPF USING C-VDEFINE C-ISPF-VARIABLE-NAMES, 046300 W-ISPF-VARIABLES, 046400 C-ISPF-VARIABLE-FORMATS, 046500 C-ISPF-VARIABLE-LENGTHS, 046600 C-LIST-OPTION. 046700 046800 IF RETURN-CODE > 4 046900 DISPLAY 'VDEFINE RETURN CODE = ' RETURN-CODE 047000 CALL C-ISPF USING C-VGET C-ZERRMSG 047100 CALL C-ISPF USING C-VGET C-ZERRLM 047200 DISPLAY W-ZERRMSG ' ' W-ZERRLM 047300 PERFORM S3000-FINALIZATION 047400 END-IF. 047500 047600 PERFORM S9000-LMINIT-LMMLIST. 047700 047800 S1000-EXIT. 047900 EXIT. 048000/**************************************************************** 048100* S2000-PROCESS-JCL * 048200***************************************************************** 048300 S2000-PROCESS-JCL SECTION. 048400 048500 CALL C-ISPF USING C-LMMFIND W-JCLLIB-DATAID, 048600 W-JCLLIB-MEMBER. 048700 048800 IF RETURN-CODE = +0 048900 MOVE SPACES TO T-CURRENT-JCL 049000 MOVE +0 TO RETURN-CODE 049100 CALL C-ISPF USING C-LMGET W-JCLLIB-DATAID, 049200 C-INVAR-MODE, 049300 C-JCL-DATA-LINE, 049400 C-JCL-LINE-LENGTH, 049500 C-JCL-MAX-LINE-LENGTH 049600 PERFORM VARYING T-JCL-NDX1 FROM +1 BY +1 049700 UNTIL RETURN-CODE > +4 049800 OR T-JCL-NDX1 > T-JCL-TABLE-SIZE 049900 MOVE W-JCL-DATA-LINE TO 050000 T-JCL-DATA-LINE (T-JCL-NDX1) 050100 CALL C-ISPF USING C-LMGET 050200 W-JCLLIB-DATAID, 050300 C-INVAR-MODE, 050400 C-JCL-DATA-LINE, 050500 C-JCL-LINE-LENGTH, 050600 C-JCL-MAX-LINE-LENGTH 050700 END-PERFORM 050800 SET T-JCL-NDX-LAST TO T-JCL-NDX1 050900 SET T-JCL-NDX-LAST DOWN BY +1 051000 CALL C-ISPF USING C-LMMLIST W-JCLLIB-DATAID, 051100 C-FREE-OPTION 051200 CALL C-ISPF USING C-LMCLOSE W-JCLLIB-DATAID 051300 CALL C-ISPF USING C-LMFREE W-JCLLIB-DATAID, 051400 C-NULL-PLACE-HOLDER, 051500 C-NULL-PLACE-HOLDER, 051600 C-NULL-PLACE-HOLDER, 051700 C-NULL-PLACE-HOLDER, 051800 C-NULL-PLACE-HOLDER, 051900 C-NULL-PLACE-HOLDER, 052000 C-NULL-PLACE-HOLDER, 052100 C-JCL-DDNAME 052200 IF T-JCL-NDX1 > T-JCL-TABLE-SIZE 052300 DISPLAY '*************************************' 052400 DISPLAY '* THE EXECUTE JCL TABLE SIZE HAS *' 052500 DISPLAY '* BEEN EXCEEDED WHILE PROCESSING *' 052600 DISPLAY '* MEMBER: ' W-JCLLIB-MEMBER 052700 ' *' 052800 DISPLAY '* INCREASE THE TABLE SIZE FOR *' 052900 DISPLAY '* "T-JCL-TABLE" AND ALSO THE VALUE *' 053000 DISPLAY '* IN "T-JCL-TABLE-SIZE". *' 053100 DISPLAY '*************************************' 053200 MOVE +2000 TO RETURN-CODE 053300 PERFORM S3000-FINALIZATION 053400 ELSE 053500 PERFORM S4000-PROCESS-JCL 053600 END-IF 053700 ELSE 053800 DISPLAY 'LMMFIND RETURN CODE = ' RETURN-CODE 053900 CALL C-ISPF USING C-VGET C-ZERRMSG 054000 CALL C-ISPF USING C-VGET C-ZERRLM 054100 DISPLAY W-ZERRMSG ' ' W-ZERRLM 054200 PERFORM S3000-FINALIZATION 054300 END-IF. 054400 054500 PERFORM S9000-LMINIT-LMMLIST. 054600 054700 CALL C-ISPF USING C-LMMLIST W-JCLLIB-DATAID, 054800 C-LIST-OPTION, 054900 C-JCLLIB-MEMBER. 055000 055100 EVALUATE RETURN-CODE 055200 WHEN +0 055300 CONTINUE 055400 WHEN +4 055500 SET S-NO-MORE-JCL-MEMBERS TO TRUE 055600 WHEN +8 055700 SET S-NO-MORE-JCL-MEMBERS TO TRUE 055800 WHEN OTHER 055900 DISPLAY 'LMMLIST RETURN CODE = ' RETURN-CODE 056000 CALL C-ISPF USING C-VGET C-ZERRMSG 056100 CALL C-ISPF USING C-VGET C-ZERRLM 056200 DISPLAY W-ZERRMSG ' ' W-ZERRLM 056300 PERFORM S3000-FINALIZATION 056400 END-EVALUATE. 056500 056600 S2000-EXIT. 056700 EXIT. 056800/**************************************************************** 056900* S3000-FINALIZATION * 057000***************************************************************** 057100 S3000-FINALIZATION SECTION. 057200 057300 CLOSE XREF-OUTPUT-FILE. 057400 057500 S3000-EXIT. 057600 EXIT. 057700/**************************************************************** 057800* S4000-PROCESS-JCL * 057900***************************************************************** 058000 S4000-PROCESS-JCL SECTION. 058100 058300 PERFORM S4100-EXTRACT-JOB-NAME. 058400 058500 IF S-JOB-NAME-IS-VALID 058600 MOVE SPACES TO XREF-OUTPUT-RECORD 058700 SET T-INPROC-NDX TO +0 058800 MOVE ZEROS TO T-INSTREAM-PROC-SUBSCRIPT-AREA 058900 PERFORM S4200-DETERMINE-PROCLIB 059000 MOVE W-JCLLIB-MEMBER TO XO-JCL-MEMBER-NAME 059100 MOVE T-PARM (1) TO XO-JCL-JOB-NAME 059300 PERFORM S5000-PROCESS-JOB 059400 VARYING T-JCL-NDX1 FROM T-JCL-NDX1 BY +1 059500 UNTIL T-JCL-NDX1 > T-JCL-NDX-LAST 059600 IF XO-STEP-NAME = SPACES 059700 DISPLAY '****************************************' 059800 DISPLAY '* MEMBER : ' W-JCLLIB-MEMBER 059900 ' HAS NO JOB STEPS. *' 060000 DISPLAY '****************************************' 060100 END-IF 060200 ELSE 060300 DISPLAY '********************************************' 060400 DISPLAY '* JCL MEMBER : ' W-JCLLIB-MEMBER 060500 ' IS NOT A VALID JOB.*' 060600 DISPLAY '* NO JOB NAME COULD BE FOUND ON THE FIRST *' 060700 DISPLAY '* LINE. *' 060800 DISPLAY '********************************************' 060900 END-IF. 061000 061100 S4000-EXIT. 061200 EXIT. 061300/**************************************************************** 061400* S4100-EXTRACT-JOB-NAME * 061500***************************************************************** 061600 S4100-EXTRACT-JOB-NAME SECTION. 061700 061800 SET S-JOB-NAME-IS-NOT-VALID TO TRUE. 061900 MOVE SPACES TO T-PARM-AREA. 062000 SET T-PARM-BYTE-NDX1 TO +0. 062100 SET T-PARM-NDX1 TO +1. 062200 062300 IF T-JCL-BYTE (1, 1) = '/' AND 062400 T-JCL-BYTE (1, 2) = '/' AND 062500 T-JCL-BYTE (1, 3) NOT = ' ' AND 062600 T-JCL-BYTE (1, 3) NOT = '*' 062700 PERFORM VARYING T-JCL-BYTE-NDX1 FROM +3 BY +1 062800 UNTIL T-PARM-NDX1 > +2 OR 062900 T-JCL-BYTE-NDX1 > +80 063000 EVALUATE TRUE 063100 WHEN T-JCL-BYTE (1, T-JCL-BYTE-NDX1) > SPACES 063200 SET T-PARM-BYTE-NDX1 UP BY +1 063300 MOVE T-JCL-BYTE (1, T-JCL-BYTE-NDX1) TO 063400 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 063500 WHEN T-JCL-BYTE (1, T-JCL-BYTE-NDX1) = SPACES 063600 PERFORM VARYING T-JCL-BYTE-NDX1 063700 FROM T-JCL-BYTE-NDX1 BY +1 063800 UNTIL T-JCL-BYTE (1, T-JCL-BYTE-NDX1) > ' ' 063900 OR T-JCL-BYTE-NDX1 > +80 064000 SET T-JCL-BYTE-NDX1 TO 064100 T-JCL-BYTE-NDX1 064200 END-PERFORM 064300 SET T-JCL-BYTE-NDX1 DOWN BY +1 064400 SET T-PARM-NDX1 UP BY +1 064500 SET T-PARM-BYTE-NDX1 TO +0 064600 END-EVALUATE 064700 END-PERFORM 064800 END-IF. 064900 065000 IF T-PARM (1) > SPACES AND T-PARM (2) = 'JOB' 065100 SET S-JOB-NAME-IS-VALID TO TRUE 065200 END-IF. 065300 065400 S4100-EXIT. 065500 EXIT. 065600/**************************************************************** 065700* S4200-DETERMINE-PROCLIB * 065800***************************************************************** 065900 S4200-DETERMINE-PROCLIB SECTION. 066000 066100 MOVE 'PROC00' TO W-CURRENT-PROCLIB-DD. 066200 066300 MOVE +0 TO W-JOBPARM-TALLY 066400 W-EXEC-TALLY. 066500 066600 PERFORM VARYING T-JCL-NDX1 FROM +2 BY +1 066700 UNTIL W-A-JOBPARM-STATEMENT-IS-FOUND OR 066800 W-AN-EXEC-STATEMENT-IS-FOUND OR 066900 T-JCL-NDX1 > T-JCL-NDX-LAST 067000 SET T-JCL-NDX2 TO T-JCL-NDX1 067100 IF T-JCL-BYTE (T-JCL-NDX1, 1) = '/' AND 067200 T-JCL-BYTE (T-JCL-NDX1, 2) > ' ' AND 067300 T-JCL-BYTE (T-JCL-NDX1, 3) NOT = ' ' AND 067400 T-JCL-BYTE (T-JCL-NDX1, 3) NOT = '*' 067500 INSPECT T-JCL-DATA-LINE (T-JCL-NDX1) 067600 TALLYING W-JOBPARM-TALLY 067700 FOR ALL '/*JOBPARM ' 067800 INSPECT T-JCL-DATA-LINE (T-JCL-NDX1) 067900 TALLYING W-EXEC-TALLY 068000 FOR ALL ' EXEC ' 068100 END-IF 068200 END-PERFORM. 068300 068400 SET T-JCL-NDX1 TO T-JCL-NDX2. 068500 068600 IF W-A-JOBPARM-STATEMENT-IS-FOUND 068700 SET W-CPD-NDX TO +1 068800 PERFORM VARYING T-JCL-BYTE-NDX1 FROM +11 BY +1 068900 UNTIL W-CPD-NDX > +1 OR 069000 T-JCL-BYTE-NDX1 > +69 069100 EVALUATE TRUE 069200 WHEN 069300 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'P' AND 069400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'R' AND 069500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'O' AND 069600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'C' AND 069700 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = 'L' AND 069800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 5) = 'I' AND 069900 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 6) = 'B' AND 070000 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 7) = '=' 070100 MOVE SPACES TO W-CURRENT-PROCLIB-DD 070200 SET T-JCL-BYTE-NDX1 UP BY +8 070300 SET W-CPD-NDX TO +1 070400 PERFORM VARYING T-JCL-BYTE-NDX1 FROM 070500 T-JCL-BYTE-NDX1 BY +1 070600 UNTIL T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 070700 = SPACE OR 070800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 070900 = ',' 071000 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 071100 TO W-CURRENT-PROCLIB-DD-BYTE (W-CPD-NDX) 071200 SET W-CPD-NDX UP BY +1 071300 END-PERFORM 071400 WHEN 071500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'P' AND 071600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = '=' 071700 MOVE SPACES TO W-CURRENT-PROCLIB-DD 071800 SET T-JCL-BYTE-NDX1 UP BY +2 071900 SET W-CPD-NDX TO +1 072000 PERFORM VARYING T-JCL-BYTE-NDX1 FROM 072100 T-JCL-BYTE-NDX1 BY +1 072200 UNTIL T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 072300 = SPACE OR 072400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 072500 = ',' 072600 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) 072700 TO W-CURRENT-PROCLIB-DD-BYTE (W-CPD-NDX) 072800 SET W-CPD-NDX UP BY +1 072900 END-PERFORM 073000 END-EVALUATE 073100 END-PERFORM 073200 END-IF. 073300 073400 S4200-EXIT. 073500 EXIT. 073600/**************************************************************** 073700* S5000-PROCESS-JOB * 073800***************************************************************** 073900 S5000-PROCESS-JOB SECTION. 074000 074100 PERFORM VARYING T-JCL-BYTE-NDX1 FROM +1 BY +1 074200 UNTIL (T-JCL-BYTE-NDX1 > +71) OR 074210 ((T-JCL-BYTE (T-JCL-NDX1, 1) = '/') AND 074211 (T-JCL-BYTE (T-JCL-NDX1, 2) = '/') AND 074212 (T-JCL-BYTE (T-JCL-NDX1, 3) = '*')) 074300 EVALUATE TRUE 074400 WHEN 074500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = ' ' AND 074600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'E' AND 074700 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'X' AND 074800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'E' AND 074900 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = 'C' AND 075000 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 5) = ' ' 075100 PERFORM S5100-PROCESS-JOB-STEP 075200 WHEN 075300 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = ' ' AND 075400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'P' AND 075500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'R' AND 075600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'O' AND 075700 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = 'C' AND 075800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 5) = ' ' 075900 SET T-INPROC-NDX UP BY +1 076000 SET T-INSTREAM-PROC-SUB (T-INPROC-NDX) TO T-JCL-NDX1 076100 WHEN 076200 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = ' ' AND 076300 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'D' AND 076400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'D' AND 076500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = ' ' 076510 IF XO-DATASET-NAME > SPACES 076520 PERFORM S6000-WRITE 076530 MOVE SPACES TO XO-DATASET-NAME 076531 XO-DATASET-DISPOSITION 076550 END-IF 076600 PERFORM S5200-PROCESS-DD 076700 WHEN 076800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'D' AND 076900 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'S' AND 077000 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'N' AND 077100 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = '=' 077110 SET T-JCL-BYTE-NDX1 UP BY +4 077200 PERFORM S5300-PROCESS-DSN 077210 WHEN 077220 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'D' AND 077230 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'S' AND 077240 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'N' AND 077241 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'A' AND 077242 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = 'M' AND 077243 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 5) = 'E' AND 077250 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 6) = '=' 077251 SET T-JCL-BYTE-NDX1 UP BY +7 077260 PERFORM S5300-PROCESS-DSN 077300 WHEN 077400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'D' AND 077500 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'I' AND 077600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'S' AND 077700 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'P' AND 077800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = '=' 077900 PERFORM S5400-PROCESS-DISP 078000 END-EVALUATE 078100 END-PERFORM. 078230 078300 S5000-EXIT. 078400 EXIT. 078500/**************************************************************** 078600* S5100-PROCESS-JOB-STEP * 078700***************************************************************** 078800 S5100-PROCESS-JOB-STEP SECTION. 078900 078910 PERFORM S5130-EXTRACT-STEP-NAME. 078920 MOVE T-PARM (1) TO XO-STEP-NAME. 078930 079000 SET T-JCL-BYTE-NDX1 UP BY +6. 079100 079200 PERFORM VARYING T-JCL-BYTE-NDX1 FROM T-JCL-BYTE-NDX1 BY +1 079300 UNTIL T-JCL-BYTE-NDX1 > +71 079800 EVALUATE TRUE 079900 WHEN 080000 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'P' AND 080100 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'G' AND 080200 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'M' AND 080300 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = '=' 080400 PERFORM S5110-EXTRACT-PROGRAM-NAME 080410 MOVE T-PARM (1) TO XO-PROGRAM-NAME 080500 WHEN 080600 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = 'P' AND 080700 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 1) = 'R' AND 080800 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 2) = 'O' AND 080900 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 3) = 'C' AND 081000 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1 + 4) = '=' 081100 SET T-JCL-BYTE-NDX1 UP BY +5 081200 PERFORM S5120-EXTRACT-PROC-NAME 081210 MOVE T-PARM (1) TO XO-PROC-NAME 081300 WHEN 081400 T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) > SPACES 081500 PERFORM S5120-EXTRACT-PROC-NAME 081510 MOVE T-PARM (1) TO XO-PROC-NAME 081600 END-EVALUATE 081700 END-PERFORM. 081800 081900 S5100-EXIT. 082000 EXIT. 082100/**************************************************************** 082200* S5110-EXTRACT-PROGRAM-NAME * 082300***************************************************************** 082400 S5110-EXTRACT-PROGRAM-NAME SECTION. 082500 082600 SET T-JCL-BYTE-NDX1 UP BY +4. 082601 INITIALIZE T-PARM-AREA. 082602 SET T-PARM-NDX1 TO +1. 082603 SET T-PARM-BYTE-NDX1 TO +1. 082700 082800 PERFORM VARYING T-JCL-BYTE-NDX1 FROM T-JCL-BYTE-NDX1 BY +1 082900 UNTIL T-JCL-BYTE-NDX1 > +71 083000 EVALUATE TRUE 083200 WHEN T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = SPACE 083210 SET T-JCL-BYTE-NDX1 TO +72 083300 WHEN T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = C-COMMA 083400 SET T-JCL-BYTE-NDX1 TO +72 083700 WHEN OTHER 083800 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) TO 083900 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 084000 SET T-PARM-BYTE-NDX1 UP BY +1 084800 END-EVALUATE 084900 END-PERFORM. 085100 085200 S5110-EXIT. 085300 EXIT. 085310/**************************************************************** 085320* S5120-EXTRACT-PROC-NAME * 085330***************************************************************** 085340 S5120-EXTRACT-PROC-NAME SECTION. 085350 085360 INITIALIZE T-PARM-AREA. 085370 SET T-PARM-NDX1 TO +1. 085380 SET T-PARM-BYTE-NDX1 TO +1. 085390 085400 PERFORM VARYING T-JCL-BYTE-NDX1 FROM T-JCL-BYTE-NDX1 BY +1 085401 UNTIL T-JCL-BYTE-NDX1 > +71 085402 EVALUATE TRUE 085403 WHEN T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = SPACE 085404 SET T-JCL-BYTE-NDX1 TO +72 085405 WHEN T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = C-COMMA 085406 SET T-JCL-BYTE-NDX1 TO +72 085407 WHEN OTHER 085408 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) TO 085409 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 085410 SET T-PARM-BYTE-NDX1 UP BY +1 085411 END-EVALUATE 085412 END-PERFORM. 085413 085414 S5120-EXIT. 085415 EXIT. 085416/**************************************************************** 085417* S5130-EXTRACT-STEP-NAME * 085418***************************************************************** 085419 S5130-EXTRACT-STEP-NAME SECTION. 085420 085421 INITIALIZE T-PARM-AREA. 085422 SET T-PARM-NDX1 TO +1. 085423 SET T-PARM-BYTE-NDX1 TO +1. 085424 085425 PERFORM VARYING T-JCL-BYTE-NDX2 FROM +3 BY +1 085426 UNTIL T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX2) = ' ' 085433 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX2) TO 085434 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 085435 SET T-PARM-BYTE-NDX1 UP BY +1 085437 END-PERFORM. 085438 085439 S5120-EXIT. 085440 EXIT. 085450/**************************************************************** 085500* S5200-PROCESS-DD * 085600***************************************************************** 085700 S5200-PROCESS-DD SECTION. 085800 085810 INITIALIZE T-PARM-AREA. 085820 SET T-PARM-NDX1 TO +1. 085830 SET T-PARM-BYTE-NDX1 TO +1. 085840 085850 PERFORM VARYING T-JCL-BYTE-NDX2 FROM +3 BY +1 085860 UNTIL T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX2) = ' ' 085861 IF T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX2) = '.' 085862 SET T-PARM-BYTE-NDX1 TO +1 085863 ELSE 085870 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX2) TO 085880 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 085890 SET T-PARM-BYTE-NDX1 UP BY +1 085891 END-IF 085892 END-PERFORM. 085893 085894 IF T-PARM (1) > SPACES 085895 MOVE T-PARM (1) TO XO-DD-NAME 085896 END-IF. 086000 086100 S5200-EXIT. 086200 EXIT. 086300/**************************************************************** 086400* S5300-PROCESS-DSN * 086500***************************************************************** 086600 S5300-PROCESS-DSN SECTION. 086700 086701 INITIALIZE T-PARM-AREA. 086702 SET T-PARM-NDX1 TO +1. 086703 SET T-PARM-BYTE-NDX1 TO +1. 086704 086705 PERFORM VARYING T-JCL-BYTE-NDX1 FROM T-JCL-BYTE-NDX1 BY +1 086706 UNTIL T-JCL-BYTE-NDX1 > +71 086708 OR T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = ' ' 086709 OR T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) = ',' 086710 MOVE T-JCL-BYTE (T-JCL-NDX1, T-JCL-BYTE-NDX1) TO 086711 T-PARM-BYTE (T-PARM-NDX1, T-PARM-BYTE-NDX1) 086712 SET T-PARM-BYTE-NDX1 UP BY +1 086713 END-PERFORM. 086900 086910 MOVE T-PARM (1) TO XO-DATASET-NAME. 086920 087000 S5300-EXIT. 087100 EXIT. 087200/**************************************************************** 087300* S5400-PROCESS-DISP * 087400***************************************************************** 087500 S5400-PROCESS-DISP SECTION. 087600 087700 EXIT. 087800 087900 S5400-EXIT. 088000 EXIT. 088010/**************************************************************** 088020* S6000-WRITE * 088030***************************************************************** 088040 S6000-WRITE SECTION. 088050 088051 DISPLAY 'RECORD: ' XREF-OUTPUT-RECORD. 088070 088080 S6000-EXIT. 088090 EXIT. 088100/**************************************************************** 088200* S9000-LMINIT-LMMLIST * 088300***************************************************************** 088400 S9000-LMINIT-LMMLIST SECTION. 088500 088600 CALL C-ISPF USING C-LMINIT C-JCLLIB-DATAID, 088700 C-NULL-PLACE-HOLDER, 088800 C-NULL-PLACE-HOLDER, 088900 C-NULL-PLACE-HOLDER, 089000 C-NULL-PLACE-HOLDER, 089100 C-NULL-PLACE-HOLDER, 089200 C-NULL-PLACE-HOLDER, 089300 C-NULL-PLACE-HOLDER, 089400 C-JCL-DDNAME. 089500 089600 IF RETURN-CODE > 4 089700 DISPLAY 'LMINIT RETURN CODE = ' RETURN-CODE 089800 CALL C-ISPF USING C-VGET C-ZERRMSG 089900 CALL C-ISPF USING C-VGET C-ZERRLM 090000 DISPLAY W-ZERRMSG ' ' W-ZERRLM 090100 PERFORM S3000-FINALIZATION 090200 END-IF. 090300 090400 CALL C-ISPF USING C-LMOPEN W-JCLLIB-DATAID. 090500 090600 IF RETURN-CODE > 4 090700 DISPLAY 'LMOPEN RETURN CODE = ' RETURN-CODE 090800 CALL C-ISPF USING C-VGET C-ZERRMSG 090900 CALL C-ISPF USING C-VGET C-ZERRLM 091000 DISPLAY W-ZERRMSG ' ' W-ZERRLM 091100 PERFORM S3000-FINALIZATION 091200 END-IF. 091300 091400 CALL C-ISPF USING C-LMMLIST W-JCLLIB-DATAID, 091500 C-LIST-OPTION, 091600 C-JCLLIB-MEMBER. 091700 091800 EVALUATE RETURN-CODE 091900 WHEN +0 092000 CONTINUE 092100 WHEN +4 092200 SET S-NO-MORE-JCL-MEMBERS TO TRUE 092300 WHEN +8 092400 SET S-NO-MORE-JCL-MEMBERS TO TRUE 092500 WHEN OTHER 092600 DISPLAY 'LMMLIST RETURN CODE = ' RETURN-CODE 092700 CALL C-ISPF USING C-VGET C-ZERRMSG 092800 CALL C-ISPF USING C-VGET C-ZERRLM 092900 DISPLAY W-ZERRMSG ' ' W-ZERRLM 093000 PERFORM S3000-FINALIZATION 093100 END-EVALUATE. 093200 093300 S9000-EXIT. 093400 EXIT. ./ ADD NAME=JCLXREF1 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. JCLXREF1. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* * 000700***************************************************************** 003300/**************************************************************** 003400* E N V I R O N M E N T D I V I S I O N * 003500***************************************************************** 003600 ENVIRONMENT DIVISION. 003700 003800 INPUT-OUTPUT SECTION. 003900 004000 FILE-CONTROL. 004100 004200 SELECT JCLCHECK-FILE ASSIGN TO JCLCHECK. 004300 004400 SELECT JCL-XREF-FILE ASSIGN TO JCLXREF. 004500 004600/**************************************************************** 004700* D A T A D I V I S I O N * 004800***************************************************************** 004900 DATA DIVISION. 005000 005100 FILE SECTION. 005200 005300***************************************************************** 005400* JCLCHECK FILE * 005500***************************************************************** 005600 FD JCLCHECK-FILE 005700 RECORD CONTAINS 120 CHARACTERS 005900 BLOCK CONTAINS 0 RECORDS 005910 LABEL RECORDS ARE STANDARD 005920 RECORDING MODE IS F 006000 DATA RECORD IS JCLCHECK-RECORD. 006100 01 JCLCHECK-RECORD. 006200 05 JC-HEADER-RECORD. 006300 10 JC-DSNQUAL PIC X(05). 006310 10 JC-JOB-MEMBER-NAME PIC X(08). 006320 10 JC-JOB-NAME PIC X(08). 006330 10 FILLER PIC X(99). 006600 05 JC-DETAIL-RECORD REDEFINES JC-HEADER-RECORD. 006610 10 JC-RECORD-TYPE PIC X(01). 006611 88 JC-FILE-RECORD-TYPE VALUE 'F'. 006612 88 JC-OVERRIDE-RECORD-TYPE VALUE 'O'. 006613 88 JC-JOB-END-RECORD-TYPE VALUE 'C'. 006620 10 JC-JOB-STEP-NAME PIC X(08). 006621 10 JC-PROC-STEP-NAME PIC X(08). 006622 10 JC-DD-NAME PIC X(08). 006623 10 JC-DATASET-NAME PIC X(44). 006624 10 JC-STATUS-DISP PIC X(08). 006625 10 JC-NORMAL-DISP PIC X(08). 006626 10 JC-ABNORMAL-DISP PIC X(08). 006627 10 FILLER PIC X(01). 006628 10 JC-CONCAT-SEQ PIC S9(03) COMP-3. 006629 10 JC-FILE-TYPE-TRAILER. 006630 15 JC-PROGRAM-NAME PIC X(08). 006631 15 JC-PROC-MEMBER-NAME PIC X(08). 006640 15 JC-PROC-NAME PIC X(08). 006650 10 JC-OVERRIDE-TYPE-TRAILER REDEFINES 006651 JC-FILE-TYPE-TRAILER. 006660 15 JC-OVR-PROC-MEMBER-NAME PIC X(08). 006670 15 FILLER PIC X(16). 007100 007200/**************************************************************** 007400* JCL CROSS REFERENCE OUTPUT FILE * 008100***************************************************************** 008110 FD JCL-XREF-FILE 008120 RECORD CONTAINS 144 CHARACTERS 008130 BLOCK CONTAINS 0 RECORDS 008140 LABEL RECORDS ARE STANDARD 008150 RECORDING MODE IS F 008160 DATA RECORD IS JCL-XREF-RECORD. 008170 01 JCL-XREF-RECORD PIC X(144). 009600 009700/**************************************************************** 009800* W O R K I N G - S T O R A G E S E C T I O N * 009900***************************************************************** 010000 WORKING-STORAGE SECTION. 010100***************************************************************** 010200* A C C U M U L A T O R S * 010300***************************************************************** 010400 01 ACCUMULATORS. 010500 05 FILLER PIC X(13) VALUE 010600 'ACCUMULATORS:'. 010700 05 A-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 010720 05 A-F-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 010730 05 A-O-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 010740 05 A-HDR-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 010750 05 A-OTHER-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 010800 05 A-RECORDS-WRITTEN PIC S9(08) COMP SYNC VALUE +0. 011100/**************************************************************** 011200* C O N S T A N T S * 011300***************************************************************** 011400 01 CONSTANTS. 011500 05 FILLER PIC X(10) VALUE 011600 'CONSTANTS:'. 011700 05 C-INCREMENT PIC S9(08) COMP SYNC VALUE +10000. 011800/**************************************************************** 011900* S W I T C H E S * 012000***************************************************************** 012100 01 SWITCHES. 012200 05 FILLER PIC X(09) VALUE 012300 'SWITCHES:'. 012400 05 S-END-OF-FILE-SWITCH PIC X(01) VALUE 'Y'. 012500 88 S-MORE-RECORDS-EXIST VALUE 'Y'. 012600 88 S-NO-MORE-RECORDS-EXIST VALUE 'N'. 012700 05 S-HEADER-RECORD-SWITCH PIC X(01) VALUE 'Y'. 012800 88 S-RECORD-IS-A-HEADER VALUE 'Y'. 012900 88 S-RECORD-IS-NOT-A-HEADER VALUE 'N'. 013000/**************************************************************** 013100* W O R K A R E A S * 013200***************************************************************** 013300 01 WORK-AREAS. 013400 05 FILLER PIC X(11) VALUE 013500 'WORK AREAS:'. 013510 05 W-JCL-XREF-RECORD. 013520 10 W-JCL-XREF-RECORD-HEADER. 013600 15 W-JX-DSNQUAL PIC X(08) VALUE SPACES. 013700 15 W-JX-JOB-MEMBER-NAME PIC X(08) VALUE SPACES. 013800 15 W-JX-JOB-NAME PIC X(08) VALUE SPACES. 013810 10 W-JCL-XREF-RECORD-TRAILER. 013900 15 W-JX-JOB-STEP-NAME PIC X(08) VALUE SPACES. 014000 15 W-JX-PROC-MEMBER-NAME PIC X(08) VALUE SPACES. 014100 15 W-JX-PROC-NAME PIC X(08) VALUE SPACES. 014200 15 W-JX-PROC-STEP-NAME PIC X(08) VALUE SPACES. 014300 15 W-JX-PROGRAM-NAME PIC X(08) VALUE SPACES. 014400 15 W-JX-DD-NAME PIC X(08) VALUE SPACES. 014500 15 W-JX-DATASET-NAME PIC X(44) VALUE SPACES. 014510 15 W-JX-STATUS-DISP PIC X(08) VALUE SPACES. 014520 15 W-JX-NORMAL-DISP PIC X(08) VALUE SPACES. 014530 15 W-JX-ABNORMAL-DISP PIC X(08) VALUE SPACES. 014540 15 W-JX-CONCAT-SEQ PIC 9(03) VALUE ZEROS. 014541 15 W-JX-OVERRIDE-FLAG PIC X(01) VALUE SPACE. 014550 88 W-JX-DD-IS-OVERRIDDEN VALUE 'Y'. 014600/**************************************************************** 014700* P R I N T L I N E S * 014800***************************************************************** 014900 01 PRINT-LINES. 015000 05 FILLER PIC X(12) VALUE 015100 'PRINT LINES:'. 015200/**************************************************************** 015300* T A B L E S * 015400***************************************************************** 015500 01 TABLES. 015600 05 FILLER PIC X(07) VALUE 015700 'TABLES:'. 015710 05 T-OVERRIDE-SAVE-TABLE-SIZE PIC S9(04) COMP VALUE +1000. 015711 05 T-OVERRIDE-SAVE-AREA. 015720 10 T-OVERRIDE-SAVE-TABLE OCCURS 1000 TIMES 015730 INDEXED BY T-OVR-NDX-1 015731 T-OVR-NDX-2. 015732 15 T-OVR-DD-NAME PIC X(08). 015733 15 T-OVR-CONCAT-SEQ PIC 9(03). 015736 15 T-OVR-JOB-STEP-NAME PIC X(08). 015738 15 T-OVR-PROC-STEP-NAME PIC X(08). 015739 15 T-OVR-PROGRAM-NAME PIC X(08). 015740 15 T-OVR-DATASET-NAME PIC X(44). 015741 15 T-OVR-STATUS-DISP PIC X(08). 015742 15 T-OVR-NORMAL-DISP PIC X(08). 015743 15 T-OVR-ABNORMAL-DISP PIC X(08). 016500/**************************************************************** 016600* P R O C E D U R E D I V I S I O N * 016700***************************************************************** 016800 PROCEDURE DIVISION. 016900***************************************************************** 017000* S0000-DRIVER * 017100* THIS SECTION SIMPLY CONTROLS PROCESSING AT THE HIGHEST LEVEL. * 017200* IT CALLS INITIALIZATION, MAINLINE, AND FINALIZATION. * 017300***************************************************************** 017400 S0000-DRIVER SECTION. 017500 017600 PERFORM S1000-INITIALIZATION. 017700 017800 PERFORM S2000-PROCESS-RECORDS UNTIL S-NO-MORE-RECORDS-EXIST. 017900 018000 PERFORM S3000-FINALIZATION. 018100 018200 GOBACK. 018300 018400 S0000-EXIT. 018500 EXIT. 018600/**************************************************************** 018700* S1000-INITIALIZATION * 018800* THIS SECTION CONTROLS ANY INITIAL PROCESSING WHICH NEEDS TO * 018900* TAKE PLACE PRIOR TO PROCESSING THROUGH THE MASTER FILE. * 019000* FILE OPENS AND INTIAL READS TAKE PLACE HERE, AND ANY PARM * 019100* PARSING AND VALIDATION COULD TAKE PLACE HERE IF NECESSARY. * 019200***************************************************************** 019300 S1000-INITIALIZATION SECTION. 019400 019500 OPEN INPUT JCLCHECK-FILE. 019600 OPEN OUTPUT JCL-XREF-FILE. 019700 019800 PERFORM S4000-READ-A-RECORD. 019900 020000 S1000-EXIT. 020100 EXIT. 020200/**************************************************************** 020300* S2000-PROCESS-RECORDS * 020400* THIS IS THE MAINLINE PROCESSING WHICH DIRECTS THE ITERATIVE * 020500* PROCESSING THROUGH THE MASTER FILE. * 020600***************************************************************** 020700 S2000-PROCESS-RECORDS SECTION. 020800 020900 EVALUATE TRUE 021000 WHEN S-RECORD-IS-A-HEADER AND 021100 JC-DSNQUAL > SPACES AND 021200 JC-JOB-MEMBER-NAME > SPACES AND 021300 JC-JOB-NAME > SPACES 021310 PERFORM S6000-HEADER-PROCESSING 021320 WHEN JC-JOB-END-RECORD-TYPE 021330 SET S-RECORD-IS-A-HEADER TO TRUE 021340 ADD +1 TO A-OTHER-RECORDS-READ 021400 WHEN JC-FILE-RECORD-TYPE 021401 PERFORM S7000-FILE-PROCESSING 021500 WHEN JC-OVERRIDE-RECORD-TYPE 021510 PERFORM S8000-OVERRIDE-PROCESSING 021600 WHEN OTHER 021700 ADD +1 TO A-OTHER-RECORDS-READ 021900 END-EVALUATE. 022000 022100 PERFORM S4000-READ-A-RECORD. 022200 022300 S2000-EXIT. 022400 EXIT. 022410/**************************************************************** 022420* S3000-FINALIZATION * 022430* THIS SECTION CLOSES THE FILES AND DISPLAYS PROCESSING * 022440* STATISTICS. ANY OTHER "CLEAN-UP" ACTIVITY COULD BE PUT HERE. * 022450***************************************************************** 022460 S3000-FINALIZATION SECTION. 022470 022471 DISPLAY 'A-F-RECORDS-READ = ' A-F-RECORDS-READ. 022472 DISPLAY 'A-O-RECORDS-READ = ' A-O-RECORDS-READ. 022473 DISPLAY 'A-HDR-RECORDS-READ = ' A-HDR-RECORDS-READ. 022474 DISPLAY 'A-OTHER-RECORDS-READ = ' A-OTHER-RECORDS-READ. 022475 DISPLAY 'A-RECORDS-READ = ' A-RECORDS-READ. 022476 DISPLAY 'A-RECORDS-WRITTEN = ' A-RECORDS-WRITTEN. 022477 022480 CLOSE JCLCHECK-FILE 022490 JCL-XREF-FILE. 022491 022501 S3000-EXIT. 022502 EXIT. 022510/**************************************************************** 022600* S4000-READ-A-RECORD * 023200***************************************************************** 023300 S4000-READ-A-RECORD SECTION. 023400 023500 READ JCLCHECK-FILE 023600 AT END 023700 SET S-NO-MORE-RECORDS-EXIST TO TRUE. 023800 023900 IF S-MORE-RECORDS-EXIST 024000 ADD +1 TO A-RECORDS-READ 024900 END-IF. 025000 025100 S4000-EXIT. 025200 EXIT. 025300/**************************************************************** 025400* S5000-WRITE-A-RECORD * 025500* THIS SECTION SIMPLY WRITES THE OUTPUT RECORD. ONCE AGAIN, * 025600* IT IS EXPECTING THE RECORD TO BE IN THE "FD" AREA ALREADY. * 025700* IT IS NOT WRITING "FROM" A WORKING-STORAGE SECTION AREA. * 025800***************************************************************** 025900 S5000-WRITE-A-RECORD SECTION. 026000 026100 WRITE JCL-XREF-RECORD FROM W-JCL-XREF-RECORD. 026101 026110 INITIALIZE W-JCL-XREF-RECORD-TRAILER. 026200 026300 ADD +1 TO A-RECORDS-WRITTEN. 026600 026700 S5000-EXIT. 026800 EXIT. 026900/**************************************************************** 027000* S6000-HEADER-PROCESSING * 027400***************************************************************** 027500 S6000-HEADER-PROCESSING SECTION. 027600 027700 INITIALIZE W-JCL-XREF-RECORD-HEADER 027701 T-OVERRIDE-SAVE-AREA. 027702 027703 SET T-OVR-NDX-1 TO +0. 027704 SET S-RECORD-IS-NOT-A-HEADER TO TRUE. 027705 027706 MOVE JC-DSNQUAL TO W-JX-DSNQUAL. 027707 MOVE JC-JOB-MEMBER-NAME TO W-JX-JOB-MEMBER-NAME. 027708 MOVE JC-JOB-NAME TO W-JX-JOB-NAME. 028200 028210 ADD +1 TO A-HDR-RECORDS-READ. 028220 028300 S6000-EXIT. 028400 EXIT. 028500/**************************************************************** 028600* S7000-FILE-PROCESSING * 028700***************************************************************** 028800 S7000-FILE-PROCESSING SECTION. 028900 028901 MOVE JC-JOB-STEP-NAME TO W-JX-JOB-STEP-NAME. 028902 MOVE JC-PROC-STEP-NAME TO W-JX-PROC-STEP-NAME. 028903 MOVE JC-DD-NAME TO W-JX-DD-NAME. 028904 MOVE JC-DATASET-NAME TO W-JX-DATASET-NAME. 028905 MOVE JC-STATUS-DISP TO W-JX-STATUS-DISP. 028906 MOVE JC-NORMAL-DISP TO W-JX-NORMAL-DISP. 028907 MOVE JC-ABNORMAL-DISP TO W-JX-ABNORMAL-DISP. 028908 MOVE JC-CONCAT-SEQ TO W-JX-CONCAT-SEQ. 028909 MOVE JC-PROGRAM-NAME TO W-JX-PROGRAM-NAME. 028910 MOVE JC-PROC-MEMBER-NAME TO W-JX-PROC-MEMBER-NAME. 028911 MOVE JC-PROC-NAME TO W-JX-PROC-MEMBER-NAME. 028912 028920 SET T-OVR-NDX-2 TO +1. 029000 029001 SEARCH T-OVERRIDE-SAVE-TABLE VARYING T-OVR-NDX-2 029003 WHEN JC-DD-NAME = 029004 T-OVR-DD-NAME (T-OVR-NDX-2) AND 029005 JC-CONCAT-SEQ = 029006 T-OVR-CONCAT-SEQ (T-OVR-NDX-2) AND 029007 JC-JOB-STEP-NAME = 029008 T-OVR-JOB-STEP-NAME (T-OVR-NDX-2) AND 029011 JC-PROC-STEP-NAME = 029012 T-OVR-PROC-STEP-NAME (T-OVR-NDX-2) AND 029013 JC-PROGRAM-NAME = 029014 T-OVR-PROGRAM-NAME (T-OVR-NDX-2) 029015 PERFORM S7100-OVERRIDE-MOVES 029016 END-SEARCH. 029017 029018 ADD +1 TO A-F-RECORDS-READ. 029019 029020 PERFORM S5000-WRITE-A-RECORD. 029030 029100 S7000-EXIT. 029200 EXIT. 029210/**************************************************************** 029220* S7100-OVERRIDE-MOVES * 029230***************************************************************** 029240 S7100-OVERRIDE-MOVES SECTION. 029250 029298 IF T-OVR-DATASET-NAME (T-OVR-NDX-2) > SPACES AND 029299 T-OVR-DATASET-NAME (T-OVR-NDX-2) NOT = ALL '*' AND 029300 T-OVR-DATASET-NAME (T-OVR-NDX-2) NOT = ALL '?' 029301 MOVE T-OVR-DATASET-NAME (T-OVR-NDX-2) TO 029302 W-JX-DATASET-NAME. 029303 029304 IF T-OVR-STATUS-DISP (T-OVR-NDX-2) > SPACES AND 029305 T-OVR-STATUS-DISP (T-OVR-NDX-2) NOT = ALL '*' AND 029306 T-OVR-STATUS-DISP (T-OVR-NDX-2) NOT = ALL '?' 029307 MOVE T-OVR-STATUS-DISP (T-OVR-NDX-2) TO 029308 W-JX-STATUS-DISP. 029309 029310 IF T-OVR-NORMAL-DISP (T-OVR-NDX-2) > SPACES AND 029311 T-OVR-NORMAL-DISP (T-OVR-NDX-2) NOT = ALL '*' AND 029312 T-OVR-NORMAL-DISP (T-OVR-NDX-2) NOT = ALL '?' 029313 MOVE T-OVR-NORMAL-DISP (T-OVR-NDX-2) TO 029314 W-JX-NORMAL-DISP. 029315 029316 IF T-OVR-ABNORMAL-DISP (T-OVR-NDX-2) > SPACES AND 029317 T-OVR-ABNORMAL-DISP (T-OVR-NDX-2) NOT = ALL '*' AND 029318 T-OVR-ABNORMAL-DISP (T-OVR-NDX-2) NOT = ALL '?' 029319 MOVE T-OVR-ABNORMAL-DISP (T-OVR-NDX-2) TO 029320 W-JX-ABNORMAL-DISP. 029330 029331 SET W-JX-DD-IS-OVERRIDDEN TO TRUE. 029332 029339 S7100-EXIT. 029340 EXIT. 029350/**************************************************************** 029400* S8000-OVERRIDE-PROCESSING * 029500***************************************************************** 029600 S8000-OVERRIDE-PROCESSING SECTION. 029700 029710 SET T-OVR-NDX-1 UP BY +1. 029800 029802 MOVE JC-JOB-STEP-NAME TO 029803 T-OVR-JOB-STEP-NAME (T-OVR-NDX-1). 029805 MOVE JC-PROC-STEP-NAME TO 029806 T-OVR-PROC-STEP-NAME (T-OVR-NDX-1). 029808 MOVE JC-DD-NAME TO 029809 T-OVR-DD-NAME (T-OVR-NDX-1). 029811 MOVE JC-DATASET-NAME TO 029812 T-OVR-DATASET-NAME (T-OVR-NDX-1). 029814 MOVE JC-STATUS-DISP TO 029815 T-OVR-STATUS-DISP (T-OVR-NDX-1). 029817 MOVE JC-NORMAL-DISP TO 029818 T-OVR-NORMAL-DISP (T-OVR-NDX-1). 029820 MOVE JC-ABNORMAL-DISP TO 029821 T-OVR-ABNORMAL-DISP (T-OVR-NDX-1). 029823 MOVE JC-CONCAT-SEQ TO 029824 T-OVR-CONCAT-SEQ (T-OVR-NDX-1). 029826 MOVE JC-PROGRAM-NAME TO 029827 T-OVR-PROGRAM-NAME (T-OVR-NDX-1). 029828 MOVE JC-PROC-STEP-NAME TO 029829 T-OVR-PROC-STEP-NAME (T-OVR-NDX-1). 029840 029900 S8000-EXIT. 030000 EXIT. ./ ADD NAME=PARSBANR 000010****************************************************************** 000020** !!!!!! ATTENTION !!!!!! ATTENTION !!!!!! ATTENTION !!!!!! ** 000021** Do NOT attempt to make things upper-case or to get rid of ** 000022** non-displayable hex values which you may find in this code. ** 000023** These values are there BY DESIGN to handle "machine" ** 000024** carriage-control values. ** 000026** !!!!!! ATTENTION !!!!!! ATTENTION !!!!!! ATTENTION !!!!!! ** 000030****************************************************************** 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. PARSBANR. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000800****************************************************************** 000900** DO NOT COPY!! ** 001000** THIS DOCUMENT CONTAINS TRADE SECRET INFORMATION, THE ** 001100** EXPRESSION OF WHICH IS AN UNPUBLISHED WORK FULLY PROTECTED ** 001200** BY THE UNITED STATES COPYRIGHT LAWS AND IS CONSIDERED A ** 001300** TRADE SECRET OWNED BY UNIPAC SERVICE CORPORATION, ** 001400** 3015 SOUTH PARKER ROAD, SUITE 400, AURORA, COLORADO 80014. ** 001500** ALL RIGHTS, TITLE, INTEREST AND OWNERSHIP ARE RESERVED BY ** 001600** UNIPAC SERVICE CORPORATION. THIS DOCUMENT CANNOT BE ** 001700** ACQUIRED, COPIED, MODIFIED OR USED IN ANY MANNER WHATSOEVER ** 001800** WITHOUT THE EXPRESS WRITTEN CONSENT OF UNIPAC SERVICE ** 001900** CORPORATION. ** 002000****************************************************************** 002100****************************************************************** 002200** ** 002300** THIS PROGRAM READS THROUGH A FILE WHICH CONSISTS OF A SERIES ** 002400** OF NOMAD-GENERATED REPORTS, EACH BEGINNING WITH A "BANNER" ** 002500** PAGE WHICH DISPLAYS THE USER ID OF THE USER WHO CREATED THE ** 002600** REPORT, AND PARSES THE BANNER PAGE TO DETERMINE WHO PRODUCED ** 002700** EACH REPORT AND WHERE EACH REPORT BEGINS. ** 002800** ** 002900** AS OUTPUT FROM THIS PROGRAM A SERIES OF SYNCSORT JOBS ARE ** 003000** WRITTEN TO A SINGLE FILE. EACH SYNCSORT JOB READS THIS SAME ** 003100** REPORT FILE IN, BUT, BY MEANS OF "SKIPREC" AND "STOPAFT" ** 003200** STATEMENTS, ONLY WRITES OUT ONE REPORT. ** 003300** ** 003400** EACH OF THE JOBS HAS A JOBNAME WHICH CONSISTS OF THE USERID ** 003500** FOR THAT REPORT (A RESULT OF PARSING THE BANNER PAGE) AND A ** 003600** DOLLAR SIGN ("$"). THE SORTOUT DD OF THE SYNCSORT IS ** 003700** DIRECTED TO RMDS WHICH HAS A REPORT NAME SET UP FOR EACH ** 003800** NOMAD USER WHICH CONSISTS OF THEIR USER ID AND THE DOLLAR ** 003900** SIGN. ** 004000** ** 004100** THIS IS THE METHOD BY WHICH NOMAD REPORTS WHICH ARE ** 004200** GENERATED IN SESSION-MANAGER (WHICH IS THE CASE FOR ALL ** 004300** NON-IS USERS) EVENTUALLY GET TO RMDS IN A "USER-SPECIFIC" ** 004400** FORMAT. ** 004500** ** 004600** THERE ARE SOME IMPORTANT ASSUMPTIONS WHICH THIS PROGRAM ** 004700** MAKES IN ORDER TO DO THE BANNER PARSING. IT HAS TO MAKE ** 004800** ASSUMPTIONS ABOUT THE BANNER WHICH IS GENERATED IN NOMAD. ** 004900** THOSE ASSUMPTIONS ARE AS FOLLOWS: ** 005000** ** 005100** 1. THE BANNER CONSISTS OF THE USER ID ONLY ** 005200** 2. EACH LETTER IS 12 COLUMNS BY 12 LINES ** 005300** 3. THERE ARE 2 COLUMNS BETWEEN EACH LETTER ** 005400** 4. THERE ARE 8 POSSIBLE LETTER BLOCKS IN THE BANNER ** 005500** 5. THE FIRST LETTER BLOCK BEGINS IN COLUMN 12 ** 005600** 6. A BANNER PAGE STARTS WITH A NEW PAGE CARRIAGE CONTROL ** 005700** FOLLOWED BY 2 TRIPLE SPACE LINES FOLLOWED BY A SINGLE ** 005800** SPACE BLANK LINE FOLLOWED BY THE 12 BANNER LINES ** 005900** FOLLOWED BY A SINGLE SPACE BLANK LINE. ** 005910** -or- A BANNER PAGE STARTS WITH A NEW PAGE CARRIAGE CONTROL ** 005920** FOLLOWED BY 2 TRIPLE SPACE LINES FOLLOWED BY 2 SINGLE ** 005930** SPACE BLANK LINEs FOLLOWED BY THE 12 BANNER LINES. ** 005940** 7. MACHINE OR ANSI CARRIAGE CONTROL MAY BE USED. ** 006000** 8. THE INDIVIDUAL CHARACTERS OF EACH BLOCK LETTER CONSIST ** 006100** ONLY OF THE LETTER WHICH THE BLOCK REPRESENTS. ** 006200****************************************************************** 006300/***************************************************************** 006400** E N V I R O N M E N T D I V I S I O N ** 006500****************************************************************** 006600 ENVIRONMENT DIVISION. 006700 006800 INPUT-OUTPUT SECTION. 006900 007000 FILE-CONTROL. 007100 007200 SELECT INPUT-REPORT-FILE ASSIGN TO INRPT. 007300 SELECT INPUT-DYNALLOC-FILE ASSIGN TO DYNALLOC. 007400 SELECT INPUT-JCL-FILE ASSIGN TO INJCL. 007500 SELECT INPUT-JOB-CARD-FILE ASSIGN TO JOBCARDS. 007600 SELECT OUTPUT-JCL-FILE ASSIGN TO OUTJCL. 007700 007800/***************************************************************** 007900** D A T A D I V I S I O N ** 008000****************************************************************** 008100 DATA DIVISION. 008200 008300 FILE SECTION. 008400 008500****************************************************************** 008600** THIS FILE IS AN INPUT FILE WHICH CONTAINS THE NOMAD REPORTS ** 008700** WHICH NEED TO BE PARSED FOR SPLITTING BY THE SYNCSORT JOBS. ** 008800** THIS IS THE PRIMARY DRIVING FILE FOR THIS PROGRAM. ** 008900****************************************************************** 009000 FD INPUT-REPORT-FILE 009100 RECORDING MODE IS F 009200 RECORD CONTAINS 133 CHARACTERS 009300 BLOCK CONTAINS 0 RECORDS 009400 DATA RECORD IS INPUT-REPORT-RECORD. 009500 009600 01 INPUT-REPORT-RECORD. 009610 88 INPUT-FILE-IS-BLANK VALUE SPACES. 009700 05 INPUT-CC PIC X(001). 009800 88 INPUT-NEW-PAGE VALUE '1'. 009900 88 INPUT-NEW-PAGE-M VALUE '.'. 010000 88 INPUT-NEW-PAGE-X VALUE 'i'. 010100 05 FILLER PIC X(132). 010200 010300/***************************************************************** 010400** THIS FILE IS AN INPUT FILE CREATED FROM THE PREVIOUS STEP. ** 010500** THE PREVIOUS STEP IS A TSO STEP WHICH DYNAMICALLY ALLOCATES ** 010600** A TIMESTAMPPED SEQUENTIAL FILE AND THEN COPIES THE NOMAD ** 010700** REPORT FILE INTO IT. ALL THIS FILE CONTAINS IS THE NAME OF ** 010800** THE DYNAMICALLY ALLOCATED SEQUENTIAL FILE. THIS NAME THEN ** 010900** REPLACES A SYMBOLIC VARIABLE IN THE SKELETON JCL FILE. ** 011000****************************************************************** 011100 FD INPUT-DYNALLOC-FILE 011200 RECORDING MODE IS F 011300 RECORD CONTAINS 80 CHARACTERS 011400 BLOCK CONTAINS 0 RECORDS 011500 DATA RECORD IS INPUT-DYNALLOC-RECORD. 011600 011700 01 INPUT-DYNALLOC-RECORD PIC X(80). 011800 011900/***************************************************************** 012000** THIS FILE CONTAINS THE SKELETON JCL FOR THE SYNCSORT JOBS TO ** 012100** BE CREATED BY THIS PROGRAM. THIS FILE IS LOADED INTO AN ** 012200** INTERNAL TABLE DURING PROGRAM INITIALIZATION. THE FIRST LINE** 012300** OF THE JOB CARD FOR THIS JOB ALSO SERVES AS THE DEFAULT JOB ** 012400** CARD IF NO JOB CARD IS FOUND IN THE JOB CARD TABLE MATCHING ** 012500** THE USERID PREFIX. ** 012600** ** 012700** WHILE BEING LOADED, THIS FILE HAS A COMMENT LINE EXPANDED TO ** 012800** PUT IN INFORMATION ABOUT WHEN EACH JOB WAS CREATED. IT ALSO ** 012900** CONTAINS A DATASET NAME SYMBOLIC IN THE SKELETON. THIS IS ** 013000** ALSO RESOLVED WHILE THE FILE IS BEING LOADED INTO THE TABLE. ** 013100** IT IS RESOLVED WITH THE NAME OF THE DYNAMICALLY CREATED ** 013200** SEQUENTIAL REPORT FILE CREATED IN THE PREVIOUS JOB STEP. ** 013300****************************************************************** 013400 FD INPUT-JCL-FILE 013500 RECORDING MODE IS F 013600 RECORD CONTAINS 80 CHARACTERS 013700 BLOCK CONTAINS 0 RECORDS 013800 DATA RECORD IS INPUT-JCL-RECORD. 013900 014000 01 INPUT-JCL-RECORD. 014100 05 INPUT-FIRST-3-BYTES PIC X(03). 014200 88 INPUT-COMMENT-CARD VALUE '//*'. 014300 05 FILLER PIC X(77). 014400 014500/***************************************************************** 014600** THIS FILE IS AN INPUT FILE OF THE FIRST LINE OF JOB CARDS. ** 014700** EACH RECORD IS THE FIRST LINE OF A JOB CARD FOR A SPECIFIC ** 014800** CLIENT. THE ACCOUNTING INFORMATION IS SPECIFIC TO THAT ** 014900** CLIENT. ADDITIONALLY, THE JOB NAME PORTION OF THE JOB CARD ** 015000** CONTAINS THE PREFIX WHICH EACH USER ID OF THAT CLIENT HAS. ** 015100** THIS PREFIX IS COMPARED WITH THE USER ID THAT HAS BEEN ** 015200** PARSED FROM THE BANNER STRING AND IF A MATCH IS FOUND IN ** 015300** THIS TABLE, THAT PARTICULAR JOB CARD IS USED. ** 015400****************************************************************** 015500 FD INPUT-JOB-CARD-FILE 015600 RECORDING MODE IS F 015700 RECORD CONTAINS 80 CHARACTERS 015800 BLOCK CONTAINS 0 RECORDS 015900 DATA RECORD IS INPUT-JOB-CARD-RECORD. 016000 016100 01 INPUT-JOB-CARD-RECORD PIC X(80). 016200 016300/***************************************************************** 016400** THIS FILE IS THE OUTPUT FILE CREATED BY THIS PROGRAM. IT ** 016500** WILL CONTAIN ONE TO MANY SINGLE-STEP SYNCSORT JOBS. EACH OF ** 016600** THESE JOBS WILL HAVE A DIFFERENT FIRST JOB CARD LINE BASED ** 016700** ON THEIR USER ID AND THE CLIENT THEY BELONG TO. ** 016800** ADDITIONALLY, EACH JOB WILL HAVE SLIGHTLY DIFFERENT SYNCSORT ** 016900** CONTROL CARDS SO THAT THEY CAN STRIP DIFFERENT PORTIONS OF ** 017000** THE REPORT OFF TO SEND TO DIFFERENT USERS IN RMDS ** 017100****************************************************************** 017200 FD OUTPUT-JCL-FILE 017300 RECORDING MODE IS F 017400 RECORD CONTAINS 80 CHARACTERS 017500 BLOCK CONTAINS 0 RECORDS 017600 DATA RECORD IS OUTPUT-JCL-RECORD. 017700 017800 01 OUTPUT-JCL-RECORD. 017900 05 FILLER PIC X(02). 018000 05 OUTPUT-JOB-NAME PIC X(08). 018100 05 FILLER PIC X(70). 018200 018300/***************************************************************** 018400** W O R K I N G - S T O R A G E S E C T I O N ** 018500****************************************************************** 018600 WORKING-STORAGE SECTION. 018700 01 A-STANDARD-PROGRAM-ID PIC X(27) VALUE 018800 'UNIPAC/PARSBANR/931101-1.00'. 018900 019000/***************************************************************** 019100* C O U N T E R S * 019200****************************************************************** 019300 01 COUNTERS. 019400 05 C-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 019500 88 C-NO-INPUT-REPORT-RECORDS VALUE +0. 019600 88 C-MULTIPLE-RECORDS-READ VALUE +2 THRU +99999999. 019700 05 C-DYNALLOC-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 019800 88 C-NO-DYALLOC-RECORD VALUE +0. 019900 88 C-A-DYNALLOC-RECORD-EXISTS VALUE +1. 020000 05 C-INPUT-JCL-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 020100 88 C-NO-INPUT-JCL-RECORDS VALUE +0. 020200 05 C-INPUT-CARD-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 020300 88 C-NO-INPUT-CARD-RECORDS VALUE +0. 020400 05 C-RECORDS-WRITTEN PIC S9(08) COMP SYNC VALUE +0. 020500 05 C-REPORTS-IN-FILE PIC S9(08) COMP SYNC VALUE +0. 020600 88 C-A-BANNER-EXISTS VALUE +1 tHRU +99999999. 020610 88 C-ONLY-ONE-REPORT VALUE +1. 020700 05 C-DISPLAY-ACCUMULATOR PIC S9(08) COMP SYNC VALUE +0. 020800/***************************************************************** 020900* F L A G S * 021000****************************************************************** 021100 01 FLAGS. 021200 05 F-END-OF-FILE-FLAG PIC X(01) VALUE 'N'. 021300 88 F-NO-MORE-RECORDS-TO-PROCESS VALUE 'Y'. 021400 88 F-MORE-RECORDS-EXIST VALUE 'N'. 021500 05 F-END-OF-JCL-FILE-FLAG PIC X(01) VALUE 'N'. 021600 88 F-NO-MORE-JCL-RECORDS VALUE 'Y'. 021700 88 F-MORE-JCL-RECORDS-EXIST VALUE 'N'. 021800 05 F-END-OF-CARD-FILE-FLAG PIC X(01) VALUE 'N'. 021900 88 F-NO-MORE-CARD-RECORDS VALUE 'Y'. 022000 88 F-MORE-CARD-RECORDS-EXIST VALUE 'N'. 022100 05 F-END-OF-DYNALLOC-FLAG PIC X(01) VALUE 'N'. 022200 88 F-NO-MORE-DYNALLOC-RECORDS VALUE 'Y'. 022300 88 F-MORE-DYNALLOC-RECORDS-EXIST VALUE 'N'. 022400 05 F-BANNER-FLAG PIC X(01) VALUE 'N'. 022500 88 F-THIS-IS-A-BANNER VALUE 'Y'. 022600 88 F-THIS-IS-NOT-A-BANNER VALUE 'N'. 022700 05 F-JOB-CARD-MATCH-FLAG PIC X(01) VALUE 'N'. 022800 88 F-A-MATCH-WAS-FOUND VALUE 'Y'. 022900 88 F-NO-MATCH-FOUND VALUE 'N'. 023000 05 F-DATASET-SYMBOLIC-FLAG PIC X(01) VALUE 'N'. 023100 88 F-DATASET-NAME-SYMBOLIC-FOUND VALUE 'Y'. 023200 88 F-NO-DATASET-NAME-SYMBOLIC VALUE 'N'. 023300/***************************************************************** 023400* L I T E R A L S * 023500****************************************************************** 023600 01 LITERALS. 023700 05 L-DISPLAY-INCREMENT PIC S9(08) COMP SYNC VALUE +100. 023800 05 L-PARSE-BEGIN-LINE PIC S9(08) COMP SYNC VALUE +5. 023900 05 L-PARSE-END-LINE PIC S9(08) COMP SYNC VALUE +16. 024000 05 L-MIN-BANNER-PAGE-SIZE PIC S9(08) COMP SYNC VALUE +17. 024100 05 L-ASTERISK-LINE. 024200 10 FILLER PIC X(02) VALUE '//'. 024300 10 FILLER PIC X(70) VALUE ALL '*'. 024400 10 FILLER PIC X(08) VALUE SPACES. 024500 05 L-JOB-END-LINE. 024600 10 FILLER PIC X(02) VALUE '//'. 024700 10 FILLER PIC X(78) VALUE SPACES. 024800 05 L-DSN-SYMBOLIC PIC X(13) VALUE '|DATASETNAME|'. 024900 05 L-SKIPREC PIC X(09) VALUE ' SKIPREC='. 025000 05 L-STOPAFT PIC X(09) VALUE ' STOPAFT='. 025100 05 L-JOB-SUFFIX PIC X(01) VALUE '$'. 025200 05 L-COMMA PIC X(01) VALUE ','. 025300/***************************************************************** 025400* S U B S C R I P T S * 025500****************************************************************** 025600* NO SUBSCRIPTS. 025700/***************************************************************** 025800* H O L D A R E A S * 025900****************************************************************** 026000 01 HOLD-AREAS. 026100 05 H-BANNER-STRING-SIZE PIC S9(08) COMP SYNC VALUE +8. 026200 05 H-PART1-COUNT PIC S9(08) COMP SYNC VALUE +0. 026300 05 H-PART1-SIZE PIC S9(08) COMP SYNC VALUE +80. 026400 05 H-SKIPREC-NUMBER PIC 9(07) VALUE 0. 026500 05 H-STOPAFT-NUMBER PIC 9(07) VALUE 0. 026600 05 H-COMMENT-LINE-1. 026700 10 FILLER PIC X(04) VALUE '//* '. 026800 10 FILLER PIC X(38) VALUE 026900 'THIS JOB WAS GENERATED BY A JES WRITER'. 027000 10 FILLER PIC X(28) VALUE SPACES. 027100 10 FILLER PIC X(02) VALUE ' *'. 027200 10 FILLER PIC X(08) VALUE SPACES. 027300 05 H-COMMENT-LINE-2. 027400 10 FILLER PIC X(04) VALUE '//* '. 027500 10 FILLER PIC X(40) VALUE 027600 'TO STRIP ONE REPORT OUT OF THE SORTIN DD'. 027700 10 FILLER PIC X(26) VALUE SPACES. 027800 10 FILLER PIC X(02) VALUE ' *'. 027900 10 FILLER PIC X(08) VALUE SPACES. 028000 05 H-COMMENT-LINE-3. 028100 10 FILLER PIC X(04) VALUE '//* '. 028200 10 FILLER PIC X(15) VALUE 028300 'GENERATED ON: '. 028400 10 FILLER. 028500 15 H-COMMENT-YY PIC X(02) VALUE SPACES. 028600 15 FILLER PIC X(01) VALUE '/'. 028700 15 H-COMMENT-MM PIC X(02) VALUE SPACES. 028800 15 FILLER PIC X(01) VALUE '/'. 028900 15 H-COMMENT-DD PIC X(02) VALUE SPACES. 029000 10 FILLER PIC X(43) VALUE SPACES. 029100 10 FILLER PIC X(02) VALUE ' *'. 029200 10 FILLER PIC X(08) VALUE SPACES. 029300 05 H-COMMENT-LINE-4. 029400 10 FILLER PIC X(04) VALUE '//* '. 029500 10 FILLER PIC X(15) VALUE 029600 ' AT: '. 029700 10 FILLER. 029800 15 H-COMMENT-HH PIC X(02) VALUE SPACES. 029900 15 FILLER PIC X(01) VALUE ':'. 030000 15 H-COMMENT-TM PIC X(02) VALUE SPACES. 030100 15 FILLER PIC X(01) VALUE ':'. 030200 15 H-COMMENT-SS PIC X(02) VALUE SPACES. 030300 15 FILLER PIC X(01) VALUE ':'. 030400 15 H-COMMENT-HS PIC X(02) VALUE SPACES. 030500 10 FILLER PIC X(40) VALUE SPACES. 030600 10 FILLER PIC X(02) VALUE ' *'. 030700 10 FILLER PIC X(08) VALUE SPACES. 030800 05 H-JCL-PART1 PIC X(80) VALUE SPACES. 030900 05 H-JCL-PART1-ARRAY REDEFINES H-JCL-PART1 031000 OCCURS 80 TIMES 031100 INDEXED BY H-PART1-NDX. 031200 10 H-PART1-BYTE PIC X(01). 031300 05 H-JCL-PART2 PIC X(80) VALUE SPACES. 031400 05 H-END-OF-PROCESSING-AREA. 031500 10 H-RETURN-CODE PIC 9(04) VALUE 0. 031600 88 H-FATAL-ERROR VALUE 2000 THRU 9999. 031700 10 H-END-OF-PROCESS-MSG PIC X(50) VALUE SPACES. 031800 05 FILLER REDEFINES H-END-OF-PROCESSING-AREA PIC X(54). 031900 88 H-NORMAL-TERMINATION VALUE 032000 '0000THE PROGRAM RAN NORMALLY '. 032100 88 H-NO-REPORTS-TO-PROCESS VALUE 032200 '0004NO NOMAD REPORT LINES EXISTED TO PROCESS '. 032300 88 H-NO-DYNALLOC-RECORD VALUE 032400 '2000THE DYNALLOC FILE WAS EMPTY -- PROGRAM ABORTED '. 032500 88 H-NO-JCL-SKELETON VALUE 032600 '2001THE JCL SKELETON FILE WAS EMPTY -- PROGRAM ABORTED'. 032700 88 H-JCL-TABLE-OVERFLOW VALUE 032800 '2002JCL SKELETON TABLE OVERFLOW -- PROGRAM ABORTED '. 032900 88 H-BUFFER-TABLE-OVERFLOW VALUE 033000 '2003REPORT BUFFER TABLE OVERFLOW -- PROGRAM ABORTED '. 033100 88 H-NO-DATASET-NAME-SYMBOLIC VALUE 033200 '2004DATASET NAME SYMBOLIC NOT FOUND -- PROGRAM ABORTED'. 033300 88 H-CARD-TABLE-OVERFLOW VALUE 033400 '2005JOB CARD TABLE OVERFLOW -- PROGRAM ABORTED '. 033500 88 H-NO-JOB-CARD-RECORDS VALUE 033600 '2006THERE WERE NO JOB CARD RECORDS -- PROGRAM ABORTED '. 033700 05 H-DELIMITER PIC X(40) VALUE SPACES. 033800 05 H-PREVIOUS-BANNER-STRING PIC X(08) VALUE SPACES. 033900 05 H-PREVIOUS-ARRAY REDEFINES H-PREVIOUS-BANNER-STRING. 034000 10 H-PREV-STRING-BYTE OCCURS 8 TIMES 034100 INDEXED BY H-PREV-NDX. 034200 15 FILLER PIC X(01). 034300 05 H-BANNER-STRING. 034400 10 H-BANNER-STRING-ARRAY OCCURS 8 TIMES 034500 INDEXED BY H-BANNER-NDX1 034600 H-BANNER-NDX2. 034700 15 H-BANNER-BYTE PIC X(01). 034800 05 H-SYSTEM-DATE. 034900 10 H-SYSTEM-YY PIC X(02) VALUE SPACES. 035000 10 H-SYSTEM-MM PIC X(02) VALUE SPACES. 035100 10 H-SYSTEM-DD PIC X(02) VALUE SPACES. 035200 05 H-SYSTEM-TIME. 035300 10 H-SYSTEM-HH PIC X(02) VALUE SPACES. 035400 10 H-SYSTEM-TM PIC X(02) VALUE SPACES. 035500 10 H-SYSTEM-SS PIC X(02) VALUE SPACES. 035600 10 H-SYSTEM-HS PIC X(02) VALUE SPACES. 035700/***************************************************************** 035800* T A B L E S * 035900****************************************************************** 036000 01 TABLES. 036100****************************************************************** 036200** T-BUFFER-TABLE ** 036300** THIS TABLE HOLDS LINES WHICH NEED TO BE EVALUATED TO SEE IF ** 036400** THEY ARE REALLY A BANNER OR NOT. IF IT'S DETERMINED THAT ** 036500** THESE LINES ARE BANNER LINES, THEN THE LINES STORED IN THE ** 036600** BUFFER WILL NOT BE WRITTEN OUT, BUT THE PARSED USERID WILL ** 036700** BE WRITTEN INSTEAD. ** 036800** ** 036900** NOTE: THERE ARE "88" DEFINITIONS BELOW WHICH END IN "-M". ** 037000** THE VALUE CLAUSES FOR THESE CONTAIN HEX CHARACTERS. ** 037100** THEY ARE "MACHINE" CARRIAGE CONTROL CHARACTERS. ** 037200** SHOULD THEY ACCIDENTLY BE CHANGED THE VALUES SHOULD ** 037300** BE AS FOLLOWS: ** 037400** ** 037500** T-BUFFER-TRIPLE-SPACE-M VALUE X'1B' ** 037600** T-BUFFER-NEW-PAGE-M VALUE X'8B' ** 037700** ** 037800** T-BUFFER-SINGLE-SPACE-X VALUE X'09' ** 037900** T-BUFFER-TRIPLE-SPACE-X VALUE X'19' ** 038000** T-BUFFER-NEW-PAGE-X VALUE X'89' ** 038100****************************************************************** 038200 05 T-BUFFER-TABLE-SIZE PIC S9(08) COMP SYNC VALUE +200. 038300 05 T-BUFFER-AREA. 038400 10 T-BUFFER-TABLE OCCURS 200 TIMES 038500 INDEXED BY T-BUFFER-NDX1 038600 T-BUFFER-NDX2. 038700 15 T-BUFFER-LINE. 038800 20 T-BUFFER-CC PIC X(001). 038900 88 T-BUFFER-SINGLE-SPACE VALUE ' '. 039000 88 T-BUFFER-SINGLE-SPACE-X VALUE '.'. 039100 88 T-BUFFER-TRIPLE-SPACE VALUE '-'. 039200 88 T-BUFFER-TRIPLE-SPACE-M VALUE '.'. 039300 88 T-BUFFER-TRIPLE-SPACE-X VALUE '.'. 039400 88 T-BUFFER-NEW-PAGE VALUE '1'. 039500 88 T-BUFFER-NEW-PAGE-M VALUE '.'. 039600 88 T-BUFFER-NEW-PAGE-X VALUE 'i'. 039700 20 T-BUFFER-DATA PIC X(132). 039800 88 T-BUFFER-BLANK-LINE VALUE SPACES. 039900****************************************************************** 040000** T-PARSE-TABLE ** 040100** THIS TABLE HOLDS THE PORTION OF THE LINE WHICH NEEDS TO BE ** 040200** PARSED TO FIND THE USER ID IN THE BANNER. ** 040300****************************************************************** 040400 05 T-PARSE-AREA REDEFINES T-BUFFER-AREA. 040500 10 T-PARSE-TABLE OCCURS 200 TIMES 040600 INDEXED BY T-PARSE-NDX1 040700 T-PARSE-NDX2. 040800 15 T-PARSE-LINE. 040900 20 FILLER PIC X(11). 041000 20 T-PARSE-BLOCK OCCURS 8 TIMES 041100 INDEXED BY T-BLOCK-NDX1 041200 T-BLOCK-NDX2. 041300 25 T-PARSE-BYTE OCCURS 14 TIMES 041400 INDEXED BY T-BYTE-NDX1 041500 T-BYTE-NDX2. 041600 30 FILLER PIC X(01). 041700 20 FILLER PIC X(10). 041800 05 T-PARSE-LINE-SIZE PIC S9(08) COMP SYNC VALUE +8. 041900 05 T-PARSE-BYTE-SIZE PIC S9(08) COMP SYNC VALUE +14. 042000****************************************************************** 042100** T-JCL-TABLE ** 042200** THIS TABLE HOLDS THE JCL, MINUS A JOBNAME, WHICH WILL BE ** 042300** WRITTEN OUT TO SPLIT THE REPORT INTO MULTIPLE REPORTS BASED ** 042400** ON USERID. ** 042500****************************************************************** 042600 05 T-JCL-TABLE-SIZE PIC S9(08) COMP SYNC VALUE +100. 042700 05 T-JCL-AREA. 042800 10 T-JCL-TABLE OCCURS 100 TIMES 042900 INDEXED BY T-JCL-NDX1 043000 T-JCL-NDX2. 043100 15 T-JCL-LINE PIC X(80). 043200****************************************************************** 043300** T-JOB-CARD-TABLE ** 043400** THIS TABLE HOLDS THE FIRST LINE OF THE JOB CARD FOR EACH ** 043500** SEPARATE NON-IS USERID PREFIX SO THAT ACCOUNTING INFORMATION ** 043600** CAN BE CORRECT FOR THE CREATED JOB. ** 043700****************************************************************** 043800 05 T-JOB-CARD-TABLE-SIZE PIC S9(08) COMP SYNC VALUE +100. 043900 05 T-JOB-CARD-AREA. 044000 10 T-JOB-CARD-TABLE OCCURS 100 TIMES 044100 INDEXED BY T-JOB-CARD-NDX1 044200 T-JOB-CARD-NDX2. 044300 15 T-JOB-CARD. 044400 20 FILLER PIC X(02). 044500 20 T-JOB-NAME-PREFIX. 044600 25 T-JOB-NAME-BYTE OCCURS 8 TIMES 044700 INDEXED BY T-JOB-BYTE-NDX. 044800 30 FILLER PIC X(01). 044900 20 FILLER PIC X(70). 045000/***************************************************************** 045100** P R O C E D U R E D I V I S I O N ** 045200****************************************************************** 045300 PROCEDURE DIVISION. 045400****************************************************************** 045500** S0000-CONTROL ** 045600** THIS SECTION IS THE DRIVER WHICH CONTROLS THE PROCESSING OF ** 045700** ALL THE SECTIONS AT THE HIGHEST LEVEL. ** 045800****************************************************************** 045900 A0000-CONTROL SECTION. 046000 046100 PERFORM A1000-INITIALIZATION. 046200 046300 PERFORM A2000-MAINLINE 046400 UNTIL F-NO-MORE-RECORDS-TO-PROCESS 046500 OR H-FATAL-ERROR. 046600 046700 PERFORM A3000-FINALIZATION. 046800 046900 A0000-EXIT. 047000 EXIT. 047100/***************************************************************** 047200** A1000-INITIALIZATION ** 047300** THIS SECTION PERFORMS INITIALIZATION FUNCTIONS. THOSE ** 047400** INCLUDE INITIALIZING CERTAIN WORKING STORAGE AREAS, OPENING ** 047500** THE INPUT AND OUTPUT FILES, LOADING TABLES AND DOING A ** 047600** PRIMING READ OF THE PRIMARY INPUT FILE. ** 047700****************************************************************** 047800 A1000-INITIALIZATION SECTION. 047900 048000 DISPLAY 'PARSBANR *** BEGINNING OF "IN PROCESS" MESSAGES '. 048100 048200 ACCEPT H-SYSTEM-TIME FROM TIME. 048300 ACCEPT H-SYSTEM-DATE FROM DATE. 048400 048500 MOVE H-SYSTEM-YY TO H-COMMENT-YY. 048600 MOVE H-SYSTEM-MM TO H-COMMENT-MM. 048700 MOVE H-SYSTEM-DD TO H-COMMENT-DD. 048800 048900 MOVE H-SYSTEM-HH TO H-COMMENT-HH. 049000 MOVE H-SYSTEM-TM TO H-COMMENT-TM. 049100 MOVE H-SYSTEM-SS TO H-COMMENT-SS. 049200 MOVE H-SYSTEM-HS TO H-COMMENT-HS. 049300 049400 SET T-BUFFER-NDX2 TO +0. 049500 SET H-NORMAL-TERMINATION TO TRUE. 049600 049700 OPEN INPUT INPUT-REPORT-FILE 049800 INPUT-DYNALLOC-FILE 049900 INPUT-JCL-FILE 050000 INPUT-JOB-CARD-FILE. 050200 050300 PERFORM S4000-READ-INPUT-REPORT. 050400 PERFORM S4100-READ-INPUT-DYNALLOC. 050401 050403 IF INPUT-REPORT-RECORD = SPACES 050405 SET F-NO-MORE-RECORDS-TO-PROCESS TO TRUE 050406 SET H-NO-REPORTS-TO-PROCESS TO TRUE 050407 ELSE 050409 IF F-MORE-RECORDS-EXIST AND 050410 F-MORE-DYNALLOC-RECORDS-EXIST 050420 OPEN OUTPUT OUTPUT-JCL-FILE 050423 ELSE 050425 SET H-NO-REPORTS-TO-PROCESS TO TRUE 050430 END-IF 050440 END-IF. 050500 050600 PERFORM A1100-LOAD-JCL-TABLE. 050700 PERFORM A1300-LOAD-JOB-CARD-TABLE. 050800 050900 A1000-EXIT. 051000 EXIT. 051100/***************************************************************** 051200** A1100-LOAD-JCL-TABLE ** 051300** THIS SECTION READS THE JCL SKELETON FILE AND LOADS IT INTO ** 051400** AN INTERNAL TABLE. WHILE LOADING IT MANIPULATES THE INPUT ** 051500** IN TWO WAYS. FIRST, WHEN IT HITS THE FIRST COMMENT LINE, IT ** 051600** EXPANDS IT INTO A COMMENT BOX WHICH CONTAINS A BRIEF MESSAGE ** 051700** ABOUT HOW THE RESULTING JOB WAS CREATED AND A TIME AND DATE ** 051800** ON WHICH IT WAS CREATED. SECOND, WHEN IT ENCOUNTERS THE ** 051900** DATASET NAME SYMBOLIC, IT REPLACES THE SYMBOLIC WITH THE ** 052000** ACTUAL DATASET NAME WHICH WAS DYNAMICALLY CREATED IN THE ** 052100** PREVIOUS JOB STEP. ** 052200****************************************************************** 052300 A1100-LOAD-JCL-TABLE SECTION. 052400 052500 PERFORM VARYING T-JCL-NDX2 FROM +1 BY +1 052600 UNTIL F-NO-MORE-JCL-RECORDS 052700 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 052800 SET H-JCL-TABLE-OVERFLOW TO TRUE 052900 ELSE 053000 PERFORM S4200-READ-INPUT-JCL 053100 IF C-A-DYNALLOC-RECORD-EXISTS 053200 UNSTRING T-JCL-LINE (T-JCL-NDX2) 053300 DELIMITED BY L-DSN-SYMBOLIC 053400 INTO H-JCL-PART1 053500 DELIMITER IN H-DELIMITER 053600 COUNT IN H-PART1-COUNT 053700 H-JCL-PART2 053800 END-UNSTRING 053900 IF H-DELIMITER = L-DSN-SYMBOLIC 054000 SET F-DATASET-NAME-SYMBOLIC-FOUND TO TRUE 054100 SET H-PART1-NDX TO H-PART1-COUNT 054200 SET H-PART1-NDX UP BY +1 054300 PERFORM VARYING H-PART1-NDX 054400 FROM H-PART1-NDX BY +1 054500 UNTIL H-PART1-NDX > H-PART1-SIZE 054600 MOVE LOW-VALUES 054700 TO H-PART1-BYTE (H-PART1-NDX) 054800 END-PERFORM 054900 STRING H-JCL-PART1 055000 DELIMITED BY LOW-VALUES 055100 INPUT-DYNALLOC-RECORD 055200 DELIMITED BY SPACES 055300 H-JCL-PART2 055400 DELIMITED SIZE 055500 INTO T-JCL-LINE (T-JCL-NDX2) 055600 END-STRING 055700 END-IF 055800 IF INPUT-COMMENT-CARD 055900 PERFORM A1200-EXPAND-COMMENT-LINE 056000 END-IF 056100 END-IF 056200 END-IF 056300 END-PERFORM. 056400 056500 SET T-JCL-NDX2 DOWN BY +2. 056600 056700 IF C-NO-INPUT-JCL-RECORDS 056800 SET H-NO-JCL-SKELETON TO TRUE 056900 END-IF. 057000 057100 A1100-EXIT. 057200 EXIT. 057300/***************************************************************** 057400** A1200-EXPAND-COMMENT-LINE ** 057500** THIS SECTION IS CALLED FROM THE JCL TABLE LOADING SECTION. ** 057600** WHEN THAT SECTION DETECTS THE FIRST COMMENT LINE IN THE ** 057700** INPUT FILE, IT CALLS THIS SECTION TO EXPAND THAT COMMENT ** 057800** LINE INTO A COMMENT BOX. THE CONTENTS OF THE COMMENT BOX ** 057900** ARE A TEXT DESCRIPTION OF HOW THIS JOB WAS CREATED AND LINES ** 058000** WHICH INDICATE THE DATE AND TIME ON WHICH THIS JOB WAS ** 058100** CREATED. ** 058200****************************************************************** 058300 A1200-EXPAND-COMMENT-LINE SECTION. 058400 058500 MOVE L-ASTERISK-LINE TO T-JCL-LINE (T-JCL-NDX2). 058600 SET T-JCL-NDX2 UP BY +1. 058700 058800 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 058900 SET H-JCL-TABLE-OVERFLOW TO TRUE 059000 ELSE 059100 MOVE H-COMMENT-LINE-1 059200 TO T-JCL-LINE (T-JCL-NDX2) 059300 SET T-JCL-NDX2 UP BY +1 059400 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 059500 SET H-JCL-TABLE-OVERFLOW TO TRUE 059600 ELSE 059700 MOVE H-COMMENT-LINE-2 059800 TO T-JCL-LINE (T-JCL-NDX2) 059900 SET T-JCL-NDX2 UP BY +1 060000 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 060100 SET H-JCL-TABLE-OVERFLOW TO TRUE 060200 ELSE 060300 MOVE H-COMMENT-LINE-3 060400 TO T-JCL-LINE (T-JCL-NDX2) 060500 SET T-JCL-NDX2 UP BY +1 060600 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 060700 SET H-JCL-TABLE-OVERFLOW TO TRUE 060800 ELSE 060900 MOVE H-COMMENT-LINE-4 061000 TO T-JCL-LINE (T-JCL-NDX2) 061100 SET T-JCL-NDX2 UP BY +1 061200 IF T-JCL-NDX2 > T-JCL-TABLE-SIZE 061300 SET H-JCL-TABLE-OVERFLOW TO TRUE 061400 ELSE 061500 MOVE L-ASTERISK-LINE 061600 TO T-JCL-LINE (T-JCL-NDX2) 061700 END-IF 061800 END-IF 061900 END-IF 062000 END-IF 062100 END-IF. 062200 062300 A1200-EXIT. 062400 EXIT. 062500/***************************************************************** 062600** A1300-LOAD-JOB-CARD-TABLE ** 062700** THIS SECTION SIMPLY ITERATIVELY READS THE JOB CARD INPUT ** 062800** FILE AND LOADS IT INTO AN INTERNAL WORKING STORAGE TABLE. ** 062900****************************************************************** 063000 A1300-LOAD-JOB-CARD-TABLE SECTION. 063100 063200 PERFORM VARYING T-JOB-CARD-NDX2 FROM +1 BY +1 063300 UNTIL F-NO-MORE-CARD-RECORDS 063400 OR T-JOB-CARD-NDX2 > T-JOB-CARD-TABLE-SIZE 063500 PERFORM S4300-READ-INPUT-JOB-CARDS 063600 END-PERFORM. 063700 063800 SET T-JOB-CARD-NDX2 DOWN BY +1. 063900 064000 IF T-JOB-CARD-NDX2 = T-JOB-CARD-TABLE-SIZE AND 064100 F-MORE-CARD-RECORDS-EXIST 064200 SET H-CARD-TABLE-OVERFLOW TO TRUE 064300 END-IF. 064400 064500 IF C-NO-INPUT-CARD-RECORDS 064600 SET H-NO-JOB-CARD-RECORDS TO TRUE 064700 END-IF. 064800 064900 A1300-EXIT. 065000 EXIT. 065100/***************************************************************** 065200** A2000-MAINLINE ** 065300** THIS IS THE MAIN PROCESSING LOOP OF THIS PROGRAM. IT CHECKS ** 065400** THE CURRENT RECORD TO SEE IF IT IS A NEW PAGE OF THE REPORT ** 065500** FILE. IF IT IS, IT CALLS THE SECTION TO CHECK THE CONTENTS ** 065600** OF THE PREVIOUS PAGE OF THE REPORT FILE WHICH ARE IN A ** 065700** BUFFER TABLE IN WORKING STORAGE. AFTER THAT CHECK, IT READS ** 065800** ANOTHER RECORD. ** 065900****************************************************************** 066000 A2000-MAINLINE SECTION. 066100 066200 IF (INPUT-NEW-PAGE OR 066300 INPUT-NEW-PAGE-X OR 066400 INPUT-NEW-PAGE-M) AND 066500 C-MULTIPLE-RECORDS-READ 066600 IF T-BUFFER-NDX2 = L-MIN-BANNER-PAGE-SIZE OR 066700 T-BUFFER-NDX2 > L-MIN-BANNER-PAGE-SIZE 066710*** 066800*** ANSI cc w/1 blank before and 1 after the banner 066810*** 066900 IF ((T-BUFFER-NEW-PAGE (1) AND 067000 T-BUFFER-BLANK-LINE (1)) AND 067100 (T-BUFFER-TRIPLE-SPACE (2) AND 067200 T-BUFFER-BLANK-LINE (2)) AND 067300 (T-BUFFER-TRIPLE-SPACE (3) AND 067400 T-BUFFER-BLANK-LINE (3)) AND 067500 (T-BUFFER-SINGLE-SPACE (4) AND 067600 T-BUFFER-BLANK-LINE (4)) AND 067700 (T-BUFFER-SINGLE-SPACE (17) AND 067800 T-BUFFER-BLANK-LINE (17))) OR 067801*** 067810*** ANSI cc w/2 blank before and 0 after the banner 067811*** 067820 ((T-BUFFER-NEW-PAGE (1) AND 067830 T-BUFFER-BLANK-LINE (1)) AND 067840 (T-BUFFER-TRIPLE-SPACE (2) AND 067850 T-BUFFER-BLANK-LINE (2)) AND 067860 (T-BUFFER-TRIPLE-SPACE (3) AND 067870 T-BUFFER-BLANK-LINE (3)) AND 067880 (T-BUFFER-SINGLE-SPACE (4) AND 067890 T-BUFFER-BLANK-LINE (4)) AND 067891 (T-BUFFER-SINGLE-SPACE (5) AND 067892 T-BUFFER-BLANK-LINE (5))) OR 067893*** 067900*** MACHINE w/x'8B' new page, 1 blank before, 1 after the banner 067910*** 068000 ((T-BUFFER-NEW-PAGE-M (1) AND 068100 T-BUFFER-BLANK-LINE (1)) AND 068200 (T-BUFFER-TRIPLE-SPACE-M (2) AND 068300 T-BUFFER-BLANK-LINE (2)) AND 068400 (T-BUFFER-TRIPLE-SPACE-M (3) AND 068500 T-BUFFER-BLANK-LINE (3)) AND 068600 (T-BUFFER-SINGLE-SPACE-X (4) AND 068700 T-BUFFER-BLANK-LINE (4)) AND 068800 (T-BUFFER-SINGLE-SPACE-X (17) AND 068900 T-BUFFER-BLANK-LINE (17))) OR 068910*** 068920*** MACHINE w/x'8B' new page, 2 blank before, 0 after the banner 068930*** 068940 ((T-BUFFER-NEW-PAGE-M (1) AND 068950 T-BUFFER-BLANK-LINE (1)) AND 068960 (T-BUFFER-TRIPLE-SPACE-M (2) AND 068970 T-BUFFER-BLANK-LINE (2)) AND 068980 (T-BUFFER-TRIPLE-SPACE-M (3) AND 068990 T-BUFFER-BLANK-LINE (3)) AND 068991 (T-BUFFER-SINGLE-SPACE-X (4) AND 068992 T-BUFFER-BLANK-LINE (4)) AND 068993 (T-BUFFER-SINGLE-SPACE-X (5) AND 068994 T-BUFFER-BLANK-LINE (5))) OR 068995*** 068996*** MACHINE w/x'89' new page, 1 blank before, 1 after the banner 068997*** 069100 ((T-BUFFER-NEW-PAGE-X (1) AND 069200 T-BUFFER-BLANK-LINE (1)) AND 069300 (T-BUFFER-TRIPLE-SPACE-X (2) AND 069400 T-BUFFER-BLANK-LINE (2)) AND 069500 (T-BUFFER-TRIPLE-SPACE-X (3) AND 069600 T-BUFFER-BLANK-LINE (3)) AND 069700 (T-BUFFER-SINGLE-SPACE-X (4) AND 069800 T-BUFFER-BLANK-LINE (4)) AND 069900 (T-BUFFER-SINGLE-SPACE-X (17) AND 070000 T-BUFFER-BLANK-LINE (17))) OR 070001*** 070010*** MACHINE w/x'89' new page, 2 blank before, 0 after the banner 070020*** 070030 ((T-BUFFER-NEW-PAGE-X (1) AND 070040 T-BUFFER-BLANK-LINE (1)) AND 070050 (T-BUFFER-TRIPLE-SPACE-X (2) AND 070060 T-BUFFER-BLANK-LINE (2)) AND 070070 (T-BUFFER-TRIPLE-SPACE-X (3) AND 070080 T-BUFFER-BLANK-LINE (3)) AND 070090 (T-BUFFER-SINGLE-SPACE-X (4) AND 070091 T-BUFFER-BLANK-LINE (4)) AND 070092 (T-BUFFER-SINGLE-SPACE-X (5) AND 070093 T-BUFFER-BLANK-LINE (5))) 070100 PERFORM S5000-PARSE-BLOCK-LETTERS 070200 END-IF 070300 END-IF 070400 SET T-BUFFER-NDX2 TO +0 070500 END-IF. 070600 070700 SET T-BUFFER-NDX2 UP BY +1. 070800 070900 IF T-BUFFER-NDX2 > T-BUFFER-TABLE-SIZE 071000 SET H-BUFFER-TABLE-OVERFLOW TO TRUE 071100 ELSE 071200 MOVE INPUT-REPORT-RECORD 071300 TO T-BUFFER-LINE (T-BUFFER-NDX2) 071400 PERFORM S4000-READ-INPUT-REPORT 071500 END-IF. 071600 071700 A2000-EXIT. 071800 EXIT. 071900/***************************************************************** 072000** A3000-FINALIZATION ** 072100** THIS SECTION DOES THE FINALIZATION PROCESSING. FIRST IT ** 072200** CALLS THE CALLS THE SECTION TO CREATE THE LAST JOB. THEN IT ** 072300** DOES FINAL PROCESSING DISPLAYS, DETERMINES IF THERE ARE ANY ** 072400** REMAINING REASONS TO SET A BAD RETURN CODE, CLOSES THE FILES ** 072500** AND GETS OUT! ** 072600****************************************************************** 072700 A3000-FINALIZATION SECTION. 072800 072810 IF H-NO-REPORTS-TO-PROCESS 072811 NEXT SENTENCE 072820 ELSE 072830 IF C-ONLY-ONE-REPORT 072831 MOVE H-BANNER-STRING TO H-PREVIOUS-BANNER-STRING 072832 END-IF 072840 PERFORM S5200-CREATE-A-JOB 072910 END-IF. 073000 073100 DISPLAY 'PARSBANR *** END OF "IN PROCESS" MESSAGES '. 073200 DISPLAY ' '. 073300 073400 DISPLAY 'PARSBANR *** DYNALLOC RECORDS READ: ' 073500 C-DYNALLOC-RECORDS-READ. 073600 DISPLAY 'PARSBANR *** INPUT JCL RECORDS READ: ' 073700 C-INPUT-JCL-RECORDS-READ. 073800 DISPLAY 'PARSBANR *** INPUT JOB CARD RECORDS READ: ' 073900 C-INPUT-CARD-RECORDS-READ. 074000 DISPLAY 'PARSBANR *** RECORDS-READ: ' 074100 C-RECORDS-READ. 074200 DISPLAY 'PARSBANR *** RECORDS-WRITTEN: ' 074300 C-RECORDS-WRITTEN. 074400 DISPLAY 'PARSBANR *** REPORTS-IN-FILE: ' 074500 C-REPORTS-IN-FILE. 074501 074510 IF H-NO-REPORTS-TO-PROCESS 074520 NEXT SENTENCE 074530 ELSE 074540 CLOSE OUTPUT-JCL-FILE 074550 END-IF. 074600 074700 EVALUATE TRUE 074800 WHEN F-NO-DATASET-NAME-SYMBOLIC 074900 SET H-NO-DATASET-NAME-SYMBOLIC TO TRUE 075000 WHEN C-NO-INPUT-REPORT-RECORDS 075100 SET H-NO-REPORTS-TO-PROCESS TO TRUE 075200 WHEN C-NO-DYALLOC-RECORD 075300 SET H-NO-DYNALLOC-RECORD TO TRUE 075400 END-EVALUATE. 075500 075600 DISPLAY 'PARSBANR *** ' H-END-OF-PROCESS-MSG. 075700 075800 CLOSE INPUT-REPORT-FILE 075900 INPUT-DYNALLOC-FILE 076000 INPUT-JCL-FILE 076100 INPUT-JOB-CARD-FILE. 076300 076400 MOVE H-RETURN-CODE TO RETURN-CODE. 076500 076600 GOBACK. 076700 076800 A3000-EXIT. 076900 EXIT. 077000/***************************************************************** 077100** S4000-READ-INPUT-REPORT ** 077200** THIS SECTION READS THE MAIN DRIVING INPUT FILE AND INCREMENTS** 077300** FILE COUNTERS. ** 077400****************************************************************** 077500 S4000-READ-INPUT-REPORT SECTION. 077600 077700 READ INPUT-REPORT-FILE 077800 AT END SET F-NO-MORE-RECORDS-TO-PROCESS TO TRUE. 077900 078000 IF F-MORE-RECORDS-EXIST 078100 ADD +1 TO C-RECORDS-READ 078200 C-DISPLAY-ACCUMULATOR 078300 IF C-DISPLAY-ACCUMULATOR = L-DISPLAY-INCREMENT 078400 DISPLAY 'PARSBANR *** RECORDS READ: ' C-RECORDS-READ 078500 MOVE +0 TO C-DISPLAY-ACCUMULATOR 078600 END-IF 078700 END-IF. 078800 078900 S4000-EXIT. 079000 EXIT. 079100/***************************************************************** 079200** S4100-READ-INPUT-DYNALLOC ** 079300** THIS SECTION READS THE INPUT FILE CONTAINING THE NAME OF THE ** 079400** DYNAMICALLY CREATED REPORT FILE COPY. ** 079500****************************************************************** 079600 S4100-READ-INPUT-DYNALLOC SECTION. 079700 079800 READ INPUT-DYNALLOC-FILE 079900 AT END SET F-NO-MORE-DYNALLOC-RECORDS TO TRUE. 080000 080100 IF F-MORE-DYNALLOC-RECORDS-EXIST 080200 ADD +1 TO C-DYNALLOC-RECORDS-READ 080300 END-IF. 080400 080500 S4100-EXIT. 080600 EXIT. 080700/***************************************************************** 080800** S4200-READ-INPUT-JCL ** 080900** THIS FILE READS THE JCL SKELETON INPUT FILE AND INCREMENTS ** 081000** THE FILE COUNTER. ** 081100****************************************************************** 081200 S4200-READ-INPUT-JCL SECTION. 081300 081400 READ INPUT-JCL-FILE INTO T-JCL-LINE (T-JCL-NDX2) 081500 AT END SET F-NO-MORE-JCL-RECORDS TO TRUE. 081600 081700 IF F-MORE-JCL-RECORDS-EXIST 081800 ADD +1 TO C-INPUT-JCL-RECORDS-READ 081900 END-IF. 082000 082100 S4200-EXIT. 082200 EXIT. 082300/***************************************************************** 082400** S4300-READ-INPUT-JOB-CARDS ** 082500** THIS SECTION READS THE INPUT JOB CARD FILE AND INCREMENTS ** 082600** THE FILE COUNTER. ** 082700****************************************************************** 082800 S4300-READ-INPUT-JOB-CARDS SECTION. 082900 083000 READ INPUT-JOB-CARD-FILE 083100 INTO T-JOB-CARD (T-JOB-CARD-NDX2) 083200 AT END SET F-NO-MORE-CARD-RECORDS TO TRUE. 083300 083400 IF F-MORE-CARD-RECORDS-EXIST 083500 ADD +1 TO C-INPUT-CARD-RECORDS-READ 083600 END-IF. 083700 083800 S4300-EXIT. 083900 EXIT. 084000/***************************************************************** 084100** S5000-PARSE-BLOCK-LETTERS ** 084200** THIS IS THE MAIN DRIVING SECTION OF THE PROCESSES WHICH ** 084300** DETERMINE IF THE PAGE IN THE BUFFER TABLE IS A BANNER OR ** 084400** NOT, WHAT THE CONTENTS OF THE BANNER ARE, CREATES THE ** 084500** PREVIOUS REPORT'S JOB, AND FIGURES OUT HOW MANY LINES WERE ** 084600** IN THIS PARTICULAR REPORT. ** 084700****************************************************************** 084800 S5000-PARSE-BLOCK-LETTERS SECTION. 084900 085000 MOVE H-BANNER-STRING TO H-PREVIOUS-BANNER-STRING. 085100 SET F-THIS-IS-A-BANNER TO TRUE. 085200 SET T-BLOCK-NDX2 TO +0. 085300 085400 PERFORM S5100-INSPECT-EACH-BLOCK 085500 VARYING T-BLOCK-NDX1 FROM +1 BY +1 085600 UNTIL T-BLOCK-NDX1 > T-PARSE-LINE-SIZE 085700 AFTER T-PARSE-NDX1 FROM L-PARSE-BEGIN-LINE BY +1 085800 UNTIL T-PARSE-NDX1 > L-PARSE-END-LINE 085900 AFTER T-BYTE-NDX1 FROM +1 BY +1 086000 UNTIL T-BYTE-NDX1 > T-PARSE-BYTE-SIZE 086100 OR F-THIS-IS-NOT-A-BANNER. 086200 086300 IF F-THIS-IS-A-BANNER 086400 IF C-A-BANNER-EXISTS 086500 PERFORM S5200-CREATE-A-JOB 086600 END-IF 086700 ADD +1 TO C-REPORTS-IN-FILE 086800 SET H-SKIPREC-NUMBER TO T-BUFFER-NDX2 086900 COMPUTE H-SKIPREC-NUMBER = C-RECORDS-READ 087000 - H-SKIPREC-NUMBER 087100 - 1 087200 IF H-BANNER-BYTE (1) = SPACE 087300 SET H-BANNER-NDX1 TO +0 087400 PERFORM 087500 VARYING H-BANNER-NDX2 FROM +1 BY +1 087600 UNTIL H-BANNER-NDX2 > H-BANNER-STRING-SIZE 087700 OR H-BANNER-BYTE (H-BANNER-NDX2) > SPACE 087800 END-PERFORM 087900 PERFORM 088000 VARYING H-BANNER-NDX2 FROM H-BANNER-NDX2 BY +1 088100 UNTIL H-BANNER-NDX2 > H-BANNER-STRING-SIZE 088200 SET H-BANNER-NDX1 UP BY +1 088300 MOVE H-BANNER-BYTE (H-BANNER-NDX2) TO 088400 H-BANNER-BYTE (H-BANNER-NDX1) 088500 END-PERFORM 088600 PERFORM 088700 VARYING H-BANNER-NDX1 FROM H-BANNER-NDX1 BY +1 088800 UNTIL H-BANNER-NDX1 > H-BANNER-STRING-SIZE 088900 MOVE SPACE TO H-BANNER-BYTE (H-BANNER-NDX1) 089000 END-PERFORM 089100 END-IF 089200 END-IF. 089300 089400 S5000-EXIT. 089500 EXIT. 089600/***************************************************************** 089700** S5100-INSPECT-EACH-BLOCK ** 089800** THIS SECTION IS CALLED TO LOOK AT EACH POTENTIAL BANNER ** 089900** LETTER BLOCK TO SEE IF THE BLOCK MATCHES THE CRITERIA OF ** 090000** BEING A BANNER LETTER. IF SO, IT PLACES THE LETTER IT FOUND ** 090100** IN AN ARRAY CONTAINING THE BANNER STRING "SO FAR". ** 090200****************************************************************** 090300 S5100-INSPECT-EACH-BLOCK SECTION. 090400 090500 IF T-BLOCK-NDX1 NOT = T-BLOCK-NDX2 090600 SET T-BLOCK-NDX2 TO T-BLOCK-NDX1 090700 SET H-BANNER-NDX1 TO T-BLOCK-NDX1 090800 MOVE T-PARSE-BYTE (T-PARSE-NDX1, 090900 T-BLOCK-NDX1, 091000 T-BYTE-NDX1) 091100 TO H-BANNER-BYTE (H-BANNER-NDX1) 091200 END-IF. 091300 091400 IF T-PARSE-BYTE (T-PARSE-NDX1, 091500 T-BLOCK-NDX1, 091600 T-BYTE-NDX1) NOT = SPACE 091700 IF T-PARSE-BYTE (T-PARSE-NDX1, 091800 T-BLOCK-NDX1, 091900 T-BYTE-NDX1) NOT = 092000 H-BANNER-BYTE (H-BANNER-NDX1) AND 092100 H-BANNER-BYTE (H-BANNER-NDX1) NOT = SPACE 092200 SET F-THIS-IS-NOT-A-BANNER TO TRUE 092300 MOVE H-PREVIOUS-BANNER-STRING TO H-BANNER-STRING 092400 ELSE 092500 MOVE T-PARSE-BYTE (T-PARSE-NDX1, 092600 T-BLOCK-NDX1, 092700 T-BYTE-NDX1) 092800 TO H-BANNER-BYTE (H-BANNER-NDX1) 092900 END-IF 093000 END-IF. 093100 093200 S5100-EXIT. 093300 EXIT. 093400/***************************************************************** 093500** S5200-CREATE-A-JOB ** 093600** ONCE IT'S BEEN DETERMINED THAT WE HAVE A NEW BANNER PAGE, WE ** 093700** NEED TO CREATE A JOB FOR THE PREVIOUS BANNER PAGE AND ITS ** 093800** REPORT. THIS SECTION IS CALLED TO DO THAT. IT DETERMINES ** 093900** HOW MANY LINES WERE IN THE REPORT, CALLS THE SECTION TO FIND ** 094000** A JOB CARD, UNLOADS THE JCL TABLE TO THE OUTPUT FILE, AND ** 094100** PUTS IN THE APPROPRIATE "SKIPREC" AND "STOPAFT" CARDS TO ** 094200** DELINIATE THIS PARTICULAR REPORT FROM THE OTHERS IN THE ** 094300** FILE. ** 094400****************************************************************** 094500 S5200-CREATE-A-JOB SECTION. 094600 094700 SET H-STOPAFT-NUMBER TO T-BUFFER-NDX2. 094800 094900 COMPUTE H-STOPAFT-NUMBER = C-RECORDS-READ 095000 - H-STOPAFT-NUMBER 095100 - H-SKIPREC-NUMBER 095200 - 1. 095300 095400 PERFORM S5300-CHOOSE-FIRST-JOB-CARD. 095500 095600 STRING H-PREVIOUS-BANNER-STRING DELIMITED BY SPACE 095700 L-JOB-SUFFIX DELIMITED BY SIZE 095800 INTO OUTPUT-JOB-NAME 095900 END-STRING. 096000 096100 PERFORM S5400-WRITE-OUTPUT-RECORD. 096200 096300 PERFORM VARYING T-JCL-NDX1 FROM +2 BY +1 096400 UNTIL T-JCL-NDX1 > T-JCL-NDX2 096500 MOVE T-JCL-LINE (T-JCL-NDX1) 096600 TO OUTPUT-JCL-RECORD 096700 PERFORM S5400-WRITE-OUTPUT-RECORD 096800 END-PERFORM. 096900 097000 MOVE SPACES TO OUTPUT-JCL-RECORD. 097100 IF F-MORE-RECORDS-EXIST 097200 STRING L-SKIPREC 097300 H-SKIPREC-NUMBER 097400 L-COMMA 097500 DELIMITED BY SIZE INTO OUTPUT-JCL-RECORD 097600 END-STRING 097700 ELSE 097800 STRING L-SKIPREC 097900 H-SKIPREC-NUMBER 098000 DELIMITED BY SIZE INTO OUTPUT-JCL-RECORD 098100 END-STRING 098200 END-IF. 098300 PERFORM S5400-WRITE-OUTPUT-RECORD. 098400 098500 IF F-MORE-RECORDS-EXIST 098600 MOVE SPACES TO OUTPUT-JCL-RECORD 098700 STRING L-STOPAFT 098800 H-STOPAFT-NUMBER 098900 DELIMITED BY SIZE INTO OUTPUT-JCL-RECORD 099000 END-STRING 099100 PERFORM S5400-WRITE-OUTPUT-RECORD 099200 END-IF. 099300 099400 MOVE L-JOB-END-LINE TO OUTPUT-JCL-RECORD. 099500 PERFORM S5400-WRITE-OUTPUT-RECORD. 099600 099700 S5200-EXIT. 099800 EXIT. 099900/***************************************************************** 100000** S5300-CHOOSE-FIRST-JOB-CARD ** 100100** THIS SECTION PUTS THE DEFAULT JOB CARD IN THE OUTPUT FILE ** 100200** BUFFER AND THEN TRIES TO SEE IF IT CAN FIND A "BETTER" ON. ** 100300** IT COMPARES THE USER ID TO BE USED FOR THIS JOB CARD WITH ** 100400** THE USER ID PREFIXES WHICH WERE LOADED INTO THE JOB CARD ** 100500** TABLE. IF IT FINDS A MATCH, IT USED THAT JOB CARD INSTEAD ** 100600** OF THE DEFAULT ONE. ** 100700****************************************************************** 100800 S5300-CHOOSE-FIRST-JOB-CARD SECTION. 100900 101000 MOVE T-JCL-LINE (1) TO OUTPUT-JCL-RECORD. 101100 101200 PERFORM VARYING T-JOB-CARD-NDX1 FROM +1 BY +1 101300 UNTIL T-JOB-CARD-NDX1 > T-JOB-CARD-NDX2 101400 SET H-PREV-NDX TO +0 101500 SET F-A-MATCH-WAS-FOUND TO TRUE 101600 PERFORM VARYING T-JOB-BYTE-NDX FROM +1 BY +1 101700 UNTIL T-JOB-BYTE-NDX > 8 OR 101800 T-JOB-NAME-BYTE 101900 (T-JOB-CARD-NDX1, T-JOB-BYTE-NDX) = SPACE 102000 SET H-PREV-NDX UP BY +1 102100 IF H-PREV-STRING-BYTE (H-PREV-NDX) NOT = 102200 T-JOB-NAME-BYTE 102300 (T-JOB-CARD-NDX1, T-JOB-BYTE-NDX) 102400 SET F-NO-MATCH-FOUND TO TRUE 102500 END-IF 102600 END-PERFORM 102700 IF F-A-MATCH-WAS-FOUND 102800 MOVE T-JOB-CARD (T-JOB-CARD-NDX1) 102900 TO OUTPUT-JCL-RECORD 103000 SET T-JOB-CARD-NDX1 TO T-JOB-CARD-NDX2 103100 END-IF 103200 END-PERFORM. 103300 103400 S5300-EXIT. 103500 EXIT. 103600/***************************************************************** 103700** S5400-WRITE-OUTPUT-RECORD ** 103800** THIS SECTION WRITES AN OUTPUT RECORD AND INCREMENTS THE FILE ** 103900** COUNTER. ** 104000****************************************************************** 104100 S5400-WRITE-OUTPUT-RECORD SECTION. 104200 104300 WRITE OUTPUT-JCL-RECORD. 104400 104500 ADD +1 TO C-RECORDS-WRITTEN. 104600 104700 S5400-EXIT. 104800 EXIT. ./ ADD NAME=PGMFLOW 000100 IDENTIFICATION DIVISION. TREE 000200 PROGRAM-ID. TREE. TREE 000300******************************************************************OWNERID 000400** DO NOT COPY!! **OWNERID 000500** THIS DOCUMENT CONTAINS TRADE SECRET INFORMATION, THE **OWNERID 000600** EXPRESSION OF WHICH IS AN UNPUBLISHED WORK FULLY PROTECTED **OWNERID 000700** BY THE UNITED STATES COPYRIGHT LAWS AND IS CONSIDERED A **OWNERID 000800** TRADE SECRET OWNED BY UNIPAC SERVICE CORPORATION, **OWNERID 000900** 3015 SOUTH PARKER ROAD, SUITE 400, AURORA, COLORADO 80014. **OWNERID 001000** ALL RIGHTS, TITLE, INTEREST AND OWNERSHIP ARE RESERVED BY **OWNERID 001100** UNIPAC SERVICE CORPORATION. THIS DOCUMENT CANNOT BE **OWNERID 001200** ACQUIRED, COPIED, MODIFIED OR USED IN ANY MANNER WHATSOEVER **OWNERID 001300** WITHOUT THE EXPRESS WRITTEN CONSENT OF UNIPAC SERVICE **OWNERID 001400** CORPORATION. **OWNERID 001500******************************************************************OWNERID 001600 AUTHOR. UNIPAC SERVICE CORPORATION. TREE 001700 DATE-WRITTEN. 01/15/91. TREE 001800 DATE-COMPILED. TREE 001900******************************************************************TREE 002000** REMARKS: **TREE 002100** PRINT A COBOL SOURCE CODE TREE STURCTURE DIAGRAM. **TREE 002200******************************************************************TREE 002300** REVISIONS: **TREE 002400** TREE DIAGRAM * SR NBR * D. A. FAVILLE ** **TREE 002500** VERSION 1.00 * EST. PROD. 01-22-91 **TREE 002600******************************************************************TREE 002700 ENVIRONMENT DIVISION. TREE 002800 CONFIGURATION SECTION. TREE 002900 INPUT-OUTPUT SECTION. TREE 003000 FILE-CONTROL. TREE 003100 SELECT COBOL-FILE TREE 003200 ASSIGN TO COBOLFL. TREE 003300 SELECT WORK-FILE TREE 003400 ASSIGN TO S-WORKFILE. TREE 003500 SELECT PRINT-FILE TREE 003600 ASSIGN TO SYS011-UR-3203-S-PRINTFL. TREE 003700 SELECT STRUCTURE-FILE TREE 003800 ASSIGN TO STRUCT TREE 003900 ORGANIZATION IS INDEXED TREE 004000 ACCESS IS DYNAMIC TREE 004100 RECORD KEY IS STRUCTURE-KEY TREE 004200 FILE STATUS IS VSAM-FILE-RETURN-STATUS. TREE 004300 SELECT SORT-FILE TREE 004400 ASSIGN TO SORTWK1. TREE 004500******************************************************************TREE 004600******************************************************************TREE 004700 DATA DIVISION. TREE 004800 FILE SECTION. TREE 004900 FD COBOL-FILE TREE 005000 RECORDING MODE IS F TREE 005100 LABEL RECORD IS STANDARD TREE 005200 RECORD CONTAINS 80 CHARACTERS TREE 005300 BLOCK CONTAINS 0 RECORDS 005400 DATA RECORD IS COBOL-REC. TREE 005500 01 COBOL-REC. TREE 005600 05 FILLER PIC X(6). TREE 005700 05 AST-TST PIC X. TREE 005800 05 COBOL-DATA. TREE 005900 10 PROCTEST. TREE 006000 15 CHAR-4-TEST PIC X(04). TREE 006100 15 FILLER PIC X(06). TREE 006200 10 FILLER PIC XX. TREE 006300 10 PRG-NAME PIC X(8). TREE 006400 10 FILLER PIC X(45). TREE 006500 05 COBOL-DATA-R1 REDEFINES COBOL-DATA. TREE 006600 10 COB-CHAR-1-64 PIC X(64). TREE 006700 10 COB-CHAR-65 PIC X. TREE 006800 05 COBOL-DATA-R2 REDEFINES COBOL-DATA. TREE 006900 10 COB-CHAR-1 PIC X. TREE 007000 10 COB-CHAR-2-65 PIC X(64). TREE 007100 05 FILLER PIC X(8). TREE 007200 FD WORK-FILE TREE 007300 RECORDING MODE IS F TREE 007400 LABEL RECORD IS STANDARD TREE 007500 RECORD CONTAINS 88 CHARACTERS TREE 007510 BLOCK CONTAINS 0 RECORDS 007700 DATA RECORD IS WORK-REC. TREE 007800 01 WORK-REC. TREE 007900 05 WR-PARA-NAME PIC X(40). TREE 008000 05 WR-PARA-AMT PIC 999. TREE 008100 05 WR-PERF-NAME PIC X(40). TREE 008200 05 WR-PERF-AMT PIC 9999. TREE 008300 05 WR-COND PIC X. TREE 008400 FD PRINT-FILE TREE 008500 RECORDING MODE IS F TREE 008600 LABEL RECORD IS OMITTED TREE 008700 RECORD CONTAINS 132 CHARACTERS TREE 008710 BLOCK CONTAINS 0 RECORDS 008800 DATA RECORD IS PRINT-REC. TREE 008900 01 PRINT-REC PIC X(132). TREE 009000 FD STRUCTURE-FILE TREE 009100 RECORD CONTAINS 70 CHARACTERS TREE 009110 BLOCK CONTAINS 0 RECORDS 009200 DATA RECORD IS STRUCTURE-REC. TREE 009300 01 STRUCTURE-REC. TREE 009400 05 STRUCTURE-KEY. TREE 009500 10 ST-PARA PIC X(30). TREE 009600 10 ST-SEQ PIC 99. TREE 009700 05 ST-PERF PIC X(30). TREE 009800 05 ST-LL-CODE PIC 9. TREE 009900 05 ST-END-CODE PIC X. TREE 010000 05 ST-PAGE PIC 999. TREE 010100 05 ST-LINE PIC 99. TREE 010200 05 ST-COND PIC X. TREE 010300 SD SORT-FILE TREE 010310 BLOCK CONTAINS 0 RECORDS 010400 DATA RECORD IS SORT-REC. TREE 010500 01 SORT-REC. TREE 010600 05 SR-PARA PIC X(40). TREE 010700 05 SR-PARA-CNT PIC 999. TREE 010800 05 SR-PERF PIC X(40). TREE 010900 05 SR-PERF-CNT PIC 9999. TREE 011000 05 SR-COND PIC X. TREE 011100 TREE 011200 WORKING-STORAGE SECTION. TREE 011300 01 A-STANDARD-PROGRAM-ID PIC X(27) VALUE TREE 011400 'UNIPAC/TREE/901210-1.00'. TREE 011500 01 COUNTERS. TREE 011600 05 LN-CT PIC 99 VALUE 99. TREE 011700 05 PG-CT PIC 999 VALUE 0. TREE 011800 05 PT-LN-CT PIC 99 VALUE 00. TREE 011900 05 KEY-CT PIC 99 VALUE 0. TREE 012000 01 FLAGS. TREE 012100 05 EOF-FLAG PIC X VALUE 'N'. TREE 012200 05 LVL-FLAG PIC 9 VALUE 0. TREE 012300 05 RECORD-FOUND PIC X VALUE 'N'. TREE 012400 05 SUPPRESS-W400-FLAG PIC X VALUE 'N'. TREE 012500 05 END-OF-FILE-FLAG PIC X VALUE 'N'. TREE 012600 05 END-OF-SENTENCE-FLAG PIC X VALUE 'N'. TREE 012700 05 CONDITIONAL-FLAG PIC 9 VALUE 0. TREE 012800 01 SUBSCRIPTS COMP-3. TREE 012900 05 X1 PIC 9(5) VALUE 0. TREE 013000 05 X2 PIC 9(5) VALUE 0. TREE 013100 05 X3 PIC 9(5) VALUE 0. TREE 013200 01 HOLDS. TREE 013300 05 INPUT-RECORD PIC X(65). TREE 013400 05 INPUT-RECORD-R1 REDEFINES INPUT-RECORD. TREE 013500 10 IR-1-64 PIC X(64). TREE 013600 10 IR-65 PIC X. TREE 013700 05 INPUT-RECORD-R2 REDEFINES INPUT-RECORD. TREE 013800 10 IR-1 PIC X. TREE 013900 10 IR-2-65 PIC X(64). TREE 014000 05 INPUT-CHAR REDEFINES INPUT-RECORD TREE 014100 PIC X OCCURS 65. TREE 014200 05 WORK-AREA PIC X(3250). TREE 014300 05 WORK-AREA-R1 REDEFINES WORK-AREA. TREE 014400 10 CHAR-1-3249 PIC X(3249). TREE 014500 10 CHAR-3250 PIC X. TREE 014600 05 WORK-AREA-R2 REDEFINES WORK-AREA. TREE 014700 10 CHAR-1 PIC X. TREE 014800 10 CHAR-2-3250 PIC X(3249). TREE 014900 05 WORK-AREA-R3 REDEFINES WORK-AREA. TREE 015000 10 END-TEST-3 PIC XXX. TREE 015100 10 FILLER PIC X(3247). TREE 015200 05 WORK-CHAR REDEFINES WORK-AREA TREE 015300 PIC X OCCURS 3250 TIMES. TREE 015400 05 WORK-AREA-RR REDEFINES WORK-AREA. TREE 015500 10 PERFORM-TEST PIC X(08). TREE 015600 10 PERFORM-TEST-R REDEFINES PERFORM-TEST. TREE 015700 15 SORT-TEST PIC X(5). TREE 015800 15 EXEC-TEST REDEFINES SORT-TEST TREE 015900 PIC X(5). TREE 016000 15 CALL-TEST REDEFINES SORT-TEST TREE 016100 PIC X(5). TREE 016200 15 FILLER PIC XXX. TREE 016300 10 PERFORM-TEST-3 REDEFINES PERFORM-TEST. TREE 016400 15 3-CHAR-TEST PIC X(3). TREE 016500 15 FILLER PIC X(5). TREE 016600 10 PERFORM-TEST-4 REDEFINES PERFORM-TEST. TREE 016700 15 4-CHAR-TEST PIC X(4). TREE 016800 15 FILLER PIC X(4). TREE 016900 10 PERFORM-TEST-5 REDEFINES PERFORM-TEST. TREE 017000 15 5-CHAR-TEST PIC X(5). TREE 017100 15 FILLER PIC XXX. TREE 017200 10 PERFORM-TEST-6 REDEFINES PERFORM-TEST. TREE 017300 15 6-CHAR-TEST PIC X(6). TREE 017400 15 FILLER PIC XX. TREE 017500 10 PERFORM-TEST-7 REDEFINES PERFORM-TEST. TREE 017600 15 7-CHAR-TEST PIC X(7). TREE 017700 15 FILLER PIC X. TREE 017800 10 PERFORM-TEST-8 REDEFINES PERFORM-TEST. TREE 017900 15 8-CHAR-TEST PIC X(8). TREE 018000 10 FILLER PIC X(3242). TREE 018100 05 PARA-HOLD PIC X(40). TREE 018200 05 PARA-AREA PIC X(40). TREE 018300 05 PARA-CHAR REDEFINES PARA-AREA TREE 018400 PIC X OCCURS 40. TREE 018500 05 PERF-HOLD PIC X(40). TREE 018600 05 PERF-AREA PIC X(40). TREE 018700 05 PERF-CHAR REDEFINES PERF-AREA TREE 018800 PIC X OCCURS 40. TREE 018900 05 LVL1-PARA-HOLD PIC X(30). TREE 019000 05 LVL2-PARA-HOLD PIC X(30). TREE 019100 05 LVL3-PARA-HOLD PIC X(30). TREE 019200 05 LVL4-PARA-HOLD PIC X(30). TREE 019300 05 LVL5-PARA-HOLD PIC X(30). TREE 019400 05 LVL6-PARA-HOLD PIC X(30). TREE 019500 05 LVL7-PARA-HOLD PIC X(30). TREE 019600 05 LVL8-PARA-HOLD PIC X(30). TREE 019700 05 LVL9-PARA-HOLD PIC X(30). TREE 019800 05 LVL10-PARA-HOLD PIC X(30). TREE 019900 05 LVL11-PARA-HOLD PIC X(30). TREE 020000 05 LVL12-PARA-HOLD PIC X(30). TREE 020100 05 LVL13-PARA-HOLD PIC X(30). TREE 020200 05 LVL14-PARA-HOLD PIC X(30). TREE 020300 05 LVL15-PARA-HOLD PIC X(30). TREE 020400 05 LVL16-PARA-HOLD PIC X(30). TREE 020500 05 LVL17-PARA-HOLD PIC X(30). TREE 020600 05 LVL1-SEQ-HOLD PIC 99. TREE 020700 05 LVL2-SEQ-HOLD PIC 99. TREE 020800 05 LVL3-SEQ-HOLD PIC 99. TREE 020900 05 LVL4-SEQ-HOLD PIC 99. TREE 021000 05 LVL5-SEQ-HOLD PIC 99. TREE 021100 05 LVL6-SEQ-HOLD PIC 99. TREE 021200 05 LVL7-SEQ-HOLD PIC 99. TREE 021300 05 LVL8-SEQ-HOLD PIC 99. TREE 021400 05 LVL9-SEQ-HOLD PIC 99. TREE 021500 05 LVL10-SEQ-HOLD PIC 99. TREE 021600 05 LVL11-SEQ-HOLD PIC 99. TREE 021700 05 LVL12-SEQ-HOLD PIC 99. TREE 021800 05 LVL13-SEQ-HOLD PIC 99. TREE 021900 05 LVL14-SEQ-HOLD PIC 99. TREE 022000 05 LVL15-SEQ-HOLD PIC 99. TREE 022100 05 LVL16-SEQ-HOLD PIC 99. TREE 022200 05 LVL17-SEQ-HOLD PIC 99. TREE 022300 05 LVL1-END-CODE PIC X. TREE 022400 05 LVL2-END-CODE PIC X. TREE 022500 05 LVL3-END-CODE PIC X. TREE 022600 05 LVL4-END-CODE PIC X. TREE 022700 05 LVL5-END-CODE PIC X. TREE 022800 05 LVL6-END-CODE PIC X. TREE 022900 05 LVL7-END-CODE PIC X. TREE 023000 05 LVL8-END-CODE PIC X. TREE 023100 05 LVL9-END-CODE PIC X. TREE 023200 05 LVL10-END-CODE PIC X. TREE 023300 05 LVL11-END-CODE PIC X. TREE 023400 05 LVL12-END-CODE PIC X. TREE 023500 05 LVL13-END-CODE PIC X. TREE 023600 05 LVL14-END-CODE PIC X. TREE 023700 05 LVL15-END-CODE PIC X. TREE 023800 05 LVL16-END-CODE PIC X. TREE 023900 05 LVL17-END-CODE PIC X. TREE 024000 01 LITERAL-AREA. TREE 024100 05 POINTER-LIT PIC X(05) VALUE '+--> '. TREE 024200 05 POINTER-LIT-C PIC X(05) VALUE '+==> '. TREE 024300 05 DUP-STRU-LIT. TREE 024400 10 FILLER PIC X(18) VALUE TREE 024500 'DISPLAYED ON PAGE '. TREE 024600 10 DUP-LIT-PAGE PIC 999. TREE 024700 10 FILLER PIC X(06) VALUE ' LINE '. TREE 024800 10 DUP-LIT-LINE PIC 99. TREE 024900 01 STRU-HEAD. TREE 025000 05 FILLER PIC X(05) VALUE 'PAGE'. TREE 025100 05 SH-PG-CT PIC ZZZ. TREE 025200 05 FILLER PIC X(12) VALUE SPACES. TREE 025300 05 FILLER PIC X(27) VALUE TREE 025400 'PROGRAM STRUCTURE LIST FOR '. TREE 025500 05 HEAD-PGM-NAME PIC X(30). TREE 025600 05 FILLER PIC X(10) VALUE ' DATE'. TREE 025700 05 HEAD-DATE PIC 99/99/99. TREE 025800 01 DETAIL-LINE. TREE 025900 05 LEVEL-LINE. TREE 026000 10 LL-LN PIC Z9. TREE 026100 10 FILLER PIC XXX. TREE 026200 10 LL-1 PIC X. TREE 026300 10 FILLER PIC X(05). TREE 026400 10 LL-2 PIC X. TREE 026500 10 FILLER PIC X(05). TREE 026600 10 LL-3 PIC X. TREE 026700 10 FILLER PIC X(05). TREE 026800 10 LL-4 PIC X. TREE 026900 10 FILLER PIC X(05). TREE 027000 10 LL-5 PIC X. TREE 027100 10 FILLER PIC X(05). TREE 027200 10 LL-6 PIC X. TREE 027300 10 FILLER PIC X(05). TREE 027400 10 LL-7 PIC X. TREE 027500 10 FILLER PIC X(05). TREE 027600 10 LL-8 PIC X. TREE 027700 10 FILLER PIC X(05). TREE 027800 10 LL-9 PIC X. TREE 027900 10 FILLER PIC X(05). TREE 028000 10 LL-10 PIC X. TREE 028100 10 FILLER PIC X(05). TREE 028200 10 LL-11 PIC X. TREE 028300 10 FILLER PIC X(05). TREE 028400 10 LL-12 PIC X. TREE 028500 10 FILLER PIC X(05). TREE 028600 10 LL-13 PIC X. TREE 028700 10 FILLER PIC X(05). TREE 028800 10 LL-14 PIC X. TREE 028900 10 FILLER PIC X(05). TREE 029000 10 LL-15 PIC X. TREE 029100 10 FILLER PIC X(05). TREE 029200 10 LL-16 PIC X. TREE 029300 10 FILLER PIC X(05). TREE 029400 10 LL-17 PIC X. TREE 029500 10 FILLER PIC X(30). TREE 029600 05 NAME-LINE-1 REDEFINES LEVEL-LINE. TREE 029700 10 FILLER PIC X(04). TREE 029800 10 NL1-NAME PIC X(30). TREE 029900 10 FILLER PIC X(98). TREE 030000 05 NAME-LINE-2 REDEFINES LEVEL-LINE. TREE 030100 10 FILLER PIC X(05). TREE 030200 10 NL2-POINTER-LIT PIC X(05). TREE 030300 10 NL2-NAME PIC X(30). TREE 030400 10 FILLER PIC X(92). TREE 030500 05 NAME-LINE-3 REDEFINES LEVEL-LINE. TREE 030600 10 FILLER PIC X(11). TREE 030700 10 NL3-POINTER-LIT PIC X(05). TREE 030800 10 NL3-NAME PIC X(30). TREE 030900 10 FILLER PIC X(86). TREE 031000 05 NAME-LINE-4 REDEFINES LEVEL-LINE. TREE 031100 10 FILLER PIC X(17). TREE 031200 10 NL4-POINTER-LIT PIC X(05). TREE 031300 10 NL4-NAME PIC X(30). TREE 031400 10 FILLER PIC X(80). TREE 031500 05 NAME-LINE-5 REDEFINES LEVEL-LINE. TREE 031600 10 FILLER PIC X(23). TREE 031700 10 NL5-POINTER-LIT PIC X(05). TREE 031800 10 NL5-NAME PIC X(30). TREE 031900 10 FILLER PIC X(74). TREE 032000 05 NAME-LINE-6 REDEFINES LEVEL-LINE. TREE 032100 10 FILLER PIC X(29). TREE 032200 10 NL6-POINTER-LIT PIC X(05). TREE 032300 10 NL6-NAME PIC X(30). TREE 032400 10 FILLER PIC X(68). TREE 032500 05 NAME-LINE-7 REDEFINES LEVEL-LINE. TREE 032600 10 FILLER PIC X(35). TREE 032700 10 NL7-POINTER-LIT PIC X(05). TREE 032800 10 NL7-NAME PIC X(30). TREE 032900 10 FILLER PIC X(62). TREE 033000 05 NAME-LINE-8 REDEFINES LEVEL-LINE. TREE 033100 10 FILLER PIC X(41). TREE 033200 10 NL8-POINTER-LIT PIC X(05). TREE 033300 10 NL8-NAME PIC X(30). TREE 033400 10 FILLER PIC X(56). TREE 033500 05 NAME-LINE-9 REDEFINES LEVEL-LINE. TREE 033600 10 FILLER PIC X(47). TREE 033700 10 NL9-POINTER-LIT PIC X(05). TREE 033800 10 NL9-NAME PIC X(30). TREE 033900 10 FILLER PIC X(50). TREE 034000 05 NAME-LINE-10 REDEFINES LEVEL-LINE. TREE 034100 10 FILLER PIC X(53). TREE 034200 10 NL10-POINTER-LIT PIC X(05). TREE 034300 10 NL10-NAME PIC X(30). TREE 034400 10 FILLER PIC X(44). TREE 034500 05 NAME-LINE-11 REDEFINES LEVEL-LINE. TREE 034600 10 FILLER PIC X(59). TREE 034700 10 NL11-POINTER-LIT PIC X(05). TREE 034800 10 NL11-NAME PIC X(30). TREE 034900 10 FILLER PIC X(38). TREE 035000 05 NAME-LINE-12 REDEFINES LEVEL-LINE. TREE 035100 10 FILLER PIC X(65). TREE 035200 10 NL12-POINTER-LIT PIC X(05). TREE 035300 10 NL12-NAME PIC X(30). TREE 035400 10 FILLER PIC X(32). TREE 035500 05 NAME-LINE-13 REDEFINES LEVEL-LINE. TREE 035600 10 FILLER PIC X(71). TREE 035700 10 NL13-POINTER-LIT PIC X(05). TREE 035800 10 NL13-NAME PIC X(30). TREE 035900 10 FILLER PIC X(26). TREE 036000 05 NAME-LINE-14 REDEFINES LEVEL-LINE. TREE 036100 10 FILLER PIC X(77). TREE 036200 10 NL14-POINTER-LIT PIC X(05). TREE 036300 10 NL14-NAME PIC X(30). TREE 036400 10 FILLER PIC X(20). TREE 036500 05 NAME-LINE-15 REDEFINES LEVEL-LINE. TREE 036600 10 FILLER PIC X(83). TREE 036700 10 NL15-POINTER-LIT PIC X(05). TREE 036800 10 NL15-NAME PIC X(30). TREE 036900 10 FILLER PIC X(14). TREE 037000 05 NAME-LINE-16 REDEFINES LEVEL-LINE. TREE 037100 10 FILLER PIC X(89). TREE 037200 10 NL16-POINTER-LIT PIC X(05). TREE 037300 10 NL16-NAME PIC X(30). TREE 037400 10 FILLER PIC X(08). TREE 037500 05 NAME-LINE-17 REDEFINES LEVEL-LINE. TREE 037600 10 FILLER PIC X(95). TREE 037700 10 NL17-POINTER-LIT PIC X(05). TREE 037800 10 NL17-NAME PIC X(30). TREE 037900 10 FILLER PIC X(02). TREE 038000 01 WORK-DATE PIC 9(6). TREE 038100 01 WORK-DATE-X REDEFINES WORK-DATE. TREE 038200 05 WD-YR PIC XX. TREE 038300 05 WD-MO PIC XX. TREE 038400 05 WD-DD PIC XX. TREE 038500 01 RPT-DATE-X. TREE 038600 05 RD-MO PIC XX. TREE 038700 05 RD-DD PIC XX. TREE 038800 05 RD-YR PIC XX. TREE 038900 01 RPT-DATE REDEFINES RPT-DATE-X TREE 039000 PIC 9(6). TREE 039100 COPY FLSTAT. TREE 039200***************************************************************** TREE 039300 PROCEDURE DIVISION. TREE 039400******************************************************************TREE 039500 A000-MAINLINE SECTION. TREE 039600 PERFORM A100-OPENS. TREE 039700 PERFORM A200-INITIAL-BYPASS UNTIL PROCTEST = TREE 039800 'PROCEDURE' OR END-OF-FILE-FLAG = 'Y'. TREE 039900 IF END-OF-FILE-FLAG = 'Y' TREE 040000 GO TO A000-EXIT. TREE 040100 PERFORM A300-PROCESS UNTIL END-OF-FILE-FLAG = 'Y'. TREE 040200 A000-EXIT. TREE 040300 PERFORM A110-CLOSE. TREE 040400 PERFORM F000-MAINLINE. TREE 040500 STOP RUN. TREE 040600******************************************************************TREE 040700 A100-OPENS SECTION. TREE 040800 OPEN INPUT COBOL-FILE. TREE 040900 OPEN OUTPUT WORK-FILE. TREE 041000 A100-EXIT. TREE 041100 EXIT. TREE 041200******************************************************************TREE 041300 A110-CLOSE SECTION. TREE 041400 CLOSE COBOL-FILE. TREE 041500 CLOSE WORK-FILE. TREE 041600******************************************************************TREE 041700 A200-INITIAL-BYPASS SECTION. TREE 041800 PERFORM R100-READ-COBOL. TREE 041900 IF PROCTEST = 'PROGRAM-ID' TREE 042000 PERFORM A400-MAKE-NAME-REC. TREE 042100 A200-EXIT. TREE 042200 EXIT. TREE 042300******************************************************************TREE 042400 A300-PROCESS SECTION. TREE 042500 PERFORM R100-READ-COBOL. TREE 042600 IF END-OF-FILE-FLAG = 'Y' TREE 042700 GO TO A300-EXIT. TREE 042800 IF AST-TST = '*' TREE 042900 GO TO A300-EXIT. TREE 043000 IF CHAR-4-TEST = SPACES TREE 043100 PERFORM C100-FIND-PERFORM TREE 043200 GO TO A300-EXIT. TREE 043300 PERFORM B100-MAKE-PARAGRAPH. TREE 043400 A300-EXIT. TREE 043500 EXIT. TREE 043600******************************************************************TREE 043700 A400-MAKE-NAME-REC SECTION. TREE 043800 MOVE SPACES TO WR-PARA-NAME. TREE 043900 MOVE PRG-NAME TO WR-PERF-NAME. TREE 044000 MOVE 0 TO WR-PARA-AMT WR-PERF-AMT. TREE 044100 PERFORM W100-WRITE-WORK. TREE 044200 A400-EXIT. TREE 044300 EXIT. TREE 044400******************************************************************TREE 044500 B100-MAKE-PARAGRAPH SECTION. TREE 044600 MOVE SPACES TO PARA-AREA. TREE 044700 MOVE SPACES TO WORK-AREA. TREE 044800 PERFORM UNTIL COB-CHAR-1 NOT = ' ' TREE 044900 MOVE COB-CHAR-2-65 TO COB-CHAR-1-64 TREE 045000 MOVE ' ' TO COB-CHAR-65 TREE 045100 END-PERFORM. TREE 045200 MOVE COBOL-DATA TO WORK-AREA. TREE 045300 MOVE 1 TO X1 X2. TREE 045400 PERFORM UNTIL WORK-CHAR(X1) = ' ' TREE 045500 OR WORK-CHAR(X1) = '.' TREE 045600 MOVE WORK-CHAR(X1) TO PARA-CHAR(X2) TREE 045700 ADD 1 TO X1 X2 TREE 045800 END-PERFORM. TREE 045900 PERFORM UNTIL WORK-CHAR(X1) NOT = ' ' TREE 046000 ADD 1 TO X1 TREE 046100 END-PERFORM. TREE 046110 IF PARA-AREA = 'COPY ' 046120 GO TO B100-EXIT. 046200 IF WORK-CHAR(X1) = 'S' TREE 046300 ADD 1 TO WR-PARA-AMT TREE 046400 MOVE PARA-AREA TO PARA-HOLD. TREE 046500 B100-EXIT. TREE 046600 EXIT. TREE 046700******************************************************************TREE 046800 C100-FIND-PERFORM SECTION. TREE 046900 IF COBOL-DATA = SPACES TREE 047000 GO TO C100-EXIT. TREE 047100 INITIALIZE WORK-AREA. TREE 047200 MOVE 0 TO CONDITIONAL-FLAG. TREE 047300 MOVE 1 TO X1. TREE 047400 PERFORM Z100-MOVE-TO-WORK-AREA. TREE 047500 MOVE 'N' TO END-OF-SENTENCE-FLAG TREE 047600 PERFORM C200-TEST-FOR-MATCH UNTIL TREE 047700 END-OF-SENTENCE-FLAG = 'Y'. TREE 047800 C100-EXIT. TREE 047900 EXIT. TREE 048000******************************************************************TREE 048100 C200-TEST-FOR-MATCH SECTION. TREE 048200 IF 3-CHAR-TEST = 'IF ' OR TREE 048300 5-CHAR-TEST = 'WHEN ' TREE 048400 ADD 1 TO CONDITIONAL-FLAG. TREE 048500 IF 7-CHAR-TEST = 'END-IF ' TREE 048600 SUBTRACT 1 FROM CONDITIONAL-FLAG. TREE 048700 IF PERFORM-TEST = 'PERFORM ' TREE 048800 PERFORM C300-BUILD-PERFORM. TREE 048900 IF SORT-TEST = 'SORT ' TREE 049000 PERFORM C500-BUILD-SORT. TREE 049100 IF EXEC-TEST = 'EXEC ' TREE 049200 PERFORM C600-BUILD-EXEC. TREE 049300 IF CALL-TEST = 'CALL ' TREE 049400 PERFORM C700-BUILD-CALL. TREE 049500 PERFORM Z400-FIND-NEXT-WORD. TREE 049600 C200-EXIT. TREE 049700 EXIT. TREE 049800******************************************************************TREE 049900 C300-BUILD-PERFORM SECTION. TREE 050000 PERFORM Z400-FIND-NEXT-WORD. TREE 050100 IF 6-CHAR-TEST = 'UNTIL ' OR 'WHILE ' TREE 050200 GO TO C300-EXIT. TREE 050300 MOVE SPACES TO PERF-AREA. TREE 050400 MOVE 1 TO X1 X2. TREE 050500 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 050600 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 050700 ADD 1 TO X1 X2 TREE 050800 END-PERFORM. TREE 050900 MOVE PERF-AREA TO PERF-HOLD. TREE 051000 PERFORM C400-BUILD-OUTPUT. TREE 051100 C300-EXIT. TREE 051200 EXIT. TREE 051300******************************************************************TREE 051400 C400-BUILD-OUTPUT SECTION. TREE 051500 ADD 1 TO WR-PERF-AMT. TREE 051600 MOVE PARA-HOLD TO WR-PARA-NAME. TREE 051700 MOVE PERF-HOLD TO WR-PERF-NAME. TREE 051800 PERFORM W100-WRITE-WORK. TREE 051900 C400-EXIT. TREE 052000 EXIT. TREE 052100******************************************************************TREE 052200 C500-BUILD-SORT SECTION. TREE 052300 PERFORM Z400-FIND-NEXT-WORD UNTIL 6-CHAR-TEST = TREE 052400 'USING ' OR 'INPUT ' OR END-OF-SENTENCE-FLAG = 'Y'. TREE 052500 IF END-OF-SENTENCE-FLAG = 'Y' TREE 052600 GO TO C500-EXIT. TREE 052700 IF 6-CHAR-TEST = 'USING ' TREE 052800 GO TO C510-TEST-GIVING. TREE 052900 PERFORM Z400-FIND-NEXT-WORD. TREE 053000 PERFORM Z400-FIND-NEXT-WORD. TREE 053100 IF 3-CHAR-TEST = 'IS ' TREE 053200 PERFORM Z400-FIND-NEXT-WORD. TREE 053300 MOVE 1 TO X1 X2. TREE 053400 MOVE SPACES TO PERF-AREA. TREE 053500 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 053600 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 053700 ADD 1 TO X1 X2 TREE 053800 END-PERFORM. TREE 053900 MOVE PERF-AREA TO PERF-HOLD. TREE 054000 PERFORM C400-BUILD-OUTPUT. TREE 054100 C510-TEST-GIVING. TREE 054200 PERFORM Z400-FIND-NEXT-WORD UNTIL 7-CHAR-TEST = TREE 054300 'GIVING ' OR 'OUTPUT ' OR END-OF-SENTENCE-FLAG = 'Y'. 054400 IF END-OF-SENTENCE-FLAG = 'Y' TREE 054500 GO TO C500-EXIT. TREE 054600 IF 7-CHAR-TEST = 'GIVING ' TREE 054700 GO TO C500-EXIT. TREE 054800 PERFORM Z400-FIND-NEXT-WORD. TREE 054900 PERFORM Z400-FIND-NEXT-WORD. TREE 055000 IF 3-CHAR-TEST = 'IS ' TREE 055100 PERFORM Z400-FIND-NEXT-WORD. TREE 055200 MOVE 1 TO X1 X2. TREE 055300 MOVE SPACES TO PERF-AREA. TREE 055400 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 055500 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 055600 ADD 1 TO X1 X2 TREE 055700 END-PERFORM. TREE 055800 MOVE PERF-AREA TO PERF-HOLD. TREE 055900 PERFORM C400-BUILD-OUTPUT. TREE 056000 C500-EXIT. TREE 056100 EXIT. TREE 056200******************************************************************TREE 056300 C600-BUILD-EXEC SECTION. TREE 056400 MOVE 'N' TO END-OF-SENTENCE-FLAG. TREE 056500 PERFORM Z400-FIND-NEXT-WORD UNTIL 5-CHAR-TEST = TREE 056600 'CICS ' OR END-OF-SENTENCE-FLAG = 'Y'. TREE 056700 IF END-OF-SENTENCE-FLAG = 'Y' TREE 056800 GO TO C600-EXIT. TREE 056900 PERFORM Z400-FIND-NEXT-WORD. TREE 057000 IF 5-CHAR-TEST = 'LINK ' TREE 057100 PERFORM D100-BUILD-LINK-NAME TREE 057200 GO TO C600-EXIT. TREE 057300 IF 7-CHAR-TEST = 'HANDLE ' TREE 057400 PERFORM Z400-FIND-NEXT-WORD TREE 057500 IF 7-CHAR-TEST = 'CONDITI' TREE 057600 ADD 1 TO CONDITIONAL-FLAG TREE 057700 MOVE 'N' TO END-OF-SENTENCE-FLAG TREE 057800 PERFORM D200-BUILD-HANDLE-NAME UNTIL TREE 057900 END-OF-SENTENCE-FLAG = 'Y' TREE 058000 END-IF TREE 058100 IF 4-CHAR-TEST = 'AID ' TREE 058200 ADD 1 TO CONDITIONAL-FLAG TREE 058300 MOVE 'N' TO END-OF-SENTENCE-FLAG TREE 058400 PERFORM D300-BUILD-AID-NAME UNTIL TREE 058500 END-OF-SENTENCE-FLAG = 'Y' TREE 058600 END-IF. TREE 058700 C600-EXIT. TREE 058800 EXIT. TREE 058900******************************************************************TREE 059000 C700-BUILD-CALL SECTION. TREE 059100 MOVE 'N' TO END-OF-SENTENCE-FLAG. TREE 059200 PERFORM Z400-FIND-NEXT-WORD. TREE 059300 MOVE 1 TO X1 X2. TREE 059400 MOVE SPACES TO PERF-AREA. TREE 059500 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 059600 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 059700 ADD 1 TO X1 X2 TREE 059800 END-PERFORM. TREE 059900 MOVE PERF-AREA TO PERF-HOLD. TREE 060000 PERFORM C400-BUILD-OUTPUT. TREE 060100 C700-EXIT. TREE 060200 EXIT. TREE 060300******************************************************************TREE 060400 D100-BUILD-LINK-NAME SECTION. TREE 060500 MOVE 'N' TO END-OF-SENTENCE-FLAG. TREE 060600 PERFORM Z400-FIND-NEXT-WORD UNTIL 8-CHAR-TEST = 'PROGRAM ' TREE 060700 OR END-OF-SENTENCE-FLAG = 'Y'. TREE 060800 IF END-OF-SENTENCE-FLAG = 'Y' TREE 060900 GO TO D100-EXIT. TREE 061000 PERFORM Z400-FIND-NEXT-WORD. TREE 061100 MOVE 1 TO X1 X2. TREE 061200 MOVE SPACES TO PERF-AREA. TREE 061300 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 061400 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 061500 ADD 1 TO X1 X2 TREE 061600 END-PERFORM. TREE 061700 MOVE PERF-AREA TO PERF-HOLD. TREE 061800 PERFORM C400-BUILD-OUTPUT. TREE 061900 D100-EXIT. TREE 062000 EXIT. TREE 062100******************************************************************TREE 062200 D200-BUILD-HANDLE-NAME SECTION. TREE 062300 PERFORM Z400-FIND-NEXT-WORD TREE 062400 IF END-OF-SENTENCE-FLAG = 'Y' GO TO D200-EXIT. TREE 062500 IF 8-CHAR-TEST = 'DSIDERR ' OR 'NOTOPEN ' OR 'NOSPACE ' OR TREE 062600 'LENGERR ' OR 'ENDFILE ' OR 'DISABLED' TREE 062700 PERFORM E100-BUILD-CONDITION-NAME TREE 062800 GO TO D200-EXIT. TREE 062900 IF 7-CHAR-TEST = 'NOTFND ' TREE 063000 PERFORM E100-BUILD-CONDITION-NAME. TREE 063100 D200-EXIT. TREE 063200 EXIT. TREE 063300******************************************************************TREE 063400 D300-BUILD-AID-NAME SECTION. TREE 063500 PERFORM Z400-FIND-NEXT-WORD TREE 063600 IF END-OF-SENTENCE-FLAG = 'Y' GO TO D300-EXIT. TREE 063700 IF 7-CHAR-TEST = 'ANYKEY ' TREE 063800 PERFORM E100-BUILD-CONDITION-NAME TREE 063900 GO TO D300-EXIT. TREE 064000 IF 6-CHAR-TEST = 'CLEAR ' OR 'ENTER ' TREE 064100 PERFORM E100-BUILD-CONDITION-NAME TREE 064200 GO TO D300-EXIT. TREE 064300 IF 4-CHAR-TEST = 'PA1 ' OR 'PA2 ' OR 'PA3' OR TREE 064400 'PF1 ' OR 'PF2 ' OR 'PF3 ' OR 'PF4 ' OR 'PF5 ' OR TREE 064500 'PF6 ' OR 'PF7 ' OR 'PF8 ' OR 'PF9 ' TREE 064600 PERFORM E100-BUILD-CONDITION-NAME TREE 064700 GO TO D300-EXIT. TREE 064800 IF 5-CHAR-TEST = 'PF10 ' OR 'PF11 ' OR 'PF12 ' OR 'PF13 ' TREE 064900 OR 'PF14 ' OR 'PF15 ' OR 'PF16 ' OR 'PF17 ' TREE 065000 OR 'PF18 ' OR 'PF19 ' OR 'PF20 ' OR 'PF21 ' TREE 065100 OR 'PF22 ' OR 'PF23 ' OR 'PF24 ' TREE 065200 PERFORM E100-BUILD-CONDITION-NAME. TREE 065300 D300-EXIT. TREE 065400 EXIT. TREE 065500******************************************************************TREE 065600 E100-BUILD-CONDITION-NAME SECTION. TREE 065700 PERFORM Z400-FIND-NEXT-WORD. TREE 065800 MOVE 1 TO X1 X2. TREE 065900 MOVE SPACES TO PERF-AREA. TREE 066000 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 066100 IF WORK-CHAR(X1) NOT = '(' AND ')' TREE 066200 MOVE WORK-CHAR(X1) TO PERF-CHAR(X2) TREE 066300 ADD 1 TO X1 X2 TREE 066400 ELSE TREE 066500 ADD 1 TO X1 TREE 066600 END-IF TREE 066700 END-PERFORM. TREE 066800 MOVE PERF-AREA TO PERF-HOLD. TREE 066900 PERFORM C400-BUILD-OUTPUT. TREE 067000 E100-EXIT. TREE 067100 EXIT. TREE 067200******************************************************************TREE 067300* *TREE 067400* THIS PART OF THE PROGRAM WILL BUILD THE STRUCTURE FILE *TREE 067500* ASSIGN THE NECESSARY CODES AND PRINT THE TREE STRUCUTRE *TREE 067600* DIAGRAM OF THE SOURCE CODE *TREE 067700* *TREE 067800******************************************************************TREE 067900 F000-MAINLINE SECTION. TREE 068000 ACCEPT WORK-DATE FROM DATE. TREE 068100 PERFORM Z999-CVT-DATE. TREE 068200 MOVE RPT-DATE TO HEAD-DATE. TREE 068300 OPEN INPUT WORK-FILE. TREE 068400 OPEN OUTPUT STRUCTURE-FILE. TREE 068500 SORT SORT-FILE ON ASCENDING KEY SR-PARA SR-PERF-CNT TREE 068600 INPUT PROCEDURE IS F100-SORT-IN TREE 068700 OUTPUT PROCEDURE IS G100-SORT-OUT. TREE 068800 PERFORM G200-ASSIGN-LL-CODE. TREE 068900 PERFORM G300-ASSIGN-END-CODE. TREE 069000 PERFORM H100-REPORT UNTIL EOF-FLAG = 'Y'. TREE 069100 CLOSE STRUCTURE-FILE TREE 069200 PRINT-FILE. TREE 069300 F000-EXIT. TREE 069400 EXIT. TREE 069500******************************************************************TREE 069600 F100-SORT-IN SECTION. TREE 069700 READ WORK-FILE INTO SORT-REC TREE 069800 AT END CLOSE WORK-FILE TREE 069900 GO TO F100-EXIT. TREE 070000 RELEASE SORT-REC. TREE 070100 GO TO F100-SORT-IN. TREE 070200 F100-EXIT. TREE 070300 EXIT. TREE 070400******************************************************************TREE 070500 G100-SORT-OUT SECTION. TREE 070600 RETURN SORT-FILE TREE 070700 AT END CLOSE STRUCTURE-FILE TREE 070800 GO TO G100-EXIT. TREE 070900 IF SR-PARA = SPACES TREE 071000 MOVE SR-PERF TO HEAD-PGM-NAME TREE 071100 GO TO G100-SORT-OUT. TREE 071200 IF SR-PARA NOT = PARA-HOLD TREE 071300 MOVE SR-PARA TO PARA-HOLD TREE 071400 MOVE 0 TO KEY-CT. TREE 071500 ADD 1 TO KEY-CT. TREE 071600 MOVE SR-PARA TO ST-PARA. TREE 071700 MOVE KEY-CT TO ST-SEQ. TREE 071800 MOVE SR-PERF TO ST-PERF. TREE 071900 MOVE SR-COND TO ST-COND. TREE 072000 MOVE 0 TO ST-LL-CODE ST-PAGE ST-LINE. TREE 072100 MOVE SPACE TO ST-END-CODE. TREE 072200 WRITE STRUCTURE-REC. TREE 072300 GO TO G100-SORT-OUT. TREE 072400 G100-EXIT. TREE 072500 EXIT. TREE 072600******************************************************************TREE 072700 G200-ASSIGN-LL-CODE SECTION. TREE 072800 OPEN INPUT WORK-FILE TREE 072900 I-O STRUCTURE-FILE. TREE 073000 PERFORM G210-SET-CODES UNTIL EOF-FLAG = 'Y'. TREE 073100 MOVE 'N' TO EOF-FLAG. TREE 073200 CLOSE WORK-FILE TREE 073300 STRUCTURE-FILE. TREE 073400 G200-EXIT. TREE 073500 EXIT. TREE 073600******************************************************************TREE 073700 G210-SET-CODES SECTION. TREE 073800 PERFORM R200-READ-WORK-FILE TREE 073900 IF EOF-FLAG = 'Y' GO TO G210-EXIT. TREE 074000 MOVE WR-PERF-NAME TO ST-PARA. TREE 074100 MOVE 01 TO ST-SEQ. TREE 074200 MOVE 'N' TO RECORD-FOUND. TREE 074300 PERFORM R300-READ-STRUCTURE. TREE 074400 IF RECORD-FOUND = 'Y' TREE 074500 PERFORM G230-SET-ALL-LL-CODES TREE 074600 UNTIL WR-PERF-NAME NOT = ST-PARA. TREE 074700 MOVE 'N' TO EOF-FLAG. TREE 074800 G210-EXIT. TREE 074900 EXIT. TREE 075000******************************************************************TREE 075100 G230-SET-ALL-LL-CODES SECTION. TREE 075200 IF ST-LL-CODE > 0 TREE 075300 MOVE 2 TO ST-LL-CODE TREE 075400 ELSE TREE 075500 MOVE 1 TO ST-LL-CODE. TREE 075600 PERFORM W200-REWRITE-STRUCTURE. TREE 075700 PERFORM R400-READ-STRUCTURE-NEXT. TREE 075800 G230-EXIT. TREE 075900 EXIT. TREE 076000******************************************************************TREE 076100 G300-ASSIGN-END-CODE SECTION. TREE 076200 OPEN I-O STRUCTURE-FILE. TREE 076300 PERFORM R400-READ-STRUCTURE-NEXT. TREE 076400 MOVE ST-PARA TO LVL10-PARA-HOLD LVL9-PARA-HOLD. TREE 076500 MOVE ST-SEQ TO LVL9-SEQ-HOLD. TREE 076600 PERFORM G310-SET-END-CODES UNTIL EOF-FLAG = 'Y'. TREE 076700 CLOSE STRUCTURE-FILE. TREE 076800 MOVE 'N' TO EOF-FLAG. TREE 076900 MOVE SPACES TO LVL10-PARA-HOLD LVL9-PARA-HOLD. TREE 077000 MOVE ZERO TO LVL9-SEQ-HOLD. TREE 077100 G300-EXIT. TREE 077200 EXIT. TREE 077300******************************************************************TREE 077400 G310-SET-END-CODES SECTION. TREE 077500 PERFORM R400-READ-STRUCTURE-NEXT. TREE 077600 IF ST-PARA NOT = LVL10-PARA-HOLD OR EOF-FLAG = 'Y' TREE 077700 MOVE LVL9-PARA-HOLD TO ST-PARA TREE 077800 MOVE LVL9-SEQ-HOLD TO ST-SEQ TREE 077900 PERFORM S100-START-STRUCTURE TREE 078000 PERFORM R400-READ-STRUCTURE-NEXT TREE 078100 MOVE 'E' TO ST-END-CODE TREE 078200 PERFORM W200-REWRITE-STRUCTURE TREE 078300 PERFORM R400-READ-STRUCTURE-NEXT TREE 078400 MOVE ST-PARA TO LVL10-PARA-HOLD. TREE 078500 MOVE ST-PARA TO LVL9-PARA-HOLD. TREE 078600 MOVE ST-SEQ TO LVL9-SEQ-HOLD. TREE 078700******************************************************************TREE 078800 H100-REPORT SECTION. TREE 078900 OPEN OUTPUT PRINT-FILE. TREE 079000 PERFORM M100-HEADING. TREE 079100 OPEN I-O STRUCTURE-FILE. TREE 079200 MOVE SPACES TO ST-PARA. TREE 079300 MOVE 0 TO ST-SEQ. TREE 079400 MOVE 'N' TO EOF-FLAG. TREE 079500 PERFORM I100-LEVEL1 UNTIL EOF-FLAG = 'Y'. TREE 079600 H100-EXIT. TREE 079700 EXIT. TREE 079800******************************************************************TREE 079900 I100-LEVEL1 SECTION. TREE 080000 PERFORM R400-READ-STRUCTURE-NEXT. TREE 080100 IF EOF-FLAG = 'Y' GO TO I100-EXIT. TREE 080200 IF ST-LL-CODE = 0 TREE 080300 NEXT SENTENCE TREE 080400 ELSE TREE 080500 GO TO I100-LEVEL1. TREE 080600 IF ST-PARA NOT = LVL1-PARA-HOLD TREE 080700 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 080800 MOVE LN-CT TO LL-LN TREE 080900 PERFORM J200-SET-PG-LN TREE 081000 MOVE ST-PARA TO NL1-NAME TREE 081100 PERFORM W300-PRINT. TREE 081200 MOVE '|' TO LL-1. TREE 081300 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 081400 PERFORM W500-PRINT TREE 081500 PERFORM M100-HEADING. TREE 081600 PERFORM W400-PRINT. TREE 081700 MOVE POINTER-LIT TO NL2-POINTER-LIT. TREE 081800 MOVE ST-PERF TO NL2-NAME. TREE 081900 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 082000 MOVE LN-CT TO LL-LN. TREE 082100 PERFORM J200-SET-PG-LN. TREE 082200 PERFORM W300-PRINT. TREE 082300 MOVE ST-END-CODE TO LVL1-END-CODE. TREE 082400 MOVE ST-PARA TO LVL1-PARA-HOLD. TREE 082500 MOVE ST-SEQ TO LVL1-SEQ-HOLD. TREE 082600 MOVE ST-PERF TO ST-PARA. TREE 082700 MOVE 01 TO ST-SEQ. TREE 082800 PERFORM R300-READ-STRUCTURE. TREE 082900 IF SUCCESSFUL TREE 083000 MOVE ' ' TO LVL2-END-CODE TREE 083100 PERFORM I200-LEVEL2. TREE 083200 MOVE LVL1-PARA-HOLD TO ST-PARA. TREE 083300 MOVE LVL1-SEQ-HOLD TO ST-SEQ. TREE 083400 PERFORM R300-READ-STRUCTURE. TREE 083500 MOVE 'N' TO EOF-FLAG. TREE 083600 I100-EXIT. TREE 083700 EXIT. TREE 083800******************************************************************TREE 083900 I200-LEVEL2 SECTION. TREE 084000 MOVE ' ' TO RECORD-FOUND. TREE 084100 PERFORM L100-TEST-FOR-DUP-STRU. TREE 084200 IF RECORD-FOUND = 'D' TREE 084300 MOVE '|' TO LL-1 LL-2 TREE 084400 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 084500 PERFORM W500-PRINT TREE 084600 PERFORM M100-HEADING TREE 084700 END-IF TREE 084800 PERFORM W400-PRINT TREE 084900 MOVE '|' TO LL-1 TREE 085000 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 085100 MOVE LN-CT TO LL-LN TREE 085200 PERFORM J200-SET-PG-LN TREE 085300 MOVE DUP-STRU-LIT TO NL3-NAME TREE 085400 MOVE POINTER-LIT TO NL3-POINTER-LIT TREE 085500 PERFORM W300-PRINT TREE 085600 GO TO I200-EXIT. TREE 085700 MOVE '|' TO LL-1 LL-2. TREE 085800 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 085900 PERFORM W500-PRINT TREE 086000 PERFORM M100-HEADING. TREE 086100 PERFORM W400-PRINT. TREE 086200 MOVE '|' TO LL-1. TREE 086300 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 086400 MOVE LN-CT TO LL-LN. TREE 086500 PERFORM J200-SET-PG-LN. TREE 086600 MOVE ST-PERF TO NL3-NAME. TREE 086700 MOVE POINTER-LIT TO NL3-POINTER-LIT. TREE 086800 PERFORM W300-PRINT. TREE 086900 MOVE ST-END-CODE TO LVL2-END-CODE. TREE 087000 MOVE ST-PARA TO LVL2-PARA-HOLD. TREE 087100 MOVE ST-SEQ TO LVL2-SEQ-HOLD. TREE 087200 MOVE ST-PERF TO ST-PARA. TREE 087300 MOVE 01 TO ST-SEQ. TREE 087400 PERFORM R300-READ-STRUCTURE. TREE 087500 IF SUCCESSFUL TREE 087600 MOVE ' ' TO LVL3-END-CODE TREE 087700 PERFORM I300-LEVEL3. TREE 087800 MOVE LVL2-PARA-HOLD TO ST-PARA. TREE 087900 MOVE LVL2-SEQ-HOLD TO ST-SEQ. TREE 088000 PERFORM R300-READ-STRUCTURE. TREE 088100 PERFORM R400-READ-STRUCTURE-NEXT. TREE 088200 IF ST-PARA = LVL2-PARA-HOLD TREE 088300 GO TO I200-LEVEL2. TREE 088400 I200-EXIT. TREE 088500 EXIT. TREE 088600******************************************************************TREE 088700 I300-LEVEL3 SECTION. TREE 088800 MOVE ' ' TO RECORD-FOUND. TREE 088900 PERFORM L100-TEST-FOR-DUP-STRU. TREE 089000 IF RECORD-FOUND = 'D' TREE 089100 MOVE '|' TO LL-1 LL-2 LL-3 TREE 089200 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 089300 PERFORM W500-PRINT TREE 089400 PERFORM M100-HEADING TREE 089500 END-IF TREE 089600 PERFORM W400-PRINT TREE 089700 MOVE '|' TO LL-1 LL-2 TREE 089800 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 089900 MOVE LN-CT TO LL-LN TREE 090000 PERFORM J200-SET-PG-LN TREE 090100 MOVE DUP-STRU-LIT TO NL4-NAME TREE 090200 MOVE POINTER-LIT TO NL4-POINTER-LIT TREE 090300 PERFORM W300-PRINT TREE 090400 GO TO I300-EXIT. TREE 090500 MOVE '|' TO LL-1 LL-2 LL-3. TREE 090600 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 090700 PERFORM W500-PRINT TREE 090800 PERFORM M100-HEADING. TREE 090900 PERFORM W400-PRINT. TREE 091000 MOVE '|' TO LL-1 LL-2. TREE 091100 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 091200 MOVE LN-CT TO LL-LN. TREE 091300 PERFORM J200-SET-PG-LN. TREE 091400 MOVE ST-PERF TO NL4-NAME. TREE 091500 MOVE POINTER-LIT TO NL4-POINTER-LIT. TREE 091600 PERFORM W300-PRINT. TREE 091700 MOVE ST-END-CODE TO LVL3-END-CODE. TREE 091800 MOVE ST-PARA TO LVL3-PARA-HOLD. TREE 091900 MOVE ST-SEQ TO LVL3-SEQ-HOLD. TREE 092000 MOVE ST-PERF TO ST-PARA. TREE 092100 MOVE 01 TO ST-SEQ. TREE 092200 PERFORM R300-READ-STRUCTURE. TREE 092300 IF SUCCESSFUL TREE 092400 MOVE ' ' TO LVL4-END-CODE TREE 092500 PERFORM I400-LEVEL4. TREE 092600 MOVE LVL3-PARA-HOLD TO ST-PARA. TREE 092700 MOVE LVL3-SEQ-HOLD TO ST-SEQ. TREE 092800 PERFORM R300-READ-STRUCTURE. TREE 092900 PERFORM R400-READ-STRUCTURE-NEXT. TREE 093000 IF ST-PARA = LVL3-PARA-HOLD TREE 093100 GO TO I300-LEVEL3. TREE 093200 I300-EXIT. TREE 093300 EXIT. TREE 093400******************************************************************TREE 093500 I400-LEVEL4 SECTION. TREE 093600 MOVE ' ' TO RECORD-FOUND. TREE 093700 PERFORM L100-TEST-FOR-DUP-STRU. TREE 093800 IF RECORD-FOUND = 'D' TREE 093900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 TREE 094000 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 094100 PERFORM W500-PRINT TREE 094200 PERFORM M100-HEADING TREE 094300 END-IF TREE 094400 PERFORM W400-PRINT TREE 094500 MOVE '|' TO LL-1 LL-2 LL-3 TREE 094600 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 094700 MOVE LN-CT TO LL-LN TREE 094800 PERFORM J200-SET-PG-LN TREE 094900 MOVE DUP-STRU-LIT TO NL5-NAME TREE 095000 MOVE POINTER-LIT TO NL5-POINTER-LIT TREE 095100 PERFORM W300-PRINT TREE 095200 GO TO I400-EXIT. TREE 095300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 TREE 095400 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 095500 PERFORM W500-PRINT TREE 095600 PERFORM M100-HEADING. TREE 095700 PERFORM W400-PRINT. TREE 095800 MOVE '|' TO LL-1 LL-2 LL-3. TREE 095900 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 096000 MOVE LN-CT TO LL-LN. TREE 096100 PERFORM J200-SET-PG-LN. TREE 096200 MOVE ST-PERF TO NL5-NAME. TREE 096300 MOVE POINTER-LIT TO NL5-POINTER-LIT. TREE 096400 PERFORM W300-PRINT. TREE 096500 MOVE ST-END-CODE TO LVL4-END-CODE. TREE 096600 MOVE ST-PARA TO LVL4-PARA-HOLD. TREE 096700 MOVE ST-SEQ TO LVL4-SEQ-HOLD. TREE 096800 MOVE ST-PERF TO ST-PARA. TREE 096900 MOVE 01 TO ST-SEQ. TREE 097000 PERFORM R300-READ-STRUCTURE. TREE 097100 IF SUCCESSFUL TREE 097200 MOVE ' ' TO LVL5-END-CODE TREE 097300 PERFORM I500-LEVEL5. TREE 097400 MOVE LVL4-PARA-HOLD TO ST-PARA. TREE 097500 MOVE LVL4-SEQ-HOLD TO ST-SEQ. TREE 097600 PERFORM R300-READ-STRUCTURE. TREE 097700 PERFORM R400-READ-STRUCTURE-NEXT. TREE 097800 IF ST-PARA = LVL4-PARA-HOLD TREE 097900 GO TO I400-LEVEL4. TREE 098000 I400-EXIT. TREE 098100 EXIT. TREE 098200******************************************************************TREE 098300 I500-LEVEL5 SECTION. TREE 098400 MOVE ' ' TO RECORD-FOUND. TREE 098500 PERFORM L100-TEST-FOR-DUP-STRU. TREE 098600 IF RECORD-FOUND = 'D' TREE 098700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 TREE 098800 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 098900 PERFORM W500-PRINT TREE 099000 PERFORM M100-HEADING TREE 099100 END-IF TREE 099200 PERFORM W400-PRINT TREE 099300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 TREE 099400 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 099500 MOVE LN-CT TO LL-LN TREE 099600 PERFORM J200-SET-PG-LN TREE 099700 MOVE DUP-STRU-LIT TO NL6-NAME TREE 099800 MOVE POINTER-LIT TO NL6-POINTER-LIT TREE 099900 PERFORM W300-PRINT TREE 100000 GO TO I500-EXIT. TREE 100100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 TREE 100200 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 100300 PERFORM W500-PRINT TREE 100400 PERFORM M100-HEADING. TREE 100500 PERFORM W400-PRINT. TREE 100600 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 TREE 100700 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 100800 MOVE LN-CT TO LL-LN. TREE 100900 PERFORM J200-SET-PG-LN. TREE 101000 MOVE ST-PERF TO NL6-NAME. TREE 101100 MOVE POINTER-LIT TO NL6-POINTER-LIT. TREE 101200 PERFORM W300-PRINT. TREE 101300 MOVE ST-END-CODE TO LVL5-END-CODE. TREE 101400 MOVE ST-PARA TO LVL5-PARA-HOLD. TREE 101500 MOVE ST-SEQ TO LVL5-SEQ-HOLD. TREE 101600 MOVE ST-PERF TO ST-PARA. TREE 101700 MOVE 01 TO ST-SEQ. TREE 101800 PERFORM R300-READ-STRUCTURE. TREE 101900 IF SUCCESSFUL TREE 102000 MOVE ' ' TO LVL6-END-CODE TREE 102100 PERFORM I600-LEVEL6. TREE 102200 MOVE LVL5-PARA-HOLD TO ST-PARA. TREE 102300 MOVE LVL5-SEQ-HOLD TO ST-SEQ. TREE 102400 PERFORM R300-READ-STRUCTURE. TREE 102500 PERFORM R400-READ-STRUCTURE-NEXT. TREE 102600 IF ST-PARA = LVL5-PARA-HOLD TREE 102700 GO TO I500-LEVEL5. TREE 102800 I500-EXIT. TREE 102900 EXIT. TREE 103000******************************************************************TREE 103100 I600-LEVEL6 SECTION. TREE 103200 MOVE ' ' TO RECORD-FOUND. TREE 103300 PERFORM L100-TEST-FOR-DUP-STRU. TREE 103400 IF RECORD-FOUND = 'D' TREE 103500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 TREE 103600 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 103700 PERFORM W500-PRINT TREE 103800 PERFORM M100-HEADING TREE 103900 END-IF TREE 104000 PERFORM W400-PRINT TREE 104100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 TREE 104200 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 104300 MOVE LN-CT TO LL-LN TREE 104400 PERFORM J200-SET-PG-LN TREE 104500 MOVE DUP-STRU-LIT TO NL7-NAME TREE 104600 MOVE POINTER-LIT TO NL7-POINTER-LIT TREE 104700 PERFORM W300-PRINT TREE 104800 GO TO I600-EXIT. TREE 104900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 TREE 105000 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 105100 PERFORM W500-PRINT TREE 105200 PERFORM M100-HEADING. TREE 105300 PERFORM W400-PRINT. TREE 105400 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 TREE 105500 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 105600 MOVE LN-CT TO LL-LN. TREE 105700 PERFORM J200-SET-PG-LN. TREE 105800 MOVE ST-PERF TO NL7-NAME. TREE 105900 MOVE POINTER-LIT TO NL7-POINTER-LIT. TREE 106000 PERFORM W300-PRINT. TREE 106100 MOVE ST-END-CODE TO LVL6-END-CODE. TREE 106200 MOVE ST-PARA TO LVL6-PARA-HOLD. TREE 106300 MOVE ST-SEQ TO LVL6-SEQ-HOLD. TREE 106400 MOVE ST-PERF TO ST-PARA. TREE 106500 MOVE 01 TO ST-SEQ. TREE 106600 PERFORM R300-READ-STRUCTURE. TREE 106700 IF SUCCESSFUL TREE 106800 MOVE ' ' TO LVL7-END-CODE TREE 106900 PERFORM I700-LEVEL7. TREE 107000 MOVE LVL6-PARA-HOLD TO ST-PARA. TREE 107100 MOVE LVL6-SEQ-HOLD TO ST-SEQ. TREE 107200 PERFORM R300-READ-STRUCTURE. TREE 107300 PERFORM R400-READ-STRUCTURE-NEXT. TREE 107400 IF ST-PARA = LVL6-PARA-HOLD TREE 107500 GO TO I600-LEVEL6. TREE 107600 I600-EXIT. TREE 107700 EXIT. TREE 107800******************************************************************TREE 107900 I700-LEVEL7 SECTION. TREE 108000 MOVE ' ' TO RECORD-FOUND. TREE 108100 PERFORM L100-TEST-FOR-DUP-STRU. TREE 108200 IF RECORD-FOUND = 'D' TREE 108300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 TREE 108400 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 108500 PERFORM W500-PRINT TREE 108600 PERFORM M100-HEADING TREE 108700 END-IF TREE 108800 PERFORM W400-PRINT TREE 108900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 TREE 109000 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 109100 MOVE LN-CT TO LL-LN TREE 109200 PERFORM J200-SET-PG-LN TREE 109300 MOVE DUP-STRU-LIT TO NL8-NAME TREE 109400 MOVE POINTER-LIT TO NL8-POINTER-LIT TREE 109500 PERFORM W300-PRINT TREE 109600 GO TO I700-EXIT. TREE 109700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 TREE 109800 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 109900 PERFORM W500-PRINT TREE 110000 PERFORM M100-HEADING. TREE 110100 PERFORM W400-PRINT. TREE 110200 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 TREE 110300 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 110400 MOVE LN-CT TO LL-LN. TREE 110500 PERFORM J200-SET-PG-LN. TREE 110600 MOVE ST-PERF TO NL8-NAME. TREE 110700 MOVE POINTER-LIT TO NL8-POINTER-LIT. TREE 110800 PERFORM W300-PRINT. TREE 110900 MOVE ST-END-CODE TO LVL7-END-CODE. TREE 111000 MOVE ST-PARA TO LVL7-PARA-HOLD. TREE 111100 MOVE ST-SEQ TO LVL7-SEQ-HOLD. TREE 111200 MOVE ST-PERF TO ST-PARA. TREE 111300 MOVE 01 TO ST-SEQ. TREE 111400 PERFORM R300-READ-STRUCTURE. TREE 111500 IF SUCCESSFUL TREE 111600 MOVE ' ' TO LVL8-END-CODE TREE 111700 PERFORM I800-LEVEL8. TREE 111800 MOVE LVL7-PARA-HOLD TO ST-PARA. TREE 111900 MOVE LVL7-SEQ-HOLD TO ST-SEQ. TREE 112000 PERFORM R300-READ-STRUCTURE. TREE 112100 PERFORM R400-READ-STRUCTURE-NEXT. TREE 112200 IF ST-PARA = LVL7-PARA-HOLD TREE 112300 GO TO I700-LEVEL7. TREE 112400 I700-EXIT. TREE 112500 EXIT. TREE 112600******************************************************************TREE 112700 I800-LEVEL8 SECTION. TREE 112800 MOVE ' ' TO RECORD-FOUND. TREE 112900 PERFORM L100-TEST-FOR-DUP-STRU. TREE 113000 IF RECORD-FOUND = 'D' TREE 113100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 TREE 113200 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 113300 PERFORM W500-PRINT TREE 113400 PERFORM M100-HEADING TREE 113500 END-IF TREE 113600 PERFORM W400-PRINT TREE 113700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 TREE 113800 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 113900 MOVE LN-CT TO LL-LN TREE 114000 PERFORM J200-SET-PG-LN TREE 114100 MOVE DUP-STRU-LIT TO NL9-NAME TREE 114200 MOVE POINTER-LIT TO NL9-POINTER-LIT TREE 114300 PERFORM W300-PRINT TREE 114400 GO TO I800-EXIT. TREE 114500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 TREE 114600 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 114700 PERFORM W500-PRINT TREE 114800 PERFORM M100-HEADING. TREE 114900 PERFORM W400-PRINT. TREE 115000 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 TREE 115100 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 115200 MOVE LN-CT TO LL-LN. TREE 115300 PERFORM J200-SET-PG-LN. TREE 115400 MOVE ST-PERF TO NL9-NAME. TREE 115500 MOVE POINTER-LIT TO NL9-POINTER-LIT. TREE 115600 PERFORM W300-PRINT. TREE 115700 MOVE ST-END-CODE TO LVL8-END-CODE. TREE 115800 MOVE ST-PARA TO LVL8-PARA-HOLD. TREE 115900 MOVE ST-SEQ TO LVL8-SEQ-HOLD. TREE 116000 MOVE ST-PERF TO ST-PARA. TREE 116100 MOVE 01 TO ST-SEQ. TREE 116200 PERFORM R300-READ-STRUCTURE. TREE 116300 IF SUCCESSFUL TREE 116400 MOVE ' ' TO LVL9-END-CODE TREE 116500 PERFORM I900-LEVEL9. TREE 116600 MOVE LVL8-PARA-HOLD TO ST-PARA. TREE 116700 MOVE LVL8-SEQ-HOLD TO ST-SEQ. TREE 116800 PERFORM R300-READ-STRUCTURE. TREE 116900 PERFORM R400-READ-STRUCTURE-NEXT. TREE 117000 IF ST-PARA = LVL8-PARA-HOLD TREE 117100 GO TO I800-LEVEL8. TREE 117200 I800-EXIT. TREE 117300 EXIT. TREE 117400******************************************************************TREE 117500 I900-LEVEL9 SECTION. TREE 117600 MOVE ' ' TO RECORD-FOUND. TREE 117700 PERFORM L100-TEST-FOR-DUP-STRU. TREE 117800 IF RECORD-FOUND = 'D' TREE 117900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 118000 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 118100 PERFORM W500-PRINT TREE 118200 PERFORM M100-HEADING TREE 118300 END-IF TREE 118400 PERFORM W400-PRINT TREE 118500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 TREE 118600 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 118700 MOVE LN-CT TO LL-LN TREE 118800 PERFORM J200-SET-PG-LN TREE 118900 MOVE DUP-STRU-LIT TO NL10-NAME TREE 119000 MOVE POINTER-LIT TO NL10-POINTER-LIT TREE 119100 PERFORM W300-PRINT TREE 119200 GO TO I900-EXIT. TREE 119300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 119400 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 119500 PERFORM W500-PRINT TREE 119600 PERFORM M100-HEADING. TREE 119700 PERFORM W400-PRINT. TREE 119800 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 TREE 119900 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 120000 MOVE LN-CT TO LL-LN. TREE 120100 PERFORM J200-SET-PG-LN. TREE 120200 MOVE ST-PERF TO NL10-NAME. TREE 120300 MOVE POINTER-LIT TO NL10-POINTER-LIT. TREE 120400 PERFORM W300-PRINT. TREE 120500 MOVE ST-END-CODE TO LVL9-END-CODE. TREE 120600 MOVE ST-PARA TO LVL9-PARA-HOLD. TREE 120700 MOVE ST-SEQ TO LVL9-SEQ-HOLD. TREE 120800 MOVE ST-PERF TO ST-PARA. TREE 120900 MOVE 01 TO ST-SEQ. TREE 121000 PERFORM R300-READ-STRUCTURE. TREE 121100 IF SUCCESSFUL TREE 121200 MOVE ' ' TO LVL10-END-CODE TREE 121300 PERFORM I1000-LEVEL10. TREE 121400 MOVE LVL9-PARA-HOLD TO ST-PARA. TREE 121500 MOVE LVL9-SEQ-HOLD TO ST-SEQ. TREE 121600 PERFORM R300-READ-STRUCTURE. TREE 121700 PERFORM R400-READ-STRUCTURE-NEXT. TREE 121800 IF ST-PARA = LVL9-PARA-HOLD TREE 121900 GO TO I900-LEVEL9. TREE 122000 I900-EXIT. TREE 122100 EXIT. TREE 122200******************************************************************TREE 122300 I1000-LEVEL10 SECTION. TREE 122400 MOVE ' ' TO RECORD-FOUND. TREE 122500 PERFORM L100-TEST-FOR-DUP-STRU. TREE 122600 IF RECORD-FOUND = 'D' TREE 122700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 122800 LL-10 TREE 122900 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 123000 PERFORM W500-PRINT TREE 123100 PERFORM M100-HEADING TREE 123200 END-IF TREE 123300 PERFORM W400-PRINT TREE 123400 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 123500 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 123600 MOVE LN-CT TO LL-LN TREE 123700 PERFORM J200-SET-PG-LN TREE 123800 MOVE DUP-STRU-LIT TO NL11-NAME TREE 123900 MOVE POINTER-LIT TO NL11-POINTER-LIT TREE 124000 PERFORM W300-PRINT TREE 124100 GO TO I1000-EXIT. TREE 124200 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 124300 LL-10 TREE 124400 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 124500 PERFORM W500-PRINT TREE 124600 PERFORM M100-HEADING. TREE 124700 PERFORM W400-PRINT. TREE 124800 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 124900 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 125000 MOVE LN-CT TO LL-LN. TREE 125100 PERFORM J200-SET-PG-LN. TREE 125200 MOVE ST-PERF TO NL11-NAME. TREE 125300 MOVE POINTER-LIT TO NL11-POINTER-LIT. TREE 125400 PERFORM W300-PRINT. TREE 125500 MOVE ST-END-CODE TO LVL10-END-CODE. TREE 125600 MOVE ST-PARA TO LVL10-PARA-HOLD. TREE 125700 MOVE ST-SEQ TO LVL10-SEQ-HOLD. TREE 125800 MOVE ST-PERF TO ST-PARA. TREE 125900 MOVE 01 TO ST-SEQ. TREE 126000 PERFORM R300-READ-STRUCTURE. TREE 126100 IF SUCCESSFUL TREE 126200 MOVE ' ' TO LVL11-END-CODE TREE 126300 PERFORM I1100-LEVEL11. TREE 126400 MOVE LVL10-PARA-HOLD TO ST-PARA. TREE 126500 MOVE LVL10-SEQ-HOLD TO ST-SEQ. TREE 126600 PERFORM R300-READ-STRUCTURE. TREE 126700 PERFORM R400-READ-STRUCTURE-NEXT. TREE 126800 IF ST-PARA = LVL10-PARA-HOLD TREE 126900 GO TO I1000-LEVEL10. TREE 127000 I1000-EXIT. TREE 127100 EXIT. TREE 127200******************************************************************TREE 127300 I1100-LEVEL11 SECTION. TREE 127400 MOVE ' ' TO RECORD-FOUND. TREE 127500 PERFORM L100-TEST-FOR-DUP-STRU. TREE 127600 IF RECORD-FOUND = 'D' TREE 127700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 127800 LL-10 LL-11 TREE 127900 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 128000 PERFORM W500-PRINT TREE 128100 PERFORM M100-HEADING TREE 128200 END-IF TREE 128300 PERFORM W400-PRINT TREE 128400 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 128500 LL-10 TREE 128600 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 128700 MOVE LN-CT TO LL-LN TREE 128800 PERFORM J200-SET-PG-LN TREE 128900 MOVE DUP-STRU-LIT TO NL12-NAME TREE 129000 MOVE POINTER-LIT TO NL12-POINTER-LIT TREE 129100 PERFORM W300-PRINT TREE 129200 GO TO I1100-EXIT. TREE 129300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 129400 LL-10 LL-11 TREE 129500 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 129600 PERFORM W500-PRINT TREE 129700 PERFORM M100-HEADING. TREE 129800 PERFORM W400-PRINT. TREE 129900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 130000 LL-10 TREE 130100 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 130200 MOVE LN-CT TO LL-LN. TREE 130300 PERFORM J200-SET-PG-LN. TREE 130400 MOVE ST-PERF TO NL12-NAME. TREE 130500 MOVE POINTER-LIT TO NL12-POINTER-LIT. TREE 130600 PERFORM W300-PRINT. TREE 130700 MOVE ST-END-CODE TO LVL11-END-CODE. TREE 130800 MOVE ST-PARA TO LVL11-PARA-HOLD. TREE 130900 MOVE ST-SEQ TO LVL11-SEQ-HOLD. TREE 131000 MOVE ST-PERF TO ST-PARA. TREE 131100 MOVE 01 TO ST-SEQ. TREE 131200 PERFORM R300-READ-STRUCTURE. TREE 131300 IF SUCCESSFUL TREE 131400 MOVE ' ' TO LVL12-END-CODE TREE 131500 PERFORM I1200-LEVEL12. TREE 131600 MOVE LVL11-PARA-HOLD TO ST-PARA. TREE 131700 MOVE LVL11-SEQ-HOLD TO ST-SEQ. TREE 131800 PERFORM R300-READ-STRUCTURE. TREE 131900 PERFORM R400-READ-STRUCTURE-NEXT. TREE 132000 IF ST-PARA = LVL11-PARA-HOLD TREE 132100 GO TO I1100-LEVEL11. TREE 132200 I1100-EXIT. TREE 132300 EXIT. TREE 132400******************************************************************TREE 132500 I1200-LEVEL12 SECTION. TREE 132600 MOVE ' ' TO RECORD-FOUND. TREE 132700 PERFORM L100-TEST-FOR-DUP-STRU. TREE 132800 IF RECORD-FOUND = 'D' TREE 132900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 133000 LL-10 LL-11 LL-12 TREE 133100 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 133200 PERFORM W500-PRINT TREE 133300 PERFORM M100-HEADING TREE 133400 END-IF TREE 133500 PERFORM W400-PRINT TREE 133600 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 133700 LL-10 LL-11 TREE 133800 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 133900 MOVE LN-CT TO LL-LN TREE 134000 PERFORM J200-SET-PG-LN TREE 134100 MOVE DUP-STRU-LIT TO NL13-NAME TREE 134200 MOVE POINTER-LIT TO NL13-POINTER-LIT TREE 134300 PERFORM W300-PRINT TREE 134400 GO TO I1200-EXIT. TREE 134500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 134600 LL-10 LL-11 LL-12 TREE 134700 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 134800 PERFORM W500-PRINT TREE 134900 PERFORM M100-HEADING. TREE 135000 PERFORM W400-PRINT. TREE 135100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 135200 LL-10 LL-11 TREE 135300 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 135400 MOVE LN-CT TO LL-LN. TREE 135500 PERFORM J200-SET-PG-LN. TREE 135600 MOVE ST-PERF TO NL13-NAME. TREE 135700 MOVE POINTER-LIT TO NL13-POINTER-LIT. TREE 135800 PERFORM W300-PRINT. TREE 135900 MOVE ST-END-CODE TO LVL12-END-CODE. TREE 136000 MOVE ST-PARA TO LVL12-PARA-HOLD. TREE 136100 MOVE ST-SEQ TO LVL12-SEQ-HOLD. TREE 136200 MOVE ST-PERF TO ST-PARA. TREE 136300 MOVE 01 TO ST-SEQ. TREE 136400 PERFORM R300-READ-STRUCTURE. TREE 136500 IF SUCCESSFUL TREE 136600 MOVE ' ' TO LVL13-END-CODE TREE 136700 PERFORM I1300-LEVEL13. TREE 136800 MOVE LVL12-PARA-HOLD TO ST-PARA. TREE 136900 MOVE LVL12-SEQ-HOLD TO ST-SEQ. TREE 137000 PERFORM R300-READ-STRUCTURE. TREE 137100 PERFORM R400-READ-STRUCTURE-NEXT. TREE 137200 IF ST-PARA = LVL12-PARA-HOLD TREE 137300 GO TO I1200-LEVEL12. TREE 137400 I1200-EXIT. TREE 137500 EXIT. TREE 137600******************************************************************TREE 137700 I1300-LEVEL13 SECTION. TREE 137800 MOVE ' ' TO RECORD-FOUND. TREE 137900 PERFORM L100-TEST-FOR-DUP-STRU. TREE 138000 IF RECORD-FOUND = 'D' TREE 138100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 138200 LL-10 LL-11 LL-12 LL-13 TREE 138300 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 138400 PERFORM W500-PRINT TREE 138500 PERFORM M100-HEADING TREE 138600 END-IF TREE 138700 PERFORM W400-PRINT TREE 138800 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 138900 LL-10 LL-11 LL-12 TREE 139000 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 139100 MOVE LN-CT TO LL-LN TREE 139200 PERFORM J200-SET-PG-LN TREE 139300 MOVE DUP-STRU-LIT TO NL14-NAME TREE 139400 MOVE POINTER-LIT TO NL14-POINTER-LIT TREE 139500 PERFORM W300-PRINT TREE 139600 GO TO I1300-EXIT. TREE 139700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 139800 LL-10 LL-11 LL-12 LL-13 TREE 139900 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 140000 PERFORM W500-PRINT TREE 140100 PERFORM M100-HEADING. TREE 140200 PERFORM W400-PRINT. TREE 140300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 140400 LL-10 LL-11 LL-12 TREE 140500 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 140600 MOVE LN-CT TO LL-LN. TREE 140700 PERFORM J200-SET-PG-LN. TREE 140800 MOVE ST-PERF TO NL14-NAME. TREE 140900 MOVE POINTER-LIT TO NL14-POINTER-LIT. TREE 141000 PERFORM W300-PRINT. TREE 141100 MOVE ST-END-CODE TO LVL13-END-CODE. TREE 141200 MOVE ST-PARA TO LVL13-PARA-HOLD. TREE 141300 MOVE ST-SEQ TO LVL13-SEQ-HOLD. TREE 141400 MOVE ST-PERF TO ST-PARA. TREE 141500 MOVE 01 TO ST-SEQ. TREE 141600 PERFORM R300-READ-STRUCTURE. TREE 141700 IF SUCCESSFUL TREE 141800 MOVE ' ' TO LVL14-END-CODE TREE 141900 PERFORM I1400-LEVEL14. TREE 142000 MOVE LVL13-PARA-HOLD TO ST-PARA. TREE 142100 MOVE LVL13-SEQ-HOLD TO ST-SEQ. TREE 142200 PERFORM R300-READ-STRUCTURE. TREE 142300 PERFORM R400-READ-STRUCTURE-NEXT. TREE 142400 IF ST-PARA = LVL13-PARA-HOLD TREE 142500 GO TO I1300-LEVEL13. TREE 142600 I1300-EXIT. TREE 142700 EXIT. TREE 142800******************************************************************TREE 142900 I1400-LEVEL14 SECTION. TREE 143000 MOVE ' ' TO RECORD-FOUND. TREE 143100 PERFORM L100-TEST-FOR-DUP-STRU. TREE 143200 IF RECORD-FOUND = 'D' TREE 143300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 143400 LL-10 LL-11 LL-12 LL-13 LL-14 TREE 143500 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 143600 PERFORM W500-PRINT TREE 143700 PERFORM M100-HEADING TREE 143800 END-IF TREE 143900 PERFORM W400-PRINT TREE 144000 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 144100 LL-10 LL-11 LL-12 LL-13 TREE 144200 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 144300 MOVE LN-CT TO LL-LN TREE 144400 PERFORM J200-SET-PG-LN TREE 144500 MOVE DUP-STRU-LIT TO NL15-NAME TREE 144600 MOVE POINTER-LIT TO NL15-POINTER-LIT TREE 144700 PERFORM W300-PRINT TREE 144800 GO TO I1400-EXIT. TREE 144900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 145000 LL-10 LL-11 LL-12 LL-13 LL-14 TREE 145100 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 145200 PERFORM W500-PRINT TREE 145300 PERFORM M100-HEADING. TREE 145400 PERFORM W400-PRINT. TREE 145500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 145600 LL-10 LL-11 LL-12 LL-13 TREE 145700 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 145800 MOVE LN-CT TO LL-LN. TREE 145900 PERFORM J200-SET-PG-LN. TREE 146000 MOVE ST-PERF TO NL15-NAME. TREE 146100 MOVE POINTER-LIT TO NL15-POINTER-LIT. TREE 146200 PERFORM W300-PRINT. TREE 146300 MOVE ST-END-CODE TO LVL14-END-CODE. TREE 146400 MOVE ST-PARA TO LVL14-PARA-HOLD. TREE 146500 MOVE ST-SEQ TO LVL14-SEQ-HOLD. TREE 146600 MOVE ST-PERF TO ST-PARA. TREE 146700 MOVE 01 TO ST-SEQ. TREE 146800 PERFORM R300-READ-STRUCTURE. TREE 146900 IF SUCCESSFUL TREE 147000 MOVE ' ' TO LVL15-END-CODE TREE 147100 PERFORM I1500-LEVEL15. TREE 147200 MOVE LVL14-PARA-HOLD TO ST-PARA. TREE 147300 MOVE LVL14-SEQ-HOLD TO ST-SEQ. TREE 147400 PERFORM R300-READ-STRUCTURE. TREE 147500 PERFORM R400-READ-STRUCTURE-NEXT. TREE 147600 IF ST-PARA = LVL14-PARA-HOLD TREE 147700 GO TO I1400-LEVEL14. TREE 147800 I1400-EXIT. TREE 147900 EXIT. TREE 148000******************************************************************TREE 148100 I1500-LEVEL15 SECTION. TREE 148200 MOVE ' ' TO RECORD-FOUND. TREE 148300 PERFORM L100-TEST-FOR-DUP-STRU. TREE 148400 IF RECORD-FOUND = 'D' TREE 148500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 148600 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 TREE 148700 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 148800 PERFORM W500-PRINT TREE 148900 PERFORM M100-HEADING TREE 149000 END-IF TREE 149100 PERFORM W400-PRINT TREE 149200 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 149300 LL-10 LL-11 LL-12 LL-13 LL-14 TREE 149400 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 149500 MOVE LN-CT TO LL-LN TREE 149600 PERFORM J200-SET-PG-LN TREE 149700 MOVE DUP-STRU-LIT TO NL16-NAME TREE 149800 MOVE POINTER-LIT TO NL16-POINTER-LIT TREE 149900 PERFORM W300-PRINT TREE 150000 GO TO I1500-EXIT. TREE 150100 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 150200 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 TREE 150300 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 150400 PERFORM W500-PRINT TREE 150500 PERFORM M100-HEADING. TREE 150600 PERFORM W400-PRINT. TREE 150700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 150800 LL-10 LL-11 LL-12 LL-13 LL-14 TREE 150900 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 151000 MOVE LN-CT TO LL-LN. TREE 151100 PERFORM J200-SET-PG-LN. TREE 151200 MOVE ST-PERF TO NL16-NAME. TREE 151300 MOVE POINTER-LIT TO NL16-POINTER-LIT. TREE 151400 PERFORM W300-PRINT. TREE 151500 MOVE ST-END-CODE TO LVL15-END-CODE. TREE 151600 MOVE ST-PARA TO LVL15-PARA-HOLD. TREE 151700 MOVE ST-SEQ TO LVL15-SEQ-HOLD. TREE 151800 MOVE ST-PERF TO ST-PARA. TREE 151900 MOVE 01 TO ST-SEQ. TREE 152000 PERFORM R300-READ-STRUCTURE. TREE 152100 IF SUCCESSFUL TREE 152200 MOVE ' ' TO LVL16-END-CODE TREE 152300 PERFORM I1600-LEVEL16. TREE 152400 MOVE LVL15-PARA-HOLD TO ST-PARA. TREE 152500 MOVE LVL15-SEQ-HOLD TO ST-SEQ. TREE 152600 PERFORM R300-READ-STRUCTURE. TREE 152700 PERFORM R400-READ-STRUCTURE-NEXT. TREE 152800 IF ST-PARA = LVL15-PARA-HOLD TREE 152900 GO TO I1500-LEVEL15. TREE 153000 I1500-EXIT. TREE 153100 EXIT. TREE 153200******************************************************************TREE 153300 I1600-LEVEL16 SECTION. TREE 153400 MOVE ' ' TO RECORD-FOUND. TREE 153500 PERFORM L100-TEST-FOR-DUP-STRU. TREE 153600 IF RECORD-FOUND = 'D' TREE 153700 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 153800 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 LL-16 TREE 153900 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 154000 PERFORM W500-PRINT TREE 154100 PERFORM M100-HEADING TREE 154200 END-IF TREE 154300 PERFORM W400-PRINT TREE 154400 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 154500 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 TREE 154600 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT TREE 154700 MOVE LN-CT TO LL-LN TREE 154800 PERFORM J200-SET-PG-LN TREE 154900 MOVE DUP-STRU-LIT TO NL17-NAME TREE 155000 MOVE POINTER-LIT TO NL17-POINTER-LIT TREE 155100 PERFORM W300-PRINT TREE 155200 GO TO I1600-EXIT. TREE 155300 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 155400 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 LL-16 TREE 155500 IF LN-CT = 17 OR PT-LN-CT > 49 TREE 155600 PERFORM W500-PRINT TREE 155700 PERFORM M100-HEADING. TREE 155800 PERFORM W400-PRINT. TREE 155900 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 156000 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 TREE 156100 ADD 1 TO LN-CT ADD 3 TO PT-LN-CT. TREE 156200 MOVE LN-CT TO LL-LN. TREE 156300 PERFORM J200-SET-PG-LN. TREE 156400 MOVE ST-PERF TO NL17-NAME. TREE 156500 MOVE POINTER-LIT TO NL17-POINTER-LIT. TREE 156600 PERFORM W300-PRINT. TREE 156700 MOVE ST-END-CODE TO LVL16-END-CODE. TREE 156800 MOVE ST-PARA TO LVL16-PARA-HOLD. TREE 156900 MOVE ST-SEQ TO LVL16-SEQ-HOLD. TREE 157000 MOVE ST-PERF TO ST-PARA. TREE 157100 MOVE 01 TO ST-SEQ. TREE 157200 PERFORM R300-READ-STRUCTURE. TREE 157300 IF SUCCESSFUL TREE 157400 PERFORM J100-OVERFLOW. TREE 157500 MOVE LVL16-PARA-HOLD TO ST-PARA. TREE 157600 MOVE LVL16-SEQ-HOLD TO ST-SEQ. TREE 157700 PERFORM R300-READ-STRUCTURE. TREE 157800 PERFORM R400-READ-STRUCTURE-NEXT. TREE 157900 IF ST-PARA = LVL16-PARA-HOLD TREE 158000 GO TO I1600-LEVEL16. TREE 158100 I1600-EXIT. TREE 158200 EXIT. TREE 158300******************************************************************TREE 158400 J100-OVERFLOW SECTION. TREE 158500 MOVE '|' TO LL-1 LL-2 LL-3 LL-4 LL-5 LL-6 LL-7 LL-8 LL-9 TREE 158600 LL-10 LL-11 LL-12 LL-13 LL-14 LL-15 LL-16. TREE 158700 MOVE 'TOO MANY LEVELS' TO NL17-NAME. TREE 158800 PERFORM W300-PRINT. TREE 158900 ADD 1 TO PT-LN-CT. TREE 159000 J100-EXIT. TREE 159100 EXIT. TREE 159200******************************************************************TREE 159300 J200-SET-PG-LN SECTION. TREE 159400 IF ST-PAGE > 0 TREE 159500 GO TO J200-EXIT. TREE 159600 MOVE PG-CT TO ST-PAGE. TREE 159700 MOVE LN-CT TO ST-LINE. TREE 159800 PERFORM W200-REWRITE-STRUCTURE. TREE 159900 J200-EXIT. TREE 160000 EXIT. TREE 160100******************************************************************TREE 160200 K100-CLEAR-LINES SECTION. TREE 160300 IF LVL1-END-CODE = 'E' TREE 160400 IF LL-1 = '|' TREE 160500 MOVE ' ' TO LL-1. TREE 160600 IF LVL2-END-CODE = 'E' TREE 160700 IF LL-2 = '|' TREE 160800 MOVE ' ' TO LL-2. TREE 160900 IF LVL3-END-CODE = 'E' TREE 161000 IF LL-3 = '|' TREE 161100 MOVE ' ' TO LL-3. TREE 161200 IF LVL4-END-CODE = 'E' TREE 161300 IF LL-4 = '|' TREE 161400 MOVE ' ' TO LL-4. TREE 161500 IF LVL5-END-CODE = 'E' TREE 161600 IF LL-5 = '|' TREE 161700 MOVE ' ' TO LL-5. TREE 161800 IF LVL6-END-CODE = 'E' TREE 161900 IF LL-6 = '|' TREE 162000 MOVE ' ' TO LL-6. TREE 162100 IF LVL7-END-CODE = 'E' TREE 162200 IF LL-7 = '|' TREE 162300 MOVE ' ' TO LL-7. TREE 162400 IF LVL8-END-CODE = 'E' TREE 162500 IF LL-8 = '|' TREE 162600 MOVE ' ' TO LL-8. TREE 162700 IF LVL9-END-CODE = 'E' TREE 162800 IF LL-9 = '|' TREE 162900 MOVE ' ' TO LL-9. TREE 163000 IF LVL10-END-CODE = 'E' TREE 163100 IF LL-10 = '|' TREE 163200 MOVE ' ' TO LL-10. TREE 163300 IF LVL11-END-CODE = 'E' TREE 163400 IF LL-11 = '|' TREE 163500 MOVE ' ' TO LL-11. TREE 163600 IF LVL12-END-CODE = 'E' TREE 163700 IF LL-12 = '|' TREE 163800 MOVE ' ' TO LL-12. TREE 163900 IF LVL13-END-CODE = 'E' TREE 164000 IF LL-13 = '|' TREE 164100 MOVE ' ' TO LL-13. TREE 164200 IF LVL14-END-CODE = 'E' TREE 164300 IF LL-14 = '|' TREE 164400 MOVE ' ' TO LL-14. TREE 164500 IF LVL15-END-CODE = 'E' TREE 164600 IF LL-15 = '|' TREE 164700 MOVE ' ' TO LL-15. TREE 164800 IF LVL16-END-CODE = 'E' TREE 164900 IF LL-16 = '|' TREE 165000 MOVE ' ' TO LL-16. TREE 165100 K100-EXIT. TREE 165200 EXIT. TREE 165300******************************************************************TREE 165400 L100-TEST-FOR-DUP-STRU SECTION. TREE 165500 IF ST-LL-CODE = 9 TREE 165600 MOVE 'D' TO RECORD-FOUND TREE 165700 MOVE ST-PAGE TO DUP-LIT-PAGE TREE 165800 MOVE ST-LINE TO DUP-LIT-LINE TREE 165900 GO TO L100-EXIT. TREE 166000 IF ST-LL-CODE = 2 TREE 166100 MOVE 9 TO ST-LL-CODE TREE 166200 MOVE ST-PARA TO LVL10-PARA-HOLD TREE 166300 MOVE ST-SEQ TO LVL10-SEQ-HOLD TREE 166400 MOVE PG-CT TO DUP-LIT-PAGE ST-PAGE TREE 166500 MOVE LN-CT TO DUP-LIT-LINE ST-LINE TREE 166600 PERFORM W200-REWRITE-STRUCTURE TREE 166700 MOVE LVL10-PARA-HOLD TO ST-PARA TREE 166800 MOVE LVL10-SEQ-HOLD TO ST-SEQ TREE 166900 PERFORM R300-READ-STRUCTURE. TREE 167000 L100-EXIT. TREE 167100 EXIT. TREE 167200******************************************************************TREE 167300 M100-HEADING SECTION. TREE 167400 ADD 1 TO PG-CT. TREE 167500 MOVE 0 TO LN-CT PT-LN-CT. TREE 167600 MOVE PG-CT TO SH-PG-CT. TREE 167700 MOVE SPACES TO PRINT-REC. TREE 167800 WRITE PRINT-REC BEFORE PAGE. TREE 167900 MOVE 'UNIPAC TOOLS' TO PRINT-REC. TREE 168000 WRITE PRINT-REC BEFORE 2. TREE 168100 MOVE STRU-HEAD TO PRINT-REC. TREE 168200 WRITE PRINT-REC BEFORE 2. TREE 168300 MOVE 'LINE "+==> " INDICATES A CONDITIONAL PATH' TREE 168400 TO PRINT-REC. TREE 168500 WRITE PRINT-REC BEFORE 2. TREE 168600******************************************************************TREE 168700 N100-SET-LITERAL SECTION. TREE 168800 IF ST-COND = 'Y' TREE 168900 MOVE '+==> ' TO POINTER-LIT TREE 169000 ELSE TREE 169100 MOVE '+--> ' TO POINTER-LIT. TREE 169200 N100-EXIT. TREE 169300 EXIT. TREE 169400******************************************************************TREE 169500 R100-READ-COBOL SECTION. TREE 169600 READ COBOL-FILE AT END MOVE 'Y' TO END-OF-FILE-FLAG. TREE 169700 R100-EXIT. TREE 169800 EXIT. TREE 169900******************************************************************TREE 170000 R200-READ-WORK-FILE SECTION. TREE 170100 READ WORK-FILE AT END MOVE 'Y' TO EOF-FLAG. TREE 170200 R200-EXIT. TREE 170300 EXIT. TREE 170400******************************************************************TREE 170500 R300-READ-STRUCTURE SECTION. TREE 170600 READ STRUCTURE-FILE. TREE 170700 IF SUCCESSFUL TREE 170800 MOVE 'Y' TO RECORD-FOUND TREE 170900 PERFORM N100-SET-LITERAL. TREE 171000 R300-EXIT. TREE 171100 EXIT. TREE 171200******************************************************************TREE 171300 R400-READ-STRUCTURE-NEXT SECTION. TREE 171400 READ STRUCTURE-FILE NEXT. TREE 171500 IF NOT SUCCESSFUL MOVE 'XXXX' TO ST-PARA TREE 171600 MOVE 01 TO ST-SEQ. TREE 171700 IF END-OF-FILE MOVE 'Y' TO EOF-FLAG. TREE 171800 PERFORM N100-SET-LITERAL. TREE 171900 R400-EXIT. TREE 172000 EXIT. TREE 172100******************************************************************TREE 172200 S100-START-STRUCTURE SECTION. TREE 172300 START STRUCTURE-FILE KEY = STRUCTURE-KEY. TREE 172400 S100-EXIT. TREE 172500 EXIT. TREE 172600******************************************************************TREE 172700 W100-WRITE-WORK SECTION. 04020058 172800 IF CONDITIONAL-FLAG > 0 TREE 172900 MOVE 'Y' TO WR-COND TREE 173000 ELSE TREE 173100 MOVE 'N' TO WR-COND. TREE 173200 WRITE WORK-REC. TREE 173300 W100-EXIT. TREE 173400 EXIT. TREE 173500******************************************************************TREE 173600 W200-REWRITE-STRUCTURE SECTION. TREE 173700 REWRITE STRUCTURE-REC. TREE 173800 IF NOT SUCCESSFUL TREE 173900 DISPLAY 'INVALID REWRITE OF STRUCTURE FILE' TREE 174000 ' ' VSAM-FILE-RETURN-STATUS TREE 174100 STOP RUN. TREE 174200 W200-EXIT. TREE 174300 EXIT. TREE 174400******************************************************************TREE 174500 W300-PRINT SECTION. TREE 174600 PERFORM K100-CLEAR-LINES. TREE 174700 WRITE PRINT-REC FROM DETAIL-LINE BEFORE 1. TREE 174800 MOVE SPACES TO DETAIL-LINE. TREE 174900 W300-EXIT. TREE 175000 EXIT. TREE 175100******************************************************************TREE 175200 W400-PRINT SECTION. TREE 175300 PERFORM K100-CLEAR-LINES. TREE 175400 WRITE PRINT-REC FROM DETAIL-LINE BEFORE 1. TREE 175500 IF SUPPRESS-W400-FLAG = 'Y' TREE 175600 MOVE 'N' TO SUPPRESS-W400-FLAG TREE 175700 MOVE SPACES TO DETAIL-LINE TREE 175800 GO TO W400-EXIT. TREE 175900 WRITE PRINT-REC FROM DETAIL-LINE BEFORE 1. TREE 176000 MOVE SPACES TO DETAIL-LINE. TREE 176100 W400-EXIT. TREE 176200 EXIT. TREE 176300******************************************************************TREE 176400 W500-PRINT SECTION. TREE 176500 PERFORM K100-CLEAR-LINES. TREE 176600 WRITE PRINT-REC FROM DETAIL-LINE BEFORE 1. TREE 176700 MOVE 'Y' TO SUPPRESS-W400-FLAG. TREE 176800 W500-EXIT. TREE 176900 EXIT. TREE 177000******************************************************************TREE 177100 Z100-MOVE-TO-WORK-AREA SECTION. TREE 177200 MOVE COBOL-DATA TO INPUT-RECORD. TREE 177300 PERFORM UNTIL IR-1 NOT = ' ' TREE 177400 MOVE IR-2-65 TO IR-1-64 TREE 177500 MOVE ' ' TO IR-65 TREE 177600 END-PERFORM. TREE 177700 MOVE 1 TO X2. TREE 177800 PERFORM UNTIL X2 = 65 TREE 177900 MOVE INPUT-CHAR(X2) TO WORK-CHAR(X1) TREE 178000 ADD 1 TO X1 X2 TREE 178100 END-PERFORM. TREE 178200 MOVE 'N' TO END-OF-SENTENCE-FLAG. TREE 178300 MOVE X1 TO X3. TREE 178400 PERFORM UNTIL WORK-CHAR(X3) = '.' OR TREE 178500 WORK-CHAR(X3) NOT = ' ' TREE 178600 OR X3 = 1 TREE 178700 SUBTRACT 1 FROM X3 TREE 178800 END-PERFORM. TREE 178900 IF WORK-CHAR(X3) = '.' OR ' ' TREE 179000 MOVE 'Y' TO END-OF-SENTENCE-FLAG TREE 179100 ELSE TREE 179200 MOVE X3 TO X1 TREE 179300 ADD 2 TO X1 TREE 179400 PERFORM R100-READ-COBOL TREE 179500 GO TO Z100-MOVE-TO-WORK-AREA. TREE 179600 PERFORM Z200-NORMALIZE. TREE 179700 Z100-EXIT. TREE 179800 EXIT. TREE 179900******************************************************************TREE 180000 Z200-NORMALIZE SECTION. TREE 180100 MOVE 1 TO X1. TREE 180200 PERFORM UNTIL WORK-CHAR(X1) NOT = ' ' TREE 180300 MOVE 1 TO X1 TREE 180400 MOVE 2 TO X2 TREE 180500 PERFORM UNTIL WORK-CHAR(X1) = '.' TREE 180600 MOVE WORK-CHAR(X2) TO WORK-CHAR(X1) TREE 180700 ADD 1 TO X1 X2 TREE 180800 END-PERFORM TREE 180900 MOVE ' ' TO WORK-CHAR(X2) TREE 181000 MOVE 1 TO X1 TREE 181100 END-PERFORM. TREE 181200 MOVE 1 TO X1. TREE 181300 PERFORM Z300-ELIMINATE-SPACES UNTIL WORK-CHAR(X1) = '.'. TREE 181400 Z200-EXIT. TREE 181500 EXIT. TREE 181600******************************************************************TREE 181700 Z300-ELIMINATE-SPACES SECTION. TREE 181800 PERFORM UNTIL WORK-CHAR(X1) = ' ' OR '.' TREE 181900 ADD 1 TO X1 TREE 182000 END-PERFORM. TREE 182100 IF WORK-CHAR(X1) = '.' TREE 182200 GO TO Z300-EXIT. TREE 182300 Z310-CONTINUE. TREE 182400 MOVE X1 TO X2. TREE 182500 ADD 1 TO X2. TREE 182600 IF WORK-CHAR(X2) = ' ' TREE 182700 MOVE X2 TO X3 TREE 182800 ADD 1 TO X3 TREE 182900 PERFORM UNTIL WORK-CHAR(X2) = '.' TREE 183000 MOVE WORK-CHAR(X3) TO WORK-CHAR(X2) TREE 183100 ADD 1 TO X2 X3 TREE 183200 END-PERFORM TREE 183300 MOVE ' ' TO WORK-CHAR(X3) TREE 183400 GO TO Z310-CONTINUE. TREE 183500 ADD 1 TO X1. TREE 183600 Z300-EXIT. TREE 183700 EXIT. TREE 183800******************************************************************TREE 183900 Z400-FIND-NEXT-WORD SECTION. TREE 184000 PERFORM UNTIL CHAR-1 = ' ' TREE 184100 MOVE CHAR-2-3250 TO CHAR-1-3249 TREE 184200 MOVE ' ' TO CHAR-3250 TREE 184300 IF END-TEST-3 = '. ' TREE 184400 MOVE 'Y' TO END-OF-SENTENCE-FLAG TREE 184500 END-IF TREE 184600 END-PERFORM. TREE 184700 MOVE CHAR-2-3250 TO CHAR-1-3249. TREE 184800 Z400-EXIT. TREE 184900 EXIT. TREE 185000******************************************************************TREE 185100 Z999-CVT-DATE SECTION. TREE 185200 MOVE WD-YR TO RD-YR. TREE 185300 MOVE WD-MO TO RD-MO. TREE 185400 MOVE WD-DD TO RD-DD. TREE 185500 Z999-EXIT. TREE 185600 EXIT. TREE 185700******************************************************************TREE ./ ADD NAME=PWBPBD01 00001 * COMPOPT: 12/27/89 00002 ******************************************************************PWBPBD01 00003 * I D E N T I F I C A T I O N D I V I S I O N * LV001 00004 ******************************************************************PWBPBD01 00005 IDENTIFICATION DIVISION. PWBPBD01 00006 PROGRAM-ID. PWBPBD01. PWBPBD01 00007 AUTHOR. DAVE LEIGH. PWBPBD01 00008 DATE-WRITTEN. NOVEMBER 1, 1989. PWBPBD01 00009 DATE-COMPILED. PWBPBD01 00010 ******************************************************************PWBPBD01 00011 * PROGRAM NAME: PWBPBD01 *PWBPBD01 00012 * *PWBPBD01 00013 * FUNCTION: THIS PROGRAM IS PART OF AN ISPF-BASED BATCH DELETE *PWBPBD01 00014 * SYSTEM FOR CAS. THIS SYSTEM ITSELF IS CONTROLLED BY *PWBPBD01 00015 * A CLIST WHICH INVOKES THIS PROGRAM. THIS PROGRAM *PWBPBD01 00016 * HANDLES ISPF TABLE "SELECTED ROWS" PROCESSING. THE *PWBPBD01 00017 * REASON THAT THIS FUNCTION OF THE BATCH DELETE SYSTEM *PWBPBD01 00018 * IS HANDLED IN A PROGRAM IS THAT "SELECTED ROWS" IN *PWBPBD01 00019 * THE BATCH DELETE ISPF TABLE MUST BE VERIFIED AGAINST *PWBPBD01 00020 * THE CAS PRODUCTION DATABASE. THIS PROGRAM SERVES AS *PWBPBD01 00021 * THE FOREGROUND INTERFACE BETWEEN TSO/ISPF AND IDMS. *PWBPBD01 00022 * *PWBPBD01 00023 * THIS PROGRAM WILL ISSUE ISPF CALLS TO DELETE ROWS *PWBPBD01 00024 * SELECTED FOR DELETE WITHOUT ANY IDMS VERIFICATION. *PWBPBD01 00025 * IF THE ISPF ROW CONTAINS ANY CHANGED DATA, IT IS *PWBPBD01 00026 * SELECTED AUTOMATICALLY BY ISPF. IF THE ROW IS NOT TO*PWBPBD01 00027 * BE DELETED, THE FOLLOWING DATABASE INFORMATION IS *PWBPBD01 00028 * VERIFIED: *PWBPBD01 00029 * 1. DOES THE CASE EXIST *PWBPBD01 00030 * 2. OWNER INFORMATION FOR MATCHING THE INFORMATION *PWBPBD01 00031 * THAT WAS TYPED IN ON THE ISPF PANEL. *PWBPBD01 00032 * 3. DOES THE CASE HAVE A REPURCHASE TIED TO IT. *PWBPBD01 00033 * 4. DOES THE CASE HAVE A BREACH TIED TO IT. *PWBPBD01 00034 * 5. DOES THE CASE HAVE A PRODUCT LIABILITY TIED TO IT.*PWBPBD01 00035 * 6. DOES THE CASE HAVE A MEDIATION TIED TO IT. *PWBPBD01 00036 * 7. DOES THE CASE HAVE AN ARBITRATION TIED TO IT. *PWBPBD01 00037 * 8. DOES THE CASE HAVE A GM1241 OR "X" TIED TO IT. *PWBPBD01 00038 * 9. CAN THE DESIRED NEW STATUS BE SUPPORTED BASED ON *PWBPBD01 00039 * THE PRESENCE OR ABSENCE OF VARIOUS LEGAL ENTITIES *PWBPBD01 00040 * TIED TO THE CASE. *PWBPBD01 00041 * *PWBPBD01 00042 * INPUTS: USER ENTERED INFORMATION IN AN ISPF TABLE. *PWBPBD01 00043 * *PWBPBD01 00044 * OUTPUTS: UPDATED ISPF TABLE. *PWBPBD01 00045 * *PWBPBD01 00046 * DATABASE RECORDS/ELEMENTS USED: CA-CASE *PWBPBD01 00047 * CA-PARTY *PWBPBD01 00048 * CA-GM1241 *PWBPBD01 00049 * CA-GM1241X *PWBPBD01 00050 * CA-REPURCHASE *PWBPBD01 00051 * CA-BREACH *PWBPBD01 00052 * CA-PROD-LIABILTY *PWBPBD01 00053 * CA-MEDIATION *PWBPBD01 00054 * CA-ARBITRATION *PWBPBD01 00055 * CA-RB-CASE *PWBPBD01 00056 * IX-RBCASE-REFNUM *PWBPBD01 00057 * *PWBPBD01 00058 * EXITS NORMAL: S3000-FINALIZATION *PWBPBD01 00059 * *PWBPBD01 00060 * EXITS ABNORMAL: IDMS-STATUS *PWBPBD01 00061 * *PWBPBD01 00062 * SWITCHES: S-CASE-SWITCH - WAS THE CASE FOUND ON THE DATABASE *PWBPBD01 00063 * S-OWNER-SWITCH - WAS THE OWNER INFORMATION FOUND *PWBPBD01 00064 * S-RUNUNIT-SWITCH - HAS A RUN-UNIT ALREADY BEEN *PWBPBD01 00065 * ESTABLISHED *PWBPBD01 00066 * S-FINISH-SWITCH - IS THE IDMS COMMAND BEING PRO- *PWBPBD01 00067 * CESSED A "FINISH" COMMAND *PWBPBD01 00068 * *PWBPBD01 00069 * TABLES: NONE *PWBPBD01 00070 * *PWBPBD01 00071 * COPY MEMBERS: NONE *PWBPBD01 00072 * *PWBPBD01 00073 *--------------------------------------------------------------- *PWBPBD01 00074 * MODIFICATION LOG *PWBPBD01 00075 *--------------------------------------------------------------- *PWBPBD01 00076 * INIT . DATE . COMMENTS *PWBPBD01 00077 *======¬========¬=============================================== *PWBPBD01 00078 ******************************************************************PWBPBD01 00079 /*****************************************************************PWBPBD01 00080 * E N V I R O N M E N T D I V I S I O N *PWBPBD01 00081 ******************************************************************PWBPBD01 00082 PWBPBD01 00083 ENVIRONMENT DIVISION. PWBPBD01 00084 PWBPBD01 00085 INPUT-OUTPUT SECTION. PWBPBD01 00086 FILE-CONTROL. PWBPBD01 00087 IDMS-CONTROL SECTION. PWBPBD01 00088 PROTOCOL. MODE IS BATCH-AUTOSTATUS DEBUG. PWBPBD01 00089 IDMS-RECORDS MANUAL. PWBPBD01 00090 PWBPBD01 00091 /*****************************************************************PWBPBD01 00092 * D A T A D I V I S I O N *PWBPBD01 00093 ******************************************************************PWBPBD01 00094 PWBPBD01 00095 DATA DIVISION. PWBPBD01 00096 SCHEMA SECTION. PWBPBD01 00097 DB CAS00S20 WITHIN CASSC00. PWBPBD01 00098 PWBPBD01 00099 FILE SECTION. PWBPBD01 00100 PWBPBD01 00101 /*****************************************************************PWBPBD01 00102 * W O R K I N G - S T O R A G E S E C T I O N *PWBPBD01 00103 ******************************************************************PWBPBD01 00104 PWBPBD01 00105 WORKING-STORAGE SECTION. PWBPBD01 00106 PWBPBD01 00107 01 WS-START PIC X(48) VALUE PWBPBD01 00108 '**** PWBPBD01 WORKING-STORAGE STARTS HERE ****'. PWBPBD01 00109 PWBPBD01 00110 ******************************************************************PWBPBD01 00111 * A C C U M U L A T O R S *PWBPBD01 00112 ******************************************************************PWBPBD01 00113 01 A-ACCUMULATORS. PWBPBD01 00114 05 A-ISPF-CALLS-MADE PIC 9(07) VALUE ZEROS. PWBPBD01 00115 PWBPBD01 00116 ******************************************************************PWBPBD01 00117 * C O N S T A N T S *PWBPBD01 00118 ******************************************************************PWBPBD01 00119 PWBPBD01 00120 01 C-CONSTANTS. PWBPBD01 00121 PWBPBD01 00122 *** RETURN CODES *** PWBPBD01 00123 05 C-NORMAL-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0000. PWBPBD01 00124 05 C-OK-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0004. PWBPBD01 00125 05 C-PASSABLE-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0008. PWBPBD01 00126 05 C-DATA-NOT-VERIFIED-RC PIC S9(08) COMP SYNC VALUE +2000. PWBPBD01 00127 05 C-BIND-OR-RUNUNIT-RC PIC S9(08) COMP SYNC VALUE +2001. PWBPBD01 00128 05 C-BAD-IDMS-RC PIC S9(08) COMP SYNC VALUE +2222. PWBPBD01 00129 PWBPBD01 00130 *** RECORD NAMES *** PWBPBD01 00131 05 C-BREACH PIC X(16) VALUE PWBPBD01 00132 'CA-BREACH '. PWBPBD01 00133 05 C-PRODUCT-LIABILITY PIC X(16) VALUE PWBPBD01 00134 'CA-PROD-LIABILTY'. PWBPBD01 00135 05 C-MEDIATION PIC X(16) VALUE PWBPBD01 00136 'CA-MEDIATION '. PWBPBD01 00137 05 C-ARBITRATION PIC X(16) VALUE PWBPBD01 00138 'CA-ARBITRATION '. PWBPBD01 00139 PWBPBD01 00140 *** MESSAGES *** PWBPBD01 00141 05 C-NO-MESSAGE. PWBPBD01 00142 10 FILLER PIC X(50) VALUE PWBPBD01 00143 '=================================================='.PWBPBD01 00144 10 FILLER PIC X(28) VALUE PWBPBD01 00145 '============================'. PWBPBD01 00146 05 C-SELECT-CODES-MSG PIC X(37) VALUE PWBPBD01 00147 'SELECT CODE MUST BE " ", "S", OR "D" '. PWBPBD01 00148 05 C-OPEN-STATUS-MSG PIC X(38) VALUE PWBPBD01 00149 'CASE MUST BE IN OPEN STATUS TO DELETE '. PWBPBD01 00150 05 C-CORRECT-OWNER-MSG PIC X(19) VALUE PWBPBD01 00151 'CORRECT OWNER IS : '. PWBPBD01 00152 05 C-NOT-M-IF-ARB-MSG. PWBPBD01 00153 10 FILLER PIC X(40) VALUE PWBPBD01 00154 'CASE CANNOT GO DIRECTLY TO "M" STATUS IF'. PWBPBD01 00155 10 FILLER PIC X(29) VALUE PWBPBD01 00156 ' AN ARBITRATION EXISTS ON IT '. PWBPBD01 00157 05 C-VALID-STATUS-MSG PIC X(44) VALUE PWBPBD01 00158 'ONLY THESE "NEXT" STATUS VALUES ARE VALID : '. PWBPBD01 00159 05 C-ARB-ONLY-TO-M-MSG PIC X(38) VALUE PWBPBD01 00160 '"ARB" CASES CAN ONLY GO TO "M" STATUS '. PWBPBD01 00161 05 C-CASE-NOT-FOUND-MSG PIC X(40) VALUE PWBPBD01 00162 'THIS CASE WAS NOT FOUND ON THE DATABASE '. PWBPBD01 00163 05 C-IF-LGL-NO-GEN-MSG PIC X(51) VALUE PWBPBD01 00164 'CASE HAS OTHER LEGAL RECORDS, CANNOT GO TO GENERAL '. PWBPBD01 00165 05 C-LEGAL-STATUS-MSG. PWBPBD01 00166 10 FILLER PIC X(51) VALUE PWBPBD01 00167 'CASE MUST BE TYPE "B","P","M","A","1","X", OR HAVE '. PWBPBD01 00168 10 FILLER PIC X(23) VALUE PWBPBD01 00169 'A REPURCHASE TO DELETE '. PWBPBD01 00170 05 C-GM1241-MSG PIC X(52) VALUE PWBPBD01 00171 '1241 CASES MAY NOT BE DELETED IF AN APPROVER EXISTS '. PWBPBD01 00172 05 C-GM1241X-MSG PIC X(53) VALUE PWBPBD01 00173 '1241X CASES MAY NOT BE DELETED IF AN APPROVER EXISTS '. PWBPBD01 00174 05 C-DATA-VERIFIED-MSG PIC X(27) VALUE PWBPBD01 00175 'CASE VERIFIED AS CORRECT : '. PWBPBD01 00176 05 C-REPURCHASE-MSG PIC X(50) VALUE PWBPBD01 00177 'REPURCHASE WILL BE DELETED -- NO CASE TYPE CHANGE '. PWBPBD01 00178 05 C-NO-REPURCHASE-MSG PIC X(54) VALUE PWBPBD01 00179 'NO REPURCHASE TO BE DELETED -- INVALID NEXT CASE TYPE '.PWBPBD01 00180 05 C-REIMBURSEMENT-MSG. PWBPBD01 00181 10 FILLER PIC X(51) VALUE PWBPBD01 00182 'AN OPEN REIMBURSEMENT EXISTS ON THIS CASE -- CANNOT'. PWBPBD01 00183 10 FILLER PIC X(24) VALUE PWBPBD01 00184 ' BE PUT TO CLOSE STATUS '. PWBPBD01 00185 PWBPBD01 00186 *** CASE STATUS TYPES *** PWBPBD01 00187 05 C-ARBITRATION-TYPE PIC X(01) VALUE 'A'. PWBPBD01 00188 05 C-MEDIATION-TYPE PIC X(01) VALUE 'M'. PWBPBD01 00189 05 C-BREACH-TYPE PIC X(01) VALUE 'B'. PWBPBD01 00190 05 C-PRODUCT-LIABILITY-TYPE PIC X(01) VALUE 'P'. PWBPBD01 00191 05 C-GM1241-TYPE PIC X(01) VALUE '1'. PWBPBD01 00192 05 C-GM1241X-TYPE PIC X(01) VALUE 'X'. PWBPBD01 00193 05 C-GENERAL-TYPE PIC X(01) VALUE 'G'. PWBPBD01 00194 05 C-REPURCHASE-TYPE PIC X(01) VALUE 'R'. PWBPBD01 00195 PWBPBD01 00196 *** ISPF VARIABLE FIELD LENGTHS FOR VDEFINES *** PWBPBD01 00197 05 C-LENGTH-1-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +1. PWBPBD01 00198 05 C-LENGTH-2-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +2. PWBPBD01 00199 05 C-LENGTH-8-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +8. PWBPBD01 00200 05 C-LENGTH-9-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +9. PWBPBD01 00201 05 C-LENGTH-15-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +15.PWBPBD01 00202 05 C-LENGTH-17-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +17.PWBPBD01 00203 05 C-LENGTH-20-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +20.PWBPBD01 00204 05 C-LENGTH-78-VARIABLES-LEN PIC S9(06) COMP SYNC VALUE +78.PWBPBD01 00205 PWBPBD01 00206 *** ISPF VARIABLE FIELD NAME LITERALS *** PWBPBD01 00207 05 C-LENGTH-1-VARIABLES. PWBPBD01 00208 10 FILLER PIC X(44) VALUE PWBPBD01 00209 '(FLGREPU FLG1241 FLG1241X FLGBRECH FLGPLIAB '. PWBPBD01 00210 10 FILLER PIC X(47) VALUE PWBPBD01 00211 'FLGMED FLGARB OMNAME VERIFIED LINECMD NEXTTYPE)'. PWBPBD01 00212 05 C-LENGTH-2-VARIABLES. PWBPBD01 00213 10 FILLER PIC X(10) VALUE PWBPBD01 00214 '(CURRSTAT)'. PWBPBD01 00215 05 C-LENGTH-8-VARIABLES. PWBPBD01 00216 10 FILLER PIC X(31) VALUE PWBPBD01 00217 '(CASETAB LUDATE LUID LUTIME SS)'. PWBPBD01 00218 05 C-LENGTH-9-VARIABLES. PWBPBD01 00219 10 FILLER PIC X(09) VALUE PWBPBD01 00220 '(CASENUM)'. PWBPBD01 00221 05 C-LENGTH-15-VARIABLES. PWBPBD01 00222 10 FILLER PIC X(08) VALUE PWBPBD01 00223 '(OFNAME)'. PWBPBD01 00224 05 C-LENGTH-20-VARIABLES. PWBPBD01 00225 10 FILLER PIC X(08) VALUE PWBPBD01 00226 '(OLNAME)'. PWBPBD01 00227 05 C-LENGTH-78-VARIABLES. PWBPBD01 00228 10 FILLER PIC X(19) VALUE PWBPBD01 00229 '(MSGLINE1 MSGLINE2)'. PWBPBD01 00230 PWBPBD01 00231 *** ISPF OPERATION NAMES AND PARAMETERS *** PWBPBD01 00232 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. PWBPBD01 00233 05 C-VGET PIC X(08) VALUE 'VGET '. PWBPBD01 00234 05 C-TBPUT PIC X(08) VALUE 'TBPUT '. PWBPBD01 00235 05 C-TBDELETE PIC X(08) VALUE 'TBDELETE'. PWBPBD01 00236 05 C-CHAR PIC X(08) VALUE 'CHAR '. PWBPBD01 00237 PWBPBD01 00238 *** VARIABLES TO VGET/VPUT *** PWBPBD01 00239 05 C-VGET-VPUT-VARIABLES. PWBPBD01 00240 10 FILLER PIC X(44) VALUE PWBPBD01 00241 '(FLGREPU FLG1241 FLG1241X FLGBRECH FLGPLIAB '. PWBPBD01 00242 10 FILLER PIC X(47) VALUE PWBPBD01 00243 'FLGMED FLGARB OMNAME VERIFIED CURRSTAT LINECMD '. PWBPBD01 00244 10 FILLER PIC X(39) VALUE PWBPBD01 00245 'NEXTTYPE CASENUM OFNAME OLNAME CASETAB '. PWBPBD01 00246 10 FILLER PIC X(40) VALUE PWBPBD01 00247 'MSGLINE1 MSGLINE2 LUID LUDATE LUTIME SS)'. PWBPBD01 00248 PWBPBD01 00249 *** MISCELLANEOUS *** PWBPBD01 00250 05 C-ISPF PIC X(08) VALUE 'ISPLINK '. PWBPBD01 00251 05 C-OWNER-PARTY-TYPE PIC X(08) VALUE 'OWNER '. PWBPBD01 00252 05 C-BREACH-VALID-STATUS PIC X(04) VALUE '"B" '. PWBPBD01 00253 05 C-PRODLIB-VALID-STATUS PIC X(04) VALUE '"P" '. PWBPBD01 00254 05 C-MED-VALID-STATUS PIC X(04) VALUE '"M" '. PWBPBD01 00255 05 C-ARB-VALID-STATUS PIC X(04) VALUE '"A" '. PWBPBD01 00256 05 C-GM1241-VALID-STATUS PIC X(04) VALUE '"1" '. PWBPBD01 00257 05 C-GM1241X-VALID-STATUS PIC X(04) VALUE '"X" '. PWBPBD01 00258 05 C-GENERAL-VALID-STATUS PIC X(04) VALUE '"G" '. PWBPBD01 00259 05 C-REPU-VALID-STATUS PIC X(04) VALUE '"R" '. PWBPBD01 00260 05 C-YES PIC X(01) VALUE 'Y'. PWBPBD01 00261 05 C-NO PIC X(01) VALUE 'N'. PWBPBD01 00262 05 C-FLAG PIC X(01) VALUE 'X'. PWBPBD01 00263 05 C-SELECT-ROW PIC X(01) VALUE 'S'. PWBPBD01 00264 05 C-DELETE-ROW PIC X(01) VALUE 'D'. PWBPBD01 00265 PWBPBD01 00266 ******************************************************************PWBPBD01 00267 * S W I T C H E S *PWBPBD01 00268 ******************************************************************PWBPBD01 00269 01 S-SWITCHES. PWBPBD01 00270 05 S-CASE-SWITCH PIC X(01) VALUE LOW-VALUES. PWBPBD01 00271 88 S-CASE-FOUND VALUE HIGH-VALUES. PWBPBD01 00272 05 S-OWNER-SWITCH PIC X(01) VALUE LOW-VALUES. PWBPBD01 00273 88 S-OWNER-FOUND VALUE HIGH-VALUES. PWBPBD01 00274 05 S-RUNUNIT-SWITCH PIC X(01) VALUE LOW-VALUES. PWBPBD01 00275 88 S-RUNUNIT-STARTED VALUE HIGH-VALUES. PWBPBD01 00276 88 S-RUNUNIT-NOT-STARTED VALUE LOW-VALUES. PWBPBD01 00277 05 S-FINISH-SWITCH PIC X(01) VALUE LOW-VALUES. PWBPBD01 00278 88 S-NOT-FINISH-COMMAND VALUE LOW-VALUES. PWBPBD01 00279 PWBPBD01 00280 ******************************************************************PWBPBD01 00281 * W O R K - A R E A S *PWBPBD01 00282 ******************************************************************PWBPBD01 00283 01 W-WORK-AREAS. PWBPBD01 00284 05 W-SUB-1 PIC S9(06) COMP SYNC VALUE +0. PWBPBD01 00285 05 W-TALLY PIC S9(06) COMP SYNC VALUE +0. PWBPBD01 00286 88 W-CANNOT-GO-TO-GENERAL VALUE +0. PWBPBD01 00287 05 W-DISPLAY-RETURN-CODE PIC 9(08) VALUE ZEROS. PWBPBD01 00288 05 W-ISPF-CALL PIC 9(07) VALUE ZEROS. PWBPBD01 00289 05 W-ERROR-STATUS. PWBPBD01 00290 10 W-ERROR-STATUS-PRI PIC X(02) VALUE ZEROS. PWBPBD01 00291 88 W-BIND-PROBLEM VALUE '14'. PWBPBD01 00292 10 W-ERROR-STATUS-SEC PIC X(02) VALUE ZEROS. PWBPBD01 00293 88 W-RUNUNIT-PROBLEM VALUE '69'. PWBPBD01 00294 05 W-VALID-STATUS-ARRAY PIC X(20) VALUE SPACES. PWBPBD01 00295 05 W-VALID-STATUS REDEFINES W-VALID-STATUS-ARRAY PWBPBD01 00296 PIC X(04) OCCURS 5 TIMES. PWBPBD01 00297 PWBPBD01 00298 *** WORKING-STORAGE BUCKETS FOR ISPF VARIABLES *** PWBPBD01 00299 05 W-LENGTH-1-VARIABLES. PWBPBD01 00300 10 W-LEGAL-FLAGS. PWBPBD01 00301 15 W-FLGREPU PIC X(01) VALUE SPACES. PWBPBD01 00302 15 W-FLG1241 PIC X(01) VALUE SPACES. PWBPBD01 00303 15 W-FLG1241X PIC X(01) VALUE SPACES. PWBPBD01 00304 15 W-FLGBRECH PIC X(01) VALUE SPACES. PWBPBD01 00305 15 W-FLGPLIAB PIC X(01) VALUE SPACES. PWBPBD01 00306 15 W-FLGMED PIC X(01) VALUE SPACES. PWBPBD01 00307 15 W-FLGARB PIC X(01) VALUE SPACES. PWBPBD01 00308 10 W-OMNAME PIC X(01) VALUE SPACES. PWBPBD01 00309 10 W-VERIFIED PIC X(01) VALUE SPACES. PWBPBD01 00310 88 W-DATA-VERIFIED VALUE 'Y'. PWBPBD01 00311 10 W-LINECMD PIC X(01) VALUE SPACES. PWBPBD01 00312 10 W-NEXTTYPE PIC X(01) VALUE SPACES. PWBPBD01 00313 88 W-GENERAL-SELECTED VALUE 'G'. PWBPBD01 00314 05 W-LENGTH-2-VARIABLES. PWBPBD01 00315 10 W-CURRSTAT. PWBPBD01 00316 15 W-CURRSTAT-TYPE PIC X(01) VALUE SPACES. PWBPBD01 00317 15 W-CURRSTAT-STAT PIC X(01) VALUE SPACES. PWBPBD01 00318 05 W-LENGTH-8-VARIABLES. PWBPBD01 00319 10 W-CASETAB PIC X(08) VALUE SPACES. PWBPBD01 00320 10 W-LUDATE PIC X(08) VALUE SPACES. PWBPBD01 00321 10 W-LUID PIC X(08) VALUE SPACES. PWBPBD01 00322 10 W-LUTIME PIC X(08) VALUE SPACES. PWBPBD01 00323 10 W-SS PIC X(08) VALUE SPACES. PWBPBD01 00324 05 W-LENGTH-9-VARIABLES. PWBPBD01 00325 10 W-CASENUM PIC X(09) VALUE SPACES. PWBPBD01 00326 05 W-LENGTH-15-VARIABLES. PWBPBD01 00327 10 W-OFNAME PIC X(15) VALUE SPACES. PWBPBD01 00328 05 W-LENGTH-20-VARIABLES. PWBPBD01 00329 10 W-OLNAME PIC X(20) VALUE SPACES. PWBPBD01 00330 05 W-LENGTH-78-VARIABLES. PWBPBD01 00331 10 W-MSGLINE1 PIC X(78) VALUE SPACES. PWBPBD01 00332 10 W-MSGLINE2 PIC X(78) VALUE SPACES. PWBPBD01 00333 PWBPBD01 00334 05 W-WORK-MSGLINE-1 PIC X(78) VALUE SPACES. PWBPBD01 00335 05 W-WORK-MSGLINE-2 PIC X(78) VALUE SPACES. PWBPBD01 00336 PWBPBD01 00337 ******************************************************************PWBPBD01 00338 * T A B L E S *PWBPBD01 00339 ******************************************************************PWBPBD01 00340 *01 T-TABLES. NO TABLES PWBPBD01 00341 01 WS-END PIC X(48) VALUE PWBPBD01 00342 '**** PWBPBD01 WORKING-STORAGE ENDS HERE ****'. PWBPBD01 00343 /*****************************************************************PWBPBD01 00344 * I D M S W O R K A R E A *PWBPBD01 00345 ******************************************************************PWBPBD01 00346 01 FILLER PIC X(42) VALUE PWBPBD01 00347 '*** IDMS SUBSCHEMA CONTROL STARTS HERE ***'. PWBPBD01 00348 COPY IDMS SUBSCHEMA-CONTROL. PWBPBD01 00349 COPY IDMS CA-CASE. PWBPBD01 00350 COPY IDMS CA-PARTY. PWBPBD01 00351 COPY IDMS CA-GM1241. PWBPBD01 00352 COPY IDMS CA-GM1241X. PWBPBD01 00353 COPY IDMS CA-REPURCHASE. PWBPBD01 00354 COPY IDMS CA-BREACH. PWBPBD01 00355 COPY IDMS CA-PROD-LIABILTY. PWBPBD01 00356 COPY IDMS CA-MEDIATION. PWBPBD01 00357 COPY IDMS CA-ARBITRATION. PWBPBD01 00358 COPY IDMS CA-RB-CASE. PWBPBD01 00359 01 FILLER PIC X(40) VALUE PWBPBD01 00360 '*** IDMS SUBSCHEMA CONTROL ENDS HERE ***'. PWBPBD01 00361 PROCEDURE DIVISION. PWBPBD01 00362 READY TRACE. PWBPBD01 00363 ******************************************************************PWBPBD01 00364 * P R O C E D U R E D I V I S I O N *PWBPBD01 00365 ******************************************************************PWBPBD01 00366 PWBPBD01 00367 /*****************************************************************PWBPBD01 00368 * S0000-DRIVER *PWBPBD01 00369 * PERFORMED BY: *PWBPBD01 00370 * FUNCTIONS: THIS ROUTINE CONTROLS THE WHOLE PROGRAM. *PWBPBD01 00371 ******************************************************************PWBPBD01 00372 PWBPBD01 00373 S0000-DRIVER SECTION. PWBPBD01 00374 PWBPBD01 00375 PERFORM S1000-INITIALIZATION. PWBPBD01 00376 PWBPBD01 00377 PERFORM S2000-MAINLINE. PWBPBD01 00378 PWBPBD01 00379 PERFORM S3000-FINALIZATION. PWBPBD01 00380 PWBPBD01 00381 S0000-EXIT. PWBPBD01 00382 EXIT. PWBPBD01 00383 /*****************************************************************PWBPBD01 00384 * S1000-INITIALIZATION *PWBPBD01 00385 * PERFORMED BY: S0000-CONTROL *PWBPBD01 00386 * FUNCTIONS: POINTS TO ISPF VARIABLES VIA "VDEFINE" SERVICE. *PWBPBD01 00387 ******************************************************************PWBPBD01 00388 PWBPBD01 00389 S1000-INITIALIZATION SECTION. PWBPBD01 00390 PWBPBD01 00391 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00392 MOVE 1 TO W-ISPF-CALL. PWBPBD01 00393 CALL C-ISPF USING C-VDEFINE PWBPBD01 00394 C-LENGTH-1-VARIABLES PWBPBD01 00395 W-LENGTH-1-VARIABLES PWBPBD01 00396 C-CHAR PWBPBD01 00397 C-LENGTH-1-VARIABLES-LEN. PWBPBD01 00398 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00399 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00400 PWBPBD01 00401 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00402 MOVE 2 TO W-ISPF-CALL. PWBPBD01 00403 CALL C-ISPF USING C-VDEFINE PWBPBD01 00404 C-LENGTH-2-VARIABLES PWBPBD01 00405 W-LENGTH-2-VARIABLES PWBPBD01 00406 C-CHAR PWBPBD01 00407 C-LENGTH-2-VARIABLES-LEN. PWBPBD01 00408 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00409 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00410 PWBPBD01 00411 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00412 MOVE 3 TO W-ISPF-CALL. PWBPBD01 00413 CALL C-ISPF USING C-VDEFINE PWBPBD01 00414 C-LENGTH-8-VARIABLES PWBPBD01 00415 W-LENGTH-8-VARIABLES PWBPBD01 00416 C-CHAR PWBPBD01 00417 C-LENGTH-8-VARIABLES-LEN. PWBPBD01 00418 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00419 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00420 PWBPBD01 00421 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00422 MOVE 4 TO W-ISPF-CALL. PWBPBD01 00423 CALL C-ISPF USING C-VDEFINE PWBPBD01 00424 C-LENGTH-9-VARIABLES PWBPBD01 00425 W-LENGTH-9-VARIABLES PWBPBD01 00426 C-CHAR PWBPBD01 00427 C-LENGTH-9-VARIABLES-LEN. PWBPBD01 00428 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00429 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00430 PWBPBD01 00431 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00432 MOVE 5 TO W-ISPF-CALL. PWBPBD01 00433 CALL C-ISPF USING C-VDEFINE PWBPBD01 00434 C-LENGTH-15-VARIABLES PWBPBD01 00435 W-LENGTH-15-VARIABLES PWBPBD01 00436 C-CHAR PWBPBD01 00437 C-LENGTH-15-VARIABLES-LEN. PWBPBD01 00438 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00439 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00440 PWBPBD01 00441 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00442 MOVE 6 TO W-ISPF-CALL. PWBPBD01 00443 CALL C-ISPF USING C-VDEFINE PWBPBD01 00444 C-LENGTH-20-VARIABLES PWBPBD01 00445 W-LENGTH-20-VARIABLES PWBPBD01 00446 C-CHAR PWBPBD01 00447 C-LENGTH-20-VARIABLES-LEN. PWBPBD01 00448 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00449 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00450 PWBPBD01 00451 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00452 MOVE 7 TO W-ISPF-CALL. PWBPBD01 00453 CALL C-ISPF USING C-VDEFINE PWBPBD01 00454 C-LENGTH-78-VARIABLES PWBPBD01 00455 W-LENGTH-78-VARIABLES PWBPBD01 00456 C-CHAR PWBPBD01 00457 C-LENGTH-78-VARIABLES-LEN. PWBPBD01 00458 IF RETURN-CODE > C-NORMAL-RETURN-CODE PWBPBD01 00459 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00460 PWBPBD01 00461 PERFORM S4600-VGET. PWBPBD01 00462 PWBPBD01 00463 S1000-EXIT. PWBPBD01 00464 EXIT. PWBPBD01 00465 /*****************************************************************PWBPBD01 00466 * S2000-MAINLINE *PWBPBD01 00467 * PERFORMED BY: S0000-CONTROL *PWBPBD01 00468 * FUNCTIONS: THIS ROUTINE DOES THE PROCESSING FOR EACH ISPF *PWBPBD01 00469 * ROW. *PWBPBD01 00470 ******************************************************************PWBPBD01 00471 PWBPBD01 00472 S2000-MAINLINE SECTION. PWBPBD01 00473 PWBPBD01 00474 MOVE C-NO-MESSAGE TO W-WORK-MSGLINE-1. PWBPBD01 00475 MOVE C-NO-MESSAGE TO W-WORK-MSGLINE-2. PWBPBD01 00476 MOVE C-NO-MESSAGE TO W-MSGLINE1. PWBPBD01 00477 MOVE C-NO-MESSAGE TO W-MSGLINE2. PWBPBD01 00478 MOVE C-YES TO W-VERIFIED. PWBPBD01 00479 MOVE SPACES TO W-LEGAL-FLAGS. PWBPBD01 00480 MOVE ZEROS TO W-SUB-1. PWBPBD01 00481 PWBPBD01 00482 IF W-LINECMD = C-SELECT-ROW OR PWBPBD01 00483 W-LINECMD = SPACES PWBPBD01 00484 IF S-RUNUNIT-NOT-STARTED PWBPBD01 00485 PERFORM S4100-BIND-AND-READY PWBPBD01 00486 MOVE HIGH-VALUES TO S-RUNUNIT-SWITCH PWBPBD01 00487 PERFORM S4200-DATABASE-VERIFICATION PWBPBD01 00488 ELSE PWBPBD01 00489 PERFORM S4200-DATABASE-VERIFICATION PWBPBD01 00490 ELSE PWBPBD01 00491 IF W-LINECMD = C-DELETE-ROW PWBPBD01 00492 PERFORM S4000-DELETE-ROW PWBPBD01 00493 ELSE PWBPBD01 00494 MOVE C-NO TO W-VERIFIED PWBPBD01 00495 STRING C-SELECT-CODES-MSG PWBPBD01 00496 C-NO-MESSAGE PWBPBD01 00497 DELIMITED BY SIZE PWBPBD01 00498 INTO W-MSGLINE1. PWBPBD01 00499 PWBPBD01 00500 IF W-DATA-VERIFIED PWBPBD01 00501 STRING C-DATA-VERIFIED-MSG PWBPBD01 00502 W-LUDATE ' ' PWBPBD01 00503 W-LUTIME ' ' PWBPBD01 00504 C-NO-MESSAGE PWBPBD01 00505 DELIMITED BY SIZE PWBPBD01 00506 INTO W-MSGLINE1. PWBPBD01 00507 PWBPBD01 00508 IF W-LINECMD NOT = C-DELETE-ROW PWBPBD01 00509 PERFORM S4500-MODIFY-ROW PWBPBD01 00510 ELSE PWBPBD01 00511 NEXT SENTENCE. PWBPBD01 00512 PWBPBD01 00513 S2000-EXIT. PWBPBD01 00514 EXIT. PWBPBD01 00515 /*****************************************************************PWBPBD01 00516 * S3000-FINALIZATION *PWBPBD01 00517 * PERFORMED BY: S0000-CONTROL *PWBPBD01 00518 * FUNCTIONS: THIS ROUTINE CLOSES FILES AND DISPLAYS CONTROL *PWBPBD01 00519 * INFORMATION. *PWBPBD01 00520 ******************************************************************PWBPBD01 00521 PWBPBD01 00522 S3000-FINALIZATION SECTION. PWBPBD01 00523 PWBPBD01 00524 IF S-RUNUNIT-STARTED PWBPBD01 00525 FINISH PWBPBD01 00526 ELSE PWBPBD01 00527 NEXT SENTENCE. PWBPBD01 00528 PWBPBD01 00529 IF W-DATA-VERIFIED PWBPBD01 00530 MOVE C-NORMAL-RETURN-CODE TO RETURN-CODE PWBPBD01 00531 GOBACK PWBPBD01 00532 ELSE PWBPBD01 00533 MOVE C-DATA-NOT-VERIFIED-RC TO RETURN-CODE PWBPBD01 00534 GOBACK. PWBPBD01 00535 PWBPBD01 00536 S3000-EXIT. PWBPBD01 00537 EXIT. PWBPBD01 00538 /*****************************************************************PWBPBD01 00539 * S4000-DELETE-ROW *PWBPBD01 00540 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 00541 * FUNCTIONS: THIS ROUTINE DELETES THE CURRENT ISPF ROW. *PWBPBD01 00542 ******************************************************************PWBPBD01 00543 PWBPBD01 00544 S4000-DELETE-ROW SECTION. PWBPBD01 00545 PWBPBD01 00546 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 00547 MOVE 9 TO W-ISPF-CALL. PWBPBD01 00548 CALL C-ISPF USING C-TBDELETE PWBPBD01 00549 W-CASETAB. PWBPBD01 00550 IF RETURN-CODE > C-OK-RETURN-CODE PWBPBD01 00551 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 00552 PWBPBD01 00553 S4000-EXIT. PWBPBD01 00554 EXIT. PWBPBD01 00555 /*****************************************************************PWBPBD01 00556 * S4100-BIND-AND-READY *PWBPBD01 00557 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 00558 * FUNCTIONS: THIS ROUTINE CREATES THE IDMS RUN-UNIT BY BINDING*PWBPBD01 00559 * AND READYING THE DATABASE. *PWBPBD01 00560 ******************************************************************PWBPBD01 00561 PWBPBD01 00562 S4100-BIND-AND-READY SECTION. PWBPBD01 00563 PWBPBD01 00564 MOVE W-SS TO SUBSCHEMA-SSNAME. PWBPBD01 00565 COPY IDMS SUBSCHEMA-BINDS. PWBPBD01 00566 READY CASE-AREA USAGE-MODE IS RETRIEVAL. PWBPBD01 00567 READY REPU-AREA USAGE-MODE IS RETRIEVAL. PWBPBD01 00568 READY LEGAL-AREA USAGE-MODE IS RETRIEVAL. PWBPBD01 00569 READY GM1241-AREA USAGE-MODE IS RETRIEVAL. PWBPBD01 00570 READY REIMB-AREA USAGE-MODE IS RETRIEVAL. PWBPBD01 00571 READY IXRCSE1-REGION USAGE-MODE IS RETRIEVAL. PWBPBD01 00572 PWBPBD01 00573 S4100-EXIT. PWBPBD01 00574 EXIT. PWBPBD01 00575 /*****************************************************************PWBPBD01 00576 * S4200-DATABASE-VERIFICATION *PWBPBD01 00577 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 00578 * FUNCTIONS: THIS ROUTINE VERIFIES THE SELECTED ROW AGAINST *PWBPBD01 00579 * THE DATABASE. *PWBPBD01 00580 ******************************************************************PWBPBD01 00581 PWBPBD01 00582 S4200-DATABASE-VERIFICATION SECTION. PWBPBD01 00583 PWBPBD01 00584 MOVE HIGH-VALUES TO S-CASE-SWITCH PWBPBD01 00585 S-OWNER-SWITCH. PWBPBD01 00586 MOVE W-CASENUM TO ACSE-REF-NUM. PWBPBD01 00587 PWBPBD01 00588 OBTAIN CALC CA-CASE PWBPBD01 00589 ON DB-REC-NOT-FOUND PWBPBD01 00590 MOVE LOW-VALUES TO S-CASE-SWITCH PWBPBD01 00591 STRING C-CASE-NOT-FOUND-MSG PWBPBD01 00592 C-NO-MESSAGE PWBPBD01 00593 DELIMITED BY SIZE PWBPBD01 00594 INTO W-MSGLINE1 PWBPBD01 00595 MOVE C-NO TO W-VERIFIED. PWBPBD01 00596 PWBPBD01 00597 IF S-CASE-FOUND PWBPBD01 00598 MOVE ACSE-CASE-STATUS-IND TO W-CURRSTAT-STAT PWBPBD01 00599 MOVE ACSE-CASE-TYPE-IND TO W-CURRSTAT-TYPE PWBPBD01 00600 IF ACSE-IN-PROCESS OR PWBPBD01 00601 ACSE-CLOSED PWBPBD01 00602 MOVE C-NO TO W-VERIFIED PWBPBD01 00603 STRING C-OPEN-STATUS-MSG PWBPBD01 00604 C-NO-MESSAGE PWBPBD01 00605 DELIMITED BY SIZE PWBPBD01 00606 INTO W-MSGLINE1 PWBPBD01 00607 ELSE PWBPBD01 00608 NEXT SENTENCE PWBPBD01 00609 ELSE PWBPBD01 00610 NEXT SENTENCE. PWBPBD01 00611 PWBPBD01 00612 IF S-CASE-FOUND AND PWBPBD01 00613 W-DATA-VERIFIED PWBPBD01 00614 MOVE C-OWNER-PARTY-TYPE TO APTY-PARTY-TYPE-NME PWBPBD01 00615 OBTAIN CA-PARTY WITHIN CASE-PARTY PWBPBD01 00616 USING APTY-PARTY-TYPE-NME PWBPBD01 00617 ON DB-REC-NOT-FOUND PWBPBD01 00618 MOVE LOW-VALUES TO S-OWNER-SWITCH PWBPBD01 00619 MOVE C-NO TO W-VERIFIED. PWBPBD01 00620 PWBPBD01 00621 IF S-OWNER-FOUND AND PWBPBD01 00622 S-CASE-FOUND AND PWBPBD01 00623 W-DATA-VERIFIED PWBPBD01 00624 IF APTY-FIRST-NME NOT = W-OFNAME OR PWBPBD01 00625 APTY-MI-NME NOT = W-OMNAME OR PWBPBD01 00626 APTY-LAST-NME NOT = W-OLNAME PWBPBD01 00627 MOVE C-NO TO W-VERIFIED PWBPBD01 00628 IF APTY-MI-NME > SPACES PWBPBD01 00629 IF W-MSGLINE1 NOT = C-NO-MESSAGE PWBPBD01 00630 STRING C-CORRECT-OWNER-MSG PWBPBD01 00631 APTY-FIRST-NME ' ' PWBPBD01 00632 APTY-MI-NME '. ' PWBPBD01 00633 APTY-LAST-NME ' ' PWBPBD01 00634 C-NO-MESSAGE DELIMITED BY SIZE PWBPBD01 00635 INTO W-MSGLINE2 PWBPBD01 00636 ELSE PWBPBD01 00637 STRING C-CORRECT-OWNER-MSG PWBPBD01 00638 APTY-FIRST-NME ' ' PWBPBD01 00639 APTY-MI-NME '. ' PWBPBD01 00640 APTY-LAST-NME ' ' PWBPBD01 00641 C-NO-MESSAGE DELIMITED BY SIZE PWBPBD01 00642 INTO W-MSGLINE1 PWBPBD01 00643 ELSE PWBPBD01 00644 IF W-MSGLINE1 NOT = C-NO-MESSAGE PWBPBD01 00645 STRING C-CORRECT-OWNER-MSG PWBPBD01 00646 APTY-FIRST-NME ' ' PWBPBD01 00647 APTY-LAST-NME ' ' PWBPBD01 00648 C-NO-MESSAGE DELIMITED BY SIZE PWBPBD01 00649 INTO W-MSGLINE2 PWBPBD01 00650 ELSE PWBPBD01 00651 STRING C-CORRECT-OWNER-MSG PWBPBD01 00652 APTY-FIRST-NME ' ' PWBPBD01 00653 APTY-LAST-NME ' ' PWBPBD01 00654 C-NO-MESSAGE DELIMITED BY SIZE PWBPBD01 00655 INTO W-MSGLINE1 PWBPBD01 00656 ELSE PWBPBD01 00657 NEXT SENTENCE PWBPBD01 00658 ELSE PWBPBD01 00659 NEXT SENTENCE. PWBPBD01 00660 PWBPBD01 00661 IF S-CASE-FOUND PWBPBD01 00662 FIND FIRST CA-REPURCHASE WITHIN CASE-REPURCHASE PWBPBD01 00663 ON DB-END-OF-SET PWBPBD01 00664 NEXT SENTENCE. PWBPBD01 00665 PWBPBD01 00666 IF S-CASE-FOUND PWBPBD01 00667 IF DB-STATUS-OK PWBPBD01 00668 MOVE C-FLAG TO W-FLGREPU PWBPBD01 00669 ADD +1 TO W-SUB-1 PWBPBD01 00670 MOVE C-REPU-VALID-STATUS TO W-VALID-STATUS(W-SUB-1) PWBPBD01 00671 ELSE PWBPBD01 00672 NEXT SENTENCE PWBPBD01 00673 ELSE PWBPBD01 00674 NEXT SENTENCE. PWBPBD01 00675 PWBPBD01 00676 IF S-CASE-FOUND PWBPBD01 00677 FIND NEXT WITHIN CASE-LEGAL PWBPBD01 00678 ON DB-END-OF-SET PWBPBD01 00679 NEXT SENTENCE. PWBPBD01 00680 PWBPBD01 00681 IF S-CASE-FOUND PWBPBD01 00682 MOVE SPACES TO W-VALID-STATUS-ARRAY PWBPBD01 00683 PERFORM S4300-GET-LEGAL-INFO PWBPBD01 00684 UNTIL DB-END-OF-SET PWBPBD01 00685 ELSE PWBPBD01 00686 NEXT SENTENCE. PWBPBD01 00687 PWBPBD01 00688 IF S-CASE-FOUND PWBPBD01 00689 OBTAIN FIRST CA-GM1241 WITHIN CASE-GM1241 PWBPBD01 00690 ON DB-END-OF-SET PWBPBD01 00691 NEXT SENTENCE. PWBPBD01 00692 PWBPBD01 00693 IF S-CASE-FOUND PWBPBD01 00694 IF DB-STATUS-OK PWBPBD01 00695 MOVE C-FLAG TO W-FLG1241 PWBPBD01 00696 IF W-CURRSTAT-TYPE = C-GM1241-TYPE PWBPBD01 00697 NEXT SENTENCE PWBPBD01 00698 ELSE PWBPBD01 00699 ADD +1 TO W-SUB-1 PWBPBD01 00700 MOVE C-GM1241-VALID-STATUS TO PWBPBD01 00701 W-VALID-STATUS(W-SUB-1) PWBPBD01 00702 ELSE PWBPBD01 00703 NEXT SENTENCE PWBPBD01 00704 ELSE PWBPBD01 00705 NEXT SENTENCE. PWBPBD01 00706 PWBPBD01 00707 IF S-CASE-FOUND PWBPBD01 00708 OBTAIN FIRST CA-GM1241X WITHIN CASE-GM1241X PWBPBD01 00709 ON DB-END-OF-SET PWBPBD01 00710 NEXT SENTENCE. PWBPBD01 00711 PWBPBD01 00712 IF S-CASE-FOUND PWBPBD01 00713 IF DB-STATUS-OK PWBPBD01 00714 MOVE C-FLAG TO W-FLG1241X PWBPBD01 00715 IF W-CURRSTAT-TYPE = C-GM1241X-TYPE PWBPBD01 00716 NEXT SENTENCE PWBPBD01 00717 ELSE PWBPBD01 00718 ADD +1 TO W-SUB-1 PWBPBD01 00719 MOVE C-GM1241X-VALID-STATUS TO PWBPBD01 00720 W-VALID-STATUS(W-SUB-1) PWBPBD01 00721 ELSE PWBPBD01 00722 NEXT SENTENCE PWBPBD01 00723 ELSE PWBPBD01 00724 NEXT SENTENCE. PWBPBD01 00725 PWBPBD01 00726 IF S-CASE-FOUND PWBPBD01 00727 IF W-SUB-1 = 0 OR PWBPBD01 00728 W-VALID-STATUS(1) = SPACES PWBPBD01 00729 MOVE C-GENERAL-VALID-STATUS TO W-VALID-STATUS(1) PWBPBD01 00730 STRING C-VALID-STATUS-MSG PWBPBD01 00731 W-VALID-STATUS(1) PWBPBD01 00732 C-NO-MESSAGE PWBPBD01 00733 DELIMITED BY SIZE PWBPBD01 00734 INTO W-WORK-MSGLINE-2 PWBPBD01 00735 ELSE PWBPBD01 00736 IF W-SUB-1 = 1 PWBPBD01 00737 STRING C-VALID-STATUS-MSG PWBPBD01 00738 W-VALID-STATUS(1) PWBPBD01 00739 C-NO-MESSAGE PWBPBD01 00740 DELIMITED BY SIZE PWBPBD01 00741 INTO W-WORK-MSGLINE-2 PWBPBD01 00742 ELSE PWBPBD01 00743 IF W-SUB-1 = 2 PWBPBD01 00744 STRING C-VALID-STATUS-MSG PWBPBD01 00745 W-VALID-STATUS(1) PWBPBD01 00746 W-VALID-STATUS(2) PWBPBD01 00747 C-NO-MESSAGE PWBPBD01 00748 DELIMITED BY SIZE PWBPBD01 00749 INTO W-WORK-MSGLINE-2 PWBPBD01 00750 ELSE PWBPBD01 00751 IF W-SUB-1 = 3 PWBPBD01 00752 STRING C-VALID-STATUS-MSG PWBPBD01 00753 W-VALID-STATUS(1) PWBPBD01 00754 W-VALID-STATUS(2) PWBPBD01 00755 W-VALID-STATUS(3) PWBPBD01 00756 C-NO-MESSAGE PWBPBD01 00757 DELIMITED BY SIZE PWBPBD01 00758 INTO W-WORK-MSGLINE-2 PWBPBD01 00759 ELSE PWBPBD01 00760 IF W-SUB-1 = 4 PWBPBD01 00761 STRING C-VALID-STATUS-MSG PWBPBD01 00762 W-VALID-STATUS(1) PWBPBD01 00763 W-VALID-STATUS(2) PWBPBD01 00764 W-VALID-STATUS(3) PWBPBD01 00765 W-VALID-STATUS(4) PWBPBD01 00766 C-NO-MESSAGE PWBPBD01 00767 DELIMITED BY SIZE PWBPBD01 00768 INTO W-WORK-MSGLINE-2 PWBPBD01 00769 ELSE PWBPBD01 00770 IF W-SUB-1 = 5 PWBPBD01 00771 STRING C-VALID-STATUS-MSG PWBPBD01 00772 W-VALID-STATUS-ARRAY PWBPBD01 00773 C-NO-MESSAGE PWBPBD01 00774 DELIMITED BY SIZE PWBPBD01 00775 INTO W-WORK-MSGLINE-2 PWBPBD01 00776 ELSE PWBPBD01 00777 NEXT SENTENCE PWBPBD01 00778 ELSE PWBPBD01 00779 NEXT SENTENCE. PWBPBD01 00780 PWBPBD01 00781 IF S-CASE-FOUND PWBPBD01 00782 MOVE W-CASENUM TO RCSE-REF-NUM PWBPBD01 00783 OBTAIN CA-RB-CASE WITHIN IX-RBCASE-REFNUM PWBPBD01 00784 USING RCSE-REF-NUM PWBPBD01 00785 ON DB-REC-NOT-FOUND PWBPBD01 00786 NEXT SENTENCE. PWBPBD01 00787 PWBPBD01 00788 IF S-CASE-FOUND PWBPBD01 00789 IF DB-STATUS-OK PWBPBD01 00790 PERFORM S4400-GET-REIMB-INFO PWBPBD01 00791 UNTIL ERROR-STATUS > ZEROS OR PWBPBD01 00792 RCSE-REF-NUM NOT = W-CASENUM PWBPBD01 00793 ELSE PWBPBD01 00794 NEXT SENTENCE PWBPBD01 00795 ELSE PWBPBD01 00796 NEXT SENTENCE. PWBPBD01 00797 PWBPBD01 00798 IF S-CASE-FOUND PWBPBD01 00799 IF (W-NEXTTYPE = C-GM1241-TYPE AND PWBPBD01 00800 W-FLG1241 = SPACES) OR PWBPBD01 00801 (W-NEXTTYPE = C-GM1241X-TYPE AND PWBPBD01 00802 W-FLG1241X = SPACES) OR PWBPBD01 00803 (W-NEXTTYPE = C-PRODUCT-LIABILITY-TYPE AND PWBPBD01 00804 W-FLGPLIAB = SPACES) OR PWBPBD01 00805 (W-NEXTTYPE = C-BREACH-TYPE AND PWBPBD01 00806 W-FLGBRECH = SPACES) OR PWBPBD01 00807 (W-NEXTTYPE = C-MEDIATION-TYPE AND PWBPBD01 00808 W-FLGMED = SPACES) OR PWBPBD01 00809 (W-NEXTTYPE = C-ARBITRATION-TYPE AND PWBPBD01 00810 W-FLGARB = SPACES) PWBPBD01 00811 MOVE C-NO TO W-VERIFIED PWBPBD01 00812 IF W-FLGARB > SPACES AND PWBPBD01 00813 W-NEXTTYPE = C-MEDIATION-TYPE AND PWBPBD01 00814 W-CURRSTAT-TYPE NOT = C-ARBITRATION-TYPE PWBPBD01 00815 STRING C-NOT-M-IF-ARB-MSG PWBPBD01 00816 C-NO-MESSAGE PWBPBD01 00817 DELIMITED BY SIZE PWBPBD01 00818 INTO W-WORK-MSGLINE-1 PWBPBD01 00819 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00820 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00821 ELSE PWBPBD01 00822 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00823 ELSE PWBPBD01 00824 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00825 MOVE W-WORK-MSGLINE-2 TO W-MSGLINE2 PWBPBD01 00826 ELSE PWBPBD01 00827 MOVE W-WORK-MSGLINE-2 TO W-MSGLINE1 PWBPBD01 00828 ELSE PWBPBD01 00829 IF W-FLGARB > SPACES AND PWBPBD01 00830 W-NEXTTYPE NOT = C-MEDIATION-TYPE AND PWBPBD01 00831 W-CURRSTAT-TYPE = C-ARBITRATION-TYPE AND NOT PWBPBD01 00832 ((W-NEXTTYPE = C-ARBITRATION-TYPE OR PWBPBD01 00833 W-NEXTTYPE = C-REPURCHASE-TYPE) AND PWBPBD01 00834 W-FLGREPU = C-FLAG) PWBPBD01 00835 MOVE C-NO TO W-VERIFIED PWBPBD01 00836 MOVE SPACES TO W-WORK-MSGLINE-1 PWBPBD01 00837 STRING C-ARB-ONLY-TO-M-MSG PWBPBD01 00838 C-NO-MESSAGE PWBPBD01 00839 DELIMITED BY SIZE PWBPBD01 00840 INTO W-WORK-MSGLINE-1 PWBPBD01 00841 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00842 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00843 ELSE PWBPBD01 00844 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00845 ELSE PWBPBD01 00846 IF W-FLGARB > SPACES AND PWBPBD01 00847 W-NEXTTYPE = C-MEDIATION-TYPE AND PWBPBD01 00848 W-CURRSTAT-TYPE NOT = C-ARBITRATION-TYPE PWBPBD01 00849 MOVE C-NO TO W-VERIFIED PWBPBD01 00850 STRING C-NOT-M-IF-ARB-MSG PWBPBD01 00851 C-NO-MESSAGE PWBPBD01 00852 DELIMITED BY SIZE PWBPBD01 00853 INTO W-WORK-MSGLINE-1 PWBPBD01 00854 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00855 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00856 ELSE PWBPBD01 00857 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00858 ELSE PWBPBD01 00859 NEXT SENTENCE PWBPBD01 00860 ELSE PWBPBD01 00861 NEXT SENTENCE. PWBPBD01 00862 PWBPBD01 00863 IF S-CASE-FOUND PWBPBD01 00864 IF W-LEGAL-FLAGS = SPACES PWBPBD01 00865 MOVE C-NO TO W-VERIFIED PWBPBD01 00866 STRING C-LEGAL-STATUS-MSG PWBPBD01 00867 C-NO-MESSAGE PWBPBD01 00868 DELIMITED BY SIZE PWBPBD01 00869 INTO W-WORK-MSGLINE-1 PWBPBD01 00870 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00871 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00872 ELSE PWBPBD01 00873 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00874 ELSE PWBPBD01 00875 NEXT SENTENCE PWBPBD01 00876 ELSE PWBPBD01 00877 NEXT SENTENCE. PWBPBD01 00878 PWBPBD01 00879 IF S-CASE-FOUND PWBPBD01 00880 IF W-NEXTTYPE = W-CURRSTAT-TYPE OR PWBPBD01 00881 W-NEXTTYPE = C-REPURCHASE-TYPE PWBPBD01 00882 IF W-FLGREPU = C-FLAG PWBPBD01 00883 STRING C-REPURCHASE-MSG PWBPBD01 00884 C-NO-MESSAGE PWBPBD01 00885 DELIMITED BY SIZE PWBPBD01 00886 INTO W-MSGLINE2 PWBPBD01 00887 MOVE C-REPURCHASE-TYPE TO W-NEXTTYPE PWBPBD01 00888 ELSE PWBPBD01 00889 MOVE C-NO TO W-VERIFIED PWBPBD01 00890 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00891 STRING C-NO-REPURCHASE-MSG PWBPBD01 00892 C-NO-MESSAGE PWBPBD01 00893 DELIMITED BY SIZE PWBPBD01 00894 INTO W-MSGLINE2 PWBPBD01 00895 ELSE PWBPBD01 00896 STRING C-NO-REPURCHASE-MSG PWBPBD01 00897 C-NO-MESSAGE PWBPBD01 00898 DELIMITED BY SIZE PWBPBD01 00899 INTO W-MSGLINE1 PWBPBD01 00900 ELSE PWBPBD01 00901 NEXT SENTENCE. PWBPBD01 00902 PWBPBD01 00903 MOVE ZEROS TO W-TALLY. PWBPBD01 00904 INSPECT W-VALID-STATUS-ARRAY PWBPBD01 00905 TALLYING W-TALLY PWBPBD01 00906 FOR ALL C-GENERAL-TYPE. PWBPBD01 00907 PWBPBD01 00908 IF W-CANNOT-GO-TO-GENERAL AND W-GENERAL-SELECTED PWBPBD01 00909 MOVE C-NO TO W-VERIFIED PWBPBD01 00910 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00911 MOVE W-WORK-MSGLINE-2 TO W-MSGLINE2 PWBPBD01 00912 ELSE PWBPBD01 00913 MOVE W-WORK-MSGLINE-2 TO W-MSGLINE1 PWBPBD01 00914 ELSE PWBPBD01 00915 NEXT SENTENCE. PWBPBD01 00916 PWBPBD01 00917 IF S-CASE-FOUND PWBPBD01 00918 IF W-CURRSTAT-TYPE = C-GM1241-TYPE PWBPBD01 00919 IF A41R-ZN-APP-NAM > SPACES PWBPBD01 00920 MOVE C-NO TO W-VERIFIED PWBPBD01 00921 STRING C-GM1241-MSG PWBPBD01 00922 C-NO-MESSAGE PWBPBD01 00923 DELIMITED BY SIZE PWBPBD01 00924 INTO W-WORK-MSGLINE-1 PWBPBD01 00925 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00926 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00927 ELSE PWBPBD01 00928 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00929 ELSE PWBPBD01 00930 NEXT SENTENCE PWBPBD01 00931 ELSE PWBPBD01 00932 IF W-CURRSTAT-TYPE = C-GM1241X-TYPE PWBPBD01 00933 IF A41X-ZN-APR-NAM > SPACES PWBPBD01 00934 MOVE C-NO TO W-VERIFIED PWBPBD01 00935 STRING C-GM1241X-MSG PWBPBD01 00936 C-NO-MESSAGE PWBPBD01 00937 DELIMITED BY SIZE PWBPBD01 00938 INTO W-WORK-MSGLINE-1 PWBPBD01 00939 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 00940 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 00941 ELSE PWBPBD01 00942 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1 PWBPBD01 00943 ELSE PWBPBD01 00944 NEXT SENTENCE PWBPBD01 00945 ELSE PWBPBD01 00946 NEXT SENTENCE. PWBPBD01 00947 PWBPBD01 00948 S4200-EXIT. PWBPBD01 00949 EXIT. PWBPBD01 00950 /*****************************************************************PWBPBD01 00951 * S4300-GET-LEGAL-INFO *PWBPBD01 00952 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 00953 * FUNCTIONS: THIS ROUTINE LOOPS THROUGH THE CASE-LEGAL SET AND*PWBPBD01 00954 * SETS THE FLAGS FOR THIS ROW. *PWBPBD01 00955 ******************************************************************PWBPBD01 00956 PWBPBD01 00957 S4300-GET-LEGAL-INFO SECTION. PWBPBD01 00958 PWBPBD01 00959 IF RECORD-NAME = C-BREACH PWBPBD01 00960 MOVE C-FLAG TO W-FLGBRECH PWBPBD01 00961 IF W-CURRSTAT-TYPE = C-BREACH-TYPE AND PWBPBD01 00962 W-FLGREPU NOT = C-FLAG PWBPBD01 00963 NEXT SENTENCE PWBPBD01 00964 ELSE PWBPBD01 00965 ADD +1 TO W-SUB-1 PWBPBD01 00966 MOVE C-BREACH-VALID-STATUS TO PWBPBD01 00967 W-VALID-STATUS(W-SUB-1) PWBPBD01 00968 ELSE PWBPBD01 00969 IF RECORD-NAME = C-PRODUCT-LIABILITY PWBPBD01 00970 MOVE C-FLAG TO W-FLGPLIAB PWBPBD01 00971 IF W-CURRSTAT-TYPE = C-PRODUCT-LIABILITY-TYPE AND PWBPBD01 00972 W-FLGREPU NOT = C-FLAG PWBPBD01 00973 NEXT SENTENCE PWBPBD01 00974 ELSE PWBPBD01 00975 ADD +1 TO W-SUB-1 PWBPBD01 00976 MOVE C-PRODLIB-VALID-STATUS TO PWBPBD01 00977 W-VALID-STATUS(W-SUB-1) PWBPBD01 00978 ELSE PWBPBD01 00979 IF RECORD-NAME = C-MEDIATION PWBPBD01 00980 MOVE C-FLAG TO W-FLGMED PWBPBD01 00981 IF W-CURRSTAT-TYPE = C-MEDIATION-TYPE AND PWBPBD01 00982 W-FLGREPU NOT = C-FLAG PWBPBD01 00983 NEXT SENTENCE PWBPBD01 00984 ELSE PWBPBD01 00985 ADD +1 TO W-SUB-1 PWBPBD01 00986 MOVE C-MED-VALID-STATUS TO PWBPBD01 00987 W-VALID-STATUS(W-SUB-1) PWBPBD01 00988 ELSE PWBPBD01 00989 IF RECORD-NAME = C-ARBITRATION PWBPBD01 00990 MOVE C-FLAG TO W-FLGARB PWBPBD01 00991 IF W-CURRSTAT-TYPE = C-ARBITRATION-TYPE AND PWBPBD01 00992 W-FLGREPU NOT = C-FLAG PWBPBD01 00993 NEXT SENTENCE PWBPBD01 00994 ELSE PWBPBD01 00995 ADD +1 TO W-SUB-1 PWBPBD01 00996 MOVE C-ARB-VALID-STATUS TO PWBPBD01 00997 W-VALID-STATUS(W-SUB-1) PWBPBD01 00998 ELSE PWBPBD01 00999 NEXT SENTENCE. PWBPBD01 01000 PWBPBD01 01001 FIND NEXT WITHIN CASE-LEGAL PWBPBD01 01002 ON DB-END-OF-SET PWBPBD01 01003 NEXT SENTENCE. PWBPBD01 01004 PWBPBD01 01005 S4300-EXIT. PWBPBD01 01006 EXIT. PWBPBD01 01007 /*****************************************************************PWBPBD01 01008 * S4400-GET-REIMB-INFO *PWBPBD01 01009 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 01010 * FUNCTIONS: THIS ROUTINE DETERMINES IF THERE IS AN OPEN *PWBPBD01 01011 * REIMBURSEMENT FOR THIS CASE. *PWBPBD01 01012 ******************************************************************PWBPBD01 01013 PWBPBD01 01014 S4400-GET-REIMB-INFO SECTION. PWBPBD01 01015 PWBPBD01 01016 IF RCSE-REJECT-STATUS OR PWBPBD01 01017 RCSE-COMPLETE-STATUS OR PWBPBD01 01018 RCSE-VOID-STATUS PWBPBD01 01019 NEXT SENTENCE PWBPBD01 01020 ELSE PWBPBD01 01021 MOVE C-NO TO W-VERIFIED PWBPBD01 01022 STRING C-REIMBURSEMENT-MSG PWBPBD01 01023 C-NO-MESSAGE PWBPBD01 01024 DELIMITED BY SIZE PWBPBD01 01025 INTO W-WORK-MSGLINE-1 PWBPBD01 01026 IF W-MSGLINE1 > C-NO-MESSAGE PWBPBD01 01027 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE2 PWBPBD01 01028 ELSE PWBPBD01 01029 MOVE W-WORK-MSGLINE-1 TO W-MSGLINE1. PWBPBD01 01030 PWBPBD01 01031 OBTAIN NEXT CA-RB-CASE WITHIN IX-RBCASE-REFNUM PWBPBD01 01032 ON DB-END-OF-SET PWBPBD01 01033 NEXT SENTENCE. PWBPBD01 01034 PWBPBD01 01035 S4400-EXIT. PWBPBD01 01036 EXIT. PWBPBD01 01037 /*****************************************************************PWBPBD01 01038 * S4500-MODIFY-ROW *PWBPBD01 01039 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 01040 * FUNCTIONS: THIS ROUTINE CALLS ISPLINK TO DO A TBPUT ON THE *PWBPBD01 01041 * CURRENT ROW. *PWBPBD01 01042 ******************************************************************PWBPBD01 01043 PWBPBD01 01044 S4500-MODIFY-ROW SECTION. PWBPBD01 01045 PWBPBD01 01046 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 01047 MOVE 8 TO W-ISPF-CALL. PWBPBD01 01048 CALL C-ISPF USING C-TBPUT PWBPBD01 01049 W-CASETAB. PWBPBD01 01050 IF RETURN-CODE > C-OK-RETURN-CODE PWBPBD01 01051 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 01052 PWBPBD01 01053 S4500-EXIT. PWBPBD01 01054 EXIT. PWBPBD01 01055 /*****************************************************************PWBPBD01 01056 * S4600-VGET *PWBPBD01 01057 * PERFORMED BY: S2000-MAINLINE *PWBPBD01 01058 * FUNCTIONS: THIS ROUTINE "VGETS" THE NECESSARY VARIABLES. *PWBPBD01 01059 ******************************************************************PWBPBD01 01060 PWBPBD01 01061 S4600-VGET SECTION. PWBPBD01 01062 PWBPBD01 01063 ADD 1 TO A-ISPF-CALLS-MADE. PWBPBD01 01064 MOVE 10 TO W-ISPF-CALL. PWBPBD01 01065 CALL C-ISPF USING C-VGET PWBPBD01 01066 C-VGET-VPUT-VARIABLES. PWBPBD01 01067 IF RETURN-CODE > C-PASSABLE-RETURN-CODE PWBPBD01 01068 PERFORM S5000-ISPF-RETURN-CODE-CHECK. PWBPBD01 01069 PWBPBD01 01070 S4600-EXIT. PWBPBD01 01071 EXIT. PWBPBD01 01072 /*****************************************************************PWBPBD01 01073 * S5000-ISPF-RETURN-CODE-CHECK *PWBPBD01 01074 * PERFORMED BY: S1000-INITIALIZATION *PWBPBD01 01075 * FUNCTIONS: THIS ROUTINE CHECKS THE RETURN CODE FROM ANY *PWBPBD01 01076 * CALL TO ISPF AND DISPLAYS ABEND MESSAGES IF ANY. *PWBPBD01 01077 ******************************************************************PWBPBD01 01078 PWBPBD01 01079 S5000-ISPF-RETURN-CODE-CHECK SECTION. PWBPBD01 01080 PWBPBD01 01081 MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE. PWBPBD01 01082 DISPLAY '********* PWBPBD01 ABEND INFO ***********'. PWBPBD01 01083 DISPLAY '*!! SCREEN PRINT THIS INFORMATION AND !!*'. PWBPBD01 01084 DISPLAY '*!!! CONTACT CAS SUPPORT IN DENVER !!!*'. PWBPBD01 01085 DISPLAY '*============= ISPF ABEND ==============*'. PWBPBD01 01086 DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *'. PWBPBD01 01087 DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE PWBPBD01 01088 ' *'. PWBPBD01 01089 DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL PWBPBD01 01090 ' *'. PWBPBD01 01091 DISPLAY '* # ISPF CALLS MADE WERE : ' A-ISPF-CALLS-MADE PWBPBD01 01092 ' *'. PWBPBD01 01093 DISPLAY '*****************************************'. PWBPBD01 01094 PERFORM S3000-FINALIZATION. PWBPBD01 01095 PWBPBD01 01096 S5000-EXIT. PWBPBD01 01097 EXIT. PWBPBD01 01098 /*****************************************************************PWBPBD01 01099 * IDMS ABORT & STATUS SECTIONS *PWBPBD01 01100 * PERFORMED BY: DML CALLS *PWBPBD01 01101 * FUNCTIONS: IDMS-STATUS PERFORMS IDMS ERROR PROCESSING AND *PWBPBD01 01102 * PERFORMS IDMS-ABORT. IDMS-ABORT CONTAINS THE *PWBPBD01 01103 * PROGRAM DISPLAYS. *PWBPBD01 01104 ******************************************************************PWBPBD01 01105 PWBPBD01 01106 IDMS-ABORT SECTION. PWBPBD01 01107 PWBPBD01 01108 IF S-NOT-FINISH-COMMAND PWBPBD01 01109 DISPLAY '*********** PWBPBD01 ABEND INFO *************' PWBPBD01 01110 DISPLAY '* !!! SCREEN PRINT THIS INFORMATION AND !!! *' PWBPBD01 01111 DISPLAY '* !!! CONTACT CAS SUPPORT IN DENVER !!! *' PWBPBD01 01112 DISPLAY '*===========================================*' PWBPBD01 01113 DISPLAY '* # OF ISPF CALLS SO FAR : ' PWBPBD01 01114 A-ISPF-CALLS-MADE ' *' PWBPBD01 01115 DISPLAY '* ISPF CALL SEQ # LAST EXECUTED : ' PWBPBD01 01116 W-ISPF-CALL ' *' PWBPBD01 01117 DISPLAY '*===========================================*' PWBPBD01 01118 DISPLAY '******* IDMS ABEND INFORMATION FOLLOWS ******' PWBPBD01 01119 DISPLAY '*********************************************' PWBPBD01 01120 DISPLAY 'PROGRAM NAME ------ ' PROGRAM-NAME PWBPBD01 01121 DISPLAY 'ERROR STATUS ------ ' ERROR-STATUS PWBPBD01 01122 DISPLAY 'ERROR RECORD ------ ' ERROR-RECORD PWBPBD01 01123 DISPLAY 'ERROR SET --------- ' ERROR-SET PWBPBD01 01124 DISPLAY 'ERROR AREA -------- ' ERROR-AREA PWBPBD01 01125 DISPLAY 'LAST GOOD RECORD -- ' RECORD-NAME PWBPBD01 01126 DISPLAY 'LAST GOOD AREA ---- ' AREA-NAME PWBPBD01 01127 DISPLAY 'DML SEQUENCE--------' DML-SEQUENCE PWBPBD01 01128 DISPLAY '*********************************************' PWBPBD01 01129 MOVE ERROR-STATUS TO W-ERROR-STATUS PWBPBD01 01130 IF S-RUNUNIT-STARTED PWBPBD01 01131 MOVE HIGH-VALUES TO S-FINISH-SWITCH PWBPBD01 01132 FINISH PWBPBD01 01133 IF W-BIND-PROBLEM OR W-RUNUNIT-PROBLEM PWBPBD01 01134 MOVE C-BIND-OR-RUNUNIT-RC TO RETURN-CODE PWBPBD01 01135 GOBACK PWBPBD01 01136 ELSE PWBPBD01 01137 MOVE C-BAD-IDMS-RC TO RETURN-CODE PWBPBD01 01138 GOBACK PWBPBD01 01139 ELSE PWBPBD01 01140 IF W-BIND-PROBLEM OR W-RUNUNIT-PROBLEM PWBPBD01 01141 MOVE C-BIND-OR-RUNUNIT-RC TO RETURN-CODE PWBPBD01 01142 GOBACK PWBPBD01 01143 ELSE PWBPBD01 01144 MOVE C-BAD-IDMS-RC TO RETURN-CODE PWBPBD01 01145 GOBACK PWBPBD01 01146 ELSE PWBPBD01 01147 NEXT SENTENCE. PWBPBD01 01148 PWBPBD01 01149 IDMS-EXIT. PWBPBD01 01150 EXIT. PWBPBD01 01151 COPY IDMS IDMS-STATUS. PWBPBD01 ./ ADD NAME=REXXDSNT TITLE 'RETURN RESULTS OF ESQL QUERY AS REXX VARIABLES' ** * Function: The results from the specified ESQL query are returned * as REXX variables. * The variable names are those attributes * resulting from the ESQL query. * This program uses the DB2 CAF interface and so can * execute outside the DB2 environment (however, SQL * must be available). * Plan name: REXXSQL ** * Input variable: : SQL query * Output variables: columnname(j).i (i = row) * <_VN>.j column names * <_VN.0> no of columns * <_NROWS> no of rows ** ** * Return code: 0 ok * otherwise error code from REXX or CAF ** ** * Register usage: * R2: work-register * R3: work-register * R4: work-register * R5: work-register * R6: * no. of columns * R7: A(SQLVARN) * R8: A(SQLDA) * R9: A(SQLCA) * R10: type pointer * R11: free * R12: base register ** REXXSQL CSECT * initialize addressing COPY REGS STM R14,R12,12(R13) save registers BALR R12,0 base register USING *,R12 LA R15,SA A(save-area) ST R13,4(R15) backward ptr ST R15,8(R13) forward ptr LR R13,R15 A(new save-area) B SA_END jump over save-area SA DS 18A save-area SA_END DS 0H LOAD EP=IRXEXCOM load IRXEXCOM ST R0,AIRXEXCOM save EP address * obtain LA R5,IRX_SHVBLOCK USING SHVBLOCK,R5 MVI SHVCODE,SHVFETCH MVC SHVBUFL,=A(L'SQLQUERY) MVC SHVVALA,=A(SQLQUERY) MVC VN,=C'SQLQUERY ' BAL R14,GETVNL get length of ST R0,SHVNAML L() MVC SHVNAMA,=A(VN) A() L R15,AIRXEXCOM CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL LTR R15,R15 REXX return code BNZ EOP parameter error L R1,SHVVALL L(parameter) STH R1,SELECT MVC RC,=H'12' preset return code CALL DB2CAFI,(PLAN,SUBSYS),VL initialize CAF LTR R15,R15 CAF return code BNZ EOP * determine no of columns in table LA R9,SQL_CA USING SQLDSECT,R9 LA R8,SQL_DA USING SQLDA,R8 * dummy PREPARE EXEC SQL PREPARE S1 FROM :SELECT BAL R14,CHECK_SQL MVC SQLN,=H'0' return count only * DESCRIBE EXEC SQL DESCRIBE S1 INTO :SQL_DA BAL R14,CHECK_SQL * analyse descriptor and acquire storage * : no. of columns LH R2,SQLD MVC RC,=H'0' reset return code LTR R2,R2 BZ A500 :non-SELECT LH R3,SQLD MH R2,=AL2(SQLVARN_SIZE) LA R2,(SQLVAR-SQLDA)(R2) +L(fixed hdr) * R2: total column size ST R2,COLSIZE GETMAIN EU,LV=(2),A=A_SQLDA L R8,A_SQLDA * perform DESCRIBE with correct length STH R3,SQLD STH R3,SQLN ST R2,SQLDABC * DESCRIBE EXEC SQL DESCRIBE S1 INTO :SQLDA BAL R14,CHECK_SQL * build row buffer LH R6,SQLD no of occurrences (columns) LTR R6,R6 BZ EOP no entries LA R7,SQLVAR USING SQLVARN,R7 SR R4,R4 zeroize buffer size accumulator * output no of columns (<_VN.0>) CVD R6,D MVC WK,=X'F020202020202020' ED WK,D+4 LA R3,WK A(data) MVC VL,=A(L'WK) L(data) MVC VNINDEX,=C'.0' MVC VLINDEX,=A(2) MVC VN,=C'_VN ' * set data into RESS variable BAL R14,SETVAR A230 DS 0H * column type BAL R14,GET_TYPE * R2: data width * R3: field size * R10: DSECT_TYPE entry USING DSECT_TYPE,R10 LA R4,2(R3,R4) accumulate total buffer size AP INDEX,=P'1' increment index * convert index to form: .n MVC VNINDEX,=X'4020202020202120' LA R1,VNINDEX+7 EDMK VNINDEX,INDEX BCTR R1,0 MVI 0(R1),C'.' MVC VNINDEX,0(R1) LA R0,VNINDEX+L'VNINDEX SR R0,R1 ST R0,VLINDEX L(index) MVC VN,=C'_VN ' name prefix LA R3,SQLNAME+2 column name LH R0,SQLNAME L(column name) * TEST WHETHER NULL COLUMN NAME LH R0,SQLNAME L(COLUMN NAME) LTR R0,R0 BNZ A231 NO COLUMN NAME MVC SQLNAME+2(8),=CL8'__VN' AP VNCT,=P'1' UNPK SQLNAME+6(1),VNCT OI SQLNAME+6,C'0' LA R0,5 STH R0,SQLNAME L(COLUMN NAME) LH R0,SQLNAME L(COLUMN NAME) A231 ST R0,VL * set data into REXX variable BAL R14,SETVAR LA R7,SQLVARN_SIZE(R7) BCT R6,A230 * end of scan phase, allocate data buffer * R5: total buffer size ST R5,BUFFSIZE GETMAIN EU,LV=(5),A=A_DBUF * complete SQLDA L R5,A_DBUF PTR(data buffer) LH R6,SQLD no of occurrences (columns) LA R7,SQLVAR reinitialize pointer * column-type A240 BAL R14,GET_TYPE * R3: field size * R10: DSECT_TYPE entry ST R5,SQLIND A(indicator), if needed LA R5,2(R5) update ptr ST R5,SQLDATA A(host variable) AR R5,R3 update ptr LA R7,SQLVARN_SIZE(R7) BCT R6,A240 * retrieve records * DECLARE CURSOR EXEC SQL DECLARE CSR CURSOR FOR S1 BAL R14,CHECK_SQL * OPEN CURSOR EXEC SQL OPEN CSR BAL R14,CHECK_SQL ZAP INDEX,=P'0' initialize row index A400 DS 0H * FETCH row EXEC SQL FETCH CSR USING DESCRIPTOR :SQLDA CLC SQLCODE,=F'100' BE EOD end of data AP INDEX,=P'1' increment index * convert index to form: .n MVC VNINDEX,=X'4020202020202120' LA R1,VNINDEX+7 EDMK VNINDEX,INDEX BCTR R1,0 MVI 0(R1),C'.' MVC VNINDEX,0(R1) LA R0,VNINDEX+L'VNINDEX SR R0,R1 ST R0,VLINDEX LH R6,SQLD no of occurrences (columns) LA R7,SQLVAR reinitialize pointer * write table row A410 DS 0H USING SQLVARN,R7 * default (null) value LA R2,1 LA R3,=C'-' L R1,SQLIND A(indicator field) LH R0,0(R1) CH R0,=H'-1' BE A420 no data BAL R14,GET_TYPE * R2: data width * R3: field size * R10: DSECT_TYPE entry L R15,DS_ADDR A(routine) BALR R14,R15 * R3: A(formatted field) * R2: L(formatted field) A420 ST R2,VL LH R1,SQLNAME L(name) LA R0,L'VN MAX(L(name)) CR R1,R0 BNH *+6 LR R1,R0 truncate BCTR R1,0 LC(name) MVC VN,VN-1 MVC VN,SQLNAME+2 column name EX R1,*-6 * set data into REXX variable BAL R14,SETVAR LA R7,SQLVARN_SIZE(R7) BCT R6,A410 get next column in row B A400 get next column A500 DS 0H process non-SELECT EXEC SQL EXECUTE S1 BAL R14,CHECK_SQL EOD CALL DB2CAFT close CAF * end of processing EOP DS 0H * output no of rows processed MVC WK,=X'F020202020202020' ED WK,INDEX LA R3,WK A(data) MVC VL,=A(L'WK) L(data) MVC VLINDEX,=A(0) no index MVC VN,=C'_NROWS ' * set data into REXX variable BAL R14,SETVAR * release allocated storage L R2,COLSIZE LTR R2,R2 BZ NOCOLS L R3,A_SQLDA FREEMAIN R,LV=(2),A=(3) NOCOLS L R2,BUFFSIZE LTR R2,R2 BZ NOBUF L R3,A_DBUF FREEMAIN R,LV=(5),A=(3) NOBUF L R13,4(R13) restore A(old save-area) LH R15,RC set return code RETURN (14,12),RC=(15) RC DS H program return code PLAN DC CL8'REXXSQL' plan name SUBSYS DC CL8'DSNT' DB2 subsystem name TITLE 'SUBROUTINES' GETVNL DS 0H determine actual length of name * input: - name * output: R0 - L(name) * R15 - A(first blank) LA R1,L'VN SR R0,R0 counter LA R15,VN GETVNL1 CLI 0(R15),C' ' BER R14 end found AH R0,=H'1' LA R15,1(R15) BCT R1,GETVNL1 * R0: L(name), without trailing blanks BR R14 DS A SETVAR ST R14,SETVAR-4 set REXX variable * : variable name, prefix * : variable name, suffix * : length (variable name, suffix) * : L(variable data) * R3: A(variable data) BAL R14,GETVNL get L(VN) * R0: L(VN), R15: A(first blank in ) MVC 0(L'VNINDEX,R15),VNINDEX A R0,VLINDEX LA R5,IRX_SHVBLOCK USING SHVBLOCK,R5 ST R0,SHVNAML MVC SHVNAMA,=A(VN) MVI SHVCODE,SHVSTORE ST R3,SHVVALA MVC SHVVALL,VL L R15,AIRXEXCOM A(IRXEXCOM) CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL L R14,SETVAR-4 BR R14 return GET_TYPE DS 0H get column type and size(s) * input: * DSECT_SQLVARN entry * output: * R2: data width * R3: field size * DSECT_TYPE entry LA R10,T_TYPE-DS_L USING DSECT_TYPE,R10 GETTYPE1 LA R10,DS_L(R10) CLC SQLTYPE,DS_TYPE BNE GETTYPE1 * entry found, get column-length LH R2,SQLLEN LR R3,R2 preset data field size CLC DS_CODE,=CL2'P' (packed) decimal? BNE GETTYPE2 :no SR R2,R2 IC R2,SQLPRCSN precision LR R3,R2 SRL R3,1 no of digit pairs LA R3,1(R3) true data field size GETTYPE2 CLC DS_CODE,=CL2'CV' character (variable)? BNE GETTYPE3 :no LA R3,2(R3) alloc room for length GETTYPE3 BR R14 return TITLE 'CONVERSION ROUTINES' T_TYPE DS 0H alignment DC H'384',AL1(@CHAR,0),CL2'D ',AL4(D_DATE) DC H'385',AL1(@CHAR,0),CL2'D ',AL4(D_DATE) DC H'388',AL1(@CHAR,0),CL2'T ',AL4(D_TIME) DC H'389',AL1(@CHAR,0),CL2'T ',AL4(D_TIME) DC H'448',AL1(@CHAR,0),CL2'CV',AL4(D_CHARV) DC H'449',AL1(@CHAR,0),CL2'CV',AL4(D_CHARV) DC H'452',AL1(@CHAR,0),CL2'C ',AL4(D_CHAR) DC H'453',AL1(@CHAR,0),CL2'C ',AL4(D_CHAR) DC H'484',AL1(@NUM,0),CL2'P ',AL4(D_DEC) DC H'485',AL1(@NUM,0),CL2'P ',AL4(D_DEC) DC H'496',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'497',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'500',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'501',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'0' EOT D_DATE EQU D_CHAR D_TIME EQU D_CHAR D_CHARV EQU D_CHAR @NULL EQU X'01' @CHAR EQU 1 @NUM EQU 2 D_CHAR DS 0H character L R3,SQLDATA A(data) LH R2,SQLLEN L(data) CLC DS_CODE,=C'CV' BNER R14 LH R2,0(R3) LA R3,2(R3) BR R14 D_DEC DS 0H packed decimal L R3,SQLDATA A(data) SR R1,R1 IC R1,SQLLEN L(data), precision * R1: no. of decimal digits SRL R1,1 * R1: length code of packed field EX R1,ZAP B FMT_DEC format decimal field D_INT DS 0H binary integer L R3,SQLDATA A(data) LH R1,SQLLEN L(data) * R1: field size * create mask for icm instruction L R2,=X'0000000F' load mask SLL R2,0(R1) SRL R2,4 N R2,=X'0000000F' R2: ICM mask SR R0,R0 EX R2,ICM load binary value into R0 CVD R0,D B FMT_DEC format decimal field FMT_DEC DS 0H format decimal field * input: * : packed decimal field * R14: return address * output: * R2: L(formatted fld) * R3: A(formatted fld) MVC EDWK,EDMK LA R1,EDWK+L'EDWK-2 EDMK EDWK,D * R1: 1st significant character LA R2,EDWK_E end addr SR R2,R1 L(formatted fld) LR R3,R1 A(formatted fld) BR R14 * EX instructions ZAP ZAP D,0(0,R3) ICM ICM R0,0,0(R3) * work fields D DS PL8 WK DS CL8 EDWK DS CL17 EDWK_E EQU * EDMK DC X'40',13X'20',X'2120',C'+' edit mask DS A CHECK_SQL ST R14,CHECK_SQL-4 check SQLCODE L R15,SQLCODE LTR R15,R15 BZR R14 :SQL ok * else display code CVD R15,D MVC MSG_CODE,=X'40212020' ED MSG_CODE,D+6 TPUT MSG,MSG_L LH R0,SQLERRM TPUT SQLERRM+2,(0) display L R14,CHECK_SQL-4 BR R14 MSG DC C'SQL CODE:' MSG_CODE DS CL4 MSG_L EQU *-MSG TITLE 'DATA AREAS' A_SQLDA DS A A(allocated SQLDA) A_DBUF DS A A(data buffer) COLSIZE DC F'0' column size BUFFSIZE DC F'0' buffer size DC C' ' clear byte VNCT DC PL4'0' GENERATED NAME COUNT (MAX 9) VN DS 2CL18 variable name VL DS A variable length INDEX DC PL4'0' row index VNINDEX DS 2CL8 VLINDEX DS F SQL_CA DS CL(SQLDLEN) basic SQLCA SQL_DA DS CL16 basic SQLDA EXEC SQL INCLUDE SQLCA EXEC SQL INCLUDE SQLDA SQLVARN_SIZE EQU 44 LTORG AIRXEXCOM DS A IRX_IRXEXCOM DC CL8'IRXEXCOM' DS 0A align IRX_SHVBLOCK DC (SHVBLEN)X'0' SELECT DC H'80',CL80' ' ORG SELECT+2 SQLQUERY DS CL4096 TITLE 'DSECTS' DSECT_TYPE DSECT DS_TYPE DS HL2 DS_GEN DS AL1 generic type (numeric, character) DS AL1 filler DS_CODE DS CL2 DS_ADDR DS AL4 DS_L EQU *-DS_TYPE IRXSHVB definition of REXX SHVB END ./ ADD NAME=REXXSQL TITLE 'RETURN RESULTS OF ESQL QUERY AS REXX VARIABLES' ** * Function: The results from the specified ESQL query are returned * as REXX variables. * The variable names are those attributes * resulting from the ESQL query. * This program uses the DB2 CAF interface and so can * execute outside the DB2 environment (however, SQL * must be available). * Plan name: REXXSQL ** * Input variable: : SQL query * : DB2 subsystem id * Output variables: columnname(j).i (i = row) * <_VN>.j column names * <_VN.0> no of columns * <_NROWS> no of rows ** ** * Return code: 0 ok * otherwise error code from REXX or CAF ** ** * Register usage: * R2: work-register * R3: work-register * R4: work-register * R5: work-register * R6: * no. of columns * R7: A(SQLVARN) * R8: A(SQLDA) * R9: A(SQLCA) * R10: type pointer * R11: 2nd base register * R12: base register ** REXXSQL CSECT * initialize addressing COPY REGS STM R14,R12,12(R13) save registers BALR R12,0 base register USING *,R12,R11 LA R11,4095(R12) LA R11,1(R11) LA R15,SA A(save-area) ST R13,4(R15) backward ptr ST R15,8(R13) forward ptr LR R13,R15 A(new save-area) B SA_END jump over save-area SA DS 18A save-area SA_END DS 0H LOAD EP=IRXEXCOM load IRXEXCOM ST R0,AIRXEXCOM save EP address * obtain from the calling REXX program LA R5,IRX_SHVBLOCK USING SHVBLOCK,R5 MVI SHVCODE,SHVFETCH MVC SHVBUFL,=A(L'SQLQUERY) MVC SHVVALA,=A(SQLQUERY) MVC VN,=C'SQLQUERY ' BAL R14,GETVNL get length of ST R0,SHVNAML L() MVC SHVNAMA,=A(VN) A() L R15,AIRXEXCOM CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL LTR R15,R15 REXX return code BNZ EOP parameter error L R1,SHVVALL L(parameter) STH R1,SELECT * obtain from the calling REXX program MVI SHVCODE,SHVFETCH MVC SHVBUFL,=A(L'DB2SSID) MVC SHVVALA,=A(DB2SSID) MVC VN,=C'DB2SSID ' BAL R14,GETVNL get length of ST R0,SHVNAML L() MVC SHVNAMA,=A(VN) A() L R15,AIRXEXCOM CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL LTR R15,R15 REXX return code BNZ EOP parameter error * Preset a "bad" DB2 return code and then call CAF to initialize. MVC RC,=H'12' preset return code CALL DB2CAFI,(PLAN,DB2SSID),VL initialize CAF LTR R15,R15 CAF return code BNZ EOP * determine no of columns in table LA R9,SQL_CA USING SQLDSECT,R9 LA R8,SQL_DA USING SQLDA,R8 * dummy PREPARE EXEC SQL PREPARE S1 FROM :SELECT BAL R14,CHECK_SQL MVC SQLN,=H'0' return count only * DESCRIBE EXEC SQL DESCRIBE S1 INTO :SQL_DA BAL R14,CHECK_SQL * analyse descriptor and acquire storage * : no. of columns LH R2,SQLD MVC RC,=H'0' reset return code LTR R2,R2 BZ A500 :non-SELECT LH R3,SQLD MH R2,=AL2(SQLVARN_SIZE) LA R2,(SQLVAR-SQLDA)(R2) +L(fixed hdr) * R2: total column size ST R2,COLSIZE GETMAIN EU,LV=(2),A=A_SQLDA L R8,A_SQLDA * perform DESCRIBE with correct length STH R3,SQLD STH R3,SQLN ST R2,SQLDABC * DESCRIBE EXEC SQL DESCRIBE S1 INTO :SQLDA BAL R14,CHECK_SQL * build row buffer LH R6,SQLD no of occurrences (columns) LTR R6,R6 BZ EOP no entries LA R7,SQLVAR USING SQLVARN,R7 SR R4,R4 zeroize buffer size accumulator * output no of columns (<_VN.0>) CVD R6,D MVC WK,=X'F020202020202020' ED WK,D+4 LA R3,WK A(data) MVC VL,=A(L'WK) L(data) MVC VNINDEX,=C'.0' MVC VLINDEX,=A(2) MVC VN,=C'_VN ' * set data into RESS variable BAL R14,SETVAR A230 DS 0H * column type BAL R14,GET_TYPE * R2: data width * R3: field size * R10: DSECT_TYPE entry USING DSECT_TYPE,R10 LA R4,2(R3,R4) accumulate total buffer size AP INDEX,=P'1' increment index * convert index to form: .n MVC VNINDEX,=X'4020202020202120' LA R1,VNINDEX+7 EDMK VNINDEX,INDEX BCTR R1,0 MVI 0(R1),C'.' MVC VNINDEX,0(R1) LA R0,VNINDEX+L'VNINDEX SR R0,R1 ST R0,VLINDEX L(index) MVC VN,=C'_VN ' name prefix LA R3,SQLNAME+2 column name LH R0,SQLNAME L(column name) * TEST WHETHER NULL COLUMN NAME LH R0,SQLNAME L(COLUMN NAME) LTR R0,R0 BNZ A231 NO COLUMN NAME MVC SQLNAME+2(8),=CL8'__VN' AP VNCT,=P'1' UNPK SQLNAME+6(1),VNCT OI SQLNAME+6,C'0' LA R0,5 STH R0,SQLNAME L(COLUMN NAME) LH R0,SQLNAME L(COLUMN NAME) A231 ST R0,VL * set data into REXX variable BAL R14,SETVAR LA R7,SQLVARN_SIZE(R7) BCT R6,A230 * end of scan phase, allocate data buffer * R5: total buffer size ST R5,BUFFSIZE GETMAIN EU,LV=(5),A=A_DBUF * complete SQLDA L R5,A_DBUF PTR(data buffer) LH R6,SQLD no of occurrences (columns) LA R7,SQLVAR reinitialize pointer * column-type A240 BAL R14,GET_TYPE * R3: field size * R10: DSECT_TYPE entry ST R5,SQLIND A(indicator), if needed LA R5,2(R5) update ptr ST R5,SQLDATA A(host variable) AR R5,R3 update ptr LA R7,SQLVARN_SIZE(R7) BCT R6,A240 * retrieve records * DECLARE CURSOR EXEC SQL DECLARE CSR CURSOR FOR S1 BAL R14,CHECK_SQL * OPEN CURSOR EXEC SQL OPEN CSR BAL R14,CHECK_SQL ZAP INDEX,=P'0' initialize row index A400 DS 0H * FETCH row EXEC SQL FETCH CSR USING DESCRIPTOR :SQLDA CLC SQLCODE,=F'100' BE EOD end of data AP INDEX,=P'1' increment index * convert index to form: .n MVC VNINDEX,=X'4020202020202120' LA R1,VNINDEX+7 EDMK VNINDEX,INDEX BCTR R1,0 MVI 0(R1),C'.' MVC VNINDEX,0(R1) LA R0,VNINDEX+L'VNINDEX SR R0,R1 ST R0,VLINDEX LH R6,SQLD no of occurrences (columns) LA R7,SQLVAR reinitialize pointer * write table row A410 DS 0H USING SQLVARN,R7 * default (null) value LA R2,1 LA R3,=C'-' L R1,SQLIND A(indicator field) LH R0,0(R1) CH R0,=H'-1' BE A420 no data BAL R14,GET_TYPE * R2: data width * R3: field size * R10: DSECT_TYPE entry L R15,DS_ADDR A(routine) BALR R14,R15 * R3: A(formatted field) * R2: L(formatted field) A420 ST R2,VL LH R1,SQLNAME L(name) LA R0,L'VN MAX(L(name)) CR R1,R0 BNH *+6 LR R1,R0 truncate BCTR R1,0 LC(name) MVC VN,VN-1 MVC VN,SQLNAME+2 column name EX R1,*-6 * set data into REXX variable BAL R14,SETVAR LA R7,SQLVARN_SIZE(R7) BCT R6,A410 get next column in row B A400 get next column A500 DS 0H process non-SELECT EXEC SQL EXECUTE S1 BAL R14,CHECK_SQL EOD CALL DB2CAFT close CAF * end of processing EOP DS 0H * output no of rows processed MVC WK,=X'F020202020202020' ED WK,INDEX LA R3,WK A(data) MVC VL,=A(L'WK) L(data) MVC VLINDEX,=A(0) no index MVC VN,=C'_NROWS ' * set data into REXX variable BAL R14,SETVAR * release allocated storage L R2,COLSIZE LTR R2,R2 BZ NOCOLS L R3,A_SQLDA FREEMAIN R,LV=(2),A=(3) NOCOLS L R2,BUFFSIZE LTR R2,R2 BZ NOBUF L R3,A_DBUF FREEMAIN R,LV=(5),A=(3) NOBUF L R13,4(R13) restore A(old save-area) LH R15,RC set return code RETURN (14,12),RC=(15) RC DS H program return code PLAN DC CL8'REXXSQL' plan name TITLE 'SUBROUTINES' GETVNL DS 0H determine actual length of name * input: - name * output: R0 - L(name) * R15 - A(first blank) LA R1,L'VN SR R0,R0 counter LA R15,VN GETVNL1 CLI 0(R15),C' ' BER R14 end found AH R0,=H'1' LA R15,1(R15) BCT R1,GETVNL1 * R0: L(name), without trailing blanks BR R14 DS A SETVAR ST R14,SETVAR-4 set REXX variable * : variable name, prefix * : variable name, suffix * : length (variable name, suffix) * : L(variable data) * R3: A(variable data) BAL R14,GETVNL get L(VN) * R0: L(VN), R15: A(first blank in ) MVC 0(L'VNINDEX,R15),VNINDEX A R0,VLINDEX LA R5,IRX_SHVBLOCK USING SHVBLOCK,R5 ST R0,SHVNAML MVC SHVNAMA,=A(VN) MVI SHVCODE,SHVSTORE ST R3,SHVVALA MVC SHVVALL,VL L R15,AIRXEXCOM A(IRXEXCOM) CALL (15),(IRX_IRXEXCOM,0,0,IRX_SHVBLOCK),VL L R14,SETVAR-4 BR R14 return GET_TYPE DS 0H get column type and size(s) * input: * DSECT_SQLVARN entry * output: * R2: data width * R3: field size * DSECT_TYPE entry LA R10,T_TYPE-DS_L USING DSECT_TYPE,R10 GETTYPE1 LA R10,DS_L(R10) CLC SQLTYPE,DS_TYPE BNE GETTYPE1 * entry found, get column-length LH R2,SQLLEN LR R3,R2 preset data field size CLC DS_CODE,=CL2'P' (packed) decimal? BNE GETTYPE2 :no SR R2,R2 IC R2,SQLPRCSN precision LR R3,R2 SRL R3,1 no of digit pairs LA R3,1(R3) true data field size GETTYPE2 CLC DS_CODE,=CL2'CV' character (variable)? BNE GETTYPE3 :no LA R3,2(R3) alloc room for length GETTYPE3 BR R14 return TITLE 'CONVERSION ROUTINES' T_TYPE DS 0H alignment DC H'384',AL1(@CHAR,0),CL2'D ',AL4(D_DATE) DC H'385',AL1(@CHAR,0),CL2'D ',AL4(D_DATE) DC H'388',AL1(@CHAR,0),CL2'T ',AL4(D_TIME) DC H'389',AL1(@CHAR,0),CL2'T ',AL4(D_TIME) DC H'448',AL1(@CHAR,0),CL2'CV',AL4(D_CHARV) DC H'449',AL1(@CHAR,0),CL2'CV',AL4(D_CHARV) DC H'452',AL1(@CHAR,0),CL2'C ',AL4(D_CHAR) DC H'453',AL1(@CHAR,0),CL2'C ',AL4(D_CHAR) DC H'484',AL1(@NUM,0),CL2'P ',AL4(D_DEC) DC H'485',AL1(@NUM,0),CL2'P ',AL4(D_DEC) DC H'496',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'497',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'500',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'501',AL1(@NUM,0),CL2'I ',AL4(D_INT) DC H'0' EOT D_DATE EQU D_CHAR D_TIME EQU D_CHAR D_CHARV EQU D_CHAR @NULL EQU X'01' @CHAR EQU 1 @NUM EQU 2 D_CHAR DS 0H character L R3,SQLDATA A(data) LH R2,SQLLEN L(data) CLC DS_CODE,=C'CV' BNER R14 LH R2,0(R3) LA R3,2(R3) BR R14 D_DEC DS 0H packed decimal L R3,SQLDATA A(data) SR R1,R1 IC R1,SQLLEN L(data), precision * R1: no. of decimal digits SRL R1,1 * R1: length code of packed field EX R1,ZAP B FMT_DEC format decimal field D_INT DS 0H binary integer L R3,SQLDATA A(data) LH R1,SQLLEN L(data) * R1: field size * create mask for icm instruction L R2,=X'0000000F' load mask SLL R2,0(R1) SRL R2,4 N R2,=X'0000000F' R2: ICM mask SR R0,R0 EX R2,ICM load binary value into R0 CVD R0,D B FMT_DEC format decimal field FMT_DEC DS 0H format decimal field * input: * : packed decimal field * R14: return address * output: * R2: L(formatted fld) * R3: A(formatted fld) MVC EDWK,EDMK LA R1,EDWK+L'EDWK-2 EDMK EDWK,D * R1: 1st significant character LA R2,EDWK_E end addr SR R2,R1 L(formatted fld) LR R3,R1 A(formatted fld) BR R14 * EX instructions ZAP ZAP D,0(0,R3) ICM ICM R0,0,0(R3) * work fields D DS PL8 WK DS CL8 EDWK DS CL17 EDWK_E EQU * EDMK DC X'40',13X'20',X'2120',C'+' edit mask DS A CHECK_SQL ST R14,CHECK_SQL-4 check SQLCODE L R15,SQLCODE LTR R15,R15 BZR R14 :SQL ok * else display code CVD R15,D MVC MSG_CODE,=X'40212020' ED MSG_CODE,D+6 TPUT MSG,MSG_L LH R0,SQLERRM TPUT SQLERRM+2,(0) display L R14,CHECK_SQL-4 BR R14 MSG DC C'SQL CODE:' MSG_CODE DS CL4 MSG_L EQU *-MSG TITLE 'DATA AREAS' A_SQLDA DS A A(allocated SQLDA) A_DBUF DS A A(data buffer) COLSIZE DC F'0' column size BUFFSIZE DC F'0' buffer size DC C' ' clear byte VNCT DC PL4'0' GENERATED NAME COUNT (MAX 9) VN DS 2CL18 variable name VL DS A variable length INDEX DC PL4'0' row index VNINDEX DS 2CL8 VLINDEX DS F SQL_CA DS CL(SQLDLEN) basic SQLCA SQL_DA DS CL16 basic SQLDA EXEC SQL INCLUDE SQLCA EXEC SQL INCLUDE SQLDA SQLVARN_SIZE EQU 44 LTORG AIRXEXCOM DS A IRX_IRXEXCOM DC CL8'IRXEXCOM' DS 0A align IRX_SHVBLOCK DC (SHVBLEN)X'0' SELECT DC H'80',CL80' ' ORG SELECT+2 SQLQUERY DS CL4096 DB2SSID DS CL8 TITLE 'DSECTS' DSECT_TYPE DSECT DS_TYPE DS HL2 DS_GEN DS AL1 generic type (numeric, character) DS AL1 filler DS_CODE DS CL2 DS_ADDR DS AL4 DS_L EQU *-DS_TYPE IRXSHVB definition of REXX SHVB END ./ ADD NAME=RXDB2V23 000100 Identification Division. 000200 Program-Id. 000300 RXDB2V23. 000400 Author. 000500 Dave Boll. 000600 Date-Written. 000700 09/10/90. 000800*** 000900* 001000* Program to service Rexx DB2 calls. 001100* 001200* The SQL statement is PREPAREd and DESCRIBEd. If it is valid, 001300* the statement is then executed. 001400* 001500* For any non-Select statement, the SQLCA is "returned" to the 001600* calling Exec. 001700* 001800* For any Select statement, the SQLCA, the SQLDA and the 001900* populated stem are "returned" to the calling Exec. 002000* 002100*** 002200/ 002300 Environment Division. 002400 Configuration Section. 002500 Special-Names. 002600 Class Decimal-Digits Is '+-0123456789.' 002700 Class Integer-Digits Is '+-0123456789'. 002800/ 002900 Data Division. 003000 003100 Working-Storage Section. 003200 003300 01 IF-Function Pic x(8). 003400 88 IF-Command Value 'COMMAND'. 003500 88 IF-ReadA Value 'READA'. 003600 88 IF-ReadS Value 'READS'. 003700 88 IF-Write Value 'WRITE'. 003800 003900 01 IF-Communication-Area. 004000 05 IFCA-Len Pic s9(4) Comp. 004100 05 Filler Pic x(2). 004200 05 IFCA-Id Pic x(4). 004300 05 IFCA-Owner Pic x(4). 004400 05 IFCA-Return-Code Pic s9(9) Comp. 004500 05 IFCA-Reason-Code Pic s9(9) Comp. 004600 05 IFCA-Bytes-Moved Pic s9(9) Comp. 004700 05 IFCA-Bytes-Not-Moved Pic s9(9) Comp. 004800 05 IFCA-PWS Pic s9(9) Comp. 004900 05 IFCA-Records-Lost-ReadA Pic s9(9) Comp. 005000 05 IFCA-OP-Dest-Name Pic x(4). 005100 05 IFCA-OP-Dest-Ret-Len Pic s9(4) Comp Value Zero. 005200 05 Filler Pic s9(4) Comp. 005300 05 IFCA-OP-Dest-Ret Pic x(32). 005400 05 IFCA-Trace-Num-Len Pic s9(4) Comp Value Zero. 005500 05 Filler Pic s9(4) Comp. 005600 05 IFCA-Trace-Num Pic x(16). 005700 05 IFCA-Diagnostic-Len Pic s9(4) Comp Value Zero. 005800 05 Filler Pic s9(4) Comp. 005900 05 IFCA-Diagnostic-Txt Pic x(80). 006000 006100 01 IF-Return-Area. 006200 05 IFRA-Len Pic s9(9) Comp Value +32769. 006300 05 IFRA-Txt Pic x(32765). 006400 006500 01 IF-CID-Area. 006600 05 IF-CID-Len Pic s9(4) Comp. 006700 05 Filler Pic s9(4) Comp. 006800 05 IF-CID-List Pic x(20). 006900 007000 01 IF-Qualification-Area. 007100 05 IFQA-Len Pic s9(4) Comp. 007200 05 Filler Pic s9(4) Comp. 007300 05 IFQA-Lit Pic x(4). 007400 05 IFQA-Thread-Id Pointer. 007500 05 IFQA-WQALAIT2 Pointer. 007600 05 IFQA-Plan-Name Pic x(8). 007700 05 IFQA-Prim-Authid Pic x(8). 007800 05 IFQA-Orig-Authid Pic x(8). 007900 05 IFQA-Conn-Name Pic x(8). 008000 05 IFQA-Corr-Id Pic x(12). 008100 05 IFQA-Res-Token Pic x(12). 008200 05 IFQA-Res-Hash Pic x(4). 008300 05 IFQA-Asid Pic x(2). 008400 05 Filler Pic x(2). 008500 05 IFQA-Luwid Pic x(24). 008600 05 IFQA-Loc-Name Pic x(16). 008700 05 IFQA-Log-Acc-Type Pic x(3). 008800 05 IFQA-Log-Acc-Mode Pic x(1). 008900 05 IFQA-Log-Start-Rba Pic x(8). 009000 05 IFQA-Log-Num-Ci Pic X(2). 009100 009200 01 IF-Output-Area. 009300 05 IFOA-Len Pic s9(4) Comp Value +4096. 009400 05 Filler Pic s9(4) Comp. 009500 05 IFOA-Buf Pic x(4092). 009600 009700 01 IF-Buffer-Info. 009800 05 IFBUFI-Len Pic s9(4) Comp Value Zero. 009900 05 Filler Pic s9(4) Comp. 010000 05 Filler Pic x(4) Value 'WBUF'. 010100 05 IFBUFI-ECB-Addr Pointer. 010200 05 IFBUFI-Rec-Thresh Pic s9(9) Comp. 010300 010400 01 External-Function-Arguments. 010500 05 Arg-DB-Names Pic x(21). 010600 05 Arg-DB2-SysId Pic x(4). 010700 88 Reuse-Attach Value Spaces. 010800 05 SQL-Statement. 010900 49 SQL-Stmt-Len Pic s9(4) Comp-4. 011000 49 SQL-Stmt-Txt Pic x(32765) Value Spaces. 011100 05 Stem-Variable. 011200 10 Stem-Var-Len Pic s9(4) Comp. 011300 10 Stem-Var-Name Pic x(250). 011400 05 Arg-SQL-Stmt-Stem. 011500 10 Arg-SQL-Stem-Var-Len Pic s9(4) Comp. 011600 10 Arg-SQL-Stem-Var-Txt Pic x(250). 011700 10 Stmt-Stem-Work-Buf Pic x(250). 011800 05 Arg-Parm-Marker-RexxVars. 011900 10 Arg-PMRV-Value-Len Pic s9(9) Binary. 012000 10 Arg-PMRV-Value-Beg-Pos Pic s9(9) Binary. 012100 10 Arg-PMRV-Value-Sign Pic x(1). 012200 88 Arg-PMRV-Value-Sign-Neg Value '-'. 012300 88 Arg-PMRV-Value-Sign-Pos Value '+'. 012400 88 Arg-PMRV-Value-Sign-None Value ' '. 012500 10 Arg-PMRV-Data-Type Pic x(11). 012600 88 Arg-PMRV-Type-Undefined Value '?'. 012700 88 Arg-PMRV-Type-Date Values 'DATE' 012800 '384' '385'. 012900 88 Arg-PMRV-Type-Time Values 'TIME' 013000 '388' '389'. 013100 88 Arg-PMRV-Type-TimeStamp Values 'TIMESTAMP' 013200 '392' '393'. 013300 88 Arg-PMRV-Type-Char Values 'CHAR' 013400 '452' '453'. 013500 88 Arg-PMRV-Type-VarChar Values 'VARCHAR' 013600 '448' '449'. 013700 88 Arg-PMRV-Type-LongVarChar Values 'LONGVARCHAR' 013800 '456' '457'. 013900 88 Arg-PMRV-Type-SmallInt Values 'SMALLINT' 014000 '500' '501'. 014100 88 Arg-PMRV-Type-Integer Values 'INTEGER' 014200 '496' '497'. 014300 88 Arg-PMRV-Type-Decimal Values 'DECIMAL' 014400 '484' '485'. 014500 88 Arg-PMRV-Type-Float Values 'FLOAT' 014600 '480' '481'. 014700 88 Arg-PMRV-Type-Graphic Values 'GRAPHIC' 014800 '468' '469'. 014900 88 Arg-PMRV-Type-VarGraphic Values 'VARGRAPHIC' 015000 '464' '465'. 015100 88 Arg-PMRV-Type-Valid Values 'DATE' 015200 'TIME' 015300 'TIMESTAMP' 015400 'CHAR' 015500 'VARCHAR' 015600 'LONGVARCHAR' 015700 'SMALLINT' 015800 'INTEGER' 015900 'DECIMAL' 016000 'FLOAT' 016100 'GRAPHIC' 016200 'VARGRAPHIC' 016300 '384' '385' 016400 '388' '389' 016500 '392' '393' 016600 '452' '453' 016700 '456' '457' 016800 '448' '449' 016900 '500' '501' 017000 '496' '497' 017100 '484' '485' 017200 '480' '481' 017300 '468' '469' 017400 '464' '465'. 017500 10 Arg-PMRV-Stem-Var Pic x(250). 017600 10 Arg-PMRV-Ptr Pointer. 017700 10 Arg-PMRV-Ptr-Num 017800 Redefines 017900 Arg-PMRV-Ptr Pic s9(9) Comp. 018000 10 Arg-PMRV-Offset Pic s9(9) Comp. 018100 10 Arg-PMRV-Int Pic s9(18). 018200 10 Arg-PMRV-Int-R Redefines 018300 Arg-PMRV-Int Pic x(18) Just Right. 018400 10 Arg-PMRV-Smint Pic s9(5). 018500 10 Arg-PMRV-Smint-R Redefines 018600 Arg-PMRV-Smint Pic x(5) Just Right. 018700 10 Arg-PMRV-Var-Ctr Pic s9(4) Comp. 018800 10 Arg-PMRV-Var-Buf-Len Pic s9(4) Comp. 018900 10 Arg-PMRV-Var-Buf Pic x(5000). 019000 10 Arg-PMRV-Var-Pos Pic s9(4) Comp. 019100 10 Arg-PMRV-Var-Len Pic s9(4) Comp. 019200 10 Arg-PMRV-Var-Name Pic x(250). 019300 10 Arg-PMRV-Value-Buf Pic x(32765). 019400 019500 01 Misc-Work-Fields. 019600 019700*--- Convert decimal number display to Comp-3. 019800 05 Dec-Num-Alt Pic s9(4) Comp. 019900 05 Dec-Num-Ctr Pic s9(4) Comp. 020000 05 Dec-Num-Sign Pic s9(4) Comp. 020100 05 Dec-Num-Disp-N Pic s9(18). 020200 05 Dec-Num-Disp-A Redefines 020300 Dec-Num-Disp-N Pic x(18) Just Right. 020400 05 Dec-Num-Packed Pic s9(18) Comp-3. 020500 05 Dec-Num-Packed-A Redefines 020600 Dec-Num-Packed Pic x(10). 020700 05 Dec-Num-Prec Pic s9(4) Comp. 020800 05 Dec-Num-Prec-A Redefines 020900 Dec-Num-Prec Pic x(2). 021000 05 Dec-Num-Scale Pic s9(4) Comp. 021100 05 Dec-Num-Scale-A Redefines 021200 Dec-Num-Scale Pic x(2). 021300 05 Dec-Num-Prec-Fld. 021400 10 Filler Pic x(1) Value x'00'. 021500 10 Dec-Num-Prec-1 Pic x(1). 021600 05 Dec-Num-Scale-Fld. 021700 10 Filler Pic x(1) Value x'00'. 021800 10 Dec-Num-Scale-1 Pic x(1). 021900 022000*--- Other stuff 022100 05 Tally2 Pic s9(9) Binary. 022200 05 Tally3 Pic s9(9) Binary. 022300 05 Map-Type Pic x(2). 022400 05 Buf-Start Pic s9(4) Comp. 022500 05 Num-Rexx-Args Pic s9(4) Comp. 022600 05 RxDB2-Trace-Flag Pic x(1). 022700 88 RxDB2-Trace-On Values 'T' 't'. 022800 05 C2X-Return-Buf Pic x(500). 022900 05 Fetch-Limit-A Pic x(9). 023000 05 Fetch-Limit-R Pic x(9) Just Right. 023100 05 Fetch-Limit-N Redefines 023200 Fetch-Limit-R Pic 9(9). 023300 05 Fetch-Limit-C Pic s9(9) Comp. 023400 05 Stmt-Start Pic s9(4) Comp Value +5. 023500 05 DB2-Cmd-Rslt-Offset Pic s9(4) Comp Value +5. 023600 05 Adjusted-Pos Pic s9(4) Comp. 023700 05 Buf-Rec-Len Pic s9(4) Comp. 023800 05 Buf-Rec-Len-A Redefines 023900 Buf-Rec-Len Pic x(2). 024000 05 SQL-Err-Msg-Tally Pic s9(4) Comp. 024100 05 SQL-Err-Msg-Lrecl Pic s9(9) Comp Value +79. 024200 05 SQL-Err-Msg. 024300 10 SQL-Err-Msg-Len Pic s9(4) Comp. 024400 10 SQL-Err-Msg-Txt Pic x(1580). 024500 05 Dsntiar Pic x(8) Value 'DSNTIAR'. 024600 05 DsnAli Pic x(8) Value 'DSNALI'. 024700 05 DsnWli Pic x(8) Value 'DSNWLI'. 024800 05 Just-Right-Field Pic x(15) Just Right. 024900 05 Ws-Stmt-Len-A Pic x(2). 025000 05 Ws-Stmt-Len Redefines 025100 Ws-Stmt-Len-A Pic s9(4) Comp. 025200 05 Statement-Counter Pic 9(9) Comp. 025300 05 Statement-Counter-A Pic x(10). 025400 05 Statement-Counter-A-Len Pic s9(9) Comp. 025500 05 Stem-Map-Order-Swc Pic x(1). 025600 88 Map-Col-Row Value '1'. 025700 88 Map-Row-Col Value '0'. 025800 05 Attach-Extant-Swc Pic x(1). 025900 88 Attach-Extant Value '1'. 026000 88 Attach-NOT-Extant Value '0'. 026100 05 Initial-Remote-Connect-Swc Pic x(1). 026200 88 Do-Init-Remote-Connect Value '1'. 026300 88 NOT-Do-Init-Rem-Connect Value '0'. 026400 05 Plan-Opened-Swc Pic x(1). 026500 88 Plan-Has-Been-Opened Value 'O'. 026600 88 Plan-Is-Closed Value 'N'. 026700 05 Flagged-For-Term-Swc Pic x(1). 026800 88 Flagged-For-Termination Value 'T'. 026900 88 Not-Flagged-For-Term Value 'N'. 027000 05 Result-Stem-Dropped-Swc Pic x(1). 027100 88 Result-Stem-Dropped Value 'D'. 027200 88 Result-Stem-Not-Dropped Value 'N'. 027300 05 Number-Of-Statements-Swc Pic x(1). 027400 88 Single-SQL-Statement Value 'S'. 027500 88 Multiple-SQL-Statements Value 'M'. 027600 05 Test-For-Keyword-Command Pic x(10). 027700 88 Stem-Supplied Value 'STEM'. 027800 88 Attach-Requested Value 'ATTACH'. 027900 88 Detach-Requested Value 'DETACH'. 028000 88 Read-Sync-Supplied Value '-READS'. 028100 88 Read-ASync-Supplied Value '-READA'. 028200 05 Filler Redefines 028300 Test-For-Keyword-Command. 028400 10 Filler Pic x(1). 028500 88 DB2-Command-Supplied Value '-'. 028600 10 Filler Pic x(9). 028700 05 Test-For-Statement-Type Pic x(10). 028800 88 Describe-SQL-Stmt Value 'DESCRIBE'. 028900 88 Connect-SQL-Stmt Value 'CONNECT'. 029000 88 Set-SQL-Stmt Value 'SET'. 029100 88 Get-SQL-Stmt Value 'GET'. 029200 88 Normal-SQL-Stmt Value Spaces. 029300 05 Special-Stmt-Word-2 Pic x(10). 029400 88 SS-Word-2-Space Value Spaces. 029500 88 SS-Word-2-To Value 'TO'. 029600 88 SS-Word-2-Reset Value 'RESET'. 029700 88 SS-Word-2-Current Value 'CURRENT'. 029800 88 SS-Word-2-Table Value 'TABLE'. 029900 88 SS-Word-2-User Value 'USER'. 030000 05 Special-Stmt-Word-3 Pic x(250). 030100 88 SS-Word-3-PackageSet Value 'PACKAGESET'. 030200 88 SS-Word-3-TimeZone Value 'TIMEZONE'. 030300 88 SS-Word-3-Date Value 'DATE'. 030400 88 SS-Word-3-Time Value 'TIME'. 030500 88 SS-Word-3-TimeStamp Value 'TIMESTAMP'. 030600 88 SS-Word-3-SqlId Value 'SQLID'. 030700 88 SS-Word-3-Server Value 'SERVER'. 030800 05 Remote-Location-Name Pic x(16). 030900 05 Current-PackageSet-Name Pic x(18). 031000 05 Current-TimeZone-Value Pic s9(6)v Comp-3. 031100 05 Dummy-Unstring-Bin Pic x(1). 031200 88 Dummy-Equal-Sign Value '='. 031300 05 C2D-By-2-Group. 031400 10 Filler Pic x(1) Value x'00'. 031500 10 C2D-By-2-Char Pic x(1). 031600 05 C2D-Number Redefines 031700 C2D-By-2-Group Pic s9(4) Comp. 031800 05 Num-Disp-15 Pic --------------9. 031900 05 IRXEXCOM-Ret-Code-Swc Pic x(1). 032000 88 IRXEXCOM-Req-Block-Failed Value '0'. 032100 88 IRXEXCOM-Req-Block-OK Value '1'. 032200 05 Upper-Case-Chars Pic x(26) Value 032300 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'. 032400 05 Lower-Case-Chars Pic x(26) Value 032500 'abcdefghijklmnopqrstuvwxyz'. 032600 032700 05 CAF-Hold-Rc Pic s9(9) Comp. 032800 05 CAF-Tecb Pic s9(9) Comp Value Zero. 032900 05 CAF-Secb Pic s9(9) Comp Value Zero. 033000 05 CAF-RibPtr Pointer. 033100 05 CAF-Rc Pic s9(9) Comp. 033200 05 CAF-Reason-Code Pic x(4). 033300 88 CAF-DB2-Sys-Not-Active Values 033400 x'00F30002' x'00F30006' x'00F30012' 033500 x'00F30056' x'00F30011'. 033600 88 CAF-DB2-Rlse-Lvl-MisMatch Values 033700 x'00C10823'. 033800 88 CAF-Ready Values 033900 x'00C10824'. 034000 88 CAF-Plan-Not-Authorized Values 034100 x'00F30034'. 034200 88 CAF-Plan-Unavailable Values 034300 x'00F30040'. 034400 05 CAF-DB2-SysId Pic x(4). 034500 05 CAF-Plan-Name Pic x(8). 034600 05 CAF-Terminate-Opt Pic x(4). 034700 88 CAF-Abrt-TermOpt Value 'ABRT'. 034800 88 CAF-Sync-TermOpt Value 'SYNC'. 034900 05 CAF-Function Pic x(12). 035000 88 CAF-Connect Value 'CONNECT'. 035100 88 CAF-Open-Plan Value 'OPEN'. 035200 88 CAF-Close-Plan Value 'CLOSE'. 035300 88 CAF-Disconnect Value 'DISCONNECT'. 035400 88 CAF-Translate Value 'TRANSLATE'. 035500 035600 05 Display-IFCA. 035700 10 Disp-IFCA-Rtc Pic x(25). 035800 10 Disp-IFCA-Rsc Pic x(8). 035900 10 Disp-IFCA-Bm Pic x(25). 036000 10 Disp-IFCA-Bnm Pic x(25). 036100 10 Disp-IFCA-Rl Pic x(25). 036200 05 Display-IFCA-Lengths. 036300 10 Disp-IFCA-Rtc-Len Pic s9(4) Comp. 036400 10 Disp-IFCA-Rsc-Len Pic s9(4) Comp. 036500 10 Disp-IFCA-Bm-Len Pic s9(4) Comp. 036600 10 Disp-IFCA-Bnm-Len Pic s9(4) Comp. 036700 10 Disp-IFCA-Rl-Len Pic s9(4) Comp. 036800 036900 05 Display-SQLCA. 037000 10 Disp-SQLCABC Pic x(25). 037100 10 Disp-SQLCODE Pic x(25). 037200 10 Disp-SQLERRD Occurs 6 Times 037300 Pic x(25). 037400 05 Display-SQLCA-Lengths. 037500 10 Disp-SQLCABC-Len Pic s9(4) Comp. 037600 10 Disp-SQLCODE-Len Pic s9(4) Comp. 037700 10 Disp-SQLERRD-Len Occurs 6 Times 037800 Pic s9(4) Comp. 037900 05 Display-SQLDA. 038000 10 Disp-SQLDABC Pic x(25). 038100 10 Disp-SQLN Pic x(5). 038200 10 Disp-SQLD Pic x(5). 038300 10 Disp-SQLVAR Occurs 750 Times. 038400 15 Disp-SQLTYPE Pic x(5). 038500 15 Disp-SQLLEN Pic x(5). 038600 05 Display-SQLDA-Lengths. 038700 10 Disp-SQLDABC-Len Pic s9(4) Comp. 038800 10 Disp-SQLN-Len Pic s9(4) Comp. 038900 10 Disp-SQLD-Len Pic s9(4) Comp. 039000 10 Disp-SQLVAR-Len Occurs 750 Times. 039100 15 Disp-SQLTYPE-Len Pic s9(4) Comp. 039200 15 Disp-SQLLEN-Len Pic s9(4) Comp. 039300 05 DLWA-Precision-A. 039400 10 Filler Pic x(1) Value Low-Values. 039500 10 DLWA-Prec-A Pic x(1). 039600 05 DLWA-Precision 039700 Redefines 039800 DLWA-Precision-A Pic s9(4) Comp. 039900 05 DLWA-Scale-A. 040000 10 Filler Pic x(1) Value Low-Values. 040100 10 DLWA-Scal-A Pic x(1). 040200 05 DLWA-Scale 040300 Redefines 040400 DLWA-Scale-A Pic s9(4) Comp. 040500 05 Dec-Part Pic x(15). 040600 05 Col-Ptr Pointer. 040700 05 Col-Ptr-Num 040800 Redefines 040900 Col-Ptr Pic s9(9) Comp. 041000 05 VarLenCol-Len Pic s9(4) Comp. 041100 05 VarLenCol-Len-A 041200 Redefines 041300 VarLenCol-Len Pic x(2). 041400 05 Stem-Dot-Zero-Var Pic x(250). 041500 05 Stem-Dot-Zero-Val Pic x(25). 041600 05 Stem-Row-Col-Var Occurs 750 Times 041700 Pic x(250). 041800 05 Num-Disp Pic --------9. 041900 05 Num-Disp-With-Zero Pic -999999. 042000 05 Row-Counter Pic 9(9) Comp. 042100 05 Stem-Index-N Pic 9(10). 042200 05 Stem-Index-A Pic x(10). 042300 05 Row-Index Pic x(10). 042400 05 Col-Index Pic x(10). 042500 05 IRXEXCOM Pic x(8) Value 'IRXEXCOM'. 042600 05 NullCheck Pic 9(1). 042700 88 Nullable Value 1. 042800 05 Char-Ctr Pic 9(9) Comp. 042900 05 Col-Ctr Pic 9(9) Comp. 043000 05 Blk-Ctr Pic 9(9) Comp. 043100 05 Block-Number Pic 9(9) Comp. 043200 05 ShvBlock-Ctr Pic 9(9) Comp. 043300 05 Column-Length Pic s9(4) Comp. 043400 05 Value-Len Pic s9(4) Comp. 043500 05 Value-Len-A 043600 Redefines 043700 Value-Len Pic x(2). 043800 05 Number-Sizing. 043900 10 Num-Pic-1 Pic 9(1). 044000 10 Num-Pic-1-A 044100 Redefines 044200 Num-Pic-1 Pic x(1). 044300 10 Num-Pic-2 Pic 9(2). 044400 10 Num-Pic-2-A 044500 Redefines 044600 Num-Pic-2 Pic x(2). 044700 10 Num-Pic-3 Pic 9(3). 044800 10 Num-Pic-3-A 044900 Redefines 045000 Num-Pic-3 Pic x(3). 045100 10 Num-Pic-4 Pic 9(4). 045200 10 Num-Pic-4-A 045300 Redefines 045400 Num-Pic-4 Pic x(4). 045500 10 Num-Pic-5 Pic 9(5). 045600 10 Num-Pic-5-A 045700 Redefines 045800 Num-Pic-5 Pic x(5). 045900 10 Num-Pic-6 Pic 9(6). 046000 10 Num-Pic-6-A 046100 Redefines 046200 Num-Pic-6 Pic x(6). 046300 10 Num-Pic-7 Pic 9(7). 046400 10 Num-Pic-7-A 046500 Redefines 046600 Num-Pic-7 Pic x(7). 046700 10 Num-Pic-8 Pic 9(8). 046800 10 Num-Pic-8-A 046900 Redefines 047000 Num-Pic-8 Pic x(8). 047100 10 Num-Pic-9 Pic 9(9). 047200 10 Num-Pic-9-A 047300 Redefines 047400 Num-Pic-9 Pic x(9). 047500 05 Decimal-Sizing. 047600 10 Dec-Pic-1 Pic s9(1) Comp-3. 047700 10 Dec-Pic-1-A 047800 Redefines 047900 Dec-Pic-1 Pic x(1). 048000 10 Dec-Pic-2 Pic s9(2) Comp-3. 048100 10 Dec-Pic-2-A 048200 Redefines 048300 Dec-Pic-2 Pic x(2). 048400 10 Dec-Pic-3 Pic s9(3) Comp-3. 048500 10 Dec-Pic-3-A 048600 Redefines 048700 Dec-Pic-3 Pic x(2). 048800 10 Dec-Pic-4 Pic s9(4) Comp-3. 048900 10 Dec-Pic-4-A 049000 Redefines 049100 Dec-Pic-4 Pic x(3). 049200 10 Dec-Pic-5 Pic s9(5) Comp-3. 049300 10 Dec-Pic-5-A 049400 Redefines 049500 Dec-Pic-5 Pic x(3). 049600 10 Dec-Pic-6 Pic s9(6) Comp-3. 049700 10 Dec-Pic-6-A 049800 Redefines 049900 Dec-Pic-6 Pic x(4). 050000 10 Dec-Pic-7 Pic s9(7) Comp-3. 050100 10 Dec-Pic-7-A 050200 Redefines 050300 Dec-Pic-7 Pic x(4). 050400 10 Dec-Pic-8 Pic s9(8) Comp-3. 050500 10 Dec-Pic-8-A 050600 Redefines 050700 Dec-Pic-8 Pic x(5). 050800 10 Dec-Pic-9 Pic s9(9) Comp-3. 050900 10 Dec-Pic-9-A 051000 Redefines 051100 Dec-Pic-9 Pic x(5). 051200 10 Dec-Pic-10 Pic s9(10) Comp-3. 051300 10 Dec-Pic-10-A 051400 Redefines 051500 Dec-Pic-10 Pic x(6). 051600 10 Dec-Pic-11 Pic s9(11) Comp-3. 051700 10 Dec-Pic-11-A 051800 Redefines 051900 Dec-Pic-11 Pic x(6). 052000 10 Dec-Pic-12 Pic s9(12) Comp-3. 052100 10 Dec-Pic-12-A 052200 Redefines 052300 Dec-Pic-12 Pic x(7). 052400 10 Dec-Pic-13 Pic s9(13) Comp-3. 052500 10 Dec-Pic-13-A 052600 Redefines 052700 Dec-Pic-13 Pic x(7). 052800 10 Dec-Pic-14 Pic s9(14) Comp-3. 052900 10 Dec-Pic-14-A 053000 Redefines 053100 Dec-Pic-14 Pic x(8). 053200 10 Dec-Pic-15 Pic s9(15) Comp-3. 053300 10 Dec-Pic-15-A 053400 Redefines 053500 Dec-Pic-15 Pic x(8). 053600 05 RXSQLDA-SQLNULL-Value Occurs 750 Times 053700 Pic x(1). 053800 05 Data-Format-Conversion-Fields. 053900 10 Prec-Work-Field Pic x(2). 054000 10 Scale-Work-Field Pic x(2). 054100 10 DFC-Dec-Work-Field Pic x(25). 054200 10 DFC-Dec-Sign Pic x(1). 054300 10 DFC-Work-Field Pic x(25) Just Right. 054400 10 DFC-Result-Field Occurs 750 Times 054500 Pic x(25). 054600 10 DFC-Dec-Work-A Pic x(15). 054700 10 DFC-Dec-Work-R 054800 Redefines 054900 DFC-Dec-Work-A. 055000 15 Filler Pic x(7). 055100 15 DFC-Dec-Work-Packed-Num Pic s9(15) Comp-3. 055200 10 DFC-Dec-Work-Disp Pic +999999999999999. 055300 10 DFC-Integer-A Pic x(4). 055400 10 DFC-Integer-Num 055500 Redefines 055600 DFC-Integer-A Pic s9(9) Comp. 055700 10 DFC-Integer-A-10 Pic x(8). 055800 10 DFC-Integer-Num-10 055900 Redefines 056000 DFC-Integer-A-10 Pic s9(18) Comp. 056100 10 DFC-Integer-Disp Pic ------------------9. 056200 10 DFC-Smallint-A Pic x(2). 056300 10 DFC-Smallint-Num 056400 Redefines 056500 DFC-Smallint-A Pic s9(4) Comp. 056600 10 DFC-Smallint-A-5 Pic x(4). 056700 10 DFC-Smallint-Num-5 056800 Redefines 056900 DFC-Smallint-A-5 Pic s9(5) Comp. 057000 10 DFC-Smallint-Disp Pic -----9. 057100 10 DFC-Float-S-A Pic x(4). 057200 10 DFC-Float-S-Num 057300 Redefines 057400 DFC-Float-S-A Usage Is Comp-1. 057500 10 DFC-Float-D-A Pic x(8). 057600 10 DFC-Float-D-Num 057700 Redefines 057800 DFC-Float-D-A Usage Is Comp-2. 057900 10 DFC-Float-Disp Pic +9.9(15)E+99. 058000 058100 01 RXDB2-Variable-Names. 058200 05 RXDB2-Stem Pic x(06) 058300 Value 'RXDB2.'. 058400 05 RXDB2-CAF-Reason-Code Pic x(21) 058500 Value 'RXDB2.CAF_REASON_CODE'. 058600 05 RXDB2-SQLCAVARS Pic x(15) 058700 Value 'RXDB2.SQLCAVARS'. 058800 05 RXDB2-SQLDAVARS Pic x(15) 058900 Value 'RXDB2.SQLDAVARS'. 059000 05 RXDB2-IFCAVARS Pic x(14) 059100 Value 'RXDB2.IFCAVARS'. 059200 05 RXDB2-IFQAVARS Pic x(14) 059300 Value 'RXDB2.IFQAVARS'. 059400 05 RXDB2-SQLSYSID Pic x(14) 059500 Value 'RXDB2.SQLSYSID'. 059600 05 RXDB2-SQLSERVER Pic x(15) 059700 Value 'RXDB2.SQLSERVER'. 059800 05 RXDB2-DB2VER Pic x(12) 059900 Value 'RXDB2.DB2VER'. 060000 05 RXDB2-SQLSTMT Pic x(13) 060100 Value 'RXDB2.SQLSTMT'. 060200 05 RXDB2-SQLSNO Pic x(12) 060300 Value 'RXDB2.SQLSNO'. 060400 05 RXDB2-SQLSTEM Pic x(13) 060500 Value 'RXDB2.SQLSTEM'. 060600 05 RXDB2-MAPSTEM Pic x(13) 060700 Value 'RXDB2.MAPSTEM'. 060800 05 RXDB2-NOWHERE Pic x(13) 060900 Value 'RXDB2.NOWHERE'. 061000 05 RXDB2-TRACE Pic x(11) 061100 Value 'RXDB2.TRACE'. 061200 061300 01 RXDB2-Variable-Values. 061400 05 RXDB2-SQLCAVARS-Value. 061500 10 Filler Pic x(41) Value 061600 'SQLCA.SQLCAID SQLCA.SQLCABC SQLCA.SQLCODE'. 061700 10 Filler Pic x(28) Value 061800 ' SQLCA.SQLERRM SQLCA.SQLERRP'. 061900 10 Filler Pic x(48) Value 062000 ' SQLCA.SQLERRD.1 SQLCA.SQLERRD.2 SQLCA.SQLERRD.3'. 062100 10 Filler Pic x(48) Value 062200 ' SQLCA.SQLERRD.4 SQLCA.SQLERRD.5 SQLCA.SQLERRD.6'. 062300 10 Filler Pic x(48) Value 062400 ' SQLCA.SQLWARN.0 SQLCA.SQLWARN.1 SQLCA.SQLWARN.2'. 062500 10 Filler Pic x(48) Value 062600 ' SQLCA.SQLWARN.3 SQLCA.SQLWARN.4 SQLCA.SQLWARN.5'. 062700 10 Filler Pic x(48) Value 062800 ' SQLCA.SQLWARN.6 SQLCA.SQLWARN.7 SQLCA.SQLWARN.8'. 062900 10 Filler Pic x(32) Value 063000 ' SQLCA.SQLWARN.9 SQLCA.SQLWARN.A'. 063100 10 Filler Pic x(28) Value 063200 ' SQLCA.SQLSTATE SQLCA.SQLMSG'. 063300 05 RXDB2-SQLDAVARS-Value. 063400 10 Filler Pic x(50) Value 063500 'SQLDA.SQLDAID SQLDA.SQLDABC SQLDA.SQLN SQLDA.SQLD '. 063600 10 Filler Pic x(43) Value 063700 'SQLDA.SQLTYPE.1-#cols SQLDA.SQLLEN.1-#cols '. 063800 10 Filler Pic x(43) Value 063900 'SQLDA.SQLNULL.1-#cols SQLDA.SQLNAME.1-#cols'. 064000 05 RXDB2-IFCAVARS-Value. 064100 10 Filler Pic x(44) Value 064200 'IFCA.RETURN_CODE IFCA.REASON_CODE IFCA.OWNER'. 064300 10 Filler Pic x(38) Value 064400 ' IFCA.BYTES_MOVED IFCA.BYTES_NOT_MOVED'. 064500 10 Filler Pic x(41) Value 064600 ' IFCA.RECORDS_LOST_READA IFCA.DIAGNOSTICS'. 064700 10 Filler Pic x(35) Value 064800 ' IFCA.OP_DEST_NAME IFCA.OP_DEST_RET'. 064900 05 RXDB2-IFQAVARS-Value. 065000 10 Filler Pic x(46) Value 065100 'IFQA.THREAD_ID IFQA.PLAN_NAME IFQA.PRIM_AUTHID'. 065200 10 Filler Pic x(45) Value 065300 ' IFQA.ORIG_AUTHID IFQA.CONN_NAME IFQA.CORR_ID'. 065400 10 Filler Pic x(39) Value 065500 ' IFQA.RES_TOKEN IFQA.RES_HASH IFQA.ASID'. 065600 10 Filler Pic x(43) Value 065700 ' IFQA.LUWID IFQA.LOC_NAME IFQA.LOG_ACC_TYPE'. 065800 10 Filler Pic x(37) Value 065900 ' IFQA.LOG_ACC_MODE IFQA.LOG_START_RBA'. 066000 10 Filler Pic x(43) Value 066100 ' IFQA.LOG_NUM_CI IFQA.CID_LIST IFQA.OP_DEST'. 066200 066300 01 Rexx-SQLCA-Variable-Names. 066400 05 Rxsqlca-Stem Pic X(06) 066500 Value 'SQLCA.'. 066600 05 Rxsqlca-Sqlcaid Pic X(13) 066700 Value 'SQLCA.SQLCAID'. 066800 05 Rxsqlca-Sqlcabc Pic X(13) 066900 Value 'SQLCA.SQLCABC'. 067000 05 Rxsqlca-Sqlcode Pic X(13) 067100 Value 'SQLCA.SQLCODE'. 067200 05 Rxsqlca-Sqlerrm Pic X(13) 067300 Value 'SQLCA.SQLERRM'. 067400 05 Rxsqlca-Sqlerrp Pic X(13) 067500 Value 'SQLCA.SQLERRP'. 067600 05 Rxsqlca-Sqlerrd-1 Pic X(15) 067700 Value 'SQLCA.SQLERRD.1'. 067800 05 Rxsqlca-Sqlerrd-2 Pic X(15) 067900 Value 'SQLCA.SQLERRD.2'. 068000 05 Rxsqlca-Sqlerrd-3 Pic X(15) 068100 Value 'SQLCA.SQLERRD.3'. 068200 05 Rxsqlca-Sqlerrd-4 Pic X(15) 068300 Value 'SQLCA.SQLERRD.4'. 068400 05 Rxsqlca-Sqlerrd-5 Pic X(15) 068500 Value 'SQLCA.SQLERRD.5'. 068600 05 Rxsqlca-Sqlerrd-6 Pic X(15) 068700 Value 'SQLCA.SQLERRD.6'. 068800 05 Rxsqlca-Sqlwarn-0 Pic X(15) 068900 Value 'SQLCA.SQLWARN.0'. 069000 05 Rxsqlca-Sqlwarn-1 Pic X(15) 069100 Value 'SQLCA.SQLWARN.1'. 069200 05 Rxsqlca-Sqlwarn-2 Pic X(15) 069300 Value 'SQLCA.SQLWARN.2'. 069400 05 Rxsqlca-Sqlwarn-3 Pic X(15) 069500 Value 'SQLCA.SQLWARN.3'. 069600 05 Rxsqlca-Sqlwarn-4 Pic X(15) 069700 Value 'SQLCA.SQLWARN.4'. 069800 05 Rxsqlca-Sqlwarn-5 Pic X(15) 069900 Value 'SQLCA.SQLWARN.5'. 070000 05 Rxsqlca-Sqlwarn-6 Pic X(15) 070100 Value 'SQLCA.SQLWARN.6'. 070200 05 Rxsqlca-Sqlwarn-7 Pic X(15) 070300 Value 'SQLCA.SQLWARN.7'. 070400 05 Rxsqlca-Sqlwarn-8 Pic X(15) 070500 Value 'SQLCA.SQLWARN.8'. 070600 05 Rxsqlca-Sqlwarn-9 Pic X(15) 070700 Value 'SQLCA.SQLWARN.9'. 070800 05 Rxsqlca-Sqlwarn-A Pic X(15) 070900 Value 'SQLCA.SQLWARN.A'. 071000 05 Rxsqlca-SqlState Pic X(14) 071100 Value 'SQLCA.SQLSTATE'. 071200 05 Rxsqlca-Sqlmsg Pic X(12) 071300 Value 'SQLCA.SQLMSG'. 071400 071500 01 Rexx-SQLDA-Variable-Names. 071600 05 Rxsqlda-Stem Pic X(06) 071700 Value 'SQLDA.'. 071800 05 Rxsqlda-Sqlvars Pic X(13) 071900 Value 'SQLDA.SQLVARS'. 072000 05 Rxsqlda-Sqldaid Pic X(13) 072100 Value 'SQLDA.SQLDAID'. 072200 05 Rxsqlda-Sqldabc Pic X(13) 072300 Value 'SQLDA.SQLDABC'. 072400 05 Rxsqlda-Sqln Pic X(10) 072500 Value 'SQLDA.SQLN'. 072600 05 Rxsqlda-Sqld Pic X(20) 072700 Value 'SQLDA.SQLD'. 072800 05 Rxsqlda-Sqlvar Occurs 750 Times. 072900 10 Rxsqlda-Sqltype Pic X(27). 073000 10 Rxsqlda-Sqllen Pic X(26). 073100 10 Rxsqlda-Sqlnull Pic X(27). 073200 10 Rxsqlda-Sqlname Pic X(27). 073300 073400 01 Rexx-IFCA-Variable-Names. 073500 05 Rxifca-Stem Pic X(05) 073600 Value 'IFCA.'. 073700 05 Rxifca-Return-Code Pic X(16) 073800 Value 'IFCA.RETURN_CODE'. 073900 05 Rxifca-Reason-Code Pic X(16) 074000 Value 'IFCA.REASON_CODE'. 074100 05 Rxifca-Owner Pic X(10) 074200 Value 'IFCA.OWNER'. 074300 05 Rxifca-Bytes-Moved Pic X(16) 074400 Value 'IFCA.BYTES_MOVED'. 074500 05 Rxifca-Bytes-Not-Moved Pic X(20) 074600 Value 'IFCA.BYTES_NOT_MOVED'. 074700 05 Rxifca-Records-Lost-Reada Pic X(23) 074800 Value 'IFCA.RECORDS_LOST_READA'. 074900 05 Rxifca-Op-Dest-Name Pic X(17) 075000 Value 'IFCA.OP_DEST_NAME'. 075100 05 Rxifca-Op-Dest-Ret Pic X(16) 075200 Value 'IFCA.OP_DEST_RET'. 075300 05 Rxifca-Trace-Num Pic X(14) 075400 Value 'IFCA.TRACE_NUM'. 075500 05 Rxifca-Diagnostics Pic X(16) 075600 Value 'IFCA.DIAGNOSTICS'. 075700 075800 01 Rexx-IFQA-Variable-Names. 075900 05 Rxifqa-Stem Pic X(05) 076000 Value 'IFQA.'. 076100 05 Rxifqa-Thread-Id Pic X(14) 076200 Value 'IFQA.THREAD_ID'. 076300 05 Rxifqa-Plan-Name Pic X(14) 076400 Value 'IFQA.PLAN_NAME'. 076500 05 Rxifqa-Prim-Authid Pic X(16) 076600 Value 'IFQA.PRIM_AUTHID'. 076700 05 Rxifqa-Orig-Authid Pic X(16) 076800 Value 'IFQA.ORIG_AUTHID'. 076900 05 Rxifqa-Conn-Name Pic X(14) 077000 Value 'IFQA.CONN_NAME'. 077100 05 Rxifqa-Corr-Id Pic X(12) 077200 Value 'IFQA.CORR_ID'. 077300 05 Rxifqa-Res-Token Pic X(14) 077400 Value 'IFQA.RES_TOKEN'. 077500 05 Rxifqa-Res-Hash Pic X(13) 077600 Value 'IFQA.RES_HASH'. 077700 05 Rxifqa-Asid Pic X(09) 077800 Value 'IFQA.ASID'. 077900 05 Rxifqa-Luwid Pic X(10) 078000 Value 'IFQA.LUWID'. 078100 05 Rxifqa-Loc-Name Pic X(13) 078200 Value 'IFQA.LOC_NAME'. 078300 05 Rxifqa-Log-Acc-Type Pic X(17) 078400 Value 'IFQA.LOG_ACC_TYPE'. 078500 05 Rxifqa-Log-Acc-Mode Pic X(17) 078600 Value 'IFQA.LOG_ACC_MODE'. 078700 05 Rxifqa-Log-Start-Rba Pic X(18) 078800 Value 'IFQA.LOG_START_RBA'. 078900 05 Rxifqa-Log-Num-Ci Pic X(15) 079000 Value 'IFQA.LOG_NUM_CI'. 079100 05 Rxifqa-CID-List Pic X(13) 079200 Value 'IFQA.CID_LIST'. 079300 05 Rxifqa-Op-Dest-Name Pic X(17) 079400 Value 'IFQA.OP_DEST_NAME'. 079500 079600 01 Row-Work-Area. 079700* Following is 32k buffer for result rows 079800 05 Row-Buf Pic x(32765). 079900* Following is 128k buffer for result rows 080000*--- 05 Row-Buf Pic x(131072). 080100 05 Row-Buf-Ptr Pointer. 080200 05 Row-Buf-Ptr-Num 080300 Redefines 080400 Row-Buf-Ptr Pic s9(9) Comp. 080500 05 Row-Buf-Offset Pic s9(9) Comp. 080600 05 Row-Buf-Field-Range Occurs 1 To 750 Times 080700 Depending On SQLD. 080800 10 Col-Beg-Pos Pic s9(5) Comp. 080900 10 Col-Len Pic s9(9) Comp. 081000 10 Col-Prec Pic s9(4) Comp. 081100 10 Col-Scale Pic s9(4) Comp. 081200 05 Col-Indicator-Info Occurs 750 Times. 081300 10 Null-Ind Pic s9(4) Comp. 081400 88 Value-Is-Null Value -1. 081500 10 Nullability Pic x(1). 081600 88 Col-Is-Nullable Value 'Y' 'y'. 081700 88 Col-Not-Nullable Value 'N' 'n'. 081800 081900 01 IRXEXCOM-Plist. 082000 05 EXCOM-IRXEXCOM Pic x(8) Value 'IRXEXCOM'. 082100 05 EXCOM-Pointer-2 Pointer Value Null. 082200 082300 01 EXCOM-Shared-Variable-Blocks. 082400 03 EXCOM-ShvBlock Occurs 3000 Times. 082500 05 EXCOM-ShvNext Pointer. 082600 05 EXCOM-ShvNext-Num Redefines 082700 EXCOM-ShvNext Pic s9(9) Comp. 082800 05 EXCOM-ShvUser Pic s9(9) Comp. 082900 05 EXCOM-ShvCode Pic x(1). 083000 88 EXCOM-Set-Variable-Direct Value 'S'. 083100 88 EXCOM-Fetch-Variable-Direct Value 'F'. 083200 88 EXCOM-Drop-Variable-Direct Value 'D'. 083300 88 EXCOM-Set-Variable-Symbol Value 's'. 083400 88 EXCOM-Fetch-Variable-Symbol Value 'f'. 083500 88 EXCOM-Drop-Variable-Symbol Value 'd'. 083600 88 EXCOM-Fetch-Next-Variable Value 'N'. 083700 88 EXCOM-Fetch-Private-Info Value 'P'. 083800 05 EXCOM-ShvRet Pic x(1). 083900 88 EXCOM-OK Values x'00'. 084000 88 EXCOM-Var-NOT-Found Values x'01' x'05'. 084100 88 EXCOM-Last-Var-Xferred Values x'02'. 084200 88 EXCOM-Trunc-Occured Values x'04' x'05'. 084300 88 EXCOM-Invalid-Var-Name Values x'08'. 084400 88 EXCOM-Value-Too-Long Values x'10'. 084500 88 EXCOM-Invalid-Func-Code Values x'80'. 084600 05 Filler Pic x(2). 084700 05 EXCOM-ShvBufL Pic 9(9) Comp. 084800 05 EXCOM-ShvNamA Pointer. 084900 05 EXCOM-ShvNamA-Num Redefines 085000 EXCOM-ShvNamA Pic s9(9) Comp. 085100 05 EXCOM-ShvNamL Pic 9(9) Comp. 085200 05 EXCOM-ShvValA Pointer. 085300 05 EXCOM-ShvValA-Num Redefines 085400 EXCOM-ShvValA Pic s9(9) Comp. 085500 05 EXCOM-ShvValL Pic 9(9) Comp. 085600 05 EXCOM-ShvValL-A Redefines 085700 EXCOM-ShvValL Pic x(4). 085800/ 085900*----------------------------------------------------------------* 086000* 086100* SQLCA Declaration. 086200* 086300*----------------------------------------------------------------* 086400 Exec SQL 086500 INCLUDE SQLCA 086600 End-Exec. 086700 086800*----------------------------------------------------------------* 086900* 087000* SQLDA Declaration. 087100* 087200*----------------------------------------------------------------* 087300 01 SQLDA. 087400 02 SQLDAID Pic x(8) Value 'SQLDA'. 087500 02 SQLDABC Pic s9(8) Comp 087600 Value 33016. 087700*------------------------ DB2 V2R2 --------- Value 13216. 087800 02 SQLN Pic s9(4) Comp Value 750. 087900 02 SQLD Pic s9(4) Comp Value 0. 088000 02 SQLVAR Occurs 1 To 750 Times 088100 Depending On SQLN. 088200* 02 SQLVAR Occurs 750 Times. 088300 03 SQLTYPE Pic s9(4) Comp. 088400 88 Type-Date Values 384 385. 088500 88 Type-Time Values 388 389. 088600 88 Type-Timestamp Values 392 393. 088700 88 Type-VarChar Values 448 449. 088800 88 Type-Char Values 452 453. 088900 88 Type-LongVarChar Values 456 457. 089000 88 Type-VarGraphic Values 464 465. 089100 88 Type-Graphic Values 468 469. 089200 88 Type-LongVarGraphic Values 472 473. 089300 88 Type-Float Values 480 481. 089400 88 Type-Decimal Values 484 485. 089500 88 Type-Integer Values 496 497. 089600 88 Type-Smallint Values 500 501. 089700 03 SQLLEN Pic s9(4) Comp. 089800 03 Filler 089900 Redefines 090000 SQLLEN. 090100 05 DLWA-Prec Pic x(1). 090200 05 DLWA-Scal Pic x(1). 090300 03 SQLDATA Pointer. 090400 03 SQLIND Pointer. 090500 03 SQLNAME. 090600 49 SQLNAMEL Pic s9(4) Comp. 090700 49 SQLNAMEC Pic x(30). 090800 090900*----------------------------------------------------------------* 091000* 091100* Rexx Variables SQLDA Declaration. 091200* 091300*----------------------------------------------------------------* 091400 01 RexxVars-SQLDA. 091500 02 RexxVars-SQLDAID Pic x(8) Value 'SQLDA'. 091600 02 RexxVars-SQLDABC Pic s9(8) Comp 091700 Value 33016. 091800*------------------------ DB2 V2R2 --------- Value 13216. 091900 02 RexxVars-SQLN Pic s9(4) Comp Value 750. 092000 02 RexxVars-SQLD Pic s9(4) Comp Value 0. 092100 02 RexxVars-SQLVAR Occurs 1 To 750 Times 092200 Depending On SQLN. 092300* 02 RexxVars-SQLVAR Occurs 750 Times. 092400 03 RexxVars-SQLTYPE Pic s9(4) Comp. 092500 88 RxVar-Type-Date Values 384 385. 092600 88 RxVar-Type-Date-N Value 385. 092700 88 RxVar-Type-Time Values 388 389. 092800 88 RxVar-Type-Time-N Value 389. 092900 88 RxVar-Type-Timestamp Values 392 393. 093000 88 RxVar-Type-Timestamp-N Value 393. 093100 88 RxVar-Type-VarChar Values 448 449. 093200 88 RxVar-Type-VarChar-N Value 449. 093300 88 RxVar-Type-Char Values 452 453. 093400 88 RxVar-Type-Char-N Value 453. 093500 88 RxVar-Type-LongVarChar Values 456 457. 093600 88 RxVar-Type-LongVarChar-N Value 457. 093700 88 RxVar-Type-VarGraphic Values 464 465. 093800 88 RxVar-Type-VarGraphic-N Value 465. 093900 88 RxVar-Type-Graphic Values 468 469. 094000 88 RxVar-Type-Graphic-N Value 469. 094100 88 RxVar-Type-LongVarGraphic Values 472 473. 094200 88 RxVar-Type-LongVarGraphic-N Value 473. 094300 88 RxVar-Type-Float Values 480 481. 094400 88 RxVar-Type-Float-N Value 481. 094500 88 RxVar-Type-Decimal Values 484 485. 094600 88 RxVar-Type-Decimal-N Value 485. 094700 88 RxVar-Type-Integer Values 496 497. 094800 88 RxVar-Type-Integer-N Value 497. 094900 88 RxVar-Type-Smallint Values 500 501. 095000 88 RxVar-Type-Smallint-N Value 501. 095100 03 RexxVars-SQLLEN Pic s9(4) Comp. 095200 03 RexxVars-SQLLEN-A Redefines 095300 RexxVars-SQLLEN Pic x(2). 095400 03 Filler 095500 Redefines 095600 RexxVars-SQLLEN. 095700 05 RexxVars-DLWA-Prec Pic x(1). 095800 05 RexxVars-DLWA-Scal Pic x(1). 095900 03 RexxVars-SQLDATA Pointer. 096000 03 RexxVars-SQLIND Pointer. 096100 03 RexxVars-SQLNAME. 096200 49 RexxVars-SQLNAMEL Pic s9(4) Comp. 096300 49 RexxVars-SQLNAMEC Pic x(30). 096400/ 096500 Linkage Section. 096600 096700*----Rexx External Function Package Parameter List (EFPL) 096800 01 IRXEFPL-Reserved-1 Pointer. 096900 01 IRXEFPL-Reserved-2 Pointer. 097000 01 IRXEFPL-Reserved-3 Pointer. 097100 01 IRXEFPL-Reserved-4 Pointer. 097200 01 IRXEFPL-EvalBlock-Addr Pointer. 097300 097400*----Rexx Argument List 097500 01 IRXEFPL-Arg-List. 097600 05 IRXEFPL-Arg-Pair Occurs 20 Times. 097700 10 IRXEFPL-Arg-Ptr Pointer. 097800 10 IRXEFPL-Arg-Len Pic s9(9) Comp. 097900 098000*----Rexx Evaluation Block 098100 01 IRXEFPL-EvalBlock. 098200 05 IRXEFPL-EvPad1 Pic x(4). 098300 05 IRXEFPL-EvSize Pic s9(9) Comp. 098400 05 IRXEFPL-EvLen Pic s9(9) Comp. 098500 05 IRXEFPL-EvPad2 Pic x(4). 098600 05 IRXEFPL-EvData Pic x(250). 098700 098800* Work Buffer used to access and alter storage by address 098900 01 Work-Buf Pic x(32765). 099000/ 099100 Procedure Division Using IRXEFPL-Reserved-1 099200 IRXEFPL-Reserved-2 099300 IRXEFPL-Reserved-3 099400 IRXEFPL-Reserved-4 099500 IRXEFPL-Arg-List 099600 IRXEFPL-EvalBlock-Addr 099700 IRXEFPL-EvalBlock 099800 Work-Buf. 099900 100000 Perform 000-Get-Argument 100100 100200 Perform 100-Initialize 100300 100400 If ( Attach-Requested Or (NOT Reuse-Attach) ) 100500 And NOT Detach-Requested Then 100600* Assume no attach exists 100700 Perform 150-CAF-Connect 100800 Else 100900* Assume existing attach will be used (thus, plan is still 101000* open) 101100 Set Plan-Has-Been-Opened To True 101200 End-If 101300 101400 Evaluate True 101500 When Attach-Requested 101600 Perform 203-Do-Preliminary-Connect 101700 Perform 205-Query-Current-Server 101800 Perform 500-Set-Rexx-SQLCA-Vars 101900 Perform 206-Set-Current-Server-Var 102000 When Detach-Requested 102100 Continue 102200 When Other 102300 Perform 200-Process-Statement 102400 End-Evaluate 102500 102600 Perform 990-Terminate 102700 102800 GoBack 102900 . 103000/ 103100 000-Get-Argument. 103200 103300* Initialize IRXEXCOM Control Block(s) 103400 Initialize EXCOM-Shared-Variable-Blocks 103500 103600* Initialize Plan Monitoring Switch 103700 Set Plan-Is-Closed To True 103800 103900* 104000* Get DB2 SysId, SQL Statement, Stem Name, FetchLimit, Vars, 104100* or 104200* DB2 Command 104300* 104400* Map-Order 104500 104600* If program was not invoked as Rexx routine, issue message. 104700* Otherwise, get arguments via the External Function Parameter 104800* List (EFPL). 104900 If Address Of IRXEFPL-Arg-List = Null Then 105000 Display ' ' 105100 Display 'RXDB2V23 must be invoked as a Rexx external' 105200 ' routine.' 105300 Display 'Invoke either as "CALL RXDB2V23" or as' 105400 ' "RXRC = RXDB2V23( , , , )"' 105500 Move +8 To Return-Code 105600 GoBack 105700 End-If 105800 105900*--- Count how many arguments were supplied 106000* (Expression " Length Of IRXEFPL-Arg-List 106100* / Length Of IRXEFPL-Arg-Pair(1)" 106200* denotes number of elements in array) 106300 Move Zero To Num-Rexx-Args 106400 Perform Varying Tally From 1 By 1 106500 Until Tally > Length Of IRXEFPL-Arg-List 106600 / Length Of IRXEFPL-Arg-Pair(1) 106700 Or IRXEFPL-Arg-Pair(Tally) = High-Values 106800 Move Tally To Num-Rexx-Args 106900 End-Perform 107000 107100*--- If no arguments supplied, Display documentation 107200 If Num-Rexx-Args = Zero Then 107300 Call 'Display-Documentation' 107400 Move +8 To CAF-Hold-Rc 107500 Perform 995-Set-EvalBlock-GoBack 107600 End-If 107700 107800*--- Get Arguments 107900*--- Get Rexx Argument Number 1 108000* (DB2 subsystem name) 108100 Move Spaces To Arg-DB2-Sysid 108200 Arg-DB-Names 108300 If Num-Rexx-Args >= 1 Then 108400 Perform 001-Get-Arg-1 108500 End-If 108600 108700*--- Get Rexx Argument Number 2 108800* (SQL statement or DB2 command) 108900 Move Zero To SQL-Stmt-Len 109000 Move Spaces To SQL-Stmt-Txt 109100 If Num-Rexx-Args >= 2 Then 109200 Perform 002-Get-Arg-2 109300 End-If 109400 109500*--- Get Rexx Argument Number 3 109600* (Result table stem name) 109700 Move Zero To Stem-Var-Len 109800 Move Spaces To Stem-Var-Name 109900 If Num-Rexx-Args >= 3 Then 110000 Perform 003-Get-Arg-3 110100 End-If 110200 110300*--- Get Rexx Argument Number 4 110400* (Row fetch limit for SQL Select statements) 110500 Move 999999999 To Fetch-Limit-N 110600 If Num-Rexx-Args >= 4 Then 110700 Perform 004-Get-Arg-4 110800 End-If 110900 Move Fetch-Limit-N To Fetch-Limit-C 111000 111100*--- Fold DB2 SubSystem-Id, and Stem-Variable-Name to uppercase. 111200 Inspect Arg-DB2-SysId 111300 Converting Lower-Case-Chars 111400 To Upper-Case-Chars 111500 Inspect Remote-Location-Name 111600 Converting Lower-Case-Chars 111700 To Upper-Case-Chars 111800 Inspect Stem-Var-Name 111900 Converting Lower-Case-Chars 112000 To Upper-Case-Chars 112100 112200*--- Check to see if SQL statement contains name of stem pointing 112300* to multiple statements. 112400 Set Single-SQL-Statement To True 112500 Move Zero To Tally 112600 Inspect SQL-Stmt-Txt 112700 Tallying Tally For Leading Spaces 112800 Add +1 To Tally 112900 Move SQL-Stmt-Txt (Tally:SQL-Stmt-Len) 113000 To Test-For-Keyword-Command 113100 Unstring Test-For-Keyword-Command 113200 Delimited By All Spaces 113300 Into Test-For-Keyword-Command 113400 Dummy-Unstring-Bin 113500 Inspect Test-For-Keyword-Command 113600 Converting Lower-Case-Chars 113700 To Upper-Case-Chars 113800 Evaluate True 113900 When Stem-Supplied 114000 Move SQL-Stmt-Txt (Tally:SQL-Stmt-Len) 114100 To Stmt-Stem-Work-Buf 114200 Move Spaces To Arg-SQL-Stem-Var-Txt 114300 Unstring Stmt-Stem-Work-Buf 114400 Delimited By All Spaces 114500 Into Dummy-Unstring-Bin 114600 Arg-SQL-Stem-Var-Txt 114700 End-Unstring 114800* Check to see if actual stem name was supplied. If it 114900* was, then validate the stem name. Otherwise, assume 115000* it's a valid SQL statement (bypass stem validation). 115100 If Arg-SQL-Stem-Var-Txt NOT = Spaces Then 115200 Perform 010-Validate-Stmt-Stem-Name 115300 End-If 115400 When Other 115500 Continue 115600 End-Evaluate 115700 115800*--- Get Rexx Argument Number 5 115900* (Host variables for SQL statement substitution) 116000 Move Zero To Arg-PMRV-Var-Buf-Len 116100 RexxVars-SQLD 116200 Move Spaces To Arg-PMRV-Var-Buf 116300 Arg-PMRV-Stem-Var 116400 If Num-Rexx-Args >= 5 Then 116500 Perform 005-Get-Arg-5 116600 End-If 116700 116800*--- Get Rexx Argument Number 6 116900* (Result table stem mapping order) 117000 Set Map-Col-Row To True 117100 Move 'CR' to Map-Type 117200 If Num-Rexx-Args >= 6 Then 117300 Perform 006-Get-Arg-6 117400 End-If 117500 117600* Get RXDB2 Trace Flag 117700 Set EXCOM-ShvNext(2) To Null 117800 Set EXCOM-Fetch-Variable-Direct(1) To True 117900 Move Length Of RxDB2-Trace To Excom-Shvnaml(1) 118000 Call 'Set-Pointer' Using RxDB2-Trace 118100 Excom-Shvnama(1) 118200 Call 'Set-Pointer' Using RxDB2-Trace-Flag 118300 EXCOM-ShvValA(1) 118400 Move Length Of RxDB2-Trace-Flag To EXCOM-ShvBufL(1) 118500 Perform 900-Call-IRXEXCOM 118600 If EXCOM-Var-NOT-Found(1) Then 118700 Move 'N' To RxDB2-Trace-Flag 118800 End-If 118900 . 119000/ 119100 001-Get-Arg-1. 119200 119300* Get DB2 SubSystem-Id 119400 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(1) 119500 Evaluate True 119600 When IRXEFPL-Arg-Len(1) > Length Of Arg-DB-Names 119700 Display 'DB2 SubSystem-Id / Remote Server Name' 119800 ' is too long.' 119900 Move Length Of Arg-DB-Names To Num-Disp-15 120000 Display 'Max allowed length is ' Num-Disp-15 120100 Move IRXEFPL-Arg-Len(1) To Num-Disp-15 120200 Display 'Supplied length is ' Num-Disp-15 120300 Display '"' Work-Buf (1:IRXEFPL-Arg-Len(1)) '"' 120400 Display 'is an invalid DB2 SubSystem-Id / Remote Server' 120500 ' Name specification.' 120600 Display 'RXDB2V23 is terminating.' 120700 Move +8 To CAF-Hold-Rc 120800 Perform 995-Set-EvalBlock-GoBack 120900 When IRXEFPL-Arg-Len(1) > Zero 121000 Move Work-Buf (1:IRXEFPL-Arg-Len(1)) 121100 To Arg-DB-Names 121200 End-Evaluate 121300 121400*--- Strip leading blanks from entire argument 121500 Move Zero To Tally 121600 Inspect Arg-DB-Names 121700 Tallying Tally 121800 For Leading Spaces 121900 Add +1 To Tally 122000 Move Arg-DB-Names (Tally:) To Row-Buf 122100 Move Row-Buf To Arg-DB-Names 122200 122300*--- Evaluate whether remote location name was supplied for 122400* initial remote connect. 122500 Move Zero To Tally 122600 Inspect Arg-DB-Names 122700 Tallying Tally 122800 For All '/' 122900 If Tally > Zero Then 123000 123100*----- Unstring Local DB2 Subsystem-Id 123200 Unstring Arg-DB-Names 123300 Delimited By '/' 123400 Into Row-Buf 123500 Dummy-Unstring-Bin 123600 End-Unstring 123700 Move Row-Buf To Arg-DB2-Sysid 123800 Move Zero To Tally 123900 Inspect Row-Buf 124000 Tallying Tally 124100 For Characters Before Initial Space 124200 If Tally > Length Of Arg-DB2-Sysid Then 124300 Display 'DB2 SubSystem-Id is too long.' 124400 Move Length Of Arg-DB2-Sysid To Num-Disp-15 124500 Display 'Max allowed length is ' Num-Disp-15 124600 Move Tally To Num-Disp-15 124700 Display 'Supplied length is ' Num-Disp-15 124800 Display '"' Row-Buf (1:Tally) '"' 124900 Display 'is an invalid DB2 SubSystem-Id name.' 125000 Display 'RXDB2V23 is terminating.' 125100 Move +8 To CAF-Hold-Rc 125200 Perform 995-Set-EvalBlock-GoBack 125300 End-If 125400 125500*----- Unstring Remote-Location-Name 125600 Unstring Arg-DB-Names 125700 Delimited By '/' 125800 Into Dummy-Unstring-Bin 125900 Row-Buf 126000 End-Unstring 126100*----- (Strip leading blanks from remote location name) 126200 Move Zero To Tally 126300 Inspect Row-Buf 126400 Tallying Tally 126500 For Leading Spaces 126600 Add +1 To Tally 126700 Move Row-Buf (Tally:) To Remote-Location-Name 126800 Move Zero To Char-Ctr 126900 Inspect Row-Buf (Tally:) 127000 Tallying Char-Ctr 127100 For Characters Before Initial Space 127200 If Char-Ctr > Length Of Remote-Location-Name Then 127300 Display 'Remote Location Name is too long.' 127400 Move Length Of Remote-Location-Name To Num-Disp-15 127500 Display 'Max allowed length is ' Num-Disp-15 127600 Move Char-Ctr To Num-Disp-15 127700 Display 'Supplied length is ' Num-Disp-15 127800 Display '"' Row-Buf (Tally:Char-Ctr) '"' 127900 Display 'is an invalid Remote Location Name.' 128000 Display 'RXDB2V23 is terminating.' 128100 Move +8 To CAF-Hold-Rc 128200 Perform 995-Set-EvalBlock-GoBack 128300 End-If 128400 Set Do-Init-Remote-Connect To True 128500 Else 128600 Move Zero To Tally 128700 Inspect Arg-DB-Names 128800 Tallying Tally 128900 For Characters Before Initial Space 129000 If Tally > Length Of Arg-DB2-Sysid Then 129100 Display 'DB2 SubSystem-Id is too long.' 129200 Move Length Of Arg-DB2-Sysid To Num-Disp-15 129300 Display 'Max allowed length is ' Num-Disp-15 129400 Move Tally To Num-Disp-15 129500 Display 'Supplied length is ' Num-Disp-15 129600 Display '"' Arg-DB-Names (1:Tally) '"' 129700 Display 'is an invalid DB2 SubSystem-Id name.' 129800 Display 'RXDB2V23 is terminating.' 129900 Move +8 To CAF-Hold-Rc 130000 Perform 995-Set-EvalBlock-GoBack 130100 End-If 130200 Move Arg-DB-Names To Arg-DB2-Sysid 130300 Set NOT-Do-Init-Rem-Connect To True 130400 End-If 130500 . 130600/ 130700 002-Get-Arg-2. 130800 130900* Get SQL Statement 131000 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(2) 131100 Move IRXEFPL-Arg-Len(2) To SQL-Stmt-Len 131200 If IRXEFPL-Arg-Len(2) > Length Of SQL-Stmt-Txt Then 131300 Display 'The SQL statement or DB2 command supplied is' 131400 ' too long.' 131500 Move IRXEFPL-Arg-Len(2) To Num-Disp-15 131600 Display 'Supplied statement length:' Num-Disp-15 131700 Move Length Of SQL-Stmt-Txt To Num-Disp-15 131800 Display 'Maximum allowable length :' Num-Disp-15 131900 Display 'First' Num-Disp-15 ' bytes of statement:' 132000 Display '"' Work-Buf (1:Length Of SQL-Stmt-Txt) '"' 132100 Display 'RXDB2V23 is terminating.' 132200 Move +8 To CAF-Hold-Rc 132300 Perform 995-Set-EvalBlock-GoBack 132400 End-If 132500 Move Spaces To SQL-Stmt-Txt 132600 If SQL-Stmt-Len > Zero Then 132700 Move Work-Buf (1:IRXEFPL-Arg-Len(2)) 132800 To SQL-Stmt-Txt 132900 End-If 133000 . 133100/ 133200 003-Get-Arg-3. 133300 133400*--- Get Stem Variable Name 133500 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(3) 133600 Move IRXEFPL-Arg-Len(3) To Stem-Var-Len 133700 If Stem-Var-Len > Zero Then 133800 Move Work-Buf (1:IRXEFPL-Arg-Len(3)) 133900 To Stem-Var-Name 134000*----- Strip leading blanks from entire argument 134100 Move Zero To Tally 134200 Inspect Stem-Var-Name 134300 Tallying Tally 134400 For Leading Spaces 134500 Add +1 To Tally 134600 Move Stem-Var-Name (Tally:) To Row-Buf 134700 Move Row-Buf To Stem-Var-Name 134800 Move Zero To Stem-Var-Len 134900 Inspect Stem-Var-Name 135000 Tallying Stem-Var-Len 135100 For Characters 135200 Before Initial Space 135300 End-If 135400 . 135500/ 135600 004-Get-Arg-4. 135700 135800* Get Fetch Limit 135900 If IRXEFPL-Arg-Len(4) NOT = Zero Then 136000 If IRXEFPL-Arg-Len(4) > Length Of Fetch-Limit-A Then 136100 Move Length Of Fetch-Limit-A To Num-Disp-15 136200 Display 'RXDB2V23: Scale of fourth argument exceeds' 136300 ' limit of ' Num-Disp-15 ' digits.' 136400 Display 'RXDB2V23 is terminating.' 136500 Move +8 To CAF-Hold-Rc 136600 Perform 995-Set-EvalBlock-GoBack 136700 End-If 136800 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(4) 136900 Move Work-Buf (1:IRXEFPL-Arg-Len(4)) 137000 To Fetch-Limit-A 137100 If Fetch-Limit-A (1:IRXEFPL-Arg-Len(4)) Is Numeric Then 137200 Move Fetch-Limit-A (1:IRXEFPL-Arg-Len(4)) 137300 To Fetch-Limit-R 137400 Inspect Fetch-Limit-R 137500 Converting Space To Zero 137600 Else 137700 Display 'RXDB2V23: Fourth argument must be a positive' 137800 ' integer denoting fetch limit.' 137900 Display 'RXDB2V23 is terminating.' 138000 Move +8 To CAF-Hold-Rc 138100 Perform 995-Set-EvalBlock-GoBack 138200 End-If 138300 End-If 138400 . 138500/ 138600 005-Get-Arg-5. 138700 138800* Get SQL Parameter Marker Rexx Variable Values (if any) 138900 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(5) 139000 If Single-SQL-Statement Then 139100 If IRXEFPL-Arg-Len(5) > Length Of Arg-PMRV-Var-Buf 139200 Move Length Of Arg-PMRV-Var-Buf To Num-Disp-15 139300 Display 'RXDB2V23: Parameter Marker Variable list is' 139400 ' too long.' 139500 Display 'Max allowed length is' 139600 Num-Disp-15 ' bytes.' 139700 Move IRXEFPL-Arg-Len(5) To Num-Disp-15 139800 Display 'Supplied length is' 139900 Num-Disp-15 ' bytes.' 140000 Display 'RXDB2V23 is terminating.' 140100 Move +8 To CAF-Hold-Rc 140200 Perform 995-Set-EvalBlock-GoBack 140300 End-If 140400 Move IRXEFPL-Arg-Len(5) 140500 To Arg-PMRV-Var-Buf-Len 140600 Move Work-Buf (1:IRXEFPL-Arg-Len(5)) 140700 To Arg-PMRV-Var-Buf 140800 Inspect Arg-PMRV-Var-Buf 140900 Converting Lower-Case-Chars 141000 To Upper-Case-Chars 141100 Inspect Arg-PMRV-Var-Buf 141200 Converting ',:;' 141300 To Spaces 141400 Else 141500 If IRXEFPL-Arg-Len(5) > Length Of Arg-PMRV-Stem-Var 141600 Move Length Of Arg-PMRV-Stem-Var To Num-Disp-15 141700 Display 'RXDB2V23: Parameter Marker Variable list stem' 141800 ' name is too long.' 141900 Display 'Max allowed length is' 142000 Num-Disp-15 ' bytes.' 142100 Move IRXEFPL-Arg-Len(5) To Num-Disp-15 142200 Display 'Supplied length is' 142300 Num-Disp-15 ' bytes.' 142400 Display 'RXDB2V23 is terminating.' 142500 Move +8 To CAF-Hold-Rc 142600 Perform 995-Set-EvalBlock-GoBack 142700 End-If 142800 Move Work-Buf (1:IRXEFPL-Arg-Len(5)) 142900 To Arg-PMRV-Stem-Var 143000 Inspect Arg-PMRV-Stem-Var 143100 Converting Lower-Case-Chars 143200 To Upper-Case-Chars 143300 Inspect Arg-PMRV-Stem-Var 143400 Converting ',:;' 143500 To Spaces 143600 End-If 143700 . 143800/ 143900 006-Get-Arg-6. 144000 144100* Get Stem Mapping Order indicator 144200 Set Address Of Work-Buf To IRXEFPL-Arg-Ptr(6) 144300 If IRXEFPL-Arg-Len(6) >= 0 Then 144400 Inspect Work-Buf (1:IRXEFPL-Arg-Len(6)) 144500 Converting Lower-Case-Chars 144600 To Upper-Case-Chars 144700 Evaluate True 144800 When Work-Buf (1:IRXEFPL-Arg-Len(6)) = 'CR' 144900 Move 'CR' to Map-Type 145000 Set Map-Col-Row To True 145100 When Work-Buf (1:IRXEFPL-Arg-Len(6)) = 'RC' 145200 Move 'RC' to Map-Type 145300 Set Map-Row-Col To True 145400 When Other 145500 Display 'RXDB2V23: Stem mapping order indicator is' 145600 ' invalid.' 145700 Display 'Allowed values are "CR" for Column.Row, or' 145800 ' "RC" for Row.Column.' 145900 Display 'Value supplied is "' 146000 Work-Buf (1:IRXEFPL-Arg-Len(6)) '".' 146100 Display 'RXDB2V23 is terminating.' 146200 Move +8 To CAF-Hold-Rc 146300 Perform 995-Set-EvalBlock-GoBack 146400 End-Evaluate 146500 Else 146600 Display 'RXDB2V23: Stem mapping order indicator is' 146700 ' invalid.' 146800 Display 'Allowed values are "CR" for Column.Row, or "RC"' 146900 ' for Row.Column.' 147000 Display 'RXDB2V23 is terminating.' 147100 Move +8 To CAF-Hold-Rc 147200 Perform 995-Set-EvalBlock-GoBack 147300 End-If 147400 . 147500/ 147600 010-Validate-Stmt-Stem-Name. 147700 147800* Fold Stem Name to Upper Case 147900 Inspect Arg-SQL-Stem-Var-Txt 148000 Converting Lower-Case-Chars 148100 To Upper-Case-Chars 148200 148300* Strip trailing spaces 148400 Move Zero To Arg-SQL-Stem-Var-Len 148500 Inspect Arg-SQL-Stem-Var-Txt 148600 Tallying Arg-SQL-Stem-Var-Len 148700 For Characters 148800 Before Initial Space 148900 149000*----------------------------------------------------------------- 149100* Check to see if stem itself has been initialized. If it has 149200* then the value has to be null, otherwise this will cause a 149300* (virtually) infinite number of stem values to be executed. 149400* (The variable "Row-Buf" is not used for any special reason. 149500* It just happened to fit the bill). 149600*----------------------------------------------------------------- 149700* Fetch contents of stem 149800 Set EXCOM-Fetch-Variable-Direct(1) To True 149900 Set EXCOM-ShvNext(1) To Null 150000 Call 'Set-Pointer' Using Arg-SQL-Stem-Var-Txt 150100 EXCOM-ShvNamA(1) 150200 Call 'Set-Pointer' Using Row-Buf 150300 EXCOM-ShvValA(1) 150400 Move Arg-SQL-Stem-Var-Len 150500 To EXCOM-ShvNamL(1) 150600 Move +32765 150700 To EXCOM-ShvBufL(1) 150800 Perform 900-Call-IRXEXCOM 150900 If EXCOM-Var-NOT-Found(1) Then 151000 Continue 151100 Else 151200 Move EXCOM-ShvValL(1) To Tally 151300 If Tally NOT = Zero Then 151400 Display 'The structure under the stem "' 151500 Arg-SQL-Stem-Var-Txt (1:Arg-SQL-Stem-Var-Len) 151600 '"' 151700 Display 'has been initialized with the value "' 151800 Row-Buf (1:Tally) 151900 '".' 152000 Display 'This will cause "' 152100 Row-Buf (1:Tally) '"' 152200 Display 'to be executed as an SQL statement an' 152300 ' infinite number of times.' 152400 Display 'RXDB2V23 is terminating.' 152500 Move +8 To CAF-Hold-Rc 152600 Perform 995-Set-EvalBlock-GoBack 152700 End-If 152800 End-If 152900 153000* Validate Stem Variable 153100 Evaluate True 153200 When Arg-SQL-Stem-Var-Len = Zero 153300* No stem variable name supplied, 153400* So assume SQL statement supplied is a 153500* genuine SQL statement 153600 Continue 153700 When Arg-SQL-Stem-Var-Txt (Arg-SQL-Stem-Var-Len:1) 153800 NOT = '.' 153900* Not a stem variable 154000* So assume SQL statement supplied is a 154100* genuine SQL statement 154200 Continue 154300 When Other 154400* Continue with processing 154500 Set Multiple-SQL-Statements To True 154600 End-Evaluate 154700 . 154800/ 154900 100-Initialize. 155000 155100 Move Zero To CAF-Hold-Rc 155200 155300* Indicate that result stem has not been dropped yet. 155400 Set Result-Stem-Not-Dropped To True 155500 155600 If Attach-Requested 155700 Or (NOT Reuse-Attach) Then 155800* Drop RXDB2 stem variable 155900 Set EXCOM-Drop-Variable-Direct(1) To True 156000 Set EXCOM-ShvNext(1) To Null 156100 Call 'Set-Pointer' Using RXDB2-Stem 156200 EXCOM-ShvNamA(1) 156300 Move Length Of RXDB2-Stem To EXCOM-ShvNamL(1) 156400 Perform 900-Call-IRXEXCOM 156500 End-If 156600 156700* Set RXDB2.SQLCAVARS, RXDB2.SQLDAVARS, RXDB2.SQLSYSID, 156800* and RXDB2.SQLSTEM values 156900 157000* Point 1->2, 2->3, 3->4, 4->5, 5->6, 6->7, 7->Null 157100* Set up IRXEXCOM ShvBlocks for Rexx RXDB2 variables 157200 Perform Varying Tally From 1 By 1 157300 Until Tally > 7 157400* Tell IRXEXCOM to set variable values 157500 Set EXCOM-Set-Variable-Direct(Tally) To True 157600* Point ahead to next ShvBlock 157700 Call 'Set-Pointer' Using EXCOM-ShvNext(Tally + 1) 157800 EXCOM-ShvNext(Tally) 157900 End-Perform 158000* Set last ShvBlock forward pointer to null 158100 Set EXCOM-ShvNext(Tally - 1) To Null 158200 158300* Setup RXDB2.SQLCAVARS 158400 Call 'Set-Pointer' Using RXDB2-SQLCAVARS 158500 EXCOM-ShvNamA(1) 158600 Call 'Set-Pointer' Using RXDB2-SQLCAVARS-Value 158700 EXCOM-ShvValA(1) 158800 Move Length Of RXDB2-SQLCAVARS 158900 To EXCOM-ShvNamL(1) 159000 Move Length Of RXDB2-SQLCAVARS-Value 159100 To EXCOM-ShvValL(1) 159200 159300* Setup RXDB2.SQLDAVARS 159400 Call 'Set-Pointer' Using RXDB2-SQLDAVARS 159500 EXCOM-ShvNamA(2) 159600 Call 'Set-Pointer' Using RXDB2-SQLDAVARS-Value 159700 EXCOM-ShvValA(2) 159800 Move Length Of RXDB2-SQLDAVARS 159900 To EXCOM-ShvNamL(2) 160000 Move Length Of RXDB2-SQLDAVARS-Value 160100 To EXCOM-ShvValL(2) 160200 160300* Setup RXDB2.SQLSYSID 160400 Call 'Set-Pointer' Using RXDB2-SQLSYSID 160500 EXCOM-ShvNamA(3) 160600 Call 'Set-Pointer' Using Arg-DB2-Sysid 160700 EXCOM-ShvValA(3) 160800 Move Length Of RXDB2-SQLSYSID 160900 To EXCOM-ShvNamL(3) 161000 Move Length Of Arg-DB2-Sysid 161100 To EXCOM-ShvValL(3) 161200 If Reuse-Attach Then 161300* Point ShvBlock(2) ahead to ShvBlock(4) in order to skip 161400* this block (3) because we don't want to set RXDB2.SQLSYSID 161500* in this case. 161600 Set EXCOM-OK(3) To True 161700 Call 'Set-Pointer' Using EXCOM-ShvNext(4) 161800 EXCOM-ShvNext(2) 161900 End-If 162000 162100* Setup RXDB2.SQLSTEM 162200 Call 'Set-Pointer' Using RXDB2-SQLSTEM 162300 EXCOM-ShvNamA(4) 162400 Call 'Set-Pointer' Using Stem-Var-Name 162500 EXCOM-ShvValA(4) 162600 Move Length Of RXDB2-SQLSTEM 162700 To EXCOM-ShvNamL(4) 162800 Move Stem-Var-Len 162900 To EXCOM-ShvValL(4) 163000 163100* Setup RXDB2.IFCAVARS 163200 Call 'Set-Pointer' Using RXDB2-IFCAVARS 163300 EXCOM-ShvNamA(5) 163400 Call 'Set-Pointer' Using RXDB2-IFCAVARS-Value 163500 EXCOM-ShvValA(5) 163600 Move Length Of RXDB2-IFCAVARS 163700 To EXCOM-ShvNamL(5) 163800 Move Length Of RXDB2-IFCAVARS-Value 163900 To EXCOM-ShvValL(5) 164000 164100* Setup RXDB2.IFQAVARS 164200 Call 'Set-Pointer' Using RXDB2-IFQAVARS 164300 EXCOM-ShvNamA(6) 164400 Call 'Set-Pointer' Using RXDB2-IFQAVARS-Value 164500 EXCOM-ShvValA(6) 164600 Move Length Of RXDB2-IFQAVARS 164700 To EXCOM-ShvNamL(6) 164800 Move Length Of RXDB2-IFQAVARS-Value 164900 To EXCOM-ShvValL(6) 165000 165100* Setup RXDB2.MAPSTEM 165200 Call 'Set-Pointer' Using RXDB2-MAPSTEM 165300 EXCOM-ShvNamA(7) 165400 Call 'Set-Pointer' Using Map-Type 165500 EXCOM-ShvValA(7) 165600 Move Length Of RXDB2-MAPSTEM 165700 To EXCOM-ShvNamL(7) 165800 Move Length Of Map-Type 165900 To EXCOM-ShvValL(7) 166000 166100 Perform 900-Call-IRXEXCOM 166200 . 166300/ 166400 150-CAF-Connect. 166500 166600* Connect To DB2 166700 Set CAF-Connect To True 166800 Move Arg-DB2-SysId 166900 To CAF-DB2-SysId 167000* Call DsnAli Using CAF-Function 167100 Call 'DSNALI' Using CAF-Function 167200 CAF-DB2-SysId 167300 CAF-Tecb 167400 CAF-Secb 167500 CAF-RibPtr 167600 CAF-Rc 167700 CAF-Reason-Code 167800 Perform 997-Set-Rexx-CAF-Reason-Code 167900 If (CAF-Rc NOT = Zero) 168000 And NOT CAF-Ready 168100 Call 'Convert-To-Hex' Using 168200 By Content Length Of CAF-Reason-Code 168300 By Reference CAF-Reason-Code 168400 C2X-Return-Buf 168500 Compute Tally = 2 * Length Of CAF-Reason-Code 168600 Display 'CAF Connect to "' CAF-DB2-SysId '" failed' 168700 ' with DB2 reason code ''' 168800 C2X-Return-Buf (1:Tally) '''x' 168900 Evaluate True 169000 When CAF-DB2-Sys-Not-Active 169100 Display 'Possible causes:' 169200 Display ' ' 169300 Display ' 1) The DB2 System "' CAF-DB2-SysId '"' 169400 ' is not active ("' CAF-DB2-SysId '"' 169500 Display ' is ''down'' right now).' 169600 Display ' ' 169700 Display ' 2) The DB2 System "' CAF-DB2-SysId '"' 169800 ' is not running on this CPU.' 169900 Display ' ' 170000 Display ' 3) The DB2 System "' CAF-DB2-SysId '"' 170100 ' does not exist, or' 170200 Display ' "' CAF-DB2-SysId '" is an invalid' 170300 ' DB2 SubSystem-Id.' 170400 When CAF-DB2-Rlse-Lvl-MisMatch 170500 Display 'Probable cause:' 170600 Display ' ' 170700 Display ' 1) The DB2 System "' CAF-DB2-SysId '"' 170800 ' and RXDB2V23''s version' 170900 Display ' of the Call Attach Facility are at' 171000 Display ' different release levels.' 171100 When Other 171200 Move CAF-Rc To Num-Disp 171300 Display 'CAF Call return code = ' Num-Disp 171400 Display 'RXDB2V23 is terminating.' 171500 End-Evaluate 171600* First, disconnect (in case it's necessary) 171700 Set CAF-Disconnect To True 171800* Call DsnAli Using CAF-Function 171900 Call 'DSNALI' Using CAF-Function 172000 CAF-Rc 172100 CAF-Reason-Code 172200 Move +8 To CAF-Hold-Rc 172300 Perform 995-Set-EvalBlock-GoBack 172400 Else 172500 If CAF-RibPtr NOT = Null Then 172600 Set Address Of Work-Buf To CAF-RibPtr 172700 Move Work-Buf (3:2) To Buf-Rec-Len-A 172800* Display 'RIB =>' Work-Buf (1:Buf-Rec-Len) '<=' 172900* Display 'DB2 Version is "' Work-Buf (17:3) '"' 173000 Set EXCOM-Set-Variable-Direct(1) To True 173100 Set EXCOM-ShvNext(1) To Null 173200 Call 'Set-Pointer' Using RXDB2-DB2VER 173300 EXCOM-ShvNamA(1) 173400 Move Length Of RXDB2-DB2VER 173500 To EXCOM-ShvNamL(1) 173600 Set EXCOM-ShvValA(1) To Address Of Work-Buf 173700 Add +17 To EXCOM-ShvValA-Num(1) 173800 Move +3 To EXCOM-ShvValL(1) 173900 Perform 900-Call-IRXEXCOM 174000 End-If 174100 End-If 174200 174300* Open Application Plan 174400 Set CAF-Open-Plan To True 174500 Move 'RXDB2V23' 174600 To CAF-Plan-Name 174700* Call DsnAli Using CAF-Function 174800 Call 'DSNALI' Using CAF-Function 174900 CAF-DB2-SysId 175000 CAF-Plan-Name 175100 CAF-Rc 175200 CAF-Reason-Code 175300 Perform 997-Set-Rexx-CAF-Reason-Code 175400 If (CAF-Rc NOT = Zero) 175500 And NOT CAF-Ready 175600 Call 'Convert-To-Hex' Using 175700 By Content Length Of CAF-Reason-Code 175800 By Reference CAF-Reason-Code 175900 C2X-Return-Buf 176000 Compute Tally = 2 * Length Of CAF-Reason-Code 176100 Display 'CAF Open of Plan ' CAF-Plan-Name ' failed' 176200 ' with DB2 reason code ''' 176300 C2X-Return-Buf (1:Tally) '''x' 176400 Evaluate True 176500 When CAF-Plan-Not-Authorized 176600 Display 'Probable cause:' 176700 Display ' ' 176800 Display ' 1) Your authorization-id is not' 176900 ' authorized to use' 177000 Display ' the plan "RXDB2V23" in DB2 System' 177100 ' "' CAF-DB2-SysId '"' 177200 Display ' ' 177300 Display ' 2) The plan "RXDB2V23" does not exist' 177400 ' in DB2 System "' CAF-DB2-SysId '"' 177500 When CAF-Plan-Unavailable 177600 Display 'Probable cause:' 177700 Display ' ' 177800 Display ' 1) A resource is unavailable' 177900 Display ' ' 178000 Display ' 2) The plan "RXDB2V23" does not exist' 178100 ' in DB2 System "' CAF-DB2-SysId '"' 178200 When Other 178300 Move CAF-Rc To Num-Disp 178400 Display 'CAF Call return code ' Num-Disp 178500 Display 'The SQLCA variables contain more information' 178600 Display 'RXDB2V23 is terminating.' 178700 End-Evaluate 178800 Set CAF-Translate To True 178900* Call DsnAli Using CAF-Function 179000 Call 'DSNALI' Using CAF-Function 179100 SQLCA 179200 CAF-Rc 179300 CAF-Reason-Code 179400 Perform 500-Set-Rexx-SQLCA-Vars 179500* First, disconnect 179600 Set CAF-Disconnect To True 179700* Call DsnAli Using CAF-Function 179800 Call 'DSNALI' Using CAF-Function 179900 CAF-Rc 180000 CAF-Reason-Code 180100 Move +8 To CAF-Hold-Rc 180200 Perform 995-Set-EvalBlock-GoBack 180300 Else 180400 Set Plan-Has-Been-Opened To True 180500 End-If 180600 . 180700/ 180800 180-Process-DB2-Command. 180900 181000* Drop SQLCA and IFCA stem structures 181100 Perform 820-Drop-Comm-Area-Stems 181200 181300* Put current DB2 Command into RXDB2.SQLSTMT 181400 Set EXCOM-Set-Variable-Direct(1) To True 181500 Set EXCOM-ShvNext(1) To Null 181600 Call 'Set-Pointer' Using RXDB2-SQLSTMT 181700 EXCOM-ShvNamA(1) 181800 Call 'Set-Pointer' Using SQL-Stmt-Txt 181900 EXCOM-ShvValA(1) 182000 Move Length Of RXDB2-SQLSTMT 182100 To EXCOM-ShvNamL(1) 182200 Move SQL-Stmt-Len 182300 To EXCOM-ShvValL(1) 182400 Perform 900-Call-IRXEXCOM 182500 182600* Get the name of the Rexx stem variable into which command 182700* output is to be mapped 182800 Perform 700-Prepare-Result-Table-Stem 182900 183000* Set Stem.0 to Zero before mapping result table 183100 Move Zero To Row-Counter 183200 Perform 800-Set-Stem-Dot-Zero 183300 183400 Move Low-Values To IFRA-Txt 183500 Add +4 To IFOA-Len 183600 Move Low-Values To IF-Communication-Area 183700 Move Length Of IF-Communication-Area To IFCA-Len 183800 Move 'IFCA' To IFCA-Id 183900 Move 'RXDB' To IFCA-Owner 184000 Evaluate True 184100 When Read-ASync-Supplied 184200 Perform 183-Setup-Read-Arguments 184300 Set IF-ReadA To True 184400 If RxDB2-Trace-On Then 184500 Display 'Dumping before IFI Call ...' 184600 Perform 189-Dump-IFI-Parms 184700 End-If 184800* Call DsnWli Using IF-Function 184900 Call 'DSNWLI' Using IF-Function 185000 IF-Communication-Area 185100 IF-Return-Area 185200 When Read-Sync-Supplied 185300 Perform 183-Setup-Read-Arguments 185400 Set IF-ReadS To True 185500 If RxDB2-Trace-On Then 185600 Display 'Dumping before IFI Call ...' 185700 Perform 189-Dump-IFI-Parms 185800 End-If 185900* Call DsnWli Using IF-Function 186000 Call 'DSNWLI' Using IF-Function 186100 IF-Communication-Area 186200 IF-Return-Area 186300 IF-CID-Area 186400 IF-Qualification-Area 186500 When Other 186600 Set IF-Command To True 186700 If RxDB2-Trace-On Then 186800 Display 'Dumping before IFI Call ...' 186900 Perform 189-Dump-IFI-Parms 187000 End-If 187100* Call DsnWli Using IF-Function 187200 Call 'DSNWLI' Using IF-Function 187300 IF-Communication-Area 187400 IF-Return-Area 187500 IF-Output-Area 187600 IF-Buffer-Info 187700 End-Evaluate 187800 187900* If Return-Code NOT = Zero Then 188000* Move Return-Code To Num-Disp-15 188100* Display 'DSNWLI Call Return-Code = ' Num-Disp-15 188200* Display 'RXDB2V23 will continue processing.' 188300* Display 'RXDB2V23 is terminating.' 188400* Move +8 To CAF-Hold-Rc 188500* Perform 995-Set-EvalBlock-GoBack 188600* End-If 188700 188800 If RxDB2-Trace-On Then 188900 Display 'Dumping after IFI Call ...' 189000 Perform 189-Dump-IFI-Parms 189100 End-If 189200 189300 Perform 520-Set-Rexx-IFCA-Vars 189400 189500 If IFCA-Bytes-Not-Moved = Zero Then 189600 If Read-Sync-Supplied 189700 Or Read-ASync-Supplied Then 189800 Perform 187-Process-Trace-Buffer 189900 Else 190000 Perform 185-Process-Result-Buffer 190100 End-If 190200 Else 190300 Display 'Not all returned data could fit in return' 190400 'buffer' 190500 End-If 190600 190700 If IFCA-Return-Code = Zero Then 190800 Move Zero To CAF-Hold-Rc 190900 Else 191000 Move +4 To CAF-Hold-Rc 191100 End-If 191200 191300 Initialize SqlCa 191400 Perform 280-Check-For-RollBack 191500 . 191600/ 191700 183-Setup-Read-Arguments. 191800 191900* Set up CID values for -READS or -READA request 192000 Move Low-Values To IF-CID-Area 192100 Move High-Values To IF-CID-List 192200 192300* Set up qualification values for -READS request 192400* (not used for -READA) 192500 Move Low-Values To IF-Qualification-Area 192600 Compute IFQA-Len = Length Of IF-Qualification-Area 192700 Move 'WQAL' To IFQA-Lit 192800 192900* Set up IRXEXCOM ShvBlocks for Rexx IFQA variables 193000 Perform Varying Tally From 1 By 1 193100 Until Tally > 17 193200 193300* Tell IRXEXCOM to fetch variable values 193400 Set EXCOM-Fetch-Variable-Direct(Tally) To True 193500 193600* Point ahead to next ShvBlock 193700 Call 'Set-Pointer' Using EXCOM-ShvNext(Tally + 1) 193800 EXCOM-ShvNext(Tally) 193900 194000 End-Perform 194100 194200* Set last ShvBlock forward pointer to null 194300 Set EXCOM-ShvNext(Tally - 1) To Null 194400 194500* Set Variable Name Lengths 194600 Move Length Of Rxifqa-Thread-Id To Excom-Shvnaml(1) 194700 Move Length Of Rxifqa-Plan-Name To Excom-Shvnaml(2) 194800 Move Length Of Rxifqa-Prim-Authid To Excom-Shvnaml(3) 194900 Move Length Of Rxifqa-Orig-Authid To Excom-Shvnaml(4) 195000 Move Length Of Rxifqa-Conn-Name To Excom-Shvnaml(5) 195100 Move Length Of Rxifqa-Corr-Id To Excom-Shvnaml(6) 195200 Move Length Of Rxifqa-Res-Token To Excom-Shvnaml(7) 195300 Move Length Of Rxifqa-Res-Hash To Excom-Shvnaml(8) 195400 Move Length Of Rxifqa-Asid To Excom-Shvnaml(9) 195500 Move Length Of Rxifqa-Luwid To Excom-Shvnaml(10) 195600 Move Length Of Rxifqa-Loc-Name To Excom-Shvnaml(11) 195700 Move Length Of Rxifqa-Log-Acc-Type To Excom-Shvnaml(12) 195800 Move Length Of Rxifqa-Log-Acc-Mode To Excom-Shvnaml(13) 195900 Move Length Of Rxifqa-Log-Start-Rba To Excom-Shvnaml(14) 196000 Move Length Of Rxifqa-Log-Num-Ci To Excom-Shvnaml(15) 196100 Move Length Of Rxifqa-CID-List To Excom-Shvnaml(16) 196200 Move Length Of Rxifqa-Op-Dest-Name To Excom-Shvnaml(17) 196300 196400* Point to Variable Names 196500 Call 'Set-Pointer' Using Rxifqa-Thread-Id 196600 Excom-Shvnama(1) 196700 Call 'Set-Pointer' Using Rxifqa-Plan-Name 196800 Excom-Shvnama(2) 196900 Call 'Set-Pointer' Using Rxifqa-Prim-Authid 197000 Excom-Shvnama(3) 197100 Call 'Set-Pointer' Using Rxifqa-Orig-Authid 197200 Excom-Shvnama(4) 197300 Call 'Set-Pointer' Using Rxifqa-Conn-Name 197400 Excom-Shvnama(5) 197500 Call 'Set-Pointer' Using Rxifqa-Corr-Id 197600 Excom-Shvnama(6) 197700 Call 'Set-Pointer' Using Rxifqa-Res-Token 197800 Excom-Shvnama(7) 197900 Call 'Set-Pointer' Using Rxifqa-Res-Hash 198000 Excom-Shvnama(8) 198100 Call 'Set-Pointer' Using Rxifqa-Asid 198200 Excom-Shvnama(9) 198300 Call 'Set-Pointer' Using Rxifqa-Luwid 198400 Excom-Shvnama(10) 198500 Call 'Set-Pointer' Using Rxifqa-Loc-Name 198600 Excom-Shvnama(11) 198700 Call 'Set-Pointer' Using Rxifqa-Log-Acc-Type 198800 Excom-Shvnama(12) 198900 Call 'Set-Pointer' Using Rxifqa-Log-Acc-Mode 199000 Excom-Shvnama(13) 199100 Call 'Set-Pointer' Using Rxifqa-Log-Start-Rba 199200 Excom-Shvnama(14) 199300 Call 'Set-Pointer' Using Rxifqa-Log-Num-Ci 199400 Excom-Shvnama(15) 199500 Call 'Set-Pointer' Using Rxifqa-CID-List 199600 Excom-Shvnama(16) 199700 Call 'Set-Pointer' Using Rxifqa-Op-Dest-Name 199800 Excom-Shvnama(17) 199900 200000* Point to Value Buffers 200100 Call 'Set-Pointer' Using IFQA-Thread-Id 200200 EXCOM-ShvValA(1) 200300 Call 'Set-Pointer' Using IFQA-Plan-Name 200400 EXCOM-ShvValA(2) 200500 Call 'Set-Pointer' Using IFQA-Prim-Authid 200600 EXCOM-ShvValA(3) 200700 Call 'Set-Pointer' Using IFQA-Orig-Authid 200800 EXCOM-ShvValA(4) 200900 Call 'Set-Pointer' Using IFQA-Conn-Name 201000 EXCOM-ShvValA(5) 201100 Call 'Set-Pointer' Using IFQA-Corr-Id 201200 EXCOM-ShvValA(6) 201300 Call 'Set-Pointer' Using IFQA-Res-Token 201400 EXCOM-ShvValA(7) 201500 Call 'Set-Pointer' Using IFQA-Res-Hash 201600 EXCOM-ShvValA(8) 201700 Call 'Set-Pointer' Using IFQA-Asid 201800 EXCOM-ShvValA(9) 201900 Call 'Set-Pointer' Using IFQA-Luwid 202000 EXCOM-ShvValA(10) 202100 Call 'Set-Pointer' Using IFQA-Loc-Name 202200 EXCOM-ShvValA(11) 202300 Call 'Set-Pointer' Using IFQA-Log-Acc-Type 202400 EXCOM-ShvValA(12) 202500 Call 'Set-Pointer' Using IFQA-Log-Acc-Mode 202600 EXCOM-ShvValA(13) 202700 Call 'Set-Pointer' Using IFQA-Log-Start-Rba 202800 EXCOM-ShvValA(14) 202900 Call 'Set-Pointer' Using IFQA-Log-Num-Ci 203000 EXCOM-ShvValA(15) 203100 Call 'Set-Pointer' Using IF-CID-List 203200 EXCOM-ShvValA(16) 203300 Call 'Set-Pointer' Using IFCA-Op-Dest-Name 203400 EXCOM-ShvValA(17) 203500 203600* Set Value Buffer Lengths 203700 Move Length Of IFQA-Thread-Id To EXCOM-ShvBufL(1) 203800 Move Length Of IFQA-Plan-Name To EXCOM-ShvBufL(2) 203900 Move Length Of IFQA-Prim-Authid To EXCOM-ShvBufL(3) 204000 Move Length Of IFQA-Orig-Authid To EXCOM-ShvBufL(4) 204100 Move Length Of IFQA-Conn-Name To EXCOM-ShvBufL(5) 204200 Move Length Of IFQA-Corr-Id To EXCOM-ShvBufL(6) 204300 Move Length Of IFQA-Res-Token To EXCOM-ShvBufL(7) 204400 Move Length Of IFQA-Res-Hash To EXCOM-ShvBufL(8) 204500 Move Length Of IFQA-Asid To EXCOM-ShvBufL(9) 204600 Move Length Of IFQA-Luwid To EXCOM-ShvBufL(10) 204700 Move Length Of IFQA-Loc-Name To EXCOM-ShvBufL(11) 204800 Move Length Of IFQA-Log-Acc-Type To EXCOM-ShvBufL(12) 204900 Move Length Of IFQA-Log-Acc-Mode To EXCOM-ShvBufL(13) 205000 Move Length Of IFQA-Log-Start-Rba To EXCOM-ShvBufL(14) 205100 Move Length Of IFQA-Log-Num-Ci To EXCOM-ShvBufL(15) 205200 Move Length Of IF-CID-List To EXCOM-ShvBufL(16) 205300 Move Length Of IFCA-Op-Dest-Name To EXCOM-ShvBufL(17) 205400 205500* Call IRXEXCOM to fetch Rexx IFQA variables 205600 Perform 900-Call-IRXEXCOM 205700 205800 If EXCOM-Var-NOT-Found(1) Then 205900 Set IFQA-Thread-Id To Null 206000 End-If 206100 If EXCOM-Var-NOT-Found(2) Then 206200 Move Low-Values To IFQA-Plan-Name 206300 End-If 206400 If EXCOM-Var-NOT-Found(3) Then 206500 Move Low-Values To IFQA-Prim-Authid 206600 End-If 206700 If EXCOM-Var-NOT-Found(4) Then 206800 Move Low-Values To IFQA-Orig-Authid 206900 End-If 207000 If EXCOM-Var-NOT-Found(5) Then 207100 Move Low-Values To IFQA-Conn-Name 207200 End-If 207300 If EXCOM-Var-NOT-Found(6) Then 207400 Move Low-Values To IFQA-Corr-Id 207500 End-If 207600 If EXCOM-Var-NOT-Found(7) Then 207700 Move Low-Values To IFQA-Res-Token 207800 End-If 207900 If EXCOM-Var-NOT-Found(8) Then 208000 Move Low-Values To IFQA-Res-Hash 208100 End-If 208200 If EXCOM-Var-NOT-Found(9) Then 208300 Move Low-Values To IFQA-Asid 208400 End-If 208500 If EXCOM-Var-NOT-Found(10) Then 208600 Move Low-Values To IFQA-Luwid 208700 End-If 208800 If EXCOM-Var-NOT-Found(11) Then 208900 Move Low-Values To IFQA-Loc-Name 209000 End-If 209100 If EXCOM-Var-NOT-Found(12) Then 209200 Move Low-Values To IFQA-Log-Acc-Type 209300 End-If 209400 If EXCOM-Var-NOT-Found(13) Then 209500 Move Low-Values To IFQA-Log-Acc-Mode 209600 End-If 209700 If EXCOM-Var-NOT-Found(14) Then 209800 Move Low-Values To IFQA-Log-Start-Rba 209900 End-If 210000 If EXCOM-Var-NOT-Found(15) Then 210100 Move Low-Values To IFQA-Log-Num-Ci 210200 End-If 210300 If EXCOM-Var-NOT-Found(16) Then 210400* No IFCID values were supplied 210500 Display 'IFCID value(s) are missing.' 210600 Display 'You must supply at least one IFCID value' 210700 ' for a -READS or -READA DB2 command.' 210800 Display 'Supply IFCID value(s) in the variable "' 210900 'IFQA.CID_LIST".' 211000 Display 'RXDB2V23 is terminating.' 211100 Move +8 To CAF-Hold-Rc 211200 Move -999 To SQLCODE 211300 Perform 280-Check-For-RollBack 211400* Move Low-Values To IF-CID-List 211500 Else 211600 Add EXCOM-ShvValL(16) 211700 +4 211800 Giving IF-CID-Len 211900 End-If 212000 If EXCOM-Var-NOT-Found(17) Then 212100 Move Low-Values To IFCA-Op-Dest-Name 212200 End-If 212300 212400* Omit length of IFQA-Log fields from IFQA-Len if IFQA value(s) 212500* were not supplied 212600 If EXCOM-Var-NOT-Found(12) 212700 And EXCOM-Var-NOT-Found(13) 212800 And EXCOM-Var-NOT-Found(14) 212900 And EXCOM-Var-NOT-Found(15) Then 213000 Compute IFQA-Len = IFQA-Len 213100 - Length Of IFQA-Log-Acc-Type 213200 - Length Of IFQA-Log-Acc-Mode 213300 - Length Of IFQA-Log-Start-Rba 213400 - Length Of IFQA-Log-Num-Ci 213500 End-Compute 213600 End-If 213700 . 213800/ 213900 185-Process-Result-Buffer. 214000 214100 Move 1 To Tally 214200 Move Zero To Buf-Rec-Len 214300 Perform With Test After 214400 Varying Row-Counter From 1 By 1 214500 Until Tally > IFRA-Len 214600 Or Buf-Rec-Len = Zero 214700 Move IFRA-Txt (Tally:2) 214800 To Buf-Rec-Len-A 214900 If Buf-Rec-Len > Zero Then 215000 Add +4 215100 Tally 215200 Giving Adjusted-Pos 215300 Subtract DB2-Cmd-Rslt-Offset 215400 From Buf-Rec-Len 215500* Prepare row portion of stem index 215600 Move Row-Counter To Stem-Index-N 215700 Perform 910-Format-Stem-Index 215800 Move Stem-Index-A To Row-Index 215900* Build indexed stem name 216000 Move Spaces To Stem-Row-Col-Var(1) 216100 If Multiple-SQL-Statements Then 216200 String Stem-Var-Name 216300 Statement-Counter-A 216400 Delimited By Spaces 216500 '.' 216600 Delimited By Size 216700 Row-Index 216800 Delimited By Spaces 216900 Into Stem-Row-Col-Var(1) 217000 End-String 217100 Else 217200 String Stem-Var-Name 217300 Row-Index 217400 Delimited By Spaces 217500 Into Stem-Row-Col-Var(1) 217600 End-String 217700 End-If 217800* Set EXCOM variable name length and address 217900 Move Zero To EXCOM-ShvNamL(1) 218000 Inspect Stem-Row-Col-Var(1) 218100 Tallying EXCOM-ShvNamL(1) 218200 For Characters Before Initial Space 218300 Call 'Set-Pointer' Using Stem-Row-Col-Var(1) 218400 EXCOM-ShvNamA(1) 218500 Call 'Set-Pointer' Using IFRA-Txt 218600 EXCOM-ShvValA(1) 218700 Add Adjusted-Pos 218800 To EXCOM-ShvValA-Num(1) 218900 Subtract 1 From EXCOM-ShvValA-Num(1) 219000 Move Buf-Rec-Len 219100 To EXCOM-ShvValL(1) 219200* Set last ShvBlock forward pointer to null 219300 Set EXCOM-ShvNext(1) To Null 219400* Call IRXEXCOM to set this row's stem variable values 219500 Perform 900-Call-IRXEXCOM 219600 Add DB2-Cmd-Rslt-Offset 219700 To Buf-Rec-Len 219800 End-If 219900 Add Buf-Rec-Len To Tally 220000 End-Perform 220100* Set Stem.0 to indicate how many rows of command output were 220200* returned. (Thus, how many rows are in the stem structure) 220300 Subtract 1 From Row-Counter 220400 Perform 800-Set-Stem-Dot-Zero 220500 . 220600/ 220700 187-Process-Trace-Buffer. 220800 220900 Move IFRA-Txt (1:2) 221000 To Buf-Rec-Len-A 221100* Prepare row portion of stem index 221200 Move 1 To Stem-Index-N 221300 Perform 910-Format-Stem-Index 221400 Move Stem-Index-A To Row-Index 221500* Build indexed stem name 221600 Move Spaces To Stem-Row-Col-Var(1) 221700 If Multiple-SQL-Statements Then 221800 String Stem-Var-Name 221900 Statement-Counter-A 222000 Delimited By Spaces 222100 '.' 222200 Delimited By Size 222300 Row-Index 222400 Delimited By Spaces 222500 Into Stem-Row-Col-Var(1) 222600 End-String 222700 Else 222800 String Stem-Var-Name 222900 Row-Index 223000 Delimited By Spaces 223100 Into Stem-Row-Col-Var(1) 223200 End-String 223300 End-If 223400* Set EXCOM variable name length and address 223500 Move Zero To EXCOM-ShvNamL(1) 223600 Inspect Stem-Row-Col-Var(1) 223700 Tallying EXCOM-ShvNamL(1) 223800 For Characters Before Initial Space 223900 Call 'Set-Pointer' Using Stem-Row-Col-Var(1) 224000 EXCOM-ShvNamA(1) 224100 Call 'Set-Pointer' Using IFRA-Txt 224200 EXCOM-ShvValA(1) 224300 Add +8 224400 To EXCOM-ShvValA-Num(1) 224500 Move Buf-Rec-Len 224600 To EXCOM-ShvValL(1) 224700* Set last ShvBlock forward pointer to null 224800 Set EXCOM-ShvNext(1) To Null 224900* Call IRXEXCOM to set this row's stem variable values 225000 Perform 900-Call-IRXEXCOM 225100* Set Stem.0 to indicate how many rows of command output were 225200* returned. (Thus, how many rows are in the stem structure) 225300 Move 1 To Row-Counter 225400 Perform 800-Set-Stem-Dot-Zero 225500 . 225600/ 225700 189-Dump-IFI-Parms. 225800 225900* Dump IFCA --------------------------------------------------- 226000 Call 'Convert-To-Hex' Using By Content 226100 Length Of IF-Communication-Area 226200 By Reference 226300 IF-Communication-Area 226400 C2X-Return-Buf 226500 Compute Tally = 2 * Length Of IF-Communication-Area 226600 Display 'IFCA "' C2X-Return-Buf (1:Tally) '"x' 226700 226800* Dump IF Fuction --------------------------------------------- 226900 Display 'IF-Function "' IF-Function '"c' 227000 227100* Dump IF CID ------------------------------------------------- 227200 Call 'Convert-To-Hex' Using By Content 227300 Length Of IF-CID-Area 227400 By Reference 227500 IF-CID-Area 227600 C2X-Return-Buf 227700 Compute Tally = 2 * Length Of IF-CID-Area 227800 Display 'IFCID "' C2X-Return-Buf (1:Tally) '"x' 227900 228000* Dump IFQA --------------------------------------------------- 228100 Call 'Convert-To-Hex' Using By Content 228200 Length Of IF-Qualification-Area 228300 By Reference 228400 IF-Qualification-Area 228500 C2X-Return-Buf 228600 Compute Tally = 2 * Length Of IF-Qualification-Area 228700 Display 'IFQA "' C2X-Return-Buf (1:Tally) '"x' 228800 . 228900/ 229000 200-Process-Statement. 229100 229200 Perform 203-Do-Preliminary-Connect 229300 229400*--- Declare a statement name for use in PREPARE 229500 Exec SQL 229600 DECLARE S1 STATEMENT 229700 End-Exec 229800*--- Declare a cursor for the Statement-Name, in case it's a 229900* SELECT statement 230000 Exec SQL 230100 DECLARE C1 CURSOR FOR S1 230200 End-Exec 230300 230400 Move Zero To Statement-Counter 230500 Perform 830-Drop-SQLDA-Stem 230600 Perform 270-Set-SQLSNO-Value 230700 If Single-SQL-Statement 230800 Move +1 To Statement-Counter 230900 Perform 270-Set-SQLSNO-Value 231000 Perform 205-Query-Current-Server 231100 Perform 210-Check-For-DB2-Command 231200 If DB2-Command-Supplied Then 231300 Perform 180-Process-DB2-Command 231400 Else 231500 Perform 250-Execute-SQL-Statement 231600 End-If 231700 Perform 206-Set-Current-Server-Var 231800 Else 231900* Perform each SQL statement in turn, until you run out 232000* of statements, or a statement gives negative SQLCode 232100* If a statement gives negative SQLCode, RollBack is 232200* attempted. 232300 Perform 220-Get-SQL-Statement 232400 If SQL-Stmt-Len = Zero 232500 Or SQL-Stmt-Txt (1:Sql-Stmt-Len) = Spaces Then 232600* No elements under supplied stem 232700 Display '"' Arg-SQL-Stem-Var-Txt (1:Arg-SQL-Stem-Var-Len) 232800 '1" was not found or is null (empty).' 232900 Display 'You must supply a value in at least "' 233000 Arg-SQL-Stem-Var-Txt (1:Arg-SQL-Stem-Var-Len) 233100 '1" for successful execution.' 233200 Display 'RXDB2V23 is terminating.' 233300 Move +8 To CAF-Hold-Rc 233400 Move -999 To SQLCODE 233500 Perform 280-Check-For-RollBack 233600 End-If 233700 Perform With Test Before 233800 Until SQLCODE < Zero 233900 Or IFCA-Return-Code > 4 234000 Or SQL-Stmt-Len = Zero 234100 Or SQL-Stmt-Txt (1:Sql-Stmt-Len) = Spaces 234200 Or EXCOM-Var-NOT-Found(1) 234300 Perform 270-Set-SQLSNO-Value 234400 Perform 205-Query-Current-Server 234500 Perform 210-Check-For-DB2-Command 234600 If DB2-Command-Supplied Then 234700 Perform 180-Process-DB2-Command 234800 Else 234900 Perform 250-Execute-SQL-Statement 235000 End-If 235100 Perform 206-Set-Current-Server-Var 235200 Perform 220-Get-SQL-Statement 235300 End-Perform 235400 End-If 235500 . 235600/ 235700 203-Do-Preliminary-Connect. 235800 235900*--- If Initial Remote Connect was specified, then try it 236000 If Do-Init-Remote-Connect Then 236100 Exec SQL 236200 CONNECT TO :Remote-Location-Name 236300 End-Exec 236400 If SqlCode NOT = Zero Then 236500 Move +4 To CAF-Hold-Rc 236600* Set SQLCA variables to tell Rexx exec what happened 236700* during Connect 236800 Perform 500-Set-Rexx-SQLCA-Vars 236900 Perform 280-Check-For-RollBack 237000 End-If 237100 End-If 237200 . 237300/ 237400 205-Query-Current-Server. 237500 237600* Display 'DB2 Version is "' Work-Buf (17:3) '"' 237700 Move Spaces To Remote-Location-Name 237800 Exec SQL 237900 SET :Remote-Location-Name = CURRENT SERVER 238000 End-Exec 238100 If SqlCode NOT = Zero Then 238200 Move +4 To CAF-Hold-Rc 238300* Set SQLCA variables to tell Rexx exec what happened 238400* during Query 238500 Perform 500-Set-Rexx-SQLCA-Vars 238600 Perform 280-Check-For-RollBack 238700 End-If 238800 . 238900/ 239000 206-Set-Current-Server-Var. 239100 239200 Set EXCOM-Set-Variable-Direct(1) To True 239300 Set EXCOM-ShvNext(1) To Null 239400 Call 'Set-Pointer' Using RXDB2-SQLSERVER 239500 EXCOM-ShvNamA(1) 239600 Move Length Of RXDB2-SQLSERVER 239700 To EXCOM-ShvNamL(1) 239800 Call 'Set-Pointer' Using Remote-Location-Name 239900 EXCOM-ShvValA(1) 240000 Move Zero To EXCOM-ShvValL(1) 240100 Inspect Remote-Location-Name 240200 Tallying EXCOM-ShvValL(1) 240300 For Characters 240400 Before Initial Space 240500 Perform 900-Call-IRXEXCOM 240600 . 240700/ 240800 210-Check-For-DB2-Command. 240900 241000 Move Zero To Tally 241100 Inspect SQL-Stmt-Txt 241200 Tallying Tally For Leading Spaces 241300 Add +1 To Tally 241400 Move SQL-Stmt-Txt (Tally:SQL-Stmt-Len) 241500 To Test-For-Keyword-Command 241600 Unstring Test-For-Keyword-Command 241700 Delimited By All Spaces 241800 Into Test-For-Keyword-Command 241900 Dummy-Unstring-Bin 242000 Inspect Test-For-Keyword-Command 242100 Converting Lower-Case-Chars 242200 To Upper-Case-Chars 242300 242400 If DB2-Command-Supplied Then 242500 Move Sql-Stmt-Txt (Tally:SQL-Stmt-Len) 242600 To IFOA-Buf 242700 Compute IFOA-Len = Sql-Stmt-Len - Tally + 1 242800 End-If 242900 . 243000/ 243100 220-Get-SQL-Statement. 243200 243300 Add +1 To Statement-Counter 243400 243500* Build indexed stem name 243600 Move Statement-Counter To Stem-Index-N 243700 Perform 910-Format-Stem-Index 243800 Move Spaces To Stmt-Stem-Work-Buf 243900 String Arg-SQL-Stem-Var-Txt 244000 Stem-Index-A 244100 Delimited By Spaces 244200 Into Stmt-Stem-Work-Buf 244300 End-String 244400 244500* Fetch contents of stem 244600 Set EXCOM-Fetch-Variable-Direct(1) To True 244700 Set EXCOM-ShvNext(1) To Null 244800 Call 'Set-Pointer' Using Stmt-Stem-Work-Buf 244900 EXCOM-ShvNamA(1) 245000 Call 'Set-Pointer' Using SQL-Stmt-Txt 245100 EXCOM-ShvValA(1) 245200 Move Zero To EXCOM-ShvNamL(1) 245300 Inspect Stmt-Stem-Work-Buf 245400 Tallying EXCOM-ShvNamL(1) 245500 For Characters Before Initial Space 245600 Move +32765 245700 To EXCOM-ShvBufL(1) 245800 Perform 900-Call-IRXEXCOM 245900 Move EXCOM-ShvValL(1) To SQL-Stmt-Len 246000 If EXCOM-Var-NOT-Found(1) Then 246100 Move Zero To SQL-Stmt-Len 246200 End-If 246300 . 246400/ 246500 250-Execute-SQL-Statement. 246600 246700* Drop SQLCA and IFCA stem structures 246800 Perform 820-Drop-Comm-Area-Stems 246900 247000* Put current SQL Statement into RXDB2.SQLSTMT 247100 Set EXCOM-Set-Variable-Direct(1) To True 247200 Set EXCOM-ShvNext(1) To Null 247300 Call 'Set-Pointer' Using RXDB2-SQLSTMT 247400 EXCOM-ShvNamA(1) 247500 Call 'Set-Pointer' Using SQL-Stmt-Txt 247600 EXCOM-ShvValA(1) 247700 Move Length Of RXDB2-SQLSTMT 247800 To EXCOM-ShvNamL(1) 247900 Move SQL-Stmt-Len 248000 To EXCOM-ShvValL(1) 248100 Perform 900-Call-IRXEXCOM 248200 248300 Perform 290-Get-Parm-Marker-Values 248400 248500 Perform 253-Check-Statement-Type 248600 248700* Display ' ' 248800* Display 'Test-For-Statement-Type >' 248900* Test-For-Statement-Type '<' 249000* Display 'Special-Stmt-Word-2 >' 249100* Special-Stmt-Word-2 '<' 249200* Display 'Special-Stmt-Word-3 >' 249300* Special-Stmt-Word-3 '<' 249400* Display 'Dummy-Unstring-Bin >' 249500* Dummy-Unstring-Bin '<' 249600* Display 'Current-PackageSet-Name >' 249700* Current-PackageSet-Name '<' 249800 249900 Move Zero To SQLD 250000 Evaluate True 250100 When Connect-SQL-Stmt 250200 Move Special-Stmt-Word-3 250300 To Remote-Location-Name 250400* Display 'Connecting to Location "' 250500* Remote-Location-Name '"' 250600 Evaluate True 250700 When SS-Word-2-Space 250800 Exec SQL 250900 CONNECT 251000 End-Exec 251100 When SS-Word-2-Reset 251200 Exec SQL 251300 CONNECT RESET 251400 End-Exec 251500 When SS-Word-2-To 251600 Exec SQL 251700 CONNECT TO :Remote-Location-Name 251800 End-Exec 251900 End-Evaluate 252000 If SqlCode = Zero Then 252100 Exec SQL 252200 SET :Remote-Location-Name = CURRENT SERVER 252300 End-Exec 252400 If SqlCode NOT = Zero Then 252500 Move +4 To CAF-Hold-Rc 252600* Set SQLCA variables to tell Rexx exec what 252700* happened. 252800 Perform 500-Set-Rexx-SQLCA-Vars 252900 Perform 280-Check-For-RollBack 253000 End-If 253100 End-If 253200 When Describe-SQL-Stmt 253300 And SS-Word-2-Table 253400 Exec SQL 253500 DESCRIBE TABLE :Special-Stmt-Word-3 253600 INTO :SQLDA 253700 USING ANY 253800 End-Exec 253900 When Get-SQL-Stmt 254000 And SS-Word-2-User 254100 Exec SQL 254200 SET :Row-Buf = USER 254300 End-Exec 254400 When Get-SQL-Stmt 254500 And SS-Word-2-Current 254600 And SS-Word-3-PackageSet 254700 Exec SQL 254800 SET :Row-Buf = CURRENT PACKAGESET 254900 End-Exec 255000 When Get-SQL-Stmt 255100 And SS-Word-2-Current 255200 And SS-Word-3-TimeZone 255300 Exec SQL 255400 SET :Current-TimeZone-Value = CURRENT TIMEZONE 255500 End-Exec 255600 Move Current-TimeZone-Value 255700 To Num-Disp-With-Zero 255800 Move Num-Disp-With-Zero 255900 To Just-Right-Field 256000 Move Zero To Tally 256100 Inspect Just-Right-Field 256200 Tallying Tally 256300 For Leading Spaces 256400 Add +1 To Tally 256500 Move Just-Right-Field (Tally:) 256600 To Row-Buf 256700 When Get-SQL-Stmt 256800 And SS-Word-2-Current 256900 And SS-Word-3-Date 257000 Exec SQL 257100 SET :Row-Buf = CURRENT DATE 257200 End-Exec 257300 When Get-SQL-Stmt 257400 And SS-Word-2-Current 257500 And SS-Word-3-Time 257600 Exec SQL 257700 SET :Row-Buf = CURRENT TIME 257800 End-Exec 257900 When Get-SQL-Stmt 258000 And SS-Word-2-Current 258100 And SS-Word-3-TimeStamp 258200 Exec SQL 258300 SET :Row-Buf = CURRENT TIMESTAMP 258400 End-Exec 258500 When Get-SQL-Stmt 258600 And SS-Word-2-Current 258700 And SS-Word-3-SqlId 258800 Exec SQL 258900 SET :Row-Buf = CURRENT SQLID 259000 End-Exec 259100 When Get-SQL-Stmt 259200 And SS-Word-2-Current 259300 And SS-Word-3-Server 259400 Exec SQL 259500 SET :Row-Buf = CURRENT SERVER 259600 End-Exec 259700 When Set-SQL-Stmt 259800 And SS-Word-2-Current 259900 And SS-Word-3-PackageSet 260000 And Dummy-Equal-Sign 260100 If Current-PackageSet-Name = 'USER' Then 260200 Exec SQL 260300 SET CURRENT PACKAGESET = USER 260400 End-Exec 260500 Else 260600 If Current-PackageSet-Name = '''USER''' 260700 Or Current-PackageSet-Name = '"USER"' Then 260800 Move 'USER' To Current-PackageSet-Name 260900 End-If 261000 Exec SQL 261100 SET CURRENT PACKAGESET = :Current-PackageSet-Name 261200 End-Exec 261300 End-If 261400 When Other 261500* Prepare the SQL statement from the SQL Statement buffer 261600* (Use "PREPARE INTO" to do prepare and describe at once) 261700 Exec SQL 261800 PREPARE S1 INTO :SQLDA USING ANY FROM :SQL-STATEMENT 261900 End-Exec 262000* Move Sqlcode To Num-Disp-15 262100* Display 'Prepare sqlcode = ' num-disp-15 262200 End-Evaluate 262300 262400 If SQLCode = Zero Then 262500 Perform 650-Set-RxDB2-No-Where-Clause 262600* SQLCODE says prepare was OK, now see if it's a "DESCRIBE" 262700* statement, or a real SQL statement. 262800 Evaluate True 262900 When Describe-SQL-Stmt 263000* Set up SQLCA, SQLDA to describe statement to Rexx 263100 Perform 500-Set-Rexx-SQLCA-Vars 263200 Perform 400-Point-SQLDA-To-Storage 263300 Perform 600-Set-Rexx-SQLDA-Vars 263400 When Connect-SQL-Stmt 263500* Set up SQLCA 263600 Perform 500-Set-Rexx-SQLCA-Vars 263700 Perform 600-Set-Rexx-SQLDA-Vars 263800 When Get-SQL-Stmt 263900 Perform 500-Set-Rexx-SQLCA-Vars 264000 Perform 252-Set-Rexx-Var-With-Value 264100 Perform 600-Set-Rexx-SQLDA-Vars 264200 When Set-SQL-Stmt 264300 And SS-Word-2-Current 264400 And SS-Word-3-PackageSet 264500 And Dummy-Equal-Sign 264600 Perform 500-Set-Rexx-SQLCA-Vars 264700 Perform 600-Set-Rexx-SQLDA-Vars 264800 When Other 264900 Perform 255-Continue-With-Execute 265000 End-Evaluate 265100 Else 265200* Prepare failed, so pass the information back to the Rexx 265300* exec via the SQLCA 265400* Set the SQLCA variables telling the Rexx exec what 265500* happened 265600 Move +4 To CAF-Hold-Rc 265700 Perform 500-Set-Rexx-SQLCA-Vars 265800 Perform 280-Check-For-RollBack 265900 End-If 266000 . 266100/ 266200 252-Set-Rexx-Var-With-Value. 266300 266400 If Get-SQL-Stmt Then 266500* Get the name of the Rexx stem variable into which GET 266600* output is to be mapped 266700 Perform 700-Prepare-Result-Table-Stem 266800* Set Stem.0 to One (GET always returns a single value) 266900 Move +1 To Row-Counter 267000 Perform 800-Set-Stem-Dot-Zero 267100* Prepare row portion of stem index 267200 Move Row-Counter To Stem-Index-N 267300 Perform 910-Format-Stem-Index 267400 Move Stem-Index-A To Row-Index 267500* Build indexed stem name 267600 Move Spaces To Stem-Row-Col-Var(1) 267700 If Multiple-SQL-Statements Then 267800 String Stem-Var-Name 267900 Statement-Counter-A 268000 Delimited By Spaces 268100 '.' 268200 Delimited By Size 268300 Row-Index 268400 Delimited By Spaces 268500 Into Stem-Row-Col-Var(1) 268600 End-String 268700 Else 268800 String Stem-Var-Name 268900 Row-Index 269000 Delimited By Spaces 269100 Into Stem-Row-Col-Var(1) 269200 End-String 269300 End-If 269400* Set EXCOM variable name length and address 269500 Move Zero To EXCOM-ShvNamL(1) 269600 Inspect Stem-Row-Col-Var(1) 269700 Tallying EXCOM-ShvNamL(1) 269800 For Characters Before Initial Space 269900 Call 'Set-Pointer' Using Stem-Row-Col-Var(1) 270000 EXCOM-ShvNamA(1) 270100 Call 'Set-Pointer' Using Row-Buf 270200 EXCOM-ShvValA(1) 270300 Move Zero To EXCOM-ShvValL(1) 270400 Inspect Row-Buf 270500 Tallying EXCOM-ShvValL(1) 270600 For Characters 270700 Before Initial Space 270800* Set last ShvBlock forward pointer to null 270900 Set EXCOM-ShvNext(1) To Null 271000* Call IRXEXCOM to set this row's stem variable values 271100 Perform 900-Call-IRXEXCOM 271200 End-If 271300 . 271400/ 271500 253-Check-Statement-Type. 271600 271700 Move Zero To Stmt-Start 271800 Inspect SQL-Stmt-Txt 271900 Tallying Stmt-Start 272000 For Leading Spaces 272100 Compute Tally = SQL-Stmt-Len - Stmt-Start 272200 Add +1 To Stmt-Start 272300 Move SQL-Stmt-Txt (Stmt-Start:Tally) 272400 To Row-Buf 272500 Move Spaces To Test-For-Statement-Type 272600 Special-Stmt-Word-2 272700 Special-Stmt-Word-3 272800 Dummy-Unstring-Bin 272900 Current-PackageSet-Name 273000* Unstring SQL-Stmt-Txt 273100 Unstring Row-Buf 273200 Delimited By All Spaces 273300 Into Test-For-Statement-Type 273400 Special-Stmt-Word-2 273500 Special-Stmt-Word-3 273600 Dummy-Unstring-Bin 273700 Current-PackageSet-Name 273800* With Pointer Stmt-Start 273900 End-Unstring 274000 Inspect Test-For-Statement-Type 274100 Converting Lower-Case-Chars 274200 To Upper-Case-Chars 274300 Inspect Special-Stmt-Word-2 274400 Converting Lower-Case-Chars 274500 To Upper-Case-Chars 274600 Inspect Special-Stmt-Word-3 274700 Converting Lower-Case-Chars 274800 To Upper-Case-Chars 274900 Inspect Current-PackageSet-Name 275000 Converting Lower-Case-Chars 275100 To Upper-Case-Chars 275200 275300 Evaluate True 275400 When Describe-SQL-Stmt 275500 And SS-Word-2-Table 275600 Continue 275700 When Describe-SQL-Stmt 275800* Fix up statement if this is other than "DESCRIBE TABLE". 275900* (That is, strip the word "DESCRIBE" off the front) 276000* Using "Row-Buf" for no particular reason other than it's 276100* a 32k buffer available for use at this point in program. 276200* (Add length of word "DESCRIBE" - 8 bytes - to Stmt-Start) 276300 Move Zero To Stmt-Start 276400 Inspect SQL-Stmt-Txt 276500 Tallying Stmt-Start 276600 For Leading Spaces 276700 Add +1 To Stmt-Start 276800 Add +8 To Stmt-Start 276900 Compute SQL-Stmt-Len = SQL-Stmt-Len - (Stmt-Start - 1) 277000 Move SQL-Stmt-Txt (Stmt-Start:SQL-Stmt-Len) 277100 To Row-Buf 277200 Move Zero To Stmt-Start 277300 Inspect Row-Buf 277400 Tallying Stmt-Start 277500 For Leading Spaces 277600 Add +1 To Stmt-Start 277700 Compute SQL-Stmt-Len = SQL-Stmt-Len - (Stmt-Start - 1) 277800 Move Row-Buf (Stmt-Start:SQL-Stmt-Len) 277900 To SQL-Stmt-Txt 278000 When Connect-SQL-Stmt 278100 And ( SS-Word-2-Space 278200 Or SS-Word-2-To 278300 Or SS-Word-2-Reset) 278400 Continue 278500 When Set-SQL-Stmt 278600 And SS-Word-2-Current 278700 And SS-Word-3-PackageSet 278800 And Dummy-Equal-Sign 278900 Continue 279000 When Get-SQL-Stmt 279100 And SS-Word-2-User 279200 Move Spaces To Row-Buf 279300 When Get-SQL-Stmt 279400 And SS-Word-2-Current 279500 And ( SS-Word-3-PackageSet 279600 Or SS-Word-3-TimeZone 279700 Or SS-Word-3-Date 279800 Or SS-Word-3-Time 279900 Or SS-Word-3-TimeStamp 280000 Or SS-Word-3-SqlId 280100 Or SS-Word-3-Server) 280200 Move Spaces To Row-Buf 280300 When Other 280400 Set Normal-SQL-Stmt To True 280500 End-Evaluate 280600 . 280700/ 280800 255-Continue-With-Execute. 280900 281000 If SQLD = Zero Then 281100* Set the SQLDA Rexx variables 281200 Perform 600-Set-Rexx-SQLDA-Vars 281300* Execute non-select statement immediately 281400 Exec SQL 281500 EXECUTE S1 USING DESCRIPTOR :RexxVars-SQLDA 281600 End-Exec 281700* Move Sqlcode To Num-Disp-15 281800* Display 'Execute sqlcode = ' num-disp-15 281900 If SQLCode NOT = Zero Then 282000 Move +4 To CAF-Hold-Rc 282100 End-If 282200* Set the SQLCA variables telling the Rexx exec what 282300* happened 282400 Perform 500-Set-Rexx-SQLCA-Vars 282500* Check to see if statement failed. If it did, then 282600* Roll Back Work and terminate program. 282700 Perform 280-Check-For-RollBack 282800 Else 282900* Go handle the SELECT statement 283000 Perform 300-Process-Select-Statement 283100 End-If 283200 . 283300/ 283400 270-Set-SQLSNO-Value. 283500 283600* Format statement counter 283700 Move Statement-Counter To Stem-Index-N 283800 Perform 910-Format-Stem-Index 283900 Set EXCOM-Set-Variable-Direct(1) To True 284000 Set EXCOM-ShvNext(1) To Null 284100 Call 'Set-Pointer' Using RXDB2-SQLSNO 284200 EXCOM-ShvNamA(1) 284300 Call 'Set-Pointer' Using Stem-Index-A 284400 EXCOM-ShvValA(1) 284500 Move Length Of RXDB2-SQLSNO To EXCOM-ShvNamL(1) 284600 Move Zero To EXCOM-ShvValL(1) 284700 Inspect Stem-Index-A 284800 Tallying EXCOM-ShvValL(1) 284900 For Characters Before Initial Space 285000 Perform 900-Call-IRXEXCOM 285100 285200* Save statement counter for use in multiple result table stem 285300 Move Stem-Index-A To Statement-Counter-A 285400 Move EXCOM-ShvValL(1) To Statement-Counter-A-Len 285500 . 285600/ 285700 280-Check-For-RollBack. 285800 285900* Check to see if statement failed. If it did, then 286000* Roll Back Work and terminate program. 286100 If SQLCode < Zero Then 286200 If (Reuse-Attach And (NOT Detach-Requested)) 286300 Or Attach-Requested Then 286400 Continue 286500 Else 286600 Exec SQL 286700 ROLLBACK WORK 286800 End-Exec 286900 If SQLCode < Zero 287000 And SQLCode NOT = -999 Then 287100 Move +8 To CAF-Hold-Rc 287200 Perform 500-Set-Rexx-SQLCA-Vars 287300 End-If 287400 End-If 287500 Perform 990-Terminate 287600 End-If 287700 . 287800/ 287900 290-Get-Parm-Marker-Values. 288000 288100*--- If multiple statements, get varlist for this stmt 288200* (otherwise, varlist was supplied as fifth argument and is 288300* already in varlist buffer). 288400 If Multiple-SQL-Statements 288500 And Arg-PMRV-Stem-Var NOT = Spaces Then 288600 Perform 292-Get-VarList-From-Stem 288700 End-If 288800 288900*--- Spin through Arg-PMRV-Buf finding Rexx variable names, 289000* getting their values. Variable names are blank delimited. 289100 Move 1 To Arg-PMRV-Offset 289200 Move Zero To Arg-PMRV-Var-Ctr 289300 Call 'Set-Pointer' Using Arg-PMRV-Value-Buf 289400 Arg-PMRV-Ptr 289500 Perform Varying Arg-PMRV-Var-Pos From 1 By 1 289600 Until Arg-PMRV-Var-Pos > Arg-PMRV-Var-Buf-Len 289700 If Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:1) NOT = Space Then 289800 Add 1 To Arg-PMRV-Var-Ctr 289900 Perform 294-Get-Variable-Value 290000 Perform 293-Check-VarVal-Buf-Overflow 290100 Perform 295-Put-Var-Value-In-Buf 290200 End-If 290300 End-Perform 290400 Move Arg-PMRV-Var-Ctr To RexxVars-SQLD 290500 . 290600/ 290700 292-Get-VarList-From-Stem. 290800 290900 Move Spaces To Arg-PMRV-Var-Name 291000 Arg-PMRV-Var-Buf 291100 String Arg-PMRV-Stem-Var 291200 Statement-Counter-A 291300 Delimited By Spaces 291400 Into Arg-PMRV-Var-Name 291500 End-String 291600 Move Zero To EXCOM-ShvNamL(1) 291700 Inspect Arg-PMRV-Var-Name 291800 Tallying EXCOM-ShvNamL(1) 291900 For Characters Before Initial Space 292000*--- Fetch contents of variable 292100* Display 'Getting varlist under stem "' 292200* Arg-PMRV-Var-Name (1:EXCOM-ShvNamL(1)) '"' 292300 Set EXCOM-Fetch-Variable-Direct(1) To True 292400 Set EXCOM-ShvNext(1) To Null 292500 Call 'Set-Pointer' Using Arg-PMRV-Var-Name 292600 EXCOM-ShvNamA(1) 292700 Call 'Set-Pointer' Using Arg-PMRV-Var-Buf 292800 EXCOM-ShvValA(1) 292900 Compute EXCOM-ShvBufL(1) = Length Of Arg-PMRV-Var-Buf 293000 Perform 900-Call-IRXEXCOM 293100 Evaluate True 293200 When EXCOM-Trunc-Occured(1) 293300 Display 'Variable list under stem "' 293400 Arg-PMRV-Var-Name (1:EXCOM-ShvNamL(1)) '"' 293500 Move Length Of Arg-PMRV-Var-Buf To Num-Disp-15 293600 Display 'is too long. Max length allowed is ' 293700 Num-Disp-15 ' bytes' 293800 Move EXCOM-ShvValL(1) To Num-Disp-15 293900 Display 'Length supplied is ' 294000 Num-Disp-15 ' bytes' 294100 Display 'RXDB2V23 is terminating.' 294200 Move +8 To CAF-Hold-Rc 294300 Move -999 To SQLCODE 294400 Perform 280-Check-For-RollBack 294500 When EXCOM-Var-NOT-Found(1) 294600 Or Arg-PMRV-Var-Buf = Spaces 294700 Move Zero To Arg-PMRV-Var-Buf-Len 294800 RexxVars-SQLD 294900 When Other 295000 Move EXCOM-ShvValL(1) To Arg-PMRV-Var-Buf-Len 295100 Inspect Arg-PMRV-Var-Buf 295200 Converting Lower-Case-Chars 295300 To Upper-Case-Chars 295400 Inspect Arg-PMRV-Var-Buf 295500 Converting ',:;' 295600 To Spaces 295700 End-Evaluate 295800 . 295900/ 296000 293-Check-VarVal-Buf-Overflow. 296100 296200 If Arg-PMRV-Offset > Length Of Arg-PMRV-Value-Buf Then 296300* Combined variable values exceed size of VarVal buffer 296400 Display 'Combined length of Rexx variable values' 296500 ' exceeds length of program buffer' 296600 Display 'for SQL statement number ' 296700 Statement-Counter-A (1:Statement-Counter-A-Len) 296800 Move Length Of Arg-PMRV-Value-Buf To Num-Disp-15 296900 Display 'Max allowable combined varval length : ' 297000 Num-Disp-15 297100 Display 'Variable whose value overflows buffer "' 297200 Arg-PMRV-Var-Name (1:Arg-PMRV-Var-Len) '"' 297300 Display 'RXDB2V23 is terminating.' 297400 Move +8 To CAF-Hold-Rc 297500 Move -999 To SQLCODE 297600 Perform 280-Check-For-RollBack 297700 End-If 297800 . 297900/ 298000 294-Get-Variable-Value. 298100 298200 Set Arg-PMRV-Type-Undefined To True 298300 Move Zero To Tally2 Tally3 298400 Move Zero To Arg-PMRV-Var-Len 298500 Compute Tally = Arg-PMRV-Var-Buf-Len + 1 298600 - Arg-PMRV-Var-Pos 298700 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally) 298800 Tallying Tally3 298900 For Characters Before Initial Space 299000 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally3) 299100 Tallying Tally2 For All '/' 299200 Evaluate True 299300 When Tally2 = Zero 299400*------- In this case, no datatype specifier was supplied, so 299500* assume undefined. 299600 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally) 299700 Tallying Arg-PMRV-Var-Len 299800 For Characters Before Initial Space 299900 Move Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Arg-PMRV-Var-Len) 300000 To Arg-PMRV-Var-Name 300100 Move Arg-PMRV-Var-Len 300200 To EXCOM-ShvNamL(1) 300300 Add Arg-PMRV-Var-Len 300400 To Arg-PMRV-Var-Pos 300500 When Tally2 = 1 300600*------- In this case, a datatype specifier was supplied, so 300700* get it. 300800 300900*------- Extract Rexx variable name 301000 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally) 301100 Tallying Arg-PMRV-Var-Len 301200 For Characters Before Initial '/' 301300 Move Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Arg-PMRV-Var-Len) 301400 To Arg-PMRV-Var-Name 301500 Move Arg-PMRV-Var-Len 301600 To EXCOM-ShvNamL(1) 301700 Add Arg-PMRV-Var-Len 301800 To Arg-PMRV-Var-Pos 301900*------- Step one beyond the '/' 302000 Add +1 302100 To Arg-PMRV-Var-Pos 302200 302300*------- Extract datatype value 302400 Compute Tally = Arg-PMRV-Var-Buf-Len + 1 302500 - Arg-PMRV-Var-Pos 302600 Move Zero To Tally2 302700 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally) 302800 Tallying Tally2 302900 For Characters Before Initial Space 303000 If Tally2 > Zero Then 303100 Move Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally2) 303200 To Arg-PMRV-Data-Type 303300 Add Tally2 303400 To Arg-PMRV-Var-Pos 303500 End-If 303600 If NOT Arg-PMRV-Type-Valid Then 303700 Display 'Rexx variable datatype specification "' 303800 Arg-PMRV-Data-Type '"' 303900 ' is invalid.' 304000 Display 'RXDB2V23 is terminating.' 304100 Move +8 To CAF-Hold-Rc 304200 Move -999 To SQLCODE 304300 Perform 280-Check-For-RollBack 304400 End-If 304500 When Other 304600 Move Zero To Tally2 304700 Inspect Arg-PMRV-Var-Buf(Arg-PMRV-Var-Pos:Tally) 304800 Tallying Tally2 304900 For Characters Before Initial Space 305000 Display 'Rexx variable specification beginning "' 305100 Arg-PMRV-Var-Buf (Arg-PMRV-Var-Pos:Tally2) 305200 '"' 305300 Display 'in SQL statement number ' 305400 Statement-Counter-A (1:Statement-Counter-A-Len) 305500 Display 'is invalid.' 305600 Display 'RXDB2V23 is terminating.' 305700 Move +8 To CAF-Hold-Rc 305800 Move -999 To SQLCODE 305900 Perform 280-Check-For-RollBack 306000 End-Evaluate 306100*--- Fetch contents of variable (into Row-Buf because it's 306200* available) 306300 Set EXCOM-Fetch-Variable-Direct(1) To True 306400 Set EXCOM-ShvNext(1) To Null 306500 Call 'Set-Pointer' Using Arg-PMRV-Var-Name 306600 EXCOM-ShvNamA(1) 306700 Call 'Set-Pointer' Using Row-Buf 306800 EXCOM-ShvValA(1) 306900 Move Length Of Row-Buf To EXCOM-ShvBufL(1) 307000 Perform 900-Call-IRXEXCOM 307100 If EXCOM-Trunc-Occured(1) Then 307200 Display 'Variable value for Rexx variable "' 307300 Arg-PMRV-Var-Name (1:EXCOM-ShvNamL(1)) '"' 307400 Display 'in SQL statement number ' 307500 Statement-Counter-A (1:Statement-Counter-A-Len) 307600 Move Length Of Row-Buf To Num-Disp-15 307700 Display 'is too long. Max length allowed is ' 307800 Num-Disp-15 ' bytes' 307900 Move EXCOM-ShvValL(1) To Num-Disp-15 308000 Display 'Length supplied is ' 308100 Num-Disp-15 ' bytes' 308200 Display 'RXDB2V23 is terminating.' 308300 Move +8 To CAF-Hold-Rc 308400 Move -999 To SQLCODE 308500 Perform 280-Check-For-RollBack 308600 End-If 308700 . 308800/ 308900 295-Put-Var-Value-In-Buf. 309000 309100* Display ' ' 309200* Display 'Getting Value of variable "' 309300* Arg-PMRV-Var-Name (1:EXCOM-ShvNamL(1)) '" ...' 309400 309500 Set RexxVars-SQLDATA(Arg-PMRV-Var-Ctr) To Arg-PMRV-Ptr 309600 If EXCOM-Var-NOT-Found(1) Then 309700*----- Variable not found, so take it to mean null value 309800 Perform 296-Process-Null-Value 309900 Else 310000*----- Variable found, so point to value in buffer 310100 Perform 297-Process-Actual-Value 310200 End-If 310300 . 310400/ 310500 296-Process-Null-Value. 310600 310700* Display 'Variable is not initialized (assuming null value)' 310800 Evaluate True 310900 When Arg-PMRV-Type-Date 311000 Move +10 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 311100 Set RxVar-Type-Date-N(Arg-PMRV-Var-Ctr) To True 311200 When Arg-PMRV-Type-Time 311300 Move +8 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 311400 Set RxVar-Type-Time-N(Arg-PMRV-Var-Ctr) To True 311500 When Arg-PMRV-Type-TimeStamp 311600 Move +26 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 311700 Set RxVar-Type-TimeStamp-N(Arg-PMRV-Var-Ctr) To True 311800 When Arg-PMRV-Type-Char 311900 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 312000 Set RxVar-Type-Char-N(Arg-PMRV-Var-Ctr) To True 312100 When Arg-PMRV-Type-VarChar 312200 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 312300 Set RxVar-Type-VarChar-N(Arg-PMRV-Var-Ctr) To True 312400 When Arg-PMRV-Type-LongVarChar 312500 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 312600 Set RxVar-Type-LongVarChar-N(Arg-PMRV-Var-Ctr) To True 312700 When Arg-PMRV-Type-SmallInt 312800 Move +2 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 312900 Set RxVar-Type-SmallInt-N(Arg-PMRV-Var-Ctr) To True 313000 When Arg-PMRV-Type-Integer 313100 Move +4 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 313200 Set RxVar-Type-Integer-N(Arg-PMRV-Var-Ctr) To True 313300 When Arg-PMRV-Type-Decimal 313400 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 313500 Set RxVar-Type-Decimal-N(Arg-PMRV-Var-Ctr) To True 313600 When Arg-PMRV-Type-Float 313700 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 313800 Set RxVar-Type-Float-N(Arg-PMRV-Var-Ctr) To True 313900 When Arg-PMRV-Type-Graphic 314000 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 314100 Set RxVar-Type-Graphic-N(Arg-PMRV-Var-Ctr) To True 314200 When Arg-PMRV-Type-VarGraphic 314300 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 314400 Set RxVar-Type-VarGraphic-N(Arg-PMRV-Var-Ctr) To True 314500 When Other 314600 Move +1 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 314700 Set RxVar-Type-Char-N(Arg-PMRV-Var-Ctr) To True 314800 End-Evaluate 314900 Add RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 315000 To Arg-PMRV-Ptr-Num 315100 Arg-PMRV-Offset 315200 Set RexxVars-SQLIND(Arg-PMRV-Var-Ctr) To Arg-PMRV-Ptr 315300 Move -1 To DFC-SmallInt-Num 315400 Move DFC-SmallInt-A 315500 To Arg-PMRV-Value-Buf (Arg-PMRV-Offset:2) 315600 Move Low-Values To RexxVars-SQLNAME(Arg-PMRV-Var-Ctr) 315700 Add +2 To Arg-PMRV-Ptr-Num 315800 Arg-PMRV-Offset 315900 . 316000/ 316100 297-Process-Actual-Value. 316200 316300* Display 'Variable value is "' 316400* Row-Buf (1:EXCOM-ShvValL(1)) 316500* '"' 316600 316700*--- If datatype was explicitly specified, then act on it 316800 Evaluate True 316900 When Arg-PMRV-Type-Char 317000 Or Arg-PMRV-Type-VarChar 317100 Or Arg-PMRV-Type-LongVarChar 317200 Perform 299-Process-Character-Value 317300 When Arg-PMRV-Type-Date 317400 Perform 299-Process-Character-Value 317500 Set RxVar-Type-Date(Arg-PMRV-Var-Ctr) To True 317600 When Arg-PMRV-Type-Time 317700 Perform 299-Process-Character-Value 317800 Set RxVar-Type-Time(Arg-PMRV-Var-Ctr) To True 317900 When Arg-PMRV-Type-TimeStamp 318000 Perform 299-Process-Character-Value 318100 Set RxVar-Type-TimeStamp(Arg-PMRV-Var-Ctr) To True 318200 When (Arg-PMRV-Type-SmallInt Or Arg-PMRV-Type-Integer) 318300 And Row-Buf (1:EXCOM-ShvValL(1)) Is Integer-Digits 318400 Perform 298-Process-Integer-Value 318500 When Arg-PMRV-Type-Decimal 318600 And Row-Buf (1:EXCOM-ShvValL(1)) Is Decimal-Digits 318700 And EXCOM-ShvValL(1) > 1 318800 Perform 29x-Process-Decimal-Value 318900* When Arg-PMRV-Type-Float 319000* When Arg-PMRV-Type-Graphic 319100* When Arg-PMRV-Type-VarGraphic 319200 When Other 319300 Evaluate True 319400 When Row-Buf (1:EXCOM-ShvValL(1)) Is Integer-Digits 319500 Perform 298-Process-Integer-Value 319600 When Row-Buf (1:EXCOM-ShvValL(1)) Is Decimal-Digits 319700 And EXCOM-ShvValL(1) > 1 319800* (must be longer than one byte, otherwise it could be 319900* just a decimal point ".", which should be 320000* considered a character string) 320100 Perform 29x-Process-Decimal-Value 320200 When Other 320300 Perform 299-Process-Character-Value 320400 End-Evaluate 320500 End-Evaluate 320600 320700*--- Set buffer pointer up by value length (minimum of 1 byte) 320800 If RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) = Zero Then 320900 Add +1 321000 To Arg-PMRV-Ptr-Num 321100 Arg-PMRV-Offset 321200 Else 321300 If RxVar-Type-Decimal(Arg-PMRV-Var-Ctr) Then 321400 Add EXCOM-ShvValL(1) 321500 To Arg-PMRV-Ptr-Num 321600 Arg-PMRV-Offset 321700 Else 321800 Add RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 321900 To Arg-PMRV-Ptr-Num 322000 Arg-PMRV-Offset 322100 End-If 322200 End-If 322300 322400*--- Set null indicator to "Not Null" 322500 Set RexxVars-SQLIND(Arg-PMRV-Var-Ctr) To Arg-PMRV-Ptr 322600 Move Zero To DFC-SmallInt-Num 322700 Move DFC-SmallInt-A 322800 To Arg-PMRV-Value-Buf (Arg-PMRV-Offset:2) 322900 Move Low-Values To RexxVars-SQLNAME(Arg-PMRV-Var-Ctr) 323000 Add +2 To Arg-PMRV-Ptr-Num 323100 Arg-PMRV-Offset 323200 . 323300/ 323400 298-Process-Integer-Value. 323500 323600*--- Validate form of number (i.e. valid integer) 323700 Move Zero To Tally 323800 Set Arg-PMRV-Value-Sign-None To True 323900 Inspect Row-Buf (1:EXCOM-ShvValL(1)) 324000 Tallying Tally 324100 For All '-' 324200 Inspect Row-Buf (1:EXCOM-ShvValL(1)) 324300 Tallying Tally 324400 For All '+' 324500 Evaluate True 324600 When Tally = Zero 324700 Perform 2981-Continue-Integer-Value 324800 When Tally = 1 324900 If Row-Buf (1:1) = '-' Or '+' Then 325000 Move Row-Buf (1:1) To Arg-PMRV-Value-Sign 325100 Move Space To Row-Buf (1:1) 325200 Perform 2981-Continue-Integer-Value 325300 Else 325400 Perform 299-Process-Character-Value 325500 End-If 325600 When Other 325700 Perform 299-Process-Character-Value 325800 End-Evaluate 325900 . 326000/ 326100 2981-Continue-Integer-Value. 326200 326300 If Arg-PMRV-Value-Sign-Neg 326400 Or Arg-PMRV-Value-Sign-Pos Then 326500 Move +2 To Arg-PMRV-Value-Beg-Pos 326600 Move EXCOM-ShvValL(1) To Arg-PMRV-Value-Len 326700 Subtract +1 From Arg-PMRV-Value-Len 326800 Else 326900 Move +1 To Arg-PMRV-Value-Beg-Pos 327000 Move EXCOM-ShvValL(1) To Arg-PMRV-Value-Len 327100 End-If 327200 Evaluate True 327300*----- When it's a "small" integer 327400 When Arg-PMRV-Value-Len <= Length Of Arg-PMRV-Smint-R 327500 Move Row-Buf (Arg-PMRV-Value-Beg-Pos:Arg-PMRV-Value-Len) 327600 To Arg-PMRV-Smint-R 327700 Inspect Arg-PMRV-Smint-R 327800 Converting Space To Zero 327900*------- Even though the value is 5 or fewer digits, it may be 328000* outside bounds of 16-bit signed integer (boundaries are 328100* +32767 <-> -32768). If so, treat it as a LARGE INTEGER. 328200 If Arg-PMRV-Value-Sign-Neg 328300 Multiply -1 By Arg-PMRV-Smint 328400 End-If 328500 If Arg-PMRV-Smint >= -32768 328600 And Arg-PMRV-Smint <= +32767 Then 328700*--------- In this case, it's actually a SMALL INTEGER, so treat 328800* it that way 328900 Move Arg-PMRV-Smint To DFC-SmallInt-Num-5 329000 Move Length Of DFC-SmallInt-A 329100 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 329200 Move DFC-SmallInt-A-5 (3:2) 329300 To Arg-PMRV-Value-Buf 329400 (Arg-PMRV-Offset:RexxVars-SQLLEN(Arg-PMRV-Var-Ctr)) 329500 Set RxVar-Type-SmallInt(Arg-PMRV-Var-Ctr) To True 329600 Else 329700*--------- In this case, it's actually a LARGE INTEGER, so treat 329800* it that way 329900 Move 330000 Row-Buf (Arg-PMRV-Value-Beg-Pos:Arg-PMRV-Value-Len) 330100 To Arg-PMRV-Int-R 330200 Inspect Arg-PMRV-Int-R 330300 Converting Space To Zero 330400 If Arg-PMRV-Value-Sign-Neg 330500 Multiply -1 By Arg-PMRV-Int 330600 End-If 330700 Move Arg-PMRV-Int To DFC-Integer-Num-10 330800 Move Length Of DFC-Integer-A 330900 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 331000 Move DFC-Integer-A-10 (5:4) 331100 To Arg-PMRV-Value-Buf 331200 (Arg-PMRV-Offset:RexxVars-SQLLEN(Arg-PMRV-Var-Ctr)) 331300 Set RxVar-Type-Integer(Arg-PMRV-Var-Ctr) To True 331400 End-If 331500*----- When it's a "large" integer 331600 When Arg-PMRV-Value-Len <= Length Of Arg-PMRV-Int-R 331700 Move Row-Buf (Arg-PMRV-Value-Beg-Pos:Arg-PMRV-Value-Len) 331800 To Arg-PMRV-Int-R 331900 Inspect Arg-PMRV-Int-R 332000 Converting Space To Zero 332100*------- Even though the value is 10 or fewer digits, it may be 332200* outside bounds of 32-bit signed integer (boundaries are 332300* +2147483647 <-> -2147483648). If so, treat it as a 332400* character string. 332500 If Arg-PMRV-Value-Sign-Neg 332600 Multiply -1 By Arg-PMRV-Int 332700 End-If 332800 If Arg-PMRV-Int >= -2147483648 332900 And Arg-PMRV-Int <= +2147483647 Then 333000*--------- In this case, it's actually a LARGE INTEGER, so treat 333100* it that way 333200 Move Arg-PMRV-Int To DFC-Integer-Num-10 333300 Move Length Of DFC-Integer-A 333400 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 333500 Move DFC-Integer-A-10 (5:4) 333600 To Arg-PMRV-Value-Buf 333700 (Arg-PMRV-Offset:RexxVars-SQLLEN(Arg-PMRV-Var-Ctr)) 333800 Set RxVar-Type-Integer(Arg-PMRV-Var-Ctr) To True 333900 Else 334000*--------- In this case, it's actually a CHAR string, so treat 334100* it that way 334200 Perform 299-Process-Character-Value 334300 End-If 334400*----- Otherwise, treat it like a character string 334500 When Other 334600 Perform 299-Process-Character-Value 334700 End-Evaluate 334800 . 334900/ 335000 299-Process-Character-Value. 335100 335200 Move +1 To Buf-Start 335300 If ( (Row-Buf (1:1) = '"' 335400 And Row-Buf (EXCOM-ShvValL(1):1) = '"') 335500 Or (Row-Buf (1:1) = '''' 335600 And Row-Buf (EXCOM-ShvValL(1):1) = '''') 335700 ) 335800 And EXCOM-ShvValL(1) >= 3 Then 335900 336000* Make sure that braketed data is integer/decimal data only 336100 Compute Tally = EXCOM-ShvValL(1) - 2 336200 If Row-Buf (2:Tally) Is Integer-Digits 336300 Or Row-Buf (2:Tally) Is Decimal-Digits Then 336400 Move Tally To EXCOM-ShvValL(1) 336500 Move +2 To Buf-Start 336600 End-If 336700 336800 End-If 336900 Move EXCOM-ShvValL(1) 337000 To RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 337100 If RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) > 254 337200 Or RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) = Zero Then 337300* (In case variable was zero-length string, fake it to be 337400* a 1 byte (zero length) VarChar string.) 337500 Move RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) 337600 To DFC-SmallInt-Num-5 337700 Move DFC-SmallInt-A-5 (3:2) 337800 To Arg-PMRV-Value-Buf (Arg-PMRV-Offset:2) 337900 Add +2 To Arg-PMRV-Ptr-Num 338000 Arg-PMRV-Offset 338100 Set RxVar-Type-VarChar(Arg-PMRV-Var-Ctr) To True 338200 Else 338300 Set RxVar-Type-Char(Arg-PMRV-Var-Ctr) To True 338400 End-If 338500 Move Row-Buf (Buf-Start:EXCOM-ShvValL(1)) 338600 To Arg-PMRV-Value-Buf 338700 (Arg-PMRV-Offset:EXCOM-ShvValL(1)) 338800 . 338900/ 339000 29x-Process-Decimal-Value. 339100 339200*--- Validate form of number (i.e. valid decimal number) 339300 Move Zero To Tally 339400 Inspect Row-Buf (1:EXCOM-ShvValL(1)) 339500 Tallying Tally 339600 For All '-' 339700 Inspect Row-Buf (1:EXCOM-ShvValL(1)) 339800 Tallying Tally 339900 For All '+' 340000 Evaluate True 340100 When Tally = Zero 340200 Perform 29x1-Continue-Decimal-Value 340300 When Tally = 1 340400 If Row-Buf (1:1) = '-' Or '+' Then 340500 Perform 29x1-Continue-Decimal-Value 340600 Else 340700 Perform 299-Process-Character-Value 340800 End-If 340900 When Other 341000 Perform 299-Process-Character-Value 341100 End-Evaluate 341200 . 341300/ 341400 29x1-Continue-Decimal-Value. 341500 341600*--- Check for correct decimal point usage 341700 Move Zero To Tally 341800 Inspect Row-Buf (1:EXCOM-ShvValL(1)) 341900 Tallying Tally 342000 For All '.' 342100 If Tally = 1 342200 Perform 29x11-Continue-Decimal-Value 342300 Else 342400 Perform 299-Process-Character-Value 342500 End-If 342600 . 342700/ 342800 29x11-Continue-Decimal-Value. 342900 343000* Display 'Variable value "' 343100* Row-Buf (1:EXCOM-ShvValL(1)) 343200* '"' 343300* Display 'is being processed as a decimal number' 343400 343500 Set RxVar-Type-Decimal(Arg-PMRV-Var-Ctr) To True 343600 343700*--- Determine algebraic sign 343800 If Row-Buf (1:1) = '-' Then 343900 Move -1 To Dec-Num-Sign 344000* Display 'Number is negative' 344100 Else 344200 Move +1 To Dec-Num-Sign 344300* Display 'Number is positive' 344400 End-If 344500 344600*--- Determine start of number 344700 Move +1 To Buf-Start 344800 If Row-Buf (1:1) = '-' Or '+' Then 344900 Move +2 To Buf-Start 345000 Subtract 1 From EXCOM-ShvValL(1) 345100 End-If 345200 345300*--- Stage number for massaging 345400 Move Row-Buf (Buf-Start:EXCOM-ShvValL(1)) 345500 To Dec-Num-Disp-A 345600 345700*--- Determine Scale and Precision 345800 Compute Dec-Num-Prec = EXCOM-ShvValL(1) - 1 345900 Move Zero To Dec-Num-Ctr 346000 Inspect Row-Buf (Buf-Start:EXCOM-ShvValL(1)) 346100 Tallying Dec-Num-Ctr 346200 For Characters 346300 Before Initial '.' 346400 Compute Dec-Num-Scale = Dec-Num-Prec - Dec-Num-Ctr 346500 346600* Move Dec-Num-Prec To Num-Disp-15 346700* Display 'Precision = ' Num-Disp-15 346800* Move Dec-Num-Scale To Num-Disp-15 346900* Display 'Scale = ' Num-Disp-15 347000 347100*--- Massage Display version of number (right just, pad left zero) 347200* to packed decimal 347300 Move Zero To Dec-Num-Ctr 347400 Inspect Dec-Num-Disp-A 347500 Tallying Dec-Num-Ctr 347600 For Characters 347700 Before Initial '.' 347800 Add +1 To Dec-Num-Ctr 347900 Perform Varying Tally From Dec-Num-Ctr By -1 348000 Until Tally < 2 348100 Compute Dec-Num-Alt = Tally - 1 348200 Move Dec-Num-Disp-A (Dec-Num-Alt:1) 348300 To Dec-Num-Disp-A (Tally:1) 348400 End-Perform 348500 Inspect Dec-Num-Disp-A 348600 Converting Space To Zero 348700 Move Dec-Num-Disp-N 348800 To Dec-Num-Packed 348900 Compute Dec-Num-Packed = Dec-Num-Packed * Dec-Num-Sign 349000 349100*--- Get SQLDA length (precision,scale) 349200 Move Dec-Num-Prec-A 349300 To Dec-Num-Prec-Fld 349400 Move Dec-Num-Scale-A 349500 To Dec-Num-Scale-Fld 349600 Move Dec-Num-Prec-1 349700 To RexxVars-SQLLEN-A(Arg-PMRV-Var-Ctr) (1:1) 349800 Move Dec-Num-Scale-1 349900 To RexxVars-SQLLEN-A(Arg-PMRV-Var-Ctr) (2:1) 350000 350100* Move RexxVars-SQLLEN(Arg-PMRV-Var-Ctr) To Num-Disp-15 350200* Display 'Decimal of SQLLEN = ' Num-Disp-15 350300 350400*--- Get buffer displacement length (different from SQLDA length) 350500 Compute Tally = Dec-Num-Prec / 2 350600 Compute EXCOM-ShvValL(1) = Tally + 1 350700 350800*--- Move packed value to buffer 350900* Move Dec-Num-Packed To Num-Disp-15 351000* Display 'Packed Value = ' Num-Disp-15 351100 Compute Tally = Length Of Dec-Num-Packed-A 351200 - EXCOM-ShvValL(1) 351300 + 1 351400 Move Dec-Num-Packed-A (Tally:EXCOM-ShvValL(1)) 351500 To Arg-PMRV-Value-Buf 351600 (Arg-PMRV-Offset:EXCOM-ShvValL(1)) 351700 . 351800/ 351900 300-Process-Select-Statement. 352000 352100* Evaluate the result table structure, then point the SQLDA to 352200* positions in the pre-defined Row-Buf buffer where result 352300* columns can be placed. 352400 Perform 400-Point-SQLDA-To-Storage 352500 352600* Set the SQLDA Rexx variables 352700 Perform 600-Set-Rexx-SQLDA-Vars 352800 352900* Get the name of the Rexx stem variable into which result 353000* table is to be mapped 353100 Perform 700-Prepare-Result-Table-Stem 353200 353300* Set Stem.0 to Zero before mapping result table 353400 Move Zero To Row-Counter 353500 Perform 800-Set-Stem-Dot-Zero 353600 353700* Open the cursor on the statement 353800 Exec SQL 353900 OPEN C1 USING DESCRIPTOR :RexxVars-SQLDA 354000 End-Exec 354100 Evaluate True 354200 When SQLCode = Zero 354300 Continue 354400 When SQLCode > Zero 354500 Move +4 To CAF-Hold-Rc 354600 When Other 354700 Move +4 To CAF-Hold-Rc 354800* Set SQLCA variables to tell Rexx exec what happened 354900* during Cursor Open 355000 Perform 500-Set-Rexx-SQLCA-Vars 355100 Perform 280-Check-For-RollBack 355200 End-Evaluate 355300 355400* If cursor open worked, then fetch first row into Row-Buf 355500 Exec SQL 355600 FETCH C1 USING DESCRIPTOR :SQLDA 355700 End-Exec 355800 Evaluate True 355900 When SQLCode = Zero 356000 Continue 356100 When SQLCode > Zero 356200* Set Stem.0 to Zero, set SQLCA Rexx variables 356300 Move +4 To CAF-Hold-Rc 356400 Perform 800-Set-Stem-Dot-Zero 356500 Perform 500-Set-Rexx-SQLCA-Vars 356600 When SQLCode = -804 356700* SQLDA is too long for this release of DB2, so reset it. 356800* (This is OK because there were 300 or fewer columns 356900* for this result table. If there were more, PREPARE 357000* would have failed with -840.) 357100 Move +13216 To SQLDABC 357200 Move +300 To SQLN 357300* Set the SQLDA Rexx variables again 357400 Perform 600-Set-Rexx-SQLDA-Vars 357500* Try first row fetch again. 357600 Exec SQL 357700 FETCH C1 USING DESCRIPTOR :SQLDA 357800 End-Exec 357900 Evaluate True 358000 When SQLCode = Zero 358100 Continue 358200 When SQLCode > Zero 358300* Set Stem.0 to Zero, set SQLCA Rexx variables 358400 Move +4 To CAF-Hold-Rc 358500 Perform 800-Set-Stem-Dot-Zero 358600 Perform 500-Set-Rexx-SQLCA-Vars 358700 When Other 358800* Something went wrong. Set SQLCA to indicate what 358900 Move +4 To CAF-Hold-Rc 359000 Perform 500-Set-Rexx-SQLCA-Vars 359100 Perform 280-Check-For-RollBack 359200 End-Evaluate 359300 When Other 359400* Something went wrong. Set SQLCA to indicate what 359500 Move +4 To CAF-Hold-Rc 359600 Perform 500-Set-Rexx-SQLCA-Vars 359700 Perform 280-Check-For-RollBack 359800 End-Evaluate 359900 360000* Fetch all rows of result table, placing their contents in 360100* stem variables 360200 Perform With Test Before 360300 Varying Row-Counter From 1 By 1 360400 Until SQLCode NOT = Zero 360500 Or Row-Counter > Fetch-Limit-C 360600 360700 Perform 350-Move-Data-To-Rexx-Vars 360800 360900 Exec SQL 361000 FETCH C1 USING DESCRIPTOR :SQLDA 361100 End-Exec 361200 Evaluate True 361300 When SQLCode = Zero 361400 Continue 361500 When SQLCode > Zero 361600 Continue 361700 When Other 361800* Set Stem.0 to indicate how many rows were fetched 361900* (Thus, how many rows are in the stem structure) 362000 Move +4 To CAF-Hold-Rc 362100 Perform 800-Set-Stem-Dot-Zero 362200 Perform 500-Set-Rexx-SQLCA-Vars 362300 Perform 280-Check-For-RollBack 362400 End-Evaluate 362500 362600 End-Perform 362700 362800* Set Stem.0 to indicate how many rows were fetched 362900* (Thus, how many rows are in the stem structure) 363000 Subtract 1 From Row-Counter 363100 Perform 800-Set-Stem-Dot-Zero 363200 363300* Close the cursor 363400 Exec SQL 363500 CLOSE C1 363600 End-Exec 363700 If SQLCode = Zero Then 363800* Only set SQLCode for cursor close if result table is not 363900* empty. 364000 If Row-Counter > Zero 364100 Or (Row-Counter = Zero And Fetch-Limit-C = Zero) Then 364200* Set SQLCA to indicate result of cursor close 364300 Perform 500-Set-Rexx-SQLCA-Vars 364400 End-If 364500 Else 364600* A problem which shouldn't happen. Program has to stop. 364700 Move SQLCode To Num-Disp 364800 Display 'Error Closing Cursor "C1"' 364900 Display 'SQLCode: ' Num-Disp 365000 Move +8 To CAF-Hold-Rc 365100* Set SQLCA to indicate result of cursor close 365200 Perform 500-Set-Rexx-SQLCA-Vars 365300* Terminate program 365400 Display 'RXDB2V23 encountered exception in processing' 365500 Display 'RXDB2V23 is terminating.' 365600 Perform 280-Check-For-RollBack 365700 End-If 365800 . 365900/ 366000 350-Move-Data-To-Rexx-Vars. 366100 366200* Prepare row portion of stem index 366300 Move Row-Counter To Stem-Index-N 366400 Perform 910-Format-Stem-Index 366500 Move Stem-Index-A To Row-Index 366600 366700* Move each column of the current row into the corresponding 366800* Rexx variables 366900 Perform Varying Col-Ctr From 1 By 1 367000 Until Col-Ctr > SQLD 367100 367200* Build the Rexx stem variable name for this column.row 367300 Perform 351-Build-Stem-Var-Name 367400 367500* If this column.row has null value, drop corresponding 367600* stem variable (This indicates to the calling Rexx exec 367700* that the column.row has the null value). Otherwise, 367800* format and stage the column.row value. 367900 If Col-Is-Nullable(Col-Ctr) 368000 And Value-Is-Null(Col-Ctr) 368100* Tell Rexx to drop stem.column.row 368200 Set EXCOM-Drop-Variable-Direct(Col-Ctr) To True 368300 Else 368400* Tell Rexx to set stem.column.row to value 368500 Set EXCOM-Set-Variable-Direct(Col-Ctr) To True 368600 Perform 352-Format-And-Stage-Result 368700 End-If 368800 368900* Point ahead to next ShvBlock 369000 Call 'Set-Pointer' Using EXCOM-ShvNext(Col-Ctr + 1) 369100 EXCOM-ShvNext(Col-Ctr) 369200 End-Perform 369300 369400* Set last ShvBlock forward pointer to null 369500 Set EXCOM-ShvNext(SQLD) To Null 369600 369700* Call IRXEXCOM to set this row's stem variable values 369800 Perform 900-Call-IRXEXCOM 369900 . 370000/ 370100 351-Build-Stem-Var-Name. 370200 370300* Build indexed stem name 370400 Move Col-Ctr To Stem-Index-N 370500 Perform 910-Format-Stem-Index 370600 Move Stem-Index-A To Col-Index 370700 Move Spaces To Stem-Row-Col-Var(Col-Ctr) 370800 If Multiple-SQL-Statements Then 370900 If Map-Col-Row Then 371000 String Stem-Var-Name 371100 Statement-Counter-A 371200 Delimited By Spaces 371300 '.' 371400 Delimited By Size 371500 Col-Index 371600 Delimited By Spaces 371700 '.' 371800 Delimited By Size 371900 Row-Index 372000 Delimited By Spaces 372100 Into Stem-Row-Col-Var(Col-Ctr) 372200 End-String 372300 Else 372400 String Stem-Var-Name 372500 Statement-Counter-A 372600 Delimited By Spaces 372700 '.' 372800 Delimited By Size 372900 Row-Index 373000 Delimited By Spaces 373100 '.' 373200 Delimited By Size 373300 Col-Index 373400 Delimited By Spaces 373500 Into Stem-Row-Col-Var(Col-Ctr) 373600 End-String 373700 End-If 373800 Else 373900 If Map-Col-Row Then 374000 String Stem-Var-Name 374100 Col-Index 374200 Delimited By Spaces 374300 '.' 374400 Delimited By Size 374500 Row-Index 374600 Delimited By Spaces 374700 Into Stem-Row-Col-Var(Col-Ctr) 374800 End-String 374900 Else 375000 String Stem-Var-Name 375100 Row-Index 375200 Delimited By Spaces 375300 '.' 375400 Delimited By Size 375500 Col-Index 375600 Delimited By Spaces 375700 Into Stem-Row-Col-Var(Col-Ctr) 375800 End-String 375900 End-If 376000 End-If 376100* Set EXCOM variable name length and address 376200 Move Zero To EXCOM-ShvNamL(Col-Ctr) 376300 Inspect Stem-Row-Col-Var(Col-Ctr) 376400 Tallying EXCOM-ShvNamL(Col-Ctr) 376500 For Characters Before Initial Space 376600 Call 'Set-Pointer' Using Stem-Row-Col-Var(Col-Ctr) 376700 EXCOM-ShvNamA(Col-Ctr) 376800 . 376900/ 377000 352-Format-And-Stage-Result. 377100 377200* Handle numeric and non-numeric columns 377300 377400 If Type-Integer(Col-Ctr) 377500 Or Type-Smallint(Col-Ctr) 377600 Or Type-Float(Col-Ctr) 377700 Or Type-Decimal(Col-Ctr) Then 377800* For numeric columns, do more evaluation 377900 Perform 353-Format-Numeric-Data 378000 Else 378100* For non-numeric cols, use SQLDA 378200 Set Col-Ptr To SQLDATA(Col-Ctr) 378300* Set EXCOM variable value length 378400 Move SQLLEN(Col-Ctr) 378500 To EXCOM-ShvValL(Col-Ctr) 378600* For varying-length columns, tweek address and length 378700 If Type-VarChar(Col-Ctr) 378800 Or Type-LongVarChar(Col-Ctr) 378900 Or Type-VarGraphic(Col-Ctr) 379000 Or Type-LongVarGraphic(Col-Ctr) 379100 Add 2 To Col-Ptr-Num 379200 Move Row-Buf (Col-Beg-Pos(Col-Ctr):2) 379300 To Value-Len-A 379400 Move Value-Len 379500 To EXCOM-ShvValL(Col-Ctr) 379600 End-If 379700* Point EXCOM to address of data 379800 Set EXCOM-ShvValA(Col-Ctr) To Col-Ptr 379900 End-If 380000 . 380100/ 380200 353-Format-Numeric-Data. 380300 380400 Evaluate True 380500 When Type-Integer(Col-Ctr) 380600* When value is negative (two's complement), then set high 380700* order bits on, otherwise set them off 380800 If Row-Buf (Col-Beg-Pos(Col-Ctr):1) > x'80' Then 380900 Move All x'FF' To DFC-Integer-A-10 381000 Else 381100 Move All x'00' To DFC-Integer-A-10 381200 End-If 381300 Move Row-Buf (Col-Beg-Pos(Col-Ctr):Col-Len(Col-Ctr)) 381400 To DFC-Integer-A-10 (5:4) 381500 381600********************************************************** 381700* Call 'Convert-To-Hex' Using 381800* By Content Length Of DFC-Integer-A-10 381900* By Reference DFC-Integer-A-10 382000* C2X-Return-Buf 382100* Compute Tally = 2 * Length Of DFC-Integer-A-10 382200* Display 'DFC-Integer-A-10 = ''' 382300* C2X-Return-Buf (1:Tally) '''x' 382400********************************************************** 382500 382600 Move DFC-Integer-Num-10 382700 To DFC-Integer-Disp 382800 Move DFC-Integer-Disp 382900 To DFC-Work-Field 383000 Move Zero To Char-Ctr 383100 Inspect DFC-Work-Field 383200 Tallying Char-Ctr 383300 For Leading Spaces 383400 Add 1 To Char-Ctr 383500 Move DFC-Work-Field (Char-Ctr:) 383600 To DFC-Result-Field(Col-Ctr) 383700 Call 'Set-Pointer' Using DFC-Result-Field(Col-Ctr) 383800 EXCOM-ShvValA(Col-Ctr) 383900 Compute 384000 EXCOM-ShvValL(Col-Ctr) 384100 = Char-Ctr - 1 - Length Of DFC-Work-Field 384200 End-Compute 384300 When Type-Smallint(Col-Ctr) 384400* When value is negative (two's complement), then set high 384500* order bits on, otherwise set them off 384600 If Row-Buf (Col-Beg-Pos(Col-Ctr):1) > x'80' Then 384700 Move All x'FF' To DFC-Smallint-A-5 384800 Else 384900 Move All x'00' To DFC-Smallint-A-5 385000 End-If 385100 Move Row-Buf (Col-Beg-Pos(Col-Ctr):Col-Len(Col-Ctr)) 385200 To DFC-Smallint-A-5 (3:2) 385300 Move DFC-Smallint-Num-5 385400 To DFC-Smallint-Disp 385500 Move DFC-Smallint-Disp 385600 To DFC-Work-Field 385700 Move Zero To Char-Ctr 385800 Inspect DFC-Work-Field 385900 Tallying Char-Ctr 386000 For Leading Spaces 386100 Add 1 To Char-Ctr 386200 Move DFC-Work-Field (Char-Ctr:) 386300 To DFC-Result-Field(Col-Ctr) 386400 Call 'Set-Pointer' Using DFC-Result-Field(Col-Ctr) 386500 EXCOM-ShvValA(Col-Ctr) 386600 Compute 386700 EXCOM-ShvValL(Col-Ctr) 386800 = Char-Ctr - 1 - Length Of DFC-Work-Field 386900 End-Compute 387000 When Type-Float(Col-Ctr) 387100 Evaluate True 387200 When Col-Len(Col-Ctr) = 4 387300 Move Row-Buf (Col-Beg-Pos(Col-Ctr):Col-Len(Col-Ctr)) 387400 To DFC-Float-S-A 387500 Move DFC-Float-S-Num 387600 To DFC-Float-Disp 387700 When Col-Len(Col-Ctr) = 8 387800 Move Row-Buf (Col-Beg-Pos(Col-Ctr):Col-Len(Col-Ctr)) 387900 To DFC-Float-D-A 388000 Move DFC-Float-D-Num 388100 To DFC-Float-Disp 388200 When Other 388300 Continue 388400 End-Evaluate 388500 Move DFC-Float-Disp (1:) 388600 To DFC-Work-Field 388700 Move Zero To Char-Ctr 388800 Inspect DFC-Work-Field 388900 Tallying Char-Ctr 389000 For Leading Spaces 389100 Add 1 To Char-Ctr 389200 Move DFC-Work-Field (Char-Ctr:) 389300 To DFC-Result-Field(Col-Ctr) 389400 Call 'Set-Pointer' Using DFC-Result-Field(Col-Ctr) 389500 EXCOM-ShvValA(Col-Ctr) 389600 Compute 389700 EXCOM-ShvValL(Col-Ctr) 389800 = Char-Ctr - 1 - Length Of DFC-Work-Field 389900 End-Compute 390000 When Type-Decimal(Col-Ctr) 390100* Put buffer contents into decimal work field 390200 Move Row-Buf (Col-Beg-Pos(Col-Ctr):Col-Len(Col-Ctr)) 390300 To DFC-Dec-Work-A 390400 Perform 920-Format-Decimal-Field 390500 Move DFC-Dec-Work-Disp 390600 To DFC-Work-Field 390700 Move Zero To Char-Ctr 390800* Find edited result in decimal work field 390900 Inspect DFC-Work-Field 391000 Tallying Char-Ctr 391100 For Leading Spaces 391200 Add 1 To Char-Ctr 391300* Extract algebraic sign from number 391400 Move DFC-Work-Field (Char-Ctr:1) 391500 To DFC-Dec-Sign 391600* Extract fractional part of number 391700 Compute Tally = 1 + Length Of DFC-Work-Field 391800 - Col-Scale(Col-Ctr) 391900 End-Compute 392000 Move DFC-Work-Field (Tally:) 392100 To Dec-Part 392200* Extract integral part of number 392300 Compute Tally = Length Of DFC-Dec-Work-Disp 392400 - Col-Scale(Col-Ctr) - 1 392500 End-Compute 392600* (Add 1 to pointer to skip sign) 392700 Add 1 To Char-Ctr 392800 Move DFC-Work-Field (Char-Ctr:Tally) 392900 To DFC-Result-Field(Col-Ctr) 393000* Strip leading zeros 393100 Move DFC-Result-Field(Col-Ctr) 393200 To DFC-Work-Field 393300 Inspect DFC-Work-Field 393400 Replacing Leading Spaces By Zeros 393500 Move Zero To Tally 393600 Inspect DFC-Work-Field 393700 Tallying Tally 393800 For Leading Zeros 393900 Add 1 To Tally 394000 Move DFC-Work-Field (Tally:) 394100 To DFC-Result-Field(Col-Ctr) 394200* Assemble pieces of number 394300 Move Spaces 394400 To DFC-Dec-Work-Field 394500* Case where we have DECIMAL(x,y) and x-y > 0 and integer 394600* part of decimal number is zero. 394700 If DFC-Result-Field(Col-Ctr) = Spaces 394800 And (Col-Prec(Col-Ctr) - Col-Scale(Col-Ctr)) > Zero Then 394900 Move '0' To DFC-Result-Field(Col-Ctr) 395000 End-If 395100 If DFC-Dec-Sign = '-' Then 395200 String DFC-Dec-Sign 395300 Delimited By Size 395400 DFC-Result-Field(Col-Ctr) 395500 Delimited By Spaces 395600 '.' 395700 Delimited By Size 395800 Dec-Part 395900 Delimited By Spaces 396000 Into DFC-Dec-Work-Field 396100 End-String 396200 Else 396300 String DFC-Result-Field(Col-Ctr) 396400 Delimited By Spaces 396500 '.' 396600 Delimited By Size 396700 Dec-Part 396800 Delimited By Spaces 396900 Into DFC-Dec-Work-Field 397000 End-String 397100 End-If 397200* Determine actual length of value 397300 Move Zero To EXCOM-ShvValL(Col-Ctr) 397400 Inspect DFC-Dec-Work-Field 397500 Tallying EXCOM-ShvValL(Col-Ctr) 397600 For Characters 397700 Before Initial Space 397800 Move DFC-Dec-Work-Field 397900 To DFC-Result-Field(Col-Ctr) 398000 Call 'Set-Pointer' Using DFC-Result-Field(Col-Ctr) 398100 EXCOM-ShvValA(Col-Ctr) 398200 When Other 398300 Display 'Logic error in RXDB2V23' 398400 Display 'Unsupported column datatype encountered' 398500 Display 'in 353-Format-Numeric-Data' 398600 Move SQLTYPE(Col-Ctr) To Num-Disp 398700 Display 'Data Type Code = ' Num-Disp 398800 Display 'RXDB2V23 terminating.' 398900 Move +8 To CAF-Hold-Rc 399000 Move -999 To SQLCode 399100 Perform 280-Check-For-RollBack 399200 End-Evaluate 399300 . 399400/ 399500 400-Point-SQLDA-To-Storage. 399600 399700* Initialize Row-Buf pointer 399800 Call 'Set-Pointer' Using Row-Buf 399900 Row-Buf-Ptr 400000 400100* For each column described in the SQLDA, point to a place 400200* in Row-Buf where column value can be placed upon fetch 400300 Move 1 To Row-Buf-Offset 400400 Perform With Test Before 400500 Varying Col-Ctr From 1 By 1 400600 Until Col-Ctr > SQLD 400700 400800 If Row-Buf-Offset > Length Of Row-Buf Then 400900* Result row exceeds size of this program's row buffer 401000 Display 'Result row for statement number ' 401100 Statement-Counter-A (1:Statement-Counter-A-Len) 401200 ' exceeds size of RXDB2V23''s row buffer.' 401300 Move Length Of Row-Buf To Num-Disp-15 401400 Display 'Maximum allowable result row length : ' 401500 Num-Disp-15 401600 Move SQLD To Num-Disp-15 401700 Display 'Number of columns in result table : ' 401800 Num-Disp-15 401900 Move Col-Ctr To Num-Disp-15 402000 Display 'Result table column which exceeds limit: ' 402100 Num-Disp-15 402200 Display ' Column Name/Label : "' 402300 SQLNAMEC(Col-Ctr) (1:SQLNAMEL(Col-Ctr)) '"' 402400 Move SQLLEN(Col-Ctr) To Num-Disp-15 402500 Display ' Column length : ' 402600 Num-Disp-15 402700 Move SQLTYPE(Col-Ctr) To Num-Disp-15 402800 Display ' Column data type : ' 402900 Num-Disp-15 403000 Display 'Problem SQL statement:' 403100 Display '"' SQL-Stmt-Txt (1:SQL-Stmt-Len) '"' 403200 Display 'RXDB2V23 is terminating.' 403300 Move +8 To CAF-Hold-Rc 403400 Move -999 To SQLCODE 403500 Perform 280-Check-For-RollBack 403600 End-If 403700 403800* Point SQLDATA occurrence to someplace in Row-Buf 403900 Move Row-Buf-Offset To Col-Beg-Pos(Col-Ctr) 404000 Set SQLDATA(Col-Ctr) To Row-Buf-Ptr 404100 404200* If it's a nullable column, point SQLIND occurrence 404300* to an element in the Null-Ind array. 404400 Divide SQLTYPE(Col-Ctr) By 2 404500 Giving Tally 404600 Remainder NullCheck 404700 If Nullable Then 404800 Call 'Set-Pointer' Using Null-Ind(Col-Ctr) 404900 SQLIND(Col-Ctr) 405000 Set Col-Is-Nullable(Col-Ctr) To True 405100 Else 405200 Set Col-Not-Nullable(Col-Ctr) To True 405300 End-If 405400 405500* Save the length and relative position of this column's 405600* data within Row-Buf in a separate array. This will be 405700* used later when mapping fetched rows into Rexx stem. 405800 Move SQLLEN(Col-Ctr) To Column-Length 405900 If Type-Decimal(Col-Ctr) 406000 Move DLWA-Prec(Col-Ctr) 406100 To DLWA-Prec-A 406200 Move DLWA-Precision 406300 To Col-Prec(Col-Ctr) 406400 Divide DLWA-Precision By 2 406500 Giving Tally 406600 Add 1 406700 Tally 406800 Giving Column-Length 406900 Move DLWA-Scal(Col-Ctr) 407000 To DLWA-Scal-A 407100 Move DLWA-Scale 407200 To Col-Scale(Col-Ctr) 407300 End-If 407400* For variable length strings, add two bytes for length field 407500 If Type-VarChar(Col-Ctr) 407600 Or Type-LongVarChar(Col-Ctr) 407700 Or Type-VarGraphic(Col-Ctr) 407800 Or Type-LongVarGraphic(Col-Ctr) 407900 Add 2 408000 To Column-Length 408100 End-If 408200 Move Column-Length To Col-Len(Col-Ctr) 408300 408400* Increment pointer position within Row-Buf 408500 Add Column-Length To Row-Buf-Ptr-Num 408600 Row-Buf-Offset 408700 408800 End-Perform 408900 . 409000/ 409100 500-Set-Rexx-SQLCA-Vars. 409200 409300 Compute SQL-Err-Msg-Len = Length Of SQL-Err-Msg-Txt 409400 Call Dsntiar Using Sqlca 409500 SQL-Err-Msg 409600 SQL-Err-Msg-Lrecl 409700 If Return-Code = Zero Then 409800 Perform With Test Before 409900 Varying SQL-Err-Msg-Tally From 1 By SQL-Err-Msg-Lrecl 410000 Until SQL-Err-Msg-Txt (SQL-Err-Msg-Tally:SQL-Err-Msg-Lrecl) 410100 = Spaces 410200 Or SQL-Err-Msg-Tally > SQL-Err-Msg-Len 410300 Continue 410400 End-Perform 410500 Subtract 1 From SQL-Err-Msg-Tally 410600 End-If 410700 410800* Set up IRXEXCOM ShvBlocks for Rexx SQLCA variables 410900 Perform Varying Tally From 1 By 1 411000 Until Tally > 24 411100 411200* Tell IRXEXCOM to set variable values 411300 Set EXCOM-Set-Variable-Direct(Tally) To True 411400 411500* Point ahead to next ShvBlock 411600 Call 'Set-Pointer' Using EXCOM-ShvNext(Tally + 1) 411700 EXCOM-ShvNext(Tally) 411800 411900 End-Perform 412000 412100* Set last ShvBlock forward pointer to null 412200 Set EXCOM-ShvNext(Tally - 1) To Null 412300 412400* Set Variable Name Lengths 412500 Move Length Of RXSQLCA-SQLCAID To EXCOM-ShvNamL(1) 412600 Move Length Of RXSQLCA-SQLCABC To EXCOM-ShvNamL(2) 412700 Move Length Of RXSQLCA-SQLCODE To EXCOM-ShvNamL(3) 412800 Move Length Of RXSQLCA-SQLERRM To EXCOM-ShvNamL(4) 412900 Move Length Of RXSQLCA-SQLERRP To EXCOM-ShvNamL(5) 413000 Move Length Of RXSQLCA-SQLERRD-1 To EXCOM-ShvNamL(6) 413100 Move Length Of RXSQLCA-SQLERRD-2 To EXCOM-ShvNamL(7) 413200 Move Length Of RXSQLCA-SQLERRD-3 To EXCOM-ShvNamL(8) 413300 Move Length Of RXSQLCA-SQLERRD-4 To EXCOM-ShvNamL(9) 413400 Move Length Of RXSQLCA-SQLERRD-5 To EXCOM-ShvNamL(10) 413500 Move Length Of RXSQLCA-SQLERRD-6 To EXCOM-ShvNamL(11) 413600 Move Length Of RXSQLCA-SQLWARN-0 To EXCOM-ShvNamL(12) 413700 Move Length Of RXSQLCA-SQLWARN-1 To EXCOM-ShvNamL(13) 413800 Move Length Of RXSQLCA-SQLWARN-2 To EXCOM-ShvNamL(14) 413900 Move Length Of RXSQLCA-SQLWARN-3 To EXCOM-ShvNamL(15) 414000 Move Length Of RXSQLCA-SQLWARN-4 To EXCOM-ShvNamL(16) 414100 Move Length Of RXSQLCA-SQLWARN-5 To EXCOM-ShvNamL(17) 414200 Move Length Of RXSQLCA-SQLWARN-6 To EXCOM-ShvNamL(18) 414300 Move Length Of RXSQLCA-SQLWARN-7 To EXCOM-ShvNamL(19) 414400 Move Length Of RXSQLCA-SQLWARN-8 To EXCOM-ShvNamL(20) 414500 Move Length Of RXSQLCA-SQLWARN-9 To EXCOM-ShvNamL(21) 414600 Move Length Of RXSQLCA-SQLWARN-A To EXCOM-ShvNamL(22) 414700 Move Length Of RXSQLCA-SQLSTATE To EXCOM-ShvNamL(23) 414800 Move Length Of RXSQLCA-SQLMSG To EXCOM-ShvNamL(24) 414900 415000* Set Variable Name Addresses 415100 Call 'Set-Pointer' Using RXSQLCA-SQLCAID 415200 EXCOM-ShvNamA(1) 415300 Call 'Set-Pointer' Using RXSQLCA-SQLCABC 415400 EXCOM-ShvNamA(2) 415500 Call 'Set-Pointer' Using RXSQLCA-SQLCODE 415600 EXCOM-ShvNamA(3) 415700 Call 'Set-Pointer' Using RXSQLCA-SQLERRM 415800 EXCOM-ShvNamA(4) 415900 Call 'Set-Pointer' Using RXSQLCA-SQLERRP 416000 EXCOM-ShvNamA(5) 416100 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-1 416200 EXCOM-ShvNamA(6) 416300 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-2 416400 EXCOM-ShvNamA(7) 416500 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-3 416600 EXCOM-ShvNamA(8) 416700 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-4 416800 EXCOM-ShvNamA(9) 416900 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-5 417000 EXCOM-ShvNamA(10) 417100 Call 'Set-Pointer' Using RXSQLCA-SQLERRD-6 417200 EXCOM-ShvNamA(11) 417300 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-0 417400 EXCOM-ShvNamA(12) 417500 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-1 417600 EXCOM-ShvNamA(13) 417700 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-2 417800 EXCOM-ShvNamA(14) 417900 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-3 418000 EXCOM-ShvNamA(15) 418100 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-4 418200 EXCOM-ShvNamA(16) 418300 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-5 418400 EXCOM-ShvNamA(17) 418500 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-6 418600 EXCOM-ShvNamA(18) 418700 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-7 418800 EXCOM-ShvNamA(19) 418900 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-8 419000 EXCOM-ShvNamA(20) 419100 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-9 419200 EXCOM-ShvNamA(21) 419300 Call 'Set-Pointer' Using RXSQLCA-SQLWARN-A 419400 EXCOM-ShvNamA(22) 419500 Call 'Set-Pointer' Using RXSQLCA-SQLSTATE 419600 EXCOM-ShvNamA(23) 419700 Call 'Set-Pointer' Using RXSQLCA-SQLMSG 419800 EXCOM-ShvNamA(24) 419900 420000* Format Numeric Fields of SQLCA 420100 420200 Move SQLCABC 420300 To DFC-Integer-Disp 420400 Move DFC-Integer-Disp 420500 To DFC-Work-Field 420600 Move Zero To Char-Ctr 420700 Inspect DFC-Work-Field 420800 Tallying Char-Ctr 420900 For Leading Spaces 421000 Add 1 To Char-Ctr 421100 Move DFC-Work-Field (Char-Ctr:) 421200 To Disp-SQLCABC 421300 Compute 421400 Disp-SQLCABC-Len 421500 = Char-Ctr - 1 - Length Of DFC-Work-Field 421600 End-Compute 421700 421800 Move SQLCODE 421900 To DFC-Integer-Disp 422000 Move DFC-Integer-Disp 422100 To DFC-Work-Field 422200 Move Zero To Char-Ctr 422300 Inspect DFC-Work-Field 422400 Tallying Char-Ctr 422500 For Leading Spaces 422600 Add 1 To Char-Ctr 422700 Move DFC-Work-Field (Char-Ctr:) 422800 To Disp-SQLCODE 422900 Compute 423000 Disp-SQLCODE-Len 423100 = Char-Ctr - 1 - Length Of DFC-Work-Field 423200 End-Compute 423300 423400 Perform Varying Tally From 1 By 1 423500 Until Tally > 6 423600 Move SQLERRD(Tally) 423700 To DFC-Integer-Disp 423800 Move DFC-Integer-Disp 423900 To DFC-Work-Field 424000 Move Zero To Char-Ctr 424100 Inspect DFC-Work-Field 424200 Tallying Char-Ctr 424300 For Leading Spaces 424400 Add 1 To Char-Ctr 424500 Move DFC-Work-Field (Char-Ctr:) 424600 To Disp-SQLERRD(Tally) 424700 Compute 424800 Disp-SQLERRD-Len(Tally) 424900 = Char-Ctr - 1 - Length Of DFC-Work-Field 425000 End-Compute 425100 End-Perform 425200 425300* Set Variable Value Addresses 425400 Call 'Set-Pointer' Using SQLCAID 425500 EXCOM-ShvValA(1) 425600 Call 'Set-Pointer' Using Disp-SQLCABC 425700 EXCOM-ShvValA(2) 425800 Call 'Set-Pointer' Using Disp-SQLCODE 425900 EXCOM-ShvValA(3) 426000 Call 'Set-Pointer' Using SQLERRMC 426100 EXCOM-ShvValA(4) 426200 Call 'Set-Pointer' Using SQLERRP 426300 EXCOM-ShvValA(5) 426400 Call 'Set-Pointer' Using Disp-SQLERRD(1) 426500 EXCOM-ShvValA(6) 426600 Call 'Set-Pointer' Using Disp-SQLERRD(2) 426700 EXCOM-ShvValA(7) 426800 Call 'Set-Pointer' Using Disp-SQLERRD(3) 426900 EXCOM-ShvValA(8) 427000 Call 'Set-Pointer' Using Disp-SQLERRD(4) 427100 EXCOM-ShvValA(9) 427200 Call 'Set-Pointer' Using Disp-SQLERRD(5) 427300 EXCOM-ShvValA(10) 427400 Call 'Set-Pointer' Using Disp-SQLERRD(6) 427500 EXCOM-ShvValA(11) 427600 Call 'Set-Pointer' Using SQLWARN0 427700 EXCOM-ShvValA(12) 427800 Call 'Set-Pointer' Using SQLWARN1 427900 EXCOM-ShvValA(13) 428000 Call 'Set-Pointer' Using SQLWARN2 428100 EXCOM-ShvValA(14) 428200 Call 'Set-Pointer' Using SQLWARN3 428300 EXCOM-ShvValA(15) 428400 Call 'Set-Pointer' Using SQLWARN4 428500 EXCOM-ShvValA(16) 428600 Call 'Set-Pointer' Using SQLWARN5 428700 EXCOM-ShvValA(17) 428800 Call 'Set-Pointer' Using SQLWARN6 428900 EXCOM-ShvValA(18) 429000 Call 'Set-Pointer' Using SQLWARN7 429100 EXCOM-ShvValA(19) 429200* Call 'Set-Pointer' Using SQLWARN8 429300* EXCOM-ShvValA(20) 429400* Call 'Set-Pointer' Using SQLWARN9 429500* EXCOM-ShvValA(21) 429600* Call 'Set-Pointer' Using SQLWARNA 429700* EXCOM-ShvValA(22) 429800* Call 'Set-Pointer' Using SQLSTATE 429900* EXCOM-ShvValA(23) 430000 Call 'Set-Pointer' Using SQLEXT (1:1) 430100 EXCOM-ShvValA(20) 430200 Call 'Set-Pointer' Using SQLEXT (2:1) 430300 EXCOM-ShvValA(21) 430400 Call 'Set-Pointer' Using SQLEXT (3:1) 430500 EXCOM-ShvValA(22) 430600 Call 'Set-Pointer' Using SQLEXT (4:) 430700 EXCOM-ShvValA(23) 430800 Call 'Set-Pointer' Using SQL-Err-Msg-Txt 430900 EXCOM-ShvValA(24) 431000 431100* Set Variable Value Lengths 431200 Move Length Of SQLCAID To EXCOM-ShvValL(1) 431300 Move Disp-SQLCABC-Len To EXCOM-ShvValL(2) 431400 Move Disp-SQLCODE-Len To EXCOM-ShvValL(3) 431500 Move SQLERRML To EXCOM-ShvValL(4) 431600 Move Length Of SQLERRP To EXCOM-ShvValL(5) 431700 Move Disp-SQLERRD-Len(1) To EXCOM-ShvValL(6) 431800 Move Disp-SQLERRD-Len(2) To EXCOM-ShvValL(7) 431900 Move Disp-SQLERRD-Len(3) To EXCOM-ShvValL(8) 432000 Move Disp-SQLERRD-Len(4) To EXCOM-ShvValL(9) 432100 Move Disp-SQLERRD-Len(5) To EXCOM-ShvValL(10) 432200 Move Disp-SQLERRD-Len(6) To EXCOM-ShvValL(11) 432300 Move Length Of SQLWARN0 To EXCOM-ShvValL(12) 432400 Move Length Of SQLWARN1 To EXCOM-ShvValL(13) 432500 Move Length Of SQLWARN2 To EXCOM-ShvValL(14) 432600 Move Length Of SQLWARN3 To EXCOM-ShvValL(15) 432700 Move Length Of SQLWARN4 To EXCOM-ShvValL(16) 432800 Move Length Of SQLWARN5 To EXCOM-ShvValL(17) 432900 Move Length Of SQLWARN6 To EXCOM-ShvValL(18) 433000 Move Length Of SQLWARN7 To EXCOM-ShvValL(19) 433100* Move Length Of SQLWARN8 To EXCOM-ShvValL(20) 433200* Move Length Of SQLWARN9 To EXCOM-ShvValL(21) 433300* Move Length Of SQLWARNA To EXCOM-ShvValL(22) 433400* Move Length Of SQLSTATE To EXCOM-ShvValL(23) 433500 Move +1 To EXCOM-ShvValL(20) 433600 Move +1 To EXCOM-ShvValL(21) 433700 Move +1 To EXCOM-ShvValL(22) 433800 Move +5 To EXCOM-ShvValL(23) 433900 Move SQL-Err-Msg-Tally To EXCOM-ShvValL(24) 434000 434100* Call IRXEXCOM to set Rexx SQLCA variables 434200 Perform 900-Call-IRXEXCOM 434300 . 434400/ 434500 520-Set-Rexx-IFCA-Vars. 434600 434700* Set up IRXEXCOM ShvBlocks for Rexx IFCA variables 434800 Perform Varying Tally From 1 By 1 434900 Until Tally > 10 435000 435100* Tell IRXEXCOM to set variable values 435200 Set EXCOM-Set-Variable-Direct(Tally) To True 435300 435400* Point ahead to next ShvBlock 435500 Call 'Set-Pointer' Using EXCOM-ShvNext(Tally + 1) 435600 EXCOM-ShvNext(Tally) 435700 435800 End-Perform 435900 436000* Set last ShvBlock forward pointer to null 436100 Set EXCOM-ShvNext(Tally - 1) To Null 436200 436300* Set Variable Name Lengths 436400 Move Length Of Rxifca-Return-Code To Excom-Shvnaml(1) 436500 Move Length Of Rxifca-Reason-Code To Excom-Shvnaml(2) 436600 Move Length Of Rxifca-Owner To Excom-Shvnaml(3) 436700 Move Length Of Rxifca-Bytes-Moved To Excom-Shvnaml(4) 436800 Move Length Of Rxifca-Bytes-Not-Moved To Excom-Shvnaml(5) 436900 Move Length Of Rxifca-Records-Lost-Reada To Excom-Shvnaml(6) 437000 Move Length Of Rxifca-Diagnostics To Excom-Shvnaml(7) 437100 Move Length Of Rxifca-Op-Dest-Name To Excom-Shvnaml(8) 437200 Move Length Of Rxifca-Op-Dest-Ret To Excom-Shvnaml(9) 437300 Move Length Of Rxifca-Trace-Num To Excom-Shvnaml(10) 437400 437500* Set Variable Name Addresses 437600 Call 'Set-Pointer' Using Rxifca-Return-Code 437700 Excom-Shvnama(1) 437800 Call 'Set-Pointer' Using Rxifca-Reason-Code 437900 Excom-Shvnama(2) 438000 Call 'Set-Pointer' Using Rxifca-Owner 438100 Excom-Shvnama(3) 438200 Call 'Set-Pointer' Using Rxifca-Bytes-Moved 438300 Excom-Shvnama(4) 438400 Call 'Set-Pointer' Using Rxifca-Bytes-Not-Moved 438500 Excom-Shvnama(5) 438600 Call 'Set-Pointer' Using Rxifca-Records-Lost-Reada 438700 Excom-Shvnama(6) 438800 Call 'Set-Pointer' Using Rxifca-Diagnostics 438900 Excom-Shvnama(7) 439000 Call 'Set-Pointer' Using Rxifca-Op-Dest-Name 439100 Excom-Shvnama(8) 439200 Call 'Set-Pointer' Using Rxifca-Op-Dest-Ret 439300 Excom-Shvnama(9) 439400 Call 'Set-Pointer' Using Rxifca-Trace-Num 439500 Excom-Shvnama(10) 439600 439700* Format Numeric Fields of IFCA 439800 439900 Move IFCA-Return-Code 440000 To DFC-Integer-Disp 440100 Move DFC-Integer-Disp 440200 To DFC-Work-Field 440300 Move Zero To Char-Ctr 440400 Inspect DFC-Work-Field 440500 Tallying Char-Ctr 440600 For Leading Spaces 440700 Add 1 To Char-Ctr 440800 Move DFC-Work-Field (Char-Ctr:) 440900 To Disp-IFCA-Rtc 441000 Compute 441100 Disp-IFCA-Rtc-Len 441200 = Char-Ctr - 1 - Length Of DFC-Work-Field 441300 End-Compute 441400 441500 Move IFCA-Bytes-Moved 441600 To DFC-Integer-Disp 441700 Move DFC-Integer-Disp 441800 To DFC-Work-Field 441900 Move Zero To Char-Ctr 442000 Inspect DFC-Work-Field 442100 Tallying Char-Ctr 442200 For Leading Spaces 442300 Add 1 To Char-Ctr 442400 Move DFC-Work-Field (Char-Ctr:) 442500 To Disp-IFCA-Bm 442600 Compute 442700 Disp-IFCA-Bm-Len 442800 = Char-Ctr - 1 - Length Of DFC-Work-Field 442900 End-Compute 443000 443100 Move IFCA-Bytes-Not-Moved 443200 To DFC-Integer-Disp 443300 Move DFC-Integer-Disp 443400 To DFC-Work-Field 443500 Move Zero To Char-Ctr 443600 Inspect DFC-Work-Field 443700 Tallying Char-Ctr 443800 For Leading Spaces 443900 Add 1 To Char-Ctr 444000 Move DFC-Work-Field (Char-Ctr:) 444100 To Disp-IFCA-Bnm 444200 Compute 444300 Disp-IFCA-Bnm-Len 444400 = Char-Ctr - 1 - Length Of DFC-Work-Field 444500 End-Compute 444600 444700 Move IFCA-Records-Lost-ReadA 444800 To DFC-Integer-Disp 444900 Move DFC-Integer-Disp 445000 To DFC-Work-Field 445100 Move Zero To Char-Ctr 445200 Inspect DFC-Work-Field 445300 Tallying Char-Ctr 445400 For Leading Spaces 445500 Add 1 To Char-Ctr 445600 Move DFC-Work-Field (Char-Ctr:) 445700 To Disp-IFCA-Rl 445800 Compute 445900 Disp-IFCA-Rl-Len 446000 = Char-Ctr - 1 - Length Of DFC-Work-Field 446100 End-Compute 446200 446300 Call 'Convert-To-Hex' Using By Content 446400 Length Of IFCA-Reason-Code 446500 By Reference 446600 IFCA-Reason-Code 446700 C2X-Return-Buf 446800 Compute Tally = 2 * Length Of IFCA-Reason-Code 446900 Move C2X-Return-Buf (1:Tally) 447000 To Disp-IFCA-Rsc 447100 447200* Set Variable Value Addresses 447300 Call 'Set-Pointer' Using Disp-IFCA-Rtc 447400 EXCOM-ShvValA(1) 447500 Call 'Set-Pointer' Using Disp-IFCA-Rsc 447600 EXCOM-ShvValA(2) 447700 Call 'Set-Pointer' Using IFCA-Owner 447800 EXCOM-ShvValA(3) 447900 Call 'Set-Pointer' Using Disp-IFCA-Bm 448000 EXCOM-ShvValA(4) 448100 Call 'Set-Pointer' Using Disp-IFCA-Bnm 448200 EXCOM-ShvValA(5) 448300 Call 'Set-Pointer' Using Disp-IFCA-Rl 448400 EXCOM-ShvValA(6) 448500 Call 'Set-Pointer' Using IFCA-Diagnostic-Txt 448600 EXCOM-ShvValA(7) 448700 Call 'Set-Pointer' Using IFCA-Op-Dest-Name 448800 EXCOM-ShvValA(8) 448900 Call 'Set-Pointer' Using IFCA-Op-Dest-Ret 449000 EXCOM-ShvValA(9) 449100 Call 'Set-Pointer' Using IFCA-Trace-Num 449200 EXCOM-ShvValA(10) 449300 449400* Set Variable Value Lengths 449500 Move Disp-IFCA-Rtc-Len To EXCOM-ShvValL(1) 449600 Move Length Of Disp-IFCA-Rsc To EXCOM-ShvValL(2) 449700 Move Length Of IFCA-Owner To EXCOM-ShvValL(3) 449800 Move Disp-IFCA-Bm-Len To EXCOM-ShvValL(4) 449900 Move Disp-IFCA-Bnm-Len To EXCOM-ShvValL(5) 450000 Move Disp-IFCA-Rl-Len To EXCOM-ShvValL(6) 450100 Move IFCA-Diagnostic-Len To EXCOM-ShvValL(7) 450200 Move Length Of IFCA-Op-Dest-Name To EXCOM-ShvValL(8) 450300 Compute EXCOM-ShvValL(9) = IFCA-Op-Dest-Ret-Len - 4 450400 Compute EXCOM-ShvValL(10) = IFCA-Trace-Num-Len - 4 450500 450600* Call IRXEXCOM to set Rexx IFCA variables 450700 Perform 900-Call-IRXEXCOM 450800 . 450900/ 451000 600-Set-Rexx-SQLDA-Vars. 451100 451200* Set up ShvBlocks for SQLDA variables 451300 Perform Varying Tally From 1 By 1 451400 Until Tally > 4 451500 451600* Tell IRXEXCOM to set variable values 451700 Set EXCOM-Set-Variable-Direct(Tally) To True 451800 451900* Point ahead to next ShvBlock 452000 Call 'Set-Pointer' Using EXCOM-ShvNext(Tally + 1) 452100 EXCOM-ShvNext(Tally) 452200 End-Perform 452300 452400* Set last ShvBlock forward pointer to null 452500 Set EXCOM-ShvNext(Tally - 1) To Null 452600 452700* Build SQLDA.SQLD variable name 452800 If Multiple-SQL-Statements Then 452900 String 'SQLDA.' 453000 Delimited By Size 453100 Statement-Counter-A 453200 Delimited By Spaces 453300 '.SQLD' 453400 Delimited By Size 453500 Into Rxsqlda-Sqld 453600 End-String 453700 Else 453800 Move 'SQLDA.SQLD' 453900 To Rxsqlda-Sqld 454000 End-If 454100 454200* Set Variable Name Lengths 454300 Move Length Of Rxsqlda-Sqldaid To Excom-Shvnaml(1) 454400 Move Length Of Rxsqlda-Sqldabc To Excom-Shvnaml(2) 454500 Move Length Of Rxsqlda-Sqln To Excom-Shvnaml(3) 454600 Move Zero To EXCOM-ShvNamL(4) 454700 Inspect Rxsqlda-Sqld 454800 Tallying Excom-Shvnaml(4) 454900 For Characters Before Initial Space 455000 455100* Set Variable Name Addresses 455200 Call 'Set-Pointer' Using Rxsqlda-Sqldaid 455300 Excom-Shvnama(1) 455400 Call 'Set-Pointer' Using Rxsqlda-Sqldabc 455500 Excom-Shvnama(2) 455600 Call 'Set-Pointer' Using Rxsqlda-Sqln 455700 Excom-Shvnama(3) 455800 Call 'Set-Pointer' Using Rxsqlda-Sqld 455900 Excom-Shvnama(4) 456000 456100* Format Numeric Fields of SQLDA 456200 456300 Move SQLDABC 456400 To DFC-Integer-Disp 456500 Move DFC-Integer-Disp 456600 To DFC-Work-Field 456700 Move Zero To Char-Ctr 456800 Inspect DFC-Work-Field 456900 Tallying Char-Ctr 457000 For Leading Spaces 457100 Add 1 To Char-Ctr 457200 Move DFC-Work-Field (Char-Ctr:) 457300 To Disp-SQLDABC 457400 Compute 457500 Disp-SQLDABC-Len 457600 = Char-Ctr - 1 - Length Of DFC-Work-Field 457700 End-Compute 457800 457900 Move SQLN 458000 To DFC-Integer-Disp 458100 Move DFC-Integer-Disp 458200 To DFC-Work-Field 458300 Move Zero To Char-Ctr 458400 Inspect DFC-Work-Field 458500 Tallying Char-Ctr 458600 For Leading Spaces 458700 Add 1 To Char-Ctr 458800 Move DFC-Work-Field (Char-Ctr:) 458900 To Disp-SQLN 459000 Compute 459100 Disp-SQLN-Len 459200 = Char-Ctr - 1 - Length Of DFC-Work-Field 459300 End-Compute 459400 459500 Move SQLD 459600 To DFC-Integer-Disp 459700 Move DFC-Integer-Disp 459800 To DFC-Work-Field 459900 Move Zero To Char-Ctr 460000 Inspect DFC-Work-Field 460100 Tallying Char-Ctr 460200 For Leading Spaces 460300 Add 1 To Char-Ctr 460400 Move DFC-Work-Field (Char-Ctr:) 460500 To Disp-SQLD 460600 Compute 460700 Disp-SQLD-Len 460800 = Char-Ctr - 1 - Length Of DFC-Work-Field 460900 End-Compute 461000 461100* Set Variable Value Lengths 461200 Move Length Of SQLDAID To EXCOM-ShvValL(1) 461300 Move Disp-SQLDABC-Len To EXCOM-ShvValL(2) 461400 Move Disp-SQLN-Len To EXCOM-ShvValL(3) 461500 Move Disp-SQLD-Len To EXCOM-ShvValL(4) 461600 461700* Set Variable Value Addresses 461800 Call 'Set-Pointer' Using SQLDAID 461900 EXCOM-ShvValA(1) 462000 Call 'Set-Pointer' Using Disp-SQLDABC 462100 EXCOM-ShvValA(2) 462200 Call 'Set-Pointer' Using Disp-SQLN 462300 EXCOM-ShvValA(3) 462400 Call 'Set-Pointer' Using Disp-SQLD 462500 EXCOM-ShvValA(4) 462600 462700* Call IRXEXCOM to set first four SQLDA variables 462800 Perform 900-Call-IRXEXCOM 462900 463000* Set Occurrences of SQLVAR & ShvBlock 463100 Move Zero To ShvBlock-Ctr 463200 Perform With Test Before 463300 Varying Col-Ctr From 1 By 1 463400 Until Col-Ctr > SQLD 463500 463600* Format SQLVARS for display 463700 Move SQLTYPE(Col-Ctr) 463800 To DFC-Integer-Disp 463900 Move DFC-Integer-Disp 464000 To DFC-Work-Field 464100 Move Zero To Char-Ctr 464200 Inspect DFC-Work-Field 464300 Tallying Char-Ctr 464400 For Leading Spaces 464500 Add 1 To Char-Ctr 464600 Move DFC-Work-Field (Char-Ctr:) 464700 To Disp-SQLTYPE(Col-Ctr) 464800 Compute 464900 Disp-SQLTYPE-Len(Col-Ctr) 465000 = Char-Ctr - 1 - Length Of DFC-Work-Field 465100 End-Compute 465200 465300 Evaluate True 465400 When Type-Decimal(Col-Ctr) 465500 Move Col-Prec(Col-Ctr) 465600 To DFC-Integer-Disp 465700 Move DFC-Integer-Disp 465800 To DFC-Work-Field 465900 Move Zero To Char-Ctr 466000 Inspect DFC-Work-Field 466100 Tallying Char-Ctr 466200 For Leading Spaces 466300 Add 1 To Char-Ctr 466400 Move DFC-Work-Field (Char-Ctr:) 466500 To Prec-Work-Field 466600 466700 Move Col-Scale(Col-Ctr) 466800 To DFC-Integer-Disp 466900 Move DFC-Integer-Disp 467000 To DFC-Work-Field 467100 Move Zero To Char-Ctr 467200 Inspect DFC-Work-Field 467300 Tallying Char-Ctr 467400 For Leading Spaces 467500 Add 1 To Char-Ctr 467600 Move DFC-Work-Field (Char-Ctr:) 467700 To Scale-Work-Field 467800 467900 Move Spaces To Disp-SQLLEN(Col-Ctr) 468000 String Prec-Work-Field 468100 Delimited By Spaces 468200 ',' 468300 Delimited By Size 468400 Scale-Work-Field 468500 Delimited By Spaces 468600 Into Disp-SQLLEN(Col-Ctr) 468700 End-String 468800 Move Zero To Disp-SQLLEN-Len(Col-Ctr) 468900 Inspect Disp-SQLLEN(Col-Ctr) 469000 Tallying Disp-SQLLEN-Len(Col-Ctr) 469100 For Characters 469200 Before Initial Space 469300 When Type-Integer(Col-Ctr) 469400 Move '10' To Disp-SQLLEN(Col-Ctr) 469500 Move 2 To Disp-SQLLEN-Len(Col-Ctr) 469600 When Type-Smallint(Col-Ctr) 469700 Move '5' To Disp-SQLLEN(Col-Ctr) 469800 Move 1 To Disp-SQLLEN-Len(Col-Ctr) 469900 When Type-Float(Col-Ctr) 470000 Move '22' To Disp-SQLLEN(Col-Ctr) 470100 Move 2 To Disp-SQLLEN-Len(Col-Ctr) 470200 When Other 470300 Move SQLLEN(Col-Ctr) 470400 To DFC-Integer-Disp 470500 Move DFC-Integer-Disp 470600 To DFC-Work-Field 470700 Move Zero To Char-Ctr 470800 Inspect DFC-Work-Field 470900 Tallying Char-Ctr 471000 For Leading Spaces 471100 Add 1 To Char-Ctr 471200 Move DFC-Work-Field (Char-Ctr:) 471300 To Disp-SQLLEN(Col-Ctr) 471400 Compute 471500 Disp-SQLLEN-Len(Col-Ctr) 471600 = Char-Ctr - 1 - Length Of DFC-Work-Field 471700 End-Compute 471800 End-Evaluate 471900 472000* Format column portion of SQLDA stem index 472100 Move Col-Ctr To Stem-Index-N 472200 Perform 910-Format-Stem-Index 472300 472400****** For SQLTYPE Occurrence ************************************ 472500* * 472600* Tell IRXEXCOM to set variable value 472700 Add 1 To ShvBlock-Ctr 472800 Set EXCOM-Set-Variable-Direct(ShvBlock-Ctr) To True 472900 473000* Point ahead to next ShvBlock 473100 Call 'Set-Pointer' 473200 Using 473300 EXCOM-ShvNext(ShvBlock-Ctr + 1) 473400 EXCOM-ShvNext(ShvBlock-Ctr) 473500 473600* Build SQLDA stem name 473700 Move Spaces To RXSQLDA-SQLTYPE(Col-Ctr) 473800 If Multiple-SQL-Statements Then 473900 String 'SQLDA.' 474000 Delimited By Size 474100 Statement-Counter-A 474200 Delimited By Spaces 474300 '.SQLTYPE.' 474400 Stem-Index-A 474500 Delimited By Size 474600 Into RXSQLDA-SQLTYPE(Col-Ctr) 474700 End-String 474800 Else 474900 String 'SQLDA.SQLTYPE.' 475000 Delimited By Size 475100 Stem-Index-A 475200 Delimited By Size 475300 Into RXSQLDA-SQLTYPE(Col-Ctr) 475400 End-String 475500 End-If 475600 Move Zero To EXCOM-ShvNamL(ShvBlock-Ctr) 475700 Inspect RXSQLDA-SQLTYPE(Col-Ctr) 475800 Tallying EXCOM-ShvNamL(ShvBlock-Ctr) 475900 For Characters Before Initial Space 476000 Call 'Set-Pointer' Using RXSQLDA-SQLTYPE(Col-Ctr) 476100 EXCOM-ShvNamA(ShvBlock-Ctr) 476200 Move Disp-SQLTYPE-Len(Col-Ctr) 476300 To EXCOM-ShvValL(ShvBlock-Ctr) 476400 Call 'Set-Pointer' Using Disp-SQLTYPE(Col-Ctr) 476500 EXCOM-ShvValA(ShvBlock-Ctr) 476600 476700****** For SQLLEN Occurrence ************************************* 476800* 476900 477000* Tell IRXEXCOM to set variable value 477100 Add 1 To ShvBlock-Ctr 477200 Set EXCOM-Set-Variable-Direct(ShvBlock-Ctr) To True 477300 477400* Point ahead to next ShvBlock 477500 Call 'Set-Pointer' 477600 Using 477700 EXCOM-ShvNext(ShvBlock-Ctr + 1) 477800 EXCOM-ShvNext(ShvBlock-Ctr) 477900 478000* Build SQLDA stem name 478100 Move Spaces To RXSQLDA-SQLLEN(Col-Ctr) 478200 If Multiple-SQL-Statements Then 478300 String 'SQLDA.' 478400 Delimited By Size 478500 Statement-Counter-A 478600 Delimited By Spaces 478700 '.SQLLEN.' 478800 Stem-Index-A 478900 Delimited By Size 479000 Into RXSQLDA-SQLLEN(Col-Ctr) 479100 End-String 479200 Else 479300 String 'SQLDA.SQLLEN.' 479400 Delimited By Size 479500 Stem-Index-A 479600 Delimited By Size 479700 Into RXSQLDA-SQLLEN(Col-Ctr) 479800 End-String 479900 End-If 480000 Move Zero To EXCOM-ShvNamL(ShvBlock-Ctr) 480100 Inspect RXSQLDA-SQLLEN(Col-Ctr) 480200 Tallying EXCOM-ShvNamL(ShvBlock-Ctr) 480300 For Characters Before Initial Space 480400 Call 'Set-Pointer' Using RXSQLDA-SQLLEN(Col-Ctr) 480500 EXCOM-ShvNamA(ShvBlock-Ctr) 480600 Move Disp-SQLLEN-Len(Col-Ctr) 480700 To EXCOM-ShvValL(ShvBlock-Ctr) 480800 Call 'Set-Pointer' Using Disp-SQLLEN(Col-Ctr) 480900 EXCOM-ShvValA(ShvBlock-Ctr) 481000 481100****** For SQLNULL Occurrence ************************************ 481200* 481300 481400* Tell IRXEXCOM to set variable value 481500 Add 1 To ShvBlock-Ctr 481600 Set EXCOM-Set-Variable-Direct(ShvBlock-Ctr) To True 481700 481800* Point ahead to next ShvBlock 481900 Call 'Set-Pointer' 482000 Using 482100 EXCOM-ShvNext(ShvBlock-Ctr + 1) 482200 EXCOM-ShvNext(ShvBlock-Ctr) 482300 482400* Build SQLDA stem name 482500 Move Spaces To RXSQLDA-SQLNULL(Col-Ctr) 482600 If Multiple-SQL-Statements Then 482700 String 'SQLDA.' 482800 Delimited By Size 482900 Statement-Counter-A 483000 Delimited By Spaces 483100 '.SQLNULL.' 483200 Stem-Index-A 483300 Delimited By Size 483400 Into RXSQLDA-SQLNULL(Col-Ctr) 483500 End-String 483600 Else 483700 String 'SQLDA.SQLNULL.' 483800 Delimited By Size 483900 Stem-Index-A 484000 Delimited By Size 484100 Into RXSQLDA-SQLNULL(Col-Ctr) 484200 End-String 484300 End-If 484400 Move Zero To EXCOM-ShvNamL(ShvBlock-Ctr) 484500 Inspect RXSQLDA-SQLNULL(Col-Ctr) 484600 Tallying EXCOM-ShvNamL(ShvBlock-Ctr) 484700 For Characters Before Initial Space 484800 Call 'Set-Pointer' Using RXSQLDA-SQLNULL(Col-Ctr) 484900 EXCOM-ShvNamA(ShvBlock-Ctr) 485000 If Col-Is-Nullable(Col-Ctr) Then 485100 Move '1' To RXSQLDA-SQLNULL-Value(Col-Ctr) 485200 Else 485300 Move '0' To RXSQLDA-SQLNULL-Value(Col-Ctr) 485400 End-If 485500 Move +1 To EXCOM-ShvValL(ShvBlock-Ctr) 485600 Call 'Set-Pointer' Using RXSQLDA-SQLNULL-Value(Col-Ctr) 485700 EXCOM-ShvValA(ShvBlock-Ctr) 485800 485900****** For SQLNAME Occurrence ************************************ 486000* 486100 486200* Tell IRXEXCOM to set variable value 486300 Add 1 To ShvBlock-Ctr 486400 Set EXCOM-Set-Variable-Direct(ShvBlock-Ctr) To True 486500 486600* Point ahead to next ShvBlock 486700 Call 'Set-Pointer' 486800 Using 486900 EXCOM-ShvNext(ShvBlock-Ctr + 1) 487000 EXCOM-ShvNext(ShvBlock-Ctr) 487100 487200* Build SQLDA stem name 487300 Move Spaces To RXSQLDA-SQLNAME(Col-Ctr) 487400 If Multiple-SQL-Statements Then 487500 String 'SQLDA.' 487600 Delimited By Size 487700 Statement-Counter-A 487800 Delimited By Spaces 487900 '.SQLNAME.' 488000 Stem-Index-A 488100 Delimited By Size 488200 Into RXSQLDA-SQLNAME(Col-Ctr) 488300 End-String 488400 Else 488500 String 'SQLDA.SQLNAME.' 488600 Delimited By Size 488700 Stem-Index-A 488800 Delimited By Size 488900 Into RXSQLDA-SQLNAME(Col-Ctr) 489000 End-String 489100 End-If 489200 Move Zero To EXCOM-ShvNamL(ShvBlock-Ctr) 489300 Inspect RXSQLDA-SQLNAME(Col-Ctr) 489400 Tallying EXCOM-ShvNamL(ShvBlock-Ctr) 489500 For Characters Before Initial Space 489600 Call 'Set-Pointer' Using RXSQLDA-SQLNAME(Col-Ctr) 489700 EXCOM-ShvNamA(ShvBlock-Ctr) 489800 Move SQLNAMEL(Col-Ctr) To EXCOM-ShvValL(ShvBlock-Ctr) 489900 Call 'Set-Pointer' Using SQLNAMEC(Col-Ctr) 490000 EXCOM-ShvValA(ShvBlock-Ctr) 490100 End-Perform 490200 490300* If it's a SELECT statement, then put values for SQLVARs 490400 If SQLD > Zero Then 490500* Set last ShvBlock forward pointer to null 490600 Set EXCOM-ShvNext(ShvBlock-Ctr) To Null 490700 490800* Call IRXEXCOM to set variable values 490900 Perform 900-Call-IRXEXCOM 491000 End-If 491100 . 491200/ 491300 650-Set-RxDB2-No-Where-Clause. 491400 491500* Set-Up ShvBlock 491600 Set EXCOM-Set-Variable-Direct(1) To True 491700 Set EXCOM-ShvNext(1) To Null 491800 Move Length Of RXDB2-NOWHERE To EXCOM-ShvNamL(1) 491900 Call 'Set-Pointer' Using RXDB2-NOWHERE 492000 EXCOM-ShvNamA(1) 492100 Call 'Set-Pointer' Using SQLWARN4 492200 EXCOM-ShvValA(1) 492300 Move Length Of SQLWARN4 To EXCOM-ShvValL(1) 492400* Call IRXEXCOM to set variable value 492500 Perform 900-Call-IRXEXCOM 492600 . 492700/ 492800 700-Prepare-Result-Table-Stem. 492900 493000* Validate Stem Variable 493100 Evaluate True 493200 When Stem-Var-Len = Zero 493300* No stem variable name supplied 493400 Display 'Stem variable name is missing. ' 493500 Display 'You must supply the name of a stem for ' 493600 'the result of a SELECT statement or' 493700 Display 'DB2 command.' 493800 Display 'RXDB2V23 is terminating.' 493900 Move +8 To CAF-Hold-Rc 494000 Move -999 To SQLCODE 494100 Perform 280-Check-For-RollBack 494200 When Stem-Var-Name (Stem-Var-Len:1) NOT = '.' 494300 Or Stem-Var-Len = 1 Or Stem-Var-Name (1:1) = '.' 494400* Not a stem variable 494500 Display 'The Rexx variable "' 494600 Stem-Var-Name (1:Stem-Var-Len) 494700 '" cannot be used as a stem by RXDB2V23' 494800 Display 'RXDB2V23 is terminating.' 494900 Move +8 To CAF-Hold-Rc 495000 Move -999 To SQLCODE 495100 Perform 280-Check-For-RollBack 495200 When Other 495300 If Result-Stem-Not-Dropped Then 495400* Set switch so that this If-Block is not executed again 495500* (i.e. do not want to drop result stem anymore) 495600 Set Result-Stem-Dropped To True 495700* Drop Row stem variable 495800 Set EXCOM-ShvNext(1) To Null 495900 Set EXCOM-Drop-Variable-Direct(1) To True 496000 Call 'Set-Pointer' Using Stem-Var-Name 496100 EXCOM-ShvNamA(1) 496200 Move Stem-Var-Len To EXCOM-ShvNamL(1) 496300 Perform 900-Call-IRXEXCOM 496400 End-If 496500 End-Evaluate 496600 . 496700/ 496800 800-Set-Stem-Dot-Zero. 496900 497000 Set EXCOM-ShvNext(1) To Null 497100 Move Spaces To Stem-Dot-Zero-Var 497200 If Multiple-SQL-Statements Then 497300 String Stem-Var-Name (1:Stem-Var-Len) 497400 Statement-Counter-A 497500 Delimited By Spaces 497600 '.' 497700 '0' 497800 Delimited By Size 497900 Into Stem-Dot-Zero-Var 498000 End-String 498100 Else 498200 String Stem-Var-Name (1:Stem-Var-Len) 498300 Delimited By Spaces 498400 '0' 498500 Delimited By Size 498600 Into Stem-Dot-Zero-Var 498700 End-String 498800 End-If 498900 Move Zero To EXCOM-ShvNamL(1) 499000 Inspect Stem-Dot-Zero-Var 499100 Tallying EXCOM-ShvNamL(1) 499200 For Characters 499300 Before Initial Space 499400 Move Row-Counter 499500 To DFC-Integer-Disp 499600 Move DFC-Integer-Disp 499700 To DFC-Work-Field 499800 Move Zero To Char-Ctr 499900 Inspect DFC-Work-Field 500000 Tallying Char-Ctr 500100 For Leading Spaces 500200 Add 1 To Char-Ctr 500300 Move DFC-Work-Field (Char-Ctr:) 500400 To Stem-Dot-Zero-Val 500500 Compute 500600 EXCOM-ShvValL(1) 500700 = Char-Ctr - 1 - Length Of DFC-Work-Field 500800 End-Compute 500900 501000 Call 'Set-Pointer' Using Stem-Dot-Zero-Var 501100 EXCOM-ShvNamA(1) 501200 Call 'Set-Pointer' Using Stem-Dot-Zero-Val 501300 EXCOM-ShvValA(1) 501400 Set EXCOM-Set-Variable-Direct(1) To True 501500 Perform 900-Call-IRXEXCOM 501600 . 501700/ 501800 820-Drop-Comm-Area-Stems. 501900 502000* Drop SQLCA, SQLDA, and IFCA stem variables 502100 Set EXCOM-Drop-Variable-Direct(1) To True 502200 Set EXCOM-Drop-Variable-Direct(2) To True 502300 Call 'Set-Pointer' Using EXCOM-ShvNext(2) 502400 EXCOM-ShvNext(1) 502500 Set EXCOM-ShvNext(2) To Null 502600 Call 'Set-Pointer' Using RXSQLCA-Stem 502700 EXCOM-ShvNamA(1) 502800 Move Length Of RXSQLCA-Stem To EXCOM-ShvNamL(1) 502900 Call 'Set-Pointer' Using RXIFCA-Stem 503000 EXCOM-ShvNamA(2) 503100 Move Length Of RXIFCA-Stem To EXCOM-ShvNamL(2) 503200 Perform 900-Call-IRXEXCOM 503300 . 503400/ 503500 830-Drop-SQLDA-Stem. 503600 503700* Drop SQLDA stem variable 503800 Set EXCOM-Drop-Variable-Direct(1) To True 503900 Set EXCOM-ShvNext(1) To Null 504000 Call 'Set-Pointer' Using RXSQLDA-Stem 504100 EXCOM-ShvNamA(1) 504200 Move Length Of RXSQLDA-Stem To EXCOM-ShvNamL(1) 504300 Perform 900-Call-IRXEXCOM 504400 . 504500/ 504600 900-Call-IRXEXCOM. 504700 504800 Set Not-Flagged-For-Term To True 504900 505000 Call IRXEXCOM Using EXCOM-IRXEXCOM 505100 EXCOM-Pointer-2 505200 EXCOM-Pointer-2 505300 EXCOM-ShvBlock(1) 505400 If Return-Code < Zero 505500 Or Return-Code >= 8 Then 505600 Move Return-Code To Num-Disp 505700 Display 'Non-Zero return code ' Num-Disp ' received' 505800 ' from IRXEXCOM' 505900 Display 'RXDB2V23 will terminate.' 506000 Move +8 To CAF-Hold-Rc 506100 Move -999 To SQLCode 506200 Set Flagged-For-Termination To True 506300 End-If 506400 506500 Set IRXEXCOM-Req-Block-OK To True 506600 Perform With Test After 506700 Varying Blk-Ctr From 1 By 1 506800 Until EXCOM-ShvNext(Blk-Ctr) = Null 506900 Or Blk-Ctr > 3000 507000 If EXCOM-ShvRet(Blk-Ctr) >= x'08' Then 507100 Set IRXEXCOM-Req-Block-Failed To True 507200 Move Blk-Ctr To Block-Number 507300 Perform 950-Display-ShvBlock 507400 Display ' ' 507500 Display 'Unexpected IRXEXCOM Return Code . . .' 507600 Display ' ' 507700 Move +8 To CAF-Hold-Rc 507800 End-If 507900 End-Perform 508000 If IRXEXCOM-Req-Block-Failed 508100 Or Flagged-For-Termination Then 508200 Display 'One or more IRXEXCOM request blocks yielded' 508300 ' an unexpected return code' 508400 Display 'RXDB2V23 is terminating.' 508500 Move -999 To SQLCode 508600 Perform 280-Check-For-RollBack 508700 End-If 508800 . 508900/ 509000 910-Format-Stem-Index. 509100 509200 Evaluate True 509300 When Stem-Index-N < 10 509400 Move Stem-Index-N To Num-Pic-1 509500 Move Num-Pic-1-A To Stem-Index-A 509600 When Stem-Index-N < 100 509700 Move Stem-Index-N To Num-Pic-2 509800 Move Num-Pic-2-A To Stem-Index-A 509900 When Stem-Index-N < 1000 510000 Move Stem-Index-N To Num-Pic-3 510100 Move Num-Pic-3-A To Stem-Index-A 510200 When Stem-Index-N < 10000 510300 Move Stem-Index-N To Num-Pic-4 510400 Move Num-Pic-4-A To Stem-Index-A 510500 When Stem-Index-N < 100000 510600 Move Stem-Index-N To Num-Pic-5 510700 Move Num-Pic-5-A To Stem-Index-A 510800 When Stem-Index-N < 1000000 510900 Move Stem-Index-N To Num-Pic-6 511000 Move Num-Pic-6-A To Stem-Index-A 511100 When Stem-Index-N < 10000000 511200 Move Stem-Index-N To Num-Pic-7 511300 Move Num-Pic-7-A To Stem-Index-A 511400 When Stem-Index-N < 100000000 511500 Move Stem-Index-N To Num-Pic-8 511600 Move Num-Pic-8-A To Stem-Index-A 511700 When Stem-Index-N < 1000000000 511800 Move Stem-Index-N To Num-Pic-9 511900 Move Num-Pic-9-A To Stem-Index-A 512000 When Other 512100 Display 'Number of rows returned exceeds limit' 512200 Display 'allowed by RXDB2V23' 512300 Display 'Maximum number of result rows allowed: ' 512400 '1000000000' 512500 Display 'RXDB2V23 is terminating.' 512600 Move +8 To CAF-Hold-Rc 512700 Move -999 To SQLCode 512800 Perform 280-Check-For-RollBack 512900 End-Evaluate 513000 . 513100/ 513200 920-Format-Decimal-Field. 513300 513400 Evaluate True 513500 When Col-Prec(Col-Ctr) = 1 513600 Move DFC-Dec-Work-A To Dec-Pic-1-A 513700 Move Dec-Pic-1 To DFC-Dec-Work-Disp 513800 When Col-Prec(Col-Ctr) = 2 513900 Move DFC-Dec-Work-A To Dec-Pic-2-A 514000 Move Dec-Pic-2 To DFC-Dec-Work-Disp 514100 When Col-Prec(Col-Ctr) = 3 514200 Move DFC-Dec-Work-A To Dec-Pic-3-A 514300 Move Dec-Pic-3 To DFC-Dec-Work-Disp 514400 When Col-Prec(Col-Ctr) = 4 514500 Move DFC-Dec-Work-A To Dec-Pic-4-A 514600 Move Dec-Pic-4 To DFC-Dec-Work-Disp 514700 When Col-Prec(Col-Ctr) = 5 514800 Move DFC-Dec-Work-A To Dec-Pic-5-A 514900 Move Dec-Pic-5 To DFC-Dec-Work-Disp 515000 When Col-Prec(Col-Ctr) = 6 515100 Move DFC-Dec-Work-A To Dec-Pic-6-A 515200 Move Dec-Pic-6 To DFC-Dec-Work-Disp 515300 When Col-Prec(Col-Ctr) = 7 515400 Move DFC-Dec-Work-A To Dec-Pic-7-A 515500 Move Dec-Pic-7 To DFC-Dec-Work-Disp 515600 When Col-Prec(Col-Ctr) = 8 515700 Move DFC-Dec-Work-A To Dec-Pic-8-A 515800 Move Dec-Pic-8 To DFC-Dec-Work-Disp 515900 When Col-Prec(Col-Ctr) = 9 516000 Move DFC-Dec-Work-A To Dec-Pic-9-A 516100 Move Dec-Pic-9 To DFC-Dec-Work-Disp 516200 When Col-Prec(Col-Ctr) = 10 516300 Move DFC-Dec-Work-A To Dec-Pic-10-A 516400 Move Dec-Pic-10 To DFC-Dec-Work-Disp 516500 When Col-Prec(Col-Ctr) = 11 516600 Move DFC-Dec-Work-A To Dec-Pic-11-A 516700 Move Dec-Pic-11 To DFC-Dec-Work-Disp 516800 When Col-Prec(Col-Ctr) = 12 516900 Move DFC-Dec-Work-A To Dec-Pic-12-A 517000 Move Dec-Pic-12 To DFC-Dec-Work-Disp 517100 When Col-Prec(Col-Ctr) = 13 517200 Move DFC-Dec-Work-A To Dec-Pic-13-A 517300 Move Dec-Pic-13 To DFC-Dec-Work-Disp 517400 When Col-Prec(Col-Ctr) = 14 517500 Move DFC-Dec-Work-A To Dec-Pic-14-A 517600 Move Dec-Pic-14 To DFC-Dec-Work-Disp 517700 When Col-Prec(Col-Ctr) = 15 517800 Move DFC-Dec-Work-A To Dec-Pic-15-A 517900 Move Dec-Pic-15 To DFC-Dec-Work-Disp 518000 When Other 518100 Display 'Unsupported Decimal value precision ( > 15)' 518200 'encountered' 518300 Display 'while processing Decimal column.' 518400 Display 'RXDB2V23 is terminating.' 518500 Move +8 To CAF-Hold-Rc 518600 Move -999 To SQLCode 518700 Perform 280-Check-For-RollBack 518800 End-Evaluate 518900 . 519000/ 519100 950-Display-ShvBlock. 519200 519300 Move Block-Number To Num-Disp 519400 Display ' ' 519500 Display '---------------------------------------------------' 519600 Display 'Begin IRXEXCOM Shared Variable Block (' Num-Disp 519700 ') contents' 519800 Display '---------------------------------------------------' 519900 Display ' ' 520000 Move EXCOM-ShvRet(Block-Number) To C2D-By-2-Char 520100 Move C2D-Number To Num-Disp-15 520200 Display 'EXCOM-ShvRet ..... ' Num-Disp-15 ' (decimal)' 520300 Evaluate True 520400 When EXCOM-ShvRet(Block-Number) = x'00' 520500 Display ' ' 520600 'Execution was OK' 520700 When EXCOM-ShvRet(Block-Number) = x'01' 520800 Display ' ' 520900 'Variable did not exist' 521000 When EXCOM-ShvRet(Block-Number) = x'02' 521100 Display ' ' 521200 'Last variable transferred (for function "N")' 521300 When EXCOM-ShvRet(Block-Number) = x'04' 521400 Display ' ' 521500 'Truncation occurred during "Fetch"' 521600 When EXCOM-ShvRet(Block-Number) = x'08' 521700 Display ' ' 521800 'Invalid variable name' 521900 When EXCOM-ShvRet(Block-Number) = x'10' 522000 Display ' ' 522100 'Value too long' 522200 When EXCOM-ShvRet(Block-Number) = x'80' 522300 Display ' ' 522400 'Invalid function code (ShvCode)' 522500 When Other 522600 Continue 522700 End-Evaluate 522800 Move EXCOM-ShvNext-Num(Block-Number) To Num-Disp-15 522900 Display 'EXCOM-ShvNext .... ' Num-Disp-15 ' (decimal)' 523000 Move EXCOM-ShvUser(Block-Number) To Num-Disp-15 523100 Display 'EXCOM-ShvUser .... ' Num-Disp-15 523200 Move EXCOM-ShvCode(Block-Number) 523300 To Just-Right-Field 523400 Display 'EXCOM-ShvCode .... ' Just-Right-Field 523500 Move EXCOM-ShvBufL(Block-Number) To Num-Disp-15 523600 Display 'EXCOM-ShvBufL .... ' Num-Disp-15 523700 Move EXCOM-ShvNamA-Num(Block-Number) To Num-Disp-15 523800 Display 'EXCOM-ShvNamA .... ' Num-Disp-15 ' (decimal)' 523900 Call 'Convert-To-Hex' Using By Content 524000 Length Of Excom-ShvNamA(Block-Number) 524100 By Reference 524200 Excom-ShvNamA(Block-Number) 524300 C2X-Return-Buf 524400 Display 'EXCOM-ShvNamA .... ' C2X-Return-Buf (1:8) 524500 ' (hex)' 524600 Move EXCOM-ShvNamL(Block-Number) To Num-Disp-15 524700 Display 'EXCOM-ShvNamL .... ' Num-Disp-15 524800 Move EXCOM-ShvValA-Num(Block-Number) To Num-Disp-15 524900 Display 'EXCOM-ShvValA .... ' Num-Disp-15 ' (decimal)' 525000 Call 'Convert-To-Hex' Using By Content 525100 Length Of Excom-ShvValA(Block-Number) 525200 By Reference 525300 Excom-ShvValA(Block-Number) 525400 C2X-Return-Buf 525500 Display 'EXCOM-ShvValA .... ' C2X-Return-Buf (1:8) 525600 ' (hex)' 525700 Move EXCOM-ShvValL(Block-Number) To Num-Disp-15 525800 Display 'EXCOM-ShvValL .... ' Num-Disp-15 525900 Set Address Of Work-Buf To EXCOM-ShvNamA(Block-Number) 526000 Display 'Variable Name .... "' 526100 Work-Buf (1:EXCOM-ShvNamL(Block-Number)) '"' 526200 Set Address Of Work-Buf To EXCOM-ShvValA(Block-Number) 526300 Display 'Variable Value ... "' 526400 Work-Buf (1:EXCOM-ShvValL(Block-Number)) '"' 526500 Display ' ' 526600 Display '---------------------------------------------------' 526700 Display 'End IRXEXCOM Shared Variable Block (' Num-Disp 526800 ') contents' 526900 Display '---------------------------------------------------' 527000 . 527100/ 527200 990-Terminate. 527300 527400* Automatically Commit Work on behalf of user if statement 527500* executed successfully ( SQLCode = 0 ) 527600 If SQLCode = Zero Then 527700 If (Reuse-Attach And (NOT Detach-Requested)) 527800 Or Attach-Requested Then 527900 Continue 528000 Else 528100 Exec SQL 528200 COMMIT WORK 528300 End-Exec 528400 If SQLCode NOT = Zero Then 528500 Display 'Your SQL statement executed successfully' 528600 ' ( SQLCode = 0 ).' 528700 Display 'However, a COMMIT of that statement failed.' 528800 Display 'The SQLCA contains information about the' 528900 ' COMMIT failure.' 529000 Move +8 To CAF-Hold-Rc 529100 Perform 500-Set-Rexx-SQLCA-Vars 529200 End-If 529300 End-If 529400 End-If 529500 529600 If Detach-Requested 529700 Or ( NOT Reuse-Attach And NOT Attach-Requested ) Then 529800 Perform 993-Detach-From-DB2 529900 End-If 530000 530100 Perform 995-Set-EvalBlock-GoBack 530200 . 530300/ 530400 993-Detach-From-DB2. 530500 530600 If Detach-Requested 530700 Initialize SqlCa 530800 Perform 500-Set-Rexx-SQLCA-Vars 530900 End-If 531000 531100 If Plan-Has-Been-Opened Then 531200* Close Application Plan 531300 Set CAF-Close-Plan To True 531400 Set CAF-Sync-TermOpt To True 531500 Move 'RXDB2V23' 531600 To CAF-Plan-Name 531700* Call DsnAli Using CAF-Function 531800 Call 'DSNALI' Using CAF-Function 531900 CAF-Terminate-Opt 532000 CAF-Rc 532100 CAF-Reason-Code 532200 Perform 997-Set-Rexx-CAF-Reason-Code 532300 If (CAF-Rc NOT = Zero) 532400 And NOT CAF-Ready 532500 Call 'Convert-To-Hex' Using 532600 By Content Length Of CAF-Reason-Code 532700 By Reference CAF-Reason-Code 532800 C2X-Return-Buf 532900 Compute Tally = 2 * Length Of CAF-Reason-Code 533000 Display 'CAF Close Plan failed for plan "' 533100 CAF-Plan-Name '"' 533200 ' with DB2 reason code ''' 533300 C2X-Return-Buf (1:Tally) '''x' 533400 Move CAF-Rc To Num-Disp 533500 Display 'CAF Call return code = ' Num-Disp 533600 Display 'RXDB2V23 is terminating.' 533700 Move +8 To CAF-Hold-Rc 533800 End-If 533900 End-If 534000 534100* Disconnect From DB2 534200 Set CAF-Disconnect To True 534300* Call DsnAli Using CAF-Function 534400 Call 'DSNALI' Using CAF-Function 534500 CAF-Rc 534600 CAF-Reason-Code 534700 Perform 997-Set-Rexx-CAF-Reason-Code 534800 If (CAF-Rc NOT = Zero) 534900 And NOT CAF-Ready 535000 Call 'Convert-To-Hex' Using 535100 By Content Length Of CAF-Reason-Code 535200 By Reference CAF-Reason-Code 535300 C2X-Return-Buf 535400 Compute Tally = 2 * Length Of CAF-Reason-Code 535500 Display 'CAF DisConnect failed' 535600 ' with DB2 reason code ''' 535700 C2X-Return-Buf (1:Tally) '''x' 535800 Move CAF-Rc To Num-Disp 535900 Display 'CAF Call return code = ' Num-Disp 536000 Display 'RXDB2V23 is terminating.' 536100 Move +8 To CAF-Hold-Rc 536200 End-If 536300 . 536400/ 536500 995-Set-EvalBlock-GoBack. 536600 536700* If program was not invoked as Rexx routine, return control 536800* one way, otherwise, return control as a Rexx external 536900* routine. 537000 If Address Of IRXEFPL-Arg-List = Null Then 537100 Move CAF-Hold-Rc 537200 To Return-Code 537300 Else 537400* Base EFPL Evaluation Block 537500 Set Address Of IRXEFPL-EvalBlock 537600 To IRXEFPL-EvalBlock-Addr 537700* Set Evaluation Return Code 537800 Move +1 To IRXEFPL-EvLen 537900 Move CAF-Hold-Rc To Num-Pic-1 538000 Move Zero To Return-Code 538100 Move Num-Pic-1-A To IRXEFPL-EvData 538200 End-If 538300 GoBack 538400 . 538500/ 538600 997-Set-Rexx-CAF-Reason-Code. 538700 538800*--- Set value of "RXDB2.CAF_REASON_CODE" 538900 Set EXCOM-Set-Variable-Direct(1) To True 539000 Set EXCOM-ShvNext(1) To Null 539100 Call 'Set-Pointer' Using RXDB2-CAF-Reason-Code 539200 EXCOM-ShvNamA(1) 539300 Call 'Set-Pointer' Using CAF-Reason-Code 539400 EXCOM-ShvValA(1) 539500 Move Length Of RXDB2-CAF-Reason-Code 539600 To EXCOM-ShvNamL(1) 539700 Move Length Of CAF-Reason-Code 539800 To EXCOM-ShvValL(1) 539900 Perform 900-Call-IRXEXCOM 540000 . 540100/*---------------------------------------------------------------* 540200* Program: Set-Pointer * 540300* * 540400* * 540500* Sets a pointer to the address of a data item. * 540600* * 540700*---------------------------------------------------------------*/ 540800 540900 Identification Division. 541000 Program-Id Set-Pointer is Common. 541100 541200 Data Division. 541300 Linkage Section. 541400 541500 01 Data-Item Pic X(01). 541600 01 Data-Pointer Pointer. 541700 541800 Procedure Division Using Data-Item 541900 Data-Pointer. 542000 542100 Set Data-Pointer to Address of Data-Item. 542200 Goback 542300 . 542400 End Program Set-Pointer. 542500/*---------------------------------------------------------------* 542600* Program: Display-Documentation * 542700* * 542800* * 542900* Displays documentation for use of RxDB2. * 543000* * 543100*---------------------------------------------------------------*/ 543200 543300 Identification Division. 543400 Program-Id Display-Documentation. 543500 543600 Data Division. 543700 Procedure Division. 543800 543900 Display ' ' 544000 Display ' ' 544100 'RxDB2 Rexx-To-DB2 Interface Routine' 544200 Display ' ' 544300 Display '***************************************************' 544400 '****************************' 544500 Display 'RxDB2 Positional Parameters:' 544600 Display ' ' 544700 Display 'DB2Sys , Stmt , Stem , FetchLim , HostVars, Mapstem' 544800 Display ' ' 544900 Display ' ' 545000 Display 'Where:' 545100 Display ' ' 545200 Display ' ' 545300 Display 'DB2Sys - is the name of the DB2 system on which' 545400 ' statement is to execute,' 545500 Display ' optionally followed by a Remote Location' 545600 ' name to which an initial' 545700 Display ' connect is done by RxDB2. Format is:' 545800 Display ' "db2id / remote-name"' 545900 Display ' Specifying an initial connect to a' 546000 ' remote location still' 546100 Display ' allows you to specify subsequent' 546200 ' "CONNECT" statements.' 546300 Display ' ' 546400 Display 'Stmt - An SQL statement' 546500 Display ' ' 546600 Display ' Or, the keyword "STEM" followed by a' 546700 ' space and the name of a Rexx' 546800 Display ' stem, under which multiple statements' 546900 ' reside.' 547000 Display ' (e.g. - Call RxDB2 DB27,"STEM SVAR.")' 547100 Display ' Statements are executed in sequence,' 547200 ' starting with stem.1, stem.2,' 547300 Display ' etc., until an un-initialized "stem.n"' 547400 ' is encountered, "stem.n"' 547500 Display ' is null (blanks or zero length), or a' 547600 ' negative SQLCODE is' 547700 Display ' encountered.' 547800 Display ' A "Commit" is issued at the end of' 547900 ' processing, unless a statement' 548000 Display ' yields a negative SQL code, in which' 548100 ' case a "Rollback" is issued' 548200 Display ' and processing terminates immediately.' 548300 Display ' ' 548400 Display ' Or, a DB2 command, beginning with a "-".' 548500 ' (e.g. "-DISPLAY DB(*)")' 548600 Display ' This includes the IFI "-READS" command' 548700 ' which allows reading of' 548800 Display ' synchronous trace information, as well' 548900 ' as the IFI -READA command,' 549000 Display ' which allows reading of asynchronous' 549100 ' trace information.' 549200 Display ' ' 549300 Display ' Or, the words "ATTACH" or "DETACH",' 549400 ' which allow thread reuse.' 549500 Display ' ' 549600 Display 'Stem - Name of a stem variable, into which' 549700 ' result table(s)/value(s) will be' 549800 Display ' mapped (only necessary for SELECT and' 549900 ' GET statements, and DB2' 550000 Display ' commands).' 550100 Display ' ' 550200 Display ' Result table/value mapping scheme:' 550300 Display ' For SELECT statements:' 550400 Display ' Stem.Col#.Row#' 550500 Display ' For GET statements:' 550600 Display ' Stem.1' 550700 Display ' For DB2 commands:' 550800 Display ' Stem.Line#' 550900 Display ' When multiple statements are executed,' 551000 ' the above structures are' 551100 Display ' mapped according to relative statement' 551200 ' number, as such:' 551300 Display ' Stem.Stmt#.Col#.Row#' 551400 Display ' ' 551500 Display 'FetchLim - Maximum number of rows to fetch (for' 551600 ' SELECT statements only).' 551700 Display ' ' 551800 Display 'HostVars - Blank delimited list of Rexx variable' 551900 ' names whose values are to be' 552000 Display ' used in substituting for parameter' 552100 ' markers in an SQL statement.' 552200 Display ' Each Rexx variable name can optionally' 552300 ' be followed by a slash "/"' 552400 Display ' and a datatype specifier to indicate' 552500 ' the datatype of the variable''s' 552600 Display ' value. This is necessary when the' 552700 ' datatype of the value is' 552800 Display ' ambiguous, such as a character string' 552900 ' consisting of all digits.' 553000 Display ' Valid datatype specifiers are:' 553100 Display ' CHAR, VARCHAR, INTEGER, SMALLINT, DEC' 553200 'IMAL, DATE, TIME, TIMESTAMP.' 553300 Display ' FLOAT, GRAPHIC, VARGRAPHIC' 553400 Display ' (e.g. - "hostvar1/char hostvar2 hostv' 553500 'ar3/decimal")' 553600 Display ' When multiple SQL statements are' 553700 ' supplied, this should be the' 553800 Display ' the name of a stem, under which are' 553900 ' lists of variables to be used' 554000 Display ' for each statement.' 554100 Display ' ' 554200 Display 'Mapstem - Either "CR" or "RC" to indicate how' 554300 ' result table is to be mapped' 554400 Display ' under the supplied stem.' 554500 Display ' ("CR" means stem.column.row, and' 554600 ' "RC" means stem.row.column.' 554700 Display ' Default is "CR".)' 554800 Display '===================================================' 554900 '============================' 555000 Display ' ' 555100 Display 'Return Codes:' 555200 Display '---------------------------------------------------' 555300 '----------------------------' 555400 Display 'RxDB2 returns a value indicating:' 555500 Display ' Result = 0 ---> Call succeeded' 555600 Display ' Result = 4 ---> SQLCODE or IFCA_Return_Code' 555700 ' was non-zero, but the call' 555800 Display ' to RxDB2 was successful' 555900 Display ' Result > 4 ---> RxDB2 call error or failure' 556000 Display ' ' 556100 Display 'DB2 Communication Variables:' 556200 Display '---------------------------------------------------' 556300 '----------------------------' 556400 Display '- Complete SQLCA information is available under the' 556500 ' stem "SQLCA."' 556600 Display ' In addition, the variable "SQLCA.SQLMSG" contains' 556700 ' a DSNTIAR-formatted message' 556800 Display '- Complete SQLDA information is available under the' 556900 ' stem "SQLDA."' 557000 Display '- For DB2 Command and Trace calls, complete IFCA' 557100 ' information is available' 557200 Display ' under the stem "IFCA."' 557300 Display ' ' 557400 Display 'RXDB2 information variables:' 557500 Display '---------------------------------------------------' 557600 '----------------------------' 557700 Display 'In addition to communication variables, RxDB2' 557800 ' provides additional' 557900 Display 'information in a set of variables under the stem' 558000 ' RXDB2.' 558100 Display ' ' 558200 Display '"RXDB2.CAF_REASON_CODE contains the DB2 reason' 558300 ' code from CAF.' 558400 Display '"RXDB2.SQLCAVARS" contains the names of variables' 558500 ' under the stem SQLCA.' 558600 Display '"RXDB2.SQLDAVARS" contains the names of variables' 558700 ' under the stem SQLDA.' 558800 Display '"RXDB2.IFCAVARS" contains the names of variables' 558900 ' under the stem IFCA.' 559000 Display '"RXDB2.IFQAVARS" contains the names of variables' 559100 ' expected under the stem IFQA.' 559200 Display '"RXDB2.SQLSTMT" contains the text of the last' 559300 ' SQL statement executed.' 559400 Display '"RXDB2.SQLSNO" contains the relative statement' 559500 ' number of the last SQL' 559600 Display ' statement executed.' 559700 Display '"RXDB2.DB2VER" contains release level of the' 559800 ' DB2 to which you are connected.' 559900 Display '"RXDB2.SQLSYSID" contains the name of the DB2' 560000 ' subsystem to which you' 560100 Display ' are attached.' 560200 Display ' (Which may/may-not be where' 560300 ' statements are executed)' 560400 Display '"RXDB2.SQLSERVER" contains the name of the server' 560500 ' on which statement was' 560600 Display ' executed.' 560700 Display '"RXDB2.SQLSTEM" contains the name of the stem' 560800 ' variable under which results' 560900 Display ' of SELECT or a DB2 command was' 561000 ' mapped (if applicable).' 561100 Display '"RXDB2.NOWHERE" contains "W" if the most recently' 561200 ' executed statement' 561300 Display ' was a DELETE or UPDATE statement' 561400 ' without a WHERE clause;' 561500 Display ' spaces otherwise.' 561600 Display ' ' 561700 Display 'Null Values:' 561800 Display '---------------------------------------------------' 561900 '----------------------------' 562000 Display 'For the result table of a SELECT statement,' 562100 ' nullable columns are' 562200 Display 'indicated by the truth value of the variable' 562300 ' "SQLDA.SQLNULL.col#".' 562400 Display '( = 1 -> Nullable = 0 -> Not Nullable )' 562500 Display ' ' 562600 Display 'If a particular row-column cell of a result table' 562700 ' contains the null value,' 562800 Display 'the corresponding stem value will be un-initialized' 562900 Display '(e.g. - If the value of the variable "STEM.1.3" is' 563000 ' null, then the expression' 563100 Display '"Symbol(''STEM.1.3'')" yields "LIT" rather than' 563200 ' "VAR").' 563300 Display ' ' 563400 Display 'Column Widths:' 563500 Display '---------------------------------------------------' 563600 '----------------------------' 563700 Display 'The maximum column width for each column is' 563800 ' returned in the variable' 563900 Display '"SQLDA.SQLLEN.col#".' 564000 Display 'For Decimal columns, the Precision (P) and Scale' 564100 ' (S) are returned in the' 564200 Display 'variable "SQLDA.SQLLEN.col#" in the form "P,S".' 564300 Display '(e.g. - SqlDa.SqlLen.4 = "7,2")' 564400 Display ' ' 564500 Display 'Number of Rows Returned:' 564600 Display '---------------------------------------------------' 564700 '----------------------------' 564800 Display 'The number of rows/records under the result stem is' 564900 ' indicated by the value of' 565000 Display 'the result table stem "Stem-Dot-Zero", in the same' 565100 ' way that EXECIO indicates' 565200 Display 'the number of records mapped under a stem.' 565300 Display '(e.g. - ResTab.0 = 435 indicates 435 rows mapped' 565400 ' under the stem "RESTAB.")' 565500 Display ' ' 565600 Display 'Executing Multiple Statements in One Call:' 565700 Display '---------------------------------------------------' 565800 '----------------------------' 565900 Display 'Multiple statements can be executed in a single' 566000 ' call to RxDB2. This will' 566100 Display 'affect the naming structure of some communication' 566200 ' and result table variables.' 566300 Display 'When multiple statements are executed:' 566400 Display '- SELECT statement result table(s) are mapped under' 566500 ' the result stem as' 566600 Display ' "Stem.Stmt#.Col#.Row#".' 566700 Display '- DB2 Command/Trace result records are mapped under' 566800 ' the result stem as' 566900 Display ' "Stem.Stmt#.Rec#".' 567000 Display '- The number of rows/records for each result is ind' 567100 'icated by the value of' 567200 Display ' "Stem.Stmt#.0".' 567300 Display '- The "SQLDA." structure for each SQL statement is' 567400 ' mapped under "SQLDA." as' 567500 Display ' "SQLDA.Stmt#.SQLD"' 567600 Display ' "SQLDA.Stmt#.SQLNAME.col#"' 567700 Display ' "SQLDA.Stmt#.SQLTYPE.col#"' 567800 Display ' "SQLDA.Stmt#.SQLLEN.col#"' 567900 Display ' "SQLDA.Stmt#.SQLNULL.col#"' 568000 Display ' ' 568100 Display 'DB2 Traces:' 568200 Display '---------------------------------------------------' 568300 '----------------------------' 568400 Display 'When reading DB2 trace data with the IFI "-READS"' 568500 ' command, you can supply' 568600 Display 'qualification data under the stem "IFQA.". The' 568700 ' "IFQA." variable names are' 568800 Display 'listed under the variable "RXDB2.IFQAVARS".' 568900 Display ' ' 569000 Display 'You must supply at least one IFCID value under the' 569100 ' variable "IFQA.CID_LIST" in' 569200 Display 'hex format for either the "-READS" or "-READA"' 569300 ' command.' 569400 Display '(e.g. ifqa.cid_list = ''0092''x for IFCID 146)' 569500 Display ' ' 569600 Display '"Special" SQL Statements:' 569700 Display '---------------------------------------------------' 569800 '----------------------------' 569900 Display 'RxDB2 allows you to use the following "static-only"' 570000 ' SQL Statements:' 570100 Display ' ' 570200 Display '- CONNECT' 570300 Display '- CONNECT TO location-name' 570400 Display '- CONNECT RESET' 570500 Display '- DESCRIBE TABLE tablename' 570600 Display '- DESCRIBE sql-statement' 570700 Display '- SET CURRENT PACKAGESET = USER' 570800 Display '- SET CURRENT PACKAGESET = packageset-name' 570900 Display '- GET special-register' 571000 Display ' ' 571100 Display 'For the "DESCRIBE" statements, the description is' 571200 ' returned in the SQLDA.' 571300 Display ' ' 571400 Display 'For the "SET CURRENT PACKAGESET" statement, a pack' 571500 'ageset name of "USER" must' 571600 Display 'be specified as: SET CURRENT PACKAGESET = "USER"' 571700 Display ' ' 571800 Display 'The "GET special-register" statement is equivalent' 571900 ' to the actual SQL Statement:' 572000 Display ' "SET :hostvar = special-register"' 572100 Display 'The result of a "GET special-register" statement' 572200 ' is returned under the result' 572300 Display 'stem, as usual.' 572400 Goback 572500 . 572600 End Program Display-Documentation. 572700/*---------------------------------------------------------------* 572800* Program: Convert-To-Hex * 572900* * 573000* * 573100* Converts a byte string to its hex character representation. * 573200* * 573300*---------------------------------------------------------------*/ 573400 573500 Identification Division. 573600 Program-Id Convert-To-Hex. 573700 573800 Data Division. 573900 Working-Storage Section. 574000 574100 01 IRXEXEC-Parm-Fields. 574200 05 IRXEXEC Pic x(8) Value 'IRXEXEC'. 574300 05 IRXEXEC-ExecBlk-Addr Pointer Value Null. 574400 05 IRXEXEC-ArgList-Addr Pointer. 574500 05 IRXEXEC-Exec-Type Pic x(4) Value x'40000000'. 574600* (Function) 574700 05 IRXEXEC-InStBlk-Addr Pointer. 574800 05 IRXEXEC-CPPL-Addr Pointer Value Null. 574900 05 IRXEXEC-EvalBlock-Addr Pointer Value Null. 575000 05 IRXEXEC-WorkArea-Addr Pointer Value Null. 575100 05 IRXEXEC-User-Fld-Addr Pointer Value Null. 575200 575300*----Rexx Exec-Block 575400 01 IRXEXECBLK. 575500 05 EXECBLK-Acryn Pic x(8) Value 'IRXEXECB'. 575600 05 EXECBLK-Len Pic s9(9) Comp Value 48. 575700 05 EXECBLK-Reserved Pic x(4). 575800 05 EXECBLK-Member Pic x(8) Value Spaces. 575900 05 EXECBLK-DDName Pic x(8) Value Spaces. 576000 05 EXECBLK-SubCom Pic x(8) Value Spaces. 576100 05 EXECBLK-DsnPtr Pointer Value Null. 576200 05 EXECBLK-DsnLen Pic s9(9) Comp Value Zero. 576300 576400*----Rexx Exec Argument List 576500 01 IRXEXEC-Arg-List. 576600 05 EXEC-Arg-Vector Occurs 10 Times. 576700 10 EXEC-Arg-Addr Pointer. 576800 10 EXEC-Arg-Len Pic s9(9) Comp. 576900 577000*----Rexx In-Storage Control Block 577100 01 IRXINSTBLK. 577200 05 INSTBLK-Acryn Pic x(8) Value 'IRXINSTB'. 577300 05 INSTBLK-HdrLen Pic s9(9) Comp Value 128. 577400 05 INSTBLK-Reserved-1 Pic x(4). 577500 05 INSTBLK-Exec-Vector-Addr Pointer. 577600 05 INSTBLK-Exec-Vector-Len Pic s9(9) Comp. 577700 05 INSTBLK-Member Pic x(8) Value Spaces. 577800 05 INSTBLK-DDName Pic x(8) Value Spaces. 577900 05 INSTBLK-SubCom Pic x(8) Value Spaces. 578000 05 INSTBLK-Reserved-2 Pic x(4). 578100 05 INSTBLK-DsnLen Pic s9(9) Comp Value Zero. 578200 05 INSTBLK-DsName Pic x(72). 578300 578400*----Rexx Evaluation Block 578500 01 EvalBlock. 578600 05 EvalBlk-EvPad1 Pic x(4) Value Low-Values. 578700 05 EvalBlk-EvSize Pic s9(9) Comp Value +65. 578800 05 EvalBlk-EvLen Pic s9(9) Comp. 578900 05 EvalBlk-EvPad2 Pic x(4) Value Low-Values. 579000 05 EvalBlk-EvData Pic x(504). 579100 579200 01 Exec-Vector. 579300 05 Exec-Element Occurs 10 Times. 579400 10 EXECVECT-Stmt-Addr Pointer. 579500 10 EXECVECT-Stmt-Len Pic s9(9) Comp. 579600 579700 01 Exec-Table. 579800 05 Exec-Stmt Occurs 10 Times 579900 Pic x(80). 580000 580100 01 Misc-Stuff. 580200 05 Num-Disp-15 Pic --------------9. 580300 05 C2X-Lctr Pic s9(4) Comp. 580400 Linkage Section. 580500 580600 01 String-Len Pic s9(9) Comp. 580700 01 String-Text Pic x(250). 580800 01 Hex-Representation Pic x(500). 580900 581000 Procedure Division Using String-Len 581100 String-Text 581200 Hex-Representation. 581300 581400*/---------------------------------------------------------------\ 581500* 581600* Following code executes an in-storage Rexx exec. 581700* 581800*\---------------------------------------------------------------/ 581900*--- Build In-Storage Rexx Exec 582000 Move Spaces To Exec-Table 582100 Move 'RETURN C2X(ARG(1))' 582200 To Exec-Stmt(1) 582300 582400*--- Point In-Storage vector of records to individual records 582500* (This must be done for all 10 records, regardless of how 582600* many are "used" in the exec). 582700 Perform Varying C2X-Lctr From 1 By 1 582800 Until C2X-Lctr > 10 582900 Call 'Set-Pointer' Using Exec-Stmt(C2X-Lctr) 583000 EXECVECT-Stmt-Addr(C2X-Lctr) 583100 Move Length Of Exec-Stmt(C2X-Lctr) 583200 To EXECVECT-Stmt-Len(C2X-Lctr) 583300 End-Perform 583400 583500*--- Point In-Storage Control Block to vector of records 583600 Call 'Set-Pointer' Using Exec-Vector 583700 INSTBLK-Exec-Vector-Addr 583800 Move Length Of Exec-Vector 583900 To INSTBLK-Exec-Vector-Len 584000 584100*--- Point to argument list 584200 Move All x'FF' To IRXEXEC-Arg-List 584300 Call 'Set-Pointer' Using IRXEXEC-Arg-List 584400 IRXEXEC-ArgList-Addr 584500 584600*--- Point Arg-Vector To Arg #1 584700 Call 'Set-Pointer' Using String-Text 584800 EXEC-Arg-Addr(1) 584900 If String-Len >= Zero Then 585000 Move String-Len 585100 To EXEC-Arg-Len(1) 585200 Else 585300 Move Length Of String-Text 585400 To EXEC-Arg-Len(1) 585500 End-If 585600 585700*--- Point to In-Storage Control Block 585800 Call 'Set-Pointer' Using IRXINSTBLK 585900 IRXEXEC-InStBlk-Addr 586000 586100*--- Point to Evaluation Block 586200 Call 'Set-Pointer' Using EvalBlock 586300 IRXEXEC-EvalBlock-Addr 586400 586500 Call IRXEXEC Using IRXEXEC-ExecBlk-Addr 586600 IRXEXEC-ArgList-Addr 586700 IRXEXEC-Exec-Type 586800 IRXEXEC-InStBlk-Addr 586900 IRXEXEC-CPPL-Addr 587000 IRXEXEC-EvalBlock-Addr 587100 IRXEXEC-WorkArea-Addr 587200 IRXEXEC-User-Fld-Addr 587300 587400 If Return-Code NOT = Zero Then 587500 Move Return-Code To Num-Disp-15 587600 Display 'IRXEXEC Return Code = ' Num-Disp-15 587700 End-If 587800 Move EvalBlk-EvData (1:EvalBlk-EvLen) 587900 To Hex-Representation 588000 Goback 588100 . 588200 End Program Convert-To-Hex. 588300 End Program RXDB2V23. ./ ADD NAME=SERVSPLT 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. SERVSPLT. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* THIS PROGRAM WILL READ A SERVHIST FILE SEQUENTIALLY AND * 000700* BASED ON INPUT PARMS OF A TOTAL RECORD ESTIMATE AND HOW MANY * 000800* RELATIVELY EVENLY SPLIT FILES YOU WOULD LIKE TO DIVIDE IT * 000900* INTO, IT WILL TELL YOU THE EXACT SSN RANGES, AND SSN RANGES * 001000* BASED ON THE EVF RANGE SPECIFICATION. * 001100***************************************************************** 001200************************ EXAMPLE JCL **************************** 001300* //STEP01 EXEC PGM=SERVSPLT * 001400* // PARM='RECORDS=445842,FILES=9' * 001500* //STEPLIB DD DSN=YOURID.COBOL.LOAD, * 001600* // DISP=(SHR,KEEP,KEEP) * 001700* // DD DSN=SYS1.COB2LIB, * 001800* // DISP=(SHR,KEEP,KEEP) * 001900* //SERVHIST DD DSN=T.USC10.SLSS.SERVHSTA.ME1(0), * 002000* // DISP=(SHR,KEEP,KEEP) * 002100* // DD DSN=T.USC10.SLSS.SERVHSTB.ME1(0), * 002200* // DISP=(SHR,KEEP,KEEP) * 002300* //SYSUDUMP DD SYSOUT=* * 002400* //SYSDBOUT DD SYSOUT=* * 002500* //SYSOUD DD SYSOUT=* * 002600***************************************************************** 002700/**************************************************************** 002800* E N V I R O N M E N T D I V I S I O N * 002900***************************************************************** 003000 ENVIRONMENT DIVISION. 003100 003200 INPUT-OUTPUT SECTION. 003300 003400 FILE-CONTROL. 003500 003600 SELECT SERVHIST-FILE ASSIGN TO SERVHIST. 003700 003800/**************************************************************** 003900* D A T A D I V I S I O N * 004000***************************************************************** 004100 DATA DIVISION. 004200 004300 FILE SECTION. 004400 004500***************************************************************** 004600* SERVHIST FILE FD * 004700***************************************************************** 004800 FD SERVHIST-FILE 004900 RECORD CONTAINS 780 TO 16218 CHARACTERS 005000 LABEL RECORDS ARE STANDARD 005100 RECORDING MODE IS V 005200 BLOCK CONTAINS 0 RECORDS 005300 DATA RECORD IS SERVHIST-RECORD. 005400 01 SERVHIST-RECORD. 005500 05 SH-FIXED-AREA-FDD. 005600 10 SH-RECORD-KEY-FDD PIC X(09). 005700 10 SH-VAR-COUNTER-FDD PIC S9(03). 005800 10 SH-OVERFLOW-NUMBER-FDD 005900 PIC 9(02). 006000 10 FILLER PIC X(704). 006100 05 SH-VARIABLE-AREA-FDD. 006200 10 SH-DATE-COMMENT-FDD PIC X(62) 006300 OCCURS 1 TO 250 TIMES 006400 DEPENDING ON SH-VAR-COUNTER-FDD. 006500 006600/**************************************************************** 006700* W O R K I N G - S T O R A G E S E C T I O N * 006800***************************************************************** 006900 WORKING-STORAGE SECTION. 007000***************************************************************** 007100* A C C U M U L A T O R S * 007200***************************************************************** 007300 01 ACCUMULATORS. 007400 05 FILLER PIC X(13) VALUE 007500 'ACCUMULATORS:'. 007600 05 A-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 007700 05 A-SSNS-IN-THIS-RANGE PIC S9(08) COMP SYNC VALUE +0. 007800/**************************************************************** 007900* C O N S T A N T S * 008000***************************************************************** 008100 01 CONSTANTS. 008200 05 FILLER PIC X(10) VALUE 008300 'CONSTANTS:'. 008400 05 C-INCREMENT PIC S9(08) COMP SYNC VALUE +10000. 008500/**************************************************************** 008600* S W I T C H E S * 008700***************************************************************** 008800 01 SWITCHES. 008900 05 FILLER PIC X(09) VALUE 009000 'SWITCHES:'. 009100 05 S-END-OF-FILE-SWITCH PIC X(01) VALUE 'Y'. 009200 88 S-MORE-RECORDS-EXIST VALUE 'Y'. 009300 88 S-NO-MORE-RECORDS-EXIST VALUE 'N'. 009400 05 S-PARM-SWITCH PIC X(01) VALUE 'Y'. 009500 88 S-BAD-PARM VALUE 'N'. 009600 88 S-GOOD-PARM VALUE 'Y'. 009700/**************************************************************** 009800* W O R K A R E A S * 009900***************************************************************** 010000 01 WORK-AREAS. 010100 05 FILLER PIC X(11) VALUE 010200 'WORK AREAS:'. 010300 05 W-INCREMENT PIC S9(08) COMP SYNC VALUE +0. 010400 05 W-RANGE-INCREMENT PIC S9(08) COMP SYNC VALUE +0. 010500 05 W-CURRENT-RANGE-NUMBER PIC 9(02) VALUE 0. 010600 05 W-PARM-DATA PIC X(100) VALUE SPACES. 010700 05 W-VARIABLE-1 PIC X(008) VALUE SPACES. 010800 05 W-VALUE-1 PIC X(008) VALUE SPACES. 010900 05 W-VALUE-1-NUMERIC REDEFINES W-VALUE-1 PIC 9(008). 011000 05 W-VALUE-1-ARRAY REDEFINES W-VALUE-1 011100 OCCURS 8 TIMES 011200 INDEXED BY W-V1-NDX1 011300 W-V1-NDX2. 011400 10 W-VALUE-1-BYTE PIC X(001). 011500 05 W-VARIABLE-2 PIC X(008) VALUE SPACES. 011600 05 W-VALUE-2 PIC X(008) VALUE SPACES. 011700 05 W-VALUE-2-NUMERIC REDEFINES W-VALUE-2 PIC 9(008). 011800 05 W-VALUE-2-ARRAY REDEFINES W-VALUE-2 011900 OCCURS 8 TIMES 012000 INDEXED BY W-V2-NDX1 012100 W-V2-NDX2. 012200 10 W-VALUE-2-BYTE PIC X(001). 012300/**************************************************************** 012400* L I N K A G E S E C T I O N * 012500***************************************************************** 012600 LINKAGE SECTION. 012700 01 L-PARM. 012800 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 012900 05 L-PARM-DATA PIC X(100). 013000/**************************************************************** 013100* P R O C E D U R E D I V I S I O N * 013200***************************************************************** 013300 PROCEDURE DIVISION USING L-PARM. 013400***************************************************************** 013500* S0000-DRIVER * 013600* THIS SECTION SIMPLY CONTROLS PROCESSING AT THE HIGHEST LEVEL. * 013700* IT CALLS INITIALIZATION, MAINLINE, AND FINALIZATION. * 013800***************************************************************** 013900 S0000-DRIVER SECTION. 014000 014100 PERFORM S1000-INITIALIZATION. 014200 014300 IF S-GOOD-PARM 014400 PERFORM S2000-PROCESS-RECORDS 014500 UNTIL S-NO-MORE-RECORDS-EXIST. 014600 014700 PERFORM S3000-FINALIZATION. 014800 014900 GOBACK. 015000 015100 S0000-EXIT. 015200 EXIT. 015300/**************************************************************** 015400* S1000-INITIALIZATION * 015500* THIS SECTION CONTROLS ANY INITIAL PROCESSING WHICH NEEDS TO * 015600* TAKE PLACE PRIOR TO PROCESSING THROUGH THE SERVHIST FILE. * 015700* FILE OPENS AND INTIAL READS TAKE PLACE HERE, AND ANY PARM * 015800* PARSING AND VALIDATION COULD TAKE PLACE HERE IF NECESSARY. * 015900***************************************************************** 016000 S1000-INITIALIZATION SECTION. 016100 016200 DISPLAY ' ....+....1....+....2....+' 016300 '....3....+....4....+....5....+....6....+' 016400 '....7....+....8....+....9....+....0'. 016500 DISPLAY 'INPUT PARM- ' L-PARM-DATA. 016600 016700 MOVE L-PARM-DATA TO W-PARM-DATA. 016800 016900 INSPECT W-PARM-DATA REPLACING ALL LOW-VALUES BY SPACES. 017000 INSPECT W-PARM-DATA REPLACING ALL '=' BY SPACES. 017100 INSPECT W-PARM-DATA REPLACING ALL ',' BY SPACES. 017200 017300 UNSTRING W-PARM-DATA 017400 DELIMITED BY ALL SPACES 017500 INTO W-VARIABLE-1 W-VALUE-1 017600 W-VARIABLE-2 W-VALUE-2 017700 END-UNSTRING. 017800 017801 DISPLAY ' '. 017802 DISPLAY 'W-VARIABLE-1 = ' W-VARIABLE-1. 017803 DISPLAY 'W-VARIABLE-2 = ' W-VARIABLE-2. 017810 017820 DISPLAY ' '. 017830 DISPLAY 'W-VALUE-1 = ' W-VALUE-1. 017840 DISPLAY 'W-VALUE-2 = ' W-VALUE-2. 017850 017900 PERFORM VARYING W-V1-NDX2 FROM +8 BY -1 018000 UNTIL W-V1-NDX2 < +1 018100 OR W-VALUE-1-BYTE (W-V1-NDX2) IS NUMERIC 018200 END-PERFORM. 018300 018400 IF W-V1-NDX2 > +0 018410 SET W-V1-NDX1 TO W-V1-NDX2 018420 SET W-V1-NDX2 TO +8 018500 PERFORM VARYING W-V1-NDX1 FROM W-V1-NDX1 BY -1 018600 UNTIL W-V1-NDX1 < +1 018700 MOVE W-VALUE-1-BYTE (W-V1-NDX1) TO 018710 W-VALUE-1-BYTE (W-V1-NDX2) 018800 SET W-V1-NDX2 DOWN BY +1 018900 END-PERFORM 019000 END-IF. 019300 019310 PERFORM VARYING W-V1-NDX2 FROM W-V1-NDX2 BY -1 019320 UNTIL W-V1-NDX2 < +1 019330 MOVE '0' TO W-VALUE-1-BYTE (W-V1-NDX2) 019340 END-PERFORM. 020700 020710 PERFORM VARYING W-V2-NDX2 FROM +8 BY -1 020720 UNTIL W-V2-NDX2 < +1 020730 OR W-VALUE-2-BYTE (W-V2-NDX2) IS NUMERIC 020740 END-PERFORM. 020750 020760 IF W-V2-NDX2 > +0 020770 SET W-V2-NDX1 TO W-V2-NDX2 020780 SET W-V2-NDX2 TO +8 020790 PERFORM VARYING W-V2-NDX1 FROM W-V2-NDX1 BY -1 020791 UNTIL W-V2-NDX1 < +1 020792 MOVE W-VALUE-2-BYTE (W-V2-NDX1) TO 020793 W-VALUE-2-BYTE (W-V2-NDX2) 020794 SET W-V2-NDX2 DOWN BY +1 020795 END-PERFORM 020796 END-IF. 020797 020798 PERFORM VARYING W-V2-NDX2 FROM W-V2-NDX2 BY -1 020799 UNTIL W-V2-NDX2 < +1 020800 MOVE '0' TO W-VALUE-2-BYTE (W-V2-NDX2) 020801 END-PERFORM. 020802 020803 DISPLAY ' '. 020804 DISPLAY 'W-VALUE-1 = ' W-VALUE-1. 020805 DISPLAY 'W-VALUE-2 = ' W-VALUE-2. 020806 020810 EVALUATE W-VARIABLE-1 020900 WHEN 'RECORDS' 021000 IF W-VALUE-1 IS NUMERIC AND 021100 W-VALUE-2 IS NUMERIC 021200 COMPUTE W-RANGE-INCREMENT ROUNDED = 021300 W-VALUE-1-NUMERIC / 021400 W-VALUE-2-NUMERIC 021500 ELSE 021600 DISPLAY 'INVALID "PARM" VALUE' 021700 SET S-BAD-PARM TO TRUE 021800 END-IF 021900 WHEN 'FILES' 022000 IF W-VALUE-1 IS NUMERIC AND 022100 W-VALUE-2 IS NUMERIC 022200 COMPUTE W-RANGE-INCREMENT ROUNDED = 022300 W-VALUE-2-NUMERIC / 022400 W-VALUE-1-NUMERIC 022500 ELSE 022600 DISPLAY 'INVALID "PARM" VALUE' 022700 SET S-BAD-PARM TO TRUE 022800 END-IF 022900 WHEN OTHER 023000 DISPLAY 'INVALID "PARM" VALUE' 023100 SET S-BAD-PARM TO TRUE 023200 END-EVALUATE. 023300 023400 EVALUATE W-VARIABLE-2 023500 WHEN 'RECORDS' 023600 CONTINUE 023700 WHEN 'FILES' 023800 CONTINUE 023900 WHEN OTHER 024000 DISPLAY 'INVALID "PARM" VALUE' 024100 SET S-BAD-PARM TO TRUE 024200 END-EVALUATE. 024300 024400 IF S-GOOD-PARM 024500 DISPLAY ' ' 024600 DISPLAY 'W-RANGE-INCREMENT = ' W-RANGE-INCREMENT 024700 OPEN INPUT SERVHIST-FILE 024800 PERFORM S2100-READ. 024900 025000 S1000-EXIT. 025100 EXIT. 025200/**************************************************************** 025300* S2000-PROCESS-RECORDS * 025400* THIS IS THE MAINLINE PROCESSING WHICH DIRECTS THE ITERATIVE * 025500* PROCESSING THROUGH THE SERVHIST FILE. * 025600***************************************************************** 025700 S2000-PROCESS-RECORDS SECTION. 025800 025900 ADD +1 TO A-SSNS-IN-THIS-RANGE. 026000 026100 IF A-SSNS-IN-THIS-RANGE >= W-RANGE-INCREMENT 026200 ADD +1 TO W-CURRENT-RANGE-NUMBER 026300 DISPLAY 'RANGE #' W-CURRENT-RANGE-NUMBER 026400 ' ENDS WITH: ' SH-RECORD-KEY-FDD 026500 MOVE +0 TO A-SSNS-IN-THIS-RANGE 026600 END-IF. 026700 026800 PERFORM S2100-READ. 026900 027000 S2000-EXIT. 027100 EXIT. 027200/**************************************************************** 027300* S2100-READ * 027400* THIS SECTION READS THE NEXT SERVHIST RECORD. IT INCREMENTS AN * 027500* ACCUMULATOR AND WILL ALSO DISPLAY A MESSAGE EACH TIME A NUMBER* 027600* EQUAL TO "C-INCREMENT" RECORDS ARE READ. IT WILL ALSO * 027700* MAKE SURE THE NUMBER INDICATING HOW MANY NOTE-LEVEL TRAILERS * 027800* EXIST ON THE RECORD IS "0" IF IT IS NOT NUMERIC. * 027900***************************************************************** 028000 S2100-READ SECTION. 028100 028200 READ SERVHIST-FILE 028300 AT END 028400 SET S-NO-MORE-RECORDS-EXIST TO TRUE. 028500 028600 IF S-MORE-RECORDS-EXIST 028700 ADD +1 TO A-RECORDS-READ 028800 W-INCREMENT 028900 IF W-INCREMENT = C-INCREMENT 029000 DISPLAY 'A-RECORDS-READ = ' A-RECORDS-READ 029100 MOVE +0 TO W-INCREMENT 029200 END-IF 029300 END-IF. 029400 029500 S2100-EXIT. 029600 EXIT. 029700/**************************************************************** 029800* S3000-FINALIZATION * 029900* THIS SECTION CLOSES THE FILES AND DISPLAYS PROCESSING * 030000* STATISTICS. ANY OTHER "CLEAN-UP" ACTIVITY COULD BE PUT HERE. * 030100***************************************************************** 030200 S3000-FINALIZATION SECTION. 030300 030400 IF S-GOOD-PARM 030500 CLOSE SERVHIST-FILE. 030600 030700 DISPLAY 'A-RECORDS-READ = ' A-RECORDS-READ. 030800 030900 S3000-EXIT. 031000 EXIT. ./ ADD NAME=SERVSTAT 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. SERVSTAT. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* THIS PROGRAM WILL READ A SERVHIST FILE SEQUENTIALLY AND * 000700* BASED ON INPUT PARMS OF A TOTAL RECORD ESTIMATE AND HOW MANY * 000800* RELATIVELY EVENLY SPLIT FILES YOU WOULD LIKE TO DIVIDE IT * 000900* INTO, IT WILL TELL YOU THE EXACT SSN RANGES, AND SSN RANGES * 001000* BASED ON THE EVF RANGE SPECIFICATION. * 001100***************************************************************** 001200************************ EXAMPLE JCL **************************** 001300* //STEP01 EXEC PGM=SERVSTAT * 001400* //STEPLIB DD DSN=YOURID.COBOL.LOAD, * 001500* // DISP=(SHR,KEEP,KEEP) * 001600* // DD DSN=SYS1.COB2LIB, * 001700* // DISP=(SHR,KEEP,KEEP) * 001800* //SERVHIST DD DSN=T.USC10.SLSS.SERVHSTA.ME1(0), SERVHIST * 001900* // DISP=(SHR,KEEP,KEEP) BACKUP * 002000* // DD DSN=T.USC10.SLSS.SERVHSTB.ME1(0), TAPE(S) * 002100* // DISP=(SHR,KEEP,KEEP) * 002200* //SYSUDUMP DD SYSOUT=* * 002300* //SYSDBOUT DD SYSOUT=* * 002400* //SYSOUD DD SYSOUT=* * 002500***************************************************************** 002600/**************************************************************** 002700* E N V I R O N M E N T D I V I S I O N * 002800***************************************************************** 002900 ENVIRONMENT DIVISION. 003000 003100 INPUT-OUTPUT SECTION. 003200 003300 FILE-CONTROL. 003400 003500 SELECT SERVHIST-FILE ASSIGN TO SERVHIST. 003600 003700/**************************************************************** 003800* D A T A D I V I S I O N * 003900***************************************************************** 004000 DATA DIVISION. 004100 004200 FILE SECTION. 004300 004400***************************************************************** 004500* SERVHIST FILE FD * 004600***************************************************************** 004700 FD SERVHIST-FILE 004800 RECORD CONTAINS 780 TO 16218 CHARACTERS 004900 LABEL RECORDS ARE STANDARD 005000 RECORDING MODE IS V 005100 BLOCK CONTAINS 0 RECORDS 005200 DATA RECORD IS SERVHIST-RECORD. 005300 01 SERVHIST-RECORD. 005400 05 SH-FIXED-AREA-FDD. SH 005500 10 SH-RECORD-KEY-FDD. SH 005600 15 SERVHIST-SSN-1-3 PIC 9(03). 005700 15 SERVHIST-SSN-4-9 PIC X(06). 005800 10 SH-VAR-COUNTER-FDD PIC S9(03). SH 005900 10 SH-OVERFLOW-NUMBER-FDD SH 006000 PIC 9(02). SH 006100 10 FILLER PIC X(704). SH 006200 05 SH-VARIABLE-AREA-FDD. SH 006300 10 SH-DATE-COMMENT-FDD PIC X(62) SH 006400 OCCURS 1 TO 250 TIMES SH 006500 DEPENDING ON SH-VAR-COUNTER-FDD. SH 006600/**************************************************************** 006700* W O R K I N G - S T O R A G E S E C T I O N * 006800***************************************************************** 006900 WORKING-STORAGE SECTION. 007000***************************************************************** 007100* A C C U M U L A T O R S * 007200***************************************************************** 007300 01 ACCUMULATORS. 007400 05 FILLER PIC X(13) VALUE 007500 'ACCUMULATORS:'. 007600 05 A-RECORDS-READ PIC S9(16) COMP SYNC VALUE +0. 007700 05 A-BYTES-READ PIC S9(16) COMP SYNC VALUE +0. 007800/**************************************************************** 007900* C O N S T A N T S * 008000***************************************************************** 008100 01 CONSTANTS. 008200 05 FILLER PIC X(10) VALUE 008300 'CONSTANTS:'. 008400 05 C-INCREMENT PIC S9(08) COMP SYNC VALUE +10000. 008500/**************************************************************** 008600* S W I T C H E S * 008700***************************************************************** 008800 01 SWITCHES. 008900 05 FILLER PIC X(09) VALUE 009000 'SWITCHES:'. 009100 05 S-END-OF-FILE-SWITCH PIC X(01) VALUE 'Y'. 009200 88 S-MORE-RECORDS-EXIST VALUE 'Y'. 009300 88 S-NO-MORE-RECORDS-EXIST VALUE 'N'. 009400/**************************************************************** 009500* W O R K A R E A S * 009600***************************************************************** 009700 01 WORK-AREAS. 009800 05 FILLER PIC X(11) VALUE 009900 'WORK AREAS:'. 010000 05 W-INCREMENT PIC S9(08) COMP SYNC VALUE +0. 010100 05 W-HOLD-PREFIX PIC 9(03) VALUE 0. 010200 05 W-DISPLAY-AREA. 010300 10 W-DISPLAY-PREFIX PIC 9(03). 010400 10 FILLER PIC X(02) VALUE SPACES. 010500 10 W-DISPLAY-COUNT PIC ZZZ,ZZ9. 010600 10 FILLER PIC X(02) VALUE SPACES. 010700 10 W-DISPLAY-MIN PIC ZZ,ZZ9. 010800 10 FILLER PIC X(02) VALUE SPACES. 010900 10 W-DISPLAY-MAX PIC ZZ,ZZ9. 011000 10 FILLER PIC X(02) VALUE SPACES. 011100 10 W-DISPLAY-AVG PIC ZZ,ZZ9. 011200 10 FILLER PIC X(02) VALUE SPACES. 011300 10 W-DISPLAY-TOT PIC Z,ZZZ,ZZZ,ZZ9. 011400 10 FILLER PIC X(02) VALUE SPACES. 011500 10 W-DISPLAY-BYTE-PCT PIC Z9.99999. 011600 10 FILLER PIC X(01) VALUE SPACES. 011700 10 W-PERCENT-SIGN-1 PIC X(01). 011800 10 FILLER PIC X(02) VALUE SPACES. 011900 10 W-DISPLAY-RECS-PCT PIC Z9.99999. 012000 10 FILLER PIC X(01) VALUE SPACES. 012100 10 W-PERCENT-SIGN-2 PIC X(01). 012200/**************************************************************** 012300* P R I N T L I N E S * 012400***************************************************************** 012500 01 PRINT-LINES. 012600 05 FILLER PIC X(12) VALUE 012700 'PRINT LINES:'. 012800/**************************************************************** 012900* T A B L E S * 013000***************************************************************** 013100 01 TABLES. 013200 05 FILLER PIC X(07) VALUE 013300 'TABLES:'. 013400 05 T-PREFIX-TABLE-AREA PIC X(16000). 013500 05 T-PREFIX-TABLE REDEFINES T-PREFIX-TABLE-AREA 013600 OCCURS 1000 TIMES 013700 INDEXED BY T-PREFIX-NDX1 013800 T-PREFIX-NDX2. 013900 10 T-PREFIX-COUNT PIC S9(08) COMP. 014000 10 T-PREFIX-MAX-LENGTH PIC S9(08) COMP. 014100 10 T-PREFIX-MIN-LENGTH PIC S9(08) COMP. 014200 10 T-PREFIX-TOT-BYTES PIC S9(08) COMP. 014300/**************************************************************** 014400* L I N K A G E S E C T I O N * 014500***************************************************************** 014600 LINKAGE SECTION. 014700 01 L-PARM. 014800 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 014900 05 L-PARM-DATA PIC X(100). 015000/**************************************************************** 015100* P R O C E D U R E D I V I S I O N * 015200***************************************************************** 015300 PROCEDURE DIVISION USING L-PARM. 015400 015500 OPEN INPUT SERVHIST-FILE. 015600 015700 READ SERVHIST-FILE 015800 AT END 015900 SET S-NO-MORE-RECORDS-EXIST TO TRUE. 016000 016100 PERFORM UNTIL S-NO-MORE-RECORDS-EXIST 016200 ADD +1 TO A-RECORDS-READ 016300 W-INCREMENT 016400 016500 IF W-INCREMENT = C-INCREMENT 016600 DISPLAY 'A-RECORDS-READ = ' A-RECORDS-READ 016700 MOVE +0 TO W-INCREMENT 016800 END-IF 016900 017000 IF SERVHIST-SSN-1-3 NOT = W-HOLD-PREFIX 017100 SET T-PREFIX-NDX1 TO SERVHIST-SSN-1-3 017200 MOVE SERVHIST-SSN-1-3 TO W-HOLD-PREFIX 017300 MOVE LENGTH OF SERVHIST-RECORD TO 017400 T-PREFIX-MAX-LENGTH (T-PREFIX-NDX1) 017500 T-PREFIX-MIN-LENGTH (T-PREFIX-NDX1) 017600 MOVE +0 TO T-PREFIX-COUNT (T-PREFIX-NDX1) 017800 T-PREFIX-TOT-BYTES (T-PREFIX-NDX1) 017900 END-IF 018000 018100 ADD +1 TO T-PREFIX-COUNT (T-PREFIX-NDX1) 018200 ADD LENGTH OF SERVHIST-RECORD TO 018300 T-PREFIX-TOT-BYTES (T-PREFIX-NDX1) 018400 A-BYTES-READ 018500 018600 IF LENGTH OF SERVHIST-RECORD < 018700 T-PREFIX-MIN-LENGTH (T-PREFIX-NDX1) 018800 MOVE LENGTH OF SERVHIST-RECORD TO 018900 T-PREFIX-MIN-LENGTH (T-PREFIX-NDX1) 019000 END-IF 019100 019200 IF LENGTH OF SERVHIST-RECORD > 019300 T-PREFIX-MAX-LENGTH (T-PREFIX-NDX1) 019400 MOVE LENGTH OF SERVHIST-RECORD TO 019500 T-PREFIX-MAX-LENGTH (T-PREFIX-NDX1) 019600 END-IF 019700 019800 READ SERVHIST-FILE 019900 AT END 020000 SET S-NO-MORE-RECORDS-EXIST TO TRUE 020100 END-READ 020200 END-PERFORM. 020300 020400 CLOSE SERVHIST-FILE. 020500 020600 DISPLAY ' '. 020700 DISPLAY '*** SERVHIST READING COMPLETE ***'. 020800 DISPLAY ' '. 020801 DISPLAY 'TOTAL RECORDS: ' A-RECORDS-READ. 020802 DISPLAY 'TOTAL BYTES: ' A-BYTES-READ. 020810 DISPLAY ' '. 020900 DISPLAY 'PFX # RECS MINLEN MAXLEN AVGLEN ' 020901 ' TOT BYTES BYTE % RECS %'. 020902 DISPLAY ' '. 021010 021102 PERFORM VARYING T-PREFIX-NDX1 FROM +1 BY +1 021110 UNTIL T-PREFIX-NDX1 > +999 021200 IF T-PREFIX-COUNT (T-PREFIX-NDX1) > +0 021300 INITIALIZE W-DISPLAY-AREA 021400 SET W-DISPLAY-PREFIX TO T-PREFIX-NDX1 021500 MOVE '%' TO W-PERCENT-SIGN-1 021600 W-PERCENT-SIGN-2 021700 COMPUTE W-DISPLAY-AVG ROUNDED = 021800 T-PREFIX-TOT-BYTES (T-PREFIX-NDX1) / 021900 T-PREFIX-COUNT (T-PREFIX-NDX1) 022000 COMPUTE W-DISPLAY-RECS-PCT ROUNDED = 022100 T-PREFIX-COUNT (T-PREFIX-NDX1) / 022200 A-RECORDS-READ * 100 022300 COMPUTE W-DISPLAY-BYTE-PCT ROUNDED = 022400 T-PREFIX-TOT-BYTES (T-PREFIX-NDX1) / 022500 A-BYTES-READ * 100 022600 MOVE T-PREFIX-TOT-BYTES (T-PREFIX-NDX1) TO 022700 W-DISPLAY-TOT 022800 MOVE T-PREFIX-MIN-LENGTH (T-PREFIX-NDX1) TO 022900 W-DISPLAY-MIN 023000 MOVE T-PREFIX-MAX-LENGTH (T-PREFIX-NDX1) TO 023100 W-DISPLAY-MAX 023200 MOVE T-PREFIX-COUNT (T-PREFIX-NDX1) TO 023300 W-DISPLAY-COUNT 023400 DISPLAY W-DISPLAY-AREA 023500 END-IF 023600 END-PERFORM. 023700 023800 GOBACK. ./ ADD NAME=S0C7S0C7 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. S0C7S0C7. 000300 AUTHOR. DAVE LEIGH 000400 DATE-COMPILED. 000500***************************************************************** 000600* REMARKS: * 000700* THIS PROGRAM WILL PRODUCE A S0C7 ABEND * 001900***************************************************************** 002000************************ EXAMPLE JCL **************************** 002100* //STEP01 EXEC PGM=S0C7S0C7 * 002900* //SYSUDUMP DD SYSOUT=* * 003000* //SYSDBOUT DD SYSOUT=* * 003100* //SYSOUT DD SYSOUT=* * 003200* //SYSOUD DD SYSOUT=* * 003300***************************************************************** 003400/**************************************************************** 003500* E N V I R O N M E N T D I V I S I O N * 003600***************************************************************** 003700 ENVIRONMENT DIVISION. 003800 003900 INPUT-OUTPUT SECTION. 004000 004100 FILE-CONTROL. 004200 005800/**************************************************************** 005900* D A T A D I V I S I O N * 006000***************************************************************** 006100 DATA DIVISION. 006200 006300 FILE SECTION. 006400 008000/**************************************************************** 008100* W O R K I N G - S T O R A G E S E C T I O N * 008200***************************************************************** 008300 WORKING-STORAGE SECTION. 008400***************************************************************** 008500* A C C U M U L A T O R S * 008600***************************************************************** 008700 01 ACCUMULATORS. 008800 05 FILLER PIC X(13) VALUE 008900 'ACCUMULATORS:'. 009600/**************************************************************** 009700* C O N S T A N T S * 009800***************************************************************** 009900 01 CONSTANTS. 010000 05 FILLER PIC X(10) VALUE 010100 'CONSTANTS:'. 010111 05 C-NUMERIC-ITEM PIC 9. 010112 05 C-SPACE REDEFINES C-NUMERIC-ITEM PIC X. 010120 05 C-NUMBER PIC S9(05) COMP-3 VALUE +1. 010200/**************************************************************** 010300* S W I T C H E S * 010400***************************************************************** 010500 01 SWITCHES. 010600 05 FILLER PIC X(09) VALUE 010700 'SWITCHES:'. 012400/**************************************************************** 012500* W O R K A R E A S * 012600***************************************************************** 012700 01 WORK-AREAS. 012800 05 FILLER PIC X(11) VALUE 012900 'WORK AREAS:'. 013000 05 W-RESULT PIC S9(08) COMP SYNC VALUE +0. 015400/**************************************************************** 015500* P R I N T L I N E S * 015600***************************************************************** 015700 01 PRINT-LINES. 015800 05 FILLER PIC X(12) VALUE 015900 'PRINT LINES:'. 016000/**************************************************************** 016100* T A B L E S * 016200***************************************************************** 016300 01 TABLES. 016400 05 FILLER PIC X(07) VALUE 016500 'TABLES:'. 016600/**************************************************************** 016700* L I N K A G E S E C T I O N * 016800***************************************************************** 016900 LINKAGE SECTION. 017000 01 L-PARM. 017100 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 017300 05 L-PARM-DATA PIC X(100). 017600/**************************************************************** 017700* P R O C E D U R E D I V I S I O N * 017800***************************************************************** 017900 PROCEDURE DIVISION USING L-PARM. 018000***************************************************************** 018100* S0000-DRIVER * 018200***************************************************************** 018300 S0000-DRIVER SECTION. 018400 018410 MOVE SPACE TO C-SPACE. 018420 018500 COMPUTE W-RESULT = C-NUMBER / C-NUMERIC-ITEM. 018600 019100 GOBACK. 019200 019400 S0000-EXIT. 019500 EXIT. ./ ADD NAME=TDB2ISPF 000100* D@UDAL.STR.JCLLIB(DB2COMP) 000200 IDENTIFICATION DIVISION. 000300 PROGRAM-ID. T2B2ISPF. 000400 AUTHOR. DAVE LEIGH 000500 DATE-COMPILED. 000800/***************************************************************** 000900** E N V I R O N M E N T D I V I S I O N ** 001000****************************************************************** 001100 ENVIRONMENT DIVISION. 001200 001300 INPUT-OUTPUT SECTION. 001400 001500 FILE-CONTROL. 001600 001900/***************************************************************** 002000** D A T A D I V I S I O N ** 002100****************************************************************** 002200 DATA DIVISION. 002300 002400 FILE SECTION. 002500 003400/***************************************************************** 003500** W O R K I N G - S T O R A G E S E C T I O N ** 003600****************************************************************** 003700 WORKING-STORAGE SECTION. 003800 003801/***************************************************************** 003802** A C C U M U L A T O R S ** 003803****************************************************************** 003804 01 ACCUMULATORS. 003805 05 A-VARIABLE-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 003806 05 A-ISPF-CALLS-EXECUTED PIC S9(08) COMP SYNC VALUE +0. 003807 05 A-VARIABLES-DEFINED PIC S9(08) COMP SYNC VALUE +0. 003808 05 A-INPUT-ROWS-FETCHED PIC S9(04) COMP VALUE +0. 003809 88 A-NO-ROWS-FETCHED VALUE +0. 003810 003811/***************************************************************** 003812** C O N S T A N T S ** 003813****************************************************************** 003814 01 CONSTANTS. 003820 05 C-ISPF PIC X(08) VALUE "ISPLINK ". 003830 05 C-ISPF-SKELETON-LIBRARY PIC X(08) VALUE "ISPSLIB ". 003840 05 C-ISPF-SKELETON-MEMBER PIC X(08) VALUE "SLIBMBR ". 003850 05 C-ISPF-OUTPUT-MEMBER PIC X(08) VALUE "OUTMBR ". 003860 05 C-VDEFINE PIC X(08) VALUE "VDEFINE ". 003870 05 C-VDELETE PIC X(08) VALUE "VDELETE ". 003880 05 C-ALL-VARIABLES PIC X(08) VALUE "* ". 003890 05 C-LIBDEF PIC X(08) VALUE "LIBDEF ". 003891 05 C-ISPSLIB PIC X(08) VALUE "ISPSLIB ". 003892 05 C-DATASET PIC X(08) VALUE "DATASET ". 003893 05 C-CONTROL PIC X(08) VALUE "CONTROL ". 003894 05 C-FTOPEN PIC X(08) VALUE "FTOPEN ". 003895 05 C-FTINCL PIC X(08) VALUE "FTINCL ". 003896 05 C-FTCLOSE PIC X(08) VALUE "FTCLOSE ". 003897 05 C-TEMP PIC X(08) VALUE "TEMP ". 003898 05 C-VPUT PIC X(08) VALUE "VPUT ". 003899 05 C-SHARED PIC X(08) VALUE "SHARED ". 003900 05 C-ERRORS PIC X(08) VALUE "ERRORS ". 003901 05 C-RETURN PIC X(08) VALUE "RETURN ". 003902 05 C-CHARACTER PIC X(08) VALUE "CHAR ". 003903 004600/***************************************************************** 004700** S W I T C H E S ** 004800****************************************************************** 004900 01 SWITCHES. 005000 05 S-END-OF-INPUT-SWITCH PIC X(01) VALUE "Y". 005100 88 S-END-OF-INPUT VALUE "N". 005200 88 S-MORE-ROWS-TO-FETCH VALUE "Y". 005300 005400/**************************************************************** 005500* W O R K A R E A S * 005600***************************************************************** 005700 01 WORK-AREAS. 006000 05 W-CREATE-RECORD PIC X(80). 006100 05 W-HOLD-RECORD PIC X(80). 006200 05 W-FETCH-INCREMENT PIC S9(08) COMP SYNC. 006300 05 W-SYNC-INCREMENT PIC 9(04) VALUE 0. 006400 05 W-PARM-VALUE1 PIC X(08) VALUE SPACES. 006500 88 W-THIS-IS-A-CREATE-REQUEST VALUE "CREATE". 006600 88 W-THIS-IS-A-DROP-REQUEST VALUE "DROP". 006700 05 W-PARM-VALUE2 PIC X(08) VALUE SPACES. 006900 88 W-PROCESS-ALL-IDS VALUE "ALL". 006910 05 W-PARM-VALUE3 PIC X(08) VALUE SPACES. 006920 88 W-PLATINUM-DRIVER-USED VALUE "PLATINUM". 006930 88 W-DSNTIAD-USED VALUE "DSNTIAD". 006931********* 006940 05 W-RETURN-CODE PIC 9(04) VALUE 0. 006950 88 W-GOOD-RETURN-CODE VALUE 0. 006960 88 W-FATAL-RETURN-CODE VALUE 5 THRU 9999. 006961 88 W-BAD-PARM VALUE 2000. 006970 05 FILLER REDEFINES W-RETURN-CODE. 006980 10 W-RETURN-CODE-PREFIX PIC 9(02). 006990 88 W-VDEFINE-RC VALUE 20. 006991 88 W-VDELETE-RC VALUE 21. 006992 88 W-LIBDEF-RC VALUE 22. 006993 88 W-CONTROL-RC VALUE 23. 006994 88 W-FTOPEN-RC VALUE 24. 006995 88 W-FTINCL-RC VALUE 25. 006996 88 W-FTCLOSE-RC VALUE 26. 006997 88 W-VPUT-RC VALUE 27. 006998 10 W-RETURN-CODE-SUFFIX PIC 9(02). 006999 88 W-ACCEPTABLE-ISPF-RETURN-CODE VALUE 0 THRU 4. 007000 007001 05 W-ISPF-SKELETON-LIBRARY-AREA. 007002 10 FILLER PIC S9(06) COMP VALUE +1. 007003 10 FILLER PIC S9(06) COMP VALUE +0. 007004 10 W-ISPF-SKELETON-LIBRARY PIC X(50) VALUE SPACES. 007005 007006 05 W-VARIABLE-LENGTH PIC S9(08) COMP VALUE +72. 007007 05 W-ISPF-SKELETON-MEMBER PIC X(08) VALUE SPACES. 007008 05 W-ISPF-OUTPUT-MEMBER PIC X(08) VALUE SPACES. 007009 88 W-NO-OUTPUT-MEMBER-SPECIFIED VALUE SPACES. 007010 007100/*********************************************************** 007200* SQLCA -- DB2 COMMUNICATION AREA 007300************************************************************ 007400 EXEC SQL INCLUDE SQLCA END-EXEC. 007500****************************************************************** 007600* DCLGEN TABLE(SYSIBM.SYSSYNONYMS) * 007700* LIBRARY(D@UDAL.STR.COPYLIB(SYSSYNON)) * 007800* APOST * 007900* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 008000****************************************************************** 008100 EXEC SQL DECLARE SYSIBM.SYSSYNONYMS TABLE 008200 ( NAME VARCHAR(18) NOT NULL, 008300 CREATOR CHAR(8) NOT NULL, 008400 TBNAME VARCHAR(18) NOT NULL, 008500 TBCREATOR CHAR(8) NOT NULL, 008600 IBMREQD CHAR(1) NOT NULL, 008700 CREATEDBY CHAR(8) NOT NULL 008800 ) END-EXEC. 008900****************************************************************** 009000* COBOL DECLARATION FOR TABLE SYSIBM.SYSSYNONYMS * 009100****************************************************************** 009200 01 DCLSYSSYNONYMS. 009300 10 NAME. 009400 49 NAME-LEN PIC S9(4) USAGE COMP. 009500 49 NAME-TEXT PIC X(18). 009600 10 CREATOR PIC X(8). 009700 10 TBNAME. 009800 49 TBNAME-LEN PIC S9(4) USAGE COMP. 009900 49 TBNAME-TEXT PIC X(18). 010000 10 TBCREATOR PIC X(8). 010100 10 IBMREQD PIC X(1). 010200****************************************************************** 010300* DCLGEN TABLE(PTI.PTRCS_APLDOM_0200) * 010400* LIBRARY(D@UDAL.STR.COPYLIB(PLATADOM)) * 010500* APOST * 010600* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 010700****************************************************************** 010800 EXEC SQL DECLARE PTI.PTRCS_APLDOM_0200 TABLE 010900 ( NAME CHAR(8) NOT NULL, 011000 DB2ID CHAR(4) NOT NULL, 011100 DEPT CHAR(8) NOT NULL, 011200 QUALIFIER CHAR(8) NOT NULL, 011300 OBJNAME VARCHAR(18) NOT NULL, 011400 OBJTYPE CHAR(2) NOT NULL, 011500 UPDATE_USER CHAR(8) NOT NULL, 011600 UPDATE_DATE DATE NOT NULL, 011700 IMPLEMENTED TIMESTAMP NOT NULL, 011800 AUTHS VARCHAR(25) NOT NULL, 011900 PENDING VARCHAR(25) NOT NULL 012000 ) END-EXEC. 012100****************************************************************** 012200* COBOL DECLARATION FOR TABLE PTI.PTRCS_APLDOM_0200 * 012300****************************************************************** 012400 01 DCLPTRCS-APLDOM-0200. 012500 10 NAME PIC X(8). 012600 10 DB2ID PIC X(4). 012700 10 DEPT PIC X(8). 012800 10 QUALIFIER PIC X(8). 012900 10 OBJNAME. 013000 49 OBJNAME-LEN PIC S9(4) USAGE COMP. 013100 49 OBJNAME-TEXT PIC X(18). 013200 10 OBJTYPE PIC X(2). 013300 10 UPDATE-USER PIC X(8). 013400 10 UPDATE-DATE PIC X(10). 013500 10 IMPLEMENTED PIC X(26). 013600 10 AUTHS. 013700 49 AUTHS-LEN PIC S9(4) USAGE COMP. 013800 49 AUTHS-TEXT PIC X(25). 013900 10 PENDING. 014000 49 PENDING-LEN PIC S9(4) USAGE COMP. 014100 49 PENDING-TEXT PIC X(25). 014200****************************************************************** 014300* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 11 * 014400****************************************************************** 014500 10 CREATEDBY PIC X(8). 014600****************************************************************** 014700* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 36 * 014800****************************************************************** 014900 015000****************************************************************** 015100* DCLGEN TABLE(PTI.PTRCS_USRDOM_0200) * 015200* LIBRARY(D@UDAL.STR.COPYLIB(PLATUDOM)) * 015300* ACTION(REPLACE) * 015400* APOST * 015500* ... IS THE DCLGEN COMMAND THAT MADE THE FOLLOWING STATEMENTS * 015600****************************************************************** 015700 EXEC SQL DECLARE PTI.PTRCS_USRDOM_0200 TABLE 015800 ( NAME CHAR(8) NOT NULL, 015900 DB2ID CHAR(4) NOT NULL, 016000 DEPT CHAR(8) NOT NULL, 016100 AUTHID CHAR(8) NOT NULL, 016200 DESCRIPTION VARCHAR(25) NOT NULL, 016300 PENDING CHAR(1) NOT NULL, 016400 UPDATE_USER CHAR(8) NOT NULL, 016500 UPDATE_DATE DATE NOT NULL, 016600 IMPLEMENTED TIMESTAMP NOT NULL 016700 ) END-EXEC. 016800****************************************************************** 016900* COBOL DECLARATION FOR TABLE PTI.PTRCS_USRDOM_0200 * 017000****************************************************************** 017100 01 DCLPTRCS-USRDOM-0200. 017200 10 NAME PIC X(8). 017300 10 DB2ID PIC X(4). 017400 10 DEPT PIC X(8). 017500 10 AUTHID PIC X(8). 017600 10 DESCRIPTION. 017700 49 DESCRIPTION-LEN PIC S9(4) USAGE COMP. 017800 49 DESCRIPTION-TEXT PIC X(25). 017900 10 PENDING PIC X(1). 018000 10 UPDATE-USER PIC X(8). 018100 10 UPDATE-DATE PIC X(10). 018200 10 IMPLEMENTED PIC X(26). 018300****************************************************************** 018400* THE NUMBER OF COLUMNS DESCRIBED BY THIS DECLARATION IS 9 * 018500****************************************************************** 018600 018700/**************************************************************** 018800* DB2 CURSOR DECLARES * 018900***************************************************************** 019000 019100****************************************************************** 019200** CREATE SYNONYM CURSOR ** 019300****************************************************************** 019400 EXEC SQL DECLARE SYNONYM_CURSOR CURSOR FOR 019500 SELECT 019600 'CREATE SYNONYM ' || A.OBJNAME || 019700- ' FOR ' || A.QUALIFIER || '.' || A.OBJNAME || ';' 019800 FROM PTI.PTRCS_APLDOM_0200 A 019900 WHERE (QUALIFIER = 'USSTRD00' 020000 AND DB2ID = 'DSNT' 020100 AND NAME = 'USSTRDP0' 020200 AND (OBJTYPE = 'V' OR OBJTYPE= 'T') 020210 AND OBJNAME ¬= '*') 020300 AND NOT EXISTS 020400 (SELECT * 020500 FROM SYSIBM.SYSSYNONYMS B 020600 WHERE CREATOR = :AUTHID 020700 AND B.NAME = A.OBJNAME) 020710 AND NOT EXISTS 020720 (SELECT * 020730 FROM SYSIBM.SYSTABLES C 020740 WHERE CREATOR = :AUTHID 020750 AND C.NAME = A.OBJNAME) 020800 END-EXEC. 020900****************************************************************** 021000** DROP SYNONYM CURSOR ** 021100****************************************************************** 021200 EXEC SQL DECLARE DROP_SYNONYM CURSOR FOR 021300 SELECT 'DROP SYNONYM ' || NAME || ';' 021400 FROM SYSIBM.SYSSYNONYMS 021500 WHERE CREATOR = :AUTHID 021600 END-EXEC. 021700****************************************************************** 021800** INPUT DRIVER CURSOR OF ALL USER ID'S ** 021900****************************************************************** 022000 EXEC SQL DECLARE ALL_USER_IDS CURSOR FOR 022100 SELECT AUTHID, 022110 DESCRIPTION 022200 FROM PTI.PTRCS_USRDOM_0200 022300 WHERE DB2ID = 'DSNT' 022400 AND NAME = 'UNISTAR' 022500 END-EXEC. 022600****************************************************************** 022700** INPUT DRIVER CURSOR FOR ONE USER ID ONLY ** 022800****************************************************************** 022900 EXEC SQL DECLARE USER_ID CURSOR FOR 022910 SELECT AUTHID, 022920 DESCRIPTION 023100 FROM PTI.PTRCS_USRDOM_0200 023200 WHERE DB2ID = 'DSNT' 023300 AND NAME = 'UNISTAR' 023400 AND AUTHID = :W-PARM-VALUE2 023500 END-EXEC. 023600/***************************************************************** 023700** L I N K A G E S E C T I O N ** 023800****************************************************************** 023900 LINKAGE SECTION. 024000 01 LINKAGE-AREA. 024100 05 L-PARM-LENGTH PIC S9(04) COMP. 024200 05 L-PARM-VALUE PIC X(100). 024300/***************************************************************** 024400** P R O C E D U R E D I V I S I O N ** 024500****************************************************************** 024600 PROCEDURE DIVISION USING LINKAGE-AREA. 024700****************************************************************** 024800** S0000-CONTROL ** 024900** THIS SECTION IS THE DRIVER WHICH CONTROLS THE PROCESSING OF ** 025000** ALL THE SECTIONS AT THE HIGHEST LEVEL AND THEN ISSUES THE ** 025100** GOBACK. ** 025200****************************************************************** 025300 S0000-CONTROL SECTION. 025310 DISPLAY "QQQ AT #1". 025400 025500 PERFORM S1000-INITIALIZATION. 025600 026000 PERFORM S3000-FINALIZATION. 026100 026200 S0000-EXIT. 026300 EXIT. 026400/***************************************************************** 026500** S1000-INITIALIZATION ** 026600** THIS SECTION PERFORMS INITIALIZATION FUNCTIONS. THOSE ** 026700** INCLUDE OPENING THE VARIABLE FILE, DOING A PRIMING FETCH, ** 026800** AND SETTING THE ISPF ERROR ENCOUNTER RESPONSE TO "RETURN". ** 026900****************************************************************** 027000 S1000-INITIALIZATION SECTION. 027010 DISPLAY "QQQ AT #2". 027100 027200 IF L-PARM-LENGTH > +0 027300 UNSTRING L-PARM-VALUE DELIMITED BY ALL SPACES OR 027310 ALL LOW-VALUES 027400 INTO W-PARM-VALUE1 027500 W-PARM-VALUE2 027510 W-PARM-VALUE3 027600 END-UNSTRING 028000 ELSE 028100 DISPLAY "*** NOTE: DEFAULT PROCESS OPTIONS USED ***" 028200 SET W-THIS-IS-A-CREATE-REQUEST TO TRUE 028300 SET W-PROCESS-ALL-IDS TO TRUE 028310 SET W-PLATINUM-DRIVER-USED TO TRUE 028400 END-IF. 028500 028600 DISPLAY "*** PROCESS OPTIONS USED ***". 028700 DISPLAY "ACTION: " W-PARM-VALUE1. 028800 DISPLAY " ON: " W-PARM-VALUE2. 028810 DISPLAY " BY: " W-PARM-VALUE3. 028820 DISPLAY "****************************". 028900 029000 IF (NOT W-THIS-IS-A-CREATE-REQUEST AND 029100 NOT W-THIS-IS-A-DROP-REQUEST) OR 029200 (NOT W-PLATINUM-DRIVER-USED AND 029300 NOT W-DSNTIAD-USED) 029310 SET W-BAD-PARM TO TRUE 029500 ELSE 029510 SET W-CONTROL-RC TO TRUE 029520 CALL C-ISPF USING C-CONTROL C-ERRORS C-RETURN 029530 PERFORM S6000-ISPF-CALL-CHECK 029700 PERFORM S7000-OPEN-INPUT-CURSOR 029800 PERFORM S8000-FETCH-INPUT-ROW 030000 END-IF. 030100 030200 S1000-EXIT. 030300 EXIT. 032400/***************************************************************** 032500** S3000-FINALIZATION ** 032600****************************************************************** 032700 S3000-FINALIZATION SECTION. 032710 DISPLAY "QQQ AT #4". 032800 033010 PERFORM S9000-CLOSE-INPUT-CURSOR. 033200 033300 MOVE W-RETURN-CODE TO RETURN-CODE. 033400 033500 GOBACK. 033600 033700 S3000-EXIT. 033800 EXIT. 045900/***************************************************************** 046000** S7000-OPEN-INPUT-CURSOR ** 046100** 1. ** 046200****************************************************************** 046300 S7000-OPEN-INPUT-CURSOR SECTION. 046310 DISPLAY "QQQ AT #8". 046400 046500 IF W-PROCESS-ALL-IDS 046600 EXEC SQL OPEN ALL_USER_IDS 046700 END-EXEC 046800 ELSE 046900 EXEC SQL OPEN USER_ID 047000 END-EXEC 047100 END-IF. 047200 047300 EVALUATE SQLCODE 047400 047500 WHEN +0 047600 CONTINUE 047700 047800 WHEN OTHER 047900 DISPLAY "EXEC SQL INPUT OPEN CC: " SQLCODE 048000 048100 END-EVALUATE. 048200 048300 S7000-EXIT. 048400 EXIT. 048500/***************************************************************** 048600** S8000-FETCH-INPUT-ROW ** 048700****************************************************************** 048800 S8000-FETCH-INPUT-ROW SECTION. 048810 DISPLAY "QQQ AT #9". 048900 048910 INITIALIZE DCLPTRCS-USRDOM-0200. 048920 049000 IF W-PROCESS-ALL-IDS 049100 EXEC SQL FETCH ALL_USER_IDS 049101 INTO :AUTHID, 049102 :DESCRIPTION 049110 END-EXEC 049120 ELSE 049130 EXEC SQL FETCH USER_ID 049131 INTO :AUTHID, 049132 :DESCRIPTION 049140 END-EXEC 049150 END-IF. 049170 049172 ADD +1 TO A-INPUT-ROWS-FETCHED. 049198 049199 EVALUATE SQLCODE 049200 049210 WHEN +0 049230 CONTINUE 049297 049298 WHEN +100 049299 SET S-END-OF-INPUT TO TRUE 049308 049309 WHEN OTHER 049310 DISPLAY "EXEC SQL INPUT FETCH CC: " SQLCODE 049311 MOVE SQLCODE TO W-RETURN-CODE 049312 049313 END-EVALUATE. 049400 049500 S8000-EXIT. 049600 EXIT. 049700/***************************************************************** 049800** S9000-CLOSE-INPUT-CURSOR ** 049900** 1. ** 050000****************************************************************** 050100 S9000-CLOSE-INPUT-CURSOR SECTION. 050110 DISPLAY "QQQ AT #10". 050200 050300 IF W-PROCESS-ALL-IDS 050400 EXEC SQL CLOSE ALL_USER_IDS 050500 END-EXEC 050600 ELSE 050700 EXEC SQL CLOSE USER_ID 050800 END-EXEC 050900 END-IF. 051000 051100 EVALUATE SQLCODE 051200 051300 WHEN +0 051400 IF A-NO-ROWS-FETCHED 051500 MOVE +2001 TO W-RETURN-CODE 051600 DISPLAY "NO INPUT ROWS SELECTED TO PROCESS" 052600 END-IF 052700 052800 WHEN OTHER 052900 DISPLAY "EXEC SQL INPUT CLOSE CC: " SQLCODE 053000 MOVE SQLCODE TO W-RETURN-CODE 053100 053200 END-EVALUATE. 053300 053400 S9000-EXIT. 053500 EXIT. 053600/***************************************************************** 053700** S9999-WRITE-OUTPUT-FILE ** 053800** 1. ** 053900****************************************************************** 054000 S9999-WRITE-OUTPUT-FILE SECTION. 054010 DISPLAY "QQQ AT #11". 054100 054200* WRITE OUTPUT-CREATE-RECORD FROM W-CREATE-RECORD. 054300 054400 S9999-EXIT. 054500 EXIT. 072100/***************************************************************** 072200** S6000-ISPF-CALL-CHECK ** 072300** THIS SECTION IS CALLED AFTER EACH ISPF CALL TO CENTRALIZE ** 072400** THE PROCESSING NECESSARY TO DO ERROR CHECKING AND COUNTING ** 072500** THE NUMBER OF ISPF EXECUTIONS. ** 072600** ** 072700** FIRST WE SAVE THE RETURN CODE FROM THE ISPF CALL. THEN WE ** 072800** ADD ONE TO THE ISPF CALL ACCUMULATOR. IF THE RETURN CODE ** 072900** WAS GOOD, WE RETURN TO THE SECTION WHICH PERFORMED THIS ONE. ** 073000** ** 073100** IF THE RETURN CODE IS NOT ACCEPTABLE, SERVICE-SPECIFIC ** 073200** DISPLAYS ARE DONE AND FINALIZATION IS CALLED IN ORDER TO GET ** 073300** OUT. ** 073400****************************************************************** 073500 S6000-ISPF-CALL-CHECK SECTION. 073600 073700 MOVE RETURN-CODE TO W-RETURN-CODE-SUFFIX. 073710 DISPLAY "QQQ ISPF CALL: " W-RETURN-CODE-SUFFIX RETURN-CODE. 073800 ADD +1 TO A-ISPF-CALLS-EXECUTED. 073900 074000 IF W-ACCEPTABLE-ISPF-RETURN-CODE 074100 SET W-GOOD-RETURN-CODE TO TRUE 074200 ELSE 074300 EVALUATE TRUE 074400 WHEN W-VDEFINE-RC 074500 DISPLAY "ISPF SERVICE: VDEFINE" 074600 WHEN W-VDELETE-RC 074700 DISPLAY "ISPF SERVICE: VDELETE" 074800 WHEN W-LIBDEF-RC 074900 DISPLAY "ISPF SERVICE: LIBDEF" 075000 WHEN W-CONTROL-RC 075100 DISPLAY "ISPF SERVICE: CONTROL" 075200 WHEN W-FTOPEN-RC 075300 DISPLAY "ISPF SERVICE: FTOPEN" 075400 WHEN W-FTINCL-RC 075500 DISPLAY "ISPF SERVICE: FTINCL" 075600 WHEN W-FTCLOSE-RC 075700 DISPLAY "ISPF SERVICE: FTCLOSE" 075800 WHEN W-VPUT-RC 075900 DISPLAY "ISPF SERVICE: VPUT" 076000 END-EVALUATE 076100 DISPLAY "ISPF CALL INSTANCE: " A-ISPF-CALLS-EXECUTED 076200 DISPLAY "ISPF RC: " W-RETURN-CODE-SUFFIX 076300 PERFORM S3000-FINALIZATION 076400 END-IF. 076500 076600 S6000-EXIT. 076700 EXIT. ./ ADD NAME=TXKEYWRD ****************************************************************** * I D E N T I F I C A T I O N D I V I S I O N * ****************************************************************** IDENTIFICATION DIVISION. PROGRAM-ID. TXKEYWRD. AUTHOR. DAVE LEIGH. DATE-WRITTEN. DECEMBER 3, 1990. DATE-COMPILED. ****************************************************************** * PROGRAM NAME: TXKEYWRD * * * * FUNCTION: THIS PROGRAM IS PART OF THE SSD TECHNOLOGY EXCHANGE * * MAINFRAME REPOSITORY. ITS FUNCTION IS TO PERFORM * * KEYWORD SEARCHES AGAINST THE "ITEMS" TABLE AND FLAG * * THE MATCHING ROWS. IT WAS INITIALLY IMPLEMENTED IN * * THE CLIST LANGUAGE IN THE TXITEMS CLIST, BUT PROVED * * TO BE TOO TIME CONSUMING. IT IS NOW CALLED FROM THE * * TXITEMS CLIST. * * * * THE LOGIC PERFORMS EITHER AN "AND" OR AND "OR" TYPE * * KEYWORD SEARCH. * * * * THIS PROGRAM WILL ISSUE ISPLINK CALLS TO PERFORM * * THE NECESSARY ISPF TABLE PROCESSING. * * * * INPUTS: THE PROGRAM GETS INPUT FROM SEVERAL ISPF TABLES AND * * VGETS INPUT FROM VARIABLES "KEYSERCH", "ANDOR" AND * * "TIMEDATE". * * * * OUTPUTS: MODIFIES "ITEMS" ISPF TABLE ROWS. * * * * EXITS NORMAL: S3000-FINALIZATION * * * * EXITS ABNORMAL: NONE * * * * SWITCHES: NONE * * * * TABLES: NONE * * * * COPY MEMBERS: NONE * * * *--------------------------------------------------------------- * * MODIFICATION LOG * *--------------------------------------------------------------- * * INIT . DATE . COMMENTS * *======¬========¬=============================================== * ****************************************************************** /***************************************************************** * E N V I R O N M E N T D I V I S I O N * ****************************************************************** ENVIRONMENT DIVISION. CONFIGURATION SECTION. SOURCE-COMPUTER. IBM-370. OBJECT-COMPUTER. IBM-370. / INPUT-OUTPUT SECTION. FILE-CONTROL. DATA DIVISION. FILE SECTION. /***************************************************************** * W O R K I N G - S T O R A G E S E C T I O N * ****************************************************************** WORKING-STORAGE SECTION. 01 WS-START PIC X(46) VALUE '**** TXKEYWRD WORKING-STORAGE STARTS HERE ****'. ****************************************************************** * A C C U M U L A T O R S * ****************************************************************** 01 A-ACCUMULATORS. 05 FILLER PIC X(24) VALUE '.ACCUMULATORS START HERE'. 05 A-ISPF-CALLS-MADE PIC 9(05) COMP-3 VALUE 0. ****************************************************************** * C O N S T A N T S * ****************************************************************** 01 C-CONSTANTS. 05 FILLER PIC X(21) VALUE '.CONSTANTS START HERE'. *** RETURN CODES *** 05 C-BAD-ISPF-RETURN-CODE PIC S9(08) COMP SYNC VALUE +2000. 05 C-NORMAL-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0. 05 C-OK-RETURN-CODE PIC S9(08) COMP SYNC VALUE +4. 05 C-PASSABLE-RETURN-CODE PIC S9(08) COMP SYNC VALUE +8. 05 C-END-TABLE-RETURN-CODE PIC S9(08) COMP SYNC VALUE +8. *** ISPF VARIABLE FIELD LENGTHS FOR VDEFINES *** 05 C-ISPF-LENGTH-ARRAY. 10 C-LINECMND-LEN PIC S9(08) COMP SYNC VALUE +1. 10 C-ANDOR-LEN PIC S9(08) COMP SYNC VALUE +1. 10 C-ITEMNAME-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-ITEMTYPE-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-ITEMLDES-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-ITEMHELP-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-LUDATE-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-LUTIME-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-LUID-LEN PIC S9(08) COMP SYNC VALUE +8. 10 C-ITEMTAG-LEN PIC S9(08) COMP SYNC VALUE +16. 10 C-TIMEDATE-LEN PIC S9(08) COMP SYNC VALUE +16. 10 C-ITEMAUTH-LEN PIC S9(08) COMP SYNC VALUE +80. 10 C-ITEMSDES-LEN PIC S9(08) COMP SYNC VALUE +80. 10 C-KEYWORD-LEN PIC S9(08) COMP SYNC VALUE +80. 10 C-KEYSERCH-LEN PIC S9(08) COMP SYNC VALUE +80. 10 C-ZERRLM-LEN PIC S9(08) COMP SYNC VALUE +512. *** ISPF VARIABLE FIELD NAME LITERALS *** 05 C-ISPF-NAME-ARRAY. 10 FILLER PIC X(01) VALUE '('. 10 C-LINECMND PIC X(09) VALUE 'LINECMND '. 10 C-ANDOR PIC X(09) VALUE 'ANDOR '. 10 C-ITEMNAME PIC X(09) VALUE 'ITEMNAME '. 10 C-ITEMTYPE PIC X(09) VALUE 'ITEMTYPE '. 10 C-ITEMLDES PIC X(09) VALUE 'ITEMLDES '. 10 C-ITEMHELP PIC X(09) VALUE 'ITEMHELP '. 10 C-LUDATE PIC X(09) VALUE 'LUDATE '. 10 C-LUTIME PIC X(09) VALUE 'LUTIME '. 10 C-LUID PIC X(09) VALUE 'LUID '. 10 C-ITEMTAG PIC X(09) VALUE 'ITEMTAG '. 10 C-TIMEDATE PIC X(09) VALUE 'TIMEDATE '. 10 C-ITEMAUTH PIC X(09) VALUE 'ITEMAUTH '. 10 C-ITEMSDES PIC X(09) VALUE 'ITEMSDES '. 10 C-KEYWORD PIC X(09) VALUE 'KEYWORD '. 10 C-KEYSERCH PIC X(09) VALUE 'KEYSERCH '. 10 C-ZERRLM PIC X(09) VALUE 'ZERRLM '. 10 FILLER PIC X(01) VALUE ')'. *** ISPF VARIABLE FORMAT ARRAY *** 05 C-ISPF-FORMAT-ARRAY. 10 C-LINECMND-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ANDOR-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMNAME-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMTYPE-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMLDES-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMHELP-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-LUDATE-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-LUTIME-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-LUID-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMTAG-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-TIMEDATE-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMAUTH-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ITEMSDES-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-KEYWORD-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-KEYSERCH-FORMAT PIC X(08) VALUE 'CHAR '. 10 C-ZERRLM-FORMAT PIC X(08) VALUE 'CHAR '. *** ISPF OPERATION NAMES AND PARAMETERS *** 05 C-ISPF PIC X(08) VALUE 'ISPLINK '. 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 05 C-VGET PIC X(08) VALUE 'VGET '. 05 C-VPUT PIC X(08) VALUE 'VPUT '. 05 C-TBSKIP PIC X(08) VALUE 'TBSKIP '. 05 C-TBTOP PIC X(08) VALUE 'TBTOP '. 05 C-TBGET PIC X(08) VALUE 'TBGET '. 05 C-TBPUT PIC X(08) VALUE 'TBPUT '. 05 C-TBSARG PIC X(08) VALUE 'TBARG '. 05 C-TBSORT PIC X(08) VALUE 'TBSORT '. 05 C-TBVCLEAR PIC X(08) VALUE 'TBVCLEAR'. 05 C-CHAR PIC X(08) VALUE 'CHAR '. 05 C-ITEMS PIC X(08) VALUE 'ITEMS '. 05 C-ITEMKEY PIC X(08) VALUE 'ITEMKEY '. *** VARIABLES TO VGET/VPUT *** 05 C-VGET-VARIABLES. 10 FILLER PIC X(32) VALUE '(TIMEDATE KEYSERCH ANDOR ZERRLM)'. *** MISCELLANEOUS *** 05 C-ISPF-OPTIONS-LIST PIC X(21) VALUE '(COPY, NOBSCAN, LIST)'. 05 C-ITEMKEY-SORT-FIELDS PIC X(25) VALUE 'ITEMNAME,C,A,ITEMTYPE,C,A'. 05 C-MAX-TABLE-ENTRIES PIC S9(08) COMP VALUE +100. 05 C-YES PIC X(01) VALUE 'Y'. 05 C-NO PIC X(01) VALUE 'N'. 05 C-AND PIC X(01) VALUE 'A'. 05 C-OR PIC X(01) VALUE 'O'. 05 C-DECIMAL PIC X(01) VALUE '.'. 05 C-PERIOD PIC X(01) VALUE '.'. 05 C-PLUS PIC X(01) VALUE '+'. 05 C-MINUS PIC X(01) VALUE '-'. 05 C-COMMA PIC X(01) VALUE ','. 05 C-QUOTE PIC X(01) VALUE ''''. ****************************************************************** * S W I T C H E S * ****************************************************************** 01 S-SWITCHES. 05 FILLER PIC X(20) VALUE '.SWITCHES START HERE'. 05 S-ITEMS-TABLE-SWITCH PIC X(01) VALUE 'N'. 88 S-END-OF-ITEMS-TABLE VALUE 'Y'. 88 S-MORE-ITEMS-ROWS-EXIST VALUE 'N'. 05 S-ITEMKEY-TABLE-SWITCH PIC X(01) VALUE 'N'. 88 S-END-OF-ITEMKEY-TABLE VALUE 'Y'. 88 S-MORE-ITEMKEY-ROWS-EXIST VALUE 'N'. ****************************************************************** * W O R K - A R E A S * ****************************************************************** 01 W-WORK-AREAS. 05 FILLER PIC X(22) VALUE '.WORK AREAS START HERE'. *** WORKING-STORAGE BUCKETS FOR ISPF VARIABLES *** 05 W-ISPF-VARIABLES. 10 W-LINECMND PIC X(01) VALUE SPACES. 10 W-ANDOR PIC X(01) VALUE SPACES. 88 W-AND-LOGIC VALUE 'A'. 88 W-OR-LOGIC VALUE 'O'. 10 W-ITEMNAME PIC X(08) VALUE SPACES. 10 W-ITEMTYPE PIC X(08) VALUE SPACES. 10 W-ITEMLDES PIC X(08) VALUE SPACES. 10 W-ITEMHELP PIC X(08) VALUE SPACES. 10 W-LUDATE PIC X(08) VALUE SPACES. 10 W-LUTIME PIC X(08) VALUE SPACES. 10 W-LUID PIC X(08) VALUE SPACES. 10 W-ITEMTAG PIC X(16) VALUE SPACES. 10 W-TIMEDATE PIC X(16) VALUE SPACES. 10 W-ITEMAUTH PIC X(80) VALUE SPACES. 10 W-ITEMSDES PIC X(80) VALUE SPACES. 10 W-KEYWORD PIC X(80) VALUE SPACES. 10 W-KEYSERCH PIC X(80) VALUE SPACES. 10 W-ZERRLM PIC X(512) VALUE SPACES. *** MISCELLANEOUS *** 05 W-RETURN-CODE PIC S9(08) COMP SYNC VALUE +0. 05 W-ISPF-RETURN-CODE PIC 9(08) VALUE 0. 88 W-NORMAL-COMPLETION VALUE 0. 88 W-ISPF-PROBLEM VALUE 9 THRU 999. 88 W-ALMOST-NORMAL-COMPLETION VALUE 4. 88 W-ROW-NOT-FOUND VALUE 8. 88 W-END-OF-TABLE VALUE 8. 88 W-TABLE-NOT-OPEN VALUE 12. 88 W-SEVERE-ERROR VALUE 20. 05 W-ISPF-CALL PIC 9(07) VALUE ZEROS. 05 W-HOLD-ITEMNAME PIC X(08) VALUE SPACES. 05 W-HOLD-ITEMTYPE PIC X(08) VALUE SPACES. ****************************************************************** * P R I N T L I N E S * ****************************************************************** *01 P-PRINT-LINES. ****************************************************************** * T A B L E S * * CAUTION !!!! SOME TABLE VALUES ARE NON-DISPLAYABLE HEX VALUES. * * BE CAREFUL WHAT YOU CHANGE OR WHAT MASS CHANGES ARE MADE. * ****************************************************************** 01 T-TABLES. 05 FILLER PIC X(18) VALUE '.TABLES START HERE'. 05 T-KEYSERCH-TABLE-AREA. 10 T-KEYSERCH-TABLE OCCURS 100 TIMES INDEXED BY T-KEYSERCH-NDX. 15 T-KEYWORD PIC X(80). 05 T-KEYSERCH-TABLE-AREA-2. 10 T-KEYSERCH-TABLE-2 OCCURS 100 TIMES INDEXED BY T-KEYSERCH-NDX-2. 15 T-KEYWORD-2 PIC X(80). 05 T-ZERRLM-TABLE-AREA. 10 T-ZERRLM-TABLE OCCURS 14 TIMES INDEXED BY T-ZERRLM-NDX. 15 T-ZERRLM PIC X(37). 01 WS-END PIC X(44) VALUE '**** TXKEYWRD WORKING-STORAGE ENDS HERE ****'. PROCEDURE DIVISION. ****************************************************************** * P R O C E D U R E D I V I S I O N * ****************************************************************** /***************************************************************** * S0000-DRIVER * * FUNCTIONS: THIS ROUTINE CONTROLS THE WHOLE PROGRAM. * ****************************************************************** S0000-DRIVER SECTION. DISPLAY '~~~ S0000- ~~~'. PERFORM S1000-INITIALIZATION. PERFORM S2000-MAINLINE. PERFORM S3000-FINALIZATION. S0000-EXIT. EXIT. /***************************************************************** * S1000-INITIALIZATION * * FUNCTIONS: POINTS TO ISPF VARIABLES VIA "VDEFINE" SERVICE. * ****************************************************************** S1000-INITIALIZATION SECTION. DISPLAY '~~~ S1000- ~~~'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 1 TO W-ISPF-CALL. CALL C-ISPF USING C-VDEFINE C-ISPF-NAME-ARRAY W-ISPF-VARIABLES C-ISPF-FORMAT-ARRAY C-ISPF-LENGTH-ARRAY C-ISPF-OPTIONS-LIST. PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 2 TO W-ISPF-CALL. CALL C-ISPF USING C-TBTOP C-ITEMKEY. PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 3 TO W-ISPF-CALL. CALL C-ISPF USING C-TBVCLEAR C-ITEMKEY. PERFORM S5000-ISPF-RETURN-CODE-CHECK. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 4 TO W-ISPF-CALL. CALL C-ISPF USING C-TBSORT C-ITEMKEY C-ITEMKEY-SORT-FIELDS. PERFORM S5000-ISPF-RETURN-CODE-CHECK. PERFORM S1100-VGET. PERFORM S1200-LOAD-KEYWORDS. PERFORM S4100-READ-ITEMKEY-TABLE. S1000-EXIT. EXIT. /***************************************************************** * S1100-VGET * * FUNCTIONS: THIS ROUTINE "VGETS" THE NECESSARY VARIABLES. * ****************************************************************** S1100-VGET SECTION. DISPLAY '~~~ S1100- ~~~'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 5 TO W-ISPF-CALL. CALL C-ISPF USING C-VGET C-VGET-VARIABLES. IF RETURN-CODE > C-PASSABLE-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S1100-EXIT. EXIT. /***************************************************************** * S1200-LOAD-KEYWORDS * * FUNCTIONS: THIS ROUTINE LOADS THE KEYWORDS INTO A TABLE. * ****************************************************************** S1200-LOAD-KEYWORDS SECTION. DISPLAY '~~~ S1200- ~~~'. UNSTRING W-KEYSERCH DELIMITED BY ALL SPACES INTO T-KEYWORD (1) T-KEYWORD (2) T-KEYWORD (3) T-KEYWORD (4) T-KEYWORD (5) T-KEYWORD (6) T-KEYWORD (7) T-KEYWORD (8) T-KEYWORD (9) T-KEYWORD (10) T-KEYWORD (11) T-KEYWORD (12) T-KEYWORD (13) T-KEYWORD (14) T-KEYWORD (15) T-KEYWORD (16) T-KEYWORD (17) T-KEYWORD (18) T-KEYWORD (19) T-KEYWORD (20) T-KEYWORD (21) T-KEYWORD (22) T-KEYWORD (23) T-KEYWORD (24) T-KEYWORD (25) T-KEYWORD (26) T-KEYWORD (27) T-KEYWORD (28) T-KEYWORD (29) T-KEYWORD (30) T-KEYWORD (31) T-KEYWORD (32) T-KEYWORD (33) T-KEYWORD (34) T-KEYWORD (35) T-KEYWORD (36) T-KEYWORD (37) T-KEYWORD (38) T-KEYWORD (39) T-KEYWORD (40) T-KEYWORD (41) T-KEYWORD (42) T-KEYWORD (43) T-KEYWORD (44) T-KEYWORD (45) T-KEYWORD (46) T-KEYWORD (47) T-KEYWORD (48) T-KEYWORD (49) T-KEYWORD (50) T-KEYWORD (51) T-KEYWORD (52) T-KEYWORD (53) T-KEYWORD (54) T-KEYWORD (55) T-KEYWORD (56) T-KEYWORD (57) T-KEYWORD (58) T-KEYWORD (59) T-KEYWORD (60) T-KEYWORD (61) T-KEYWORD (62) T-KEYWORD (63) T-KEYWORD (64) T-KEYWORD (65) T-KEYWORD (66) T-KEYWORD (67) T-KEYWORD (68) T-KEYWORD (69) T-KEYWORD (70) T-KEYWORD (71) T-KEYWORD (72) T-KEYWORD (73) T-KEYWORD (74) T-KEYWORD (75) T-KEYWORD (76) T-KEYWORD (77) T-KEYWORD (78) T-KEYWORD (79) T-KEYWORD (80) T-KEYWORD (81) T-KEYWORD (82) T-KEYWORD (83) T-KEYWORD (84) T-KEYWORD (85) T-KEYWORD (86) T-KEYWORD (87) T-KEYWORD (88) T-KEYWORD (89) T-KEYWORD (90) T-KEYWORD (91) T-KEYWORD (92) T-KEYWORD (93) T-KEYWORD (94) T-KEYWORD (95) T-KEYWORD (96) T-KEYWORD (97) T-KEYWORD (98) T-KEYWORD (99) T-KEYWORD (100). S1200-EXIT. EXIT. /***************************************************************** * S2000-MAINLINE * * FUNCTIONS: THIS ROUTINE DOES THE PROCESSING FOR EACH ISPF * * ROW. * ****************************************************************** S2000-MAINLINE SECTION. DISPLAY '~~~ S2000- ~~~'. PERFORM UNTIL S-END-OF-ITEMKEY-TABLE MOVE T-KEYSERCH-TABLE-AREA TO T-KEYSERCH-TABLE-AREA-2 SET T-KEYSERCH-NDX-2 TO +1 SEARCH T-KEYSERCH-TABLE-2 VARYING T-KEYSERCH-NDX-2 WHEN W-AND-LOGIC AND T-KEYWORD-2 (T-KEYSERCH-NDX-2) = W-KEYWORD MOVE SPACES TO T-KEYWORD-2 (T-KEYSERCH-NDX-2) WHEN W-OR-LOGIC AND T-KEYWORD-2 (T-KEYSERCH-NDX-2) = W-KEYWORD MOVE SPACES TO T-KEYSERCH-TABLE-AREA-2 END-SEARCH IF T-KEYSERCH-TABLE-AREA-2 = SPACES PERFORM S4000-READ-ITEMS-TABLE MOVE W-TIMEDATE TO W-ITEMTAG PERFORM S4200-MODIFY-ITEMS-TABLE PERFORM S4300-SCAN-TO-NEXT-ITEMKEY-KEY ELSE PERFORM S4100-READ-ITEMKEY-TABLE END-IF END-PERFORM. S2000-EXIT. EXIT. /***************************************************************** * S3000-FINALIZATION * * FUNCTIONS: THIS ROUTINE CLOSES FILES AND DISPLAYS CONTROL * * INFORMATION. * ****************************************************************** S3000-FINALIZATION SECTION. DISPLAY '~~~ S3000- ~~~'. MOVE W-RETURN-CODE TO RETURN-CODE GOBACK. S3000-EXIT. EXIT. /***************************************************************** * S4000-READ-ITEMS-TABLE * * THIS ROUTINE READS THE ITEMS TABLE. * ****************************************************************** S4000-READ-ITEMS-TABLE SECTION. DISPLAY '~~~ S4000- ~~~'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 6 TO W-ISPF-CALL. CALL C-ISPF USING C-TBGET C-ITEMS. IF RETURN-CODE > C-PASSABLE-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S4000-EXIT. EXIT. /***************************************************************** * S4100-READ-ITEMKEY-TABLE * * THIS ROUTINE READS THE ITEMKEY TABLE. * ****************************************************************** S4100-READ-ITEMKEY-TABLE SECTION. DISPLAY '~~~ S4100- ~~~'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 7 TO W-ISPF-CALL. CALL C-ISPF USING C-TBSKIP C-ITEMKEY. IF RETURN-CODE = C-END-TABLE-RETURN-CODE SET S-END-OF-ITEMKEY-TABLE TO TRUE ELSE IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S4100-EXIT. EXIT. /***************************************************************** * S4200-MODIFY-ITEMS-TABLE * * THIS ROUTINE MODIFIES THE CURRENT "ITEMS" TABLE ROW. * ****************************************************************** S4200-MODIFY-ITEMS-TABLE SECTION. DISPLAY '~~~ S4200- ~~~'. ADD 1 TO A-ISPF-CALLS-MADE. MOVE 8 TO W-ISPF-CALL. CALL C-ISPF USING C-TBPUT C-ITEMS. IF RETURN-CODE > C-NORMAL-RETURN-CODE PERFORM S5000-ISPF-RETURN-CODE-CHECK. S4200-EXIT. EXIT. /***************************************************************** * S4300-SCAN-TO-NEXT-ITEMKEY-KEY * * THIS ROUTINE SCANS TO THE NEXT ITEM NAME/TYPE KEY * ****************************************************************** S4300-SCAN-TO-NEXT-ITEMKEY-KEY SECTION. DISPLAY '~~~ S4300- ~~~'. MOVE W-ITEMNAME TO W-HOLD-ITEMNAME. MOVE W-ITEMTYPE TO W-HOLD-ITEMTYPE. PERFORM S4100-READ-ITEMKEY-TABLE UNTIL W-ITEMNAME NOT = W-HOLD-ITEMNAME OR W-ITEMTYPE NOT = W-HOLD-ITEMTYPE OR S-END-OF-ITEMKEY-TABLE. S4300-EXIT. EXIT. /***************************************************************** * S5000-ISPF-RETURN-CODE-CHECK * * FUNCTIONS: THIS ROUTINE CHECKS THE RETURN CODE FROM ANY * * CALL TO ISPF AND DISPLAYS ABEND MESSAGES IF ANY. * ****************************************************************** S5000-ISPF-RETURN-CODE-CHECK SECTION. DISPLAY '~~~ S5000- ~~~'. MOVE RETURN-CODE TO W-ISPF-RETURN-CODE. MOVE C-BAD-ISPF-RETURN-CODE TO W-RETURN-CODE. MOVE SPACES TO T-ZERRLM-TABLE-AREA. MOVE W-ZERRLM TO T-ZERRLM-TABLE-AREA. IF W-ISPF-PROBLEM DISPLAY '********** TXKEYWRD ABEND INFO **********' DISPLAY '*============= ISPF ABEND ==============*' DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' DISPLAY '* RETURN CODE WAS : ' W-ISPF-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* # ISPF CALLS MADE WERE : ' A-ISPF-CALLS-MADE ' *' DISPLAY '* ISPF MESSAGE IS AS FOLLOWS : *' DISPLAY '* ' T-ZERRLM (1) ' *' DISPLAY '* ' T-ZERRLM (2) ' *' DISPLAY '* ' T-ZERRLM (3) ' *' DISPLAY '* ' T-ZERRLM (4) ' *' DISPLAY '* ' T-ZERRLM (5) ' *' DISPLAY '* ' T-ZERRLM (6) ' *' DISPLAY '* ' T-ZERRLM (7) ' *' DISPLAY '* ' T-ZERRLM (8) ' *' DISPLAY '* ' T-ZERRLM (9) ' *' DISPLAY '* ' T-ZERRLM (10) ' *' DISPLAY '* ' T-ZERRLM (11) ' *' DISPLAY '* ' T-ZERRLM (12) ' *' DISPLAY '* ' T-ZERRLM (13) ' *' DISPLAY '* ' T-ZERRLM (14) ' *' DISPLAY '*****************************************' PERFORM S3000-FINALIZATION. S5000-EXIT. ./ ADD NAME=WADATPGM ******************************************************************WADATPGM * I D E N T I F I C A T I O N D I V I S I O N *WADATPGM ******************************************************************WADATPGM IDENTIFICATION DIVISION. WADATPGM PROGRAM-ID. WADATPGM. WADATPGM AUTHOR. DAVE LEIGH. WADATPGM DATE-WRITTEN. JUNE 6, 1988. WADATPGM DATE-COMPILED. WADATPGM * COMPOPT: DYNAM WADATPGM ******************************************************************WADATPGM * PROGRAM NAME: WADATPGM *WADATPGM * *WADATPGM * FUNCTION: THIS PROGRAM CONVERTS DATES TO MULTIPLE FORMATS WITH *WADATPGM * WAASDATE AND PUTS THEM OUT INTO SEVERAL ISPF SHARED *WADATPGM * POOL VARIABLES. *WADATPGM * *WADATPGM * INPUTS: VGET THE INPUT DATE AND MOD NUMBER. *WADATPGM * *WADATPGM * OUTPUTS: ISPF VARIABLES *WADATPGM * *WADATPGM * DATABASE RECORDS/ELEMENTS USED: NONE *WADATPGM * *WADATPGM * EXITS NORMAL: *WADATPGM * *WADATPGM * EXITS ABNORMAL: *WADATPGM * *WADATPGM * SWITCHES: NONE *WADATPGM * *WADATPGM * TABLES: NONE *WADATPGM * *WADATPGM * COPY MEMBERS: WAAYCDAT *WADATPGM * *WADATPGM *--------------------------------------------------------------- *WADATPGM * MODIFICATION LOG *WADATPGM *--------------------------------------------------------------- *WADATPGM * INIT . DATE . COMMENTS *WADATPGM *======¬========¬=============================================== *WADATPGM ******************************************************************WADATPGM /*****************************************************************WADATPGM * E N V I R O N M E N T D I V I S I O N *WADATPGM ******************************************************************WADATPGM WADATPGM ENVIRONMENT DIVISION. WADATPGM WADATPGM INPUT-OUTPUT SECTION. WADATPGM FILE-CONTROL. WADATPGM WADATPGM /*****************************************************************WADATPGM * D A T A D I V I S I O N *WADATPGM ******************************************************************WADATPGM WADATPGM DATA DIVISION. WADATPGM WADATPGM FILE SECTION. WADATPGM WADATPGM /*****************************************************************WADATPGM * W O R K I N G - S T O R A G E S E C T I O N *WADATPGM ******************************************************************WADATPGM WADATPGM WORKING-STORAGE SECTION. WADATPGM WADATPGM 01 WS-START PIC X(48) VALUE WADATPGM '**** WADATPGM WORKING-STORAGE STARTS HERE ****'. WADATPGM WADATPGM ******************************************************************WADATPGM * A C C U M U L A T O R S *WADATPGM ******************************************************************WADATPGM 01 A-ACCUMULATORS. WADATPGM 05 A-WAASDATE-CALLS PIC 9(04) VALUE ZEROS. WADATPGM 05 A-ISPF-CALLS-MADE PIC 9(04) VALUE ZEROS. WADATPGM WADATPGM ******************************************************************WADATPGM * C O N S T A N T S *WADATPGM ******************************************************************WADATPGM WADATPGM 01 C-CONSTANTS. WADATPGM 05 C-MSG-ASTRISKS PIC X(46) VALUE PWBPDATE '**********************************************'. PWBPDATE 05 C-WAASDATE-ABEND-MSG PIC X(46) VALUE PWBPDATE '* PROBLEM WITH CALL TO WAASDATE *'. PWBPDATE 05 C-WDMESSAG-LEN PIC S9(06) COMP SYNC VALUE +50.WADATPGM 05 C-WDINDATE-LEN PIC S9(06) COMP SYNC VALUE +10.WADATPGM 05 C-WDINMOD-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDINFMT-LEN PIC S9(06) COMP SYNC VALUE +2. WADATPGM 05 C-WDDAYXXI-LEN PIC S9(06) COMP SYNC VALUE +9. WADATPGM 05 C-WDDAY99I-LEN PIC S9(06) COMP SYNC VALUE +2. WADATPGM 05 C-WDDAYXXO-LEN PIC S9(06) COMP SYNC VALUE +9. WADATPGM 05 C-WDDAY99O-LEN PIC S9(06) COMP SYNC VALUE +2. WADATPGM 05 C-WDFMT00I-LEN PIC S9(06) COMP SYNC VALUE +5. WADATPGM 05 C-WDFMT01I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT05I-LEN PIC S9(06) COMP SYNC VALUE +7. WADATPGM 05 C-WDFMT06I-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT10I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT11I-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT12I-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT20I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT21I-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT30I-LEN PIC S9(06) COMP SYNC VALUE +18.WADATPGM 05 C-WDFMT31I-LEN PIC S9(06) COMP SYNC VALUE +13.WADATPGM 05 C-WDFMT32I-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT33I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT40I-LEN PIC S9(06) COMP SYNC VALUE +9. WADATPGM 05 C-WDFMT50I-LEN PIC S9(06) COMP SYNC VALUE +4. WADATPGM 05 C-WDFMT60I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT70I-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT00O-LEN PIC S9(06) COMP SYNC VALUE +5. WADATPGM 05 C-WDFMT01O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT05O-LEN PIC S9(06) COMP SYNC VALUE +7. WADATPGM 05 C-WDFMT06O-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT10O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT11O-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT12O-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT20O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT21O-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT30O-LEN PIC S9(06) COMP SYNC VALUE +18.WADATPGM 05 C-WDFMT31O-LEN PIC S9(06) COMP SYNC VALUE +13.WADATPGM 05 C-WDFMT32O-LEN PIC S9(06) COMP SYNC VALUE +8. WADATPGM 05 C-WDFMT33O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT40O-LEN PIC S9(06) COMP SYNC VALUE +9. WADATPGM 05 C-WDFMT50O-LEN PIC S9(06) COMP SYNC VALUE +4. WADATPGM 05 C-WDFMT60O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-WDFMT70O-LEN PIC S9(06) COMP SYNC VALUE +6. WADATPGM 05 C-NORMAL-RETURN-CODE PIC 9(08) VALUE 4. 05 C-INITIAL-VARIABLES PIC X(26) VALUE '(WDINDATE WDINMOD WDINFMT)'. 05 C-VPUT-1 PIC X(46) VALUE '(WDFMT00I WDFMT01I WDFMT05I WDFMT06I WDFMT10I)'. 05 C-VPUT-2 PIC X(46) VALUE '(WDFMT11I WDFMT12I WDFMT20I WDFMT21I WDFMT30I)'. 05 C-VPUT-3 PIC X(46) VALUE '(WDFMT31I WDFMT32I WDFMT33I WDFMT40I WDFMT50I)'. 05 C-VPUT-4 PIC X(37) VALUE '(WDFMT60I WDFMT70I WDDAYXXI WDDAY99I)'. 05 C-VPUT-5 PIC X(46) VALUE '(WDFMT00O WDFMT01O WDFMT05O WDFMT06O WDFMT10O)'. 05 C-VPUT-6 PIC X(46) VALUE '(WDFMT11O WDFMT12O WDFMT20O WDFMT21O WDFMT30O)'. 05 C-VPUT-7 PIC X(46) VALUE '(WDFMT31O WDFMT32O WDFMT33O WDFMT40O WDFMT50O)'. 05 C-VPUT-8 PIC X(37) VALUE '(WDFMT60O WDFMT70O WDDAYXXO WDDAY99O)'. 05 C-WDMESSAG PIC X(10) VALUE '(WDMESSAG)'. 05 C-WDINDATE PIC X(10) VALUE '(WDINDATE)'. 05 C-WDINMOD PIC X(09) VALUE '(WDINMOD)'. 05 C-WDINFMT PIC X(09) VALUE '(WDINFMT)'. 05 C-WDDAYXXI PIC X(10) VALUE '(WDDAYXXI)'. WADATPGM 05 C-WDDAY99I PIC X(10) VALUE '(WDDAY99I)'. WADATPGM 05 C-WDDAYXXO PIC X(10) VALUE '(WDDAYXXO)'. WADATPGM 05 C-WDDAY99O PIC X(10) VALUE '(WDDAY99O)'. WADATPGM 05 C-WDFMT00I PIC X(10) VALUE '(WDFMT00I)'. 05 C-WDFMT01I PIC X(10) VALUE '(WDFMT01I)'. 05 C-WDFMT05I PIC X(10) VALUE '(WDFMT05I)'. 05 C-WDFMT06I PIC X(10) VALUE '(WDFMT06I)'. 05 C-WDFMT10I PIC X(10) VALUE '(WDFMT10I)'. 05 C-WDFMT11I PIC X(10) VALUE '(WDFMT11I)'. 05 C-WDFMT12I PIC X(10) VALUE '(WDFMT12I)'. 05 C-WDFMT20I PIC X(10) VALUE '(WDFMT20I)'. 05 C-WDFMT21I PIC X(10) VALUE '(WDFMT21I)'. 05 C-WDFMT30I PIC X(10) VALUE '(WDFMT30I)'. 05 C-WDFMT31I PIC X(10) VALUE '(WDFMT31I)'. 05 C-WDFMT32I PIC X(10) VALUE '(WDFMT32I)'. 05 C-WDFMT33I PIC X(10) VALUE '(WDFMT33I)'. 05 C-WDFMT40I PIC X(10) VALUE '(WDFMT40I)'. 05 C-WDFMT50I PIC X(10) VALUE '(WDFMT50I)'. 05 C-WDFMT60I PIC X(10) VALUE '(WDFMT60I)'. 05 C-WDFMT70I PIC X(10) VALUE '(WDFMT70I)'. 05 C-WDFMT00O PIC X(10) VALUE '(WDFMT00O)'. 05 C-WDFMT01O PIC X(10) VALUE '(WDFMT01O)'. 05 C-WDFMT05O PIC X(10) VALUE '(WDFMT05O)'. 05 C-WDFMT06O PIC X(10) VALUE '(WDFMT06O)'. 05 C-WDFMT10O PIC X(10) VALUE '(WDFMT10O)'. 05 C-WDFMT11O PIC X(10) VALUE '(WDFMT11O)'. 05 C-WDFMT12O PIC X(10) VALUE '(WDFMT12O)'. 05 C-WDFMT20O PIC X(10) VALUE '(WDFMT20O)'. 05 C-WDFMT21O PIC X(10) VALUE '(WDFMT21O)'. 05 C-WDFMT30O PIC X(10) VALUE '(WDFMT30O)'. 05 C-WDFMT31O PIC X(10) VALUE '(WDFMT31O)'. 05 C-WDFMT32O PIC X(10) VALUE '(WDFMT32O)'. 05 C-WDFMT33O PIC X(10) VALUE '(WDFMT33O)'. 05 C-WDFMT40O PIC X(10) VALUE '(WDFMT40O)'. 05 C-WDFMT50O PIC X(10) VALUE '(WDFMT50O)'. 05 C-WDFMT60O PIC X(10) VALUE '(WDFMT60O)'. 05 C-WDFMT70O PIC X(10) VALUE '(WDFMT70O)'. 05 C-VDEFINE PIC X(08) VALUE 'VDEFINE '. 05 C-VDELETE PIC X(08) VALUE 'VDELETE '. 05 C-VGET PIC X(08) VALUE 'VGET '. 05 C-VPUT PIC X(08) VALUE 'VPUT '. 05 C-CHAR PIC X(08) VALUE 'CHAR '. WADATPGM 05 C-WAASDATE PIC X(08) PWBPDATE VALUE 'WAASDATE'. PWBPDATE 05 C-CONVERT-FUNCTION PIC X(01) VALUE '0'. PWBPDATE 05 C-ADJUST-FUNCTION PIC X(01) VALUE '1'. PWBPDATE 05 C-DAY-OF-WEEK-FUNCTION PIC X(01) VALUE '3'. PWBPDATE WADATPGM ******************************************************************WADATPGM * S W I T C H E S *WADATPGM ******************************************************************WADATPGM 01 S-SWITCHES. WADATPGM 05 S-XREF-DATA-SWITCH PIC X(01) VALUE LOW-VALUES. 88 S-EOF-XREF-DATA VALUE HIGH-VALUES.WADATPGM 88 S-MORE-RECORDS VALUE LOW-VALUES. WADATPGM 05 S-LETTER-SWITCH PIC X(01) VALUE LOW-VALUES. 88 S-LETTER-SHOULD-BE-MOVED VALUE HIGH-VALUES.WADATPGM WADATPGM ******************************************************************WADATPGM * W O R K - A R E A S *WADATPGM ******************************************************************WADATPGM WADATPGM 01 W-WORK-AREAS. WADATPGM 05 W-DOUBLE PIC S9(18) COMP SYNC. PWBPDATE 05 W-LENGTH PIC S9(05) COMP SYNC VALUE ZEROS. 05 W-WAASDATE-RETURN-CODE PIC S9(09) COMP SYNC. PWBPDATE 88 W-NO-WAASDATE-PROBLEM VALUE +0. PWBPDATE 88 W-A-WAASDATE-PROBLEM VALUE +0001 PWBPDATE THRU +9999. PWBPDATE 05 W-WAASDATE-RC-MSG. PWBPDATE 10 FILLER PIC X(33) VALUE PWBPDATE '* THE WAASDATE RETURN CODE WAS : '. PWBPDATE 10 W-DISPLAY-RETURN-CODE PIC 9(08) VALUE ZEROS. PWBPDATE 10 FILLER PIC X(05) VALUE PWBPDATE ' *'. PWBPDATE 05 W-ISPF-CALL PIC 9(02) VALUE ZEROS. 05 W-VARIABLES PIC X(80) VALUE SPACES. 05 W-SERVICE PIC X(08) VALUE SPACES. 05 W-FORMAT PIC X(08) VALUE SPACES. 05 W-DISP-WORK PIC X(19) VALUE SPACES. 05 W-WDMESSAG PIC X(50) VALUE SPACES. 05 W-WDINDATE PIC X(10) VALUE SPACES. 05 W-WDINMOD PIC X(06) VALUE SPACES. 05 W-WDINMOD-WORK. 10 W-WDINMOD-TRASH PIC X(50) VALUE SPACES. WADATPGM 10 W-WDINMOD-SIGN PIC X(01) VALUE SPACES. 88 W-WDINMOD-MINUS VALUE '-'. 88 W-WDINMOD-PLUS VALUE '+'. 10 W-WDINMOD-AMOUNT PIC 9(05) VALUE ZEROS. 05 W-WDINFMT PIC X(02) VALUE SPACES. 05 W-WDDAYXXI PIC X(09) VALUE SPACES. WADATPGM 05 W-WDDAY99I PIC X(02) VALUE SPACES. WADATPGM 05 W-WDDAYXXO PIC X(09) VALUE SPACES. WADATPGM 05 W-WDDAY99O PIC X(02) VALUE SPACES. WADATPGM 05 W-WDFMT00I PIC X(05) VALUE SPACES. 05 W-WDFMT01I PIC X(06) VALUE SPACES. 05 W-WDFMT05I PIC X(07) VALUE SPACES. 05 W-WDFMT06I PIC X(08) VALUE SPACES. 05 W-WDFMT10I PIC X(06) VALUE SPACES. 05 W-WDFMT11I PIC X(08) VALUE SPACES. 05 W-WDFMT12I PIC X(08) VALUE SPACES. 05 W-WDFMT20I PIC X(06) VALUE SPACES. 05 W-WDFMT21I PIC X(08) VALUE SPACES. 05 W-WDFMT30I PIC X(18) VALUE SPACES. 05 W-WDFMT31I PIC X(13) VALUE SPACES. 05 W-WDFMT32I PIC X(08) VALUE SPACES. 05 W-WDFMT33I PIC X(06) VALUE SPACES. 05 W-WDFMT40I PIC X(09) VALUE SPACES. 05 W-WDFMT50I PIC X(04) VALUE SPACES. 05 W-WDFMT60I PIC X(06) VALUE SPACES. 05 W-WDFMT70I PIC X(06) VALUE SPACES. 05 W-WDFMT00O PIC X(05) VALUE SPACES. 05 W-WDFMT01O PIC X(06) VALUE SPACES. 05 W-WDFMT05O PIC X(07) VALUE SPACES. 05 W-WDFMT06O PIC X(08) VALUE SPACES. 05 W-WDFMT10O PIC X(06) VALUE SPACES. 05 W-WDFMT11O PIC X(08) VALUE SPACES. 05 W-WDFMT12O PIC X(08) VALUE SPACES. 05 W-WDFMT20O PIC X(06) VALUE SPACES. 05 W-WDFMT21O PIC X(08) VALUE SPACES. 05 W-WDFMT30O PIC X(18) VALUE SPACES. 05 W-WDFMT31O PIC X(13) VALUE SPACES. 05 W-WDFMT32O PIC X(08) VALUE SPACES. 05 W-WDFMT33O PIC X(06) VALUE SPACES. 05 W-WDFMT40O PIC X(09) VALUE SPACES. 05 W-WDFMT50O PIC X(04) VALUE SPACES. 05 W-WDFMT60O PIC X(06) VALUE SPACES. 05 W-WDFMT70O PIC X(06) VALUE SPACES. /*****************************************************************PWBPDATE * W A A S D A T E W O R K A R E A *PWBPDATE ******************************************************************PWBPDATE COPY WAAYCDAT. PWBPDATE ******************************************************************WADATPGM * T A B L E S *WADATPGM ******************************************************************WADATPGM * NO TABLES WADATPGM 01 WS-END PIC X(48) VALUE WADATPGM '**** WADATPGM WORKING-STORAGE ENDS HERE ****'. WADATPGM PROCEDURE DIVISION. WADATPGM ******************************************************************WADATPGM * P R O C E D U R E D I V I S I O N *WADATPGM ******************************************************************WADATPGM WADATPGM /*****************************************************************WADATPGM * S0000-DRIVER *WADATPGM * PERFORMED BY: *WADATPGM * FUNCTIONS: THIS ROUTINE CONTROLS THE WHOLE PROGRAM. *WADATPGM ******************************************************************WADATPGM WADATPGM S0000-DRIVER SECTION. WADATPGM WADATPGM PERFORM S1000-INITIALIZATION. WADATPGM WADATPGM PERFORM S2000-MAINLINE. WADATPGM WADATPGM PERFORM S3000-FINALIZATION. WADATPGM WADATPGM S0000-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S1000-INITIALIZATION *WADATPGM * PERFORMED BY: S0000-CONTROL *WADATPGM * FUNCTIONS: THIS ROUTINE OPENS THE INPUT FILE, PERFORMS THE *WADATPGM * PRIMING READ, DEFINES THE FUNCTION POOL VARIABLES*WADATPGM * TO ISPF, AND INITIALIZES THE ISPF TABLE. *WADATPGM ******************************************************************WADATPGM WADATPGM S1000-INITIALIZATION SECTION. WADATPGM WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 1 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDINDATE W-WDINDATE C-CHAR C-WDINDATE-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 2 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDINFMT W-WDINFMT C-CHAR C-WDINFMT-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 3 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDINMOD W-WDINMOD C-CHAR C-WDINMOD-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 4 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT00I W-WDFMT00I C-CHAR C-WDFMT00I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 5 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT01I W-WDFMT01I C-CHAR C-WDFMT01I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 6 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT05I W-WDFMT05I C-CHAR C-WDFMT05I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 7 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT06I W-WDFMT06I C-CHAR C-WDFMT06I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 8 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT10I W-WDFMT10I C-CHAR C-WDFMT10I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 9 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT11I W-WDFMT11I C-CHAR C-WDFMT11I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 10 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT12I W-WDFMT12I C-CHAR C-WDFMT12I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 12 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT20I W-WDFMT20I C-CHAR C-WDFMT20I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 13 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT21I W-WDFMT21I C-CHAR C-WDFMT21I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 14 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT30I W-WDFMT30I C-CHAR C-WDFMT30I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 15 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT31I W-WDFMT31I C-CHAR C-WDFMT31I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 16 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT32I W-WDFMT32I C-CHAR C-WDFMT32I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 17 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT33I W-WDFMT33I C-CHAR C-WDFMT33I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 18 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT40I W-WDFMT40I C-CHAR C-WDFMT40I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 19 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT50I W-WDFMT50I C-CHAR C-WDFMT50I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 20 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT60I W-WDFMT60I C-CHAR C-WDFMT60I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 21 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT70I W-WDFMT70I C-CHAR C-WDFMT70I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 23 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT00O W-WDFMT00O C-CHAR C-WDFMT00O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 24 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT01O W-WDFMT01O C-CHAR C-WDFMT01O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 25 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT05O W-WDFMT05O C-CHAR C-WDFMT05O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 26 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT06O W-WDFMT06O C-CHAR C-WDFMT06O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 27 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT10O W-WDFMT10O C-CHAR C-WDFMT10O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 28 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT11O W-WDFMT11O C-CHAR C-WDFMT11O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 29 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT12O W-WDFMT12O C-CHAR C-WDFMT12O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 31 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT20O W-WDFMT20O C-CHAR C-WDFMT20O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 32 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT21O W-WDFMT21O C-CHAR C-WDFMT21O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 33 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT30O W-WDFMT30O C-CHAR C-WDFMT30O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 34 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT31O W-WDFMT31O C-CHAR C-WDFMT31O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 35 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT32O W-WDFMT32O C-CHAR C-WDFMT32O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 36 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT33O W-WDFMT33O C-CHAR C-WDFMT33O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 37 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT40O W-WDFMT40O C-CHAR C-WDFMT40O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 38 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT50O W-WDFMT50O C-CHAR C-WDFMT50O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 38 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT60O W-WDFMT60O C-CHAR C-WDFMT60O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 40 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDFMT70O W-WDFMT70O C-CHAR C-WDFMT70O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 42 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDMESSAG W-WDMESSAG C-CHAR C-WDMESSAG-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 43 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDDAYXXI W-WDDAYXXI C-CHAR C-WDDAYXXI-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 44 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDDAY99I W-WDDAY99I C-CHAR C-WDDAY99I-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 45 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDDAYXXO W-WDDAYXXO C-CHAR C-WDDAYXXO-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 46 TO W-ISPF-CALL. CALL 'ISPLINK' USING C-VDEFINE C-WDDAY99O W-WDDAY99O C-CHAR C-WDDAY99O-LEN. PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM S1000-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S2000-MAINLINE *WADATPGM * PERFORMED BY: S0000-CONTROL *WADATPGM * FUNCTIONS: THIS ROUTINE CREATES THE TABLE ENTRY AND DOES THE*WADATPGM * NEXT READ. *WADATPGM ******************************************************************WADATPGM WADATPGM S2000-MAINLINE SECTION. WADATPGM WADATPGM ADD 1 TO A-ISPF-CALLS-MADE. MOVE 47 TO W-ISPF-CALL. WADATPGM CALL 'ISPLINK' USING C-VGET C-INITIAL-VARIABLES. WADATPGM PERFORM S5000-ISPF-RETURN-CODE-CHECK. WADATPGM UNSTRING W-WDINMOD DELIMITED BY '+' OR '-' OR SPACES WADATPGM INTO W-WDINMOD-TRASH DELIMITER IN W-WDINMOD-SIGN WADATPGM W-WDINMOD-AMOUNT. WADATPGM WADATPGM IF W-WDINFMT NUMERIC WADATPGM PERFORM S2100-REFORMAT-IN-DATE WADATPGM IF W-WDINMOD-AMOUNT NUMERIC WADATPGM PERFORM S2200-REFORMAT-OUT-DATE WADATPGM ELSE WADATPGM NEXT SENTENCE WADATPGM ELSE WADATPGM MOVE 8 TO RETURN-CODE WADATPGM DISPLAY 'INPUT DATE FORMAT : ' W-WDINFMT WADATPGM ' WAS NOT NUMERIC '. WADATPGM WADATPGM S2000-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S2100-REFORMAT-IN-DATE *WADATPGM * PERFORMED BY: S2000 *WADATPGM * FUNCTIONS: THIS ROUTINE REFORMATS THE INPUT DATE *WADATPGM ******************************************************************WADATPGM WADATPGM S2100-REFORMAT-IN-DATE SECTION. WADATPGM WADATPGM MOVE W-WDINFMT TO W-FORMAT-1. PWBPDATE MOVE W-WDINDATE TO W-DATE-1. PWBPDATE MOVE C-CONVERT-FUNCTION TO W-FUNCTION-CODE. WADATPGM MOVE '00' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-5 TO W-WDFMT00I. PWBPDATE WADATPGM MOVE '01' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT01I. PWBPDATE WADATPGM MOVE '05' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-7 TO W-WDFMT05I. PWBPDATE WADATPGM MOVE '06' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT06I. PWBPDATE WADATPGM MOVE '10' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT10I. PWBPDATE WADATPGM MOVE '11' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT11I. PWBPDATE WADATPGM MOVE '12' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT12I. PWBPDATE WADATPGM MOVE '20' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT20I. PWBPDATE WADATPGM MOVE '21' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT21I. PWBPDATE WADATPGM MOVE '30' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2 TO W-WDFMT30I. PWBPDATE WADATPGM MOVE '31' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-13 TO W-WDFMT31I. PWBPDATE WADATPGM MOVE '32' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT32I. PWBPDATE WADATPGM MOVE '33' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT33I. PWBPDATE WADATPGM MOVE '40' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-9 TO W-WDFMT40I. PWBPDATE WADATPGM MOVE '50' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-4 TO W-WDFMT50I. PWBPDATE WADATPGM MOVE '60' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT60I. PWBPDATE WADATPGM MOVE '70' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT70I. PWBPDATE WADATPGM MOVE C-DAY-OF-WEEK-FUNCTION TO W-FUNCTION-CODE. PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-9 TO W-WDDAYXXI. PWBPDATE MOVE W-FORMAT-2 TO W-WDDAY99I. PWBPDATE WADATPGM S2100-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S2200-REFORMAT-OUT-DATE *WADATPGM * PERFORMED BY: S2000 *WADATPGM * FUNCTIONS: THIS ROUTINE REFORMATS THE OUTPUT DATE *WADATPGM ******************************************************************WADATPGM WADATPGM S2200-REFORMAT-OUT-DATE SECTION. WADATPGM WADATPGM MOVE W-WDINMOD-AMOUNT TO W-NUMBER-FIELD. PWBPDATE IF W-WDINMOD-MINUS COMPUTE W-NUMBER-FIELD = W-NUMBER-FIELD - W-NUMBER-FIELD - W-NUMBER-FIELD. WADATPGM MOVE W-WDINFMT TO W-FORMAT-1. PWBPDATE MOVE W-WDINDATE TO W-DATE-1. PWBPDATE MOVE C-ADJUST-FUNCTION TO W-FUNCTION-CODE. MOVE '00' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-5 TO W-WDFMT00O PWBPDATE TO W-DATE-1. PWBPDATE WADATPGM MOVE '00' TO W-FORMAT-1. PWBPDATE MOVE C-CONVERT-FUNCTION TO W-FUNCTION-CODE. WADATPGM MOVE '01' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT01O. PWBPDATE WADATPGM MOVE '05' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-7 TO W-WDFMT05O. PWBPDATE WADATPGM MOVE '06' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT06O. PWBPDATE WADATPGM MOVE '10' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT10O. PWBPDATE WADATPGM MOVE '11' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT11O. PWBPDATE WADATPGM MOVE '12' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT12O. PWBPDATE WADATPGM MOVE '20' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT20O. PWBPDATE WADATPGM MOVE '21' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT21O. PWBPDATE WADATPGM MOVE '30' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2 TO W-WDFMT30O. PWBPDATE WADATPGM MOVE '31' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-13 TO W-WDFMT31O. PWBPDATE WADATPGM MOVE '32' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-8 TO W-WDFMT32O. PWBPDATE WADATPGM MOVE '33' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT33O. PWBPDATE WADATPGM MOVE '40' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-9 TO W-WDFMT40O. PWBPDATE WADATPGM MOVE '50' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-4 TO W-WDFMT50O. PWBPDATE WADATPGM MOVE '60' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT60O. PWBPDATE WADATPGM MOVE '70' TO W-FORMAT-2. PWBPDATE PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-6 TO W-WDFMT70O. PWBPDATE WADATPGM MOVE C-DAY-OF-WEEK-FUNCTION TO W-FUNCTION-CODE. PERFORM S4000-CALL-WAASDATE. PWBPDATE MOVE W-DATE-2-9 TO W-WDDAYXXO. PWBPDATE MOVE W-FORMAT-2 TO W-WDDAY99O. PWBPDATE WADATPGM S2200-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S3000-FINALIZATION *WADATPGM * PERFORMED BY: S0000-CONTROL *WADATPGM * FUNCTIONS: THIS ROUTINE CLOSES FILES AND DISPLAYS CONTROL *WADATPGM * INFORMATION. *WADATPGM ******************************************************************WADATPGM WADATPGM S3000-FINALIZATION SECTION. WADATPGM WADATPGM IF RETURN-CODE > 0 GO TO S3000-GOBACK ELSE NEXT SENTENCE. ADD 1 TO A-ISPF-CALLS-MADE MOVE 49 TO W-ISPF-CALL CALL 'ISPLINK' USING C-VPUT C-VPUT-1 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM ADD 1 TO A-ISPF-CALLS-MADE MOVE 50 TO W-ISPF-CALL CALL 'ISPLINK' USING C-VPUT C-VPUT-2 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM ADD 1 TO A-ISPF-CALLS-MADE MOVE 51 TO W-ISPF-CALL CALL 'ISPLINK' USING C-VPUT C-VPUT-3 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM ADD 1 TO A-ISPF-CALLS-MADE MOVE 52 TO W-ISPF-CALL CALL 'ISPLINK' USING C-VPUT C-VPUT-4 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM CALL 'ISPLINK' USING C-VPUT C-VPUT-5 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM CALL 'ISPLINK' USING C-VPUT C-VPUT-6 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM CALL 'ISPLINK' USING C-VPUT C-VPUT-7 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM CALL 'ISPLINK' USING C-VPUT C-VPUT-8 IF RETURN-CODE > C-NORMAL-RETURN-CODE WADA MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADA DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADA DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************'. WADA WADATPGM S3000-GOBACK. WADATPGM GOBACK. WADATPGM WADATPGM S3000-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************WADATPGM * S5000-ISPF-RETURN-CODE-CHECK *WADATPGM * PERFORMED BY: S1000-INITIALIZATION *WADATPGM * FUNCTIONS: THIS ROUTINE CHECKS THE RETURN CODE FROM ANY *WADATPGM * CALL TO ISPF AND DISPLAYS ABEND MESSAGES IF ANY. *WADATPGM ******************************************************************WADATPGM WADATPGM S5000-ISPF-RETURN-CODE-CHECK SECTION. WADATPGM WADATPGM IF RETURN-CODE > C-NORMAL-RETURN-CODE WADATPGM MOVE RETURN-CODE TO W-DISPLAY-RETURN-CODE DISPLAY '************** ISPF ABEND ***************' WADATPGM DISPLAY '* BAD RETURN CODE FROM ISPF CALL. *' WADATPGM DISPLAY '* RETURN CODE WAS : ' W-DISPLAY-RETURN-CODE ' *' DISPLAY '* ISPF CALL SEQUENCE WAS : ' W-ISPF-CALL ' *' DISPLAY '* ISPF CALL NUMBER WAS : ' A-ISPF-CALLS-MADE ' *' DISPLAY '*****************************************' WADATPGM PERFORM S3000-FINALIZATION ELSE WADATPGM NEXT SENTENCE. WADATPGM WADATPGM S5000-EXIT. WADATPGM EXIT. WADATPGM /*****************************************************************PWBPDATE * S4000-CALL-WAASDATE *PWBPDATE * PERFORMED BY: S2100, S2200, S2300 *PWBPDATE * FUNCTIONS: THIS ROUTINE CALLS WAASDATE AND HANDLES ERROR *PWBPDATE * PROCESSING. *PWBPDATE ******************************************************************PWBPDATE PWBPDATE S4000-CALL-WAASDATE SECTION. PWBPDATE PWBPDATE ADD 1 TO A-WAASDATE-CALLS. PWBPDATE PWBPDATE CALL C-WAASDATE USING W-DATE-AREA, W-DOUBLE. PWBPDATE PWBPDATE MOVE W-RETURN-CODE TO W-WAASDATE-RETURN-CODE PWBPDATE RETURN-CODE. PWBPDATE PWBPDATE IF W-A-WAASDATE-PROBLEM PWBPDATE MOVE W-RETURN-CODE TO W-DISPLAY-RETURN-CODE PWBPDATE DISPLAY C-MSG-ASTRISKS PWBPDATE DISPLAY W-WAASDATE-RC-MSG PWBPDATE DISPLAY C-MSG-ASTRISKS PWBPDATE DISPLAY '* PERTINENT WAASDATE WORK FIELD VALUES *' PWBPDATE EXHIBIT NAMED W-FUNCTION-CODE PWBPDATE EXHIBIT NAMED W-DATE-1 PWBPDATE EXHIBIT NAMED W-FORMAT-1 PWBPDATE EXHIBIT NAMED W-DATE-2 PWBPDATE EXHIBIT NAMED W-FORMAT-2 PWBPDATE EXHIBIT NAMED W-NUMBER-FIELD PWBPDATE DISPLAY W-WAASDATE-RC-MSG PWBPDATE DISPLAY '----PERTINENT WAASDATE WORK FIELD VALUES----' PWBPDATE DISPLAY 'W-FUNCTION-CODE' W-FUNCTION-CODE PWBPDATE DISPLAY 'W-DATE-1' W-DATE-1 PWBPDATE DISPLAY 'W-FORMAT-1' W-FORMAT-1 PWBPDATE DISPLAY 'W-DATE-2' W-DATE-2 PWBPDATE DISPLAY 'W-FORMAT-2' W-FORMAT-2 PWBPDATE DISPLAY 'W-NUMBER-FIELD' W-NUMBER-FIELD PWBPDATE PERFORM S3000-FINALIZATION ELSE PWBPDATE NEXT SENTENCE. PWBPDATE PWBPDATE S4000-EXIT. PWBPDATE EXIT. PWBPDATE ./ ADD NAME=WORKSTOR 008400/**************************************************************** 008500* W O R K I N G - S T O R A G E S E C T I O N * 008600***************************************************************** 008700 WORKING-STORAGE SECTION. 008710 01 STANDARD-PROGRAM-ID. 008720 05 A-STANDARD-PROGRAM-ID PIC X(26) VALUE 008730 'UNIPAC/???????/??????-1.00'. 008800***************************************************************** 008900* A C C U M U L A T O R S * 009000***************************************************************** 009100 01 ACCUMULATORS. 009200 05 FILLER PIC X(13) VALUE 009300 'ACCUMULATORS:'. 009800/**************************************************************** 009900* C O N S T A N T S * 010000***************************************************************** 010100 01 CONSTANTS. 010200 05 FILLER PIC X(10) VALUE 010300 'CONSTANTS:'. 010500/**************************************************************** 010600* S W I T C H E S * 010700***************************************************************** 010800 01 SWITCHES. 010900 05 FILLER PIC X(09) VALUE 011000 'SWITCHES:'. 011700/**************************************************************** 011800* W O R K A R E A S * 011900***************************************************************** 012000 01 WORK-AREAS. 012100 05 FILLER PIC X(11) VALUE 012200 'WORK AREAS:'. 013300/**************************************************************** 013400* P R I N T L I N E S * 013500***************************************************************** 013600 01 PRINT-LINES. 013700 05 FILLER PIC X(12) VALUE 013800 'PRINT LINES:'. 013900/**************************************************************** 014000* T A B L E S * 014100***************************************************************** 014200 01 TABLES. 014300 05 FILLER PIC X(07) VALUE 014400 'TABLES:'. 014500/**************************************************************** 014600* L I N K A G E S E C T I O N * 014700***************************************************************** 014800 LINKAGE SECTION. 014900 01 L-PARM. 015000 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 015200 05 L-PARM-DATA PIC X(100). ./ ADD NAME=WSLAYOUT 008800***************************************************************** 008900* A C C U M U L A T O R S * 009000***************************************************************** 009100 01 ACCUMULATORS. 009200 05 FILLER PIC X(13) VALUE 009300 'ACCUMULATORS:'. 009400 05 A-RECORDS-READ PIC S9(08) COMP SYNC VALUE +0. 009500 05 A-RECORDS-WRITTEN PIC S9(08) COMP SYNC VALUE +0. 009800/**************************************************************** 009900* C O N S T A N T S * 010000***************************************************************** 010100 01 CONSTANTS. 010200 05 FILLER PIC X(10) VALUE 010300 'CONSTANTS:'. 010400 05 C-INCREMENT PIC S9(08) COMP SYNC VALUE +10000. 010500/**************************************************************** 010600* S W I T C H E S * 010700***************************************************************** 010800 01 SWITCHES. 010900 05 FILLER PIC X(09) VALUE 011000 'SWITCHES:'. 011100 05 S-END-OF-FILE-SWITCH PIC X(01) VALUE 'N'. 011200 88 S-END-OF-FILE VALUE 'Y'. 011300 88 S-NOT-END-OF-FILE VALUE 'N'. 011700/**************************************************************** 011800* W O R K A R E A S * 011900***************************************************************** 012000 01 WORK-AREAS. 012100 05 FILLER PIC X(11) VALUE 012200 'WORK AREAS:'. 012400 05 W-INCREMENT PIC S9(08) COMP SYNC VALUE +0. 013300/**************************************************************** 013400* P R I N T L I N E S * 013500***************************************************************** 013600 01 PRINT-LINES. 013700 05 FILLER PIC X(12) VALUE 013800 'PRINT LINES:'. 013900/**************************************************************** 014000* T A B L E S * 014100***************************************************************** 014200 01 TABLES. 014300 05 FILLER PIC X(07) VALUE 014400 'TABLES:'. 014500/**************************************************************** 014600* L I N K A G E S E C T I O N * 014700***************************************************************** 014800 LINKAGE SECTION. 014900 01 L-PARM. 015000 05 L-PARM-LENGTH PIC S9(04) COMP SYNC. 015200 05 L-PARM-DATA PIC X(100). ./ ADD NAME=XDB2ISPF 070900/***************************************************************** 071000** S2000-MAIN-PROCESS ** 071100** THIS IS THE MAINLINE SECTION WHICH IS EXECUTED FOR EACH ** 071200** RECORD READ FROM THE INPUT VARIABLE FILE. THE PROCESSING ** 071300** FOR EACH RECORD IS AS FOLLOWS: ** 071400** 1. IF THIS IS THE ISPF SKELETON LIBRARY "RESERVED" VARIABLE ** 071500** THEN STORE THE VALUE FOR THAT IN WORKING STORAGE. ** 071600** 2. IF THIS IS THE MEMBER NAME OF THE SKELETON "RESERVED" ** 071700** VARIABLE THEN STORE THE VALUE FOR THAT IN WORKING STORAGE.** 071800** 3. DETERMINE THE LENGTH OF THE VARIABLE. THIS IS NECESSARY ** 071900** OR ISPF WILL ASSUME THAT THE VARIABLE IS 72 BYTES LONG AND** 072000** THE TRAILING BLANKS WILL BE MAINTAINED. ** 072100** 4. DEFINE THE VARIABLE TO ISPF AS A FUNCTION VARIABLE WITH ** 072200** THE VDEFINE STATEMENT. ** 072300** 5. VPUT THE VARIABLE INTO THE THE SHARED POOL. THE REASON ** 072400** WE DON'T USE THE FUNCTION POOL VARIABLES FOR THE FILE ** 072500** TAILORING IS THAT THEY ALL POINT TO THE SAME WORKING ** 072600** STORAGE FIELD (INPUT-VARIABLE-VALUE) TO CONTAIN THE VALUE.** 072700** CONSEQUENTLY, BY THE TIME THE PROGRAM IS FINISHED, EACH ** 072800** FUNCTION POOL VARIABLE CONTAINS THE VALUE OF THE LAST ** 072900** VARIABLE DEFINED. THE SHARED POOL VARIABLE RETAINS ITS ** 073000** VALUE PROPERLY, HOWEVER. ** 073100** 6. READ THE NEXT RECORD. ** 073200****************************************************************** 073300 S2000-MAIN-PROCESS SECTION. 073400 073500 IF INPUT-VARIABLE-NAME = C-ISPF-SKELETON-LIBRARY 073600 MOVE INPUT-VARIABLE-VALUE TO W-ISPF-SKELETON-LIBRARY 073700 END-IF. 073800 073900 IF INPUT-VARIABLE-NAME = C-ISPF-SKELETON-MEMBER 074000 MOVE INPUT-VARIABLE-VALUE TO W-ISPF-SKELETON-MEMBER 074100 END-IF. 074200 074300 IF INPUT-VARIABLE-NAME = C-ISPF-OUTPUT-MEMBER 074400 MOVE INPUT-VARIABLE-VALUE TO W-ISPF-OUTPUT-MEMBER 074500 END-IF. 074600 074700 PERFORM VARYING INPUT-NDX FROM +72 BY -1 074800 UNTIL INPUT-VARIABLE-BYTE (INPUT-NDX) > SPACES 074900 OR INPUT-NDX < +2 075000 END-PERFORM. 075100 075200 SET W-VARIABLE-LENGTH TO INPUT-NDX. 075300 075400 SET W-VDEFINE-RC TO TRUE. 075500 CALL C-ISPF USING C-VDEFINE 075600 INPUT-VARIABLE-NAME 075700 INPUT-VARIABLE-VALUE 075800 C-CHARACTER 075900 W-VARIABLE-LENGTH. 076000 PERFORM S6000-ISPF-CALL-CHECK. 076100 076200 SET W-VPUT-RC TO TRUE. 076300 CALL C-ISPF USING C-VPUT 076400 INPUT-VARIABLE-NAME 076500 C-SHARED. 076600 PERFORM S6000-ISPF-CALL-CHECK. 076700 076800 DISPLAY 'VARIABLE: "' INPUT-VARIABLE-NAME '" = "' 076900 INPUT-VARIABLE-VALUE '"'. 077000 077100 ADD +1 TO A-VARIABLES-DEFINED. 077200 077300 PERFORM S5000-READ-SYMBOLIC-FILE. 077400 077500 S2000-EXIT. 077600 EXIT. 077700/***************************************************************** 077800** S3000-FILE-TAILOR ** 077900** THIS SECTION IS EXECUTED CONDITIONALLY IF ALL THE VARIABLE ** 078000** DEFINING AND "PUTTING" HAS HAPPENED SUCCESSUFULLY AND THE ** 078100** SKELETON LIBRARY NAME AND THE MEMBER NAME TO TAILOR WERE ALSO** 078200** BOTH RECEIVED. ** 078300** ** 078400** THE FIRST THING WE DO IS TO DELETE THE FUNCTION VARIABLES WE ** 078500** "VDEFINED". THAT WAY, WHEN THE FILE TAILORING GOES AFTER ** 078600** VARIABLES OF A SPECIFIC NAME, THE FIRST ONES IT WILL ** 078700** ENCOUNTER WILL BE THE ONES IN THE SHARED POOL. ** 078800** ** 078900** THEN WE "LIBDEF" TO THE ISPF SKELETON LIBRARY WHICH WAS ** 079000** PASSED IN THE INPUT VARIABLE STREAM. ONCE ALL OF THIS HAS ** 079100** BEEN DONE SUCCESSFULLY, WE FILE TAILOR THE MEMBER, WHICH WAS ** 079200** ALSO SPECIFIED IN THE INPUT VARIABLE STREAM. ** 079300****************************************************************** 079400 S3000-FILE-TAILOR SECTION. 079500 079600 SET W-VDELETE-RC TO TRUE. 079700 CALL C-ISPF USING C-VDELETE 079800 C-ALL-VARIABLES. 079900 PERFORM S6000-ISPF-CALL-CHECK. 080000 080100 SET W-LIBDEF-RC TO TRUE. 080200 CALL C-ISPF USING C-LIBDEF 080300 C-ISPSLIB 080400 C-DATASET 080500 W-ISPF-SKELETON-LIBRARY-AREA. 080600 PERFORM S6000-ISPF-CALL-CHECK. 080700 080800 SET W-FTOPEN-RC TO TRUE. 080900 CALL C-ISPF USING C-FTOPEN. 081000 PERFORM S6000-ISPF-CALL-CHECK. 081100 081200 SET W-FTINCL-RC TO TRUE. 081300 CALL C-ISPF USING C-FTINCL 081400 W-ISPF-SKELETON-MEMBER. 081500 PERFORM S6000-ISPF-CALL-CHECK. 081600 081700 SET W-FTCLOSE-RC TO TRUE. 081800 IF W-NO-OUTPUT-MEMBER-SPECIFIED 081900 CALL C-ISPF USING C-FTCLOSE 082000 ELSE 082100 CALL C-ISPF USING C-FTCLOSE 082200 W-ISPF-OUTPUT-MEMBER 082300 END-IF. 082400 PERFORM S6000-ISPF-CALL-CHECK. 082500 082600 S3000-EXIT. 082700 EXIT. 082800/***************************************************************** 082900** S4000-FINALIZATION ** 083000** THIS SECTION CONTROLS THE FINAL PROCESSING FOR EITHER GOOD OR** 083100** BAD EXECUTIONS. IF A FATAL ERROR OCCURS MID-STREAM, THIS ** 083200** SECTION WILL BE PERFORMED TO GET OUT. THAT IS WHY IT HAS THE** 083300** GOBACK AT THE END. ** 083400** ** 083500** IS DISPLAYS THE ACCUMULATORS, CLOSES THE INPUT FILE, MOVES ** 083600** THE RETURN CODE AND "GOES BACK". ** 083700****************************************************************** 083800 S4000-FINALIZATION SECTION. 083900 084000 DISPLAY 'A-VARIABLE-RECORDS-READ: ' 084100 A-VARIABLE-RECORDS-READ. 084200 084300 DISPLAY 'A-VARIABLES-DEFINED: ' 084400 A-VARIABLES-DEFINED. 084500 084600 IF A-VARIABLES-DEFINED NOT = A-VARIABLE-RECORDS-READ 084700 DISPLAY '*** NOTE ***' 084800 DISPLAY 'THE SAME NUMBER OF VARIABLES WAS NOT DEFINED ' 084900 'AS WAS READ!' 085000 IF W-GOOD-RETURN-CODE 085100 MOVE 8 TO W-RETURN-CODE 085200 END-IF 085300 END-IF. 085400 085500 DISPLAY 'A-ISPF-CALLS-EXECUTED: ' 085600 A-ISPF-CALLS-EXECUTED. 085700 085800 CLOSE INPUT-VARIABLE-FILE. 085900 086000 MOVE W-RETURN-CODE TO RETURN-CODE. 086100 086200 GOBACK. 086300 086400 S4000-EXIT. 086500 EXIT. 086600/***************************************************************** 086700** S5000-READ-SYMBOLIC-FILE ** 086800** THIS SECTION SIMPLY READS THE NEXT INPUT VARIABLE FILE ** 086900** RECORD AND INCREMENTS THE READ COUNTER. ** 087000****************************************************************** 087100 S5000-READ-SYMBOLIC-FILE SECTION. 087200 087300 READ INPUT-VARIABLE-FILE 087400 AT END 087500 SET S-END-OF-FILE TO TRUE 087600 END-READ. 087700 087800 IF S-MORE-RECORDS-TO-READ 087900 ADD +1 TO A-VARIABLE-RECORDS-READ 088000 END-IF. 088100 088200 S5000-EXIT. 088300 EXIT. 088400/***************************************************************** 088500** S6000-ISPF-CALL-CHECK ** 088600** THIS SECTION IS CALLED AFTER EACH ISPF CALL TO CENTRALIZE ** 088700** THE PROCESSING NECESSARY TO DO ERROR CHECKING AND COUNTING ** 088800** THE NUMBER OF ISPF EXECUTIONS. ** 088900** ** 089000** FIRST WE SAVE THE RETURN CODE FROM THE ISPF CALL. THEN WE ** 089100** ADD ONE TO THE ISPF CALL ACCUMULATOR. IF THE RETURN CODE ** 089200** WAS GOOD, WE RETURN TO THE SECTION WHICH PERFORMED THIS ONE. ** 089300** ** 089400** IF THE RETURN CODE IS NOT ACCEPTABLE, SERVICE-SPECIFIC ** 089500** DISPLAYS ARE DONE AND FINALIZATION IS CALLED IN ORDER TO GET ** 089600** OUT. ** 089700****************************************************************** 089800 S6000-ISPF-CALL-CHECK SECTION. 089900 090000 MOVE RETURN-CODE TO W-RETURN-CODE-SUFFIX. 090100 ADD +1 TO A-ISPF-CALLS-EXECUTED. 090200 090300 IF W-ACCEPTABLE-ISPF-RETURN-CODE 090400 SET W-GOOD-RETURN-CODE TO TRUE 090500 ELSE 090600 EVALUATE TRUE 090700 WHEN W-VDEFINE-RC 090800 DISPLAY 'ISPF SERVICE: VDEFINE' 090900 WHEN W-VDELETE-RC 091000 DISPLAY 'ISPF SERVICE: VDELETE' 091100 WHEN W-LIBDEF-RC 091200 DISPLAY 'ISPF SERVICE: LIBDEF' 091300 WHEN W-CONTROL-RC 091400 DISPLAY 'ISPF SERVICE: CONTROL' 091500 WHEN W-FTOPEN-RC 091600 DISPLAY 'ISPF SERVICE: FTOPEN' 091700 WHEN W-FTINCL-RC 091800 DISPLAY 'ISPF SERVICE: FTINCL' 091900 WHEN W-FTCLOSE-RC 092000 DISPLAY 'ISPF SERVICE: FTCLOSE' 092100 WHEN W-VPUT-RC 092200 DISPLAY 'ISPF SERVICE: VPUT' 092300 END-EVALUATE 092400 DISPLAY 'ISPF CALL INSTANCE: ' A-ISPF-CALLS-EXECUTED 092500 DISPLAY 'ISPF RC: ' W-RETURN-CODE-SUFFIX 092600 PERFORM S4000-FINALIZATION 092700 END-IF. 092800 092900 S6000-EXIT. 093000 EXIT. ./ ADD NAME=YEARDAY 000100 10 FILLER PIC X(16) VALUE '1800366247251361'. 000200 10 FILLER PIC X(16) VALUE '1801477351362472'. 000300 10 FILLER PIC X(16) VALUE '1802511462473513'. 000400 10 FILLER PIC X(16) VALUE '1803622573514624'. 000500 10 FILLER PIC X(16) VALUE '1804734725736146'. 000600 10 FILLER PIC X(16) VALUE '1805255136147257'. 000700 10 FILLER PIC X(16) VALUE '1806366247251361'. 000800 10 FILLER PIC X(16) VALUE '1807477351362472'. 000900 10 FILLER PIC X(16) VALUE '1808512573514624'. 001000 10 FILLER PIC X(16) VALUE '1809733614625735'. 001100 10 FILLER PIC X(16) VALUE '1810144725736146'. 001200 10 FILLER PIC X(16) VALUE '1811255136147257'. 001300 10 FILLER PIC X(16) VALUE '1812367351362472'. 001400 10 FILLER PIC X(16) VALUE '1813511462473513'. 001500 10 FILLER PIC X(16) VALUE '1814622573514624'. 001600 10 FILLER PIC X(16) VALUE '1815733614625735'. 001700 10 FILLER PIC X(16) VALUE '1816145136147257'. 001800 10 FILLER PIC X(16) VALUE '1817366247251361'. 001900 10 FILLER PIC X(16) VALUE '1818477351362472'. 002000 10 FILLER PIC X(16) VALUE '1819511462473513'. 002100 10 FILLER PIC X(16) VALUE '1820623614625735'. 002200 10 FILLER PIC X(16) VALUE '1821144725736146'. 002300 10 FILLER PIC X(16) VALUE '1822255136147257'. 002400 10 FILLER PIC X(16) VALUE '1823366247251361'. 002500 10 FILLER PIC X(16) VALUE '1824471462473513'. 002600 10 FILLER PIC X(16) VALUE '1825622573514624'. 002700 10 FILLER PIC X(16) VALUE '1826733614625735'. 002800 10 FILLER PIC X(16) VALUE '1827144725736146'. 002900 10 FILLER PIC X(16) VALUE '1828256247251361'. 003000 10 FILLER PIC X(16) VALUE '1829477351362472'. 003100 10 FILLER PIC X(16) VALUE '1830511462473513'. 003200 10 FILLER PIC X(16) VALUE '1831622573514624'. 003300 10 FILLER PIC X(16) VALUE '1832734725736146'. 003400 10 FILLER PIC X(16) VALUE '1833255136147257'. 003500 10 FILLER PIC X(16) VALUE '1834366247251361'. 003600 10 FILLER PIC X(16) VALUE '1835477351362472'. 003700 10 FILLER PIC X(16) VALUE '1836512573514624'. 003800 10 FILLER PIC X(16) VALUE '1837733614625735'. 003900 10 FILLER PIC X(16) VALUE '1838144725736146'. 004000 10 FILLER PIC X(16) VALUE '1839255136147257'. 004100 10 FILLER PIC X(16) VALUE '1840367351362472'. 004200 10 FILLER PIC X(16) VALUE '1841511462473513'. 004300 10 FILLER PIC X(16) VALUE '1842622573514624'. 004400 10 FILLER PIC X(16) VALUE '1843733614625735'. 004500 10 FILLER PIC X(16) VALUE '1844145136147257'. 004600 10 FILLER PIC X(16) VALUE '1845366247251361'. 004700 10 FILLER PIC X(16) VALUE '1846477351362472'. 004800 10 FILLER PIC X(16) VALUE '1847511462473513'. 004900 10 FILLER PIC X(16) VALUE '1848623614625735'. 005000 10 FILLER PIC X(16) VALUE '1849144725736146'. 005100 10 FILLER PIC X(16) VALUE '1850255136147257'. 005200 10 FILLER PIC X(16) VALUE '1851366247251361'. 005300 10 FILLER PIC X(16) VALUE '1852471462473513'. 005400 10 FILLER PIC X(16) VALUE '1853622573514624'. 005500 10 FILLER PIC X(16) VALUE '1854733614625735'. 005600 10 FILLER PIC X(16) VALUE '1855144725736146'. 005700 10 FILLER PIC X(16) VALUE '1856256247251361'. 005800 10 FILLER PIC X(16) VALUE '1857477351362472'. 005900 10 FILLER PIC X(16) VALUE '1858511462473513'. 006000 10 FILLER PIC X(16) VALUE '1859622573514624'. 006100 10 FILLER PIC X(16) VALUE '1860734725736146'. 006200 10 FILLER PIC X(16) VALUE '1861255136147257'. 006300 10 FILLER PIC X(16) VALUE '1862366247251361'. 006400 10 FILLER PIC X(16) VALUE '1863477351362472'. 006500 10 FILLER PIC X(16) VALUE '1864512573514624'. 006600 10 FILLER PIC X(16) VALUE '1865733614625735'. 006700 10 FILLER PIC X(16) VALUE '1866144725736146'. 006800 10 FILLER PIC X(16) VALUE '1867255136147257'. 006900 10 FILLER PIC X(16) VALUE '1868367351362472'. 007000 10 FILLER PIC X(16) VALUE '1869511462473513'. 007100 10 FILLER PIC X(16) VALUE '1870622573514624'. 007200 10 FILLER PIC X(16) VALUE '1871733614625735'. 007300 10 FILLER PIC X(16) VALUE '1872145136147257'. 007400 10 FILLER PIC X(16) VALUE '1873366247251361'. 007500 10 FILLER PIC X(16) VALUE '1874477351362472'. 007600 10 FILLER PIC X(16) VALUE '1875511462473513'. 007700 10 FILLER PIC X(16) VALUE '1876623614625735'. 007800 10 FILLER PIC X(16) VALUE '1877144725736146'. 007900 10 FILLER PIC X(16) VALUE '1878255136147257'. 008000 10 FILLER PIC X(16) VALUE '1879366247251361'. 008100 10 FILLER PIC X(16) VALUE '1880471462473513'. 008200 10 FILLER PIC X(16) VALUE '1881622573514624'. 008300 10 FILLER PIC X(16) VALUE '1882733614625735'. 008400 10 FILLER PIC X(16) VALUE '1883144725736146'. 008500 10 FILLER PIC X(16) VALUE '1884256247251361'. 008600 10 FILLER PIC X(16) VALUE '1885477351362472'. 008700 10 FILLER PIC X(16) VALUE '1886511462473513'. 008800 10 FILLER PIC X(16) VALUE '1887622573514624'. 008900 10 FILLER PIC X(16) VALUE '1888734725736146'. 009000 10 FILLER PIC X(16) VALUE '1889255136147257'. 009100 10 FILLER PIC X(16) VALUE '1890366247251361'. 009200 10 FILLER PIC X(16) VALUE '1891477351362472'. 009300 10 FILLER PIC X(16) VALUE '1892512573514624'. 009400 10 FILLER PIC X(16) VALUE '1893733614625735'. 009500 10 FILLER PIC X(16) VALUE '1894144725736146'. 009600 10 FILLER PIC X(16) VALUE '1895255136147257'. 009700 10 FILLER PIC X(16) VALUE '1896367351362472'. 009800 10 FILLER PIC X(16) VALUE '1897511462473513'. 009900 10 FILLER PIC X(16) VALUE '1898622573514624'. 010000 10 FILLER PIC X(16) VALUE '1899733614625735'. 010100 10 FILLER PIC X(16) VALUE '1900144725736146'. 010200 10 FILLER PIC X(16) VALUE '1901255136147257'. 010300 10 FILLER PIC X(16) VALUE '1902366247251361'. 010400 10 FILLER PIC X(16) VALUE '1903477351362472'. 010500 10 FILLER PIC X(16) VALUE '1904512573514624'. 010600 10 FILLER PIC X(16) VALUE '1905733614625735'. 010700 10 FILLER PIC X(16) VALUE '1906144725736146'. 010800 10 FILLER PIC X(16) VALUE '1907255136147257'. 010900 10 FILLER PIC X(16) VALUE '1908367351362472'. 011000 10 FILLER PIC X(16) VALUE '1909511462473513'. 011100 10 FILLER PIC X(16) VALUE '1910622573514624'. 011200 10 FILLER PIC X(16) VALUE '1911733614625735'. 011300 10 FILLER PIC X(16) VALUE '1912145136147257'. 011400 10 FILLER PIC X(16) VALUE '1913366247251361'. 011500 10 FILLER PIC X(16) VALUE '1914477351362472'. 011600 10 FILLER PIC X(16) VALUE '1915511462473513'. 011700 10 FILLER PIC X(16) VALUE '1916623614625735'. 011800 10 FILLER PIC X(16) VALUE '1917144725736146'. 011900 10 FILLER PIC X(16) VALUE '1918255136147257'. 012000 10 FILLER PIC X(16) VALUE '1919366247251361'. 012100 10 FILLER PIC X(16) VALUE '1920471462473513'. 012200 10 FILLER PIC X(16) VALUE '1921622573514624'. 012300 10 FILLER PIC X(16) VALUE '1922733614625735'. 012400 10 FILLER PIC X(16) VALUE '1923144725736146'. 012500 10 FILLER PIC X(16) VALUE '1924256247251361'. 012600 10 FILLER PIC X(16) VALUE '1925477351362472'. 012700 10 FILLER PIC X(16) VALUE '1926511462473513'. 012800 10 FILLER PIC X(16) VALUE '1927622573514624'. 012900 10 FILLER PIC X(16) VALUE '1928734725736146'. 013000 10 FILLER PIC X(16) VALUE '1929255136147257'. 013100 10 FILLER PIC X(16) VALUE '1930366247251361'. 013200 10 FILLER PIC X(16) VALUE '1931477351362472'. 013300 10 FILLER PIC X(16) VALUE '1932512573514624'. 013400 10 FILLER PIC X(16) VALUE '1933733614625735'. 013500 10 FILLER PIC X(16) VALUE '1934144725736146'. 013600 10 FILLER PIC X(16) VALUE '1935255136147257'. 013700 10 FILLER PIC X(16) VALUE '1936367351362472'. 013800 10 FILLER PIC X(16) VALUE '1937511462473513'. 013900 10 FILLER PIC X(16) VALUE '1938622573514624'. 014000 10 FILLER PIC X(16) VALUE '1939733614625735'. 014100 10 FILLER PIC X(16) VALUE '1940145136147257'. 014200 10 FILLER PIC X(16) VALUE '1941366247251361'. 014300 10 FILLER PIC X(16) VALUE '1942477351362472'. 014400 10 FILLER PIC X(16) VALUE '1943511462473513'. 014500 10 FILLER PIC X(16) VALUE '1944623614625735'. 014600 10 FILLER PIC X(16) VALUE '1945144725736146'. 014700 10 FILLER PIC X(16) VALUE '1946255136147257'. 014800 10 FILLER PIC X(16) VALUE '1947366247251361'. 014900 10 FILLER PIC X(16) VALUE '1948471462473513'. 015000 10 FILLER PIC X(16) VALUE '1949622573514624'. 015100 10 FILLER PIC X(16) VALUE '1950733614625735'. 015200 10 FILLER PIC X(16) VALUE '1951144725736146'. 015300 10 FILLER PIC X(16) VALUE '1952256247251361'. 015400 10 FILLER PIC X(16) VALUE '1953477351362472'. 015500 10 FILLER PIC X(16) VALUE '1954511462473513'. 015600 10 FILLER PIC X(16) VALUE '1955622573514624'. 015700 10 FILLER PIC X(16) VALUE '1956734725736146'. 015800 10 FILLER PIC X(16) VALUE '1957255136147257'. 015900 10 FILLER PIC X(16) VALUE '1958366247251361'. 016000 10 FILLER PIC X(16) VALUE '1959477351362472'. 016100 10 FILLER PIC X(16) VALUE '1960512573514624'. 016200 10 FILLER PIC X(16) VALUE '1961733614625735'. 016300 10 FILLER PIC X(16) VALUE '1962144725736146'. 016400 10 FILLER PIC X(16) VALUE '1963255136147257'. 016500 10 FILLER PIC X(16) VALUE '1964367351362472'. 016600 10 FILLER PIC X(16) VALUE '1965511462473513'. 016700 10 FILLER PIC X(16) VALUE '1966622573514624'. 016800 10 FILLER PIC X(16) VALUE '1967733614625735'. 016900 10 FILLER PIC X(16) VALUE '1968145136147257'. 017000 10 FILLER PIC X(16) VALUE '1969366247251361'. 017100 10 FILLER PIC X(16) VALUE '1970477351362472'. 017200 10 FILLER PIC X(16) VALUE '1971511462473513'. 017300 10 FILLER PIC X(16) VALUE '1972623614625735'. 017400 10 FILLER PIC X(16) VALUE '1973144725736146'. 017500 10 FILLER PIC X(16) VALUE '1974255136147257'. 017600 10 FILLER PIC X(16) VALUE '1975366247251361'. 017700 10 FILLER PIC X(16) VALUE '1976471462473513'. 017800 10 FILLER PIC X(16) VALUE '1977622573514624'. 017900 10 FILLER PIC X(16) VALUE '1978733614625735'. 018000 10 FILLER PIC X(16) VALUE '1979144725736146'. 018100 10 FILLER PIC X(16) VALUE '1980256247251361'. 018200 10 FILLER PIC X(16) VALUE '1981477351362472'. 018300 10 FILLER PIC X(16) VALUE '1982511462473513'. 018400 10 FILLER PIC X(16) VALUE '1983622573514624'. 018500 10 FILLER PIC X(16) VALUE '1984734725736146'. 018600 10 FILLER PIC X(16) VALUE '1985255136147257'. 018700 10 FILLER PIC X(16) VALUE '1986366247251361'. 018800 10 FILLER PIC X(16) VALUE '1987477351362472'. 018900 10 FILLER PIC X(16) VALUE '1988512573514624'. 019000 10 FILLER PIC X(16) VALUE '1989733614625735'. 019100 10 FILLER PIC X(16) VALUE '1990144725736146'. 019200 10 FILLER PIC X(16) VALUE '1991255136147257'. 019300 10 FILLER PIC X(16) VALUE '1992367351362472'. 019400 10 FILLER PIC X(16) VALUE '1993511462473513'. 019500 10 FILLER PIC X(16) VALUE '1994622573514624'. 019600 10 FILLER PIC X(16) VALUE '1995733614625735'. 019700 10 FILLER PIC X(16) VALUE '1996145136147257'. 019800 10 FILLER PIC X(16) VALUE '1997366247251361'. 019900 10 FILLER PIC X(16) VALUE '1998477351362472'. 020000 10 FILLER PIC X(16) VALUE '1999511462473513'. 020100 10 FILLER PIC X(16) VALUE '2000623614625735'. 020200 10 FILLER PIC X(16) VALUE '2001144725736146'. 020300 10 FILLER PIC X(16) VALUE '2002255136147257'. 020400 10 FILLER PIC X(16) VALUE '2003366247251361'. 020500 10 FILLER PIC X(16) VALUE '2004471462473513'. 020600 10 FILLER PIC X(16) VALUE '2005622573514624'. 020700 10 FILLER PIC X(16) VALUE '2006733614625735'. 020800 10 FILLER PIC X(16) VALUE '2007144725736146'. 020900 10 FILLER PIC X(16) VALUE '2008256247251361'. 021000 10 FILLER PIC X(16) VALUE '2009477351362472'. 021100 10 FILLER PIC X(16) VALUE '2010511462473513'. 021200 10 FILLER PIC X(16) VALUE '2011622573514624'. 021300 10 FILLER PIC X(16) VALUE '2012734725736146'. 021400 10 FILLER PIC X(16) VALUE '2013255136147257'. 021500 10 FILLER PIC X(16) VALUE '2014366247251361'. 021600 10 FILLER PIC X(16) VALUE '2015477351362472'. 021700 10 FILLER PIC X(16) VALUE '2016512573514624'. 021800 10 FILLER PIC X(16) VALUE '2017733614625735'. 021900 10 FILLER PIC X(16) VALUE '2018144725736146'. 022000 10 FILLER PIC X(16) VALUE '2019255136147257'. 022100 10 FILLER PIC X(16) VALUE '2020367351362472'. 022200 10 FILLER PIC X(16) VALUE '2021511462473513'. 022300 10 FILLER PIC X(16) VALUE '2022622573514624'. 022400 10 FILLER PIC X(16) VALUE '2023733614625735'. 022500 10 FILLER PIC X(16) VALUE '2024145136147257'. 022600 10 FILLER PIC X(16) VALUE '2025366247251361'. 022700 10 FILLER PIC X(16) VALUE '2026477351362472'. 022800 10 FILLER PIC X(16) VALUE '2027511462473513'. 022900 10 FILLER PIC X(16) VALUE '2028623614625735'. 023000 10 FILLER PIC X(16) VALUE '2029144725736146'. 023100 10 FILLER PIC X(16) VALUE '2030255136147257'. 023200 10 FILLER PIC X(16) VALUE '2031366247251361'. 023300 10 FILLER PIC X(16) VALUE '2032471462473513'. 023400 10 FILLER PIC X(16) VALUE '2033622573514624'. 023500 10 FILLER PIC X(16) VALUE '2034733614625735'. 023600 10 FILLER PIC X(16) VALUE '2035144725736146'. 023700 10 FILLER PIC X(16) VALUE '2036256247251361'. 023800 10 FILLER PIC X(16) VALUE '2037477351362472'. 023900 10 FILLER PIC X(16) VALUE '2038511462473513'. 024000 10 FILLER PIC X(16) VALUE '2039622573514624'. 024100 10 FILLER PIC X(16) VALUE '2040734725736146'. 024200 10 FILLER PIC X(16) VALUE '2041255136147257'. 024300 10 FILLER PIC X(16) VALUE '2042366247251361'. 024400 10 FILLER PIC X(16) VALUE '2043477351362472'. 024500 10 FILLER PIC X(16) VALUE '2044512573514624'. 024600 10 FILLER PIC X(16) VALUE '2045733614625735'. 024700 10 FILLER PIC X(16) VALUE '2046144725736146'. 024800 10 FILLER PIC X(16) VALUE '2047255136147257'. 024900 10 FILLER PIC X(16) VALUE '2048367351362472'. 025000 10 FILLER PIC X(16) VALUE '2049511462473513'. 025100 10 FILLER PIC X(16) VALUE '2050622573514624'. 025200 10 FILLER PIC X(16) VALUE '2051733614625735'. 025300 10 FILLER PIC X(16) VALUE '2052145136147257'. 025400 10 FILLER PIC X(16) VALUE '2053366247251361'. 025500 10 FILLER PIC X(16) VALUE '2054477351362472'. 025600 10 FILLER PIC X(16) VALUE '2055511462473513'. 025700 10 FILLER PIC X(16) VALUE '2056623614625735'. 025800 10 FILLER PIC X(16) VALUE '2057144725736146'. 025900 10 FILLER PIC X(16) VALUE '2058255136147257'. 026000 10 FILLER PIC X(16) VALUE '2059366247251361'. 026100 10 FILLER PIC X(16) VALUE '2060471462473513'. 026200 10 FILLER PIC X(16) VALUE '2061622573514624'. 026300 10 FILLER PIC X(16) VALUE '2062733614625735'. 026400 10 FILLER PIC X(16) VALUE '2063144725736146'. 026500 10 FILLER PIC X(16) VALUE '2064256247251361'. 026600 10 FILLER PIC X(16) VALUE '2065477351362472'. 026700 10 FILLER PIC X(16) VALUE '2066511462473513'. 026800 10 FILLER PIC X(16) VALUE '2067622573514624'. 026900 10 FILLER PIC X(16) VALUE '2068734725736146'. 027000 10 FILLER PIC X(16) VALUE '2069255136147257'. 027100 10 FILLER PIC X(16) VALUE '2070366247251361'. 027200 10 FILLER PIC X(16) VALUE '2071477351362472'. 027300 10 FILLER PIC X(16) VALUE '2072512573514624'. 027400 10 FILLER PIC X(16) VALUE '2073733614625735'. 027500 10 FILLER PIC X(16) VALUE '2074144725736146'. 027600 10 FILLER PIC X(16) VALUE '2075255136147257'. 027700 10 FILLER PIC X(16) VALUE '2076367351362472'. 027800 10 FILLER PIC X(16) VALUE '2077511462473513'. 027900 10 FILLER PIC X(16) VALUE '2078622573514624'. 028000 10 FILLER PIC X(16) VALUE '2079733614625735'. 028100 10 FILLER PIC X(16) VALUE '2080145136147257'. 028200 10 FILLER PIC X(16) VALUE '2081366247251361'. 028300 10 FILLER PIC X(16) VALUE '2082477351362472'. 028400 10 FILLER PIC X(16) VALUE '2083511462473513'. 028500 10 FILLER PIC X(16) VALUE '2084623614625735'. 028600 10 FILLER PIC X(16) VALUE '2085144725736146'. 028700 10 FILLER PIC X(16) VALUE '2086255136147257'. 028800 10 FILLER PIC X(16) VALUE '2087366247251361'. 028900 10 FILLER PIC X(16) VALUE '2088471462473513'. 029000 10 FILLER PIC X(16) VALUE '2089622573514624'. 029100 10 FILLER PIC X(16) VALUE '2090733614625735'. 029200 10 FILLER PIC X(16) VALUE '2091144725736146'. 029300 10 FILLER PIC X(16) VALUE '2092256247251361'. 029400 10 FILLER PIC X(16) VALUE '2093477351362472'. 029500 10 FILLER PIC X(16) VALUE '2094511462473513'. 029600 10 FILLER PIC X(16) VALUE '2095622573514624'. 029700 10 FILLER PIC X(16) VALUE '2096734725736146'. 029800 10 FILLER PIC X(16) VALUE '2097255136147257'. 029900 10 FILLER PIC X(16) VALUE '2098366247251361'. 030000 10 FILLER PIC X(16) VALUE '2099477351362472'. 030100 10 FILLER PIC X(16) VALUE '2100511462473513'. 030200 10 FILLER PIC X(16) VALUE '2101622573514624'. 030300 10 FILLER PIC X(16) VALUE '2102733614625735'. 030400 10 FILLER PIC X(16) VALUE '2103144725736146'. 030500 10 FILLER PIC X(16) VALUE '2104256247251361'. 030600 10 FILLER PIC X(16) VALUE '2105477351362472'. 030700 10 FILLER PIC X(16) VALUE '2106511462473513'. 030800 10 FILLER PIC X(16) VALUE '2107622573514624'. 030900 10 FILLER PIC X(16) VALUE '2108734725736146'. 031000 10 FILLER PIC X(16) VALUE '2109255136147257'. 031100 10 FILLER PIC X(16) VALUE '2110366247251361'. 031200 10 FILLER PIC X(16) VALUE '2111477351362472'. 031300 10 FILLER PIC X(16) VALUE '2112512573514624'. 031400 10 FILLER PIC X(16) VALUE '2113733614625735'. 031500 10 FILLER PIC X(16) VALUE '2114144725736146'. 031600 10 FILLER PIC X(16) VALUE '2115255136147257'. 031700 10 FILLER PIC X(16) VALUE '2116367351362472'. 031800 10 FILLER PIC X(16) VALUE '2117511462473513'. 031900 10 FILLER PIC X(16) VALUE '2118622573514624'. 032000 10 FILLER PIC X(16) VALUE '2119733614625735'. 032100 10 FILLER PIC X(16) VALUE '2120145136147257'. 032200 10 FILLER PIC X(16) VALUE '2121366247251361'. 032300 10 FILLER PIC X(16) VALUE '2122477351362472'. 032400 10 FILLER PIC X(16) VALUE '2123511462473513'. 032500 10 FILLER PIC X(16) VALUE '2124623614625735'. 032600 10 FILLER PIC X(16) VALUE '2125144725736146'. 032700 10 FILLER PIC X(16) VALUE '2126255136147257'. 032800 10 FILLER PIC X(16) VALUE '2127366247251361'. 032900 10 FILLER PIC X(16) VALUE '2128471462473513'. 033000 10 FILLER PIC X(16) VALUE '2129622573514624'. 033100 10 FILLER PIC X(16) VALUE '2130733614625735'. 033200 10 FILLER PIC X(16) VALUE '2131144725736146'. 033300 10 FILLER PIC X(16) VALUE '2132256247251361'. 033400 10 FILLER PIC X(16) VALUE '2133477351362472'. 033500 10 FILLER PIC X(16) VALUE '2134511462473513'. 033600 10 FILLER PIC X(16) VALUE '2135622573514624'. 033700 10 FILLER PIC X(16) VALUE '2136734725736146'. 033800 10 FILLER PIC X(16) VALUE '2137255136147257'. 033900 10 FILLER PIC X(16) VALUE '2138366247251361'. 034000 10 FILLER PIC X(16) VALUE '2139477351362472'. 034100 10 FILLER PIC X(16) VALUE '2140512573514624'. 034200 10 FILLER PIC X(16) VALUE '2141733614625735'. 034300 10 FILLER PIC X(16) VALUE '2142144725736146'. 034400 10 FILLER PIC X(16) VALUE '2143255136147257'. 034500 10 FILLER PIC X(16) VALUE '2144367351362472'. 034600 10 FILLER PIC X(16) VALUE '2145511462473513'. 034700 10 FILLER PIC X(16) VALUE '2146622573514624'. 034800 10 FILLER PIC X(16) VALUE '2147733614625735'. 034900 10 FILLER PIC X(16) VALUE '2148145136147257'. 035000 10 FILLER PIC X(16) VALUE '2149366247251361'. 035100 10 FILLER PIC X(16) VALUE '2150477351362472'. 035200 10 FILLER PIC X(16) VALUE '2151511462473513'. 035300 10 FILLER PIC X(16) VALUE '2152623614625735'. 035400 10 FILLER PIC X(16) VALUE '2153144725736146'. 035500 10 FILLER PIC X(16) VALUE '2154255136147257'. 035600 10 FILLER PIC X(16) VALUE '2155366247251361'. 035700 10 FILLER PIC X(16) VALUE '2156471462473513'. 035800 10 FILLER PIC X(16) VALUE '2157622573514624'. 035900 10 FILLER PIC X(16) VALUE '2158733614625735'. 036000 10 FILLER PIC X(16) VALUE '2159144725736146'. 036100 10 FILLER PIC X(16) VALUE '2160256247251361'. 036200 10 FILLER PIC X(16) VALUE '2161477351362472'. 036300 10 FILLER PIC X(16) VALUE '2162511462473513'. 036400 10 FILLER PIC X(16) VALUE '2163622573514624'. 036500 10 FILLER PIC X(16) VALUE '2164734725736146'. 036600 10 FILLER PIC X(16) VALUE '2165255136147257'. 036700 10 FILLER PIC X(16) VALUE '2166366247251361'. 036800 10 FILLER PIC X(16) VALUE '2167477351362472'. 036900 10 FILLER PIC X(16) VALUE '2168512573514624'. 037000 10 FILLER PIC X(16) VALUE '2169733614625735'. 037100 10 FILLER PIC X(16) VALUE '2170144725736146'. 037200 10 FILLER PIC X(16) VALUE '2171255136147257'. 037300 10 FILLER PIC X(16) VALUE '2172367351362472'. 037400 10 FILLER PIC X(16) VALUE '2173511462473513'. 037500 10 FILLER PIC X(16) VALUE '2174622573514624'. 037600 10 FILLER PIC X(16) VALUE '2175733614625735'. 037700 10 FILLER PIC X(16) VALUE '2176145136147257'. 037800 10 FILLER PIC X(16) VALUE '2177366247251361'. 037900 10 FILLER PIC X(16) VALUE '2178477351362472'. 038000 10 FILLER PIC X(16) VALUE '2179511462473513'. 038100 10 FILLER PIC X(16) VALUE '2180623614625735'. 038200 10 FILLER PIC X(16) VALUE '2181144725736146'. 038300 10 FILLER PIC X(16) VALUE '2182255136147257'. 038400 10 FILLER PIC X(16) VALUE '2183366247251361'. 038500 10 FILLER PIC X(16) VALUE '2184471462473513'. 038600 10 FILLER PIC X(16) VALUE '2185622573514624'. 038700 10 FILLER PIC X(16) VALUE '2186733614625735'. 038800 10 FILLER PIC X(16) VALUE '2187144725736146'. 038900 10 FILLER PIC X(16) VALUE '2188256247251361'. 039000 10 FILLER PIC X(16) VALUE '2189477351362472'. 039100 10 FILLER PIC X(16) VALUE '2190511462473513'. 039200 10 FILLER PIC X(16) VALUE '2191622573514624'. 039300 10 FILLER PIC X(16) VALUE '2192734725736146'. 039400 10 FILLER PIC X(16) VALUE '2193255136147257'. 039500 10 FILLER PIC X(16) VALUE '2194366247251361'. 039600 10 FILLER PIC X(16) VALUE '2195477351362472'. 039700 10 FILLER PIC X(16) VALUE '2196512573514624'. 039800 10 FILLER PIC X(16) VALUE '2197733614625735'. 039900 10 FILLER PIC X(16) VALUE '2198144725736146'. 040000 10 FILLER PIC X(16) VALUE '2199255136147257'. 040100 10 FILLER PIC X(16) VALUE '2200366247251361'.