*DECK     DCCBL320
00001  IDENTIFICATION DIVISION.                                         09/27/78
       PROGRAM-ID. CBL320.
*CALL COPYRIGHT 
      *    THIS MODULE GENERATES FD ENTRIES FOR COBOL 
00008  ENVIRONMENT DIVISION.                                               CL**2
00009  CONFIGURATION SECTION.                                              CL**2
       SOURCE-COMPUTER. CYBER.
       OBJECT-COMPUTER. CYBER.
00012  DATA DIVISION.                                                      CL**2
00013  FILE SECTION.                                                       CL**2
*CALL GENCS 
*CALL     WRKSTG77                                                         CL**4
*CALL     MAST1WS                                                          CL**4
*CALL     CBL20DAT                                                         CL**2
*CALL     GEN20DAT                                                         CL**4
*CALL     TESTWACOM                                                        CL**4
*CALL DCDWA13 
*CALL     DCDWA20                                                          CL**4
*CALL     CBLDEF                                                           CL**2
       01  SAVE-ELE-STC-FILL-LEN       PICTURE X(4).
00022                                                                    DCCBL32
00026                                                                    DCCBL32
00027  PROCEDURE DIVISION.                                                 CL**2
00031 *********************************************************            CL**2
00032 *********************************************************            CL**2
00033 *                                                                    CL**2
00034 *    CHECK FOR RETURNS FROM CALLING MODULE AFTER I/O REQUEST         CL**2
00035 *                                                                    CL**2
00036 *********************************************************            CL**2
00037 *********************************************************            CL**2
00038  0000-BEGIN.                                                         CL**2
00039      IF GTBL-MOD-REQ EQUAL "1"                                       CL**2
00040          GO TO DATA-READ-RETURN.                                     CL**2
00041      IF GTBL-MOD-REQ EQUAL "4"                                       CL**2
00042          GO TO CBL-OUT-RETURN.                                       CL**2
00043 ******************************************************************   CL**2
00044 ******************************************************************   CL**2
00045 *                                                                    CL**2
00046 *     INITIALIZATION                                                 CL**2
00047 *                                                                    CL**2
00048 ******************************************************************   CL**2
00049 ******************************************************************   CL**2
00050      MOVE "N" TO MSG-SWITCH.                                         CL**2
00052      MOVE SPACES TO DATA-ARG-LIST.                                   CL**2
00053      MOVE SPACES TO DATA-LAST-ENTRY-NAME.                            CL**2
00054      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00055      MOVE GTBL-SEL-CNAME TO DATA-ENTRY-NAME.                         CL**2
00056      MOVE NAME-CAT-NO TO DATA-ENTRY-CAT.                             CL**2
00057      PERFORM READ-CATEGORY THRU READ-CATEGORY-XIT.                   CL**2
00058      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00059          MOVE DATA-ENTRY-NAME TO WS-DATA-NAME                        CL**2
00060          GO TO 0050-CBL20.                                           CL**2
00061      PERFORM CHECK-COMMENT THRU CHECK-COMMENT-XIT.                   CL**2
00062      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00063          MOVE DATA-ENTRY-NAME TO WS-DATA-NAME                        CL**2
00064          GO TO 0050-CBL20.                                           CL**2
00065      IF NAME-FILE-FD EQUAL SPACE                                     CL**2
00066          MOVE DATA-ENTRY-NAME TO WS-DATA-NAME                        CL**2
00067      ELSE                                                            CL**2
00068          MOVE NAME-FILE-FD TO WS-DATA-NAME.                          CL**2
00069  0050-CBL20.                                                         CL**2
00070      IF GTBL-OPT-FDNAME NOT EQUAL TO SPACES                          CL**2
00071          MOVE GTBL-OPT-FDNAME TO WS-DATA-NAME.                       CL**2
00072      PERFORM INSERT-PREFIX THRU INSERT-PREFIX-XIT.                   CL**2
00073      MOVE WORK-DATA-NAME TO CBL-FDNAME.                              CL**2
00074      MOVE FDKW TO CBL-FD.                                            CL**2
00075      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00076      PERFORM CBL-OUT THRU CBL-OUT-XIT.                            DCCBL320
00077      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00078 ******************************************************************   CL**2
00079 *     FORMAT FD ATTRIBUTES                                       *   CL**2
00080 ******************************************************************   CL**2
00081      MOVE ATTR-CAT-NO TO DATA-ENTRY-CAT.                             CL**2
00082      PERFORM READ-CATEGORY THRU READ-CATEGORY-XIT.                   CL**2
00083      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00084          GO TO 1000-CBL20.                                           CL**2
00085      PERFORM CHECK-COMMENT THRU CHECK-COMMENT-XIT.                   CL**2
00086      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00087          GO TO 1000-CBL20.                                           CL**2
00088 ******************************************************************   CL**2
00089 *     OUTPUT RECORD CONTAINS CLAUSE                              *   CL**2
00090 ******************************************************************   CL**2
00091      MOVE RECKW1 TO CBL-REC.                                      DCCBL320
00092      MOVE RECKW2 TO CBL-RECCHAR.                                  DCCBL320
00093      IF ATTR-FILE-RECSIZE EQUAL SPACE                             DCCBL320
00094          MOVE ZERO TO CBL-RECSIZE                                 DCCBL320
00095      ELSE MOVE ATTR-FILE-RECSIZE TO CBL-RECSIZE.                  DCCBL320
00096      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00097      PERFORM CBL-OUT THRU CBL-OUT-XIT.                            DCCBL320
00098      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00109 ******************************************************************   CL**2
00110 *     OUTPUT LABEL CLAUSE                                        *   CL**2
00111 ******************************************************************   CL**2
00112  0100-CBL20.                                                         CL**2
00113      IF ATTR-FILE-LABEL EQUAL "SL"                                   CL**2
00114          MOVE LABELKW1 TO CBL-LABEL                                  CL**2
00115      ELSE MOVE LABELKW2 TO CBL-LABEL.                                CL**2
00116      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00117      PERFORM CBL-OUT THRU CBL-OUT-XIT.                            DCCBL320
00118      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00119 ******************************************************************   CL**2
00120 *     OUTPUT BLOCKSIZE CLAUSE                                    *   CL**2
00121 ******************************************************************   CL**2
00123      IF ATTR-FILE-BLKSIZE EQUAL SPACE                             DCCBL320
               GO TO 1000-CBL20 
00125      ELSE MOVE ATTR-FILE-BLKSIZE TO CBL-BLKSIZE.                  DCCBL320
           MOVE BLKKW1 TO CBL-BLK.
00126      MOVE RECKW2 TO CBL-BLKCHAR.                                     CL**2
00127      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00128      PERFORM CBL-OUT THRU CBL-OUT-XIT.                               CL**2
00129      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00130      GO TO 1000-CBL20.                                               CL**2
00131                                                                    DCCBL32
00132 ******************************************************************   CL**2
00133 *                                                                *   CL**2
00134 *     RETRIEVE NAMES OF ALL RECORDS IN FILE STRUCTURE            *   CL**2
00135 *                                                                *   CL**2
00136 ******************************************************************   CL**2
00137 ******************************************************************   CL**2
00138 *     OUTPUT DATA RECORDS ARE CLAUSE                             *   CL**2
00139 ******************************************************************   CL**2
00140  1000-CBL20.                                                      DCCBL320
00141 *                                                                    CL**2
00142 *     SEE IF PARENT FILE HAS STRUCTURE                               CL**2
00143 *                                                                    CL**2
00144      MOVE STC-CAT-NO TO DATA-ENTRY-CAT.                              CL**2
00145      MOVE GTBL-SEL-CNAME TO DATA-ENTRY-NAME.                         CL**2
00146      PERFORM READ-CATEGORY THRU READ-CATEGORY-XIT.                   CL**2
00147      IF DATA-RETURN-CODE NOT EQUAL ZERO                              CL**2
00148          PERFORM 9010-NO-STC-MSSG THRU 9010-NO-STC-MSSG-XIT          CL**2
00149          GO TO 8000-CBL20-END.                                       CL**2
00150      PERFORM CHECK-COMMENT THRU CHECK-COMMENT-XIT.                   CL**2
00151      IF DATA-RETURN-CODE NOT EQUAL ZERO                              CL**2
00152          PERFORM 9010-NO-STC-MSSG THRU 9010-NO-STC-MSSG-XIT          CL**2
00153          GO TO 8000-CBL20-END.                                       CL**2
00154      MOVE DATAKW TO CBL-DATAREC.                                     CL**2
00155      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00156      PERFORM CBL-OUT THRU CBL-OUT-XIT.                               CL**2
00157      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
           GO TO 1100-CBL20.
       1050-CBL20.
           PERFORM READ-NEXT-DATA THRU READ-NEXT-DATA-XIT 
           IF DATA-RETURN-CODE NOT EQUAL ZERO 
               PERFORM 9010-NO-STC-MSSG THRU 9010-NO-STC-MSSG-XIT 
               GO TO 8000-CBL20-END.
           PERFORM CHECK-COMMENT THRU CHECK-COMMENT-XIT.
           IF DATA-RETURN-CODE NOT EQUAL ZERO 
               PERFORM 9010-NO-STC-MSSG THRU 9010-NO-STC-MSSG-XIT 
               GO TO 8000-CBL20-END.
00158 *                                                                    CL**2
00159 *     PROCESS STRUCTURE                                              CL**2
00160 *                                                                    CL**2
00161  1100-CBL20.                                                         CL**2
           IF STC-CNAME EQUAL SPACES
               GO TO 1050-CBL20.
00162      MOVE DATA-SEARCH TO GEN20-SAVE-SEARCH.                          CL**2
00163      MOVE CAT-LINE TO SAVE-DATA-ENTRY-LINE.                          CL**2
00164      MOVE SPACES TO DATA-SEARCH.                                     CL**2
00165 *                                                                    CL**2
00166 *     RETRIEVE DATA NAME OF RECORD IN FILE STRUCTURE                 CL**2
00167 *                                                                    CL**2
00168      MOVE STC-CNAME TO DATA-ENTRY-NAME.                              CL**2
00169      MOVE NAME-CAT-NO TO DATA-ENTRY-CAT.                             CL**2
00170      PERFORM READ-CATEGORY THRU READ-CATEGORY-XIT.                   CL**2
00171      IF DATA-RETURN-CODE EQUAL ZERO                                  CL**2
00172          GO TO 1200-CBL20.                                           CL**2
00173      GO TO 1300-CBL20.                                               CL**2
00174 *                                                                    CL**2
00175 *     CHECK DATA NAME                                                CL**2
00176 *                                                                    CL**2
00177  1200-CBL20.                                                         CL**2
00178      IF NAME-SR-DATA-NAME EQUAL SPACES                               CL**2
00179          GO TO 1300-CBL20.                                           CL**2
00180      MOVE NAME-SR-DATA-NAME TO WS-DATA-NAME.                         CL**2
00181      PERFORM INSERT-PREFIX THRU INSERT-PREFIX-XIT.                   CL**2
00182      MOVE WORK-DATA-NAME TO CBL-RECNAME.                             CL**2
00183      GO TO 1350-CBL20.                                               CL**2
00184 *                                                                    CL**2
00185 *     USE STRUCTURE NAME                                             CL**2
00186 *                                                                    CL**2
00187  1300-CBL20.                                                         CL**2
00188      MOVE DATA-ENTRY-NAME TO WS-DATA-NAME.                           CL**2
00189      PERFORM INSERT-PREFIX THRU INSERT-PREFIX-XIT.                   CL**2
00190      MOVE WORK-DATA-NAME TO CBL-RECNAME.                             CL**2
00191 *                                                                    CL**2
00192 *     RETURN TO FILE STRUCTURE                                       CL**2
00193 *                                                                    CL**2
00194  1350-CBL20.                                                         CL**2
00195      MOVE GEN20-SAVE-SEARCH TO DATA-SEARCH.                          CL**2
00196      PERFORM RETURN-KEY THRU RETURN-KEY-XIT.                         CL**2
00197 *                                                                    CL**2
00198 *     READ NEXT LINE OF DATA                                         CL**2
00199 *                                                                    CL**2
       1355-CBL20.
00200      PERFORM READ-NEXT-DATA THRU READ-NEXT-DATA-XIT.                 CL**2
00201      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00202          GO TO 1400-CBL20.                                           CL**2
00203      PERFORM CHECK-COMMENT THRU CHECK-COMMENT-XIT.                   CL**2
00204      IF DATA-RETURN-CODE NOT EQUAL 0                                 CL**2
00205          GO TO 1400-CBL20.                                           CL**2
           IF STC-CNAME EQUAL SPACES
               GO TO 1355-CBL20.
00206      MOVE CBL-WORK-AREA TO HOLD-CARD-IMAGE.                          CL**2
00207      PERFORM CBL-OUT THRU CBL-OUT-XIT.                               CL**2
00208      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00209          GO TO 1100-CBL20.                                           CL**2
00210 *                                                                    CL**2
00211 *     COMPLETE DATA RECORDS ARE CLAUSE - SCAN AND INSERT PERIOD      CL**2
00212 *                                                                    CL**2
00213  1400-CBL20.                                                         CL**2
00214      MOVE CBL-WORK-AREA7 TO SCAN-AREA.                               CL**2
00215      PERFORM FLOAT-PERIOD THRU FLOAT-PERIOD-XIT.                     CL**2
00216      MOVE SCAN-AREA TO HOLD-CARD-IMAGE.                              CL**2
00217      PERFORM CBL-OUT THRU CBL-OUT-XIT.                               CL**2
00218      MOVE SPACES TO CBL-WORK-AREA.                                   CL**2
00219  8000-CBL20-END.                                                     CL**2
00220      MOVE "9" TO GTBL-MOD-REQ.                                       CL**2
00221 *                                                                    CL**2
00222 *     RETURN TO CBL GENERATION CTL PROG                              CL**2
00223 *                                                                    CL**2
           EXIT PROGRAM.
00225 ****************************************************************     CL**2
00226 *     ERROR ROUTINES                                                 CL**2
00227 *****************************************************************    CL**2
00228  9010-NO-STC-MSSG.                                                   CL**2
00229      MOVE "Y" TO MSG-SWITCH.                                         CL**2
00230      MOVE " 600-S" TO ERROR-MSSG-NUM.                                CL**2
00231      MOVE SPACES TO ERROR-MSSG-TYPE.                                 CL**2
00232      MOVE DATA-ENTRY-NAME TO ERROR-CAT-NAME.                         CL**2
00233      MOVE NO-STC-MSSG TO MSSG-TYPE.                                  CL**2
00234      PERFORM CBL-OUT THRU CBL-OUT-XIT.                               CL**2
00235  9010-NO-STC-MSSG-XIT.                                               CL**2
00236      EXIT.                                                           CL**2
00237                                                                    DCCBL32
00238                                                                    DCCBL32
*CALL     CBLOUT                                                           CL**4
*CALL     CBLSUB                                                           CL**4
*CALL     MAST1RK                                                          CL**4
*CALL     MAST1RFL                                                         CL**4
*CALL     MAST1RNL                                                         CL**4
*CALL     MAST1RFC                                                         CL**4
*CALL     MAST1EXT                                                         CL**4
*CALL     MAST1RDI                                                         CL**4
*CALL     MAST1ALG                                                         CL**4
