cobol42

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 embaressed 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 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.