       IDENTIFICATION DIVISION.                                         COB00010
       PROGRAM-ID. COBTEST.                                             COB00020
       DATE-WRITTEN. 03/21.                                             COB00030
      **********************************************************
      * THIS PROGRAM WILL CALL ASSEMBLER SUBROUTINES TO        *
      * PROCESS THE MCE 38.1 INSTALLATION TEST DATABASE.       *
      * THE RETURN INFO WILL BE COMPARED WITH EXPECTED RESULTS *
      * ON THE INPUT.  IF THEY DIFFER, THE EXPECTED AND ACTUAL *
      * RESULTS WILL BE PRINTED FOR THE RECORD.                *
      **********************************************************
       ENVIRONMENT DIVISION.                                            COB00100
       CONFIGURATION SECTION.                                           COB00110
       SOURCE-COMPUTER. IBM-370.                                        COB00120
       OBJECT-COMPUTER. IBM-370.                                        COB00130
       INPUT-OUTPUT SECTION.                                            COB00140
       FILE-CONTROL.                                                    COB00150
           SELECT INDATA ASSIGN TO UR-2301-S-INFILE.                    COB00160
           SELECT PRINT ASSIGN TO UR-1403-S-SYSPRINT.                   COB00170
       DATA DIVISION.                                                   COB00180
       FILE SECTION.                                                    COB00190
       FD  PRINT RECORDING MODE IS F,                                   COB00200
           LABEL RECORDS ARE OMITTED,                                   COB00210
           RECORD CONTAINS 80 CHARACTERS,                               COB00220
           DATA RECORD IS PRINT-LINE.                                   COB00230
       01  PRINT-LINE.                                                  COB00240
           02 NUM            PIC 9(8).                                  COB00250
           02 FILLER         PIC XX.                                    COB00260
           02 MSG            PIC X(70).                                 COB00270
       FD  INDATA RECORDING MODE IS F,                                  COB00290
           LABEL RECORDS ARE OMITTED,                                   COB00300
           RECORD CONTAINS 1400 CHARACTERS,                             COB00310
           BLOCK CONTAINS 0 RECORDS,                                    COB00320
           DATA RECORD IS INPUT-RECORD.                                 COB00330
       01  INPUT-RECORD.                                                COB00340
           02 IN-REC            PIC X(1400).                            COB00350
           02 DATA-REC REDEFINES IN-REC.                                COB00360
              03 IN-CLAIM-DATA  PIC X(483).
              03 IN-CLAIM-REC-1 REDEFINES IN-CLAIM-DATA.
                 05 IN-AGE      PIC X(3).                               COB00370
                 05 IN-SEX      PIC X(1).                               COB00380
                 05 IN-DSTAT    PIC X(2).                               COB00390
                 05 IN-LOS      PIC X(5).                               COB00370
                 05 IN-DDATE    PIC X(8).
                 05 IN-DX       PIC X(208).
                 05 IN-PROC     PIC X(175).
                 05 IN-PROV     PIC X(15).
                 05 IN-PPS      PIC X(1).
381              05 FILLER      PIC X(64).
381              05 IN-DEBUG-IND   PIC X(01).
              03 IN-INRESULTS   PIC X(917).
              03 INRES REDEFINES IN-INRESULTS.                          COB00430
                 05 INVERS   PIC X(3).
                 05 INADXFLG PIC X(1).
                 05 INDXFLGS PIC X(350).
                 05 INPRFLGS PIC X(425).
                 05 INBUFF   PIC X(138).
       WORKING-STORAGE SECTION.                                         COB00550
       77 WS-DXCODES-NUM        PIC S9(8) COMP VALUE IS +26.            COB00560
       77 WS-PRCODES-NUM        PIC S9(8) COMP VALUE IS +25.            COB00570
       77 WS-DSCFLAG            PIC S9(8) COMP VALUE IS +1.
       01 MCT381JV              PIC X(08) VALUE 'MCT381JV'.
       01 MCT381PA              PIC X(08) VALUE 'MCT381PA'.
       01 EDSCRP                PIC X(40).                              COB00590
       01 WS-COUNT-TOTAL        PIC 9(8) COMP.                          COB00590
       01 WS-OUTRESULTS         PIC X(917).                             COB00600
       01 WS-OUTRS REDEFINES WS-OUTRESULTS.                             COB00610
          05 WS-OUTVERS         PIC X(3).
          05 WS-OUTADXFLG       PIC X(1).
          05 WS-OUTDXFLGS       PIC X(350).
          05 WS-OUTPRFLGS       PIC X(425).
          05 WS-OUTBUFF         PIC X(138).
      ***************************
      * LNK INTERFACE BUFFER 1  *
      ***************************
       01  LNK-INTERFACE-AREA-1                  PIC X(500).
       01  LNK-INTERFACE-AREA-1-REDEF REDEFINES
           LNK-INTERFACE-AREA-1.
      ******************************************************
      * CMS MCE     INPUT BUFFER LAYOUT                    *
      * COMMUNICATION INPUT AREAS SECTION 1.    500  BYTES *
      ******************************************************
              05 LNK-IN-CMSMCE-CLAIM.
                 07 LNK-IN-CLAIM-AGE                PIC X(03).
                 07 LNK-IN-CLAIM-SEX                PIC X(01).
                 07 LNK-IN-CLAIM-DISCHARGE-STATUS   PIC X(02).
                 07 LNK-IN-CLAIM-LOS                PIC X(05).
                 07 LNK-IN-CLAIM-DISCHARGE-DATE     PIC X(08).
                 07 LNK-IN-CLAIM-DISCH-DATE-N REDEFINES
                    LNK-IN-CLAIM-DISCHARGE-DATE     PIC 9(08).
                 07 LNK-IN-DIAG-CODES               PIC X(208).
                 07 LNK-IN-DIAG-CODES-R REDEFINES LNK-IN-DIAG-CODES.
                    09 LNK-IN-DIAG-CODE OCCURS 26 TIMES PIC X(08).
                 07 LNK-IN-PROC-CODES               PIC X(175).
                 07 LNK-IN-PROC-CODES-R REDEFINES LNK-IN-PROC-CODES.
                    09 LNK-IN-PROC-CODE OCCURS 25 TIMES PIC X(07).
                 07 LNK-IN-PROV                     PIC X(15).
                 07 LNK-IN-PPS                      PIC X(1).
                 07 LNK-IN-I9-I10-IND               PIC X(1).
381              07 FILLER                          PIC X(80).
381              07 LNK-IN-DEBUG-IND                PIC X(01).
      ******************************************************
      * CMS MCE     OUTPUT BUFFER LAYOUT (917)             *
      ******************************************************
      ************************
      ***************************
      * LNK INTERFACE BUFFER 2  *
      ***************************
       01  LNK-INTERFACE-AREA-2                     PIC X(917).
       01  LNK-INTERFACE-AREA-2-REDEF REDEFINES
           LNK-INTERFACE-AREA-2.
              07 LNK-OUT-CMSMCE-VER                 PIC X(03).
              07 LNK-OUT-CMSMCE-OUTADXFLAG          PIC X(01).
              07 LNK-OUT-CMSMCE-OUTDXFLGS           PIC X(350).
              07 LNK-OUT-CMSMCE-OUTPRFLGS           PIC X(425).
              07 LNK-OUT-CMSMCE-OUTBUFF.
                 09 LNK-OUT-CMSMCE-OUTPROV          PIC X(15).
                 09 LNK-OUT-CMSMCE-PPS              PIC X(01).
                 09 LNK-OUT-CMSMCE-ACCUMS           PIC X(120).
                 09 FILLER     REDEFINES LNK-OUT-CMSMCE-ACCUMS.
                    11 OUTEDITS  OCCURS 60 TIMES PIC X(02).
                 09 LNK-OUT-CMSMCE-OUTEDFLAG        PIC X(02).
      ************************
      * INTERFACE BUFFER 1   *
      ************************
       01  INTERFACE-AREA-1                  PIC X(500).
       01  INTERFACE-AREA-1-REDEF REDEFINES
           INTERFACE-AREA-1.
      ******************************************************
      * CMS MCE     INPUT BUFFER LAYOUT                    *
      * COMMUNICATION INPUT AREAS SECTION 1.    500  BYTES *
      ******************************************************
           05 CI-CMSMCE-CLAIM                PIC X(500).
      ******************************************************
      * CMS MCE     OUTPUT BUFFER LAYOUT (917)             *
      ******************************************************
      ************************
      * INTERFACE BUFFER 2   *
      ************************
       01  INTERFACE-AREA-2                  PIC X(917).
       01  INTERFACE-AREA-2-REDEF REDEFINES
           INTERFACE-AREA-2.
           05 CO-CMSMCE-CLAIM                PIC X(917).
      ******************************************************
      * PROGRAM EXECUTION                                  *
      ******************************************************
       PROCEDURE DIVISION.                                              COB00730
       STARTING.                                                        COB00740
           COMPUTE WS-COUNT-TOTAL = 0.                                  COB00750
           OPEN INPUT INDATA.                                           COB00760
           OPEN OUTPUT PRINT.                                           COB00770
       READ-ROUTINE.                                                    COB00780
           READ INDATA AT END GO TO EOFINDATA.                          COB00790
           ADD 1 TO WS-COUNT-TOTAL.                                     COB00800
      * MOVE INPUT FIELDS TO LINK BUFFER 1 TO WRAPPER
           MOVE IN-AGE           TO LNK-IN-CLAIM-AGE
           MOVE IN-SEX           TO LNK-IN-CLAIM-SEX
           MOVE IN-DSTAT         TO LNK-IN-CLAIM-DISCHARGE-STATUS
           MOVE IN-LOS           TO LNK-IN-CLAIM-LOS
           MOVE IN-DDATE         TO LNK-IN-CLAIM-DISCHARGE-DATE
           MOVE IN-DX            TO LNK-IN-DIAG-CODES
           MOVE IN-PROC          TO LNK-IN-PROC-CODES
           MOVE IN-DEBUG-IND     TO LNK-IN-DEBUG-IND
           MOVE IN-PROV          TO LNK-IN-PROV
           MOVE IN-PPS           TO LNK-IN-PPS
           IF LNK-IN-CLAIM-DISCH-DATE-N < 20151001
              MOVE '9'           TO LNK-IN-I9-I10-IND
           ELSE
              MOVE '0'           TO LNK-IN-I9-I10-IND.
           MOVE LNK-INTERFACE-AREA-1 TO CI-CMSMCE-CLAIM.
      *
           CALL MCT381JV  USING   INTERFACE-AREA-1
                                  INTERFACE-AREA-2.
      * MOVE OUTPUT FIELDS FROM LINK BUFFER 2
           MOVE INTERFACE-AREA-2 TO LNK-INTERFACE-AREA-2.
           MOVE LNK-OUT-CMSMCE-VER        TO WS-OUTVERS
           MOVE LNK-OUT-CMSMCE-OUTADXFLAG TO WS-OUTADXFLG
           MOVE LNK-OUT-CMSMCE-OUTDXFLGS  TO WS-OUTDXFLGS
           MOVE LNK-OUT-CMSMCE-OUTPRFLGS  TO WS-OUTPRFLGS
           MOVE LNK-OUT-CMSMCE-OUTBUFF    TO WS-OUTBUFF
           IF WS-OUTRESULTS NOT EQUAL IN-INRESULTS                      COB00840
              DISPLAY 'INADXFLG         ' INADXFLG
              DISPLAY 'WS-OUTADXFLG     ' WS-OUTADXFLG
              DISPLAY 'INDXFLGS         ' INDXFLGS
              DISPLAY 'WS-OUTDXFLGS     ' WS-OUTDXFLGS
              DISPLAY 'INPRFLGS         ' INPRFLGS
              DISPLAY 'WS-OUTPRFLGS     ' WS-OUTPRFLGS
              DISPLAY 'INBUFF           ' INBUFF
              DISPLAY 'WS-OUTBUFF       ' WS-OUTBUFF
              DISPLAY 'WS-DSCFLAG       ' WS-DSCFLAG
              DISPLAY 'WS-DSCFLAG       ' WS-DSCFLAG
              DISPLAY 'EDSCRP           ' EDSCRP
              MOVE 'EXPECTED'  TO EDSCRP
              CALL 'MCT381PA' USING IN-DX, WS-DXCODES-NUM,
                                    IN-PROC, WS-PRCODES-NUM,
                                    IN-AGE, IN-SEX, IN-DSTAT,
                                    IN-PROV, IN-PPS, IN-LOS, IN-DDATE,
                                    INVERS, INADXFLG,
                                    INDXFLGS, INPRFLGS,
                                    INBUFF, WS-DSCFLAG, EDSCRP
              MOVE 'ACTUAL  '  TO EDSCRP
              CALL 'MCT381PA' USING IN-DX, WS-DXCODES-NUM,
                                    IN-PROC, WS-PRCODES-NUM,
                                    IN-AGE, IN-SEX, IN-DSTAT,
                                    IN-PROV, IN-PPS, IN-LOS, IN-DDATE,
                                    WS-OUTVERS, WS-OUTADXFLG,
                                    WS-OUTDXFLGS, WS-OUTPRFLGS,
                                    WS-OUTBUFF, WS-DSCFLAG, EDSCRP
           ELSE
              NEXT SENTENCE.
           GO TO READ-ROUTINE.                                          COB00990
       EOFINDATA.                                                       COB01000
           MOVE 'LAST RECORD' TO EDSCRP
              CALL 'MCT381PA' USING IN-DX, WS-DXCODES-NUM,
                                    IN-PROC, WS-PRCODES-NUM,
                                    IN-AGE, IN-SEX, IN-DSTAT,
                                    IN-PROV, IN-PPS, IN-LOS, IN-DDATE,
                                    WS-OUTVERS, WS-OUTADXFLG,
                                    WS-OUTDXFLGS, WS-OUTPRFLGS,
                                    WS-OUTBUFF, WS-DSCFLAG, EDSCRP.
           CLOSE INDATA.                                                COB01010
           MOVE SPACES TO PRINT-LINE.                                   COB01020
           MOVE 'RECORDS PROCESSED' TO MSG.                             COB01030
           COMPUTE NUM = WS-COUNT-TOTAL.                                COB01040
           WRITE PRINT-LINE.                                            COB01050
           CALL  MCT381PA.
           CLOSE PRINT.                                                 COB01060
           STOP RUN.                                                    COB01070
