FASTLOAD Format Program Sample Listing

This section shows a listing of a format program that can be used with IDMSDBLU to load the sample Commonweather database provided during the CA IDMS/DB installation. The program is written in COBOL and has been run through the CA IDMS DML COBOL precompiler.
idmscu
This section shows a listing of a format program that can be used with IDMSDBLU to load the sample Commonweather database provided during the CA IDMS/DB installation. The program is written in COBOL and has been run through the CA IDMS DML COBOL precompiler.
Format program for FASTLOAD
      *RETRIEVAL       *DMLIST        IDENTIFICATION DIVISION.        PROGRAM-ID.                     EMPFLOAD.       *AUTHOR.                         KGV.       *       *INSTALLATION.                   CA       *                                8600 BRYN MAWR AVENUE       *                                CHICAGO, IL 60131.       *       *DATE-WRITTEN.                   08/20/90.       *UPDATED FOR 15.0.               11/16/00.  LRD.       *       *REMARKS.                        THIS PROGRAM CREATES DATA TO       *                                BE USED AS INPUT TO THE FASTLOAD       *                                UTILITY, TO LOAD THE EMPLOYEE       *                                DEMO DATABASE.  IT USES THE SAME       *                                INPUT AS EMPLOAD.        ENVIRONMENT DIVISION.        IDMS-CONTROL SECTION.        PROTOCOL.                       MODE IS BATCH                                             DEBUG                                        IDMS-RECORDS WITHIN                                             WORKING-STORAGE SECTION.        DATA DIVISION.        SCHEMA SECTION.        DB  EMPSS01 WITHIN EMPSCHM  VERSION 100.            SKIP2        WORKING-STORAGE SECTION.       *        01  OWNER-DESCRIPTOR-ONE.            03  OWNER-ONE-SET           PIC X(16).            03  OWNER-ONE-SERIAL        PIC S9(8) COMP.            03  OWNER-ONE-KEY           PIC X(40).            03  OWNER-ONE-KEY-RDEF REDEFINES OWNER-ONE-KEY.                05 OWNER-ONE-KEY-SERIAL PIC S9(8) COMP.                05 FILLER               PIC X(36).        01  OWNER-DESCRIPTOR-TWO.            03  OWNER-TWO-SET           PIC X(16).            03  OWNER-TWO-SERIAL        PIC S9(8) COMP.            03  OWNER-TWO-KEY           PIC X(40).            03  OWNER-TWO-KEY-RDEF REDEFINES OWNER-TWO-KEY.                05 OWNER-TWO-KEY-SERIAL PIC S9(8) COMP.                05 FILLER               PIC X(36).        01  OWNER-DESCRIPTOR-THREE.            03  OWNER-THREE-SET         PIC X(16).            03  OWNER-THREE-SERIAL      PIC S9(8) COMP.            03  OWNER-THREE-KEY         PIC X(40).            03  OWNER-THREE-KEY-RDEF REDEFINES OWNER-THREE-KEY.                05 OWNER-THREE-KEY-SERIAL PIC S9(8) COMP.                05 FILLER               PIC X(36).        01  OCCURRENCE-DESCRIPTOR.            03  RECORD-SR-NAME          PIC X(18).            03  FILLER                  PIC X(6)  VALUE LOW-VALUES.            03  RECORD-ID               PIC S9(8) COMP.            03  RECORD-SUGGESTED-PAGE   PIC S9(8) COMP.            03  FILLER                  PIC S9(8) COMP VALUE ZERO.            03  RECORD-SERIAL           PIC S9(8) COMP.            03  RECORD-LOAD-STATUS      PIC X(4).            03  RECORD-DATA             PIC X(2040).            03  FILLER                  REDEFINES RECORD-DATA.                05  RECORD-DATA-REDEF   PIC X(40).                05  FILLER              PIC X(2000).       *       *       *        01  MISCELLANEOUS-FIELDS.            02  END-FLAG                PIC XXX     VALUE SPACES.              88  END-OF-DATA           VALUE 'END'.            02  COUNTS.              03  SUM-CARDS-IN          PIC  9(6)   VALUE ZERO.              03  SUM-TRANSACTIONS      PIC  9(6)   VALUE ZERO.              03  CARD-COUNT            PIC  9(6)   VALUE ZERO.            02  ERROR-MESSAGE           PIC  X(30)  VALUE SPACES.            02  I-CTRL                  PIC  S9(4)  COMP SYNC.            02  SAVE-COVERAGE-SERIAL    PIC  S9(8)  COMP SYNC.            SKIP2        01  CARD-IMAGE.            02  CI-DATA-IMAGE.             03 CI-KEYFIELDS.              04  FILLER                PIC  X.              04  CI-CARD-TYPE          PIC  XX.                88  CI-END              VALUE 'EN'.              04  CI-CARD-TYPE-RD       REDEFINES CI-CARD-TYPE.                  05  CI-CARD-TYPE-MAJ  PIC  X.                  05  CI-CARD-TYPE-MIN  PIC  X.                    88  CI-FIRST-PART   VALUES ARE                      'A', 'C', 'E', 'G', 'I', 'M', 'O', 'Q', 'S'.                    88  CI-2ND-PART  VALUES ARE                      'B', 'D', 'F', 'H', 'J', 'L', 'N', 'P', 'R', 'T'.              04  FILLER                PIC  X.              04  CI-EMP-ID             PIC  9(4).              04  CI-INSPLAN            REDEFINES CI-EMP-ID.                  05  CI-INSPLAN-CODE   PIC  9(3).                  05  FILLER            PIC  X.              04  CI-OFFICE             REDEFINES CI-EMP-ID.                  05  CI-OFFICE-CODE    PIC  9(3).                  05  FILLER            PIC  X.             03  CI-DATAFIELDS          PIC  X(72).            SKIP3       ***************************************************************       *       TRANSACTION-STORAGE:                                  *       *          ONE CARD TYPE FOR EACH INPUT RECORD TYPE;          *       *          EACH CARD CONTAINS A CARD-TYPE CODE.               *       *          INPUT CARDS MAY INCLUDE KEYFIELDS USED BY          *       *          THE PROGRAM TO MAKE THE APPROPRIATE OWNER          *       *          RECORDS CURRENT BEFORE A MEMBER IS STORED.         *       *          TRANSACTION-STORAGE IS REDEFINED FOR THE           *       *          FORMAT OF EACH TYPE OF INPUT CARD.                 *       ***************************************************************        01  TRANSACTION-STORAGE-AREA.            02  TRANSACTION-STORAGE-ALL.             03  TSA-SINGLE-CARD.              04  TSA-KEYFIELDS.               05  FILLER               PIC  X.               05  TSA-CARD-TYPE        PIC  XX.                88  TSA-DEPARTMENT      VALUE IS 'D '.                88  TSA-EMPLOYEE        VALUE IS 'E1'.                88  TSA-JOB             VALUE IS 'J1'.                88  TSA-EMPOSITION      VALUE IS 'P '.                88  TSA-EXPERTISE       VALUE IS 'T '.                88  TSA-SKILL           VALUE IS 'S '.                88  TSA-OFFICE          VALUE IS 'O1'.                88  TSA-STRUCTURE       VALUE IS 'OG'.                88  TSA-INS-PLAN-CODE   VALUE IS 'I1'.                88  TSA-COVERAGE        VALUE IS 'C '.                88  TSA-DENTAL          VALUE IS 'L1'.                88  TSA-HOSPITAL        VALUE IS 'H1'.                88  TSA-NON-HOSP-CLAIM  VALUE IS 'N1'.             04  FILLER                 PIC  X(77).            03  TSA-OTHER-CARD-SPACE    PIC  X(400).           02  DEPT-STORAGE-AREA        REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  D-CARD.             04  D-KEYFIELDS.              05  FILLER                PIC  X(4).              05  D-DEPT-ID             PIC  9(4).             04  D-DATAFIELDS.              05  D-DEPT-NAME           PIC  X(45).              05  D-DEPT-HEAD-ID        PIC  9(4).              05  FILLER                PIC  X(23).            03  FILLER                  PIC  X(400).           02  EMPLOYEE-STORAGE-AREA    REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  E1-CARD.             04  E1-KEYFIELDS.              05  FILLER                PIC  X(4).              05  E1-EMP-ID             PIC  9(4).             04  E1-DATAFIELDS.              05  E1-EMP-NAME           PIC  X(25).              05  E1-EMP-DEPT-ID        PIC  9(4).              05  E1-EMP-OFFICE         PIC  9(3).              05  FILLER                PIC  X(40).            03  E2-CARD.             04  E2-KEYFIELDS.              05  FILLER                PIC  X(4).              05  E2-EMP-ID             PIC  9(4).             04  E2-DATAFIELDS.              05  E2-EMP-ADDRESS        PIC  X(46).              05  E2-EMP-PHONE          PIC  9(10).              05  E2-EMP-STATUS         PIC  9(2).              05  E2-EMP-SS-NUMBER      PIC  9(9).              05  FILLER                PIC  X(5).            03  E3-CARD.             04  E3-KEYFIELDS.              05  FILLER                PIC  X(4).              05  E3-EMP-ID             PIC  9(4).             04  E3-DATAFIELDS.              05  E3-EMP-START          PIC  9(8).              05  E3-EMP-DOB            PIC  9(8).              05  E3-EMP-TERM           PIC  9(8).              05  FILLER                PIC  X(48).            03  FILLER                  PIC  X(240).           02  JOB-STORAGE-AREA         REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  J1-CARD.             04  J1-KEYFIELDS.              05  FILLER                PIC  X(4).              05  J1-JOB-ID             PIC  9(4).             04  J1-DATAFIELDS.              05  J1-JOB-TITLE          PIC  X(20).              05  J1-JOB-MIN-SAL        PIC  9(8).              05  J1-JOB-MAX-SAL        PIC  9(8).              05  J1-JOB-SAL-GRDS       PIC  9(2) OCCURS 4.              05  J1-JOB-NUM-POSTS      PIC  9(3).              05  J1-JOB-NUM-OPEN       PIC  9(3).              05  FILLER                PIC  X(22).            03  J2-CARD.             04  J2-KEYFIELDS.              05  FILLER                PIC  X(4).             04  J2-DATAFIELDS.              05  J2-JOB-DES-LINE       PIC  X(60).              05  FILLER                PIC  X(16).            03  J3-CARD.             04  J3-KEYFIELDS.              05  FILLER                PIC  X(4).             04  J3-DATAFIELDS.              05  J3-JOB-DES-LINE       PIC  X(60).              05  FILLER                PIC  X(16).            03  J4-CARD.             04  J4-KEYFIELDS.              05  FILLER                PIC  X(4).             04  J4-DATAFIELDS.              05  J4-JOB-REQ-LINE       PIC  X(60).              05  FILLER                PIC  X(16).            03  J5-CARD.             04  J5-KEYFIELDS.              05  FILLER                PIC  X(4).             04  J5-DATAFIELDS.              05  J5-JOB-REQ-LINE       PIC  X(60).              05  FILLER                PIC  X(16).            03  FILLER                  PIC  X(80).           02  POSITION-STORAGE-AREA    REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  P-CARD.             04  P-KEYFIELDS.              05  FILLER                PIC  X(4).              05  P-JOB-ID              PIC  9(4).              05  P-EMP-ID              PIC  9(4).             04  P-DATAFIELDS.              05  P-START-DATE          PIC  9(8).              05  P-FINISH-DATE         PIC  9(8).              05  P-SALARY-GRADE        PIC  9(2).              05  P-SALARY-AMOUNT       PIC  9(6)V99.              05  P-BONUS-PERCENT       PIC  V999.              05  P-COMM-PERCENT        PIC  V999.              05  P-OVERTIME-RATE       PIC  9V99.             04  FILLER                 PIC  X(33).            03  FILLER                  PIC  X(400).           02  EXPERTISE-STORAGE-AREA   REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  T-CARD.             04  T-KEYFIELDS.              05  FILLER                PIC  X(4).              05  T-SKILL-ID            PIC  9(4).              05  T-EMP-ID              PIC  9(4).             04  T-DATAFIELDS.              05  T-SKILL-LEVEL         PIC  9(2).              05  T-EXPERTISE-DATE      PIC  9(8).              05  FILLER                PIC  X(58).            03  FILLER                  PIC  X(400).           02  SKILL-STORAGE-AREA       REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  S-CARD.             04  S-KEYFIELDS.              05  FILLER                PIC  X(4).              05  S-SKILL-ID            PIC  9(4).             04  S-DATAFIELDS.              05  S-SKILL-NAME          PIC  X(12).              05  S-SKILL-DESC          PIC  X(60).            03  FILLER                  PIC  X(400).           02  OFFICE-STORAGE-AREA      REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  O1-CARD.             04  O1-KEYFIELDS.              05  FILLER                PIC  X(4).              05  O1-OFFICE-CODE        PIC  9(3).             04  O1-DATAFIELDS.              05  O1-OFFICE-ADDRESS     PIC  X(56).              05  FILLER                PIC  X(17).            03  O2-CARD.             04  O2-KEYFIELDS.              05  FILLER                PIC  X(4).              05  O2-OFFICE-CODE        PIC  9(3).             04  O2-DATAFIELDS.              05  O2-OFFICE-PHONE       PIC  9(7) OCCURS 3 TIMES.              05  O2-OFFICE-AREA        PIC  9(3).              05  O2-OFFICE-SPEED-DIAL  PIC  9(3).              05  FILLER                PIC  X(46).            03  FILLER                  PIC  X(320).           02  STRUCTURE-STORAGE-AREA   REDEFINES                                             TRANSACTION-STORAGE-ALL.            03  OG-CARD.             04  OG-KEYFIELDS.              05  FILLER                PIC  X(4).              05  OG-EMP-RPTS-TO        PIC  9(4).              05  OG-EMP-MANAGES        PIC  9(4).             04  OG-DATAFIELDS.              05  OG-STRUCT-CODE        PIC  X(2).              05  OG-RELATION-DATE      PIC  9(8).              05  FILLER                PIC  X(58).           03  FILLER                   PIC  X(400).          02  INSURANCE-STORAGE-AREA    REDEFINES                                             TRANSACTION-STORAGE-ALL.           03  I1-CARD.            04  I1-KEYFIELDS.             05  FILLER                 PIC  X(4).             05  I1-INSPLAN-CODE        PIC  X(3).            04  I1-DATAFIELDS.             05  I1-INSPLAN-CO-NAME     PIC  X(45).             05  FILLER                 PIC  X(28).           03  I2-CARD.            04  I2-KEYFIELDS.             05  FILLER                 PIC  X(4).             05  I2-INSPLAN-CODE        PIC  X(3).            04  I2-DATAFIELDS.             05  I2-CO-ADDRESS          PIC  X(46).             05  I2-CO-PHONE            PIC  9(10).             05  FILLER                 PIC  X(17).           03  I3-CARD.            04  I3-KEYFIELDS.             05  FILLER                 PIC  X(4).             05  I3-INSPLAN-CODE        PIC  X(3).            04  I3-DATAFIELDS.             05  I3-GROUP-NUM           PIC  9(6).             05  I3-DESCRIPTION.              06  I3-DEDUCT             PIC  9(6)V99.              06  I3-MAX-LIFE-COST      PIC  9(6)V99.              06  I3-FAM-COST           PIC  9(6)V99.              06  I3-DEP-COST           PIC  9(6)V99.             05  FILLER                 PIC  X(35).           03  FILLER                   PIC  X(240).          02  COVERAGE-STORAGE-AREA     REDEFINES                                             TRANSACTION-STORAGE-ALL.           03  C-CARD.            04  C-KEYFIELDS.             05  FILLER                 PIC  X(4).             05  C-INSPLAN-CODE         PIC  X(3).             05  C-EMP-ID               PIC  9(4).            04  C-DATAFIELDS.             05  C-SELECT-DATE          PIC  9(8).             05  C-TERMIN-DATE          PIC  9(8).             05  C-TYPE                 PIC  X.             05  C-INS-PLAN-CODE        PIC  X(3).             05  FILLER                 PIC  X(49).           03  FILLER                   PIC  X(400).          02  DENTAL-STORAGE-AREA       REDEFINES                                             TRANSACTION-STORAGE-ALL.           03  L1-CARD.            04  L1-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  L1-DATAFIELDS.             05  L1-DC-CLAIM-DATE       PIC  9(8).             05  L1-DC-PATIENT-NAME     PIC  X(25).             05  L1-DC-PATIENT-DOB      PIC  9(8).             05  L1-DC-SEX              PIC  X.             05  L1-DC-REL-TO-EMP       PIC  X(10).             05  L1-DC-DENTIST-NAME     PIC  X(24).           03  L2-CARD.            04  L2-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  L2-DATAFIELDS.             05  L2-DC-DENTIST-ADDRESS  PIC  X(46).             05  L2-DC-DENTIST-LIC-NUM  PIC  9(6).             05  L2-DC-NUM-PROCEDURES   PIC  9(2).             05  FILLER                 PIC  X(22).           03  LA-CARD.            04  LA-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  LA-DATAFIELDS.             05  LA-DC-TOOTH-NUM        PIC  9(2).             05  LA-DC-SERVICE-DATE     PIC  9(8).             05  LA-DC-PROC-CODE        PIC  9(4).             05  LA-DC-FEE              PIC  9(6)V99.             05  FILLER                 PIC  X(54).           03  LB-CARD.            04  LB-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  LB-DATAFIELDS.             05  LB-DC-DESC-OF-SERVICE  PIC  X(60).             05  FILLER                 PIC  X(16).           03  FILLER                   PIC  X(160).          02  HOSPITAL-STORAGE-AREA     REDEFINES                                             TRANSACTION-STORAGE-ALL.           03  H1-CARD.            04  H1-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  H1-DATAFIELDS.             05  H1-HC-CLAIM-DATE       PIC  9(8).             05  H1-HC-PATIENT-NAME     PIC  X(25).             05  H1-HC-PATIENT-DOB      PIC  9(8).             05  H1-HC-SEX              PIC  X.             05  H1-HC-REL-TO-EMP       PIC  X(10).             05  H1-HC-HOSP-NAME        PIC  X(24).           03  H2-CARD.            04  H2-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  H2-DATAFIELDS.             05  H2-HC-HOSP-ADDRESS     PIC  X(46).             05  H2-HC-ADMIT-DATE       PIC  9(8).             05  H2-HC-DISCH-DATE       PIC  9(8).             05  FILLER                 PIC  X(14).           03  H3-CARD.            04  H3-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  H3-DATAFIELDS.             05  H3-HC-DIAGNOSIS        PIC  X(60).             05  FILLER                 PIC  X(16).           03  H4-CARD.            04  H4-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  H4-DATAFIELDS.             05  H4-HC-DIAGNOSIS        PIC  X(60).             05  FILLER                 PIC  X(16).           03  H5-CARD.            04  H5-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  H5-DATAFIELDS.             05  H5-HOSP-CHARGES.              06  H5-HC-WARD.               07  H5-HC-WARD-DAYS      PIC  9(4).               07  H5-HC-WARD-RATE      PIC  9(6)V99.               07  H5-HC-WARD-TOTAL     PIC  9(6)V99.              06  H5-SEMI-PRIVATE.               07  H5-HC-SEMI-DAYS      PIC  9(4).               07  H5-HC-SEMI-RATE      PIC  9(6)V99.               07  H5-HC-SEMI-TOTAL     PIC  9(6)V99.              06  H5-HC-OTHER.               07  H5-HC-DEL-COST       PIC  9(6)V99.               07  H5-HC-ANESTH-COST    PIC  9(6)V99.               07  H5-HC-LAB-COST       PIC  9(6)V99.             05  FILLER                 PIC  X(12).           03  FILLER                   PIC  X(80).          02  NONHOSP-STORAGE-AREA      REDEFINES                                             TRANSACTION-STORAGE-ALL.           03  N1-CARD.            04  N1-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  N1-DATAFIELDS.             05  N1-NC-CLAIM-DATE       PIC  9(8).             05  N1-NC-PATIENT-NAME     PIC  X(25).             05  N1-NC-PATIENT-DOB      PIC  9(8).             05  N1-NC-SEX              PIC  X.             05  N1-NC-REL-TO-EMP       PIC  X(10).             05  N1-NC-PHYS-NAME        PIC  X(24).           03  N2-CARD.            04  N2-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  N2-DATAFIELDS.             05  N2-NC-PHYS-ADDRESS     PIC  X(46).             05  N2-NC-PHYS-ID          PIC  9(6).             05  N2-NC-NUM-PROCS        PIC  9(2).             05  FILLER                 PIC  X(22).           03  N3-CARD.            04  N3-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  N3-DATAFIELDS.             05  N3-NC-DIAGNOSIS        PIC  X(60).             05  FILLER                 PIC  X(16).           03  N4-CARD.            04  N4-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  N4-DATAFIELDS.             05  N4-NC-DIAGNOSIS        PIC  X(60).             05  FILLER                 PIC  X(16).           03  NA-CARD.            04  NA-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  NA-DATAFIELDS.             05  NA-NC-SERVICE-DATE     PIC  9(8).             05  NA-NC-PROC-CODE        PIC  9(4).             05  NA-NC-FEE              PIC  9(6)V99.             05  FILLER                 PIC  X(56).           03  NB-CARD.            04  NB-KEYFIELDS.             05  FILLER                 PIC  X(4).            04  NB-DATAFIELDS.             05  NB-NC-DESC-OF-SERVICE  PIC  X(62).             05  FILLER                 PIC  X(14).        01  NAMES-INFO.          02  NAMES-SSNAME              PIC  X(8)                                             VALUE  'EMPSS01 '.          02  NAMES-DBNAME              PIC  X(8)                                             VALUE  'EMPDEMO '.          02  NAMES-DMCLNAME            PIC  X(8)                                             VALUE 'IDMSDMCL'.        PROCEDURE DIVISION.       ***************************************************************       *       PROCEDURE DIVISION GENERAL STRATEGY:                  *       *       1)  READ 1 OR MORE CARDS TO FOR A TRANSACTION         *       *       2)  PERFORM THE APPROPRIATE ROUTINE, BASED UPON THE   *       *           TRANSACTION CODE                                  *       *       3)  CONTINUE UNTIL ALL CARD INPUT IS EXHAUSTED        *       ***************************************************************        0000-MAIN-LINE SECTION.         0001-SETUP.             DISPLAY '*** BEFORE FIRST CALL ***'.             CALL 'IDMSDBLU' USING NAMES-INFO.         0005-ML-START.             ACCEPT CARD-IMAGE.             DISPLAY '*** AFTER ACCEPT ***'             PERFORM 0020-MAIN-LOOP THRU 0020-ML-EXIT UNTIL                END-OF-DATA.             PERFORM 9999-END.         0020-MAIN-LOOP.             PERFORM 0510-READ-TRANSACTION THRU 0515-RT-EXIT.             DISPLAY '*** AFTER PERFORM 510- ***'.             IF END-OF-DATA                 GO TO 0020-ML-EXIT.             ADD 1 TO SUM-TRANSACTIONS.             IF  TSA-DEPARTMENT                  PERFORM 1010-DO-DEPARTMENT THRU 1090-DD-EXIT                      ELSE             IF  TSA-EMPLOYEE                  PERFORM 1510-DO-EMPLOYEE THRU 1590-DE-EXIT                      ELSE             IF  TSA-JOB                  PERFORM 2010-DO-JOB THRU 2090-DJ-EXIT                      ELSE             IF  TSA-EMPOSITION                  PERFORM 2510-DO-EMPOSITION THRU 2590-DEM-EXIT                      ELSE             IF  TSA-EXPERTISE                  PERFORM 3010-DO-EXPERTISE THRU 3090-DEX-EXIT                      ELSE             IF  TSA-SKILL                  PERFORM 3510-DO-SKILL THRU 3590-DS-EXIT                      ELSE             IF  TSA-OFFICE                  PERFORM 4510-DO-OFFICE THRU 4590-DO-EXIT                      ELSE             IF  TSA-STRUCTURE                  PERFORM 5010-DO-STRUCTURE THRU 5090-DS-EXIT                      ELSE             IF  TSA-INS-PLAN-CODE                  PERFORM 5510-DO-INSURANCE THRU 5590-DI-EXIT                      ELSE             IF  TSA-COVERAGE                  PERFORM 6010-DO-COVERAGE THRU 6090-DC-EXIT                      ELSE             IF  TSA-DENTAL                  PERFORM 6510-DO-DENTAL THRU 6590-DDN-EXIT                      ELSE             IF  TSA-HOSPITAL                  PERFORM 7010-DO-HOSPITAL THRU 7090-DH-EXIT                      ELSE                  PERFORM 7510-DO-NONHOSP THRU 7590-DN-EXIT.        0020-ML-EXIT.             EXIT.       **************************************       *     UTILITY ROUTINES FOLLOW        *       **************************************        0500-UTILITY SECTION.       ***************************************************************       *    THIS ROUTINE ASSEMBLES A TRANSACTION FROM ONE OR MORE    *       *    INDIVIDUAL CARDS;  NOTE THAT WHEN THIS PROCEDURE IS      *       *    ENTERED, A CARD IS ALWAYS PRESENT IN THE 'CARD IMAGE'    *       *    BUFFER.                                                  *       *                                                             *       *      DEPARTMENT HAS A SINGLE 'D' CARD                       *       *      EMPLOYEE HAS AN 'E1', AN 'E2', AND AN 'E3' CARD        *       *      JOB HAS 'J1' THRU 'J5' CARDS                           *       *      EMPOSITION HAS A SINGLE 'P ' CARD                      *       *      EXPERTISE HAS A SINGLE 'T ' CARD                       *       *      SKILL HAS A SINGLE 'S ' CARD                           *       *      OFFICE HAS AN 'O1' AND AN 'O2' CARD                    *       *      STRUCTURE HAS A SINGLE 'OG' CARD                       *       *      INSURANCE-PLAN HAS AN 'I1', AN 'I2', AND AN 'I3' CARD  *       *      COVERAGE HAS A SINGLE 'C ' CARD                        *       *      DENTAL-CLAIM HAS AN 'L1' AND AN 'L2' CARD, FOLLOWED    *       *        BY 2 TO 20 'LX' CARDS (WHERE 'X' IS A LETTER         *       *        FROM A TO T)                                         *       *      HOSPITAL-CLAIM HAS 'H1' THRU 'H5' CARDS                *       *      NON-HOSP-CLAIM HAS 'N1' THRU 'N4' CARDS, FOLLOWED      *       *        BY 2 TO 20 'NX' CARDS (WHERE 'X' IS A LETTER         *       *        FROM A TO T)                                         *       *                                                             *       ***************************************************************        0510-READ-TRANSACTION.            MOVE SPACES TO TRANSACTION-STORAGE-AREA.            IF CI-END                MOVE 'END' TO END-FLAG                GO TO 0515-RT-EXIT.            IF CI-CARD-TYPE = 'D ' OR 'P ' OR 'T ' OR 'S '                               OR 'OG' OR 'C '                MOVE CI-DATA-IMAGE TO TSA-SINGLE-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT                    ELSE            IF CI-CARD-TYPE = 'E1'                PERFORM 0520-ASSEM-EMPLOYEE THRU 0528-AE-EXIT                    ELSE            IF CI-CARD-TYPE = 'O1'                PERFORM 0530-ASSEM-OFFICE THRU 0538-AO-EXIT                    ELSE            IF CI-CARD-TYPE = 'J1'                PERFORM 0540-ASSEM-JOB THRU 0548-AJ-EXIT                    ELSE            IF CI-CARD-TYPE = 'I1'                PERFORM 0550-ASSEM-INS THRU 0558-AI-EXIT                    ELSE            IF CI-CARD-TYPE = 'L1'                PERFORM 0560-ASSEM-DENT THRU 0568-AD-EXIT                    ELSE            IF CI-CARD-TYPE = 'H1'                PERFORM 0570-ASSEM-HOSP THRU 0578-AH-EXIT                    ELSE            IF CI-CARD-TYPE = 'N1'                PERFORM 0580-ASSEM-NONHOSP THRU 0588-AN-EXIT                    ELSE            MOVE 'INVALID CARD TYPE/SEQ' TO ERROR-MESSAGE            PERFORM 0620-DISPLAY-CARD-ERROR THRU 0640-DCE-EXIT            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT            GO TO 0510-READ-TRANSACTION.        0515-RT-EXIT.            EXIT.       ***************************************************************       *   THE FOLLOWING MODULES ASSEMBLE MULTIPLE INPUT CARDS       *       *   INTO THE APPROPRIATE WORK RECORDS.                        *       ***************************************************************        0520-ASSEM-EMPLOYEE.            MOVE CI-DATA-IMAGE      TO E1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'E2'                AND CI-EMP-ID = E1-EMP-ID                MOVE CI-DATA-IMAGE TO E2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'E3'                AND CI-EMP-ID = E1-EMP-ID                MOVE CI-DATA-IMAGE TO E3-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0528-AE-EXIT.            EXIT.        0530-ASSEM-OFFICE.            MOVE CI-DATA-IMAGE         TO O1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'O2'                AND CI-OFFICE-CODE = O1-OFFICE-CODE                MOVE CI-DATA-IMAGE     TO O2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0538-AO-EXIT.            EXIT.        0540-ASSEM-JOB.            MOVE CI-DATA-IMAGE         TO J1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'J2'                MOVE CI-DATA-IMAGE     TO J2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'J3'                MOVE CI-DATA-IMAGE     TO J3-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'J4'                MOVE CI-DATA-IMAGE     TO J4-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'J5'                MOVE CI-DATA-IMAGE     TO J5-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0548-AJ-EXIT.            EXIT.        0550-ASSEM-INS.            MOVE CI-DATA-IMAGE         TO I1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'I2'                AND CI-INSPLAN-CODE = I1-INSPLAN-CODE                MOVE CI-DATA-IMAGE     TO I2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'I3'                AND CI-INSPLAN-CODE = I1-INSPLAN-CODE                MOVE CI-DATA-IMAGE     TO I3-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0558-AI-EXIT.            EXIT.        0560-ASSEM-DENT.            MOVE CI-DATA-IMAGE TO L1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'L2'                MOVE CI-DATA-IMAGE     TO L2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            MOVE 0 TO I-CTRL.            PERFORM 0563-GET-CHARGES THRU 0563-GC-EXIT                UNTIL (CI-CARD-TYPE-MAJ NOT = 'L' OR                       CI-CARD-TYPE-MIN NOT ALPHABETIC).        0568-AD-EXIT.            EXIT.        0563-GET-CHARGES.            IF CI-FIRST-PART                ADD 1 TO I-CTRL                MOVE CI-DATA-IMAGE   TO LA-CARD                MOVE LA-DC-TOOTH-NUM TO TOOTH-NUMBER-0405 (I-CTRL)                MOVE LA-DC-SERVICE-DATE TO SERVICE-DATE-0405 (I-CTRL)                MOVE LA-DC-PROC-CODE TO PROCEDURE-CODE-0405 (I-CTRL)                MOVE LA-DC-FEE       TO FEE-0405 (I-CTRL).            IF CI-2ND-PART                MOVE CI-DATA-IMAGE         TO LB-CARD                MOVE LB-DC-DESC-OF-SERVICE TO                     DESCRIPTION-OF-SERVICE-0405 (I-CTRL).            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0563-GC-EXIT.            EXIT.        0570-ASSEM-HOSP.            MOVE CI-DATA-IMAGE        TO H1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'H2'                MOVE CI-DATA-IMAGE    TO H2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'H3'                MOVE CI-DATA-IMAGE    TO H3-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'H4'                MOVE CI-DATA-IMAGE    TO H4-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'H5'                MOVE CI-DATA-IMAGE    TO H5-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0578-AH-EXIT.            EXIT.        0580-ASSEM-NONHOSP.            MOVE CI-DATA-IMAGE        TO N1-CARD.            PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'N2'                MOVE CI-DATA-IMAGE    TO N2-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'N3'                MOVE CI-DATA-IMAGE    TO N3-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            IF CI-CARD-TYPE = 'N4'                MOVE CI-DATA-IMAGE    TO N4-CARD                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.            MOVE 0 TO I-CTRL.            PERFORM 0583-GET-CHARGES THRU 0583-GC-EXIT                UNTIL (CI-CARD-TYPE-MAJ NOT = 'N' OR                       CI-CARD-TYPE-MIN NOT ALPHABETIC).        0588-AN-EXIT.            EXIT.        0583-GET-CHARGES.            IF CI-FIRST-PART                ADD 1 TO I-CTRL                MOVE CI-DATA-IMAGE    TO NA-CARD                MOVE NA-NC-SERVICE-DATE TO SERVICE-DATE-0445 (I-CTRL)                MOVE NA-NC-PROC-CODE  TO PROCEDURE-CODE-0445 (I-CTRL)                MOVE NA-NC-FEE        TO FEE-0445 (I-CTRL).            IF CI-2ND-PART                MOVE CI-DATA-IMAGE    TO NB-CARD                MOVE NB-NC-DESC-OF-SERVICE                    TO DESCRIPTION-OF-SERVICE-0445 (I-CTRL).                PERFORM 0600-READ-CARD THRU 0615-RC-EXIT.        0583-GC-EXIT.            EXIT.        0600-READ-CARD.            IF CARD-COUNT = '50'                MOVE ZERO TO CARD-COUNT.            DISPLAY CARD-IMAGE.            ACCEPT CARD-IMAGE.            ADD 1 TO CARD-COUNT.            ADD 1 TO SUM-CARDS-IN.        0615-RC-EXIT.            EXIT.        0620-DISPLAY-CARD-ERROR.            DISPLAY ERROR-MESSAGE, CARD-IMAGE.        0640-DCE-EXIT.            EXIT.        1000-PROCESS SECTION.       *       ***************************************************************       *                                                             *       *    THIS MAIN PROCESS SECTION HANDLES ALL FORMATTING OF       *       *    OWNER DESCRIPTOR RECORDS AND CALLS TO IDMSDBLU.           *       *                                                             *       ***************************************************************        1010-DO-DEPARTMENT.       *****************************************************       *                                                   *       *    THIS ROUTINE STORES A DEPARTMENT RECORD.       *       *                                                   *       *****************************************************       ***BUILD RECORD OCCURRENCE OF DEPARTMENT RECORD****************            MOVE D-DEPT-ID          TO  DEPT-ID-0410.            MOVE D-DEPT-NAME        TO  DEPT-NAME-0410.            MOVE D-DEPT-HEAD-ID     TO  DEPT-HEAD-ID-0410.        1020-STORE-DEPT.            MOVE 'DEPARTMENT'        TO  RECORD-SR-NAME.            MOVE 410                 TO  RECORD-ID.            MOVE DEPARTMENT          TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR.            PERFORM DBLU-STATUS.        1090-DD-EXIT.            EXIT.        1510-DO-EMPLOYEE.       ***************************************************************       *    THIS ROUTINE STORES THE EMPLOYEE RECORD.  THE OWNERS IN  *       *    THE DEPT-EMPLOYEE AND OFFICE-EMPLOYEE SETS MUST BE       *       *    PRESENT BY THE END OF THE RUN.                           *       ***************************************************************       *****BUILD OWNER OCCURRENCE OF SKILL-NAME-NDX SET**************            MOVE 'EMP-NAME-NDX'      TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE -1                  TO  OWNER-ONE-KEY-SERIAL.       *****BUILD OWNER OCCURRENCE OF DEPT-EMPLOYEE SET***************            MOVE 'DEPT-EMPLOYEE'     TO  OWNER-TWO-SET.            MOVE -1                  TO  OWNER-TWO-SERIAL.            MOVE E1-EMP-DEPT-ID      TO  OWNER-TWO-KEY.       *****BUILD OWNER OCCURRENCE OF OFFICE-EMPLOYEE SET*************            MOVE 'OFFICE-EMPLOYEE'   TO  OWNER-THREE-SET.            MOVE -1                  TO  OWNER-THREE-SERIAL.            MOVE E1-EMP-OFFICE       TO  OWNER-THREE-KEY.       *****BUILD RECORD OCCURRENCE OF EMPLOYEE RECORD****************            MOVE E1-EMP-ID           TO  EMP-ID-0415.            MOVE E1-EMP-NAME         TO  EMP-NAME-0415.            MOVE E2-EMP-ADDRESS      TO  EMP-ADDRESS-0415.            MOVE E2-EMP-PHONE        TO  EMP-PHONE-0415.            MOVE E2-EMP-STATUS       TO  STATUS-0415.            IF STATUS-0415 EQUAL TO '05'                MOVE ZEROS           TO  TERMINATION-DATE-0415                    ELSE                MOVE E3-EMP-TERM     TO  TERMINATION-DATE-0415.            MOVE E2-EMP-SS-NUMBER    TO  SS-NUMBER-0415.            MOVE E3-EMP-START        TO  START-DATE-0415.            MOVE E3-EMP-DOB          TO  BIRTH-DATE-0415.        1520-STORE-EMP.            MOVE 'EMPLOYEE'          TO  RECORD-SR-NAME.            MOVE 415                 TO  RECORD-ID.            MOVE EMPLOYEE            TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE                                  OWNER-DESCRIPTOR-TWO                                  OWNER-DESCRIPTOR-THREE.            PERFORM DBLU-STATUS.        1590-DE-EXIT.            EXIT.        2010-DO-JOB.       ***********************************************       *    THIS ROUTINE STORES THE JOB RECORD       *       ***********************************************       *****BUILD OWNER OCCURRENCE OF JOB-TITLE-NDX SET***************            MOVE 'JOB-TITLE-NDX'     TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE -1                  TO  OWNER-ONE-KEY-SERIAL.       *****BUILD RECORD OCCURRENCE OF JOB RECORD*********************            MOVE J1-JOB-ID           TO JOB-ID-0440.            MOVE J1-JOB-TITLE        TO TITLE-0440.            MOVE J1-JOB-MIN-SAL      TO MINIMUM-SALARY-0440.            MOVE J1-JOB-MAX-SAL      TO MAXIMUM-SALARY-0440.            MOVE J1-JOB-NUM-POSTS    TO NUMBER-OF-POSITIONS-0440.            MOVE J1-JOB-NUM-OPEN     TO NUMBER-OPEN-0440.            MOVE J2-JOB-DES-LINE     TO DESCRIPTION-LINE-0440 (1).            MOVE J3-JOB-DES-LINE     TO DESCRIPTION-LINE-0440 (2).            MOVE J4-JOB-REQ-LINE     TO REQUIREMENT-LINE-0440 (1).            MOVE J5-JOB-REQ-LINE     TO REQUIREMENT-LINE-0440 (2).            MOVE 0 TO I-CTRL.            PERFORM 2110-DO-SAL-GRDS THRU 2110-DSG-EXIT                VARYING I-CTRL FROM 1 BY 1 UNTIL I-CTRL = +4.        2020-STORE-JOB.            MOVE 'JOB'               TO  RECORD-SR-NAME.            MOVE 440                 TO  RECORD-ID.            MOVE JOB                 TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.        2090-DJ-EXIT.            EXIT.        2110-DO-SAL-GRDS.            MOVE J1-JOB-SAL-GRDS (I-CTRL)                TO SALARY-GRADES-0440 (I-CTRL).        2110-DSG-EXIT.            EXIT.        2510-DO-EMPOSITION.       ***************************************************************       *    THIS ROUTINE STORES THE EMPOSITION RECORD.  THE OWNERS   *       *    THE JOB-EMPOSITION AND EMP-EMPOSITION SETS MUST BE       *       *    PRESENT BY THE END OF THE RUN.                           *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR THE EMP-EMPOSITION SET*********            MOVE 'EMP-EMPOSITION'    TO  OWNER-TWO-SET.            MOVE -1                  TO  OWNER-TWO-SERIAL.            MOVE P-EMP-ID            TO  OWNER-TWO-KEY.       *****BUILD OWNER OCCURRENCE FOR THE JOB-EMPOSITION SET*********            MOVE 'JOB-EMPOSITION'    TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE P-JOB-ID            TO  OWNER-ONE-KEY.       *****BUILD RECORD OCCURRENCE OF EMPOSITION RECORD**************            MOVE P-START-DATE        TO  START-DATE-0420.            MOVE P-FINISH-DATE       TO  FINISH-DATE-0420.            MOVE P-SALARY-GRADE      TO  SALARY-GRADE-0420.            MOVE P-SALARY-AMOUNT     TO  SALARY-AMOUNT-0420.            MOVE P-BONUS-PERCENT     TO  BONUS-PERCENT-0420.            MOVE P-COMM-PERCENT      TO  COMMISSION-PERCENT-0420.            MOVE P-OVERTIME-RATE     TO  OVERTIME-RATE-0420.        2520-STORE-EMPOSITION.            MOVE 'EMPOSITION'        TO  RECORD-SR-NAME.            MOVE 420                 TO  RECORD-ID.            MOVE EMPOSITION          TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE                                  OWNER-DESCRIPTOR-TWO.        2590-DEM-EXIT.            EXIT.        3010-DO-EXPERTISE.       ***************************************************************       *    THE NEXT ROUTINE STORES A NEW EXPERTISE RECORD.  THE     *       *    SKILL AND EMPLOYEE OWNER RECORDS MUST BE PRESENT         *       *    BY THE END OF THE RUN.                                   *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR THE EMP-EXPERTISE SET**********            MOVE 'EMP-EXPERTISE'     TO  OWNER-TWO-SET.            MOVE -1                  TO  OWNER-TWO-SERIAL.            MOVE T-EMP-ID            TO  OWNER-TWO-KEY.       *****BUILD OWNER OCCURRENCE FOR SKILL-EXPERTISE SET************            MOVE 'SKILL-EXPERTISE'   TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE T-SKILL-ID          TO  OWNER-ONE-KEY.       *****BUILD OCCURRENCE OF EXPERTISE RECORD**********************            MOVE T-SKILL-LEVEL       TO  SKILL-LEVEL-0425.            MOVE T-EXPERTISE-DATE    TO  EXPERTISE-DATE-0425.        3020-STORE-EXPERTISE.            MOVE 'EXPERTISE'         TO  RECORD-SR-NAME.            MOVE 425                 TO  RECORD-ID.            MOVE EXPERTISE           TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE                                  OWNER-DESCRIPTOR-TWO.            PERFORM DBLU-STATUS.        3090-DEX-EXIT.            EXIT.        3510-DO-SKILL.       ***************************************************************       *    THIS ROUTINE STORES A NEW SKILL RECORD.                  *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR THE SKILL-NAME-NDX SET*********            MOVE 'SKILL-NAME-NDX'    TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE -1                  TO  OWNER-ONE-KEY-SERIAL.       *****BUILD OCCURRENCE OF SKILL RECORD**************************            MOVE S-SKILL-ID          TO  SKILL-ID-0455.            MOVE S-SKILL-NAME        TO  SKILL-NAME-0455.            MOVE S-SKILL-DESC        TO  SKILL-DESCRIPTION-0455.        3520-STORE-SKILL.            MOVE 'SKILL'             TO  RECORD-SR-NAME.            MOVE 455                 TO  RECORD-ID.            MOVE SKILL               TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.        3590-DS-EXIT.            EXIT.        4510-DO-OFFICE.       ***************************************************       *    THIS ROUTINE STORES A NEW OFFICE RECORD      *       ***************************************************       *****BUILD OCCURRENCE OF OFFICE RECORD*************************            MOVE O1-OFFICE-CODE      TO  OFFICE-CODE-0450.            MOVE O1-OFFICE-ADDRESS   TO  OFFICE-ADDRESS-0450.            MOVE O2-OFFICE-AREA      TO  OFFICE-AREA-CODE-0450.            MOVE O2-OFFICE-SPEED-DIAL TO SPEED-DIAL-0450.            PERFORM 4615-OFFICE-PHONE THRU 4615-OP-EXIT                VARYING I-CTRL FROM 1 BY 1 UNTIL I-CTRL = +4.        4520-STORE-OFFICE.            MOVE 'OFFICE'            TO  RECORD-SR-NAME.            MOVE 450                 TO  RECORD-ID.            MOVE OFFICE              TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR.            PERFORM DBLU-STATUS.        4590-DO-EXIT.            EXIT.        4615-OFFICE-PHONE.            IF O2-OFFICE-PHONE (I-CTRL) IS NOT NUMERIC                MOVE ZEROS TO OFFICE-PHONE-0450 (I-CTRL)                    ELSE                MOVE O2-OFFICE-PHONE (I-CTRL)                    TO OFFICE-PHONE-0450 (I-CTRL).        4615-OP-EXIT.            EXIT.        5010-DO-STRUCTURE.       ***************************************************************       *    THIS ROUTINE STORES A NEW STRUCTURE RECORD.  THE OWNERS  *       *    IN THE MANAGES AND REPORTS-TO SETS MUST BE PRESENT       *       *    BY THE END OF THE RUN.                                   *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR THE MANAGES SET****************            MOVE 'MANAGES'           TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE OG-EMP-MANAGES      TO  OWNER-ONE-KEY.       *****BUILD OWNER OCCURRENCE FOR SKILL-EXPERTISE SET************            MOVE 'REPORTS-TO'        TO  OWNER-TWO-SET.            MOVE -1                  TO  OWNER-TWO-SERIAL.            MOVE OG-EMP-RPTS-TO      TO  OWNER-TWO-KEY.       *****BUILD OCCURRENCE OF STRUCTURE RECORD**********************            MOVE OG-STRUCT-CODE      TO  STRUCTURE-CODE-0460.            MOVE OG-RELATION-DATE    TO  STRUCTURE-DATE-0460.        5020-STORE-STRUCTURE.            MOVE 'STRUCTURE'         TO  RECORD-SR-NAME.            MOVE 460                 TO  RECORD-ID.            MOVE STRUCTURE           TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE                                  OWNER-DESCRIPTOR-TWO.            PERFORM DBLU-STATUS.        5090-DS-EXIT.            EXIT.        5510-DO-INSURANCE.       ***************************************************************       *    THIS ROUTINE STORES A NEW INSURANCE-PLAN RECORD          *       ***************************************************************       *****BUILD RECORD OCCURRENCE OF INSURANCE-PLAN RECORD**********            MOVE I1-INSPLAN-CODE     TO  INS-PLAN-CODE-0435.            MOVE I1-INSPLAN-CO-NAME  TO  INS-CO-NAME-0435.            MOVE I2-CO-ADDRESS       TO  INS-CO-ADDRESS-0435.            MOVE I2-CO-PHONE         TO  INS-CO-PHONE-0435.            MOVE I3-GROUP-NUM        TO  GROUP-NUMBER-0435.            MOVE I3-DEDUCT           TO  DEDUCT-0435.            MOVE I3-MAX-LIFE-COST    TO  MAXIMUM-LIFE-COST-0435.            MOVE I3-FAM-COST         TO  FAMILY-COST-0435.            MOVE I3-DEP-COST         TO  DEP-COST-0435.        5520-STORE-INSURANCE.            MOVE 'INSURANCE-PLAN'    TO  RECORD-SR-NAME.            MOVE 435                 TO  RECORD-ID.            MOVE INSURANCE-PLAN      TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR.            PERFORM DBLU-STATUS.        5590-DI-EXIT.            EXIT.        6010-DO-COVERAGE.       ***************************************************************       *    THIS MODULE STORES A NEW COVERAGE RECORD.  THE OWNER IN  *       *    THE EMP-COVERAGE SET MUST BE PRESENT BY THE END OF THE   *       *    RUN.  SINCE THIS IS NOT A CALC RECORD THE SERIAL NUMBER  *       *    RETURNED FROM IDMSDBLU MUST BE SAVED, SO MEMBERS OWNED   *       *    BY THIS OCCURRENCE CAN REFER TO IT.                      *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR EMP-COVERAGE SET***************            MOVE 'EMP-COVERAGE'      TO  OWNER-ONE-SET.            MOVE -1                  TO  OWNER-ONE-SERIAL.            MOVE C-EMP-ID            TO  OWNER-ONE-KEY.       *****BUILD OCCURRENCE OF COVERAGE RECORD***********************            MOVE C-DATAFIELDS        TO  COVERAGE.        6020-STORE-COVERAGE.            MOVE 'COVERAGE'          TO  RECORD-SR-NAME.            MOVE 400                 TO  RECORD-ID.            MOVE COVERAGE            TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.            MOVE RECORD-SERIAL       TO  SAVE-COVERAGE-SERIAL.        6090-DC-EXIT.            EXIT.        6510-DO-DENTAL.       ***************************************************************       *    THIS ROUTINE STORES A NEW DENTAL-CLAIM RECORD.           *       *    THE SERIAL NUMBER OF THE OWNER IN THE COVERAGE-CLAIMS    *       *    SET MUST BE OBTAINED AND SAVED PRIOR TO AN ATTEMPT TO    *       *    STORE THIS RECORD.                                       *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR COVERAGE-CLAIMS SET************            MOVE 'COVERAGE-CLAIMS'    TO  OWNER-ONE-SET.            MOVE -1                   TO  OWNER-ONE-SERIAL            MOVE SAVE-COVERAGE-SERIAL TO  OWNER-ONE-KEY-SERIAL.       *****BUILD OCCURRENCE OF DENTAL-CLAIM RECORD*******************            MOVE L1-DC-CLAIM-DATE     TO  CLAIM-DATE-0405.            MOVE L1-DC-PATIENT-NAME   TO  PATIENT-NAME-0405.            MOVE L1-DC-PATIENT-DOB    TO  PATIENT-BIRTH-DATE-0405.            MOVE L1-DC-SEX            TO  PATIENT-SEX-0405.            MOVE L1-DC-REL-TO-EMP     TO  RELATION-TO-EMPLOYEE-0405.            MOVE L1-DC-DENTIST-NAME   TO  DENTIST-NAME-0405.            MOVE L2-DC-DENTIST-ADDRESS TO DENTIST-ADDRESS-0405.            MOVE L2-DC-DENTIST-LIC-NUM TO DENTIST-LICENSE-NUMBER-0405.            MOVE I-CTRL               TO  NUMBER-OF-PROCEDURES-0405.        6520-STORE-DENTAL.            MOVE 'DENTAL-CLAIM'       TO  RECORD-SR-NAME.            MOVE 405                  TO  RECORD-ID.            MOVE DENTAL-CLAIM         TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.        6590-DDN-EXIT.            EXIT.        7010-DO-HOSPITAL.       ***************************************************************       *    THIS ROUTINE STORES A NEW HOSPITAL-CLAIM RECORD.         *       *    THE SERIAL NUMBER OF THE OWNER IN THE COVERAGE-CLAIMS    *       *    SET MUST BE OBTAINED AND SAVED PRIOR TO AN ATTEMPT TO    *       *    STORE THIS RECORD.                                       *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR COVERAGE-CLAIMS SET************            MOVE 'COVERAGE-CLAIMS'    TO  OWNER-ONE-SET.            MOVE -1                   TO  OWNER-ONE-SERIAL            MOVE SAVE-COVERAGE-SERIAL TO  OWNER-ONE-KEY-SERIAL.       *****BUILD OCCURRENCE OF HOSPITAL-CLAIM RECORD*****************            MOVE H1-HC-CLAIM-DATE     TO  CLAIM-DATE-0430.            MOVE H1-HC-PATIENT-NAME   TO  PATIENT-NAME-0430.            MOVE H1-HC-PATIENT-DOB    TO  PATIENT-BIRTH-DATE-0430.            MOVE H1-HC-SEX            TO  PATIENT-SEX-0430.            MOVE H1-HC-REL-TO-EMP     TO  RELATION-TO-EMPLOYEE-0430.            MOVE H1-HC-HOSP-NAME      TO  HOSPITAL-NAME-0430.            MOVE H2-HC-HOSP-ADDRESS   TO  HOSP-ADDRESS-0430.            MOVE H2-HC-ADMIT-DATE     TO  ADMIT-DATE-0430.            MOVE H2-HC-DISCH-DATE     TO  DISCHARGE-DATE-0430.            MOVE H3-HC-DIAGNOSIS      TO  DIAGNOSIS-0430 (1).            MOVE H4-HC-DIAGNOSIS      TO  DIAGNOSIS-0430 (2).            MOVE H5-HC-WARD-DAYS      TO  WARD-DAYS-0430.            MOVE H5-HC-WARD-RATE      TO  WARD-RATE-0430.            MOVE H5-HC-WARD-TOTAL     TO  WARD-TOTAL-0430.            MOVE H5-HC-SEMI-DAYS      TO  SEMI-DAYS-0430.            MOVE H5-HC-SEMI-RATE      TO  SEMI-RATE-0430.            MOVE H5-HC-SEMI-TOTAL     TO  SEMI-TOTAL-0430.            MOVE H5-HC-DEL-COST       TO  DELIVERY-COST-0430.            MOVE H5-HC-ANESTH-COST    TO  ANESTHESIA-COST-0430.            MOVE H5-HC-LAB-COST       TO  LAB-COST-0430.        7020-STORE-HOSPITAL.            MOVE 'HOSPITAL-CLAIM'     TO  RECORD-SR-NAME.            MOVE 430                  TO  RECORD-ID.            MOVE HOSPITAL-CLAIM       TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.        7090-DH-EXIT.            EXIT.        7510-DO-NONHOSP.       ***************************************************************       *    THIS ROUTINE STORES A NEW NON-HOSP-CLAIM RECORD.         *       *    THE SERIAL NUMBER OF THE OWNER IN THE COVERAGE-CLAIMS    *       *    SET MUST BE OBTAINED AND SAVED PRIOR TO AN ATTEMPT TO    *       *    STORE THIS RECORD.                                       *       ***************************************************************       *****BUILD OWNER OCCURRENCE FOR COVERAGE-CLAIMS SET************            MOVE 'COVERAGE-CLAIMS'    TO  OWNER-ONE-SET.            MOVE -1                   TO  OWNER-ONE-SERIAL            MOVE SAVE-COVERAGE-SERIAL TO  OWNER-ONE-KEY-SERIAL.       *****BUILD OCCURRENCE OF NON-HOSP-CLAIM RECORD*****************            MOVE N1-NC-CLAIM-DATE     TO  CLAIM-DATE-0445.            MOVE N1-NC-PATIENT-NAME   TO  PATIENT-NAME-0445.            MOVE N1-NC-PATIENT-DOB    TO  PATIENT-BIRTH-DATE-0445.            MOVE N1-NC-SEX            TO  PATIENT-SEX-0445.            MOVE N1-NC-REL-TO-EMP     TO  RELATION-TO-EMPLOYEE-0445.            MOVE N1-NC-PHYS-NAME      TO  PHYSICIAN-NAME-0445.            MOVE N2-NC-PHYS-ADDRESS   TO  PHYSICIAN-ADDRESS-0445.            MOVE N2-NC-PHYS-ID        TO  PHYSICIAN-ID-0445.            MOVE N3-NC-DIAGNOSIS      TO  DIAGNOSIS-0445 (1).            MOVE N4-NC-DIAGNOSIS      TO  DIAGNOSIS-0445 (2).            MOVE I-CTRL               TO  NUMBER-OF-PROCEDURES-0445.        7520-STORE-NONHOSP.            MOVE 'NON-HOSP-CLAIM'     TO  RECORD-SR-NAME.            MOVE 445                  TO  RECORD-ID.            MOVE NON-HOSP-CLAIM       TO  RECORD-DATA.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR                                  OWNER-DESCRIPTOR-ONE.            PERFORM DBLU-STATUS.        7590-DN-EXIT.            EXIT.       ***************************************************************       *    CLOSE OUT LOAD PROGRAM OPERATIONS HERE.                  *       *                                                             *       *    DISPLAY APPROPRIATE RUN-TIME STATISTICS FROM PROGRAM     *       *    AND DATABASE SYSTEM;  THEN CALL IDMSDBLU WITH A -1       *       *    IN RECORD-ID TO CLOSE HIS FILES AND PUT OUT A CONTROL    *       *    RECORD.                                                  *       ***************************************************************        9999-END.            DISPLAY SUM-CARDS-IN ' CARDS'.            DISPLAY SUM-TRANSACTIONS '  TRANSACTIONS'.            MOVE -1 TO RECORD-ID.            CALL 'IDMSDBLU' USING OCCURRENCE-DESCRIPTOR.            GOBACK.       ***************************************************************        DBLU-STATUS                                           SECTION.       ***************************************************************            IF RECORD-LOAD-STATUS NOT = '0000'                DISPLAY 'LOAD STATUS ------- ' RECORD-LOAD-STATUS                DISPLAY 'RECORD NAME ------- ' RECORD-SR-NAME                DISPLAY 'RECORD ID --------- ' RECORD-ID                DISPLAY 'RECORD SERIAL NO.-- ' RECORD-SERIAL                DISPLAY 'SUGGESTED PAGE ---- ' RECORD-SUGGESTED-PAGE                DISPLAY 'RECORD DATA ------- ' RECORD-DATA-REDEF                DISPLAY '******************* '.        DBLU-STATUS-EXIT.            EXIT.