This appendix 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.
|
Copyright © 2014 CA.
All rights reserved.
|
|