OPTIONS Compiler Defaults... PRINT OFF 00030000 COPY IGYCOPT 00031000 PRINT ON 00033000 PUNCH ' CATALOG IGYCDOPT.OBJ REPLACE=YES' 00034000 IGYCDOPT CSECT 00035000 IGYCDOPT AMODE ANY 00035000 IGYCDOPT RMODE ANY 00035000 * /* DEFAULT*/ IGYCOPT ADV=NO, /* YES */ X00038000 BUF=32760, /* 4K */ /* THIS IS DATA MGT MAX*/ X00038000 DATA=24, /* 31 */ X00038000 This was not necessary, but we did not know this when we began. FLAG=(I,I), /* I */ X00038000 This causes "embedded" error messages, important for Printer Exit LANGUAGE=EN, /* UE */ X00038000 LIB=YES, /* NO */ X00038000 LITCHAR=APOST, /* QUOTE */ X00038000 For compatability with existing programs. MAP=YES, /* NO */ *** X00038000 NAME=ALIAS, /* NO */ CBL NONAME TO TURN OFF X00038000 Forces load module name to match PROGRAM-ID. NUM=YES, /* NO */ X00038000 NUMCLS=ALT, /* PRIM */ X00038000 NUMPROC=MIG, /* NOPFD */ X00038000 OUTDD=SYSOUA, /* SYSOUT*/ *** X00038000 TEA standard for DISPLAY output. Historical when SORT did SYSOUT. RMODE=24, /* AUTO */ X00038000 SSRANGE=YES, /* NO */ X00038000 This also caught a LOT of pre-existing errors, with minimal overhead. TEST=(NONE,SYM), /* NO */ X00038000 SYN is the biggest deal, makes for very easy to read formatted dumps. I really can't stress how helpful this is, and it has NO execution overhead! Load module is only slightly larger, but this single option has saved more Debugging time than anything else! TRUNC=BIN, /* STD */ X00038000 XREFOPT=SHORT, /* NO */ X00038000 ZWB=YES /* YES */ THIS IS LAST OPTION---- 00038000 END IGYCDOPT ******************************* COBOL Batch Program Defaults CEEUOPT CSECT 00110000 CEEUOPT AMODE ANY 00120000 CEEUOPT RMODE ANY 00130000 CEEXOPT RTEREUS=(ON),ABTERMENC=(ABEND) 00140000 RTEREUS required to not load new copy of program for Dynamic Loads. ABEND option was for compatability, we expect bad programs to ABEND, and JCL is set-up for this. END 00510000 PRINT OFF 00030000 *************************************** Compile Compiler Print Exit
PrintExitCpl DSC=RYDER CVX COMPILE //************************CBL DATA(31),RMODE(ANY),NORENT ******** //** COMPILE PROD VERSION (SEE CVXTEST FOR TEST VERSION CHANGES) //COBINS EXEC TECOBCPL,LIB=SYSLIB, // LNKOPT='MAP,LET,LIST,REUS,RMODE(24),AMODE(ANY)', // PARM.COBOL=(RMODE(24),DATA(31),OUTDD(SYSOUA),MAP) //COBOL.SOURCE DD DSN=USERTEA.SYS3.JSRSYS(COBV9PRT),DISP=SHR These were options we used for compiler exit, DATA(31) was required.
COBV9PRT -ADD COBV9PRT,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC COBOL-LE COMPILER PRINTER EXIT -PGMR STEVE RYDER, JSR SYSTEMS -LANG COB 001000 IDENTIFICATION DIVISION. 001100 PROGRAM-ID. COBV9PRT. 001200*AUTHOR. STEVE RYDER JSR SYSTEMS. 001300 DATE-WRITTEN. JANUARY 27, 1998. 001400 DATE-COMPILED. 001410*MODIFICATION HISTORY. 001420*--- 001430*--- 001440*--- Debugging suggestions: Be liberal with DISPLAY statements, anticipate errors. When it is running, comment out. This can be very helpful when later errors occurs, as you can remove comments, and re-run. 001450*--- 001460*--- 001470*--- 001480*---1998/11/30 MOVE EXIT-PAGE LEFT TWO BYTES. 001490*--- These are options I chose to support. The standard print format is very VERBOSE, just the options takes over a page. Also, since the DMAP and XREF are "folded", printing them is redundant. "ERR" is very userful, and works in conjunction with the (I,I) option. 001500*REMARKS. 001600* COMPILER PRINT EXIT FOR COBOL/VSE COMPILER. 001610* ALL = PRINT ALL LINES, SAME AS NOT USING EXIT. 001615* NOP = NO PRINT AT ALL. 001620* ERR = PRINT LINE BEFORE AND AFTER ANY ERROR LINES. 001630* *** = (DEFAULT), PRINT JUST PROGRAM PART. SINCE DMAP AND XREF 001640* DATA IS LISTED WITH PROGRAM, SUPPRESS. 001650*----------------------------------------------------------------- 001700* 001800 ENVIRONMENT DIVISION. 001900 CONFIGURATION SECTION. 002000 SPECIAL-NAMES. 002100 C01 IS TOP-OF-FORM. 002200 INPUT-OUTPUT SECTION. 002300 FILE-CONTROL. 002400 SELECT PRINT-FILE 002500* ASSIGN TO SYS008-PRINT. 002510 FILE STATUS IS PRINT-STATUS 002520 ASSIGN TO UT-S-PRINT. 002600 DATA DIVISION. 002700 FILE SECTION. 002800 FD PRINT-FILE 002900 LABEL RECORDS ARE STANDARD 003000 RECORDING MODE IS F 003100 RECORD CONTAINS 133 CHARACTERS 003200 BLOCK CONTAINS 1 RECORDS 003300 DATA RECORD IS PRINT-REC. 003400 01 PRINT-REC. 003500 05 PRINT-CC. 003600 10 FILLER PIC X(01). 003700 05 PRINT-LINE PIC X(132). 003800 WORKING-STORAGE SECTION. 003900 01 MY-PROGRAM-ID PIC X(08) VALUE 'COBV9PRT'. 004000 01 SYSSNAP-ID PIC X(08) VALUE 'SYSSNAP '. 004100 01 SYSSNAP-4 PIC S9(4) BINARY VALUE +4. 004200 01 SYSSNAP-100 PIC S9(4) BINARY VALUE +100. 004210 01 PRINT-STATUS PIC X(02) VALUE '00'. 004220 01 ENTRY-COUNT PIC 9(06) VALUE ZERO. 004300 01 EXIT-OPEN-PARM. 004400 05 OPEN-STRING-LENGTH PIC S9(4) COMP. 004500 05 OPEN-STRING PIC X(03). 004600* CAN BE UP TO 64 BYTES, WE LOOK ONLY AT FIRST 3. 004700 01 SAVE-LINES VALUE SPACES. 004800 05 SAVE-LINE PIC X(133) OCCURS 5 TIMES. 004900 01 STATUS-FLAGS. 005000 05 PRINT-NEXT PIC S9(04) BINARY VALUE ZERO. 005100 05 PRINT-FLAG PIC X(01) VALUE '0'. 005200 88 PRINT-YES VALUE '1' '3'. Here are required parameters for exit. 005300 LINKAGE SECTION. 005400 01 EXIT-TYPE PIC S9(4) COMP. 005500 01 EXIT-OPERATION PIC S9(4) COMP. 005600 01 EXIT-RETURNCODE PIC S9(5) COMP. 005700 01 EXIT-WORKAREA. 005800 05 INPUT-SLOT PIC S9(5) COMP. 005900 05 LIBEXIT-SLOT PIC S9(5) COMP. 006000 05 SYSLST-SLOT PIC S9(5) COMP. 006100 05 RESERVED-SLOT PIC S9(5) COMP. 006200 01 EXIT-DATALENGTH PIC S9(5) COMP. 006300 01 EXIT-DATAAREA. 006400 05 EXIT-CC PIC X(01). 006500 05 EXIT-1-8. 006600 10 EXIT-1-2 PIC X(02). 006700 10 FILLER PIC X(06). 006800*****05 FILLER PIC X(105).1998/11/30 006900*****05 EXIT-PAGE PIC X(18). MOVE PAGE LEFT 2 BYTES 006910 05 FILLER PIC X(103). 006920 05 EXIT-PAGE PIC X(08). 006930 05 FILLER PIC X(12). 007000 01 EXIT-LIBRARY PIC X(08). 007100 01 EXIT-SYSTEXT PIC X(08). 007200 01 EXIT-CBLLIBRARY PIC X(30). 007300 01 EXIT-CBLTEXT PIC X(30). 007500 PROCEDURE DIVISION USING 007600 EXIT-TYPE 007700 EXIT-OPERATION 007800 EXIT-RETURNCODE 007900 EXIT-WORKAREA 008000 EXIT-DATALENGTH 008100 EXIT-DATAAREA 008200 EXIT-LIBRARY 008300 EXIT-SYSTEXT 008400 EXIT-CBLLIBRARY 008500 EXIT-CBLTEXT. 008600 0000-COBV9PRT. 008700* DISPLAY 'COBV9PRT--ENTERING TYPE=' EXIT-TYPE 008800* ' OPRN=' EXIT-OPERATION 008810 ADD 1 TO ENTRY-COUNT 008900 IF EXIT-TYPE = 3 009000 PERFORM 1000-HANDLE-PRINT 009100 ELSE 009200 DISPLAY 'COBV9PRT--INVALID EXIT-TYPE=' EXIT-TYPE 009300 MOVE 16 TO EXIT-RETURNCODE 009400 . 009500 GOBACK 009600 . Go To COBV0ERR 009700 1000-HANDLE-PRINT. 009800 IF EXIT-OPERATION = 0 009900* DISPLAY 'COBV9PRT--OPENING OUTPUT' 010000* CALL SYSSNAP-ID USING SYSSNAP-100 EXIT-DATAAREA 010100 MOVE EXIT-DATAAREA TO EXIT-OPEN-PARM 010200 IF OPEN-STRING-LENGTH < 3 010300 MOVE '***' TO OPEN-STRING 010400 END-IF 010500 OPEN OUTPUT PRINT-FILE 010510 IF PRINT-STATUS NOT = '00' 010520 DISPLAY 'COBV9PRT--OPEN STATUS=' PRINT-STATUS 010530 END-IF 010600 MOVE 00 TO EXIT-RETURNCODE 010700 ELSE 010800 IF EXIT-OPERATION = 1 010900* DISPLAY 'COBV9PRT--CLOSING PRINT' 011000 CLOSE PRINT-FILE 011100 MOVE 00 TO EXIT-RETURNCODE 011200 ELSE 011300 IF EXIT-OPERATION = 3 011410* DISPLAY 'COBV9PRT--PRINT FLAG: ' PRINT-FLAG ':' 011420* EXIT-CC ':' EXIT-1-8 ':' EXIT-PAGE '!' 011430* ENTRY-COUNT 011500 PERFORM 9100-PRINT 011600 ELSE 011700 DISPLAY 'COBV9PRT--INVALID EXIT-OPRN=' EXIT-OPERATION 011800 . 011900 9100-PRINT. 012000 MOVE 0 TO EXIT-RETURNCODE 012100* CALL SYSSNAP-ID USING SYSSNAP-100 EXIT-DATAAREA 012200 IF OPEN-STRING = 'NOP' 012300 NEXT SENTENCE 012400 ELSE 012500 IF OPEN-STRING = 'ALL' 012600 PERFORM 9150-PRINT-AS-IS 012700 ELSE 012800 IF OPEN-STRING = 'ERR' 012900 PERFORM 9120-CHECK-ERR 013000 ELSE 013100 PERFORM 9110-CHECK 013200 . 013300 9110-CHECK. 013400 IF PRINT-FLAG = '0' 013500* IF EXIT-1-8 = 'PP 5686-' 013510 IF EXIT-1-8 = 'PP 5648-' 013600* AND EXIT-PAGE = ' 2 ' 013610 AND EXIT-PAGE = ' 2 ' 013700 MOVE '1' TO PRINT-FLAG 013800 END-IF 013900 ELSE 014000 IF PRINT-FLAG = '1' 014100 IF EXIT-1-2 = '*/' 014200 MOVE '2' TO PRINT-FLAG 014300 END-IF 014400 ELSE 014500 IF PRINT-FLAG = '2' 014600 IF EXIT-1-8 = '* Statis' 014700*------------------------ABOVE MUST BE MIXED CASE!!!!!! 014800 MOVE '3' TO PRINT-FLAG 014900 END-IF 015000 . 015100 IF PRINT-YES 015200 PERFORM 9150-PRINT-AS-IS 015300 . 015400 9120-CHECK-ERR. 015500 IF PRINT-FLAG = '0' 015600* IF EXIT-1-8 = 'PP 5686-' 015610 IF EXIT-1-8 = 'PP 5648-' 015700* AND EXIT-PAGE = ' 2 ' 015710 AND EXIT-PAGE = ' 2 ' 015800 MOVE '1' TO PRINT-FLAG 015900 END-IF 016000 ELSE 016100 IF PRINT-FLAG = '1' 016200 IF EXIT-1-2 = '*/' 016300 MOVE '2' TO PRINT-FLAG 016400 END-IF 016500 . 016600 IF PRINT-YES 016700 IF EXIT-1-2 = SPACES 016710 AND PRINT-NEXT = ZERO 016800 MOVE SAVE-LINE (2) TO SAVE-LINE (1) 016900 MOVE SAVE-LINE (3) TO SAVE-LINE (2) 017000 MOVE SAVE-LINE (4) TO SAVE-LINE (3) 017100 MOVE SAVE-LINE (5) TO SAVE-LINE (4) 017200 MOVE EXIT-DATAAREA TO SAVE-LINE (5) 017300 ELSE 017400 IF EXIT-1-2 = '==' 017500 MOVE 3 TO PRINT-NEXT 017600 IF SAVE-LINE (1) NOT = SPACES 017700 WRITE PRINT-REC FROM SAVE-LINE (1) AFTER 1 017800 END-IF 017900 IF SAVE-LINE (2) NOT = SPACES 018000 WRITE PRINT-REC FROM SAVE-LINE (2) AFTER 1 018100 END-IF 018200 IF SAVE-LINE (3) NOT = SPACES 018300 WRITE PRINT-REC FROM SAVE-LINE (3) AFTER 1 018400 END-IF 018500 IF SAVE-LINE (4) NOT = SPACES 018600 WRITE PRINT-REC FROM SAVE-LINE (4) AFTER 1 018700 END-IF 018800 IF SAVE-LINE (1) NOT = SPACES 018900 WRITE PRINT-REC FROM SAVE-LINE (5) AFTER 1 019000 END-IF 019100 MOVE SPACES TO SAVE-LINES 019200 . 019300 IF PRINT-YES 019400 AND PRINT-NEXT > 0 019500 WRITE PRINT-REC FROM EXIT-DATAAREA AFTER 1 019600 SUBTRACT 1 FROM PRINT-NEXT 019700 . 019800 9150-PRINT-AS-IS. 019900 MOVE EXIT-DATAAREA TO PRINT-REC 020000 IF PRINT-CC = ' ' 020100 WRITE PRINT-REC AFTER 1 020200 ELSE 020300 IF PRINT-CC = '1' 020400 WRITE PRINT-REC AFTER TOP-OF-FORM 020500 ELSE 020600 IF PRINT-CC = '0' 020700 WRITE PRINT-REC AFTER 2 020800 ELSE 020900 IF PRINT-CC = '-' 021000 WRITE PRINT-REC AFTER 3 021100 ELSE 021200 WRITE PRINT-REC AFTER 1 021300 . 021400 END PROGRAM COBV9PRT. -END
COBV0ERR -ADD COBV0ERR,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC LIST POTENTIAL COBOL-LE ERRORS -PGMR STEVE RYDER, JSR SYSTEMS -LANG COB 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. COBV0ERR. 000300*AUTHOR. STEVE RYDER JSR SYSTEMS. 000400 DATE-WRITTEN. JULY 11, 1997. 000500 DATE-COMPILED. 000600*REMARKS. 000700* IDENTIFY POTENTIAL ERRORS, PRINT 3 LINES (BEFORE, #, AFTER) This found about 95% of actual things that needed to be changed, before the compile. Go to 1200-PROC-CHECKS. 000800* 000900 ENVIRONMENT DIVISION. 001000 INPUT-OUTPUT SECTION. 001100 FILE-CONTROL. 001200 SELECT SYSIPT-FILE 001300 ASSIGN TO SYS016-COBIPT. 001400 DATA DIVISION. 001500 FILE SECTION. 001600 FD SYSIPT-FILE 001700 LABEL RECORDS ARE STANDARD 001800 RECORDING MODE IS F 001900 RECORD CONTAINS 80 CHARACTERS 002000 BLOCK CONTAINS 1 RECORDS 002100 DATA RECORD IS SYSIPT-REC. 002200 01 SYSIPT-REC. 002300 05 SYSIPT-NUM. 002400 10 SYSIPT-CBL PIC X(05). 002500 10 FILLER PIC X(01). 002600 05 SYSIPT-COMMENT PIC X(01). 002700 05 SYSIPT-MARGIN-A PIC X(04). 002800 05 SYSIPT-MARGIN-B PIC X(61). 002900 05 FILLER PIC X(08). 003000 WORKING-STORAGE SECTION. 003100 01 MY-PROGRAM-ID PIC X(08) VALUE 'COBV0ERR'. 003200 01 PROC-STATUS PIC X(01) VALUE '0'. 003300 88 SYSIPT-PROC VALUE 'P'. 003400 01 SYSIPT-STATUS PIC X(01) VALUE '0'. 003500 88 SYSIPT-EOF VALUE '4'. 003600 01 SAVE-SYSIPT VALUE SPACES. 003700 05 FILLER PIC X(06). 003700 05 SAVE-SYSIPT-COMMENT PIC X(01). 003800 05 SAVE-SYSIPT-MARGIN-A PIC X(04). 003900 05 FILLER PIC X(69). 004000 01 I PIC S9(4) BINARY. 004100 01 TEXT-DATABASE-G. 004200 05 FILLER PIC X(01) VALUE QUOTE. 004300 05 FILLER PIC X(08) VALUE 'DATABASE'. 004400 05 FILLER PIC X(01) VALUE QUOTE. 004500 01 TEXT-DATABASE REDEFINES TEXT-DATABASE-G PIC X(10). 004600 01 TEXT-GDTCALL-G. 004700 05 FILLER PIC X(01) VALUE QUOTE. 004800 05 FILLER PIC X(07) VALUE 'GDTCALL'. 004900 05 FILLER PIC X(01) VALUE QUOTE. 005000 01 TEXT-GDTCALL REDEFINES TEXT-GDTCALL-G PIC X(09). 005100 01 TEXT-SETASOF-G. 005200 05 FILLER PIC X(01) VALUE QUOTE. 005300 05 FILLER PIC X(07) VALUE 'SETASOF'. 005400 05 FILLER PIC X(01) VALUE QUOTE. 005500 01 TEXT-SETASOF REDEFINES TEXT-SETASOF-G PIC X(09). 005600 01 TEXT-SYSCALL-G. 005700 05 FILLER PIC X(01) VALUE QUOTE. 005800 05 FILLER PIC X(07) VALUE 'SYSCALL'. 005900 05 FILLER PIC X(01) VALUE QUOTE. 006000 01 TEXT-SYSCALL REDEFINES TEXT-SYSCALL-G PIC X(09). 006100 01 TEXT-CALL-G1. 006200 05 FILLER PIC X(05) VALUE 'CALL '. 006300 05 FILLER PIC X(01) VALUE QUOTE. 006400 01 TEXT-CALL-1 REDEFINES TEXT-CALL-G1 PIC X(6). 006500 01 TEXT-CALL-G2. 006600 05 FILLER PIC X(06) VALUE 'CALL '. 006700 05 FILLER PIC X(01) VALUE QUOTE. 006800 01 TEXT-CALL-2 REDEFINES TEXT-CALL-G2 PIC X(7). 006900 01 TEXT-CALL-G3. 007000 05 FILLER PIC X(07) VALUE 'CALL '. 007100 05 FILLER PIC X(01) VALUE QUOTE. 007200 01 TEXT-CALL-3 REDEFINES TEXT-CALL-G3 PIC X(8). 007300 LINKAGE SECTION. 007400 01 PARM-FIELD. 007500 05 PARM-LEN PIC S9(4) COMP. 007600 05 PARM-DATA. 007700 10 PARM-CHAR PIC X(01) OCCURS 0 TO 100 TIMES 007800 DEPENDING ON PARM-LEN. 007900 PROCEDURE DIVISION USING PARM-FIELD. 008000 0000-COBV0ERR. 008100 OPEN INPUT SYSIPT-FILE 008200 PERFORM 9100-READ-SYSIPT 008300 MOVE SYSIPT-REC TO SAVE-SYSIPT 008400 PERFORM 9100-READ-SYSIPT 008500 PERFORM 1000-PROCESS-SYSIPT 008600 UNTIL SYSIPT-EOF 008700 IF NOT SYSIPT-PROC 008800 DISPLAY 'COBV0ERR-NO "PROCEDURE DIVISION... " TEXT FOUND' 008900 END-IF 009000 CLOSE SYSIPT-FILE 009100 GOBACK 009200 . 009300 1000-PROCESS-SYSIPT. 009400 IF SYSIPT-COMMENT NOT = '*' 009500 IF SYSIPT-MARGIN-A = 'PROC' 009600 MOVE 'P' TO PROC-STATUS 009700 ELSE 009800 IF SYSIPT-PROC 009900 PERFORM 1200-PROC-CHECKS 010000 ELSE 010100 PERFORM 1100-WS-CHECKS 010200 010300 . 010400 MOVE SYSIPT-REC TO SAVE-SYSIPT 010500 PERFORM 9100-READ-SYSIPT 010600 . 010700 1100-WS-CHECKS. 010800 MOVE ZERO TO I 010900 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL 'COPY ' 011000 IF I NOT = ZERO 011100 AND (( SYSIPT-MARGIN-A = '01 ' 011110 AND SYSIPT-COMMENT = SPACE) 011120 OR 011200 ( SAVE-SYSIPT-MARGIN-A = '01 ' 011210 AND SAVE-SYSIPT-COMMENT = SPACE)) 011300 DISPLAY 'COBV0ERR-"COPY... " TEXT FOUND' 011400 PERFORM 1100-LIST-3 011500 END-IF 011600 . 011700 1200-PROC-CHECKS. 011800 MOVE ZERO TO I 011900 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL ' ACCEPT ' 012000 IF I NOT = ZERO 012100 DISPLAY 'COBV0ERR-"ACCEPT" TEXT FOUND' 012200 PERFORM 1100-LIST-3 012300 END-IF Usually is CURRENT date or time. 012400 MOVE ZERO TO I 012500 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL 'EXAMINE' 012600 IF I NOT = ZERO 012700 DISPLAY 'COBV0ERR-"EXAMINE" TEXT FOUND' 012800 PERFORM 1100-LIST-3 012900 END-IF Change to INSPECT. 013000 MOVE ZERO TO I 013100 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-DATABASE 013200 IF I NOT = ZERO 013300 DISPLAY 'COBV0ERR-"DATABASE" TEXT FOUND' 013400 PERFORM 1100-LIST-3 013500 END-IF Obsolete sub-routine calls. 013600 MOVE ZERO TO I 013700 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-GDTCALL 013800 IF I NOT = ZERO 013900 DISPLAY 'COBV0ERR-"GDTCALL" TEXT FOUND' 014000 PERFORM 1100-LIST-3 014100 END-IF 014200 MOVE ZERO TO I 014300 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-SETASOF 014400 IF I NOT = ZERO 014500 MOVE ZERO TO I 014600 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL ' VALUE ' 014700 IF I = ZERO 014800 DISPLAY 'COBV0ERR-"SETASOF" TEXT FOUND' 014900 PERFORM 1100-LIST-3 015000 END-IF 015100 END-IF 015200 MOVE ZERO TO I 015300 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-SYSCALL 015400 IF I NOT = ZERO 015500 DISPLAY 'COBV0ERR-"SYSCALL" TEXT FOUND' 015600 PERFORM 1100-LIST-3 015700 END-IF 015800 MOVE ZERO TO I 015900 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-CALL-1 016000 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-CALL-2 016100 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL TEXT-CALL-3 016200 IF I NOT = ZERO 016300 DISPLAY 'COBV0ERR-"CALL ..." TEXT FOUND' 016400 PERFORM 1100-LIST-3 016500 END-IF 016600 MOVE ZERO TO I 016700 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL 016800 ' CURRENT-DATE ' 016900 IF I NOT = ZERO 017000 MOVE ZERO TO I 017100 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL 017200 ' FUNCTION ' 017300 IF I = ZERO 017400 DISPLAY 'COBV0ERR-"CURRENT-DATE" TEXT FOUND' 017500 PERFORM 1100-LIST-3 017600 END-IF 017700 END-IF Reference to current-date but not the function. 017800 MOVE ZERO TO I 017900 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL ' TIME-OF-DAY' 018000 IF I NOT = ZERO 018100 DISPLAY 'COBV0ERR-"TIME-OF-DAY" TEXT FOUND' 018200 PERFORM 1100-LIST-3 018300 END-IF 018400 MOVE ZERO TO I 018500 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL ' TRANSFORM ' 018600 IF I NOT = ZERO 018700 DISPLAY 'COBV0ERR-"TRANSFORM" TEXT FOUND' 018800 PERFORM 1100-LIST-3 018900 END-IF Use TRANSFORM. 019000 INSPECT SYSIPT-MARGIN-B TALLYING I FOR ALL 'STOP RUN' 019100 IF I NOT = ZERO 019200 DISPLAY 'COBV0ERR-"STOP RUN " TEXT FOUND' 019300 PERFORM 1100-LIST-3 019400 END-IF Do GOBACK. 019500 . 019600 1100-LIST-3. 019700 DISPLAY SAVE-SYSIPT 019800 DISPLAY SYSIPT-REC 019900 PERFORM 9100-READ-SYSIPT 020000 DISPLAY SYSIPT-REC 020100 . 020200 9100-READ-SYSIPT. 020300 IF SYSIPT-EOF 020400 MOVE '999999*----END OF FILE ON COBIPT----*' 020500 TO SYSIPT-REC 020600 ELSE 020700 READ SYSIPT-FILE 020800 AT END 020900 MOVE '4' TO SYSIPT-STATUS 021000 . 021100 END PROGRAM COBV0ERR. -END
COB0LINK -ADD COB0LINK,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC ADD CEEUPOT SETSSI TO OBJECT FILE -PGMR STEVE RYDER, JSR SYSTEMS -LANG COB 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. COB0LINK. 000300 AUTHOR. STEVE RYDER/JSR SYSTEMS. 000400 DATE-WRITTEN. APR 1999. 000500 DATE-COMPILED. 000600* Sets User Options, and SETSSI for date of compile yyyymmdd. 000700*----COPY OBJECT CARD, ADD INCLUDE SYSLIB(CEEUOPT) + SETSSI 000800*---- Go to SYS9TMEM 000900 ENVIRONMENT DIVISION. 001000 CONFIGURATION SECTION. 001100 INPUT-OUTPUT SECTION. 001200 FILE-CONTROL. 001300 SELECT OBJIN-FILE ASSIGN TO UT-S-OBJIN. 001400 SELECT OBJOUT-FILE ASSIGN TO UT-S-OBJOUT. 001500 DATA DIVISION. 001600 FILE SECTION. 001700 FD OBJIN-FILE 001800 RECORDING MODE IS F 001900 RECORD CONTAINS 0 CHARACTERS 002000 LABEL RECORDS ARE STANDARD 002100 BLOCK CONTAINS 0 RECORDS 002200 DATA RECORD IS OBJIN-RECORD. 002300 01 OBJIN-RECORD. 002400 05 OBJIN-01-04 PIC X(04). 002500 05 FILLER PIC X(76). 002600 FD OBJOUT-FILE 002700 RECORDING MODE IS F 002800 RECORD CONTAINS 80 CHARACTERS 002900 LABEL RECORDS ARE STANDARD 003000 BLOCK CONTAINS 0 RECORDS 003100 DATA RECORD IS OBJOUT-RECORD. 003200 01 OBJOUT-RECORD PIC X(80). 003300 WORKING-STORAGE SECTION. 003400 01 MY-PROGRAM-ID PIC X(08) VALUE 'COB0LINK'. 003500 01 OBJIN-EOF-SW PIC X(01) VALUE SPACE. 003600 88 OBJIN-EOF VALUE 'E'. 003700*----COBVDATE SUGGETED CHANGES FOR COBOL/LE DATE/TIME 003800 01 WS-CURRENT-DATE. 003900 05 CURR-YYYY. 004000 10 CURR-CC PIC X(02). 004100 10 CURR-YY PIC X(02). 004200 05 CURR-MM PIC X(02). 004300 05 CURR-DD PIC X(02). 004400 05 CURR-HRS PIC X(02). 004500 05 CURR-MIN PIC X(02). 004600 05 CURR-SEC PIC X(02). 004700 05 CURR-HUN PIC X(02). 004800 05 GMT-PLUS-MINUS PIC X(01). 004900 05 GMT-HRS PIC X(02). 005000 05 GMT-MIN PIC X(02). 005100 01 SETSSI-LINE. 005200 05 FILLER PIC X(08) VALUE ' SETSSI '. 005300 05 SETSSI-DATE PIC X(08). 005400 LINKAGE SECTION. 005500 01 PARM-FIELDS. 005600 05 PARM-LENGTH PIC S9(4) COMP SYNC. 005700 05 PARM-DATA. 005800 10 PARM-CHAR PIC X(01) OCCURS 0 TO 100 TIMES 005900 DEPENDING ON PARM-LENGTH. 006000 PROCEDURE DIVISION USING PARM-FIELDS. 006100 0000-BEGIN. 006200 OPEN INPUT OBJIN-FILE 006300 OUTPUT OBJOUT-FILE 006400 PERFORM 900-READ 006500 IF OBJIN-EOF 006600 MOVE 16 TO RETURN-CODE 006700 ELSE 006800 PERFORM 100-COPY 006900 UNTIL OBJIN-EOF 007000 MOVE 00 TO RETURN-CODE 007100 . 007200 CLOSE OBJIN-FILE OBJOUT-FILE 007300 . 007400 GOBACK 007500 . 007600 100-COPY. 007700 IF OBJIN-01-04 = ' NAM' 007800 MOVE ' INCLUDE SYSLIB(CEEUOPT)' TO OBJOUT-RECORD 007900*+++ DISPLAY 'OBJECT=' OBJOUT-RECORD '+' 008000 WRITE OBJOUT-RECORD 008100 MOVE FUNCTION CURRENT-DATE TO WS-CURRENT-DATE 008200 MOVE WS-CURRENT-DATE TO SETSSI-DATE 008300 MOVE SETSSI-LINE TO OBJOUT-RECORD 008400*+++ DISPLAY 'OBJECT=' OBJOUT-RECORD '+' 008500 WRITE OBJOUT-RECORD 008600 . 008700*+++ DISPLAY 'OBJECT=' OBJIN-RECORD '*' 008800 WRITE OBJOUT-RECORD FROM OBJIN-RECORD 008900 PERFORM 900-READ 009000 . 009100 900-READ. 009200 READ OBJIN-FILE 009300 AT END MOVE 'E' TO OBJIN-EOF-SW 009400 . 009500 END PROGRAM COB0LINK. -END
SYS9TMEM -ADD SYS9TMEM,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC SYSTABLE READ SEQ TBL TO ALLOC MEMORY -PGMR RYDER JSR SYSTEMS -LANG COB 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. SYS9TMEM. 000300*AUTHOR. STEVE RYDER. 000400*DATE-WRITTEN. MARCH 1999. CLONED FROM SYSTREAD. 000500* 000600*REMARKS. CALLED BY SYSTABLE TO READ TABLE FILES. 000700* DETERMINE THE FILE TYPE AND FILE TO LOAD FROM BY 000800* SPECIFYING THE PROPER DDNAMES. SYS9TMEM LOOKS FOR 000900* DDNAMES IN THE FOLLOWING ORDER: 001000* - FIRST 8 BYTES OF TABLE-ID REPLACING '-' WITH '@' 001100* TABLE IS SEQUENTIAL 001200* IF ABOVE NOT FOUND, RETURN STATUS=TFNF 001300* AND SYSTABLE WILL READ TABLE FROM DDNAME=TABL. 001400*---------- 001500*MODIFICATION HISTORY : 001600* DATE PROGRAMMER CHANGE 001700* 001800* 001900* 002000* 002100* 002200* 002300**************************************************************** 002400 ENVIRONMENT DIVISION. 002500 CONFIGURATION SECTION. 002600 OBJECT-COMPUTER. IBM-370. 002700 INPUT-OUTPUT SECTION. 002800 FILE-CONTROL. 002900 SELECT TABLE-FILE 003000 ASSIGN TO UT-S-XXXXXXXX. 003100* DDNAME TO BE FILLED IN BY SYSDDNAM. 003200 DATA DIVISION. 003300 FILE SECTION. 003400 FD TABLE-FILE 003500 RECORDING MODE IS F 003600 LABEL RECORDS ARE STANDARD 003700 RECORD CONTAINS 0 CHARACTERS 003800 BLOCK CONTAINS 0 RECORDS 003900 DATA RECORD IS TABLE-RECORD. 004000 01 TABLE-RECORD. 004100 05 TABLE-CHAR PIC X(01) OCCURS 289 TIMES 004200 INDEXED BY TABLE-LEFT, 004300 TABLE-RIGHT. 004400 WORKING-STORAGE SECTION. 004500 01 MY-PROGRAM-ID PIC X(08) VALUE 'SYS9TMEM'. 004600 01 SYSLOG-ID PIC X(08) VALUE 'SYSLOG '. 004700 01 SYSDDNAM-ID PIC X(08) VALUE 'SYSDDNAM'. 004800 01 SYSJFCB-ID PIC X(08) VALUE 'SYSJFCB '. 004900 01 SYSMOVE-ID PIC X(08) VALUE 'SYSMOVE '. SYSJFCB sees if DDNAME exists (ASM). SYSDDNAME changes DDNAME (COBOL). SYSMOVE moves ll bytes (ASM, could be COBOL).
Following parameters required to allocate storage. 005000 01 CEEGTST PIC X(08) VALUE 'CEEGTST '. 005100 01 CEEFRST PIC X(08) VALUE 'CEEFRST '. 005200 01 GET-STORAGE-HEAPID PIC S9(9) BINARY. 005300 01 GET-STORAGE-NBYTES PIC S9(9) BINARY. 005400 01 GET-STORAGE-FEEDBACK. 005500 05 FILLER PIC X(08) VALUE '********'. 005600 88 CEE000 VALUE LOW-VALUES. 005700 05 FILLER PIC X(04) VALUE '****'. 005800 05 FILLER PIC X(04) VALUE '****'. 005900 01 GET-STORAGE-ADDRESS USAGE IS POINTER VALUE NULL. 006000 01 TABLE-HEADER. 006100* FIRST CARD OF TABLE-FILE MUST BE TABLE-HEADER. 006200* COLUMNS CONTENTS 006300* 03-10 ALTERNATE TABLE DDNAME. 006400* - IF 3-10 OF TABLE HEADER RECORD IS NOT 006500* BLANK, DO SYSJFCB, IF DDNAME EXISTS 006600* OPEN IT AS ALTERNATE. THIS WILL ALLOW 006700* TABLE DETAIL RECORDS TO BE SHORTER 006800* THAN HEADER RECORD. 006900* 12-26 TABLE-ID 007000* 28-31 MAXIMUM ENTRIES IN TABLE 007100* 32-35 LENGTH OF LEFT SIDE DATA 007200* 36-39 LENGTH OF RIGHT SIDE DATA 007300* 40-43 LEFTMOST POSITION OF LEFT DATA IN SEQ REC. 007400* 44-47 LEFTMOST POSITION OF RIGHT DATA IN SEQ REC. 007500* 51-55 MAXIMUM ENTRIES IF > 9999 AND 28-31 = 0000. 007600 05 FILLER PIC X(02). 007700 05 TABLE-ALT-DDNAME PIC X(08). 007800 05 FILLER PIC X(01). 007900 05 TABLE-ID. 008000 10 TABLE-8 PIC X(08) VALUE SPACES. 008100 88 FIRST-CALL VALUE SPACES. 008200 10 TABLE-7 PIC X(07) VALUE SPACES. 008300 05 FILLER PIC X(01). 008400 05 TABLE-MAX-ENTRIES PIC 9(4). 008500 05 TABLE-LENGTH-LEFT PIC 9(4). 008600 05 TABLE-LENGTH-RIGHT PIC 9(4). 008700 05 TABLE-POSITION-LEFT PIC 9(4). 008800 05 TABLE-POSITION-RIGHT PIC 9(4). 008900 05 FILLER PIC X(03). 009000 05 TABLE-MAX-5-DIGIT PIC 9(05). 009100 01 WS-POINTERS USAGE IS BINARY. 009200 05 WS-MAX-ENTRIES PIC S9(4). 009300 05 WS-LENGTH-LEFT PIC S9(4). 009400 05 WS-LENGTH-RIGHT PIC S9(4). 009500*--- 009600 COPY 'SYSLLOG'. 009700 05 LOG-MESSAGE-X REDEFINES LOG-MESSAGE. 009800 10 FILLER PIC X(08). 009900 10 LOG-TABLE-ID PIC X(15). 010000 10 FILLER PIC X(05). 010100 10 LOG-MAX-ENTRIES PIC ZZZZZ. 010200 10 FILLER PIC X(05). 010300 10 LOG-LENGTH-LEFT PIC ZZZ. 010400 10 FILLER PIC X(01). 010500 10 LOG-LENGTH-RIGHT PIC ZZZ. 010600 10 FILLER PIC X(01). 010700 10 LOG-MEMBER PIC X(09). 010800 10 LOG-DSN-44 PIC X(44). 010900 10 FILLER PIC X(01). 011000 COPY 'SYSLJFCB'. 011100 COPY 'SYSBITWS'. 011200 LINKAGE SECTION. Set depending on values, then allocate LENGTH(TABL-ALLOCATION). Go to 9100-GET-STORAGE. 011300 01 TABL-ALLOCATION. 011400 05 TABL-MAX-ENTRIES PIC S9(4) BINARY. 011500 05 TABL-LENGTH-LEFT PIC S9(4) BINARY. 011600 05 TABL-LENGTH-RIGHT PIC S9(4) BINARY. 011700 05 TABL-ENTRY OCCURS 1 TO 32000 TIMES 011800 DEPENDING ON WS-MAX-ENTRIES 011900 INDEXED BY TABL-X. 012000 10 TABL-LEFT. 012100 15 TABL-LEFT-CHAR PIC X(01) OCCURS 1 TO 20 TIMES 012200 DEPENDING ON WS-LENGTH-LEFT. 012300 10 TABL-RIGHT. 012400 15 TABL-RT-CHAR PIC X(01) OCCURS 1 TO 250 TIMES 012500 DEPENDING ON WS-LENGTH-RIGHT. 012600 01 LK-COMMANDS. 012700 05 LK-FUNCTION PIC X(08). 012800 88 LK-READ VALUE 'READ '. 012900 88 LK-READX VALUE 'READX'. 013000*** READX IS TO READ THE KEY FIELD ONLY 013100*** READ IS TO READ THE KEY AND OBJECT FIELDS 013200*** DETERMINED BY SYSTABLE DEPENDING ON PRESENCE OF 013300*** THIRD PARAMETER. 013400 05 LK-STATUS PIC X(04). 013500 88 LK-STATUS-OK VALUE '****'. 013600 05 LK-TABLE-ID. 013700 10 LK-TABLE-8 PIC X(08). 013800 10 LK-TABLE-7 PIC X(07). 013900 01 LK-POINTER USAGE IS POINTER. 014000 PROCEDURE DIVISION USING LK-COMMANDS LK-POINTER. 014100 0000-ENTRY. 014200 IF LK-FUNCTION = 'FREE ' 014300 CALL 'CEEFRST' USING LK-POINTER 014400 GET-STORAGE-FEEDBACK 014500 GOBACK 014600 . 014700 MOVE '****' TO LK-STATUS 014800 PERFORM 0700-OPEN 014900 IF LK-STATUS = '****' 015000*--------ALLOCATE SPACE HERE. 015100 PERFORM 9100-GET-STORAGE 015200 SET TABL-X TO 1 015300 PERFORM 0100-READ 015400 UNTIL LK-STATUS NOT = '****' 015500 . 015600 IF LK-STATUS = 'END.' 015700 MOVE '****' TO LK-STATUS 015800 . 015810 IF LK-STATUS NOT = 'TFNF' 015900 PERFORM 0800-CLOSE-TABLE-FILE 015910 . 016000 GOBACK 016100 . 016200 0100-READ. 016300 PERFORM 0400-READ-TABLE-FILE 016400 SUBTRACT 1 FROM WS-MAX-ENTRIES 016500 IF LK-STATUS IS EQUAL TO 'END.' 016600 NEXT SENTENCE 016700 ELSE 016800 IF WS-MAX-ENTRIES IS LESS THAN ZERO 016900 MOVE 'TFUL' TO LK-STATUS 017000 MOVE 'TABLE EXCEEDS MAX ENTRIES' TO LOG-MESSAGE 017100 MOVE LK-STATUS TO LOG-STATUS 017200 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 017300 ELSE 017400 PERFORM 0110-MOVE-DATA 017500 SET TABL-X UP BY 1 017600 . 017700 0110-MOVE-DATA. 017800 IF LK-READ AND WS-LENGTH-RIGHT IS EQUAL TO ZERO 017900 MOVE 'TNRS' TO LK-STATUS 018000 MOVE 'TABLE HAS NO RIGHT SIDE ' TO LOG-MESSAGE 018100 MOVE LK-STATUS TO LOG-STATUS 018200 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 018300 ELSE 018400 CALL SYSMOVE-ID USING WS-LENGTH-LEFT, 018500 TABLE-CHAR (TABLE-LEFT) 018600 TABL-LEFT (TABL-X) 018700 IF LK-READ 018800 CALL SYSMOVE-ID USING WS-LENGTH-RIGHT 018900 TABLE-CHAR (TABLE-RIGHT) 019000 TABL-RIGHT (TABL-X) 019100 . 019200 IF TABL-X > 1 019300 IF TABL-LEFT (TABL-X) NOT > TABL-LEFT (TABL-X - 1) 019400 MOVE 'TSEQ' TO LK-STATUS 019500 MOVE 'TABLE OUT OF SEQUENCE' TO LOG-MESSAGE 019600 MOVE LK-STATUS TO LOG-STATUS 019700 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 019800 . 019900 0400-READ-TABLE-FILE. 020000 READ TABLE-FILE 020100 AT END 020200 MOVE 'END.' TO LK-STATUS 020300 . 020400 0700-OPEN. 020500 IF LK-TABLE-8 IS EQUAL TO SPACES 020600 MOVE 'TFNF' TO LK-STATUS 020700 ELSE 020800 MOVE LK-TABLE-8 TO JFCB-DDNAME 020900**** LOOK FOR USER SUPPLIED SEQUENTIAL TABLE FILE 021000 INSPECT 021100 JFCB-DDNAME REPLACING ALL '-' BY '@' 021200 CALL SYSJFCB-ID USING JFCB-COMMAND 021300 JFCB-AREA 021400 IF JFCB-GOOD-STATUS 021500 PERFORM 0710-OPEN-SEQUENTIAL 021600 ELSE 021700 MOVE 'TFNF' TO LK-STATUS 021800 . 021900 0710-OPEN-SEQUENTIAL. 022000 CALL SYSDDNAM-ID USING JFCB-DDNAME TABLE-FILE 022100**** JFCB-DDNAME HAS '@' IN PLACE OF LK-TABLE-8'S '-' 022200 OPEN INPUT TABLE-FILE 022300 PERFORM 0400-READ-TABLE-FILE 022400 MOVE 47 TO WS-MAX-ENTRIES 022500 CALL SYSMOVE-ID USING 022600 WS-MAX-ENTRIES, TABLE-CHAR (01), TABLE-HEADER 022700 IF LK-TABLE-ID = TABLE-ID 022800 AND TABLE-MAX-ENTRIES IS NUMERIC 022900 AND TABLE-LENGTH-LEFT IS NUMERIC 023000 AND TABLE-LENGTH-RIGHT IS NUMERIC 023100 AND TABLE-POSITION-LEFT IS NUMERIC 023200 AND TABLE-POSITION-RIGHT IS NUMERIC 023300 AND TABLE-POSITION-LEFT > ZERO 023400 MOVE TABLE-MAX-ENTRIES TO WS-MAX-ENTRIES 023500 PERFORM 0711-CHECK-MAX-GT-9999 023600 MOVE TABLE-LENGTH-LEFT TO WS-LENGTH-LEFT 023700 MOVE TABLE-LENGTH-RIGHT TO WS-LENGTH-RIGHT 023800 SET TABLE-LEFT TO TABLE-POSITION-LEFT 023900 SET TABLE-RIGHT TO TABLE-POSITION-RIGHT 024000 PERFORM 0715-SETUP-LK-MESSAGE 024100 ELSE 024200 MOVE ZERO TO WS-MAX-ENTRIES 024300 WS-LENGTH-LEFT WS-LENGTH-RIGHT 024400 PERFORM 0715-SETUP-LK-MESSAGE 024500 MOVE 'TBAD' TO LK-STATUS 024600 MOVE 'TABLE HEADER INCORRECTLY FORMATTED ' 024700 TO LOG-MESSAGE 024800 MOVE LK-STATUS TO LOG-STATUS 024900 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 025000 . 025100 IF LK-STATUS = '****' 025200 AND TABLE-ALT-DDNAME NOT = SPACES 025300 MOVE TABLE-ALT-DDNAME TO JFCB-DDNAME 025400**** LOOK FOR ALTERNATE DDNAME 025500 CALL SYSJFCB-ID USING JFCB-COMMAND 025600 JFCB-AREA 025700 IF JFCB-GOOD-STATUS 025800 CLOSE TABLE-FILE 025900 CALL SYSDDNAM-ID USING JFCB-DDNAME TABLE-FILE 026000 OPEN INPUT TABLE-FILE 026100*------------PERFORM 0715-SETUP-LK-MESSAGE, NOT HERE!!! 026200 . 026300 0711-CHECK-MAX-GT-9999. 026400 IF TABLE-MAX-ENTRIES = ZERO 026500 MOVE 5 TO WS-MAX-ENTRIES 026600 CALL SYSMOVE-ID USING 026700 WS-MAX-ENTRIES TABLE-CHAR(51) TABLE-MAX-5-DIGIT 026800 IF TABLE-MAX-5-DIGIT IS NOT NUMERIC 026900 OR TABLE-MAX-5-DIGIT > 32767 027000 MOVE ZERO TO WS-MAX-ENTRIES 027100 WS-LENGTH-LEFT WS-LENGTH-RIGHT 027200 PERFORM 0715-SETUP-LK-MESSAGE 027300 MOVE 'TBAD' TO LK-STATUS 027400 MOVE 'TABLE HEADER INCORRECTLY FORMATTED ' 027500 TO LOG-MESSAGE 027600 MOVE LK-STATUS TO LOG-STATUS 027700 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 027800 ELSE 027900 MOVE TABLE-MAX-5-DIGIT TO WS-MAX-ENTRIES 028000 . 028100 0715-SETUP-LK-MESSAGE. 028200 MOVE 'LOADING MAX= LEN= /' 028300 TO LOG-MESSAGE 028400 MOVE TABLE-ID TO LOG-TABLE-ID 028500 MOVE WS-MAX-ENTRIES TO LOG-MAX-ENTRIES 028600 MOVE WS-LENGTH-LEFT TO LOG-LENGTH-LEFT 028700 MOVE WS-LENGTH-RIGHT TO LOG-LENGTH-RIGHT 028800 MOVE JFCB-DATA-MGT TO BIT-TO-BYTE-X1 028900 PERFORM 9000-BIT-TO-BYTE 029000 IF BYTE-2 IS EQUAL TO '1' 029100 MOVE 'DD * FILE' TO LOG-MEMBER 029200 ELSE 029300 MOVE JFCB-DSN TO LOG-DSN-44 029400 MOVE JFCB-MEMBER TO LOG-MEMBER 029500 . 029600 MOVE 'SYSTABLE' TO LOG-PROGRAM-ID 029700 MOVE 'SYSLOG ' TO LOG-DEVICE 029800 MOVE '****' TO LOG-STATUS 029900 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 030000 . 030100 0800-CLOSE-TABLE-FILE. 030200 CLOSE TABLE-FILE 030300 . 030400 9000-BIT-TO-BYTE. 030500 COPY SYSBITPR. 030600 9100-GET-STORAGE. 030700*+++ DISPLAY 'SYS9TMEM-MAX/LENL/LENR: ' WS-MAX-ENTRIES '/' 030800*+++ WS-LENGTH-LEFT '/' 030900*+++ WS-LENGTH-RIGHT '.' 031000*+++ DISPLAY 'SYS9TMEM-LENGTH OF TABLE:' LENGTH OF TABL-ALLOCATION 031100 COMPUTE GET-STORAGE-NBYTES = LENGTH OF TABL-ALLOCATION 031200 CALL 'CEEGTST' USING GET-STORAGE-HEAPID 031300 GET-STORAGE-NBYTES 031400 GET-STORAGE-ADDRESS 031500 GET-STORAGE-FEEDBACK 031600 IF CEE000 THEN 031700 SET ADDRESS OF TABL-ALLOCATION TO GET-STORAGE-ADDRESS 031800 SET LK-POINTER TO GET-STORAGE-ADDRESS 031900 MOVE ALL '9' TO TABL-ALLOCATION 032000 MOVE WS-MAX-ENTRIES TO TABL-MAX-ENTRIES 032100 MOVE WS-LENGTH-LEFT TO TABL-LENGTH-LEFT 032200 MOVE WS-LENGTH-RIGHT TO TABL-LENGTH-RIGHT 032300 ELSE 032400 MOVE 'NSTG' TO LK-STATUS 032500 MOVE 'NOT ENOUGH STORAGE AVAILABLE' TO LOG-MESSAGE 032600 MOVE LK-STATUS TO LOG-STATUS 032700 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 032800 . 032900 END PROGRAM SYS9TMEM. -END Go to Compile Proc.SYSLTMEM -ADD SYSLTMEM,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC SYS9TMEM LINKAGE FORMATS -PGMR RYDER JSR SYSTEMS -LANG COB 000100*----IN WORKING STORAGE OF CALLING PROGRAM. 000200 01 SYS9TMEM-ID PIC X(08) VALUE 'SYS9TMEM'. 000300 01 SYS9TMEM-COMMANDS. 000400 05 SYS9TMEM-FUNCTION PIC X(08) VALUE 'READ '. 000500 88 SYS9TMEM-READ VALUE 'READ '. 000600 88 SYS9TMEM-READX VALUE 'READX '. 000700 05 SYS9TMEM-STATUS PIC X(04) VALUE '****'. 000800 88 SYS9TMEM-STATUS-OK VALUE '****'. 000900 05 SYS9TMEM-TABLE-ID PIC X(15) VALUE SPACES. 001000 01 SYS9TMEM-VALUES. 001100 05 SYS9TMEM-NUM-ENTRY PIC S9(4) BINARY. 001200 05 SYS9TMEM-LENGTH-LEFT PIC S9(4) BINARY. 001300 05 SYS9TMEM-LENGTH-RIGHT PIC S9(4) BINARY. 001400 01 SYS9TMEM-OBJECT. 001500 05 SYS9TMEM-OPEN-MESSAGE PIC X(24). 001600 05 SYS9TMEM-DSN-44 PIC X(44). 001700 05 SYS9TMEM-MEMBER PIC X(08). 001800 01 SYS9TMEM-POINTER USAGE IS POINTER. 001900*----IN LINKAGE OF CALLING PROGRAM. 002000 01 SYS9TMEM-TABLE. 002100 05 SYS9TMEM-ENTRY OCCURS 1 TO 10000 TIMES 002200 DEPENDING ON SYS9TMEM-NUM-ENTRY 002300 INDEXED BY SYS9TMEM-X. 002400 10 SYS9TMEM-LEFT. 002500 15 SYS9TMEM-LT-CHAR PIC X(01) OCCURS 1 TO 20 002600 DEPENDING ON SYS9TMEM-LENGTH-LEFT. 002700 10 SYS9TMEM-RIGHT. 002800 15 SYS9TMEM-RT-CHAR PIC X(01) OCCURS 1 TO 250 002900 DEPENDING ON SYS9TMEM-LENGTH-RIGHT. 003000*----IN PROCEDURE DIVISION OF CALLING PROGRAM. 003100 CALL SYS9TMEM-ID USING SYS9TMEM-COMMANDS SYS9TMEM-VALUES 003200 SYS9TMEM-OBJECT SYS9TMEM-POINTER -END
SYSTABLE -ADD SYSTABLE,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC COBOL-LE SYSTABLE TABLE LOOKUP -PGMR RYDER JSR SYSTEMS -LANG COB 000100 IDENTIFICATION DIVISION. 000200 PROGRAM-ID. SYSTABLE. 000300*AUTHOR. STEVE RYDER JSR SYSTEMS. 000400 DATE-WRITTEN. JUNE 23, 1997. 000500 DATE-COMPILED. 000600*REMARKS. 000700* TABLE LOOKUP. 000800* 000900 ENVIRONMENT DIVISION. 001000 INPUT-OUTPUT SECTION. 001100 FILE-CONTROL. 001200 SELECT TABLE-FILE 001300 FILE STATUS IS TABLE-FILE-STATUS 001400 ORGANIZATION IS INDEXED 001500 ACCESS IS DYNAMIC 001600 RECORD KEY IS TABLE-KEY 001700 ASSIGN TO SYS016-TABL. 001800 DATA DIVISION. 001900 FILE SECTION. 002000 FD TABLE-FILE 002100 DATA RECORD IS TABLE-REC. 002200 01 TABLE-REC. 002300 05 TABLE-DATU PIC 9(4)V999. 002400 05 TABLE-BLNK PIC X(01). 002500 05 TABLE-KEY. 002600 10 TABLE-NAME PIC X(15). 002700 10 TABLE-RECORD-CODE PIC X(01). 002800 10 TABLE-LEFT PIC X(20). 002900 05 TABLE-DATE PIC X(03). 003000 05 TABLE-RIGHT. 003100 10 TABLA011-MAX-ENTRIES PIC 9(4). 003200 10 TABLA012-LEFT-SIDE-LENGTH PIC 9(4). 003300 10 TABLA013-RIGHT-SIDE-LENGTH PIC 9(4). 003400 10 FILLER PIC X(238). 003500* RIGHT SIDE LENGTH MUST TOTAL 250. 003600 WORKING-STORAGE SECTION. 003700 01 MY-PROGRAM-ID PIC X(08) VALUE 'SYSTABLE'. 003800 01 SYSLOG-ID PIC X(08) VALUE 'SYSLOG '. 003900*--- SYSLOAD-ID PIC X(08) VALUE 'SYSLOAD '. 004000*+++ SYSSNAP-ID PIC X(08) VALUE 'SYSSNAP '. 004100*+++ SYSSNAP-LEN PIC S9(4) BINARY VALUE +20. 004200 01 DISPLAY-TBL-X PIC 9(04) VALUE ZERO. 004300 01 WS-DATA-VALUES. 004400 05 ENTRY-COUNT PIC S9(9) BINARY VALUE ZERO. 004500 05 TABLE-FILE-STATE PIC X(01) VALUE 'C'. 004600 05 TABLE-FILE-STATUS PIC X(02) VALUE '00'. 004700 88 TABLE-FILE-OK VALUE '00' '04'. 004800* 04 MEANS READ SHORT RECORD, 00 IS NORMAL, ALL OK. 004900 COPY SYSLLOG. 005000 05 LOG-MESSAGE-X REDEFINES LOG-MESSAGE. 005100 10 LOG-MESSAGE-CALLING-ID PIC X(08). 005200 10 LOG-MESSAGE-ENTRY-COUNT PIC ZZZ,ZZZ,ZZZ-. 005300 10 LOG-MESSAGE-TABLE-ID PIC X(15). 005400 10 LOG-MESSAGE-TEXT. 005500 15 LOG-MESSAGE-LEFT PIC X(20). 005600 15 LOG-MESSAGE-TEXT-XX PIC X(45). 005700* 005800 COPY SYSLLOAD. 005900* 006000 01 SAVE-TABLE-ID PIC X(15) VALUE SPACES. 006100 01 SAVE-REFER. 006200 05 SAVE-REF-POUND1 PIC X(01). 006300 05 SAVE-REF-INDEX PIC X(01). 006400 05 SAVE-REF-LL PIC X(01). 006500 05 SAVE-REF-RRR PIC X(01). 006600 05 SAVE-REF-POUND2 PIC X(01). 006700 01 TBL-REF-INDEX PIC S9(4) BINARY VALUE ZERO. 006800 01 TBL-REF-INDEX-R REDEFINES TBL-REF-INDEX. 006900 05 FILLER PIC X(01). 007000 05 TBL-REF-INDEX-1 PIC X(01). 007100 01 TBL-REF-LL PIC S9(4) BINARY VALUE ZERO. 007200 01 TBL-REF-LL-R REDEFINES TBL-REF-LL. 007300 05 FILLER PIC X(01). 007400 05 TBL-REF-LL-1 PIC X(01). 007500 01 TBL-REF-RRR PIC S9(4) BINARY VALUE ZERO. 007600 01 TBL-REF-RRR-R REDEFINES TBL-REF-RRR. 007700 05 FILLER PIC X(01). 007800 05 TBL-REF-RRR-1 PIC X(01). 007900 01 TABLE-OF-TABLES. 008000 05 TABLE-ENTRY OCCURS 50 TIMES 008100 INDEXED BY TBL-X TBL-TOP TBL-MAX. 008200 10 TABLE-TABLE-ID PIC X(15). 008300 10 TABLE-REFER PIC X(05). 008400 10 TABLE-SEARCHES PIC 9(9). 008500 10 TABLE-POINTER USAGE IS POINTER. 008600 01 SYS9TMEM-ID PIC X(08) VALUE 'SYS9TMEM'. 008700 01 SYS9TMEM-COMMANDS. 008800 05 SYS9TMEM-FUNCTION PIC X(08) VALUE 'READ '. 008900 88 SYS9TMEM-READ VALUE 'READ '. 009000 88 SYS9TMEM-READX VALUE 'READX '. 009100 05 SYS9TMEM-STATUS PIC X(04) VALUE '****'. 009200 88 SYS9TMEM-STATUS-OK VALUE '****'. 009300 05 SYS9TMEM-TABLE-ID PIC X(15) VALUE SPACES. 009400 01 SYS9TMEM-POINTER USAGE IS POINTER. 009500 01 WS-MID-POINT PIC S9(4) BINARY. 009600 01 WS-HI PIC S9(4) BINARY. 009700 01 WS-LO PIC S9(4) BINARY. 009800 LINKAGE SECTION. 009900 01 SYS9TMEM-TABLE. 010000 05 SYS9TMEM-MAX-ENTRIES PIC S9(4) BINARY. 010100 05 SYS9TMEM-LENGTH-LEFT PIC S9(4) BINARY. 010200 05 SYS9TMEM-LENGTH-RIGHT PIC S9(4) BINARY. 010300 05 SYS9TMEM-ENTRY OCCURS 1 TO 32000 TIMES 010400 DEPENDING ON SYS9TMEM-MAX-ENTRIES 010500 INDEXED BY SYS9TMEM-X. 010600 10 SYS9TMEM-LEFT. 010700 15 SYS9TMEM-LT-CHAR PIC X(01) OCCURS 1 TO 20 010800 DEPENDING ON SYS9TMEM-LENGTH-LEFT. 010900 10 SYS9TMEM-RIGHT. 011000 15 SYS9TMEM-RT-CHAR PIC X(01) OCCURS 1 TO 250 011100 DEPENDING ON SYS9TMEM-LENGTH-RIGHT. 011200* COPY SYSLTBL, BUT W/O THE VALUE CLAUSES. 011300 01 SYSTABLE-LINKAGE-AREA. 011400 05 TBL-OPERATION PIC X(08). 011500 05 TBL-PROGRAM-ID PIC X(08). 011600 05 TBL-STATUS PIC X(04). 011700 05 TBL-SYSTABLE PIC X(08). 011800 05 TBL-TABLE-ID PIC X(15). 011900 05 TBL-DIRECTION PIC X(01). 012000 05 TBL-REFERENCE. 012100 10 TBL-REF-POUND1 PIC X(01). 012200 10 FILLER PIC X(03). 012300 10 TBL-REF-POUND2 PIC X(01). 012400 01 TBL-LEFT. 012500 05 TBL-LEFT-CHAR PIC X(01) OCCURS 1 TO 20 012600 DEPENDING ON TBL-REF-LL. 012700 01 TBL-RIGHT. 012800 05 TBL-RIGHT-CHAR PIC X(01) OCCURS 1 TO 250 012900 DEPENDING ON TBL-REF-RRR. 013000 PROCEDURE DIVISION USING SYSTABLE-LINKAGE-AREA 013100 TBL-LEFT TBL-RIGHT. 013200 0000-SYSTABLE. 013300*+++ MOVE +49 TO SYSSNAP-LEN 013400*+++ CALL SYSSNAP-ID USING SYSSNAP-LEN SYSTABLE-LINKAGE-AREA 013500*+++ MOVE +20 TO SYSSNAP-LEN 013600*+++ CALL SYSSNAP-ID USING SYSSNAP-LEN SAVE-TABLE-ID 013700 ADD 1 TO ENTRY-COUNT 013800 IF ENTRY-COUNT = 1 013900 MOVE MY-PROGRAM-ID TO SYSLOAD-PROGRAM-ID 014000 MOVE 'FILEOPEN' TO SYSLOAD-FUNCTION 014100 CALL SYSLOAD-ID USING SYSLOAD-LINKAGE-AREA 014200 SET TBL-TOP TO 1 014300 SET TBL-MAX TO 50 014400 MOVE SPACES TO TABLE-OF-TABLES 014500 . 014600 MOVE '****' TO TBL-STATUS 014700 IF TABLE-FILE-STATE = 'C' 014800 OPEN INPUT TABLE-FILE 014900 IF TABLE-FILE-OK 015000 MOVE 'O' TO TABLE-FILE-STATE 015100 ELSE 015200 MOVE 'TFNO' TO TBL-STATUS 015300 DISPLAY 'SYSTABLE-FILE-STATUS=' TABLE-FILE-STATUS 015400 MOVE TABLE-FILE-STATUS TO LOG-MESSAGE-LEFT 015500 MOVE '(TABL) FILE OPEN, BAD FILE STATUS.' 015600 TO LOG-MESSAGE-TEXT-XX 015700 PERFORM 9500-CALL-SYSLOG 015800 GOBACK 015900 . 016000 IF TBL-OPERATION = 'CLOSE' 016100 IF TABLE-FILE-STATE = 'C' 016200 CLOSE TABLE-FILE 016300 END-IF 016400 MOVE 'FREE' TO SYS9TMEM-COMMANDS 016500 PERFORM 2000-DISPLAY-SEARCHES 016600 VARYING TBL-X FROM 1 BY 1 016700 UNTIL TBL-X > TBL-TOP 016800 IF TBL-PROGRAM-ID NOT = 'SYSLOAD ' 016900 MOVE 'FILECLOS' TO SYSLOAD-FUNCTION 017000 CALL SYSLOAD-ID USING SYSLOAD-LINKAGE-AREA 017100 END-IF 017200 ELSE 017300 IF TBL-OPERATION NOT = 'SEARCH' 017400 DISPLAY 'SYSTABLE--INVALID OPERATION=' TBL-OPERATION '*' 017500 ' CALLING PROG=' TBL-PROGRAM-ID 017600 ' TABLE=' TBL-TABLE-ID 017700 MOVE 'TOPN' TO TBL-STATUS 017800 MOVE TBL-OPERATION TO LOG-MESSAGE-LEFT 017900 MOVE ' TABLE OPERATION IS INVALID, MUST BE "SEARCH". ' 018000 TO LOG-MESSAGE-TEXT-XX 018100 PERFORM 9500-CALL-SYSLOG 018200 ELSE 018300 IF TBL-DIRECTION = 'R' 018400 DISPLAY 'SYSTABLE--INVALID DIRECTION=' TBL-DIRECTION '*' 018500 ' CALLING PROG=' TBL-PROGRAM-ID 018600 ' TABLE=' TBL-TABLE-ID 018700 MOVE 'TDIR' TO TBL-STATUS 018800 MOVE TBL-DIRECTION TO LOG-MESSAGE-LEFT 018900 MOVE ' TABLE DIRECTION IS INVALID, MUST BE "L" OR "R".' 019000 TO LOG-MESSAGE-TEXT-XX 019100 PERFORM 9500-CALL-SYSLOG 019200 ELSE 019300 PERFORM 1000-LOOKUP 019400 . 019500*+++ DISPLAY 'SYSTABLE-LINK=' SYSTABLE-LINKAGE-AREA 019600*+++ ' L=' TBL-REF-LL '/' TBL-LEFT 019700*+++ ' R=' TBL-REF-RRR '/' TBL-RIGHT 019800*+++ MOVE +49 TO SYSSNAP-LEN 019900*+++ CALL SYSSNAP-ID USING SYSSNAP-LEN SYSTABLE-LINKAGE-AREA 020000*+++ MOVE +20 TO SYSSNAP-LEN 020100*+++ CALL SYSSNAP-ID USING SYSSNAP-LEN SAVE-TABLE-ID 020200 GOBACK 020300 . 020400 1000-LOOKUP. 020500 IF TBL-TABLE-ID = SAVE-TABLE-ID 020600 AND TBL-REFERENCE = SAVE-REFER 020700 PERFORM 1100-TABLE-LOOKUP 020800 ELSE 020900 MOVE TBL-REFERENCE TO SAVE-REFER 021000 PERFORM 1200-SET-TBL-REFER 021100 IF TBL-STATUS = '****' 021200 AND TBL-TABLE-ID = TABLE-TABLE-ID (TBL-X) 021300 MOVE TBL-TABLE-ID TO SAVE-TABLE-ID 021400 MOVE TABLE-REFER (TBL-X) TO SAVE-REFER 021500 TBL-REFERENCE 021600 PERFORM 1200-SET-TBL-REFER 021700*+++ DISPLAY 'SYSTABLE-RESET, INDEX=' TBL-REF-INDEX 021800*+++ ' L=' TBL-REF-LL 021900*+++ ' R=' TBL-REF-RRR 022000*+++ ' T=' TABLE-TABLE-ID (TBL-X) 022100 PERFORM 1100-TABLE-LOOKUP 022200 ELSE 022300 MOVE 'LOOK' TO TBL-STATUS 022400 SET TBL-X TO 1 022500 PERFORM 1500-LOOK-FOR-TABLE 022600 UNTIL TBL-STATUS NOT = 'LOOK' 022700 OR TBL-X > TBL-MAX 022800*+++ DISPLAY 'SYSTABLE-RESET, NAMEX=' TBL-REF-INDEX 022900*+++ ' L=' TBL-REF-LL 023000*+++ ' R=' TBL-REF-RRR 023100*+++ ' T=' TABLE-TABLE-ID (TBL-X) 023200 PERFORM 1100-TABLE-LOOKUP 023300 . 023400 1100-TABLE-LOOKUP. 023500*+++ SET DISPLAY-TBL-X TO TBL-X 023600*+++ DISPLAY 'SEARCHING: ' TBL-TABLE-ID '/' TBL-LEFT 023700*+++ '=' DISPLAY-TBL-X 023800*+++ DISPLAY 'SYS9TMEM=' SYS9TMEM-MAX-ENTRIES '/' 023900*+++ SYS9TMEM-LENGTH-LEFT '/' 024000*+++ SYS9TMEM-LENGTH-RIGHT '/' 024100*+++ SYS9TMEM-ENTRY (1) '*' 024200 IF TBL-STATUS = '****' 024300 IF TABLE-POINTER (TBL-X) NOT = NULL 024400 PERFORM 1120-SEARCH 024500 ELSE 024600 MOVE TBL-TABLE-ID TO TABLE-NAME 024700 MOVE 'E' TO TABLE-RECORD-CODE 024800 MOVE TBL-LEFT TO TABLE-LEFT 024900 MOVE SPACES TO TABLE-RIGHT 025000 PERFORM 9100-READ-TABLE-RANDOM 025100 IF TABLE-FILE-OK 025200 ADD 1 TO TABLE-SEARCHES (TBL-X) 025300 MOVE TABLE-RIGHT TO TBL-RIGHT 025400 ELSE 025500 PERFORM 1130-TRNF 025600 . 025700 1120-SEARCH. 025800 COMPUTE WS-HI = SYS9TMEM-MAX-ENTRIES 025900 COMPUTE WS-LO = 1 026000 PERFORM UNTIL WS-HI < WS-LO 026100 COMPUTE WS-MID-POINT = (WS-LO + WS-HI) / 2 026200 SET SYS9TMEM-X TO WS-MID-POINT 026300*+++ DISPLAY 'SEARCH: ' WS-MID-POINT '/' WS-LO '/' WS-HI 026400*+++ '/' TBL-LEFT '/' SYS9TMEM-LEFT (SYS9TMEM-X) 026500 IF TBL-LEFT < SYS9TMEM-LEFT (SYS9TMEM-X) 026600 COMPUTE WS-HI = WS-MID-POINT - 1 026700 ELSE 026800 IF TBL-LEFT > SYS9TMEM-LEFT (SYS9TMEM-X) 026900 COMPUTE WS-LO = WS-MID-POINT + 1 027000 ELSE 027100 COMPUTE WS-LO = WS-HI + 1 027200 END-IF END-IF 027300 END-PERFORM 027400 IF TBL-LEFT = SYS9TMEM-LEFT (SYS9TMEM-X) 027500 MOVE SYS9TMEM-RIGHT (SYS9TMEM-X) TO TBL-RIGHT 027600 ADD 1 TO TABLE-SEARCHES (TBL-X) 027700 ELSE 027800 PERFORM 1130-TRNF 027900 . 028000 1130-TRNF. 028100 MOVE 'TRNF' TO TBL-STATUS 028200 MOVE TBL-LEFT TO LOG-MESSAGE-LEFT 028300 MOVE ' TABLE RECORD NOT FOUND' TO LOG-MESSAGE-TEXT-XX 028400 PERFORM 9500-CALL-SYSLOG 028500 . 028600 1200-SET-TBL-REFER. 028700 IF SAVE-REF-POUND1 = '#' 028800 AND SAVE-REF-POUND2 = '#' 028900 MOVE SAVE-REF-INDEX TO TBL-REF-INDEX-1 029000 MOVE SAVE-REF-LL TO TBL-REF-LL-1 029100 MOVE SAVE-REF-RRR TO TBL-REF-RRR-1 029200 ELSE 029300 MOVE '*REF' TO TBL-STATUS 029400 SET TBL-REF-INDEX TO TBL-MAX 029500 MOVE 1 TO TBL-REF-LL 029600 MOVE 1 TO TBL-REF-RRR 029700 . 029800 SET TBL-X TO TBL-REF-INDEX 029900 IF TABLE-POINTER (TBL-X) NOT = NULL 030000 SET ADDRESS OF SYS9TMEM-TABLE TO TABLE-POINTER (TBL-X) 030100 . 030200 1500-LOOK-FOR-TABLE. 030300 IF SPACES = TABLE-TABLE-ID (TBL-X) 030400 PERFORM 1600-READ-TABLE-HEADER 030500 ELSE 030600 IF TBL-TABLE-ID = TABLE-TABLE-ID (TBL-X) 030700 MOVE '****' TO TBL-STATUS 030800 MOVE TABLE-TABLE-ID (TBL-X) TO SAVE-TABLE-ID 030900 MOVE TABLE-REFER (TBL-X) TO SAVE-REFER 031000 TBL-REFERENCE 031100 PERFORM 1200-SET-TBL-REFER 031200 ELSE 031300 SET TBL-X UP BY 1 031400 . 031500 1600-READ-TABLE-HEADER. 031600 MOVE 'READ ' TO SYS9TMEM-FUNCTION 031700 MOVE TBL-TABLE-ID TO SYS9TMEM-TABLE-ID 031800 CALL SYS9TMEM-ID USING SYS9TMEM-COMMANDS SYS9TMEM-POINTER 031900 IF SYS9TMEM-STATUS = 'TFNF' 032000 PERFORM 1610-READ-VSAM-HEADER 032100 ELSE 032200 IF SYS9TMEM-STATUS NOT = '****' 032300 MOVE SYS9TMEM-STATUS TO TBL-STATUS 032400 MOVE 1 TO TBL-REF-LL 032500 MOVE 1 TO TBL-REF-RRR 032600 MOVE 'X' TO SAVE-TABLE-ID 032700 MOVE SPACES TO TBL-REFERENCE 032800 ELSE 032900 MOVE SYS9TMEM-STATUS TO TBL-STATUS 033000 SET ADDRESS OF SYS9TMEM-TABLE TO SYS9TMEM-POINTER 033100 MOVE TBL-TABLE-ID TO TABLE-TABLE-ID (TBL-X) 033200 SET TBL-TOP TO TBL-X 033300 MOVE ZEROES TO TABLE-SEARCHES (TBL-X) 033400 SET TBL-REF-INDEX TO TBL-X 033500 MOVE SYS9TMEM-LENGTH-LEFT TO TBL-REF-LL 033600 MOVE SYS9TMEM-LENGTH-RIGHT TO TBL-REF-RRR 033700 MOVE TBL-TABLE-ID TO SAVE-TABLE-ID 033800 MOVE '#' TO SAVE-REF-POUND1 SAVE-REF-POUND2 033900 MOVE TBL-REF-INDEX-1 TO SAVE-REF-INDEX 034000 MOVE TBL-REF-LL-1 TO SAVE-REF-LL 034100 MOVE TBL-REF-RRR-1 TO SAVE-REF-RRR 034200 MOVE SAVE-REFER TO TABLE-REFER (TBL-X) 034300 TBL-REFERENCE 034400 SET TABLE-POINTER (TBL-X) TO SYS9TMEM-POINTER 034500*+++ DISPLAY 'LOADED: ' SAVE-TABLE-ID 034600 . 034700 1610-READ-VSAM-HEADER. 034800 MOVE '****' TO TBL-STATUS 034900 MOVE TBL-TABLE-ID TO TABLE-NAME 035000 MOVE 'A' TO TABLE-RECORD-CODE 035100 MOVE SPACES TO TABLE-LEFT 035200 PERFORM 9100-READ-TABLE-RANDOM 035300 IF TABLE-FILE-OK 035400 MOVE TBL-TABLE-ID TO TABLE-TABLE-ID (TBL-X) 035500 SET TBL-TOP TO TBL-X 035600 MOVE ZEROES TO TABLE-SEARCHES (TBL-X) 035700 SET TBL-REF-INDEX TO TBL-X 035800 MOVE TABLA012-LEFT-SIDE-LENGTH TO TBL-REF-LL 035900 MOVE TABLA013-RIGHT-SIDE-LENGTH TO TBL-REF-RRR 036000*+++ DISPLAY 'SYSTABLE-LEFT=' 036100*+++ TABLA012-LEFT-SIDE-LENGTH 036200*+++ ' RIGHT=' 036300*+++ TABLA013-RIGHT-SIDE-LENGTH 036400 MOVE TBL-TABLE-ID TO SAVE-TABLE-ID 036500 MOVE '#' TO SAVE-REF-POUND1 SAVE-REF-POUND2 036600 MOVE TBL-REF-INDEX-1 TO SAVE-REF-INDEX 036700 MOVE TBL-REF-LL-1 TO SAVE-REF-LL 036800 MOVE TBL-REF-RRR-1 TO SAVE-REF-RRR 036900 MOVE SAVE-REFER TO TABLE-REFER (TBL-X) 037000 TBL-REFERENCE 037100 SET TABLE-POINTER (TBL-X) TO NULL 037200 ELSE 037300 MOVE 1 TO TBL-REF-LL 037400 MOVE 1 TO TBL-REF-RRR 037500 MOVE 'TFNF' TO TBL-STATUS 037600 MOVE ' TABLE FILE-- NOT FOUND' 037700 TO LOG-MESSAGE-TEXT 037800 PERFORM 9500-CALL-SYSLOG 037900 MOVE 'X' TO SAVE-TABLE-ID 038000 MOVE SPACES TO TBL-REFERENCE 038100 . 038200 2000-DISPLAY-SEARCHES. 038300 MOVE ALL '*SEARCH=' TO LOG-MESSAGE-CALLING-ID 038400 MOVE TABLE-SEARCHES (TBL-X) TO LOG-MESSAGE-ENTRY-COUNT 038500 MOVE TABLE-TABLE-ID (TBL-X) TO LOG-MESSAGE-TABLE-ID 038600 MOVE ' TABLE SEARCHES PERFORMED FOR TABLE.' 038700 TO LOG-MESSAGE-TEXT 038800 MOVE MY-PROGRAM-ID TO LOG-PROGRAM-ID 038900 MOVE TBL-STATUS TO LOG-STATUS 039000 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 039100 IF TABLE-POINTER (TBL-X) NOT = NULL 039200 CALL SYS9TMEM-ID USING SYS9TMEM-COMMANDS 039300 TABLE-POINTER (TBL-X) 039400 . 039500 MOVE SPACES TO TABLE-ENTRY (TBL-X) 039600 . 039700 9100-READ-TABLE-RANDOM. 039800 READ TABLE-FILE RECORD 039900 IF NOT TABLE-FILE-OK 040000 IF TABLE-FILE-STATUS NOT = '23' 040100 DISPLAY 'SYSTABLE-FILE-STATUS=' TABLE-FILE-STATUS 040200 ' KEY=' TABLE-KEY 040300 . 040400 9500-CALL-SYSLOG. 040500 MOVE MY-PROGRAM-ID TO LOG-PROGRAM-ID 040600 MOVE TBL-PROGRAM-ID TO LOG-MESSAGE-CALLING-ID 040700 MOVE ENTRY-COUNT TO LOG-MESSAGE-ENTRY-COUNT 040800 MOVE TBL-STATUS TO LOG-STATUS 040900 MOVE TBL-TABLE-ID TO LOG-MESSAGE-TABLE-ID 041000 CALL SYSLOG-ID USING LOG-LINKAGE-AREA 041100 . 041200 END PROGRAM SYSTABLE. -END
SYSLTBLR -ADD SYSLTBLR,PSWD=40EF,ARC,SEQ=/1,6,100,100/ -DESC COBOL-LE SYSLTBL W/ REPLACE -PGMR RYDER JSR SYSTEMS -LANG COB 000000 01 :TBL:LINKAGE-AREA. SYSLTBLR 000100 05 :TBL:OPERATION PICTURE X(8) VALUE 'SEARCH'. 01/04/99 000200 88 :TBL:OPERATION-IS-BINARY-SEARCH VALUE 'SEARCH'. SYSLTBLR 000300 88 :TBL:OPERATION-IS-SERIAL-SEARCH VALUE IS 'SCAN'. SYSLTBLR 000400 88 :TBL:OPERATION-IS-READ-NEXT VALUE IS 'READ'. SYSLTBLR 000500 88 :TBL:OPERATION-IS-CLOSE-TABLE VALUE IS 'CLOSE'.SYSLTBLR 000600 05 :TBL:PROGRAM-ID PICTURE X(8) VALUE IS SPACES. SYSLTBLR 000700 05 :TBL:STATUS PICTURE X(4) VALUE IS SPACES. SYSLTBLR 000800 88 :TBL:SUCCESSFUL-COMPLETION VALUE IS '****'. SYSLTBLR 000810 88 :TBL:RECORD-NOT-FOUND VALUE IS 'TRNF'. SYSLTBLR 000900 05 :TBL:SYSTABLE PICTURE X(8) VALUE 'SYSTABLE'.SYSLTBLR 001000 05 :TBL:TABLE-ID PICTURE X(15) VALUE IS SPACES. SYSLTBLR 001100 05 :TBL:DIRECTION PICTURE X VALUE IS SPACE. SYSLTBLR 001200 88 :TBL:DIRECTION-IS-LEFT-TO-RIGHT VALUE IS SPACE SYSLTBLR 001300 'L'. SYSLTBLR 001400 88 :TBL:DIRECTION-IS-RIGHT-TO-LEFT VALUE IS 'R'. SYSLTBLR 001500 05 :TBL:REFERENCE PICTURE X(5) VALUE IS SPACES. SYSLTBLR -END
//TECOBCPL PROC SYSTEM=COB, // PROPT='***', ***=SHORT LIST, ALL, OR ERR Sets option for printer exit. // LISTOUT='*', // LC=60, LINECOUNT(52) COB LINES PER PAGE // OPTION=, // MAP=MAP, // DEST=LOCAL, // CLC=60, // LNKOPT='MAP,LET,LIST,REUS,RMODE(24),AMODE(24)', // SYSLBLK=3200, // LIB= SYSLMOD LIBRARY (USE APPL LIB) //COBOL EXEC PGM=COB0COPY //STEPLIB DD DSN=USERTEA.SYS3.SYSLIB,DISP=SHR //OSJOB DD DISP=(NEW,PASS),UNIT=VIO,SPACE=(CYL,(1,1)),DSN=&&SOURCE //LIBIN DD DISP=(NEW,PASS),UNIT=VIO,SPACE=(CYL,(1,1)),DSN=&&LIBIN //CARDS DD DDNAME=SOURCE //SOURCE DD DDNAME=SYSIN COB0COPY sets RC depending on -SEL or not. // IF RC EQ 0 THEN //LIBRUN EXEC PGM=AFOLIBR, // PARM='NJTA,NRJS,LINES=&LC,IEX=SYSXADR1,OEX=SYSXADR5' //MASTER DD DISP=SHR,DSN=USERTEA.SYS1.ADR.&SYSTEM.LIB //SYSPRINT DD SYSOUT=&LISTOUT,DCB=RECFM=FBA //LIST DD DUMMY //INDEX DD DUMMY //OSJOB DD DISP=(OLD,PASS),UNIT=VIO,SPACE=(CYL,(1,1)),DSN=&&SOURCE //SYSIN DD DISP=(OLD,PASS),DSN=&&LIBIN // ENDIF // IF RC LT 8 THEN //******************************************************************** //COBV0ERR EXEC PGM=COBV0ERR //STEPLIB DD DSN=USERTEA.SYS3.SYSLIB,DISP=SHR //SYSOUA DD SYSOUT=* //COBIPT DD DSN=&&SOURCE,DISP=(OLD,PASS) This lists most potential errors, all in one place. //******************************************************************** //* COMPILE AND LINK EDIT A COBOL PROGRAM //COBOLCC EXEC PGM=IGYCRCTL,REGION=2048K, // PARM='&MAP,OUTDD(SYSOUA),LINECOUNT(&CLC), // EXIT(PRTX(''&PROPT'',COBV9PRT)),&OPTION' //STEPLIB DD DISP=SHR,DSN=USERTEA.SYS3.SYSLIB //SYSPRINT DD SYSOUT=* //SYSOUA DD SYSOUT=* //PRINT DD SYSOUT=*,DEST=&DEST //SYSOUT DD DUMMY W/PRTX COMPILER GENERATES ONE BLANK LINE //SYSIN DD DSN=&&SOURCE,DISP=(OLD,DELETE) //LIBIN DD DSN=&&LIBIN,DISP=(OLD,DELETE) //SYSLIN DD DSNAME=&&LOADSET,UNIT=VIO, // DISP=(MOD,PASS),SPACE=(TRK,(3,3)), // DCB=(BLKSIZE=&SYSLBLK) //SYSLIB DD DISP=SHR,DSN=USERTEA.SYS3.COPYLIB //SYSUT1 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT2 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT3 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT4 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT5 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT6 DD UNIT=VIO,SPACE=(CYL,(1,1)) //SYSUT7 DD UNIT=VIO,SPACE=(CYL,(1,1)) // IF RC LT 8 THEN //OBJADD EXEC PGM=COB0LINK STEP ADDS INCLUDE CEEUOPT + SETSSI //STEPLIB DD DSN=USERTEA.SYS3.SYSLIB,DISP=SHR //OBJIN DD DSN=&&LOADSET,DISP=(OLD,DELETE) //OBJOUT DD DSNAME=&&LOADOBJ,UNIT=VIO,DISP=(NEW,PASS), // DCB=(BLKSIZE=&SYSLBLK),SPACE=(TRK,(3,3)) Adds INCLUDE CEEUOPT and SETSSI yyyymmdd. //LKED EXEC PGM=HEWL,REGION=1M,PARM=(&LNKOPT) //SYSLIB DD DISP=SHR,DSN=CEE.SCEELKED // DD DISP=SHR,DSN=USERTEA.SYS3.&LIB // DD DISP=SHR,DSN=USERTEA.SYS3.SYSLIB //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(10,10)) //SYSPRINT DD SYSOUT=*,DEST=&DEST //SYSLIN DD DSNAME=&&LOADOBJ,DISP=(OLD,DELETE) //SYSLMOD DD DISP=SHR,DSN=USERTEA.SYS3.&LIB // ENDIF // ENDIF //******************************************************************** That's All Folks! Return to title page.