COBOL TIPS #22
by
Shawn M. Gordon
President S.M.Gordon & Associates
In the process of cleaning up my house for the new baby, I ran across some of the first COBOL code I had ever written on the HP 3000, and believe it or not, it’s actually useful. I was to embarrassed to publish it in it’s total original form, so I cleaned it up a little bit for the column.
Basically what this program does is read through a COBOL copylib, and generates a nice little report. Each copy member has a header, and if it is continued from another page, the header will say (CONT). Each page is numbered, and at the end of a report and index is generated that tells you what page each copy member begins on. Here is the source code;
1 $CONTROL USLINIT,BOUNDS 1.1 IDENTIFICATION DIVISION. 1.2 PROGRAM-ID. PRINTCL. 1.3 * 1.4 *********************************************** 1.5 * Program creates indexed and paged output for 1.6 * a COBOL copy library. 1.7 *********************************************** 1.8 * 1.9 AUTHOR. Shawn M. Gordon. 2 INSTALLATION. SMGA. 2.1 DATE-WRITTEN. MON, JUL 24, 1995. 2.2 DATE-COMPILED. 2.3 ENVIRONMENT DIVISION. 2.4 CONFIGURATION SECTION. 2.5 SOURCE-COMPUTER. HP-3000. 2.6 OBJECT-COMPUTER. HP-3000. 2.7 INPUT-OUTPUT SECTION. 2.8 FILE-CONTROL. 2.9 SELECT INFILE ASSIGN TO DUMMY USING WS-COPYLIB. 3 SELECT OUTFILE ASSIGN TO "PRINTCL,,,LP(CCTL)". 3.1 DATA DIVISION. 3.2 FILE SECTION. 3.3 FD INFILE 3.4 RECORD CONTAINS 86 CHARACTERS. 3.5 01 INFILE-RECORD. 3.6 03 IR-COBOL-CODE PIC X(72). 3.7 03 IR-COPY-NAME PIC X(08). 3.8 03 PIC X(06). 3.9 4 FD OUTFILE 4.1 RECORD CONTAINS 80 CHARACTERS. 4.2 01 OUTFILE-RECORD PIC X(80). 4.3 4.4 WORKING-STORAGE SECTION. 4.5 4.6 01 S1 PIC S9(4) COMP VALUE 0. 4.7 01 PAGE-COUNT PIC 9(04) VALUE ZEROES. 4.8 01 LINE-COUNT PIC S9(4) COMP VALUE 0. 4.9 01 WS-COPYLIB PIC X(26) VALUE SPACES. 5 01 SAVE-NAME PIC X(08) VALUE SPACES. 5.1 01 BLANK-LINE PIC X(80) VALUE SPACES. 5.2 5.3 ******** OUTPUT RECORD 5.4 5.5 01 CODE-LINE. 5.6 03 PIC X(04) VALUE SPACES. 5.7 03 CL-COBOL-CODE PIC X(72) VALUE SPACES. 5.8 03 PIC X(04) VALUE SPACES. 5.9 6 01 COPYLIB-TITLE. 6.1 03 PIC X(36) VALUE SPACES. 6.2 03 CT-COPY-NAME PIC X(08) VALUE SPACES. 6.3 03 CT-CONTINUE PIC X(08) VALUE SPACES. 6.4 03 PIC X(09) VALUE " PAGE: ". 6.5 03 CT-PAGE-NO PIC ZZZ9. 6.6 03 PIC X(15) VALUE SPACES. 6.7 6.8 01 INDEX-PAGE. 6.9 03 PIC X(06) VALUE SPACES. 7 03 IP-COPY-NAME PIC X(08) VALUE SPACES. 7.1 03 PIC X(35) VALUE ALL ".". 7.2 03 IP-PAGE-NO PIC ZZZ9. 7.3 03 PIC X(22) VALUE SPACES. 7.4 7.5 01 INDEX-TITLE. 7.6 03 PIC X(27) VALUE SPACES. 7.7 03 PIC X(05) VALUE "INDEX". 7.8 03 PIC X(12) VALUE SPACES. 7.9 03 PIC X(06) VALUE "PAGE: ". 8 03 PIC X VALUE "I". 8.1 03 IT-PAGE-NO PIC ZZ9. 8.2 03 PIC X(27) VALUE SPACES. 8.3 8.4 01 INDEX-TABLE. 8.5 03 IX-FORMAT-INDEX OCCURS 1000. 8.6 05 FI-COPY-NAME PIC X(08). 8.7 05 FI-PAGE-NO PIC 9(04). 8.8 8.9 PROCEDURE DIVISION. 9 A1000-INIT. 9.1 DISPLAY 'Begin run of PRINTCL @ ' TIME-OF-DAY. 9.2 DISPLAY 'Enter COPYLIB file name to process: ' 9.3 NO ADVANCING. 9.4 ACCEPT WS-COPYLIB FREE. 9.5 IF WS-COPYLIB = SPACES 9.6 DISPLAY 'Early termination of PRINTCL @ ' TIME-OF-DAY 9.7 STOP RUN. 9.8 9.9 OPEN INPUT INFILE 10 OUTPUT OUTFILE. 10.1 MOVE SPACES TO INDEX-TABLE. 10.2 10.3 A1100-READ. 10.4 READ INFILE 10.5 AT END 10.6 GO TO B1000-INDEX. 10.7 10.8 MOVE IR-COBOL-CODE TO CL-COBOL-CODE. 10.9 MOVE IR-COPY-NAME TO SAVE-NAME. 11 IF SAVE-NAME <> CT-COPY-NAME OR LINE-COUNT > 56 11.1 PERFORM C1000-HEADER THRU C1000-EXIT. 11.2 WRITE OUTFILE-RECORD FROM CODE-LINE 11.3 AFTER ADVANCING 1 LINE. 11.4 ADD 1 TO LINE-COUNT. 11.5 GO TO A1100-READ. 11.6 A1100-EXIT. EXIT. 11.7 * 11.8 B1000-INDEX. 11.9 MOVE ZEROES TO PAGE-COUNT. 12 MOVE 60 TO LINE-COUNT. 12.1 PERFORM VARYING S1 FROM 1 BY 1 UNTIL 12.2 FI-COPY-NAME(S1) = SPACES 12.3 MOVE FI-COPY-NAME(S1) TO IP-COPY-NAME 12.4 MOVE FI-PAGE-NO (S1) TO IP-PAGE-NO 12.5 PERFORM C2100-IDETAIL THRU C2100-EXIT 12.6 END-PERFORM. 12.7 GO TO C9000-EOJ. 12.8 B1000-EXIT. EXIT. 12.9 * 13 C1000-HEADER. 13.1 ADD 1 TO PAGE-COUNT. 13.2 IF SAVE-NAME = CT-COPY-NAME 13.3 MOVE " (CONT)" TO CT-CONTINUE 13.4 ELSE 13.5 MOVE SPACES TO CT-CONTINUE 13.6 ADD 1 TO S1 13.7 MOVE PAGE-COUNT TO FI-PAGE-NO(S1) 13.8 MOVE SAVE-NAME TO FI-COPY-NAME(S1). 13.9 14 MOVE PAGE-COUNT TO CT-PAGE-NO. 14.1 MOVE SAVE-NAME TO CT-COPY-NAME. 14.2 WRITE OUTFILE-RECORD FROM COPYLIB-TITLE 14.3 AFTER ADVANCING PAGE. 14.4 WRITE OUTFILE-RECORD FROM BLANK-LINE 14.5 AFTER ADVANCING 2 LINES. 14.6 MOVE 0 TO LINE-COUNT. 14.7 C1000-EXIT. EXIT. 14.8 * 14.9 C2000-IHEADER. 15 MOVE 0 TO LINE-COUNT. 15.1 ADD 1 TO PAGE-COUNT. 15.2 MOVE PAGE-COUNT TO IT-PAGE-NO. 15.3 WRITE OUTFILE-RECORD FROM INDEX-TITLE 15.4 AFTER ADVANCING PAGE. 15.5 WRITE OUTFILE-RECORD FROM BLANK-LINE 15.6 AFTER ADVANCING 2 LINES. 15.7 C2000-EXIT. 15.8 * 15.9 C2100-IDETAIL. 16 ADD 2 TO LINE-COUNT. 16.1 IF LINE-COUNT > 54 16.2 PERFORM C2000-IHEADER THRU C2000-EXIT. 16.3 WRITE OUTFILE-RECORD FROM INDEX-PAGE 16.4 AFTER ADVANCING 2 LINES. 16.5 C2100-EXIT. EXIT. 16.6 * 16.7 C9000-EOJ. 16.8 CLOSE INFILE 16.9 OUTFILE. 17 DISPLAY 'Normal termination of PRINTCL @ ' TIME-OF-DAY. 17.1 STOP RUN.
The only things that are even marginally complicated, is using a dynamic variable to determine what copylib file to open. Other than that, we just have some straight forward control breaks and such. Here is an example of the output that is generated.
DBMACROS PAGE: 5
001000*
001100* !1 = variable with data base name
001200* !2 = db open mode.
001300$DEFINE %DBOPEN=
001400 CALL "DBOPEN" USING !1, DB-PASS-WORD,
001500 !2, DB-STATUS-AREA#
001600*
001700* !1 = data base variable
001800* !2 = data set variable
001900* !3 = data set search item
002000* !4 = search item argument
002100$DEFINE %DBFIND=
002200 CALL "DBFIND" USING !1, !2,
002300 DB-MODE-1, DB-STATUS-AREA
002400 !3
002500 !4#
002600*
002700* !1 = data base variable
002800* !2 = data set variable
002900* !3 = get mode
003000* !4 = buffer to hold record returned
003100* !5 = search item argument
003200$DEFINE %DBGET=
003300 CALL "DBGET" USING !1, !2,
003400 !3, DB-STATUS-AREA,
003500 DB-LIST-ALL,
003600 !4,
003700 !5#
003800*
003900* !1 = data base variable
004000* !2 = data set variable
004100* !3 = buffer to be updated in data set
004200$DEFINE %DBUPDATE=
004300 CALL "DBUPDATE" USING !1, !2,
004400 DB-MODE-1, DB-STATUS-AREA,
004500 DB-LIST-ALL,
004600 !3#
004700*
004800* !1 = data base variable
004900* !2 = data set variable
005000* !3 = buffer to be put in data set
005100$DEFINE %DBPUT=
005200 CALL "DBPUT" USING !1, !2,
005300 DB-MODE-1, DB-STATUS-AREA,
005400 DB-LIST-ALL,
005500 !3
005600 IF DB-CONDITION-WORD = 16
005700 DISPLAY '!!!! DATA SET IS FULL !!!!'
005800 CALL "DBEXPLAIN" USING DB-STATUS-AREA
005900 END-IF#
006000*
006100* !1 = data base variable
006200* !2 = data set variable
006300$DEFINE %DBDELETE=
006400 CALL "DBDELETE" USING !1, !2,
006500 DB-MODE-1, DB-STATUS-AREA#
006600*
DBMACROS (CONT) PAGE: 6
006700* !1 = data base variable
006800* !2 = data set variable
006900$DEFINE %DBLOCK=
007000 CALL "DBLOCK" USING !1, !2,
007100 DB-MODE-3, DB-STATUS-AREA#
007200*
007300* !1 = data base variable
007400* !2 = data set variable
007500$DEFINE %DBUNLOCK=
007600 CALL "DBUNLOCK" USING !1, !2,
007700 DB-MODE-1, DB-STATUS-AREA#
INDEX PAGE: I 1
BBSDB ................................... 1
DBCALLS ................................... 3
DBMACROS................................... 5
DBSTAT ................................... 8
EZQK ................................... 9
FYIDB ................................... 10
PIMDB ................................... 14
TRACE ................................... 15
TREND ................................... 16
I think that you might find this month’s project pretty generically useful. I want to make a final point about backing up your systems. I have had this dumb little program laying around for more years than I care to mention, but I have had to retype it about 5 times because I keep loosing the source code on the machine, fortunatly I still have the original printout from when I first wrote it. I recently lost a very critical piece of source code, and I am now going to have to rewrite it from scratch because there are no print outs. Ironically the day I noticed it was gone, was the day I was getting set to do a back up. So always backup your work, you’ll be glad you did.