       IDENTIFICATION DIVISION.                                         COB00010
       PROGRAM-ID. COBTEST.                                             COB00020
       DATE-WRITTEN. 10/22.                                             COB00030
      **********************************************************
      * THIS PROGRAM WILL CALL JAVA      SUBROUTINES TO GROUP  *
      * THE CMS 40.0 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 120 CHARACTERS,                              COB00220
           DATA RECORD IS PRINT-LINE.                                   COB00230
       01  PRINT-LINE.                                                  COB00240
           03 NUM            PIC 9(8).                                  COB00250
           03 NUM-RDF REDEFINES NUM.
              05 NUM-X       PIC X(8).
           03 FILLER         PIC XX.                                    COB00260
           03 MSG            PIC X(10).                                 COB00270
           03 EXPACT         PIC X(100).                                COB00280
       FD  INDATA RECORDING MODE IS F,                                  COB00290
           LABEL RECORDS ARE OMITTED,                                   COB00300
           RECORD CONTAINS 2000 CHARACTERS,                             COB00310
           BLOCK CONTAINS 0 RECORDS,                                    COB00320
           DATA RECORD IS INPUT-RECORD.                                 COB00330
       01  INPUT-RECORD.                                                COB00340
           03 IN-REC                          PIC X(2000).              COB00350
           03 DATA-REC REDEFINES IN-REC.                                COB00360
              05 CLAIM-INPUT-DATA.
                 07 CLAIM-AGE                    PIC X(03).
                 07 CLAIM-SEX                    PIC X(01).
                 07 CLAIM-DISCHARGE-STATUS       PIC X(02).
                 07 CLAIM-POA                    PIC X(01).
                 07 CLAIM-ADMIT-DATE             PIC X(08).
                 07 CLAIM-DISCHARGE-DATE         PIC X(08).
                 07 DIAG-CODES                   PIC X(200).
                 07 DIAG-CODES-R REDEFINES DIAG-CODES.
                    09 DIAG-CODE OCCURS 25 TIMES PIC X(08).
                 07 PROC-CODES                   PIC X(175).
                 07 PROC-CODES-R REDEFINES PROC-CODES.
                    09 PROC-CODE OCCURS 25 TIMES PIC X(07).
                 07 PROC-DATES                   PIC X(200).
                 07 CLAIM-OPT-DATA               PIC X(40).
                 07 CLAIM-OPT-DATA-RR REDEFINES CLAIM-OPT-DATA.
                    09 FILLER                    PIC X(39).
                    09 DEBUG-IND                 PIC X(01).
              05 FILLER                          PIC X(200).
      * CMSDRG RETURN DATA 1162 BYTES
              05 INRESULTS                    PIC X(1162).              COB00420
              05 INRES REDEFINES INRESULTS.                             COB00430
                 07 IN-CMSDRG-RTC             PIC X(02).                COB00460
                 07 IN-CMSDRG-MDC             PIC X(02).                COB00450
                 07 IN-CMSDRG-DRG             PIC X(04).                COB00440
                 07 IN-CMSDRG-OUTGRFLGS       PIC X(05).
                 07 IN-CMSDRG-OUTDXFLGS       PIC X(625).
                 07 IN-CMSDRG-OUTDXFLGS-R REDEFINES
                    IN-CMSDRG-OUTDXFLGS.
                    09 IN-CMSDRG-OUTDXFLGS-PER-DX
                                   OCCURS 25 TIMES PIC X(25).
                 07 IN-CMSDRG-OUTPRFLGS            PIC X(500).
                 07 IN-CMSDRG-OUTPRFLGS-R REDEFINES
                    IN-CMSDRG-OUTPRFLGS.
                    11 IN-CMSDRG-OUTPRFLGS-PER-SG
                                   OCCURS 25 TIMES PIC X(20).
                 07 IN-CMSDRG-OUTBUFF              PIC X(24).           COB00470
              05 INPRT REDEFINES INRESULTS.                             COB00430
                 07 INPRT-1   PIC X(13).
                 07 INPRT-DX1 PIC X(100).
                 07 INPRT-DX2 PIC X(100).
                 07 INPRT-DX3 PIC X(100).
                 07 INPRT-DX4 PIC X(100).
                 07 INPRT-DX5 PIC X(100).
                 07 INPRT-DX6 PIC X(100).
                 07 INPRT-DX7 PIC X(025).
                 07 INPRT-SG1 PIC X(100).
                 07 INPRT-SG2 PIC X(100).
                 07 INPRT-SG3 PIC X(100).
                 07 INPRT-SG4 PIC X(100).
                 07 INPRT-SG5 PIC X(100).
                 07 INPRT-10 PIC X(24).
       WORKING-STORAGE SECTION.                                         COB00550
       01 VERS               PIC  X(08).                                COB00580
       01 DISP-IND           PIC  X(01).                                COB00580
       01 DRG400JV           PIC  X(08) VALUE 'DRG400JV'.
       01 COUNT-TOTAL        PIC  9(08) COMP.                           COB00590
       01 OUTRESULTS         PIC  X(1162).                              COB00600
       01 OUTRS REDEFINES OUTRESULTS.                                   COB00610
          03 OUTRTC          PIC  X(02).                                COB00640
          03 OUTMDC          PIC  X(02).                                COB00630
          03 OUTDRG          PIC  X(04).                                COB00620
          03 OUTGRFLGS       PIC  X(05).
          03 OUTDXFLGS       PIC  X(625).
          03 OTDXFLGS-R REDEFINES
             OUTDXFLGS.
             07 OTDXFLAGS-SINGLE OCCURS 25 TIMES PIC X(25).
          03 OUTPRFLGS       PIC  X(500).
          03 OTPRFLGS-R REDEFINES
             OUTPRFLGS.
             07 OTPRFLAGS-SINGLE OCCURS 25 TIMES PIC X(20).
          03 OUTBUFF         PIC X(24).
       01 OUTPRT REDEFINES OUTRESULTS.
          03 OUTPRT-1        PIC X(13).
          03 OUTPRT-DX1      PIC X(100).
          03 OUTPRT-DX2      PIC X(100).
          03 OUTPRT-DX3      PIC X(100).
          03 OUTPRT-DX4      PIC X(100).
          03 OUTPRT-DX5      PIC X(100).
          03 OUTPRT-DX6      PIC X(100).
          03 OUTPRT-DX7      PIC X(025).
          03 OUTPRT-SG1      PIC X(100).
          03 OUTPRT-SG2      PIC X(100).
          03 OUTPRT-SG3      PIC X(100).
          03 OUTPRT-SG4      PIC X(100).
          03 OUTPRT-SG5      PIC X(100).
          03 OUTPRT-10       PIC X(24).
      ************************
      * INTERFACE BUFFER 1   *
      ************************
       01  INTERFACE-AREA-1                  PIC X(638).
       01  INTERFACE-AREA-1-REDEF REDEFINES
           INTERFACE-AREA-1.
      ******************************************************
      * CMS DRG     INPUT BUFFER LAYOUT                    *
      * COMMUNICATION INPUT AREAS SECTION 1.    638  BYTES *
      ******************************************************
              05 CI-CMSDRG-CLAIM             PIC X(638).
      ******************************************************
      * CMS DRG     OUTPUT BUFFER LAYOUT (1162)            *
      *            COMMUNICATION OUTPUT AREAS              *
      ******************************************************
      ************************
      * INTERFACE BUFFER 2   *
      ************************
       01  INTERFACE-AREA-2                  PIC X(1162).
       01  INTERFACE-AREA-2-REDEF REDEFINES
           INTERFACE-AREA-2.
              05 CO-CMSDRG-CLAIM             PIC X(1162).
      ******************************************************
      * PROGRAM EXECUTION                                  *
      ******************************************************
       PROCEDURE DIVISION.                                              COB00730
       STARTING.                                                        COB00740
           COMPUTE COUNT-TOTAL = 0.                                     COB00750
           OPEN INPUT INDATA.                                           COB00760
           OPEN OUTPUT PRINT.                                           COB00770
       READ-ROUTINE.                                                    COB00780
           MOVE 'N' TO DISP-IND.
           READ INDATA AT END GO TO EOFINDATA.                          COB00790
           IF DEBUG-IND = 'Y'
              MOVE 'Y' TO DISP-IND.
           IF DISP-IND = 'Y'
              DISPLAY 'COBTEST COMPILE DATE 06/16/2022'
              DISPLAY 'COBTEST RECORD READ      '
              DISPLAY 'IN-REC              ' IN-REC.
           ADD 1 TO COUNT-TOTAL.                                        COB00800
           MOVE CLAIM-INPUT-DATA TO INTERFACE-AREA-1.
           IF DISP-IND = 'Y'
              DISPLAY 'INTERFACE-AREA-1 ' INTERFACE-AREA-1
              DISPLAY 'CALLING DRG400JV'.
           CALL DRG400JV  USING   INTERFACE-AREA-1
                                  INTERFACE-AREA-2.
           IF DISP-IND = 'Y'
              DISPLAY 'RETURNED  FROM DRG400JV'.
           MOVE CO-CMSDRG-CLAIM  TO OUTRESULTS.
           IF DISP-IND = 'Y'
              DISPLAY ' INRESULTS       '  INRESULTS
              DISPLAY 'OUTRESULTS       ' OUTRESULTS.
           IF OUTRESULTS NOT EQUAL INRESULTS                            COB00840
              MOVE SPACES      TO PRINT-LINE                            COB00860
              COMPUTE NUM = COUNT-TOTAL                                 COB00870
              MOVE 'EXPECTED'  TO MSG                                   COB00880
              MOVE INPRT-1     TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX1   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX2   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX3   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX4   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX5   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX6   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-DX7   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-SG1   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-SG2   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-SG3   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-SG4   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-SG5   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE INPRT-10    TO EXPACT
              WRITE PRINT-LINE                                          COB00900
      *
              MOVE SPACES      TO PRINT-LINE                            COB00950
              MOVE 'ACTUAL'    TO MSG                                   COB00920
              MOVE OUTPRT-1    TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX1  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX2  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX3  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX4  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX5  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX6  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-DX7  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-SG1  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-SG2  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-SG3  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-SG4  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-SG5  TO EXPACT
              WRITE PRINT-LINE                                          COB00900
              MOVE SPACES      TO PRINT-LINE                            COB00910
              MOVE OUTPRT-10   TO EXPACT
              WRITE PRINT-LINE                                          COB00900
      *
              MOVE SPACES      TO PRINT-LINE
              MOVE '********'  TO NUM-X
              WRITE PRINT-LINE                                          COB00960
           ELSE                                                         COB00970
              NEXT SENTENCE.                                            COB00980
           GO TO READ-ROUTINE.                                          COB00990
       EOFINDATA.                                                       COB01000
           CLOSE INDATA.                                                COB01010
           MOVE SPACES TO PRINT-LINE.                                   COB01020
           MOVE 'CLAIMS ' TO MSG.                                       COB01030
           COMPUTE NUM = COUNT-TOTAL.                                   COB01040
           WRITE PRINT-LINE.                                            COB01050
           CLOSE PRINT.                                                 COB01060
           STOP RUN.                                                    COB01070
