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.