       IDENTIFICATION DIVISION.
       PROGRAM-ID. ESCH.
       REMARKS. COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979, 1980.
       ENVIRONMENT DIVISION.
       CONFIGURATION SECTION.
       SOURCE-COMPUTER. XEROX-560.
       OBJECT-COMPUTER. XEROX-560.
       INPUT-OUTPUT SECTION.
       FILE-CONTROL.
            SELECT DDL-OUT ASSIGN DISC ACCESS IS RANDOM ACTUAL IS KEY1.
            SELECT DMCL-OUT ASSIGN DISC ACCESS IS RANDOM ACTUAL IS KEY2.
            SELECT DMCL-IN ASSIGN DISC ACCESS IS SEQUENTIAL.
            SELECT LIST-OUT ASSIGN PRINTER.
            SELECT LOCK-OUT ASSIGN DISC ACCESS IS RANDOM ACTUAL IS KEY3.
            SELECT LOCK-IN ASSIGN DISC ACCESS IS SEQUENTIAL.
       DATA DIVISION.
       FILE SECTION.
       FD DDL-OUT LABEL RECORD OMITTED DATA RECORD IS DDL-OUT-RECD.
       01 DDL-OUT-RECD PIC X(80).
       FD DMCL-OUT LABEL RECORD OMITTED DATA RECORD IS DMCL-OUT-RECD.
       01 DMCL-OUT-RECD PIC X(80).
       FD DMCL-IN LABEL RECORD OMITTED DATA RECORD IS DMCL-IN-RECD.
       01 DMCL-IN-RECD PIC X(80).
       FD LIST-OUT LABEL RECORD OMITTED DATA RECORD IS LIST-OUT-RECD.
       01 LIST-OUT-RECD PIC X(132).
       FD LOCK-OUT LABEL RECORD OMITTED DATA RECORD IS LOCK-OUT-RECD.
       01 LOCK-OUT-RECD PIC X(80).
       FD LOCK-IN LABEL RECORD OMITTED DATA RECORD IS LOCK-IN-RECD.
       01 LOCK-IN-RECD PIC X(80).
      /
       WORKING-STORAGE SECTION.
       77 COPYRITE PIC X(64) VALUE
             'COPYRIGHT, (C) HONEYWELL INFORMATION SYSTEMS INC., 1979,
      -      '1980.'.
       01 DATA-CANT-BE-5800 COMP.
       01 AREA-REF-CODE COMP.
       01 ERROR-FLAG COMP.
       01 PASS-TEMP PIC X(12) VALUE IS SPACES.
       01 DIR   PIC 9 VALUE IS 1 .
       01 INX  PIC 9 VALUE IS 2 .
       01 CALC  PIC 9 VALUE IS 3 .
       01 CLCD  PIC 9 VALUE IS 4 .
       01 VIA   PIC 9 VALUE IS 5 .
       01 VIA-SET PIC 9 VALUE IS 3 .
       01 LOC-MODE-OWNER  PIC 9.
       01 LOC-MODE-OWNER1 PIC 9.
       01 LOC-MODE-OWNER2 PIC 9.
       01 LOC-MODE-OWNER3 PIC 9.
       01 VIA-SET-NAME1 COMP.
       01 VIA-SET-NAME2 COMP.
       01 VIA-SET-NAME3 COMP.
       01 DEPTH COMP.
       01 FIRST-ALIAS USAGE COMP.
       01 KEY-TEMP USAGE COMP.
       01 KEY-VALUE COMP.
       01 LOCK-SWITCH COMP.
       01 NEXT-SWITCH COMP.
       01 IDX COMP.
       01 NTYPE COMP.
       01 NSET  COMP.
       01 SHIFT-VALUE COMP.
       01 TWO COMP VALUE 2.
       01 SAVE-1.
          02 SAVE-1-001-AREA  COMP.
          02 SAVE-1-002-UNITO COMP.
          02 SAVE-1-002-UNITM COMP.
          02 SAVE-1-003-ASOWN COMP.
          02 SAVE-1-004-ASMEM COMP.
       01 SAVE-2.
          02 SAVE-2-002-UNITO COMP.
          02 SAVE-2-003-ASOWN COMP.
          02 SAVE-2-004-ASMEM COMP.
       01 SAVE-UNIT COMP.
       01 SAVE-UNIT1 COMP.
       01 SET-NAMES.
          02 SET-NAME-0 PIC X(30).
          02 SET-NAME-1 PIC X(30).
          02 SET-NAME-2 PIC X(30).
       01 DDL-OUT-KEY.
          02 DUMMY PIC X.
          02 KEY1 PIC X(3).
       01 DDL-COMPKEY REDEFINES DDL-OUT-KEY COMP .
       01 DMCL-OUT-KEY.
          02 DUMMY PIC X.
          02 KEY2 PIC X(3).
       01 DMCL-COMPKEY REDEFINES DMCL-OUT-KEY COMP .
       01 LOCK-OUT-KEY.
          02 DUMMY PIC X.
          02 KEY3 PIC X(3).
       01 LIST-LINE COMP VALUE 2.
       01 COMMENT-L1.
          02 FILLER PIC X(10) VALUE '    1.000 '.
          02 DDL-COMMENT-L1.
             03 FILLER PIC X(80) VALUE
                '/* TRANSLATE SCHEMA DDL AND DMCL AND GENERATE SUBSCHEMA
      -     ' DDL.  '.
       01 COMMENT-L2.
          02 FILLER PIC X(10) VALUE '    2.000 '.
          02 DDL-COMMENT-L2.
             03 FILLER PIC X(80) VALUE
                '     !DBACS IDSDDLFILE OVER SUBSCHEMA-DDL '.
       01 COMMENT-L3.
          02 FILLER PIC X(10) VALUE '    3.000 '.
          02 DDL-COMMENT-L3.
             03 FILLER PIC X(10) VALUE
                '*/  '.
       01 TRANS-LINE.
          02 FILLER PIC X(10) VALUE '    1.000 '.
          02 DDL-TRANS-LINE.
             03 DBACS-TRAN PIC X(23) VALUE 'DBACS TRANSLATE SCHEMA '.
             03 TSCHEMA-NAME PIC X(30) VALUE SPACES.
       01 SCHEMA-LINE.
          02 FILLER PIC X(20) VALUE '    2.000 '.
          02 DDL-SCHEMA-LINE.
             03 SCHEMA-TEXT PIC X(15) VALUE 'SCHEMA NAME IS '.
             03 SCHEMA-NAME PIC X(30) VALUE IS SPACES.
       01 LOCKS-LINE.
          02 LLINE-NO PIC X(10) VALUE '    1.000 '.
          02 LOCKS-TRANS-LINE.
             03 DBACS-LOCKS PIC X(29) VALUE
               'DBACS ASSIGN LOCKS TO SCHEMA '.
             03 LSCHEMA-NAME PIC X(40) VALUE SPACES.
       01 SUBSCHEMA-LINE.
          02 SSLINE-NO PIC X(10) VALUE '    1.000 '.
          02 SSUB-TRANS-LINE.
            03 DBACS-SSTRAN PIC X(31) VALUE
              'DBACS GENERATE COBOL SUBSCHEMA '.
            03 SUBSCHEMA-NAME PIC X(60) VALUE IS SPACES.
       01 SUB-LINE.
           02 SUB-TRAN-LINE.
              03  FILLER PIC X(32) VALUE
                 'DBACS TRANSLATE COBOL SUBSCHEMA '.
              03  SUB-NAME PIC X(60) VALUE IS SPACES.
       01 SUB-L2.
           02 FILLER PIC X(10) VALUE     '    1.000 '.
           02 SUB-VAL-LINE.
              03  FILLER PIC X(25) VALUE
                  'DBACS VALIDATE SUBSCHEMA '.
              03  SUB-VAL-NAME PIC X(60) VALUE SPACES.
       01 COVER-HEAD.
          02 BLANKS PIC X(35) VALUE IS SPACES.
          02 TEXT PIC X(46) VALUE
            'EDMS SCHEMA TO I-D-S/II DDL AND DMCL CONVERTER'.
          02 BLAANK PIC X(49) VALUE IS SPACES.
       01 LINE-1 PIC X(123) VALUE
            'THE SCHEMA TRANSLATOR USES AN EDMS SCHEMA FILE AS INPUT.  I
      -     '-D-S/II DDL AND DMCL'.
       01 LINE-2 PIC X(121) VALUE
            'IS PRODUCED FOR INPUT TO THE DBACS PROCESSOR ON CP-6'.
       01 LINE-3 PIC X(121) VALUE
            'THREE OUTPUT FILES ARE ALWAYS GENERATED, DDLOUT, DMCLOUT AN
      -     'D LOCKSOUT.  DDLOUT IS THE DDL,'.
       01 LINE-4 PIC X(121) VALUE
            'AND DMCLOUT IS THE DMCL.'.
       01 LINE-6 PIC X(121) VALUE
            'THE THIRD FILE GENERATED CONTAINS LOCKS AND IS CALLED LOCKO
      -     'UT.'.
       01 LINE-7 PIC X(121) VALUE
            'LOCK FUNCTION STATEMENTS WHICH MAY BE INPUT TO THE LOCK FUN
      -     'CTION IN ORDER TO APPLY THE'.
       01 LINE-8 PIC X(121) VALUE
            'LOCKS TO THE GENERATED LOCK NAMES.'.
       01 LINE-10 PIC X(121) VALUE
            'THE TRANSLATOR PRINTOUT INCLUDES A LISTING OF ALL GENERATED
      -     ' FILES.  LINE NUMBERS (EDIT KEYS)'.
       01 LINE-11 PIC X(121) VALUE
      -     'LE LISTINGS.  THEY INDICATE'.
       01 LINE-12 PIC X(123) VALUE
            'FUNCTIONAL DISCREPANCIES BETWEEN EDMS AND I-D-S/II.  COMMEN
      -     'TS ARE PRECEEDED BY ****,'.
       01 LINE-13 PIC X(121) VALUE
            'THEY ARE NOT INCLUDED IN THE OUTPUT FILES.'.
       01 LINE-14 PIC X(131) VALUE
            'THE TRANSLATOR CHANGES ALL HYPHENS (-) USED IN USER NAMES T
      -     'O UNDER-SCORES (_). IT'.
       01 LINE-15 PIC X(132) VALUE
            'PREFIXS ALL USER NAMES STARTING WITH A NUMERIC CHAR WITH (Z
      -     ') AND PREFIXS ALL USER NAMES'.
       01 LINE-16 PIC X(123) VALUE
            'WHICH ARE I-D-S/II RESERVED NAMES WITH (Z) AND A MESSAGE IS
      -     ' OUTPUT ON THE LISTING. '.
       01 LINE-17 PIC X(121) VALUE
            'THE ERROR MESSAGES HAVE SEVERITY LEVEL FROM 0-9 A
      -     'ND OF THE FORMAT (X-Y-Z) WHERE: '.
       01 LINE-18 PIC X(121) VALUE
            'X=DATA BASE STRUCTURE IMPACT, Y=SUBSCHEMA IMPACT AND Z=APPL
      -     'ICATION PROGRAM IMPACT.'.
       01 PRIVACY-LINE.
          02 LINE-NO PIC X(10) VALUE '    2.000 '.
          02 DDL-PRIVACY-LINE.
             03 PRIVACY-TEXT PIC X(29)
                VALUE '   ;PRIVACY LOCK FOR COPY IS '.
             03 PRIVACY-LOCK PIC X(30) VALUE IS SPACES.
       01 AREA-LINE.
          02 AREA-LINE-NO PIC BZZZZ.000B.
          02 DDL-AREA-LINE.
           03 AREA-TEXT PIC X(13) VALUE 'AREA NAME IS '.
           03 AREA-NAME PIC X(30) VALUE IS SPACES.
       01 Z-LINE.
          02 Z-LINE-NO PIC BZZZZ.000B.
          02 DDL-Z-LINE.
             03 Z-TEXT PIC X(9)
                VALUE '   ;Z'.
       01 ALLOCATE-LINE.
          02 ALLOCATE-LINE-NO PIC BZZZZ.000B.
          02 DMCL-ALLOCATE-LINE.
             03 ALLOCATE-TEXT PIC X(13)
                VALUE '    ALLOCATE '.
             03 ALLOCATE-KEYS PIC X(60).
       01 DATA-BASE-KEYS PIC X(15) VALUE ' DATA_BASE_KEYS'.
       01 ALLOCATE-VALUE PIC Z(12)9.
       01 INVENTORY-LINE.
          02 INVENTORY-LINE-NO PIC BZZZZ.000B.
          02 DDL-INVENTORY-LINE.
             03 INVENTORY-TEXT PIC X(17)
                VALUE '    INVENTORY AT '.
             03 INVENTORY-VALUE PIC Z9.
       01 PAGE-INTERVAL-LINE.
          02 PAGE-INTERVAL-LINE-NO PIC BZZZZ.000B.
          02 DDL-PAGE-INTERVAL-LINE.
             03 PAGE-INTERVAL-TEXT PIC X(21)
                VALUE '    PAGE_INTERVAL IS '.
             03 PAGE-KEYS PIC X(60).
       01 PAGE-INTERVAL-VALUE PIC Z(5).
       01 CHECKSUM-LINE.
          02 DMCL-CHECKSUM-LINE.
             03 CHECKSUM-LINE-TEXT  PIC X(12)
                VALUE '    CHECKSUM'.
       01 JOURNAL-LINE.
          02 DMCL-JOURNAL-LINE.
             03 JOURNAL-LINE-TEXT PIC X(11)
                VALUE '    JOURNAL'.
       01 ENCRYPTION-LINE.
          02 DMCL-ENCRYPTION-LINE.
             03 ENCRYPTION-LINE-TEXT  PIC X(32)
                VALUE '    ENCRYPTION'.
       01 BLANK-LINE PIC X VALUE SPACES.
       01 KEYS-PER-PAGE COMP.
       01 TEMPS.
          02 TEMP3 PIC X(3).
          02 TEMPX PIC X.
       01 TEMP REDEFINES TEMPS USAGE COMP.
       01 TEMPB PIC X.
       01 THREE USAGE COMP VALUE IS 3.
       01 SIGNED COMP.
       01 NINES COMP.
       01 NUM-SIZE COMP.
       01 NUM-IN   COMP.
       01 NUM-VAL  COMP.
          02 PACK1 PIC X(1).
          02 PACK2 PIC X(14).
          02 PACK3 PIC X(1).
          02 PACK4 PIC X(14).
       01 NUM-RET USAGE COMP.
       01 STOR-SET USAGE COMP.
       01 I USAGE COMP.
       01 J USAGE COMP.
       01 K USAGE COMP.
       01 L USAGE COMP.
       01 NUM-DIGITS PIC X(30).
       01 NUM-SCALE  PIC X(30).
       01 PIC-EXPAND.
          02 FILLER PIC X(3) VALUE IS SPACES.
          02 PICT-CNT PIC X  VALUE IS SPACES.
       01 PICT-COUNT REDEFINES PIC-EXPAND COMP .
       01 SCALE-EXPAND.
          02 FILLER PIC X(3) VALUE IS SPACES.
          02 SCALE-CNT PIC X VALUE IS SPACES.
       01 SCALE-COUNT REDEFINES SCALE-EXPAND COMP.
       01 AREANO-EXPAND.
          02 FILLER PIC X(3) VALUE IS SPACES.
          02 AREANO-CNT PIC X VALUE IS SPACES.
       01 AREANO-COUNT REDEFINES AREANO-EXPAND COMP.
       01 CALC-KEYS-TABLE.
          02 CALC-KEYS OCCURS 40 TIMES PICTURE X(30).
       01 PASS-WORD PIC X(30) VALUE IS SPACES.
       01 COPY-WORD PIC X(30) VALUE IS SPACES.
       01 PERIOD-LINE.
          02 PERIOD-LINE-NO PIC BZZZZ.000B.
          02 PERIOD-TEXT PIC X(5) VALUE '   .'.
       01 RECORD-LINE.
          02 RECORD-LINE-NO PIC BZZZZ.000B.
          02 DDL-RECORD-LINE.
             03 RECORD-TEXT PIC X(15)
                VALUE 'RECORD NAME IS '.
             03 RECORD-NAME PIC X(30) VALUE IS SPACES.
       01 WITHIN-LINE.
          02 WITHIN-LINE-NO PIC BZZZZ.000B.
          02 DDL-WITHIN-LINE.
             03 WITHIN-TEXT PIC X(11)
                VALUE '   ;WITHIN '.
             03 WITHIN-NAME PIC X(30) VALUE IS SPACES.
       01 RANGE-LINE.
          02 DMCL-RANGE-LINE.
             03 RANGE-TEXT PIC X(13)
                VALUE '    RANGE IS '.
             03 RANGE-AREA PIC X(56).
       01 RANGE1 PIC Z(12)9.
       01 RANGE2 PIC Z(12)9.
       01 LOC-DIR-LINE.
          02 LOC-DIR-LINE-NO PIC BZZZZ.000B.
          02 DDL-LOC-DIR-LINE.
             03 LOC-DIR-TEXT PIC X(37)
                VALUE '   ;LOCATION MODE IS DIRECT REF_CODE '.
       01 LOC-INDEX-LINE.
          02 LOC-INDEX-LINE-NO PIC BZZZZ.000B.
          02 DDL-LOC-INDEX-LINE.
             03 LOC-INDEX-TEXT PIC X(39)
                VALUE '   ;LOCATION MODE IS INDEXED USING KEY_'.
             03 LOC-INDEX-NAMES PIC X(30) VALUE IS SPACES.
       01 AREAI-LINE.
          02 AREAI-LINE-NO PIC BZZZZ.000B.
          02 DMCL-AREAI-LINE.
             03 AREAI-TEXT PIC X(30) VALUE
                '    ORGANIZATION IS INTEGRATED'.
       01 AREAX-LINE.
          02 AREAX-LINE-NO PIC BZZZZ.000B.
          02 DMCL-AREAX-LINE.
             03 AREAX-TEXT PIC X(27) VALUE
                '    ORGANIZATION IS INDEXED'.
       01 INDEX-TO-CALC USAGE COMP.
       01 KEY-NAME-LINE.
          02 KEY-NAME-LINE-NO PIC BZZZZ.000B.
          02 DDL-KEY-NAME-LINE.
             03 FILLER PIC X(20) VALUE
                      '    KEY NAME IS KEY_'.
             03 KEY-NAME-TEXT PIC X(30) VALUE SPACES.
       01 ASC-NAME-LINE.
          02 ASC-NAME-LINE-NO PIC BZZZZ.000B.
          02 DDL-ASC-NAME-LINE.
             03 FILLER PIC X(16) VALUE
                '      ASCENDING '.
             03 ASC-NAME-TEXT PIC X(30) VALUE SPACES.
       01 LOC-CALC-LINE.
          02 LOC-CALC-LINE-NO PIC BZZZZ.000B.
             03 LOC-CALC-TEXT PIC X(32)
                VALUE '   ;LOCATION MODE IS CALC USING '.
             03 LOC-CALC-NAMES PIC X(100) VALUE IS SPACES.
       01 NEXT-CALC-LINE.
          02 NEXT-CALC-LINE-NO PIC BZZZZ.000B.
          02 DDL-NEXT-CALC-LINE.
             03 NEXT-CALC-TEXT PIC X(32)
                VALUE IS '                               ,'.
             03 NEXT-CALC-NAME PIC X(30) VALUE IS SPACES.
       01 DUPLICATES-LINE.
          02 DUPLICATES-LINE-NO PIC BZZZZ.000B.
          02 DDL-DUPLICATES-LINE.
             03 DUPLICATES-TEXT PIC X(34)
                VALUE '       DUPLICATES ARE NOT ALLOWED'.
       01 LOC-VIA-LINE.
          02 LOC-VIA-LINE-NO  PIC BZZZZ.000B.
          02 DDL-LOC-VIA-LINE.
             03 LOC-VIA-TEXT  PIC X(25)
                VALUE '   ;LOCATION MODE IS VIA '.
             03 LOC-VIA-NAME PIC X(30) VALUE IS SPACES.
       01 TYPE-LINE.
          02 TYPE-LINE-NO PIC BZZZZ.000B.
          02 DDL-TYPE-LINE.
             03 TYPE-TEXT PIC X(12)
                VALUE '    TYPE IS '.
             03 TYPE-VALUE PIC X(10) VALUE IS SPACES.
       01 FIND-GET-LINE.
          02 FIND-GET-LINE-NO PIC BZZZZ.000B.
          02 DDL-FIND-GET-LINE.
             03 FIND-GET-TEXT PIC X(25)
                VALUE '   ;PRIVACY FIND, GET IS '.
             03 LOCK-FIND-VALUE PIC X(30) VALUE IS SPACES.
       01 OR-FIND-LINE.
          02 OR-FIND-LINE-NO PIC BZZZZ.000B.
          02 DDL-OR-FIND-LINE.
             03 OR-FIND-TEXT PIC X(25)
                VALUE '                      OR '.
             03 OR-FIND-VALUE PIC X(30) VALUE IS SPACES.
       01 IRSDM-LINE.
          02 IRSDM-LINE-NO     PIC BZZZZ.000B.
          02 DDL-IRSDM-LINE.
             03 IRSDM-TEXT     PIC X(53)
                VALUE '   ;PRIVACY INSERT, REMOVE, STORE, DELETE, MODIFY
      -     ' IS '.
             03 IRSDM-LOCK-VALUE PIC X(10) VALUE IS SPACES.
       01 OR-IRSDM-LINE.
          02 OR-IRSDM-LINE-NO PIC BZZZZ.000B.
          02 DDL-OR-IRSDM-LINE.
             03 OR-IRSDM-TEXT     PIC X(53)
                VALUE '
      -     ' OR '.
             03 OR-IRSDM-VALUE PIC X(10) VALUE IS SPACES.
       01 PRIV-GET-LINE.
          02 PRIV-GET-LINE-NO PIC BZZZZ.000B.
          02 DDL-PRIV-GET-LINE.
             03 PRIV-GET-TEXT PIC X(19)
                VALUE '   ;PRIVACY GET IS '.
             03 LOCK-GET-VALUE PIC X(30) VALUE IS SPACES.
       01 PRIV-MODIFY-LINE.
          02 PRIV-MODIFY-LINE-NO PIC BZZZZ.000B.
          02 DDL-PRIV-MODIFY-LINE.
             03 PRIV-MODIFY-TEXT PIC X(22)
                VALUE '   ;PRIVACY MODIFY IS '.
             03 LOCK-MOD-VALUE PIC X(30) VALUE IS SPACES.
       01 OR-GET-LINE.
          02 OR-GET-LINE-NO PIC BZZZZ.000B.
          02 DDL-OR-GET-LINE.
             03 OR-GET-TEXT PIC X(19)
                VALUE '                OR '.
             03 OR-GET-VALUE PIC X(30) VALUE IS SPACES.
       01 OR-MODIFY-LINE.
          02 OR-MODIFY-LINE-NO PIC BZZZZ.000B.
          02 DDL-OR-MODIFY-LINE.
             03 OR-MODIFY-TEXT PIC X(22)
                VALUE '                   OR '.
             03 OR-MODIFY-VALUE PIC X(30) VALUE IS SPACES.
       01 LOCK-STATEMENT.
          02 LOCK-TEXT PIC X(80) VALUE IS SPACES.
       01 DATA-ITEM-NAME-LINE.
          02 DATA-ITEM-NAME-LINE-NO PIC BZZZZ.000B.
          02 DDL-DATA-ITEM-NAME-LINE.
             03 DATA-ITEM-NAME PIC X(30) VALUE IS SPACES.
             03 FILLER PIC X(6) VALUE ';TYPE '.
             03 ITEM-TYPE-TEXT PIC X(30).
       01 ITEM-TYPE PIC X(19).
       01 DATA-ITEM-BASE  PIC X(30)  VALUE IS SPACES.
       01 LIST-IN-RECD PIC.
          02 LIST-LINE-NO PIC BZZZZ.000B.
          02 IN-RECD.
             03 ASTERISKS PIC X(4).
             03 LIST-TEXT PIC X(119).
       01 UNDER-R PIC X(3) VALUE '_R '.
       01 UNDER-U PIC X(3) VALUE '_U '.
       01 ITEM-SIZE COMP.
       01 NUMBER-IN USAGE COMP.
       01 CHAR1 PIC 9.
       01 CHAR2 PIC 99.
       01 CHAR3 PIC 999.
       01 CHAR4 PIC 9999.
       01 NCHAR1 PIC S9.
       01 NCHAR2 PIC S99.
       01 NCHAR3 PIC S999.
       01 NCHAR4 PIC S9999.
       01 NUM-TOTAL PIC S9(4) VALUE ZERO.
       01 SIGN-VALUE PIC X(11) VALUE SPACES.
       01 CHAR-VALUE.
          02 CHAR-SGN PIC X VALUE IS SPACE.
          02 CHAR-NUM PIC X(4) VALUE IS SPACES.
       01 PIC-LINE.
          02 PIC-LINE-NO PIC BZZZZ.000B.
          02 SUBSCHEMA-PIC-LINE.
             03 PIC-TEXT PIC X(15) VALUE '   ;PICTURE IS '.
             03 PIC-VALUE PIC X(72) VALUE IS SPACES.
       01 SET-LINE.
          02 SET-LINE-NO PIC BZZZZ.000B.
          02 DDL-SET-LINE.
             03 SET-TEXT PIC X(12)
                VALUE 'SET NAME IS '.
             03 SET-NAME PIC X(30) VALUE IS SPACES.
       01 OWNER-LINE.
          02 OWNER-LINE-NO PIC BZZZZ.000B.
          02 DDL-OWNER-LINE.
             03 OWNER-TEXT PIC X(13)
                VALUE '   ;OWNER IS '.
             03 OWNER-NAME PIC X(30) VALUE IS SPACES.
       01 ORDER-LINE.
          02 ORDER-LINE-NO PIC BZZZZ.000B.
          02 DDL-ORDER-LINE.
             03 ORDER-TEXT PIC X(36)
                VALUE '   ;ORDER IS PERMANENT INSERTION IS'.
             03 ORDER-VALUE PIC X(7).
             03 SUB-ORDER-VALUE PIC X(19).
       01 PRIOR-LINE.
          02 PRIOR-LINE-NO PIC BZZZZ.000B.
          02 DDL-PRIOR-LINE.
             03 PRIOR-TEXT PIC X(29)
                VALUE '   ;SET IS PRIOR PROCESSABLE '.
       01 MEMBER-LINE.
          02 MEMBER-LINE-NO PIC BZZZZ.000B.
          02 DDL-MEMBER-LINE.
             03 MEMBER-TEXT PIC X(13)
                VALUE '   MEMBER IS '.
             03 MEMBER-NAME-VALUE PIC X(66) VALUE IS SPACES.
       01 AUTOMATIC-TEXT PIC X(36)
           VALUE ' MANDATORY AUTOMATIC LINKED TO OWNER'.
       01 OPTIONAL-TEXT PIC X(35)
           VALUE ' AUTOMATIC OPTIONAL LINKED TO OWNER'.
      /
       01 MEMBER-SET-LINE.
          02 MEMBER-SET-LINE-NO PIC BZZZZ.000B.
          02 DDL-MEMBER-SET-LINE.
             03 MEMBER-SET-TEXT PIC X(26)
                VALUE '      ;SET SELECTION THRU '.
             03 MEMBER-SET-NAME PIC X(51).
       01 APPLICATION-LINE.
          02 APPLICATION-LINE-NO PIC BZZZZ.000B.
          02 DDL-APPLICATION-LINE.
             03 APPLICATION-TEXT PIC X(37)
             VALUE '      OWNER IDENTIFIED BY APPLICATION'.
       01 DATA-BASE-KEY-LINE.
          02 DATA-BASE-KEY-LINE-NO PIC BZZZZ.000B.
          02 DDL-DATA-BASE-KEY-LINE.
             03 DATA-BASE-KEY-TEXT PIC X(39)
             VALUE '      OWNER IDENTIFIED BY DATA_BASE_KEY'.
             03 DB-KEY-NAME PIC X(31).
       01 CALC-LINE.
          02 DDL-CALC-LINE.
             03 CALC-LINE-TEXT PIC X(34)
             VALUE '      OWNER IDENTIFIED BY CALC_KEY'.
             03 CALC-NAMES PIC X(100).
       01 THEN-THRU-LINE.
          02 THEN-THRU-LINE-NO PIC BZZZZ.000B.
          02 DDL-THEN-THRU-LINE.
             03 THEN-THRU-LINE-TEXT PIC X(16)
             VALUE '      THEN THRU '.
             03 THRU-SET-NAME PIC X(30).
       01 WHERE-LINE.
          02 WHERE-LINE-NO PIC BZZZZ.000B.
          02 DDL-WHERE-LINE.
             03 WHERE-LINE-TEXT PIC X(32)
             VALUE '      WHERE OWNER IDENTIFIED BY '.
             03 WHERE-DBID PIC X(30).
      /
       01 MEMBER-SORT-LINE.
          02 MEMBER-SORT-LINE-NO PIC BZZZZ.000B.
          02 DDL-MEMBER-SORT-LINE.
             03 KEY-TEXT PIC X(10).
             03 SORT-ASC-DES PIC X(42).
       01 DUPLICATE-LINE.
          02 DUPLICATE-LINE-NO PIC BZZZZ.000B.
          02 DDL-DUPLICATE-LINE.
             03 DUPLICATE-LINE-TEXT PIC X(30)
                VALUE '               DUPLICATES ARE '.
             03 DUPLICATE-CONDITION PIC X(11).
       01 END-SCHEMA-LINE.
          02 END-SCHEMA-LINE-NO PIC BZZZZ.000B.
          02 DDL-END-SCHEMA-LINE.
             03 END-SCHEMA-TEXT PIC X(11) VALUE 'END_SCHEMA.'.
       01 MANUAL-TEXT PIC X(32)
           VALUE ' MANUAL OPTIONAL LINKED TO OWNER'.
       01 END-DMCL-LINE PIC X(9) VALUE 'END_DMCL.'.
       01 DDL-HEAD.
          02 BLANKS PIC X(48) VALUE IS SPACES.
          02 TEXT PIC X(24) VALUE IS 'DDL OUTPUT FILE LISTING'.
       01 TOP-OF-FORM PIC X VALUE '1'.
       01 DMCL-HEAD.
          02 BLANKS PIC X(48) VALUE IS SPACES.
       01 LOCK-HEAD.
          02 BLANKS PIC X(48) VALUE IS SPACES.
          02 TEXT PIC X(24) VALUE IS 'LOCK OUTPUT FILE LISTING'.
      /
       01 ALT-KEYNAME.
          02 ALT-KEYNAME-LINE-NO PIC BZZZZ.000B.
          02 DDL-ALT-KEYNAME-LINE.
             03 ALT-KEYNAME-LINE-TEXT PIC X(16)
                VALUE '   ;KEY NAME IS '.
             03 ALT-KEYNAME-VAL PIC X(32) VALUE IS SPACES.
       01 ALT-ASCEND.
          02 ALT-ASCEND-LINE-NO PIC BZZZZ.000B.
          02 DDL-ALT-ASCEND-LINE.
             03 ALT-ASCEND-LINE-TEXT PIC X(14)
                VALUE '    ASCENDING '.
             03 ALT-ITEMNAME PIC X(32) VALUE IS SPACES.
       01 ALT-DUPS.
          02 ALT-DUPS-LINE-NO PIC BZZZZ.000B.
          02 DDL-ALT-DUPS-LINE.
             03 ALT-DUPS-LINE-TEXT PIC X(26)
                VALUE '    DUPLICATES ARE ALLOWED'.
       01 ALT-NDUPS.
          02 ALT-NDUPS-LINE-NO PIC BZZZZ.000B.
          02 DDL-ALT-NDUPS-LINE.
             03 ALT-NDUPS-LINE-TEXT PIC X(30)
                VALUE '    DUPLICATES ARE NOT ALLOWED'.
       01 ALT-KEYNAME1.
          02 ALT-KEYNAME1-LINE-NO PIC BZZZZ.000B.
          02 DDL-ALT-KEYNAME1-LINE.
             03 ALT-KEYNAME1-LINE-TEXT PIC X(16)
                VALUE '    KEY NAME IS '.
             03 ALT-KEYNAME1-VAL PIC X(32) VALUE IS SPACES.
       01 ALT-KEYID.
          02 ALT-KEYID-LINE-NO PIC BZZZZ.000B.
          02 DMCL-ALT-KEYID-LINE.
             03  ALT-KEYID-LINE-TEXT PIC X(14)
                 VALUE '   ;KEY_ID IS '.
             03  ALT-KEYID-NUM PIC ZZ9.
               03  FILLER PIC X VALUE '.'.
      /
       01 GROUP-STATS-LINE PIC X(67) VALUE
       01 SET-STATS-LINE PIC X(67) VALUE
           ' **** (0-0-0) I-D-S/II DOES NOT HAVE SET STATISTICS.'.
       01 LOC-VIA-SET-LINE PIC X(68) VALUE
           ' **** (0-0-2) STORAGE SET ON LOCATION MODE VIA NOT IN I-D-S/
      -     'II.'.
       01 OWNER-AREA-LINE.
          02 OWNER-AREA-TEXT PIC X(61) VALUE
           ' **** (0-1-2) THIS GROUP GENERATED TO SATISFY OWNER IS AREA
      -     ' '.
       01 RANGE-NOTE PIC X(60) VALUE
           ' **** (0-0-0) RANGE OPTION ON KEY NOT IN I-D-S/II.'.
       01 CHANGE-NUMERIC-NAME-LINE.
          02 FILLER PIC X(6) VALUE ' **** '.
          02 CHANGE-NUMERIC-NAME PIC X(90) VALUE IS SPACES.
       01 NUMERIC-CHANGE PIC X(51) VALUE
             ' STARTS WITH NUMERIC VALUE AND CHANGED ON NEXT LINE'.
       01 OVERFLOW-NOT-REQD-LINE PIC X(68) VALUE
           ' **** (0-0-0) OVERFLOW NOT REQUIRED FOR I-D-S/II INDEXED ARE
      -     'AS.'.
       01 SUB-SAVE PIC X(32) VALUE  SPACES.
       01 T-NAME PIC X(32) VALUE SPACES.
       01 LOAD-LIMIT-LINE PIC X(68) VALUE
           ' **** (0-0-0) LOAD LIMIT NOT REQUIRED FOR I-D-S/II INDEXED A
      -     'REAS.'.
       01 LOC-CHANGE-LINE PIC X(47) VALUE
           ' **** (0-0-2) LOCATION MODE CHANGED TO CALC.'.
       01 INDEX-KEY-SHORT-LINE PIC X(68) VALUE
           ' **** (0-0-2) INDEXED KEY IS SHORTENED TO ONE ITEM ONLY.'.
       01 INDEXED-AREA-LINE PIC X(74) VALUE
           ' **** (0-0-2) INDEXED AREA CONTAINS SETS - CHANGED TO INTEGR
      -     'ATED'.
       01 INDEXED-AREA-RECORD-LINE PIC X(94) VALUE
           ' **** (0-0-2) INDEXED AREA CONTAINS MULTIPLE RECORD TYPES -
      -     'CHANGED TO INTEGRATED.'.
       01 INDEXED-AREA-INVERT-LINE PIC X(68) VALUE
      -     'O CALC.'.
       01 NUMERIC-DATA-LINE PIC X(68) VALUE
           ' **** (0-1-2) NUMERIC DATA TYPES CONVERTED TO PACKED DECIMAL
      -     '.'.
      *01 TOO-DEEP-ERROR.
      *   02 TEXT PIC X(55) VALUE
      *    ' **** LOCATION MODE OF OWNER MUST BE INSERTED MANUALLY.'.
       01 RECORD-ERROR.
          02 TEXT PIC X(48) VALUE
           ' **** ERROR ENCOUNTERED IN ACCESSING GROUP TYPE '.
          02 ERROR-NO PIC XX.
          02 ABORT PIC X(14) VALUE ', RUN ABORTED.'.
       01 GRP-NO-SORT-NOTE PIC X(68) VALUE
            ' **** (0-1-2) NOT EQUIVALENT TO MAJOR OR MINOR SORT ON GRP.
      -     ' '.
       01 INVALID-DDL-MESSAGE PIC X(132) VALUE
            ' **** INVALID KEY WHEN WRITING DDLOUT, RUN ABORTED.'.
       01 INVALID-DMCL-MESSAGE PIC X(132) VALUE
            ' **** INVALID KEY WHEN WRITING DMCLOUT, RUN ABORTED.'.
       01 INVALID-LOCK-MESSAGE PIC X(132) VALUE
            ' **** INVALID KEY WHEN WRITING LOCKOUT, RUN ABORTED.'.
      /
       01 IDSIIRESWORDS.
         02 IDS-II-RESWORDS-TABLE.
          03 FILLER PIC X(18) VALUE IS  'ACTUAL'.
          03 FILLER PIC X(18) VALUE IS  'AFTER'.
          03 FILLER PIC X(18) VALUE IS  'ALL'.
          03 FILLER PIC X(18) VALUE IS  'ALLOCATE'.
          03 FILLER PIC X(18) VALUE IS  'ALLOWED'.
          03 FILLER PIC X(18) VALUE IS  'ALTER'.
          03 FILLER PIC X(18) VALUE IS  'ALWAYS'.
          03 FILLER PIC X(18) VALUE IS  'AND'.
          03 FILLER PIC X(18) VALUE IS  'ANY'.
          03 FILLER PIC X(18) VALUE IS  'APPLICATION'.
          03 FILLER PIC X(18) VALUE IS  'ARE'.
          03 FILLER PIC X(18) VALUE IS  'AREA'.
          03 FILLER PIC X(18) VALUE IS  'ARRAY'.
          03 FILLER PIC X(18) VALUE IS  'ASC'.
          03 FILLER PIC X(18) VALUE IS  'ASCENDING'.
          03 FILLER PIC X(18) VALUE IS  'AT'.
          03 FILLER PIC X(18) VALUE IS  'AUTHOR'.
          03 FILLER PIC X(18) VALUE IS  'AUTO'.
          03 FILLER PIC X(18) VALUE IS  'AUTOMATIC'.
          03 FILLER PIC X(18) VALUE IS  'BASE_DBKEY'.
          03 FILLER PIC X(18) VALUE IS  'BEFORE'.
          03 FILLER PIC X(18) VALUE IS  'BIN'.
          03 FILLER PIC X(18) VALUE IS  'BINARY'.
          03 FILLER PIC X(18) VALUE IS  'BIT'.
          03 FILLER PIC X(18) VALUE IS  'BY'.
          03 FILLER PIC X(18) VALUE IS  'BYTES'.
          03 FILLER PIC X(18) VALUE IS  'CALC'.
          03 FILLER PIC X(18) VALUE IS  'CALC_INTERVAL'.
          03 FILLER PIC X(18) VALUE IS  'CALC_KEY'.
          03 FILLER PIC X(18) VALUE IS  'CALL'.
          03 FILLER PIC X(18) VALUE IS  'CHAIN'.
          03 FILLER PIC X(18) VALUE IS  'CHAR'.
          03 FILLER PIC X(18) VALUE IS  'CHARACTER'.
          03 FILLER PIC X(18) VALUE IS  'CHECK'.
          03 FILLER PIC X(18) VALUE IS  'CLAUSE_TYPE'.
          03 FILLER PIC X(18) VALUE IS  'CLOSE'.
          03 FILLER PIC X(18) VALUE IS  'COMMENT'.
          03 FILLER PIC X(18) VALUE IS  'COMPLEX'.
          03 FILLER PIC X(18) VALUE IS  'COPY'.
          03 FILLER PIC X(18) VALUE IS  'CURRENT'.
          03 FILLER PIC X(18) VALUE IS  'DATA_BASE_KEY'.
          03 FILLER PIC X(18) VALUE IS  'DATA_BASE_KEYS'.
          03 FILLER PIC X(18) VALUE IS  'DBKEY'.
          03 FILLER PIC X(18) VALUE IS  'DBKEYS'.
          03 FILLER PIC X(18) VALUE IS  'DB_DATA_NAME'.
          03 FILLER PIC X(18) VALUE IS  'DB_RECORD_NAME'.
          03 FILLER PIC X(18) VALUE IS  'DECIMAL'.
          03 FILLER PIC X(18) VALUE IS  'DECLARATIVE'.
          03 FILLER PIC X(18) VALUE IS  'DECLARATIVE_TYPE'.
          03 FILLER PIC X(18) VALUE IS  'DECODING'.
          03 FILLER PIC X(18) VALUE IS  'DEFINED'.
          03 FILLER PIC X(18) VALUE IS  'DELETE'.
          03 FILLER PIC X(18) VALUE IS  'DESC'.
          03 FILLER PIC X(18) VALUE IS  'DESCENDING'.
          03 FILLER PIC X(18) VALUE IS  'DIRECT'.
          03 FILLER PIC X(18) VALUE IS  'DISPLAY'.
          03 FILLER PIC X(18) VALUE IS  'DUPLICATES'.
          03 FILLER PIC X(18) VALUE IS  'DUPS'.
          03 FILLER PIC X(18) VALUE IS  'DURING'.
          03 FILLER PIC X(18) VALUE IS  'DYNAMIC'.
          03 FILLER PIC X(18) VALUE IS  'ENCODING'.
          03 FILLER PIC X(18) VALUE IS  'ENTRIES'.
          03 FILLER PIC X(18) VALUE IS  'EQUAL'.
          03 FILLER PIC X(18) VALUE IS  'ERROR'.
          03 FILLER PIC X(18) VALUE IS  'EXCEPT'.
          03 FILLER PIC X(18) VALUE IS  'EXCL'.
          03 FILLER PIC X(18) VALUE IS  'EXCLUSIVE'.
          03 FILLER PIC X(18) VALUE IS  'FIND'.
          03 FILLER PIC X(18) VALUE IS  'FIRST'.
          03 FILLER PIC X(18) VALUE IS  'FIXED'.
          03 FILLER PIC X(18) VALUE IS  'FIXED'.
          03 FILLER PIC X(18) VALUE IS  'FLOAT'.
          03 FILLER PIC X(18) VALUE IS  'FOR'.
          03 FILLER PIC X(18) VALUE IS  'FORTRAN'.
          03 FILLER PIC X(18) VALUE IS  'FORTY'.
          03 FILLER PIC X(18) VALUE IS  'FUNCTION_TYPE'.
          03 FILLER PIC X(18) VALUE IS  'GET'.
          03 FILLER PIC X(18) VALUE IS  'GIVING'.
          03 FILLER PIC X(18) VALUE IS  'IDENTIFIED'.
          03 FILLER PIC X(18) VALUE IS  'IN'.
          03 FILLER PIC X(18) VALUE IS  'INDEX'.
          03 FILLER PIC X(18) VALUE IS  'INDEXED'.
          03 FILLER PIC X(18) VALUE IS  'INPUT_VALUE'.
          03 FILLER PIC X(18) VALUE IS  'INSERT'.
          03 FILLER PIC X(18) VALUE IS  'INSERTION'.
          03 FILLER PIC X(18) VALUE IS  'INTEGRATED'.
          03 FILLER PIC X(18) VALUE IS  'INVENTORY'.
          03 FILLER PIC X(18) VALUE IS  'IS'.
          03 FILLER PIC X(18) VALUE IS  'KEY'.
          03 FILLER PIC X(18) VALUE IS  'KEY_ID'.
          03 FILLER PIC X(18) VALUE IS  'KEYS'.
          03 FILLER PIC X(18) VALUE IS  'LAST'.
          03 FILLER PIC X(18) VALUE IS  'LANGUAGE'.
          03 FILLER PIC X(18) VALUE IS  'LENGTH'.
          03 FILLER PIC X(18) VALUE IS  'LENGTH_OF_ACCOUNT'.
          03 FILLER PIC X(18) VALUE IS  'LINKED'.
          03 FILLER PIC X(18) VALUE IS  'LOC'.
          03 FILLER PIC X(18) VALUE IS  'LOCAL'.
          03 FILLER PIC X(18) VALUE IS  'LOCATION'.
          03 FILLER PIC X(18) VALUE IS  'LOCK'.
          03 FILLER PIC X(18) VALUE IS  'LOCKS'.
          03 FILLER PIC X(18) VALUE IS  'MAND'.
          03 FILLER PIC X(18) VALUE IS  'MANDATORY'.
          03 FILLER PIC X(18) VALUE IS  'MANUAL'.
          03 FILLER PIC X(18) VALUE IS  'MEMBERS'.
          03 FILLER PIC X(18) VALUE IS  'MODE'.
          03 FILLER PIC X(18) VALUE IS  'MODIFY'.
          03 FILLER PIC X(18) VALUE IS  'NAME'.
          03 FILLER PIC X(18) VALUE IS  'NEXT'.
          03 FILLER PIC X(18) VALUE IS  'NEXCL'.
          03 FILLER PIC X(18) VALUE IS  'NONEXCLUSIVE'.
          03 FILLER PIC X(18) VALUE IS  'NONNULL'.
          03 FILLER PIC X(18) VALUE IS  'NOT'.
          03 FILLER PIC X(18) VALUE IS  'OCCURS'.
          03 FILLER PIC X(18) VALUE IS  'OF'.
          03 FILLER PIC X(18) VALUE IS  'ON'.
          03 FILLER PIC X(18) VALUE IS  'OPEN'.
          03 FILLER PIC X(18) VALUE IS  'OPT'.
          03 FILLER PIC X(18) VALUE IS  'OPTIONAL'.
          03 FILLER PIC X(18) VALUE IS  'OR'.
          03 FILLER PIC X(18) VALUE IS  'ORDER'.
          03 FILLER PIC X(18) VALUE IS  'ORGANIZATION'.
          03 FILLER PIC X(18) VALUE IS  'OUTPUT_VALUE'.
          03 FILLER PIC X(18) VALUE IS  'OWNER'.
          03 FILLER PIC X(18) VALUE IS  'PA_TYPE'.
          03 FILLER PIC X(18) VALUE IS  'PAGE_INTERVAL'.
          03 FILLER PIC X(18) VALUE IS  'PERCENT'.
          03 FILLER PIC X(18) VALUE IS  'PER_CENT'.
          03 FILLER PIC X(18) VALUE IS  'PERM'.
          03 FILLER PIC X(18) VALUE IS  'PERMANENT'.
          03 FILLER PIC X(18) VALUE IS  'PIC'.
          03 FILLER PIC X(18) VALUE IS  'PICTURE'.
          03 FILLER PIC X(18) VALUE IS  'PL1'.
          03 FILLER PIC X(18) VALUE IS  'POINTER'.
          03 FILLER PIC X(18) VALUE IS  'POINTER_SEQ'.
          03 FILLER PIC X(18) VALUE IS  'POINTERS'.
          03 FILLER PIC X(18) VALUE IS  'PRIOR'.
          03 FILLER PIC X(18) VALUE IS  'PRIVACY'.
          03 FILLER PIC X(18) VALUE IS  'PROC'.
          03 FILLER PIC X(18) VALUE IS  'PROCEDURE'.
          03 FILLER PIC X(18) VALUE IS  'PROCESSABLE'.
          03 FILLER PIC X(18) VALUE IS  'PROGRAM_NAME'.
          03 FILLER PIC X(18) VALUE IS  'PROT'.
          03 FILLER PIC X(18) VALUE IS  'PROTECTED'.
          03 FILLER PIC X(18) VALUE IS  'RANGE'.
          03 FILLER PIC X(18) VALUE IS  'REAL'.
          03 FILLER PIC X(18) VALUE IS  'RECORD_NAME'.
          03 FILLER PIC X(18) VALUE IS  'RELATIVE'.
          03 FILLER PIC X(18) VALUE IS  'REMOVE'.
          03 FILLER PIC X(18) VALUE IS  'RESERVE'.
          03 FILLER PIC X(18) VALUE IS  'RESULT'.
          03 FILLER PIC X(18) VALUE IS  'RETENTION'.
          03 FILLER PIC X(18) VALUE IS  'RETR'.
          03 FILLER PIC X(18) VALUE IS  'RETRIEVAL'.
          03 FILLER PIC X(18) VALUE IS  'SCALE'.
          03 FILLER PIC X(18) VALUE IS  'SCHEMA'.
          03 FILLER PIC X(18) VALUE IS  'SEARCH'.
          03 FILLER PIC X(18) VALUE IS  'SELECTION'.
          03 FILLER PIC X(18) VALUE IS  'SEQUENTIAL'.
          03 FILLER PIC X(18) VALUE IS  'SET'.
          03 FILLER PIC X(18) VALUE IS  'SIGNED'.
          03 FILLER PIC X(18) VALUE IS  'SORTED'.
          03 FILLER PIC X(18) VALUE IS  'SOURCE'.
          03 FILLER PIC X(18) VALUE IS  'SS_DATA_NAME'.
          03 FILLER PIC X(18) VALUE IS  'SS_RECORD_NAME'.
          03 FILLER PIC X(18) VALUE IS  'STATUS_RETURN'.
          03 FILLER PIC X(18) VALUE IS  'STORE'.
          03 FILLER PIC X(18) VALUE IS  'SYSTEM'.
          03 FILLER PIC X(18) VALUE IS  'SYSTEM_DEFAULT'.
          03 FILLER PIC X(18) VALUE IS  'TEMP'.
          03 FILLER PIC X(18) VALUE IS  'TEMPORARY'.
          03 FILLER PIC X(18) VALUE IS  'THEN'.
          03 FILLER PIC X(18) VALUE IS  'THIS'.
          03 FILLER PIC X(18) VALUE IS  'THRU'.
          03 FILLER PIC X(18) VALUE IS  'TIMES'.
          03 FILLER PIC X(18) VALUE IS  'TO'.
          03 FILLER PIC X(18) VALUE IS  'TYPE'.
          03 FILLER PIC X(18) VALUE IS  'UNSPEC'.
          03 FILLER PIC X(18) VALUE IS  'UNSPECIFIED'.
          03 FILLER PIC X(18) VALUE IS  'USING'.
          03 FILLER PIC X(18) VALUE IS  'VALUE'.
          03 FILLER PIC X(18) VALUE IS  'VARYING'.
          03 FILLER PIC X(18) VALUE IS  'VIA'.
          03 FILLER PIC X(18) VALUE IS  'VIRTUAL'.
          03 FILLER PIC X(18) VALUE IS  'WHERE'.
          03 FILLER PIC X(18) VALUE IS  'WITHIN'.
         02 RES-WORD-TABLE REDEFINES IDS-II-RESWORDS-TABLE
                OCCURS 192 TIMES PICTURE X(18).
      /
       01 TEMP-STORAGE.
         02 TEMP-NAME PIC X(31) VALUE SPACES.
         02 TEMP-NAME2 REDEFINES TEMP-NAME OCCURS 31 TIMES PIC X.
         02 TEMP-NAME3 PIC X(16) VALUE SPACES.
         02 TEMP-NAME4 REDEFINES TEMP-NAME3 OCCURS 16 TIMES PIC X.
       01 OCCURS-COUNT PIC 999.
       01 CHAR-COUNT PIC 999.
       01 WORD-COUNT PIC 999.
       01 CHANGE-RES-WORD-LINE.
          02 FILLER PIC X(6) VALUE ' **** '.
          02 CHANGE-RES-NAME PIC X(90) VALUE IS SPACES.
       01 RESERVED-CHANGE PIC X(44) VALUE
             ' IS A RESERVED WORD AND CHANGED ON NEXT LINE'.
      /
          01 DB-COPY COPY ESCH-COPY.
      /
       PROCEDURE DIVISION.
      * OPEN THE SCHEMA DATA BASE FOR RETRIEVAL ONLY,
      *    AND OBTAIN THE SCHEMAHD GROUP TO GET GOING,
      *    ITS REF-CODE IS AREA 1, PAGE 1, LINE 1.
            DISPLAY ' ESCH A02 HERE' UPON PRINTER
            MOVE 0 TO ERROR-FLAG.
            MOVE '99' TO ERROR-NO.
            OPEN OUTPUT LIST-OUT.
            ENTER FIXIT, SCHEMA-NAME, ERROR-FLAG.
            IF ERROR-FLAG IS NOT EQUAL TO 0 GO TO ERRROR.
            MOVE 0 TO REF-CODE.
            ENTER OPENRET, REF-CODE, SCHEBASE.
            MOVE 16777473 TO REF-CODE.
            ENTER GET, SCHEMAHD.
            ENTER FIXSCHMA, SCHESIZE.
            OPEN OUTPUT DDL-OUT.
            MOVE 1000 TO DDL-COMPKEY.
            OPEN OUTPUT DMCL-OUT.
            MOVE 1000 TO DMCL-COMPKEY.
            OPEN OUTPUT LOCK-OUT.
            MOVE 1000 TO LOCK-COMPKEY.
            PERFORM SCHEMA THRU END-SCHEMA.
            PERFORM GET-PASSWORDS THRU END-GET-PASSWORDS.
            PERFORM GET-AREAS THRU END-GET-AREAS.
            PERFORM GET-SETS THRU END-GET-SETS.
            PERFORM CLOSE-OUT-FILES THRU END-CLOSE-OUT-FILES.
            PERFORM SUMMARY THRU END-SUMMARY.
      /
       SCHEMA.
      * OUTPUT SCHEMA SUMMARY.
            PERFORM COVER THRU END-COVER.
            WRITE LIST-OUT-RECD FROM TOP-OF-FORM.
            WRITE LIST-OUT-RECD FROM DDL-HEAD BEFORE 4.
            MOVE SCHEMA-NAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO SCHEMA-NAME.
            MOVE SUBSCHEMA-NAME TO   TEMP-NAME
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO SUBSCHEMA-NAME, T-NAME.
            STRING SCHEMA-NAME,' END'
               DELIMITED BY '  ' INTO LSCHEMA-NAME.
            STRING SCHEMA-NAME,' DDL END'
               DELIMITED BY '  ' INTO TSCHEMA-NAME.
            STRING SCHEMA-NAME,'_SUBALL'
               DELIMITED BY '  ' INTO SUBSCHEMA-NAME.
           MOVE SUBSCHEMA-NAME TO T-NAME.
            STRING SUBSCHEMA-NAME,'  SCHEMA ',SCHEMA-NAME,' END '
               DELIMITED BY '   ' INTO SUB-VAL-NAME.
            STRING SUBSCHEMA-NAME,' DDL SCHEMA ',SCHEMA-NAME,' END'
               DELIMITED BY '  ' INTO SUBSCHEMA-NAME.
      *     WRITE DDL-OUT-RECD FROM DDL-COMMENT-L1
      *        INVALID PERFORM INVALID-DDL.
      *     WRITE LIST-OUT-RECD FROM COMMENT-L1
      *     ADD 1 TO LIST-LINE
      *     ADD 1000 TO DDL-COMPKEY
      *     WRITE DDL-OUT-RECD FROM DDL-COMMENT-L2
      *        INVALID PERFORM INVALID-DDL.
      *     WRITE LIST-OUT-RECD FROM COMMENT-L2
      *     ADD 1 TO LIST-LINE
      *     ADD 1000 TO DDL-COMPKEY
      *     WRITE DDL-OUT-RECD FROM DDL-COMMENT-L3
      *        INVALID PERFORM INVALID-DDL.
      *     WRITE LIST-OUT-RECD FROM COMMENT-L3
      *     ADD 1 TO LIST-LINE
      *     ADD 1000 TO DDL-COMPKEY
           MOVE SPACES TO SUB-SAVE, LIST-OUT-RECD, DDL-OUT-RECD.
           STRING T-NAME,'_DDL'  DELIMITED BY '   ' INTO SUB-SAVE.
           STRING '!DBACS OVER ',SUB-SAVE DELIMITED BY SIZE
               INTO LIST-OUT-RECD.
           STRING '!DBACS OVER ',SUB-SAVE DELIMITED BY SIZE
             INTO DDL-OUT-RECD.
           WRITE DDL-OUT-RECD INVALID PERFORM INVALID-DDL.
           WRITE LIST-OUT-RECD.
           ADD 1 TO LIST-LINE.
           ADD 1000 TO DDL-COMPKEY.
            WRITE LIST-OUT-RECD FROM TRANS-LINE.
            WRITE DDL-OUT-RECD FROM DDL-TRANS-LINE
               INVALID PERFORM INVALID-DDL.
            STRING SCHEMA-NAME,' DMCL END'
               DELIMITED BY '  ' INTO TSCHEMA-NAME.
            WRITE DMCL-OUT-RECD FROM DDL-TRANS-LINE
               INVALID PERFORM INVALID-DMCL.
            WRITE LOCK-OUT-RECD FROM LOCKS-TRANS-LINE
               INVALID PERFORM INVALID-LOCK THRU END-INVALID-LOCK.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-SCHEMA-LINE
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DDL-SCHEMA-LINE
               INVALID PERFORM INVALID-DMCL.
            WRITE LIST-OUT-RECD FROM SCHEMA-LINE BEFORE 1.
            IF COPYSWD IS NOT EQUAL TO '        ' PERFORM PRIVACY
            THRU END-PRIVACY.
            PERFORM LIST-DDL-PERIOD THRU END-DMCL-PERIOD.
       END-SCHEMA. EXIT.
      /
       COVER.
            WRITE LIST-OUT-RECD FROM TOP-OF-FORM.
            WRITE LIST-OUT-RECD FROM COVER-HEAD.
            WRITE LIST-OUT-RECD FROM LINE-1 AFTER 3.
            WRITE LIST-OUT-RECD FROM LINE-2 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-3 AFTER 3.
            WRITE LIST-OUT-RECD FROM LINE-4 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-6 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-7 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-8 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-10 AFTER 3.
            WRITE LIST-OUT-RECD FROM LINE-11 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-12 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-13 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-14 AFTER 3.
            WRITE LIST-OUT-RECD FROM LINE-15 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-16 AFTER 1.
            WRITE LIST-OUT-RECD FROM LINE-17 AFTER 3.
            WRITE LIST-OUT-RECD FROM LINE-18 AFTER 1.
       END-COVER. EXIT.
      /
       PRIVACY.
            MOVE COPYSWD TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO COPY-WORD.
            MOVE COPY-WORD TO PRIVACY-LOCK.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-PRIVACY-LINE
            ADD 1 TO LIST-LINE.
            WRITE LIST-OUT-RECD FROM PRIVACY-LINE BEFORE 1.
             ADD 1000 TO LOCK-COMPKEY.
             MOVE SPACES TO LOCK-TEXT.
             STRING 'SET ',COPY-WORD,' TO "',COPY-WORD,'"'
                DELIMITED BY '  ' INTO LOCK-TEXT.
      *      WRITE LOCK-OUT-RECD FROM LOCK-STATEMENT
      *         INVALID PERFORM INVALID-LOCK THRU END-INVALID-LOCK.
       END-PRIVACY. EXIT.
      /
       GET-PASSWORDS.
            ENTER FINDN,PASSWSET.
            ENTER GET, PASWORD.
            IF GRP-NO IS EQUAL TO 7 GO TO END-GET-PASSWORDS.
            IF GRP-NO IS NOT EQUAL TO 8 PERFORM ERROR8.
            MOVE 0 TO IDX.
       RET-KEY.
               ADD 1 TO IDX.
               IF IDX IS GREATER THAN 8 GO TO CHECK-UPD.
               IF RKEYS(IDX) IS NOT EQUAL TO 0 GO TO OUTPUT-RET
                  ELSE GO TO RET-KEY.
       OUTPUT-RET.
            MOVE PASSWRD TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO PASS-WORD.
               ADD 1000 TO LOCK-COMPKEY.
               MOVE SPACES TO LOCK-TEXT.
               STRING 'SET ',PASS-WORD,':R TO "',PASS-WORD,'"'
                  DELIMITED BY '  ' INTO LOCK-TEXT.
      *        WRITE LOCK-OUT-RECD FROM LOCK-STATEMENT
      *           INVALID PERFORM INVALID-LOCK THRU END-INVALID-LOCK.
       CHECK-UPD.
            MOVE 0 TO IDX.
       UPD-KEY.
               ADD 1 TO IDX.
               IF IDX IS GREATER THAN 8 GO TO GET-PASSWORDS.
               IF UKEYS(IDX) IS NOT EQUAL TO 0 GO TO OUTPUT-UPD
                  ELSE GO TO UPD-KEY.
       END-UPD-KEY.
       OUTPUT-UPD.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO PASS-WORD.
               ADD 1000 TO LOCK-COMPKEY.
               MOVE SPACES TO LOCK-TEXT.
               STRING 'SET ',PASS-WORD,':U TO "',PASS-WORD,'"'
                  DELIMITED BY '  ' INTO LOCK-TEXT.
      *        WRITE LOCK-OUT-RECD FROM LOCK-STATEMENT
      *           INVALID PERFORM INVALID-LOCK THRU END-INVALID-LOCK.
            GO TO GET-PASSWORDS.
       END-GET-PASSWORDS.
      /
      * THIS PARAGRAPH SEARCHES FOR A NEXT AREAGP GROUP WHICH DEFINES AN AREA.
      *   FOR EACH AREA FOUND, PERFORM AREA AND THEN PERFORM GET-GROUPS
      *   TO PROCESS ALL GROUPS DEFINED IN THE AREA.  WHEN ALL AREAS DEFINED
      *   HAVE BEEN PROCESSED, EXIT.
       GET-AREAS.
            ENTER FINDN,AREASET
      * IF GROUP NUMBER IS 7 WE ARE BACK TO OWNER AND FINISHED.
            IF GRP-NO IS EQUAL TO 7 GO TO END-GET-AREAS.
      * WE HAVE ANOTHER AREA DEFINED.
            IF GRP-NO IS NOT EQUAL TO 1 PERFORM ERROR1.
            PERFORM AREA THRU END-AREA.
      * NOW PROCESS ALL GROUPS DEFINED IN THIS AREA.
            PERFORM GET-GROUPS THRU END-GET-GROUPS.
      * WE HAVE PROCESSED ALL GROUPS, GO LOOK FOR ANOTHER AREA.
            GO TO GET-AREAS.
      * WE HAVE PROCESSED ALL AREAS DEFINED, RETURN TO MAIN PROCEDURE.
       END-GET-AREAS. EXIT.
      /
       AREA.
            ENTER GET,AREAGP.
            MOVE REF-CODE TO AREA-REF-CODE.
            MOVE AREANAME TO AREA-NAME.
            MOVE LIST-LINE TO AREA-LINE-NO.
            MOVE AREA-NAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO AREA-NAME.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-AREA-LINE
               INVALID PERFORM INVALID-DDL.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DDL-AREA-LINE
               INVALID PERFORM INVALID-DMCL.
            COMPUTE TEMP = 2 ** (NBROFLIN - 1) * 16.
            COMPUTE KEYS-PER-PAGE = 2 * TEMP.
            COMPUTE PAGE-INTERVAL-VALUE = 2 * TEMP.
            COMPUTE ALLOCATE-VALUE =
               KEYS-PER-PAGE * ((DATAPGES + 1) / 2)
            MOVE SPACES TO PACK.
            UNSTRING ALLOCATE-VALUE DELIMITED ALL ' ' INTO PACK1, PACK2.
            MOVE SPACES TO ALLOCATE-KEYS.
            STRING PACK2 DELIMITED BY '  ',DATA-BASE-KEYS
               DELIMITED BY '  ' INTO ALLOCATE-KEYS.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DMCL-ALLOCATE-LINE
               INVALID PERFORM INVALID-DMCL.
      *  DETERMINE IF THE AREA SHOULD BE INDEXED OR INTEGRATED.
      *  INDEXED AREAS MAY NOT CONTAIN SETS OR MULTIPLE RECORD TYPES.
            MOVE 0 TO INDEX-TO-CALC.
            IF INDEXIND IS EQUAL TO 0 GO TO AREA-INTEG.
      /
      *  AREA IS INDEXED - TEST FOR SETS AND MULTIPLE RECORD TYPES.
            MOVE CURR-001 TO SAVE-1-001-AREA
            MOVE 0 TO NSET.
            MOVE 0 TO NTYPE.
       AREA-SETS.
            ENTER FINDN,GROUPC
            ENTER GET,UNITT
            IF GRP-NO IS EQUAL TO 1 GO TO AREA-ONE-TYPE.
            ADD 1 TO NTYPE
            IF LOCATMOD IS NOT EQUAL TO IDX ADD 1 TO NTYPE.
       AREA-SET-NEXT.
            ENTER FINDN,OWNERSET
            IF GRP-NO IS EQUAL TO 2 GO TO AREA-SETS.
            ADD 1 TO NSET
      *  GROUP OWNS SETS
            GO TO AREA-CHANGE.
       AREA-ONE-TYPE.
            IF NTYPE = 1 AND NSET = 0 GO TO AREA-INDEXED.
            IF NTYPE > 1
            WRITE LIST-OUT-RECD FROM INDEXED-AREA-RECORD-LINE AFTER 1
            WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
            IF NSET IS > 0
            WRITE LIST-OUT-RECD FROM INDEXED-AREA-LINE AFTER 1
            WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
       AREA-CHANGE.
      *  INDEXED RECORD PARTICIPATES IN A SET OR HAS MULT REC TYPES.
            MOVE 1 TO INDEX-TO-CALC.
            GO TO AREA-INTEG.
       AREA-INDEXED.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DMCL-AREAI-LINE
               INVALID PERFORM INVALID-DMCL.
            GO TO AREA-200.
       AREA-INTEG.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DMCL-AREAI-LINE
               INVALID PERFORM INVALID-DMCL.
       AREA-200.
      *  RE-ESTABLISH AREAGP AND SET CURRENCIES.
            ENTER FINDC,AREAGP
            MOVE ZERO TO TEMP.
            MOVE AREANO TO TEMPX.
            IF INVPERCT IS NOT EQUAL TO 0
               MOVE INVPERCT TO INVENTORY-VALUE
               ADD 1000 TO DMCL-COMPKEY
               WRITE DMCL-OUT-RECD FROM DDL-INVENTORY-LINE
                  INVALID PERFORM INVALID-DMCL.
            IF CHECKSUM IS EQUAL TO 1
               ADD 1000 TO DMCL-COMPKEY
               WRITE DMCL-OUT-RECD FROM DMCL-CHECKSUM-LINE
                    INVALID PERFORM INVALID-DMCL.
            IF JOURNAL IS EQUAL TO 1
               ADD 1000 TO DMCL-COMPKEY
               WRITE DMCL-OUT-RECD FROM DMCL-JOURNAL-LINE
            IF ENCIPHER IS EQUAL TO 1
               ADD 1000 TO DMCL-COMPKEY
               WRITE DMCL-OUT-RECD FROM DMCL-ENCRYPTION-LINE
                    INVALID PERFORM INVALID-DMCL.
            MOVE SPACES TO PACK.
            UNSTRING PAGE-INTERVAL-VALUE DELIMITED ALL ' '
               INTO PACK1, PACK2.
            MOVE SPACES TO PAGE-KEYS.
            STRING PACK2 DELIMITED BY '  ',DATA-BASE-KEYS
               DELIMITED BY '  ' INTO PAGE-KEYS.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DDL-PAGE-INTERVAL-LINE
               INVALID PERFORM INVALID-DMCL.
            PERFORM LIST-DDL-PERIOD THRU END-DMCL-PERIOD.
       END-AREA. EXIT.
      /
       GET-GROUPS.
            ENTER FINDN,GROUPC
      * IF GROUP NUMBER IS 1 WE ARE BACK TO HEADER AND FINISHED.
            IF GRP-NO IS EQUAL TO 1 GO TO END-GET-GROUPS.
      * WE HAVE A GROUP, PROCESS IT.
            ENTER GET,UNITT.
            IF SECINDEX IS EQUAL TO 0
               PERFORM GROUP THRU END-GROUP.
      * IF THIS GROUP HAS INVERT ITEMS, FIND THE INVERT KEYS AND GROUP
            IF INVTITEM IS EQUAL TO 1
                PERFORM INVERT-KEYS THRU END-INVERT-KEYS.
            PERFORM LIST-DDL-PERIOD THRU END-LIST-DDL-PERIOD.
      * NOW PROCESS ALL ITEMS IN GROUP.
            IF SECINDEX IS EQUAL TO 0
               PERFORM GET-ITEMS THRU END-GET-ITEMS
      * ITEMS ALL PROCESSED, LOOK FOR NEXT GROUP.
            GO TO GET-GROUPS.
       END-GET-GROUPS. EXIT.
      /
       GROUP.
      * GET GROUP NAME
            IF GROUPNO IS LESS THAN 1000
               ENTER FINDN,GNAMESET
               IF GRP-NO IS NOT EQUAL TO 18 PERFORM ERROR18
               ELSE
                  ENTER FINDM, NAMESET
                  IF GRP-NO IS NOT EQUAL TO 16 PERFORM ERROR16
                  ELSE
                     ENTER GET, NAMEGP
                     MOVE NAMEVALU TO RECORD-NAME
            ELSE
               MOVE SPACES TO RECORD-NAME
               STRING AREANAME,'_OWNER ' DELIMITED BY ' '
                  INTO RECORD-NAME.
            MOVE RECORD-NAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO RECORD-NAME.
            MOVE LIST-LINE TO RECORD-LINE-NO.
            WRITE LIST-OUT-RECD FROM RECORD-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-RECORD-LINE
               INVALID PERFORM INVALID-DDL.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DDL-RECORD-LINE
               INVALID PERFORM INVALID-DMCL.
            MOVE AREA-NAME TO WITHIN-NAME.
            MOVE WITHIN-NAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO WITHIN-NAME.
            MOVE LIST-LINE TO WITHIN-LINE-NO.
            WRITE LIST-OUT-RECD FROM WITHIN-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-WITHIN-LINE
               INVALID PERFORM INVALID-DDL.
            IF DEFRGE IS EQUAL TO 0 AND GROUPNO IS LESS THAN 1000
               AND BEGPGRGE IS EQUAL TO 1 COMPUTE RANGE1 = 1
               ELSE
               COMPUTE RANGE1 =
                  KEYS-PER-PAGE * (((BEGPGRGE + 1) / 2) + 1) + 1 .
            IF DEFRGE IS EQUAL TO 0 AND GROUPNO IS LESS THAN 1000
                  KEYS-PER-PAGE * ((ENDPGRGE + 1) / 2)
               MOVE SPACES TO PACK
               UNSTRING RANGE1 DELIMITED ALL ' ' INTO PACK1, PACK2
               MOVE SPACES TO RANGE-AREA
               UNSTRING RANGE2 DELIMITED ALL ' ' INTO PACK3, PACK4
               STRING PACK2, ' TO ', PACK4, ' IN ', AREA-NAME
                  DELIMITED BY '  ' INTO RANGE-AREA
               ADD 1000 TO DMCL-COMPKEY
               WRITE DMCL-OUT-RECD FROM DMCL-RANGE-LINE
                  INVALID PERFORM INVALID-DMCL.
            PERFORM GET-RETRIEVAL THRU END-GET-RETRIEVAL.
            IF LOCATMOD IS EQUAL TO DIR
               MOVE LIST-LINE TO LOC-DIR-LINE-NO
               WRITE LIST-OUT-RECD FROM LOC-DIR-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-LOC-DIR-LINE
               INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO INX
               MOVE LIST-LINE TO LOC-INDEX-LINE-NO
               WRITE LIST-OUT-RECD FROM LOC-INDEX-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-LOC-INDEX-LINE
               INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO INX
               MOVE LIST-LINE TO KEY-NAME-LINE-NO
               WRITE LIST-OUT-RECD FROM KEY-NAME-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-KEY-NAME-LINE
               INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO INX
               MOVE LIST-LINE TO ASC-NAME-LINE-NO
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-ASC-NAME-LINE
               INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO CALC OR CLCD
               MOVE LIST-LINE TO LOC-CALC-LINE-NO
               WRITE LIST-OUT-RECD FROM LOC-CALC-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-LOC-CALC-LINE
               INVALID PERFORM INVALID-DDL.
            IF (LOCATMOD IS EQUAL TO CALC OR CLCD)
               AND NUM-RET IS GREATER THAN 1
               PERFORM MORE-CALC VARYING I FROM 1 BY 1
                 UNTIL I IS EQUAL TO NUM-RET     .
            IF LOCATMOD IS EQUAL TO INX OR CALC
               MOVE LIST-LINE TO DUPLICATES-LINE-NO
               WRITE LIST-OUT-RECD FROM DUPLICATES-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-DUPLICATES-LINE
               INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO CLCD
               MOVE LIST-LINE TO DUPLICATE-LINE-NO
               MOVE 'ALLOWED' TO DUPLICATE-CONDITION
               WRITE LIST-OUT-RECD FROM DUPLICATE-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-DUPLICATE-LINE
                 INVALID PERFORM INVALID-DDL.
            IF LOCATMOD IS EQUAL TO VIA
               MOVE LIST-LINE TO LOC-VIA-LINE-NO
               WRITE LIST-OUT-RECD FROM LOC-VIA-LINE BEFORE 1
               ADD 1 TO LIST-LINE
               IF STOR-SET IS EQUAL TO 1
                  WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
            IF LOCATMOD IS EQUAL TO VIA
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-LOC-VIA-LINE
               INVALID PERFORM INVALID-DDL.
            IF GROUPNO IS LESS THAN 10
                  MOVE GROUPNO TO CHAR1
                  MOVE CHAR1 TO TYPE-VALUE
               ELSE IF GROUPNO IS LESS THAN 100
                  MOVE GROUPNO TO CHAR2
                  MOVE CHAR2 TO TYPE-VALUE
               ELSE IF GROUPNO IS LESS THAN 1000
                  MOVE GROUPNO TO CHAR3
                  MOVE CHAR3 TO TYPE-VALUE
               ELSE
                  COMPUTE AREANO-COUNT = 0
                  MOVE AREANO TO AREANO-CNT
                  COMPUTE AREANO-COUNT = AREANO-COUNT  + 1000
                  MOVE AREANO-COUNT TO CHAR4
                  MOVE CHAR4 TO TYPE-VALUE.
            STRING TYPE-VALUE,'.' DELIMITED BY '  '
               INTO TYPE-VALUE
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM DDL-TYPE-LINE
                  INVALID PERFORM INVALID-DMCL.
            IF GROUPNO IS GREATER THAN 999
            MOVE AREANAME TO TEMP-NAME
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES
            MOVE TEMP-NAME TO AREANAME
               MOVE AREANAME TO OWNER-NAME
               STRING OWNER-NAME, CLAUSE DELIMITED BY '  '
                  INTO OWNER-NAME
               WRITE LIST-OUT-RECD FROM OWNER-AREA-LINE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
            IF GRPRLOCK IS EQUAL TO 0 GO TO NO-GRPR-LOCK.
            MOVE GRPRLOCK TO KEY-VALUE.
            PERFORM RET-LOCK THRU END-RET-LOCK.
            MOVE LIST-LINE TO FIND-GET-LINE-NO.
            WRITE LIST-OUT-RECD FROM FIND-GET-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-FIND-GET-LINE
               INVALID PERFORM INVALID-DDL.
       NEXT-FIND-GET.
            PERFORM NEXT-LOCK THRU END-GET-LOCK.
            IF NEXT-SWITCH IS EQUAL TO 0 GO TO NO-GRPR-LOCK.
            MOVE PASS-TEMP TO OR-FIND-VALUE.
            MOVE LIST-LINE TO OR-FIND-LINE-NO.
            WRITE LIST-OUT-RECD FROM OR-FIND-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-OR-FIND-LINE
                  INVALID PERFORM INVALID-DDL.
            GO TO NEXT-FIND-GET.
       NO-GRPR-LOCK.
            IF GRPULOCK IS EQUAL TO 0 GO TO NO-GRPU-LOCK.
            MOVE GRPULOCK TO KEY-VALUE.
            PERFORM UPD-LOCK THRU END-UPD-LOCK.
            MOVE PASS-TEMP TO IRSDM-LOCK-VALUE.
            MOVE LIST-LINE TO IRSDM-LINE-NO.
            WRITE LIST-OUT-RECD FROM IRSDM-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-IRSDM-LINE
               INVALID PERFORM INVALID-DDL.
       NEXT-IRSDM.
            PERFORM NEXT-LOCK THRU END-GET-LOCK.
            IF NEXT-SWITCH IS EQUAL TO 0 GO TO NO-GRPU-LOCK.
            MOVE PASS-TEMP TO OR-IRSDM-VALUE.
            MOVE LIST-LINE TO OR-IRSDM-LINE-NO.
            WRITE LIST-OUT-RECD FROM OR-IRSDM-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-OR-IRSDM-LINE
               INVALID PERFORM INVALID-DDL.
            GO TO NEXT-IRSDM.
       NO-GRPU-LOCK.
            ENTER FINDN, GSTATSET.
            IF GRP-NO IS EQUAL TO 20
               WRITE LIST-OUT-RECD FROM GROUP-STATS-LINE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2
            ELSE IF GRP-NO IS NOT EQUAL TO 2 PERFORM ERROR20.
       END-GROUP. EXIT.
      /
       INVERT-KEYS.
            MOVE CURR-002 TO SAVE-UNIT.
       INVERT-NEXT-KEY.
            ENTER FINDN,ITEMSET
            IF GRP-NO IS EQUAL TO 2 GO TO INVERT-LAST-KEY.
            ENTER GET,ELEMENT
            IF INVTDNO IS EQUAL TO 0 GO TO INVERT-NEXT-KEY.
      *  THIS GROUP CONTAINS INVERTED ITEMS (ALTERNATE KEYS)
      * GET ITEM NAME
            ENTER FINDN,INAMESET
            IF GRP-NO IS NOT EQUAL TO 17 PERFORM ERROR17.
            ENTER FINDM,NAMESET
            ENTER GET,NAMEGP
           MOVE SPACES TO ALT-KEYNAME-VAL.
            MOVE NAMEVALU TO TEMP-NAME
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            STRING 'KEY_',TEMP-NAME DELIMITED BY SPACES
                INTO ALT-KEYNAME-VAL.
            MOVE TEMP-NAME TO ALT-ITEMNAME
            MOVE LIST-LINE TO ALT-KEYNAME-LINE-NO
            WRITE LIST-OUT-RECD FROM ALT-KEYNAME BEFORE 1.
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-ALT-KEYNAME-LINE
                INVALID PERFORM INVALID-DDL.
      *
      * NOW WRITE THE DMCL FOR THE INVERTED KEY.
           MOVE ALT-KEYNAME-VAL TO ALT-KEYNAME1-VAL.
           ADD 1000 TO DMCL-COMPKEY.
           WRITE DMCL-OUT-RECD   FROM DDL-ALT-KEYNAME1-LINE
               INVALID PERFORM INVALID-DMCL.
           ADD 1000 TO DMCL-COMPKEY.
           WRITE DMCL-OUT-RECD   FROM DMCL-ALT-KEYID-LINE
               INVALID PERFORM INVALID-DMCL.
      *
            MOVE LIST-LINE TO ALT-ASCEND-LINE-NO
            WRITE LIST-OUT-RECD FROM ALT-ASCEND BEFORE 1
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-ALT-ASCEND-LINE
                INVALID PERFORM INVALID-DDL.
      /
            MOVE CURR-005 TO SAVE-UNIT1
            MOVE INVTDNO TO GROUPNO
            ENTER FINDG,UNITT
      *  CHECK FOR INVERT DUPLICATES
            IF LOCATMOD IS NOT EQUAL TO CALC GO TO INVERT-DUPS.
            MOVE LIST-LINE TO ALT-NDUPS-LINE-NO
            WRITE LIST-OUT-RECD FROM ALT-NDUPS BEFORE 1.
            ADD 1 TO LIST-LINE
            ADD 1 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-ALT-NDUPS-LINE
                INVALID PERFORM INVALID-DDL.
            GO TO INVERT-END-DUPS.
       INVERT-DUPS.
            IF LOCATMOD IS NOT EQUAL TO CLCD GO TO INVERT-END-DUPS.
            MOVE LIST-LINE TO ALT-DUPS-LINE-NO
            WRITE LIST-OUT-RECD FROM ALT-DUPS  BEFORE 1.
            ADD 1 TO LIST-LINE
            ADD 1 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-ALT-DUPS-LINE
                INVALID PERFORM INVALID-DDL.
       INVERT-END-DUPS.
            MOVE SAVE-UNIT1 TO CURR-005
            ENTER FINDC,ELEMENT.
            ENTER GET,ELEMENT.
            GO TO INVERT-NEXT-KEY.
       INVERT-LAST-KEY.
            MOVE SAVE-UNIT TO CURR-002
            ENTER FINDC,UNITT.
            ENTER GET,UNITT.
       END-INVERT-KEYS. EXIT.
      /
       MORE-CALC.
            MOVE CALC-KEYS(I) TO NEXT-CALC-NAME
            MOVE LIST-LINE TO NEXT-CALC-LINE-NO
            WRITE LIST-OUT-RECD FROM NEXT-CALC-LINE BEFORE 1
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-NEXT-CALC-LINE
              INVALID PERFORM INVALID-DDL.
       END-MORE-CALC. EXIT.
      /
       GET-RETRIEVAL.
            MOVE 0 TO NUM-RET
            MOVE 0 TO STOR-SET.
       GET-NEXT-RETRIEVAL.
            ENTER FINDN, GRPRET.
            IF GRP-NO IS EQUAL TO 2 GO TO END-GET-RETRIEVAL.
            IF GRP-NO IS NOT EQUAL TO 15 PERFORM ERROR15.
            PERFORM RETRIEVAL.
            GO TO GET-NEXT-RETRIEVAL.
       END-GET-RETRIEVAL. EXIT.
      /
       RETRIEVAL.
      * GET GROUPRET GROUP.
            ENTER GET, GROUPRET.
            MOVE DATNAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO DATNAME.
            IF LOCATMOD IS EQUAL TO INX AND
               INDEX-TO-CALC IS EQUAL TO 1
               WRITE LIST-OUT-RECD FROM LOC-CHANGE-LINE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2
               MOVE CALC TO LOCATMOD.
            IF LOCATMOD IS EQUAL TO DIR
            IF LOCATMOD IS EQUAL TO INX
               IF NUM-RET IS EQUAL TO 0
                  MOVE DATNAME TO LOC-INDEX-NAMES
                  MOVE DATNAME TO KEY-NAME-TEXT
                  MOVE DATNAME TO ASC-NAME-TEXT
                  MOVE 1 TO NUM-RET.
            IF LOCATMOD IS EQUAL TO CALC OR CLCD
               IF NUM-RET IS EQUAL TO 0
                  MOVE DATNAME TO LOC-CALC-NAMES
                  MOVE 1 TO NUM-RET
               ELSE
                  ADD 1 TO NUM-RET.
            IF LOCATMOD IS EQUAL TO VIA
               IF NUM-RET IS EQUAL TO 0
                  MOVE DATNAME TO LOC-VIA-NAME
                  MOVE 1 TO NUM-RET
               ELSE
                  IF RTVLTYPE IS EQUAL TO 4
                     MOVE 1 TO STOR-SET
                  GO TO END-GET-RETRIEVAL.
       END-RETRIEVAL. EXIT.
      /
       NEXT-LOCK.
            MOVE 1 TO NEXT-SWITCH.
            GO TO GET-NEXT-PASSWORD.
       RET-LOCK.
            MOVE 0 TO LOCK-SWITCH.
            PERFORM GET-LOCK THRU END-GET-LOCK.
       END-RET-LOCK. EXIT.
       UPD-LOCK.
            MOVE 1 TO LOCK-SWITCH.
            PERFORM GET-LOCK THRU END-GET-LOCK.
       END-UPD-LOCK. EXIT.
      /
       GET-LOCK.
            MOVE 16777473 TO REF-CODE.
            ENTER FINDD, SCHEMAHD.
            MOVE AREA-REF-CODE TO REF-CODE.
            ENTER FINDD, AREAGP.
            COMPUTE IDX = (KEY-VALUE / 32) + 1.
            COMPUTE SHIFT-VALUE = KEY-VALUE - (32 * IDX) + 32.
       GET-NEXT-PASSWORD.
            ENTER FINDN, PASSWSET.
            IF GRP-NO IS EQUAL TO 7 GO TO NO-MATCH.
            ENTER GET, PASWORD.
            IF LOCK-SWITCH IS EQUAL TO 0 MOVE RKEYS(IDX) TO KEY-TEMP
               ELSE MOVE UKEYS(IDX) TO KEY-TEMP.
            PERFORM SHIFT SHIFT-VALUE TIMES.
            IF KEY-TEMP IS LESS THAN 0 GO TO KEY-MATCH
               ELSE GO TO GET-NEXT-PASSWORD.
       NO-MATCH.
            MOVE 0 TO NEXT-SWITCH.
            GO TO END-GET-LOCK.
       KEY-MATCH.
            MOVE SPACES TO PASS-TEMP.
            MOVE PASSWRD TO PASS-TEMP1.
            IF LOCK-SWITCH IS EQUAL TO 0
               STRING PASS-TEMP1,UNDER-R
                  DELIMITED BY SPACES INTO PASS-TEMP
            ELSE
               STRING PASS-TEMP1,UNDER-U
                  DELIMITED BY SPACES INTO PASS-TEMP.
       END-GET-LOCK. EXIT.
      *
      *
      *
       SHIFT.
            MULTIPLY TWO BY KEY-TEMP.
       END-SHIFT.
      /
       GET-ITEMS.
            ENTER FINDN,ITEMSET
      * IF GROUP NUMBER IS 2 WE ARE BACK TO OWNER AND FINISHED.
            IF GRP-NO IS EQUAL TO 2 GO TO END-GET-ITEMS.
      * WE HAVE AN ITEM, PROCESS IT.
            PERFORM ITEM THRU END-ITEM.
      * ITEM PROCESSING COMPLETE, LOOK FOR ANOTHER.
            GO TO GET-ITEMS.
       END-GET-ITEMS. EXIT.
      /
       ITEM.
      * GET ELEMENT GROUP
            ENTER GET, ELEMENT.
      * GET ITEM NAME
            ENTER FINDN, INAMESET.
            IF GRP-NO IS NOT EQUAL TO 17 PERFORM ERROR17.
            ENTER FINDM, NAMESET
            ENTER GET, NAMEGP
            MOVE SPACES TO ITEM-TYPE-TEXT
            MOVE NAMEVALU TO TEMP-NAME
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES
            MOVE TEMP-NAME TO DATA-ITEM-BASE
            MOVE TEMP-NAME TO DATA-ITEM-NAME
            IF OCCURCNT IS > 1
               COMPUTE ITEMSIZE = ITEMSIZE / OCCURCNT
               PERFORM OCCURS-PRESENT THRU END-OCCURS-PRESENT
                  VARYING OCCURS-COUNT FROM 1 BY 1 UNTIL
                  OCCURS-COUNT IS > OCCURCNT
                  GO TO END-ITEM.
            IF OCCURCNT IS EQUAL TO 0
               PERFORM OCCURS-ITEM THRU END-OCCURS-ITEM.
       END-ITEM. EXIT.
      /
       OCCURS-PRESENT.
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER.
            STRING DATA-ITEM-BASE DELIMITED BY ' ','Z',
               CHAR-VALUE DELIMITED BY ' ' INTO DATA-ITEM-NAME.
            PERFORM OCCURS-ITEM THRU END-OCCURS-ITEM.
       END-OCCURS-PRESENT. EXIT.
      /
       OCCURS-ITEM.
            IF ITMRLOCK IS EQUAL TO 0 GO TO NO-ITMR-LOCK.
            MOVE ITMRLOCK TO KEY-VALUE.
            PERFORM RET-LOCK THRU END-RET-LOCK.
            MOVE PASS-TEMP TO LOCK-GET-VALUE.
            MOVE LIST-LINE TO PRIV-GET-LINE-NO.
            WRITE LIST-OUT-RECD FROM PRIV-GET-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-PRIV-GET-LINE
               INVALID PERFORM INVALID-DDL.
       NEXT-GET.
            PERFORM NEXT-LOCK THRU END-GET-LOCK.
            IF NEXT-SWITCH IS EQUAL TO 0 GO TO NO-ITMR-LOCK.
            MOVE PASS-TEMP TO OR-GET-VALUE.
            MOVE LIST-LINE TO OR-GET-LINE-NO.
            WRITE LIST-OUT-RECD FROM OR-GET-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-OR-GET-LINE
                     INVALID PERFORM INVALID-DDL.
                  GO TO NEXT-GET.
       NO-ITMR-LOCK.
            IF ITMULOCK IS EQUAL TO 0 GO TO NO-ITMU-LOCK.
            MOVE ITMULOCK TO KEY-VALUE.
            PERFORM UPD-LOCK THRU END-UPD-LOCK.
            MOVE PASS-TEMP TO LOCK-MOD-VALUE.
            MOVE LIST-LINE TO PRIV-MODIFY-LINE-NO.
            WRITE LIST-OUT-RECD FROM PRIV-MODIFY-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-PRIV-MODIFY-LINE
       NEXT-MODIFY.
            PERFORM NEXT-LOCK THRU END-GET-LOCK.
            IF NEXT-SWITCH IS EQUAL TO 0 GO TO NO-ITMU-LOCK.
               MOVE PASS-TEMP TO OR-MODIFY-VALUE.
               MOVE LIST-LINE TO OR-MODIFY-LINE-NO.
               WRITE LIST-OUT-RECD FROM OR-MODIFY-LINE BEFORE 1.
               ADD 1 TO LIST-LINE.
               ADD 1000 TO DDL-COMPKEY
               WRITE DDL-OUT-RECD FROM DDL-OR-MODIFY-LINE
               INVALID PERFORM INVALID-DDL.
               GO TO NEXT-MODIFY.
       NO-ITMU-LOCK.
            IF ITEMTYPE IS  EQUAL TO 4
               MOVE 'BINARY 35.' TO ITEM-TYPE-TEXT
               GO TO WRITE-TYPE.
            IF ITEMTYPE IS EQUAL TO 1 OR 3
               MOVE 'CHARACTER' TO ITEM-TYPE
               COMPUTE ITEM-SIZE = ITEMSIZE
               GO TO SET-SIZE.
            IF ITEMTYPE IS EQUAL TO 0 OR 2
               PERFORM NUMERIC-PACKED THRU END-NUMERIC-PACKED
               GO TO WRITE-TYPE.
            IF ITEMTYPE IS EQUAL TO 7
               PERFORM PACKED-DECIMAL THRU END-PACKED-DECIMAL
               GO TO WRITE-TYPE.
            IF ITEMTYPE IS EQUAL TO 5
               MOVE 'FLOAT BINARY 35.' TO ITEM-TYPE-TEXT
               GO TO WRITE-TYPE.
            IF ITEMTYPE IS EQUAL TO 6
               MOVE 'FLOAT BINARY 71.' TO ITEM-TYPE-TEXT
               GO TO WRITE-TYPE.
            MOVE        ' UNSPECIFIED' TO ITEM-TYPE.
            COMPUTE ITEM-SIZE = ITEMSIZE
            GO TO SET-SIZE.
      /
       GET-PICTURE.
            ENTER FINDN,DESCPSET
            IF GRP-NO IS EQUAL TO 12 OR 13
               GO TO GET-PICTURE.
            IF GRP-NO IS EQUAL TO 5
            ENTER GET,PICTUR.
       END-PICTURE. EXIT.
      /
       PACKED-DECIMAL.
            ENTER FINDC,ELEMENT
            PERFORM GET-PICTURE
            COMPUTE PICT-COUNT = 0
            COMPUTE SCALE-COUNT = 0
            MOVE PICTCNT TO PICT-CNT
            MOVE SCALE TO SCALE-CNT
            IF SCALE-COUNT IS GREATER THAN 127
                COMPUTE SCALE-COUNT = -1
                MOVE SCALE TO SCALE-CNT.
            COMPUTE NINES = 0
            COMPUTE NUM-TOTAL = 0
            COMPUTE SIGNED = 0
            MOVE ITEMPICT TO TEMP-NAME
            PERFORM PICTURE-SCAN THRU END-PICTURE-SCAN
               VARYING CHAR-COUNT FROM 1 BY 1
                  UNTIL CHAR-COUNT IS GREATER THAN PICT-COUNT.
                COMPUTE NUM-TOTAL = NUM-TOTAL + NINES.
      *
            COMPUTE NUMBER-IN = NUM-TOTAL
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER
            MOVE CHAR-VALUE TO NUM-DIGITS
      *
            COMPUTE NUMBER-IN = SCALE-COUNT
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER
            MOVE CHAR-VALUE TO NUM-SCALE
             IF SIGNED = 1
                  MOVE ' SIGNED.'    TO SIGN-VALUE
              ELSE
                  MOVE '.       '    TO SIGN-VALUE.
            STRING 'DECIMAL ',NUM-DIGITS,',',NUM-SCALE,SIGN-VALUE
               DELIMITED BY '  ' INTO ITEM-TYPE-TEXT.
       END-PACKED-DECIMAL. EXIT.
      /
       NUMERIC-PACKED.
            ENTER FINDC,ELEMENT
            PERFORM GET-PICTURE
            COMPUTE PICT-COUNT = 0
            COMPUTE SCALE-COUNT = 0
            MOVE PICTCNT TO PICT-CNT
            MOVE SCALE TO SCALE-CNT
                COMPUTE SCALE-COUNT = -1
                MOVE SCALE TO SCALE-CNT.
            COMPUTE NINES = 0
            COMPUTE NUM-TOTAL = 0
            COMPUTE SIGNED = 0
            MOVE ITEMPICT TO TEMP-NAME
            PERFORM PICTURE-SCAN THRU END-PICTURE-SCAN
               VARYING CHAR-COUNT FROM 1 BY 1
                  UNTIL CHAR-COUNT IS GREATER THAN PICT-COUNT.
             COMPUTE NUM-TOTAL = NUM-TOTAL + NINES.
      *
            COMPUTE NUMBER-IN = NUM-TOTAL
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER
            MOVE CHAR-VALUE TO NUM-DIGITS
      *
            COMPUTE NUMBER-IN = SCALE-COUNT
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER
            MOVE CHAR-VALUE TO NUM-SCALE
             IF SIGNED = 1
                  MOVE ' SIGNED.'    TO SIGN-VALUE
              ELSE
                  MOVE '.       '    TO SIGN-VALUE.
            STRING 'DECIMAL ',NUM-DIGITS,',',NUM-SCALE,SIGN-VALUE
               DELIMITED BY '  ' INTO ITEM-TYPE-TEXT.
       END-NUMERIC-PACKED. EXIT.
      /
       PICTURE-SCAN.
            IF TEMP-NAME2(CHAR-COUNT) = 'S'
               COMPUTE SIGNED = 1
               GO TO END-PICTURE-SCAN.
            COMPUTE I = CHAR-COUNT + 1
            IF TEMP-NAME2(CHAR-COUNT) = '9'
               IF TEMP-NAME2(I) = '('
                  PERFORM PAREN THRU END-PAREN
               ELSE
                  COMPUTE NINES = NINES + 1.
       END-PICTURE-SCAN. EXIT.
      *     EVALUATE NUMERIC WITHIN PARENTHESIS
       PAREN.
            COMPUTE NUM-VAL = 0
            COMPUTE J = CHAR-COUNT + 2
            COMPUTE K = CHAR-COUNT + 3
            COMPUTE L = CHAR-COUNT + 4
               COMPUTE NUM-SIZE = 1
               MOVE TEMP-NAME2(J) TO CHAR1
               COMPUTE NUM-VAL = CHAR1
               IF TEMP-NAME2(K) IS NUMERIC
                  COMPUTE NUM-SIZE = 2
                  MOVE TEMP-NAME2(K) TO CHAR1
                  COMPUTE NUM-VAL = 10 * NUM-VAL + CHAR1
               IF TEMP-NAME2(L) IS NUMERIC
                  COMPUTE NUM-SIZE = 3
                  MOVE TEMP-NAME2(L) TO CHAR1
                  COMPUTE NUM-VAL = 10 * NUM-VAL + CHAR1.
            COMPUTE CHAR-COUNT = CHAR-COUNT + NUM-SIZE + 2.
              COMPUTE NUM-TOTAL = NUM-TOTAL + NUM-VAL.
       END-PAREN. EXIT.
      /
       DEC-NUMBER.
            IF NUMBER-IN IS LESS THAN 0
               GO TO NEG-DEC-NUMBER.
            IF NUMBER-IN IS LESS THAN 10
               MOVE NUMBER-IN TO CHAR1
               MOVE CHAR1 TO CHAR-VALUE
               GO TO END-DEC-NUMBER.
            IF NUMBER-IN IS LESS THAN 100
               MOVE NUMBER-IN TO CHAR2
               MOVE CHAR2 TO CHAR-VALUE
               GO TO END-DEC-NUMBER.
            MOVE NUMBER-IN TO CHAR3
            MOVE CHAR3 TO CHAR-VALUE.
            GO TO END-DEC-NUMBER.
       NEG-DEC-NUMBER.
            MOVE '-' TO CHAR-SGN
            IF NUMBER-IN IS LESS THAN -99
               MOVE NUMBER-IN TO NCHAR3
               MOVE NCHAR3 TO CHAR-NUM
               GO TO END-DEC-NUMBER.
            IF NUMBER-IN IS LESS THAN -9
               MOVE NUMBER-IN TO NCHAR2
               MOVE NCHAR2 TO CHAR-NUM
               GO TO END-DEC-NUMBER.
           IF NUMBER-IN IS LESS THAN 0
               MOVE NUMBER-IN TO NCHAR1
               MOVE NCHAR1 TO CHAR-NUM.
       END-DEC-NUMBER. EXIT.
      /
       SET-SIZE.
      *
            COMPUTE NUMBER-IN = ITEM-SIZE
            PERFORM DEC-NUMBER THRU END-DEC-NUMBER
            STRING ITEM-TYPE,' ',CHAR-VALUE,' . '
               DELIMITED BY '  ' INTO ITEM-TYPE-TEXT.
       WRITE-TYPE.
            MOVE LIST-LINE TO DATA-ITEM-NAME-LINE-NO.
            WRITE LIST-OUT-RECD FROM DATA-ITEM-NAME-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-DATA-ITEM-NAME-LINE
               INVALID PERFORM INVALID-DDL.
       END-OCCURS-ITEM. EXIT.
      /
       GET-SETS.
            ENTER FINDN,HDRSET.
            IF GRP-NO IS EQUAL TO 7 GO TO END-GET-SETS.
      * WE HAVE A SET, PROCESS IT.
            PERFORM SETT THRU END-SETT.
            GO TO GET-SETS.
       END-GET-SETS. EXIT.
      /
       SETT.
      * GET ASOWNER GROUP
            ENTER GET, ASOWNER.
      * GET SET NAME
            ENTER FINDN, SNAMESET.
            ENTER FINDM, NAMESET.
            ENTER GET, NAMEGP.
      * GET SET NAME
            MOVE NAMEVALU TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO NAMEVALU.
            MOVE NAMEVALU TO SET-NAME.
            MOVE LIST-LINE TO SET-LINE-NO.
      *  "SET NAME IS XXXXXX"
            WRITE LIST-OUT-RECD FROM SET-LINE
               BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-SET-LINE
               INVALID PERFORM INVALID-DDL.
      * GET SET OWNER
            ENTER FINDM, OWNERSET.
      * GET OWNER NAME
            IF GROUPNO IS LESS THAN 1000
               ENTER FINDN, GNAMESET
                  ENTER FINDM, NAMESET
                  ENTER GET, NAMEGP
                  MOVE NAMEVALU TO OWNER-NAME
            ELSE
               ENTER FINDM, GROUPC
               ENTER GET, AREAGP
               MOVE SPACES TO OWNER-NAME
                  STRING AREANAME,'_OWNER ' DELIMITED BY ' '
                     INTO OWNER-NAME.
            MOVE OWNER-NAME TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO OWNER-NAME.
            MOVE LIST-LINE TO OWNER-LINE-NO
      *  ";OWNER IS XXXXXX"
            WRITE LIST-OUT-RECD FROM OWNER-LINE
               BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-OWNER-LINE
               INVALID PERFORM INVALID-DDL.
      * GET SET STATISTICS
            PERFORM GET-SET-STATS THRU END-GET-SET-STATS.
      * GET SET MEMBERS
      * GET FIRST MEMBER TO GET SET ORDER
            ENTER FINDN, SETLINK.
            ENTER GET, ASMEMBER.
            IF GRP-NO IS NOT EQUAL TO 4 PERFORM ERROR4.
            MOVE SPACES TO SUB-ORDER-VALUE.
            IF ORDER IS EQUAL TO 0
               MOVE 'LAST' TO ORDER-VALUE.
            IF ORDER IS EQUAL TO 1
               MOVE 'PRIOR' TO ORDER-VALUE.
            IF ORDER IS EQUAL TO 4
               MOVE 'SORTED' TO ORDER-VALUE
            IF GRPNOKY IS EQUAL TO 2 OR 3
               MOVE 'WITHIN RECORD_NAME' TO SUB-ORDER-VALUE
            ELSE
               MOVE 'BY DEFINED KEYS ' TO SUB-ORDER-VALUE.
            IF ORDER IS EQUAL TO 8
            IF ORDER IS EQUAL TO 9
               MOVE 'NEXT' TO ORDER-VALUE.
            MOVE LIST-LINE TO ORDER-LINE-NO.
            WRITE LIST-OUT-RECD FROM ORDER-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-ORDER-LINE
               INVALID PERFORM INVALID-DDL.
            IF ORDER-VALUE IS EQUAL TO 'SORTED'
                AND GRPNOKY IS NOT EQUAL TO 2 AND 3
            MOVE LIST-LINE TO DUPLICATES-LINE-NO
            WRITE LIST-OUT-RECD FROM DUPLICATES-LINE
               BEFORE 1
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DUPLICATES-TEXT
                INVALID PERFORM INVALID-DDL.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-PRIOR-LINE
               INVALID PERFORM INVALID-DDL.
            IF GRPNOKY IS EQUAL TO 2 OR  3
               WRITE LIST-OUT-RECD FROM GRP-NO-SORT-NOTE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
            MOVE LIST-LINE TO PRIOR-LINE-NO.
            WRITE LIST-OUT-RECD FROM PRIOR-LINE
               BEFORE 1.
            ADD 1 TO LIST-LINE.
            PERFORM LIST-DDL-PERIOD THRU END-LIST-DDL-PERIOD.
      * SAVE LOCATION MODE OF OWNER FOR MEMBER STATEMENT.
            MOVE LOCATMOD TO LOC-MODE-OWNER.
            PERFORM GET-MEMBERS THRU END-GET-MEMBERS.
       END-SETT. EXIT.
      /
       GET-SET-STATS.
            ENTER FINDN, SSTATSET.
            IF GRP-NO IS EQUAL TO 3 GO TO END-GET-SET-STATS.
            WRITE LIST-OUT-RECD FROM SET-STATS-LINE AFTER 1.
            WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
      /
       GET-NEXT-MEMBER.
            ENTER FINDN, SETLINK.
            ENTER GET, ASMEMBER.
            IF GRP-NO IS EQUAL TO 3 GO TO END-GET-MEMBERS.
       GET-MEMBERS.
            PERFORM MEMBER THRU END-MEMBER.
            GO TO GET-NEXT-MEMBER.
       END-GET-MEMBERS. EXIT.
      /
       MEMBER.
      * GET MEMBER NAME - DRIVEN BY CURRENT OF ASMEMBER.
            ENTER FINDM, MEMBRSET.
            ENTER FINDN, GNAMESET.
            IF GRP-NO IS NOT EQUAL TO 18 PERFORM ERROR18.
            ENTER FINDM, NAMESET.
            ENTER GET, NAMEGP.
            MOVE NAMEVALU TO MEMBER-NAME-VALUE.
            MOVE MEMBER-NAME-VALUE TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO MEMBER-NAME-VALUE.
            MOVE LIST-LINE TO MEMBER-LINE-NO.
      * TEST FOR ERRONEOUS '1B' IN OPTIONAL - - BAD EDMSFDP COMPENSATION.
            MOVE ASMEMBER TO TEMPS
            MOVE TEMPX TO TEMPB.
            COMPUTE TEMP = 0
            MOVE TEMPB TO TEMPX
            IF TEMP IS EQUAL TO 27
               IF AUTOMANL IS EQUAL TO 0
                  STRING MEMBER-NAME-VALUE, OPTIONAL-TEXT
                     DELIMITED BY '  ' INTO MEMBER-NAME-VALUE
                  GO TO MEMBER-SKIP.
            IF OPTIONAL IS EQUAL TO 0
               IF AUTOMANL IS EQUAL TO 0
                  STRING MEMBER-NAME-VALUE, AUTOMATIC-TEXT
                     DELIMITED BY '  ' INTO MEMBER-NAME-VALUE
               ELSE
                  STRING MEMBER-NAME-VALUE, MANUAL-TEXT
                     DELIMITED BY '  ' INTO MEMBER-NAME-VALUE.
            IF OPTIONAL IS EQUAL TO 1
               AND AUTOMANL IS EQUAL TO 0
                  STRING MEMBER-NAME-VALUE, OPTIONAL-TEXT
                    DELIMITED BY '  ' INTO MEMBER-NAME-VALUE.
       MEMBER-SKIP.
            WRITE LIST-OUT-RECD FROM MEMBER-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-MEMBER-LINE
               INVALID PERFORM INVALID-DDL.
            IF ORDER IS NOT EQUAL TO 4 GO TO LOC-MEMBER.
            MOVE '      KEY IS' TO KEY-TEXT.
       GET-MEMBER-KEYS.
            ENTER FINDN, CTRLSET.
            IF GRP-NO IS EQUAL TO 4 GO TO END-KEYS.
            MOVE SPACES TO SORT-ASC-DES.
            ENTER GET, ASCNTROL.
            ENTER FINDM, MODFYSET
            ENTER FINDN, INAMESET
            ENTER FINDM, NAMESET
            ENTER GET, NAMEGP
            IF CTRLTYPE IS EQUAL TO 1 MOVE 'ASCENDING ' TO SORT-ASC-DES
            ELSE MOVE 'DESCENDING ' TO SORT-ASC-DES.
            MOVE NAMEVALU  TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO NAMEVALU.
            STRING SORT-ASC-DES, ' ', NAMEVALU DELIMITED BY '  '
               INTO SORT-ASC-DES.
            MOVE LIST-LINE TO MEMBER-SORT-LINE-NO.
            WRITE LIST-OUT-RECD FROM MEMBER-SORT-LINE.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-MEMBER-SORT-LINE
               INVALID PERFORM INVALID-DDL.
            IF MATCHIND IS EQUAL TO 1
               WRITE LIST-OUT-RECD FROM RANGE-NOTE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2.
            MOVE '        , ' TO KEY-TEXT.
            GO TO GET-MEMBER-KEYS.
       END-KEYS.
            IF GRPNOKY NOT EQUAL TO 2 AND 3 GO TO LOC-MEMBER.
            IF DUPSIND IS EQUAL TO 0
               MOVE 'NOT ALLOWED' TO DUPLICATE-CONDITION
            ELSE IF DUPSIND IS EQUAL TO 1
               MOVE 'FIRST' TO DUPLICATE-CONDITION
            ELSE IF DUPSIND IS EQUAL TO 2
               MOVE 'LAST' TO DUPLICATE-CONDITION.
            MOVE LIST-LINE TO DUPLICATE-LINE-NO.
            WRITE LIST-OUT-RECD FROM DUPLICATE-LINE.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-DUPLICATE-LINE
               INVALID PERFORM INVALID-DDL.
      /
      *  DRIVEN BY CURRENT OF UNITT (MEMBER)
       LOC-MEMBER.
            MOVE SET-NAME TO SET-NAME-0.
            MOVE LOC-MODE-OWNER TO LOC-MODE-OWNER1.
      * SAVE CURRENCIES.
            MOVE CURR-002 TO SAVE-1-002-UNITM.
            MOVE CURR-003 TO SAVE-1-003-ASOWN.
            MOVE CURR-004 TO SAVE-1-004-ASMEM.
            IF SETOWNER IS EQUAL TO 1 GO TO SINGLE.
            IF LOC-MODE-OWNER1 IS NOT EQUAL TO VIA GO TO SINGLE.
      * BACK UP ONE LEVEL FOR LOCATION MODE OF OWNER DUE TO VIA
            ENTER FINDC,ASOWNER
            ENTER FINDM,OWNERSET
            MOVE CURR-002 TO SAVE-1-002-UNITO.
       VIA-LOOP1.
            ENTER FINDN,GRPRET.
               IF GRP-NO IS NOT EQUAL TO 15 PERFORM ERROR15.
            ENTER GET GROUPRET.
               IF RTVLTYPE IS NOT EQUAL TO VIA-SET GO TO VIA-LOOP1.
      * VIA SET NAME LOCATED
            MOVE DATNAME TO TEMP-NAME.
            MOVE DATNAME TO NAMEVALU.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO SET-NAME-1.
            ENTER FINDG,NAMEGP
               IF GRP-NO IS NOT EQUAL TO 19 PERFORM ERROR19.
            ENTER FINDM,SNAMESET.
            ENTER FINDM,OWNERSET.
            ENTER GET,UNITT.
            MOVE LOCATMOD TO LOC-MODE-OWNER2
      /
      * BACK UP ONE MORE LEVEL FOR LOCATION MODE OF OWNER DUE TO VIA (5)
      * SAVE CURRENCIES
            MOVE CURR-002 TO SAVE-2-002-UNITO
            MOVE CURR-003 TO SAVE-2-003-ASOWN.
       VIA-FIND-MEM.
            ENTER FINDN,SETLINK
            ENTER FINDM,MEMBRSET
            IF CURR-002 IS NOT EQUAL TO SAVE-1-002-UNITO
               GO TO VIA-FIND-MEM.
            MOVE CURR-004 TO SAVE-2-004-ASMEM
      *  ---IF OWNER IS VIA ---> DEPTH = 2
      *  ---        AND OWNER IS BY APPLICATION
            MOVE 1 TO SETOWNER
            GO TO DOUBLE.
      /
      *VIA-LOOP2.
      *     ENTER FINDN,GRPRET.
      *        IF GRP-NO IS NOT EQUAL TO 15 PERFORM ERROR15.
      *     ENTER GET,GROUPRET.
      *        IF RTVLTYPE IS NOT EQUAL TO VIA-SET GO TO VIA-LOOP2.
      * VIA SET LOCATED
      *     MOVE DATNAME TO TEMP-NAME.
      *     PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
      *     MOVE TEMP-NAME TO NAMEVALU.
      *     MOVE TEMP-NAME TO SET-NAME-2.
      *     ENTER FINDG,NAMEGP.
      *     ENTER FINDN,NAMESET.
      *        IF GRP-NO IS NOT EQUAL TO 19 PERFORM ERROR19.
      *     ENTER FINDM,SNAMESET.
      *     ENTER FINDM,OWNERSET.
      *     ENTER GET,UNITT.
      *     MOVE LOCATMOD TO LOC-MODE-OWNER3.
      *        IF LOC-MODE-OWNER3 IS NOT EQUAL TO VIA GO TO TRIPLE.
      *     WRITE LIST-OUT-RECD FROM TOO-DEEP-ERROR.
      *     ADD 1 TO LIST-LINE.
      *     GO TO END-SELECTION.
      /
            COMPUTE DEPTH = 1
            MOVE SET-NAME-0 TO MEMBER-SET-NAME
            MOVE LOC-MODE-OWNER1 TO LOC-MODE-OWNER
               GO TO BACK-DOWN.
       DOUBLE.
            COMPUTE DEPTH = 2
            MOVE SET-NAME-1 TO MEMBER-SET-NAME
            MOVE LOC-MODE-OWNER2 TO LOC-MODE-OWNER
               GO TO BACK-DOWN.
      *TRIPLE.
      *     COMPUTE DEPTH = 3
      *     MOVE SET-NAME-2 TO MEMBER-SET-NAME
      *     MOVE LOC-MODE-OWNER3 TO LOC-MODE-OWNER
      *        GO TO BACK-DOWN.
      /
       BACK-DOWN.
            MOVE LIST-LINE TO MEMBER-SET-LINE-NO.
            WRITE LIST-OUT-RECD FROM MEMBER-SET-LINE.
            ADD 1 TO LIST-LINE.
      * ";SET SELECTION THRU MEMBER-SET-NAME"
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-MEMBER-SET-LINE
               INVALID PERFORM INVALID-DDL.
      /
      *  "OWNER IDENTIFIED BY IS BY APPLICATION"
       APPL-OWNER.
            IF SETOWNER IS EQUAL TO 0 GO TO DIRECT-OWNER.
            MOVE LIST-LINE TO APPLICATION-LINE-NO
            WRITE LIST-OUT-RECD FROM APPLICATION-LINE
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-APPLICATION-LINE
               INVALID PERFORM INVALID-DDL.
            IF DEPTH IS EQUAL TO 1
               GO TO END-SELECTION
            ELSE
               GO TO GET-VIA-KEYS.
      /
      *  OWNER SELECTION IS DIRECT.
       DIRECT-OWNER.
            IF LOC-MODE-OWNER IS NOT EQUAL TO DIR GO TO CALC-OWNER.
            MOVE LIST-LINE TO DATA-BASE-KEY-LINE-NO
            MOVE SPACES TO DB-KEY-NAME
            ENTER FINDN, ALIASSET
            IF GRP-NO IS EQUAL TO 14
               ENTER FINDM, ALNAMSET
               ENTER GET, NAMEGP
               STRING ' EQUAL TO ', NAMEVALU, DELIMITED BY '  '
                  INTO DB-KEY-NAME.
            WRITE LIST-OUT-RECD FROM DATA-BASE-KEY-LINE
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-DATA-BASE-KEY-LINE
               INVALID PERFORM INVALID-DDL.
            IF DEPTH IS EQUAL TO 1
               GO TO END-SELECTION
            ELSE
               GO TO GET-VIA-KEYS.
      /
      *  SET SELECTION IS BY CALC
       CALC-OWNER.
            MOVE LIST-LINE TO CALC-LINE-NO.
            MOVE SPACES TO CALC-NAMES.
            MOVE 1 TO FIRST-ALIAS.
       GET-NEXT-ALIAS.
            ENTER FINDN, ALIASSET.
            IF GRP-NO IS EQUAL TO 4
               GO TO END-ALIAS
            ELSE
               ENTER FINDM, ALNAMSET
               ENTER GET, NAMEGP
               IF FIRST-ALIAS IS EQUAL TO 1
                  STRING ' EQUAL TO ', NAMEVALU, DELIMITED BY '  '
                     INTO CALC-NAMES
                  MOVE 0 TO FIRST-ALIAS
               ELSE
                  STRING CALC-NAMES, ', ', NAMEVALU DELIMITED BY '  '
                     INTO CALC-NAMES.
            GO TO GET-NEXT-ALIAS.
       END-ALIAS.
            WRITE LIST-OUT-RECD FROM CALC-LINE.
            ADD 1 TO LIST-LINE.
               ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-CALC-LINE
               INVALID PERFORM INVALID-DDL.
            IF DEPTH EQUAL TO 1 GO TO END-SELECTION.
      /
      *  SET SELECTION IS VIA
      * THEN THRU SET-NAME
            IF DEPTH IS EQUAL TO 2 GO TO VIA-THRU-2.
            MOVE SET-NAME-1 TO THRU-SET-NAME.
            MOVE SAVE-2-004-ASMEM TO CURR-004.
            ENTER FINDC,ASMEMBER.
            PERFORM VIA-KEYS THRU END-VIA-KEYS.
       VIA-THRU-2.
            MOVE SET-NAME-0 TO THRU-SET-NAME.
            MOVE SAVE-2-004-ASMEM TO CURR-004.
            ENTER FINDC,ASMEMBER.
            PERFORM VIA-KEYS THRU END-VIA-KEYS.
            GO TO END-SELECTION.
       END-GET-VIA-KEYS.
      /
      *  DRIVEN BY CURRENT OF ASMEMBER
       VIA-KEYS.
            MOVE LIST-LINE TO THEN-THRU-LINE-NO
            WRITE LIST-OUT-RECD FROM THEN-THRU-LINE.
            ADD 1 TO LIST-LINE
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-THEN-THRU-LINE
               INVALID PERFORM INVALID-DDL.
       NEXT-VIA-KEY.
            ENTER FINDN,CTRLSET.
               IF GRP-NO IS EQUAL TO 4 GO TO END-VIA-KEYS.
            ENTER GET,ASCNTROL.
            ENTER FINDM,MODFYSET.
            ENTER FINDN,INAMESET.
            ENTER FINDM,NAMESET.
            ENTER GET,NAMEGP.
            MOVE NAMEVALU TO TEMP-NAME.
            PERFORM CHANGE-NAMES THRU END-CHANGE-NAMES.
            MOVE TEMP-NAME TO WHERE-DBID.
            MOVE LIST-LINE TO WHERE-LINE-NO.
            WRITE LIST-OUT-RECD FROM WHERE-LINE.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-WHERE-LINE
               INVALID PERFORM INVALID-DDL.
            GO TO NEXT-VIA-KEY.
       END-VIA-KEYS. EXIT.
      /
       END-SELECTION.
      *  RESTORE OWNER CURRENCY.
            MOVE SAVE-1-003-ASOWN TO CURR-003
            ENTER FINDC,ASOWNER.
      *  RESTORE MEMBER CURRENCY.
            MOVE SAVE-1-004-ASMEM TO CURR-004
            ENTER FINDC,ASMEMBER
            PERFORM LIST-DDL-PERIOD THRU END-LIST-DDL-PERIOD.
       END-MEMBER. EXIT.
      * MEMBER PROCEDURE STARTS NEAR LINE 1663.
      /
       CLOSE-OUT-FILES.
            MOVE LIST-LINE TO END-SCHEMA-LINE-NO.
            WRITE LIST-OUT-RECD FROM END-SCHEMA-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM DDL-END-SCHEMA-LINE
               INVALID GO TO CLOSE-OUT.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM END-DMCL-LINE
               INVALID GO TO CLOSE-OUT.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM SSUB-TRANS-LINE
               INVALID GO TO CLOSE-OUT.
           ADD 1000 TO DMCL-COMPKEY.
           MOVE SPACES TO DMCL-OUT-RECD.
           MOVE 'END ' TO DMCL-OUT-RECD.
           WRITE DMCL-OUT-RECD INVALID GO TO CLOSE-OUT.
           ADD 1000 TO DMCL-COMPKEY.
           MOVE SPACES TO DMCL-OUT-RECD.
           STRING '!DBACS ',SUB-SAVE DELIMITED BY SIZE
                   INTO DMCL-OUT-RECD.
           WRITE DMCL-OUT-RECD INVALID GO TO CLOSE-OUT.
           ADD 1000 TO DMCL-COMPKEY.
           MOVE SPACES TO DMCL-OUT-RECD.
           MOVE '!DBACS ' TO DMCL-OUT-RECD.
           WRITE DMCL-OUT-RECD INVALID GO TO CLOSE-OUT.

           ADD 1000 TO DMCL-COMPKEY.
           WRITE DMCL-OUT-RECD FROM SUB-VAL-LINE
               INVALID GO TO CLOSE-OUT.
       CLOSE-OUT.
            CLOSE DDL-OUT WITH LOCK.
            CLOSE DMCL-OUT WITH LOCK.
            CLOSE LOCK-OUT WITH LOCK.
       END-CLOSE-OUT-FILES. EXIT.
            ENTER DMSTRACE.
       END-TRACER. EXIT.
      /
       SUMMARY.
            OPEN I-O DMCL-IN.
            OPEN I-O LOCK-IN.
            WRITE LIST-OUT-RECD FROM TOP-OF-FORM.
            WRITE LIST-OUT-RECD FROM DMCL-HEAD BEFORE 3.
       GET-NEXT-DMCL.
            READ DMCL-IN INTO IN-RECD AT END GO TO PRINT-LOCK-FILE.
            ENTER LASTKEY DMCL-IN, KEY1, THREE.
            IF ASTERISKS EQUAL TO '****'
               ENTER DELETER DMCL-IN, KEY1, THREE
               WRITE LIST-OUT-RECD FROM IN-RECD
            ELSE
               DIVIDE DDL-COMPKEY BY 1000 GIVING LIST-LINE-NO
               WRITE LIST-OUT-RECD FROM LIST-IN-RECD.
            GO TO GET-NEXT-DMCL.
       PRINT-LOCK-FILE.
            WRITE LIST-OUT-RECD FROM TOP-OF-FORM.
            WRITE LIST-OUT-RECD FROM LOCK-HEAD BEFORE 3.
       GET-NEXT-LOCK.
            READ LOCK-IN INTO IN-RECD AT END GO TO CLOSE-FILES.
            ENTER LASTKEY LOCK-IN, KEY1, THREE.
            IF ASTERISKS EQUAL TO '****'
               ENTER DELETER LOCK-IN, KEY1, THREE
               WRITE LIST-OUT-RECD FROM IN-RECD
            ELSE
               DIVIDE DDL-COMPKEY BY 1000 GIVING LIST-LINE-NO
               WRITE LIST-OUT-RECD FROM LIST-IN-RECD.
            GO TO GET-NEXT-LOCK.
            CLOSE LOCK-IN WITH LOCK.
       CLOSE-FILES.
            CLOSE DMCL-IN WITH LOCK.
            STOP RUN.
       END-SUMMARY. EXIT.
      /
       INVALID-DDL.
            WRITE LIST-OUT-RECD FROM INVALID-DDL-MESSAGE.
            PERFORM CLOSE-OUT-FILES THRU END-CLOSE-OUT-FILES.
            STOP RUN.
       END-INVALID-DDL. EXIT.
       INVALID-DMCL.
            PERFORM CLOSE-OUT-FILES THRU END-CLOSE-OUT-FILES.
            STOP RUN.
       END-INVALID-DMCL. EXIT.
       INVALID-LOCK.
            WRITE LIST-OUT-RECD FROM INVALID-LOCK-MESSAGE.
            PERFORM CLOSE-OUT-FILES THRU END-CLOSE-OUT-FILES.
            STOP RUN.
       END-INVALID-LOCK. EXIT.
      /
       ERROR1.
            MOVE '1 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR2.
            MOVE '2 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR3.
            MOVE '3 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR4.
            MOVE '4 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR5.
            MOVE '5 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR6.
            MOVE '6 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR7.
            MOVE '7 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR8.
            MOVE '8 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR9.
            MOVE '9 ' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR10.
            MOVE '10' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR11.
            MOVE '11' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR12.
            MOVE '12' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR13.
            MOVE '13' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR14.
            PERFORM ERRROR THRU END-ERROR.
       ERROR15.
            MOVE '15' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR16.
            MOVE '16' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR17.
            MOVE '17' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR18.
            MOVE '18' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR19.
            MOVE '19' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR20.
            MOVE '20' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
       ERROR21.
            MOVE '21' TO ERROR-NO.
            PERFORM ERRROR THRU END-ERROR.
      /
       ERRROR.
            WRITE LIST-OUT-RECD FROM RECORD-ERROR.
            PERFORM CLOSE-OUT-FILES THRU END-CLOSE-OUT-FILES.
            STOP RUN.
       END-ERROR. EXIT.
       LIST-DDL-PERIOD.
            MOVE LIST-LINE TO PERIOD-LINE-NO.
            WRITE LIST-OUT-RECD FROM PERIOD-LINE BEFORE 1.
            ADD 1 TO LIST-LINE.
            ADD 1000 TO DDL-COMPKEY
            WRITE DDL-OUT-RECD FROM PERIOD-TEXT
               INVALID PERFORM INVALID-DDL.
       END-LIST-DDL-PERIOD.
      /
       DMCL-PERIOD.
            ADD 1000 TO DMCL-COMPKEY
            WRITE DMCL-OUT-RECD FROM PERIOD-TEXT
               INVALID PERFORM INVALID-DMCL.
       END-DMCL-PERIOD. EXIT.
      /
       CHANGE-NAMES.
            PERFORM CHECK-HYPHENS THRU END-HYPHENS VARYING CHAR-COUNT
               FROM 2 BY 1 UNTIL TEMP-NAME2(CHAR-COUNT) = ' '.
            IF TEMP-NAME2(1) IS NOT ALPHABETIC
               STRING '"',TEMP-NAME,'"',NUMERIC-CHANGE
                  DELIMITED BY '  ' INTO CHANGE-NUMERIC-NAME
               WRITE LIST-OUT-RECD FROM CHANGE-NUMERIC-NAME-LINE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2
               PERFORM PREFIX-Z THRU END-PREFIX-Z VARYING CHAR-COUNT
                  FROM 30 BY -1 UNTIL CHAR-COUNT < 2
               MOVE 'Z' TO TEMP-NAME2(1)
               GO TO END-CHANGE-NAMES.
            PERFORM CHECK-RESWORDS THRU END-RESWORDS
               VARYING WORD-COUNT FROM 1 BY 1 UNTIL WORD-COUNT > 192.
       END-CHANGE-NAMES. EXIT.
      *
       CHECK-HYPHENS.
            IF TEMP-NAME2(CHAR-COUNT) = '-'
               MOVE '_' TO TEMP-NAME2(CHAR-COUNT).
       END-HYPHENS. EXIT.
      *
       CHECK-RESWORDS.
            MOVE RES-WORD-TABLE(WORD-COUNT) TO TEMP-NAME3.
            IF TEMP-NAME2(1) < TEMP-NAME4(1) GO TO END-RESWORDS.
            IF TEMP-NAME = RES-WORD-TABLE(WORD-COUNT)
               MOVE SPACES TO CHANGE-RES-NAME
               STRING '"',TEMP-NAME,'"',RESERVED-CHANGE
                  DELIMITED BY '  ' INTO CHANGE-RES-NAME
               WRITE LIST-OUT-RECD FROM CHANGE-RES-WORD-LINE AFTER 1
               WRITE LIST-OUT-RECD FROM BLANK-LINE AFTER 2
               PERFORM PREFIX-Z THRU END-PREFIX-Z VARYING CHAR-COUNT
                  FROM 17 BY -1 UNTIL CHAR-COUNT < 2
               MOVE 'Z' TO TEMP-NAME2(1).
       END-RESWORDS. EXIT.
       PREFIX-Z.
            COMPUTE CHAR2 = CHAR-COUNT - 1.
            MOVE TEMP-NAME2(CHAR2) TO TEMP-NAME2(CHAR-COUNT).
       END-PREFIX-Z. EXIT.
