*DECK     DCUTL400
00001  IDENTIFICATION DIVISION.                                         07/15/78
       PROGRAM-ID.    UTL400. 
00003 ******************************************************************   LV002
00004 *    THIS MODULE IMPLEMENTS THE STANDARD FIELDS FEATURE OF UTILITYDCUTL400
00005 *                                                                *DCUTL400
00006 ******************************************************************DCUTL400
00007  ENVIRONMENT DIVISION.                                            DCUTL400
00008  CONFIGURATION SECTION.                                           DCUTL400
       SOURCE-COMPUTER. CYBER.
       OBJECT-COMPUTER. CYBER.
00011  INPUT-OUTPUT SECTION.                                            DCUTL400
00012  FILE-CONTROL.                                                    DCUTL400
           SELECT MAST3 ASSIGN TO "MAST3" 
               ORGANIZATION IS RELATIVE 
           ACCESS MODE IS RANDOM
               RELATIVE KEY IS CONTROL-NOM-KEY
           USE "PRUF=YES".
           SELECT SYSPRINT ASSIGN TO "OUTPUT".
00017  DATA DIVISION.                                                   DCUTL400
00018  FILE SECTION.                                                    DCUTL400
*CALL     MAST3FD                                                       DCUTL400
*CALL     SYSPRTFD                                                      DCUTL400
       COMMON-STORAGE SECTION.
  
       77 RETURN-CODE   PICTURE 99. 
       01 WKPRINT-UTL.
*CALL WKPRINT 
             10 ERROR-LINE REDEFINES STD-REPORT-REC.
                   15 FILLER   PICTURE X(12). 
                   15 PRT-STD-NAME   PICTURE X(8).
               15 ERROR-POS1   PICTURE X(6).
               15 ERROR-POS2   PICTURE X(60). 
               15 FILLER       PICTURE X(46). 
       01 UNUSED-COMMON.
           02  UC  PICTURE X OCCURS 533 TIMES.
       01 TRANS-AREA. 
           05 COMMAND-TYPE. 
               10 CONT-TYPE   PICTURE XX. 
               10 FILLER      PICTURE X.
           05 FILLER          PICTURE X(69).
       01 TRANS-OP REDEFINES TRANS-AREA.
           05 FILLER   PICTURE XX.
           05 TX-POS   PICTURE X  OCCURS 70 TIMES.
       01 UNUSED-COMM1. 
           02 FILLER   PICTURE X(11). 
       01 UTL-TABLE-STD.
              05 FUNCTION-CODE   PICTURE X. 
*CALL     WRKSTG77                                                      DCUTL400
00022  77  MAX-POS                       PICTURE S99 COMP VALUE +72.    DCUTL400
00023                                                                    DCUTL40
00024 ***************************************************************   DCUTL400
00025 *                                                                 DCUTL400
00026 *     WORK AREAS FOR THIS MODULE                                  DCUTL400
00027 *                                                                 DCUTL400
00028 ***************************************************************   DCUTL400
       01 CONTROL-NOM-KEY   PICTURE 999   VALUE ZEROS.
00030  01  WORK-AREA.                                                   DCUTL400
00031      05  TYPE-CON.                                                DCUTL400
00032          10  PROG-ID           PICTURE X(6) VALUE "DCUTL-".       DCUTL400
00033      05  ERROR-MESSAGES.                                          DCUTL400
00034          10  ERROR-MSG1.                                          DCUTL400
00035              15  FILLER          PICTURE X(13) VALUE              DCUTL400
00036          "550-S *ERROR ".                                            CL**2
00037              15  FILLER          PICTURE X(19) VALUE              DCUTL400
00038              "ILLEGAL ENTITY TYPE".                               DCUTL400
00039          10  ERROR-MSG2.                                             CL**2
00040              15  FILLER        PICTURE X(13) VALUE                   CL**2
00041          "555-S *ERROR ".                                            CL**2
00042              15  PRT-NO-MATCH  PICTURE X(8).                         CL**2
00043          15  FILLER             PICTURE X(23) VALUE                  CL**2
00044                  " IS NOT A VALID SYSNAME".                          CL**2
00045          10  ERROR-MSG3.                                             CL**2
00046              15  FILLER        PICTURE X(13) VALUE                   CL**2
00047                  "950-F *ERROR".                                     CL**2
00048              15  FILLER        PICTURE X(15) VALUE                   CL**2
00049                  "MAST3 READ".                                       CL**2
00050          10  ERROR-MSG4.                                          DCUTL400
00051              15  FILLER          PICTURE X(13) VALUE              DCUTL400
00052              "515-S *ERROR ".                                     DCUTL400
00053              15  FILLER          PICTURE X(30) VALUE              DCUTL400
00054              "EQUAL SIGN MUST FOLLOW KEYWORD".                    DCUTL400
00055          10  ERROR-MSG5.                                          DCUTL400
00056              15  FILLER          PICTURE X(13) VALUE              DCUTL400
00057              "520-S *ERROR ".                                     DCUTL400
00058              15  FILLER          PICTURE X(20) VALUE              DCUTL400
00059              "VALUE MUST BE Y OR N".                              DCUTL400
00060          15  FILLER         PICTURE X(5) VALUE " FOR ".              CL**2
00061              15  PRT-BAD-NAME  PICTURE X(8).                         CL**2
00062          10  ERROR-MSG6.                                          DCUTL400
00063              15  FILLER          PICTURE X(13) VALUE              DCUTL400
00064              "525-S *ERROR ".                                     DCUTL400
00065              15  FILLER          PICTURE X(14) VALUE              DCUTL400
00066              "ILLEGAL SYNTAX".                                    DCUTL400
00067          10  ERROR-MSG10.                                         DCUTL400
00068              15  FILLER          PICTURE X(13) VALUE              DCUTL400
00069              "530-S *ERROR ".                                     DCUTL400
00070              15  FILLER          PICTURE X(32) VALUE              DCUTL400
00071              "INVALID CONTINUATION TRANSACTION".                  DCUTL400
00072      05  INFO-MESSAGES.                                           DCUTL400
00073      10  INFO-MSG1.                                               DCUTL400
00074          15  FILLER       PICTURE X(5) VALUE SPACE.               DCUTL400
00075          15  FILLER       PICTURE X(49) VALUE                     DCUTL400
00076          "THE FOLLOWING FIELDS WERE ALTERED FOR THE ENTITY".      DCUTL400
00077          15  INFO-ENTITY             PICTURE X(15).               DCUTL400
00078      10  INFO-MSG2.                                               DCUTL400
00079          15  FILLER       PICTURE X(10) VALUE SPACE.              DCUTL400
00080          15  FILLER       PICTURE X(15) VALUE                     DCUTL400
00081          "SYSTEM NAME".                                           DCUTL400
00082          15  FILLER       PICTURE X(10) VALUE                     DCUTL400
00083          "OLD VALUE".                                             DCUTL400
00084          15  FILLER       PICTURE X(10) VALUE                     DCUTL400
00085          "NEW VALUE".                                             DCUTL400
00086       10  INFO-MSG3.                                              DCUTL400
00087          15  FILLER       PICTURE X(12) VALUE SPACE.              DCUTL400
00088          15  PRT-FIELD-NAME         PICTURE X(13).                DCUTL400
00089          15  FILLER       PICTURE X(4) VALUE SPACE.               DCUTL400
00090          15  PRT-OLD-VALUE          PICTURE X(6).                 DCUTL400
00091          15  FILLER       PICTURE X(4) VALUE SPACE.               DCUTL400
00092          15  PRT-NEW-VALUE          PICTURE X.                    DCUTL400
00093      10  INFO-MSG4.                                               DCUTL400
00094          15  FILLER       PICTURE X(5) VALUE SPACE.               DCUTL400
00095          15  FILLER       PICTURE X(31) VALUE                     DCUTL400
00096          "STANDARD FIELDS FOR THE ENTITY".                        DCUTL400
00097          15  INFO-ENTITY1           PICTURE X(15).                DCUTL400
00098          15  FILLER       PICTURE X(4) VALUE "ARE:".              DCUTL400
00099      10  INFO-MSG5.                                               DCUTL400
00100          15  FILLER       PICTURE X(20) VALUE SPACE.              DCUTL400
00101          15  PRT-STANDARD-NAME      PICTURE X(8).                 DCUTL400
00102      05  SUB-SCRIPTS.                                             DCUTL400
00103          10  TX-SUB              PICTURE 99 COMP SYNC.            DCUTL400
00104          10  OPT-SUB             PICTURE 99 COMP SYNC.            DCUTL400
               10 SUB1                   PICTURE 999 COMP SYNC. 
               10 SUB2                   PICTURE 999 COMP SYNC. 
               10 SUB3                   PICTURE 999 COMP SYNC. 
00108      05  FLAGS.                                                   DCUTL400
00109          10  CHAR-NOT-FOUND      PICTURE X.                       DCUTL400
00110          10  END-OF-CARD         PICTURE X VALUE "N".             DCUTL400
00111      05  TEST-TYPES.                                              DCUTL400
00112          10  TEST-CHAR           PICTURE X.                       DCUTL400
00113          10  EQUAL-SIGN          PICTURE X VALUE "=".             DCUTL400
00114          10  COMMA-CHAR          PICTURE X VALUE ",".             DCUTL400
00115      05  SAVE-AREAS.                                              DCUTL400
00116          10  SAVE-ID           PICTURE XX.                        DCUTL400
00117          10  SAVE-START     PICTURE S9(8) COMP SYNC.                 CL**2
00118      05  AREA-SCAN.                                               DCUTL400
00119          10  SCAN-FIELD-15.                                       DCUTL400
00120              15  SCAN-FIELD-8.                                    DCUTL400
00121                  20  SCAN-FIELD-1           PICTURE X.            DCUTL400
00122                  20  FILLER                 PICTURE X(7).         DCUTL400
00123              15  FILLER                     PICTURE X(7).         DCUTL400
00124          10  FILLER                         PICTURE X(57).        DCUTL400
00125      05  SCAN-AREA REDEFINES AREA-SCAN PICTURE X OCCURS 72 TIMES. DCUTL400
00126                                                                   DCUTL400
00127                                                                   DCUTL400
00128  01  POINTER-STACK.                                               DCUTL400
           05  POINTER-ENTRY OCCURS 17 TIMES. 
00130          10  POINTER-NAME            PICTURE X(15).               DCUTL400
00131          10  POINTER-ID              PICTURE XX.                  DCUTL400
               10  POINTER-START       PICTURE XXX. 
00133                                                                   DCUTL400
00134                                                                   DCUTL400
00135                                                                   DCUTL400
00136 *          SYSTEM NAMES AND VALUES ARE STORED HERE                DCUTL400
00137 *           THEY ARE TAKEN FROM THE TRANSACTION INPUT             DCUTL400
00138                                                                   DCUTL400
00139                                                                   DCUTL400
00140  01  TRANSACTION-TABLE.                                           DCUTL400
00141      05  TRANSACTION-ENTRY OCCURS 100 TIMES.                         CL**2
00142           10  TRANSACTION-NAME          PICTURE X(8).             DCUTL400
00143           10  TRANSACTION-VALUE         PICTURE X.                DCUTL400
00144                                                                   DCUTL400
00145                                                                   DCUTL400
00146                                                                   DCUTL400
00147  01  RECORD-POINTER-TABLE.                                        DCUTL400
           05 RECORD-POINTER PICTURE 999 OCCURS 150 TIMES.
00149                                                                   DCUTL400
00150                                                                   DCUTL400
00151                                                                   DCUTL400
00152  01  FIELD-TABLE.                                                 DCUTL400
           05 FIELD-ENTRY OCCURS 300 TIMES. 
00154          10  FIELD-NAME                 PICTURE X(8).             DCUTL400
00155          10  FIELD-ID                   PICTURE XX.               DCUTL400
               10  FILLER                     PICTURE X(8). 
00157          10  FIELD-STANDARD             PICTURE X.                DCUTL400
00158                                                                    DCUTL40
00178                                                                    DCUTL40
00179  PROCEDURE DIVISION.                                              DCUTL400
       OLD-ENTRY. 
00184      IF FUNCTION-CODE EQUAL "R"                                   DCUTL400
00185          MOVE TRANS-AREA TO STD-REPORT-REC                        DCUTL400
00186          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT               DCUTL400
00187          GO TO GET-NEXT-CARD-RETURN.                              DCUTL400
00188      MOVE "N" TO END-OF-CARD.                                     DCUTL400
00189      OPEN OUTPUT SYSPRINT.                                        DCUTL400
00190      MOVE SPACE TO PRINT-LINE.                                       CL**2
00191      OPEN INPUT MAST3.                                            DCUTL400
           MOVE 3 TO CONTROL-NOM-KEY. 
00193      READ MAST3                                                   DCUTL400
00194           INVALID KEY  GO TO ABORT-RUN.                           DCUTL400
00195 ******************************************************************DCUTL400
00196 *       SET UP POINTER TABLE                                      DCUTL400
00197 ******************************************************************DCUTL400
00198      MOVE SPACE TO POINTER-STACK.                                 DCUTL400
00199      MOVE 1 TO SUB1.                                              DCUTL400
00200  GET-ENTRY.                                                       DCUTL400
00201      MOVE CTL-ENTRY-NAME (SUB1) TO POINTER-NAME (SUB1).           DCUTL400
00202      MOVE CTL-ENTRY-ID (SUB1) TO POINTER-ID (SUB1).               DCUTL400
00203      ADD 1 TO SUB1.                                               DCUTL400
           IF ( SUB1 IS NOT GREATER THAN 17 ) 
00205            GO TO GET-ENTRY.                                       DCUTL400
00206      MOVE 1 TO SUB1.                                              DCUTL400
00207      MOVE 1 TO SUB2.                                              DCUTL400
00208  GET-START.                                                       DCUTL400
00209      IF CTL-DIR-ID (SUB1) EQUAL POINTER-ID (SUB2)                 DCUTL400
00210          MOVE CTL-DIR-START (SUB1) TO POINTER-START (SUB2)        DCUTL400
00211          MOVE CTL-DIR-ID (SUB1) TO SAVE-ID                        DCUTL400
00212          GO TO GET-START-200.                                     DCUTL400
00213      ADD 1 TO SUB1.                                               DCUTL400
00214      IF CTL-DIR-ID (SUB1) NOT EQUAL SPACE                         DCUTL400
00215          GO TO GET-START.                                         DCUTL400
00216      GO TO FIND-ENTITY-TYPE.                                         CL**2
00217  GET-START-200.                                                   DCUTL400
00218      ADD 1 TO SUB1.                                               DCUTL400
00219      IF CTL-DIR-ID (SUB1) EQUAL SPACE                             DCUTL400
00220          GO TO  FIND-ENTITY-TYPE.                                 DCUTL400
00221      IF CTL-DIR-ID (SUB1) EQUAL SAVE-ID                           DCUTL400
00222           GO TO GET-START-200.                                    DCUTL400
00223      ADD 1 TO SUB2.                                               DCUTL400
00224      GO TO GET-START.                                             DCUTL400
00225                                                                    DCUTL40
00226 ******************************************************************DCUTL400
00227 *                                                                 DCUTL400
00228 *   FIND TYPE OF ENTITY AND STORE ITS FIELDS IN FIELD-TABLE       DCUTL400
00229 *                                                                 DCUTL400
00230 ******************************************************************DCUTL400
00231  FIND-ENTITY-TYPE.                                                DCUTL400
           MOVE 2 TO TX-SUB.
00235      PERFORM FIND-BLANK THRU FIND-BLANK-XIT.                      DCUTL400
00236      MOVE COMMA-CHAR TO TEST-CHAR.                                DCUTL400
00237      PERFORM FIND-CHAR THRU FIND-CHAR-XIT.                        DCUTL400
00238      IF CHAR-NOT-FOUND NOT EQUAL "Y"                              DCUTL400
00239          GO TO ILLEGAL-RENAME-SYNTAX.                             DCUTL400
00240      MOVE 1 TO SUB1.                                              DCUTL400
00241  FIND-ENTITY-TYPE-200.                                            DCUTL400
00242      IF POINTER-NAME (SUB1) EQUAL SCAN-FIELD-15                   DCUTL400
00243          MOVE POINTER-START (SUB1) TO CONTROL-NOM-KEY             DCUTL400
00244          MOVE POINTER-ID (SUB1) TO SAVE-ID                           CL**2
00245          MOVE CONTROL-NOM-KEY TO SAVE-START                       DCUTL400
00246          GO TO BUILD-FIELD-TABLE.                                 DCUTL400
00247      ADD 1 TO SUB1.                                               DCUTL400
           IF ( SUB1 IS NOT GREATER THAN 17 ) 
00249            GO TO  FIND-ENTITY-TYPE-200.                           DCUTL400
00250      MOVE ERROR-MSG1 TO ERROR-POS2.                               DCUTL400
00251      GO TO PRINT-FATAL-ERROR.                                     DCUTL400
00252                                                                    DCUTL40
00253 ******************************************************************DCUTL400
00254 *      GET FIELD TABLE FOR THIS ENTITY TYPE                       DCUTL400
00255 ******************************************************************DCUTL400
00256  BUILD-FIELD-TABLE.                                               DCUTL400
00257      MOVE POINTER-NAME (SUB1) TO INFO-ENTITY INFO-ENTITY1.        DCUTL400
00258      MOVE SPACE TO FIELD-TABLE.                                   DCUTL400
00259      MOVE ZERO TO RECORD-POINTER-TABLE.                           DCUTL400
00260      MOVE 1 TO SUB2.                                              DCUTL400
00261      MOVE 1 TO SUB3.                                              DCUTL400
00262  BUILD-FIELD-TABLE-200.                                           DCUTL400
00263      READ MAST3                                                   DCUTL400
00264           INVALID KEY  GO TO ABORT-RUN.                           DCUTL400
00265      IF CTL-FLD-ENTRY-TYPE NOT EQUAL SAVE-ID                      DCUTL400
00266          GO TO FIELD-TABLE-BUILT.                                 DCUTL400
00267      MOVE 1 TO SUB1.                                              DCUTL400
00268  BUILD-FIELD-TABLE-400.                                           DCUTL400
00269      MOVE CTL-FLD-ENTRY (SUB1) TO FIELD-ENTRY (SUB2).             DCUTL400
00270      ADD 1 TO SUB1.                                               DCUTL400
00271      ADD 1 TO SUB2.                                               DCUTL400
           IF CTL-FLD-NAME (SUB1) NOT EQUAL TO SPACES 
00273         GO TO BUILD-FIELD-TABLE-400.                              DCUTL400
00274      MOVE SUB2 TO RECORD-POINTER (SUB3).                             CL**2
00275      ADD 1 TO CONTROL-NOM-KEY.                                    DCUTL400
00276      ADD 1 TO SUB3.                                               DCUTL400
00277      GO TO BUILD-FIELD-TABLE-200.                                 DCUTL400
00278                                                                    DCUTL40
00279 ******************************************************************DCUTL400
00280 *     GET OPERANDS OF TRANSACTIONS AND STORE IN TABLE             DCUTL400
00281 ******************************************************************DCUTL400
00282  FIELD-TABLE-BUILT.                                               DCUTL400
00283      CLOSE MAST3.                                                 DCUTL400
00284      MOVE 1 TO SUB2.                                              DCUTL400
00285      MOVE SPACE TO TRANSACTION-TABLE.                                CL**2
00286  FIELD-TABLE-BUILT-200.                                           DCUTL400
00287      PERFORM FIND-BLANK THRU FIND-BLANK-XIT.                      DCUTL400
00288      IF END-OF-CARD EQUAL "Y"                                     DCUTL400
00289          PERFORM GET-NEXT-CARD THRU GET-NEXT-CARD-XIT.            DCUTL400
00290      MOVE EQUAL-SIGN TO TEST-CHAR.                                DCUTL400
00291      PERFORM FIND-CHAR THRU FIND-CHAR-XIT.                        DCUTL400
00292      IF CHAR-NOT-FOUND NOT EQUAL "Y"                              DCUTL400
00293          GO TO ILLEGAL-RENAME-SYNTAX.                             DCUTL400
00294      MOVE SCAN-FIELD-8 TO TRANSACTION-NAME (SUB2).                DCUTL400
00295      PERFORM FIND-BLANK THRU FIND-BLANK-XIT.                      DCUTL400
00296      IF END-OF-CARD EQUAL "Y"                                        CL**2
00297            GO TO ILLEGAL-RENAME-SYNTAX.                              CL**2
00298      MOVE COMMA-CHAR TO TEST-CHAR.                                DCUTL400
00299      PERFORM FIND-CHAR THRU FIND-CHAR-XIT.                        DCUTL400
00300      IF CHAR-NOT-FOUND NOT EQUAL "Y"                              DCUTL400
00301          MOVE SCAN-FIELD-1 TO TRANSACTION-VALUE (SUB2)               CL**2
00302          GO TO UPDATE-VALUE.                                      DCUTL400
00303      MOVE SCAN-FIELD-1 TO TRANSACTION-VALUE (SUB2).               DCUTL400
00304      ADD 1 TO SUB2.                                               DCUTL400
00305      GO TO FIELD-TABLE-BUILT-200.                                 DCUTL400
00306                                                                    DCUTL40
00307 *****************************************************************    CL**2
00308 *  VALIDATE VALUES AND FIELD NAMES                                DCUTL400
00309 *****************************************************************    CL**2
00310  UPDATE-VALUE.                                                    DCUTL400
00311      MOVE 1 TO SUB2.                                              DCUTL400
00312      MOVE MAX-LINES TO LINE-CT.                                   DCUTL400
00313      MOVE INFO-MSG1 TO STD-REPORT-REC.                            DCUTL400
00314      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                  DCUTL400
00315      MOVE INFO-MSG2 TO STD-REPORT-REC.                            DCUTL400
00316      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                  DCUTL400
00317  UPDATE-VALUE-200.                                                DCUTL400
00318      IF TRANSACTION-VALUE (SUB2) EQUAL "Y" OR "N"                 DCUTL400
00319          GO TO  UPDATE-VALUE-400.                                 DCUTL400
00320      MOVE TRANSACTION-NAME (SUB2) TO PRT-BAD-NAME.                   CL**2
00321      MOVE ERROR-MSG5 TO ERROR-POS2.                               DCUTL400
00322      GO TO UPDATE-VALUE-800.                                      DCUTL400
00323  UPDATE-VALUE-400.                                                DCUTL400
00324      MOVE 1 TO SUB1.                                              DCUTL400
00325  UPDATE-VALUE-600.                                                DCUTL400
00326      IF FIELD-NAME (SUB1) EQUAL TRANSACTION-NAME (SUB2)           DCUTL400
00327          MOVE FIELD-NAME (SUB1) TO PRT-FIELD-NAME                 DCUTL400
00328          MOVE FIELD-STANDARD (SUB1) TO PRT-OLD-VALUE              DCUTL400
00329          MOVE TRANSACTION-VALUE (SUB2) TO PRT-NEW-VALUE           DCUTL400
00330          MOVE INFO-MSG3 TO STD-REPORT-REC                            CL**2
00331          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT               DCUTL400
00332         MOVE TRANSACTION-VALUE (SUB2) TO FIELD-STANDARD (SUB1)    DCUTL400
00333         GO TO GET-NEXT-FIELD.                                     DCUTL400
00334      ADD 1 TO SUB1.                                               DCUTL400
00335      IF FIELD-NAME (SUB1) NOT EQUAL SPACE                         DCUTL400
00336         GO TO UPDATE-VALUE-600.                                   DCUTL400
00337      MOVE TRANSACTION-NAME (SUB2) TO PRT-NO-MATCH.                   CL**2
00338      MOVE ERROR-MSG2 TO ERROR-POS2.                               DCUTL400
00339  UPDATE-VALUE-800.                                                DCUTL400
00340      PERFORM ERROR-ROUTINE THRU ERROR-ROUTINE-XIT.                DCUTL400
00341      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00342      MOVE INFO-MSG2 TO STD-REPORT-REC.                               CL**2
00343      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                     CL**2
00344  GET-NEXT-FIELD.                                                  DCUTL400
00345      ADD 1 TO SUB2.                                               DCUTL400
00346      IF TRANSACTION-NAME (SUB2) NOT EQUAL SPACE                   DCUTL400
00347           GO TO UPDATE-VALUE-200.                                 DCUTL400
00348      MOVE MAX-LINES TO LINE-CT.                                   DCUTL400
00349      MOVE INFO-MSG4 TO STD-REPORT-REC.                            DCUTL400
00350      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                  DCUTL400
00351      MOVE 1 TO SUB1.                                              DCUTL400
00352      MOVE 1 TO SUB2.                                              DCUTL400
00353      MOVE 1 TO SUB3.                                              DCUTL400
00354      OPEN I-O MAST3.                                              DCUTL400
00355      MOVE SAVE-START TO CONTROL-NOM-KEY.                          DCUTL400
00356      READ MAST3                                                   DCUTL400
00357           INVALID KEY  GO TO ABORT-RUN.                           DCUTL400
00358  WRITE-FIELD-TABLE.                                               DCUTL400
00359      MOVE FIELD-ENTRY (SUB1) TO CTL-FLD-ENTRY (SUB2).             DCUTL400
00360      ADD 1 TO SUB1.                                               DCUTL400
00361      ADD 1 TO SUB2.                                               DCUTL400
00362      IF SUB1 EQUAL RECORD-POINTER (SUB3)                          DCUTL400
00363          PERFORM WRITE-IT THRU WRITE-IT-XIT.                      DCUTL400
00364      IF FIELD-NAME (SUB1) NOT EQUAL SPACE                         DCUTL400
00365          GO TO WRITE-FIELD-TABLE.                                 DCUTL400
00366      GO TO FINISH-PROCESS.                                           CL**2
00367                                                                    DCUTL40
00368 ******************************************************************DCUTL400
00369 *       COMMON ERROR MESSAGE PRINTING                             DCUTL400
00370 ***************************************************************** DCUTL400
00371                                                                   DCUTL400
00372  ERROR-ROUTINE.                                                   DCUTL400
00373      MOVE PROG-ID TO ERROR-POS1.                                  DCUTL400
00374      MOVE 8 TO RETURN-CODE.                                       DCUTL400
00375      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                  DCUTL400
00376  ERROR-ROUTINE-XIT.                                               DCUTL400
00377      EXIT.                                                        DCUTL400
00378  ABORT-RUN.                                                       DCUTL400
00379      MOVE ERROR-MSG3 TO ERROR-POS2.                                  CL**2
00380      GO TO PRINT-FATAL-ERROR.                                     DCUTL400
00381  ILLEGAL-RENAME-SYNTAX.                                           DCUTL400
00382      MOVE ERROR-MSG6 TO ERROR-POS2.                               DCUTL400
00383  PRINT-FATAL-ERROR.                                               DCUTL400
00384      MOVE PROG-ID TO ERROR-POS1.                                  DCUTL400
00385      PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.                  DCUTL400
00386      MOVE 8 TO RETURN-CODE.                                          CL**2
00387      GO TO FINISH-PROCESS.                                        DCUTL400
00388                                                                    DCUTL40
00389 ******************************************************************DCUTL400
00390 *    END OF JOB                                                   DCUTL400
00391 ******************************************************************DCUTL400
00392  FINISH-PROCESS.                                                  DCUTL400
00393      MOVE SPACE TO STD-REPORT-REC.                                DCUTL400
00394      CLOSE MAST3.                                                 DCUTL400
00395      CLOSE SYSPRINT.                                              DCUTL400
00396      MOVE "N" TO FUNCTION-CODE.                                   DCUTL400
           EXIT PROGRAM.
00398                                                                    DCUTL40
00399 ******************************************************************DCUTL400
00400 *                                                                 DCUTL400
00401 *       SCAN SUBROUTINES                                          DCUTL400
00402 *                                                                 DCUTL400
00403 ******************************************************************DCUTL400
00404  FIND-BLANK.                                                      DCUTL400
00405      ADD 1 TO TX-SUB.                                             DCUTL400
00406      IF TX-SUB GREATER THAN MAX-POS                               DCUTL400
00407         MOVE "Y" TO END-OF-CARD                                   DCUTL400
00408           GO TO FIND-BLANK-XIT.                                   DCUTL400
00409      IF TX-POS (TX-SUB) EQUAL SPACE                               DCUTL400
00410          GO TO FIND-BLANK.                                        DCUTL400
00411      SUBTRACT 1 FROM TX-SUB.                                      DCUTL400
00412  FIND-BLANK-XIT.                                                  DCUTL400
00413      EXIT.                                                        DCUTL400
00414  FIND-CHAR.                                                       DCUTL400
00415      MOVE "N" TO CHAR-NOT-FOUND.                                  DCUTL400
00416      MOVE ZERO TO OPT-SUB.                                        DCUTL400
00417      ADD 1 TO TX-SUB.                                             DCUTL400
00418      MOVE SPACE TO AREA-SCAN.                                     DCUTL400
00419  FIND-CHAR-100.                                                   DCUTL400
00420      ADD 1 TO OPT-SUB.                                            DCUTL400
00421      IF TX-POS (TX-SUB) EQUAL TEST-CHAR                           DCUTL400
00422          MOVE "Y" TO CHAR-NOT-FOUND                               DCUTL400
00423          GO TO FIND-CHAR-XIT.                                     DCUTL400
00424      MOVE TX-POS (TX-SUB) TO SCAN-AREA (OPT-SUB).                 DCUTL400
00425      ADD 1 TO TX-SUB.                                             DCUTL400
00426      IF TX-SUB GREATER THAN MAX-POS                               DCUTL400
00427         MOVE "Y" TO END-OF-CARD                                   DCUTL400
00428          GO TO FIND-CHAR-XIT.                                     DCUTL400
00429      GO TO FIND-CHAR-100.                                         DCUTL400
00430  FIND-CHAR-XIT.                                                   DCUTL400
00431      EXIT.                                                        DCUTL400
00432 ******************************************************************DCUTL400
00433 *       GET NEXT CARD                                             DCUTL400
00434 ***************************************************************** DCUTL400
00435  GET-NEXT-CARD.                                                   DCUTL400
00436      MOVE "N" TO END-OF-CARD.                                     DCUTL400
00437      MOVE "R" TO FUNCTION-CODE.                                   DCUTL400
           EXIT PROGRAM.
00439  GET-NEXT-CARD-RETURN.                                            DCUTL400
00440      MOVE "N" TO FUNCTION-CODE.                                   DCUTL400
00441      IF CONT-TYPE NOT EQUAL SPACE                                 DCUTL400
00442          MOVE ERROR-MSG10 TO ERROR-POS2                           DCUTL400
00443          GO TO PRINT-FATAL-ERROR.                                 DCUTL400
00444      MOVE ZERO TO TX-SUB.                                         DCUTL400
00445      PERFORM FIND-BLANK THRU FIND-BLANK-XIT.                      DCUTL400
00446  GET-NEXT-CARD-XIT.                                               DCUTL400
00447      EXIT.                                                        DCUTL400
00448 ******************************************************************   CL**2
00449 *     WRITE UPDATED CONTROL RECORDS                                  CL**2
00450 *****************************************************************    CL**2
00451  WRITE-IT.                                                        DCUTL400
00452      MOVE 1 TO SUB2.                                              DCUTL400
00453  WRITE-IT-200.                                                    DCUTL400
00454      IF CTL-FLD-STD (SUB2) EQUAL "Y"                              DCUTL400
00455          MOVE CTL-FLD-NAME (SUB2) TO PRT-STD-NAME                 DCUTL400
00456          PERFORM DISPLAY-LINE THRU DISPLAY-LINE-XIT.              DCUTL400
00457      ADD 1 TO SUB2.                                               DCUTL400
00458      IF CTL-FLD-NAME (SUB2) NOT EQUAL SPACE                       DCUTL400
00459          GO TO WRITE-IT-200.                                      DCUTL400
00460      REWRITE CTL-RECORD-5                                            CL**2
00461         INVALID KEY GO TO ABORT-RUN.                              DCUTL400
00462      ADD 1 TO CONTROL-NOM-KEY.                                    DCUTL400
00463      READ MAST3                                                   DCUTL400
00464          INVALID KEY GO TO ABORT-RUN.                             DCUTL400
00465      MOVE 1 TO SUB2.                                              DCUTL400
00466      ADD 1 TO SUB3.                                               DCUTL400
00467  WRITE-IT-XIT.                                                    DCUTL400
00468      EXIT.                                                        DCUTL400
00469  USER-ROUTINE.                                                    DCUTL400
00470      GO TO USER-ROUTINE-XIT.                                      DCUTL400
00471  USER-ROUTINE-XIT.                                                DCUTL400
00472      EXIT.                                                        DCUTL400
*CALL     DISPLAYLN                                                        CL**2
*CALL     WRITELN                                                          CL**2
