000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.          PPMGR200.
000300*AUTHOR.             DDS TEAM.
000400*          CENTERS FOR MEDICARE AND MEDICAID SERVICES
000500******************************************************************
000600*REMARKS.
000700*   EFFECTIVE JAN 1, 2006  CONVERTED SOFTWARE TO CICS FORMAT.
000800*
000900*   FOR TESTING PRICER COBOL
001000*            >  EXECUTE PPMGR___,PPOPN___,PPDRV___,PPCAL___
001100*
001200*   FOR CICS PRICER PROCESS
001300*            >  YOU MUST HAVE YOUR OWN OPEN AND CLOSE PROGRAMS
001400*            >  CAN NOT RUN PPMGR___ OR PPOPN___
001500*            >  CICS DOES NOT ALLOW ANY OPEN OR CLOSE ECT...
001600*            >  YOU NEED TO SET UP YOUR OWN INTERFACE FOR TESTING
001700*
001800*            THIS PROGRAM HAS BEEN CONVERTED TO COBOL II
001900* MILLENNIUM STANDARDS
002000*****        *******        ********        *******         ******
002100*     THIS CHANGE  MUST BE DONE FOR VS/COBOL II
002200*
002300*  VS/COBOL II -
002400*               TO COMPILE USING VS/COBOL II -
002500*  1. BLOCK CONTAINS 133 RECORDS -  IN BOTH
002600*               PRTOPER AND PRTCAPI FD'S
002700*  2. CHANGE THE WRITE STATEMENTS TO AFTER ADVANCING
002800*  3. CHANGE TO ADVANCING PAGE FROM ADVANCING 0
002900*****        *******        ********        *******         ******
003000*
003100*     THIS CHANGE MUST BE DONE FOR VS/COBOL
003200*
003300*  VS/COBOL -
003400*             TO COMPILE USING VS/COBOL -
003500*  1. BLOCK CONTAINS 0 RECORDS -  IN BOTH
003600*               PRTOPER AND PRTCAPI FD'S
003700*  2. CHANGE THE WRITE STATEMENTS TO AFTER POSITIONING
003800*  3. CHANGE TO POSITIONING 0 FROM POSITIONING PAGE
003900******************************************************************
004000*  FY 2020.0 PRICER
004100*  PPMGR200, PPOPN200, PPDRV200, PPCAL200 EFFECTIVE 10/01/2019
004200******************************************************************
004300 DATE-COMPILED.
004400 ENVIRONMENT                     DIVISION.
004500
004600 CONFIGURATION                   SECTION.
004700 SOURCE-COMPUTER.                IBM-370.
004800 OBJECT-COMPUTER.                IBM-370.
004900
005000 INPUT-OUTPUT SECTION.
005100 FILE-CONTROL.
005200
005300     SELECT BILLFILE   ASSIGN TO UT-S-SYSUT1
005400         FILE STATUS IS UT1-STAT.
005500     SELECT PPSOUT     ASSIGN TO UT-S-SYSUT2
005600         FILE STATUS IS UT2-STAT.
005700     SELECT PRTOPER    ASSIGN TO UT-S-PRTOPER
005800         FILE STATUS IS OPR-STAT.
005900     SELECT PRTCAPI    ASSIGN TO UT-S-PRTCAPI
006000         FILE STATUS IS CAP-STAT.
006100
006200 DATA DIVISION.
006300 FILE SECTION.
006400 FD  BILLFILE
006500     LABEL RECORDS ARE STANDARD
006600     RECORDING MODE IS F
006700     BLOCK CONTAINS 0 RECORDS.
006800 01  PPS-REC                     PIC X(500).
006900
007000 FD  PPSOUT
007100     LABEL RECORDS ARE STANDARD
007200     RECORDING MODE IS F
007300     BLOCK CONTAINS 0 RECORDS.
007400 01  OUT-REC                     PIC X(1897).
007500
007600 FD  PRTOPER
007700     RECORDING MODE IS F
007800     BLOCK CONTAINS 133 RECORDS
007900     LABEL RECORDS ARE STANDARD.
008000 01  PRTOPER-LINE                PIC X(133).
008100
008200 FD  PRTCAPI
008300     RECORDING MODE IS F
008400     BLOCK CONTAINS 133 RECORDS
008500     LABEL RECORDS ARE STANDARD.
008600 01  PRTCAPI-LINE                PIC X(133).
008700
008800 WORKING-STORAGE SECTION.
008900 77  W-STORAGE-REF               PIC X(49)  VALUE
009000     'P P M A N A G E R - W O R K I N G   S T O R A G E'.
009100
009200 01  PPMGR-VERSION               PIC X(05)  VALUE 'M20.0'.
009300 01  PPOPN-VERSION               PIC X(05)  VALUE 'O20.0'.
009400 01  PPDRV-VERSION               PIC X(05)  VALUE 'D20.0'.
009500 01  PPOPN200                    PIC X(08)  VALUE 'PPOPN200'.
009600 01  EOF-SW                      PIC 9(01)  VALUE 0.
009700 01  X1                          PIC 9(05)  COMP SYNC VALUE 0.
009800 01  X2                          PIC 9(05)  COMP SYNC VALUE 0.
009900 01  X3                          PIC 9(05)  COMP SYNC VALUE 0.
010000 01  X4                          PIC 9(05)  COMP SYNC VALUE 0.
010100
010200 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.
010300 01  CAPILINE-CTR                PIC 9(02)  VALUE 65.
010400 01  BILLFILE-CTR                PIC 9(09)  VALUE 0.
010500 01  PPSOUT-CTR                  PIC 9(09)  VALUE 0.
010600
010700 01  UT1-STAT.
010800     05  UT1-STAT1               PIC X.
010900     05  UT1-STAT2               PIC X.
011000
011100 01  UT2-STAT.
011200     05  UT2-STAT1               PIC X.
011300     05  UT2-STAT2               PIC X.
011400
011500 01  OPR-STAT.
011600     05  OPR-STAT1               PIC X.
011700     05  OPR-STAT2               PIC X.
011800
011900 01  CAP-STAT.
012000     05  CAP-STAT1               PIC X.
012100     05  CAP-STAT2               PIC X.
012200
012300************************************************************************
012400* BILL RECORD FORMAT                                                   *
012500*                                                                      *
012600* BILL-CHARGES-CLAIMED = TOTAL COVERED CHARGES ON THE 0001 (TOTALS     *
012700* LINE) MINUS BLOOD CLOT COST, KIDNEY COSTS, ACQUISITION COSTS, AND    *
012800* TECHNICAL PROVIDER CHARGES.                                          *
012900************************************************************************
013000 01  BILL-WORK.
013100     05  BILL-INPUT-DATA.
013200         10  BILL-NPI-NUMBER.
013300             15  BILL-NPI            PIC X(08).
013400             15  BILL-NPI-FILLER     PIC X(02).
013500         10  BILL-PROVIDER-NO        PIC X(06).
013600         10  BILL-HI-CLAIM-NO        PIC X(12).
013700         10  BILL-REVIEW-CODE        PIC 9(02).
013800         10  BILL-DRG                PIC 9(03).
013900         10  BILL-LOS                PIC 9(03).
014000         10  BILL-COVERED-DAYS       PIC 9(03).
014100         10  BILL-LTR-DAYS           PIC 9(02).
014200         10  BILL-DISCHARGE-DATE.
014300             15  D-CC                PIC 9(02).
014400             15  D-YY                PIC 9(02).
014500             15  D-MM                PIC 9(02).
014600             15  D-DD                PIC 9(02).
014700         10  BILL-CHARGES-CLAIMED    PIC 9(07)V9(02).
014800         10  BILL-PRIN-PROC-CODE     PIC X(07).
014900         10  BILL-OTHER-PROC-CODE1   PIC X(07).
015000         10  BILL-OTHER-PROC-CODE2   PIC X(07).
015100         10  BILL-OTHER-PROC-CODE3   PIC X(07).
015200         10  BILL-OTHER-PROC-CODE4   PIC X(07).
015300         10  BILL-OTHER-PROC-CODE5   PIC X(07).
015400         10  BILL-OTHER-PROC-CODE6   PIC X(07).
015500         10  BILL-OTHER-PROC-CODE7   PIC X(07).
015600         10  BILL-OTHER-PROC-CODE8   PIC X(07).
015700         10  BILL-OTHER-PROC-CODE9   PIC X(07).
015800         10  BILL-OTHER-PROC-CODE10  PIC X(07).
015900         10  BILL-OTHER-PROC-CODE11  PIC X(07).
016000         10  BILL-OTHER-PROC-CODE12  PIC X(07).
016100         10  BILL-OTHER-PROC-CODE13  PIC X(07).
016200         10  BILL-OTHER-PROC-CODE14  PIC X(07).
016300         10  BILL-OTHER-PROC-CODE15  PIC X(07).
016400         10  BILL-OTHER-PROC-CODE16  PIC X(07).
016500         10  BILL-OTHER-PROC-CODE17  PIC X(07).
016600         10  BILL-OTHER-PROC-CODE18  PIC X(07).
016700         10  BILL-OTHER-PROC-CODE19  PIC X(07).
016800         10  BILL-OTHER-PROC-CODE20  PIC X(07).
016900         10  BILL-OTHER-PROC-CODE21  PIC X(07).
017000         10  BILL-OTHER-PROC-CODE22  PIC X(07).
017100         10  BILL-OTHER-PROC-CODE23  PIC X(07).
017200         10  BILL-OTHER-PROC-CODE24  PIC X(07).
017300         10  BILL-OTHER-DIAG-CODE1  PIC X(07).
017400         10  BILL-OTHER-DIAG-CODE2  PIC X(07).
017500         10  BILL-OTHER-DIAG-CODE3  PIC X(07).
017600         10  BILL-OTHER-DIAG-CODE4  PIC X(07).
017700         10  BILL-OTHER-DIAG-CODE5  PIC X(07).
017800         10  BILL-OTHER-DIAG-CODE6  PIC X(07).
017900         10  BILL-OTHER-DIAG-CODE7  PIC X(07).
018000         10  BILL-OTHER-DIAG-CODE8  PIC X(07).
018100         10  BILL-OTHER-DIAG-CODE9  PIC X(07).
018200         10  BILL-OTHER-DIAG-CODE10 PIC X(07).
018300         10  BILL-OTHER-DIAG-CODE11 PIC X(07).
018400         10  BILL-OTHER-DIAG-CODE12 PIC X(07).
018500         10  BILL-OTHER-DIAG-CODE13 PIC X(07).
018600         10  BILL-OTHER-DIAG-CODE14 PIC X(07).
018700         10  BILL-OTHER-DIAG-CODE15 PIC X(07).
018800         10  BILL-OTHER-DIAG-CODE16 PIC X(07).
018900         10  BILL-OTHER-DIAG-CODE17 PIC X(07).
019000         10  BILL-OTHER-DIAG-CODE18 PIC X(07).
019100         10  BILL-OTHER-DIAG-CODE19 PIC X(07).
019200         10  BILL-OTHER-DIAG-CODE20 PIC X(07).
019300         10  BILL-OTHER-DIAG-CODE21 PIC X(07).
019400         10  BILL-OTHER-DIAG-CODE22 PIC X(07).
019500         10  BILL-OTHER-DIAG-CODE23 PIC X(07).
019600         10  BILL-OTHER-DIAG-CODE24 PIC X(07).
019700         10  BILL-OTHER-DIAG-CODE25 PIC X(07).
019800         10  BILL-DEMO-DATA.
019900             15  BILL-DEMO-CODE1        PIC X(02).
020000             15  BILL-DEMO-CODE2        PIC X(02).
020100             15  BILL-DEMO-CODE3        PIC X(02).
020200             15  BILL-DEMO-CODE4        PIC X(02).
020300         10  BILL-NDC-DATA.
020400             15  BILL-NDC-NUMBER        PIC X(11).
020500         10  FILLER                     PIC X(73).
020600*************************************************************
020700*******************************************************
020800*    RETURNED BY PPOPN___                             *
020900*******************************************************
021000     05  PPS-DATA.
021100         10  PPS-RTC               PIC 9(02).
021200         10  PPS-WAGE-INDX         PIC 9(02)V9(04).
021300         10  PPS-OUTLIER-DAYS      PIC 9(03).
021400         10  PPS-AVG-LOS           PIC 9(02)V9(01).
021500         10  PPS-DAYS-CUTOFF       PIC 9(02)V9(01).
021600         10  PPS-OPER-IME-ADJ      PIC 9(06)V9(02).
021700         10  PPS-TOTAL-PAYMENT     PIC 9(07)V9(02).
021800         10  PPS-OPER-HSP-PART     PIC 9(06)V9(02).
021900         10  PPS-OPER-FSP-PART     PIC 9(06)V9(02).
022000         10  PPS-OPER-OUTLIER-PART PIC 9(07)V9(02).
022100         10  PPS-REG-DAYS-USED     PIC 9(03).
022200         10  PPS-LTR-DAYS-USED     PIC 9(02).
022300         10  PPS-OPER-DSH-ADJ      PIC 9(06)V9(02).
022400         10  PPS-CALC-VERS         PIC X(05).
022500     05  FILLER                    PIC X(02).
022600     05  PPS-ADDITIONAL-VARIABLES.
022700         10  PPS-HSP-PCT                PIC 9(01)V9(02).
022800         10  PPS-FSP-PCT                PIC 9(01)V9(02).
022900         10  PPS-NAT-PCT                PIC 9(01)V9(02).
023000         10  PPS-REG-PCT                PIC 9(01)V9(02).
023100         10  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
023200         10  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
023300         10  PPS-DRG-WT                 PIC 9(02)V9(04).
023400         10  PPS-NAT-LABOR              PIC 9(05)V9(02).
023500         10  PPS-NAT-NLABOR             PIC 9(05)V9(02).
023600         10  PPS-REG-LABOR              PIC 9(05)V9(02).
023700         10  PPS-REG-NLABOR             PIC 9(05)V9(02).
023800         10  PPS-OPER-COLA              PIC 9(01)V9(03).
023900         10  PPS-INTERN-RATIO           PIC 9(01)V9(04).
024000         10  PPS-OPER-COST-OUTLIER      PIC 9(07)V9(09).
024100         10  PPS-OPER-BILL-COSTS        PIC 9(07)V9(09).
024200         10  PPS-OPER-DOLLAR-THRESHOLD  PIC 9(07)V9(09).
024300         10  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
024400         10  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
024500         10  PPS-CAPITAL-VARIABLES.
024600             15  PPS-CAPI-TOTAL-PAY         PIC 9(07)V9(02).
024700             15  PPS-CAPI-HSP               PIC 9(07)V9(02).
024800             15  PPS-CAPI-FSP               PIC 9(07)V9(02).
024900             15  PPS-CAPI-OUTLIER           PIC 9(07)V9(02).
025000             15  PPS-CAPI-OLD-HARM          PIC 9(07)V9(02).
025100             15  PPS-CAPI-DSH-ADJ           PIC 9(07)V9(02).
025200             15  PPS-CAPI-IME-ADJ           PIC 9(07)V9(02).
025300             15  PPS-CAPI-EXCEPTIONS        PIC 9(07)V9(02).
025400         10  PPS-CAPITAL2-VARIABLES.
025500             15  PPS-CAPI2-PAY-CODE         PIC X(1).
025600             15  PPS-CAPI2-B-FSP            PIC 9(07)V9(02).
025700             15  PPS-CAPI2-B-OUTLIER        PIC 9(07)V9(02).
025800         10  PPS-OTHER-VARIABLES.
025900             15  PPS-NON-TEMP-RELIEF-PAYMENT PIC 9(07)V9(02).
026000             15  PPS-NEW-TECH-PAY-ADD-ON     PIC 9(07)V9(02).
026100             15  PPS-ISLET-ISOL-PAY-ADD-ON   PIC 9(07)V9(02).
026200             15  PPS-LOW-VOL-PAYMENT         PIC 9(07)V9(02).
026300         10  PPS-HVBP-HRR-DATA.
026400             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
026500             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
026600             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
026700             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
026800         10  PPS-OPERATNG-DATA.
026900             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
027000             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
027100             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
027200         10  PPS-PC-VARIABLES.
027300             15  PPS-OPER-DSH                PIC 9(01)V9(04).
027400             15  PPS-CAPI-DSH                PIC 9(01)V9(04).
027500             15  PPS-CAPI-HSP-PCT            PIC 9(01)V9(02).
027600             15  PPS-CAPI-FSP-PCT            PIC 9(01)V9(04).
027700             15  PPS-ARITH-ALOS              PIC 9(02)V9(01).
027800             15  PPS-PR-WAGE-INDEX           PIC 9(02)V9(04).
027900             15  PPS-TRANSFER-ADJ            PIC 9(01)V9(04).
028000             15  PPS-PC-HMO-FLAG             PIC X(01).
028100             15  PPS-PC-COT-FLAG             PIC X(01).
028200             15  PPS-OPER-HSP-PART2          PIC 9(07)V9(02).
028300             15  PPS-BUNDLE-ADJUST-AMT       PIC S9(07)V99.
028400         10  PPS-ADDITIONAL-PAY-INFO-DATA.
028500             15  PPS-UNCOMP-CARE-AMOUNT         PIC S9(07)V9(02).
028600             15  PPS-BUNDLE-ADJUST-AMT          PIC S9(07)V9(02).
028700             15  PPS-VAL-BASED-PURCH-ADJUST-AMT PIC S9(07)V9(02).
028800             15  PPS-READMIS-ADJUST-AMT         PIC S9(07)V9(02).
028900         10  PPS-ADDITIONAL-PAY-INFO-DATA2.
029000             15  PPS-HAC-PROG-REDUC-IND      PIC X.
029100             15  PPS-EHR-PROG-REDUC-IND      PIC X.
029200             15  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
029300             15  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
029400             15  PPS-HAC-PAYMENT-AMT         PIC S9(07)V9(02).
029500             15  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
029600         10  PPS-FILLER                      PIC X(0897).
029700*************************************************************
029800
029900*******************************************************
030000* RETURNED BY PPOPN___                                *
030100*******************************************************
030200 COPY PPHOLDAR.
030300
030400************************************************************************
030500* PASSED TO PPOPN___                                                   *
030600*                                                                      *
030700* B-CHARGES-CLAIMED = TOTAL COVERED CHARGES ON THE 0001 (TOTALS        *
030800* LINE) MINUS BLOOD CLOT COST, KIDNEY COSTS, ACQUISITION COSTS, AND    *
030900* TECHNICAL PROVIDER CHARGES.                                          *
031000************************************************************************
031100 01  BILL-DATA.
031200     05  B-NPI-NUMBER.
031300         10  B-NPI               PIC X(08).
031400         10  B-NPI-FILLER        PIC X(02).
031500     05  B-PROVIDER-NO.
031600         10 B-PROVIDER-STATE     PIC X(02).
031700         10 FILLER               PIC X(04).
031800     05  B-REVIEW-CODE           PIC 9(02).
031900     05  B-DRG                   PIC 9(03).
032000     05  B-LOS                   PIC 9(03).
032100     05  B-COVERED-DAYS          PIC 9(03).
032200     05  B-LTR-DAYS              PIC 9(02).
032300     05  B-DISCHARGE-DATE.
032400         10  B-DISCHG-CC         PIC 9(02).
032500         10  B-DISCHG-YY         PIC 9(02).
032600         10  B-DISCHG-MM         PIC 9(02).
032700         10  B-DISCHG-DD         PIC 9(02).
032800     05  B-CHARGES-CLAIMED       PIC 9(07)V9(02).
032900     05  B-PRIN-PROC-CODE        PIC X(07).
033000     05  B-OTHER-PROC-CODE1      PIC X(07).
033100     05  B-OTHER-PROC-CODE2      PIC X(07).
033200     05  B-OTHER-PROC-CODE3      PIC X(07).
033300     05  B-OTHER-PROC-CODE4      PIC X(07).
033400     05  B-OTHER-PROC-CODE5      PIC X(07).
033500     05  B-OTHER-PROC-CODE6      PIC X(07).
033600     05  B-OTHER-PROC-CODE7      PIC X(07).
033700     05  B-OTHER-PROC-CODE8      PIC X(07).
033800     05  B-OTHER-PROC-CODE9      PIC X(07).
033900     05  B-OTHER-PROC-CODE10     PIC X(07).
034000     05  B-OTHER-PROC-CODE11     PIC X(07).
034100     05  B-OTHER-PROC-CODE12     PIC X(07).
034200     05  B-OTHER-PROC-CODE13     PIC X(07).
034300     05  B-OTHER-PROC-CODE14     PIC X(07).
034400     05  B-OTHER-PROC-CODE15     PIC X(07).
034500     05  B-OTHER-PROC-CODE16     PIC X(07).
034600     05  B-OTHER-PROC-CODE17     PIC X(07).
034700     05  B-OTHER-PROC-CODE18     PIC X(07).
034800     05  B-OTHER-PROC-CODE19     PIC X(07).
034900     05  B-OTHER-PROC-CODE20     PIC X(07).
035000     05  B-OTHER-PROC-CODE21     PIC X(07).
035100     05  B-OTHER-PROC-CODE22     PIC X(07).
035200     05  B-OTHER-PROC-CODE23     PIC X(07).
035300     05  B-OTHER-PROC-CODE24     PIC X(07).
035400     05  B-OTHER-DIAG-CODE1        PIC X(07).
035500     05  B-OTHER-DIAG-CODE2        PIC X(07).
035600     05  B-OTHER-DIAG-CODE3        PIC X(07).
035700     05  B-OTHER-DIAG-CODE4        PIC X(07).
035800     05  B-OTHER-DIAG-CODE5        PIC X(07).
035900     05  B-OTHER-DIAG-CODE6        PIC X(07).
036000     05  B-OTHER-DIAG-CODE7        PIC X(07).
036100     05  B-OTHER-DIAG-CODE8        PIC X(07).
036200     05  B-OTHER-DIAG-CODE9        PIC X(07).
036300     05  B-OTHER-DIAG-CODE10       PIC X(07).
036400     05  B-OTHER-DIAG-CODE11       PIC X(07).
036500     05  B-OTHER-DIAG-CODE12       PIC X(07).
036600     05  B-OTHER-DIAG-CODE13       PIC X(07).
036700     05  B-OTHER-DIAG-CODE14       PIC X(07).
036800     05  B-OTHER-DIAG-CODE15       PIC X(07).
036900     05  B-OTHER-DIAG-CODE16       PIC X(07).
037000     05  B-OTHER-DIAG-CODE17       PIC X(07).
037100     05  B-OTHER-DIAG-CODE18       PIC X(07).
037200     05  B-OTHER-DIAG-CODE19       PIC X(07).
037300     05  B-OTHER-DIAG-CODE20       PIC X(07).
037400     05  B-OTHER-DIAG-CODE21       PIC X(07).
037500     05  B-OTHER-DIAG-CODE22       PIC X(07).
037600     05  B-OTHER-DIAG-CODE23       PIC X(07).
037700     05  B-OTHER-DIAG-CODE24       PIC X(07).
037800     05  B-OTHER-DIAG-CODE25       PIC X(07).
037900     05  B-DEMO-DATA.
038000         10  B-DEMO-CODE1           PIC X(02).
038100         10  B-DEMO-CODE2           PIC X(02).
038200         10  B-DEMO-CODE3           PIC X(02).
038300         10  B-DEMO-CODE4           PIC X(02).
038400     05  B-NDC-DATA.
038500         10  B-NDC-NUMBER           PIC X(11).
038600     05  FILLER                     PIC X(73).
038700*************************************************************
038800
038900
039000*******************************************************
039100*    PASSED TO PPOPN___                               *
039200*******************************************************
039300 01  PRICER-OPT-VERS-SW.
039400     02  PRICER-OPTION-SW        PIC X.
039500*    02  PPS-VERSIONS.
039600*        10  PPOPN-VERSION       PIC X(05) VALUE 'O13.1'.
039700
039800*******************************************************
039900*    CAN BE PASSED TO PPOPN___                        *
040000*******************************************************
040100 01  PROV-RECORD-FROM-USER       PIC X(310).
040200
040300*******************************************************
040400*    CAN BE PASSED TO PPOPN___   4 POSITION MSA       *
040500*******************************************************
040600 01  MSAX-TABLE-FROM-USER.
040700     05  FILLER                  PIC X(32000).
040800     05  FILLER                  PIC X(30000).
040900     05  FILLER                  PIC X(30000).
041000
041100*******************************************************
041200*    CAN BE PASSED TO PPOPN___   5 POSITION CBSA      *
041300*******************************************************
041400 01  CBSA-TABLE-FROM-USER.
041500     05  FILLER                  PIC X(32000).
041600     05  FILLER                  PIC X(30000).
041700     05  FILLER                  PIC X(30000).
041800
041900*******************************************************
042000*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *
042100*******************************************************
042200 01  PPS-DETAIL-LINE-OPER.
042300     05  FILLER                  PIC X(01)  VALUE SPACES.
042400     05  PRT-HIC                 PIC X(12).
042500     05  FILLER                  PIC X(01)  VALUE SPACES.
042600     05  PRT-PROV                PIC X(06).
042700     05  FILLER                  PIC X(01)  VALUE SPACES.
042800     05  PRT-WAGE-INDX           PIC 9.9999.
042900     05  FILLER                  PIC X(01)  VALUE SPACES.
043000     05  PRT-GRP-DRG             PIC 9(03).
043100     05  FILLER                  PIC X(01)  VALUE SPACES.
043200     05  PRT-ALOS                PIC Z9.9.
043300     05  FILLER                  PIC X(01)  VALUE SPACES.
043400     05  PRT-DAY-CUT             PIC Z9.
043500     05  FILLER                  PIC X(01)  VALUE SPACES.
043600     05  PRT-DISCHG-DATE         PIC 9(08).
043700**   05  PRT-SLASH1              PIC X(01)  VALUE '/'.
043800**   05  PRT-DISCHG-DD           PIC 9(02).
043900**   05  PRT-SLASH2              PIC X(01)  VALUE '/'.
044000**   05  PRT-DISCHG-YY           PIC 9(02).
044100     05  FILLER                  PIC X(01)  VALUE SPACES.
044200     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.
044300     05  FILLER                  PIC X(01)  VALUE SPACES.
044400     05  PRT-FSP-PART            PIC ZZZ,ZZZ.99.
044500     05  FILLER                  PIC X(01)  VALUE SPACES.
044600     05  PRT-HSP-PART            PIC ZZZ,ZZZ.99.
044700     05  FILLER                  PIC X(01)  VALUE SPACES.
044800     05  PRT-OUTLIER-PART        PIC Z,ZZZ,ZZZ.99.
044900     05  PRT-DSH-ADJ             PIC ZZ,ZZZ.99.
045000     05  PRT-INDTCH-ADJ          PIC ZZ,ZZZ.99.
045100     05  FILLER                  PIC X(01)  VALUE SPACES.
045200     05  PRT-LOS                 PIC ZZ9.
045300     05  FILLER                  PIC X(02)  VALUE SPACES.
045400     05  PRT-OUTLIER-DAYS        PIC ZZ9.
045500     05  FILLER                  PIC X(02)  VALUE SPACES.
045600     05  PRT-REV-CODE            PIC 99.
045700     05  FILLER                  PIC X(03)  VALUE SPACES.
045800     05  PRT-PPS-RTC             PIC 99.
045900     05  FILLER                  PIC X(01)  VALUE SPACES.
046000
046100 01  PPS-HEAD1.
046200     05  FILLER                  PIC X(01)  VALUE SPACES.
046300     05  FILLER                  PIC X(44)  VALUE
046400        '  C M S ,                                   '.
046500     05  FILLER                  PIC X(44)  VALUE
046600        '                                            '.
046700     05  FILLER                  PIC X(44)  VALUE
046800        '                                            '.
046900
047000 01  PPS-HEAD2-OPER.
047100     05  FILLER                  PIC X(01)  VALUE SPACES.
047200     05  FILLER                  PIC X(44)  VALUE
047300        '  C M S     PRICER OPERATING  P R O S P E C '.
047400     05  FILLER                  PIC X(44)  VALUE
047500        'T I V E   P A Y M E N T   T E S T   D A T A '.
047600     05  FILLER                  PIC X(44)  VALUE
047700        '  R E P O R T  OPER200                      '.
047800
047900 01  PPS-HEAD3-OPER.
048000     05  FILLER                  PIC X(01)  VALUE SPACES.
048100     05  FILLER                  PIC X(44)  VALUE
048200        ' HI CLAIM   PROVIDER WAGE  DRG GMN DRG DIS-D'.
048300     05  FILLER                  PIC X(44)  VALUE
048400        'ATE TOT OPERATING  FEDERAL     HOSPITAL     '.
048500     05  FILLER                  PIC X(44)  VALUE
048600        'OUTLIER  DISPROP   IMETCH     OUTL REV  PPS '.
048700
048800 01  PPS-HEAD4-OPER.
048900     05  FILLER                  PIC X(01)  VALUE SPACES.
049000     05  FILLER                  PIC X(44)  VALUE
049100        '    NO         NO    INDEX  NO LOS CUT CCYYM'.
049200     05  FILLER                  PIC X(44)  VALUE
049300        'MDD & CAPITAL PAY  PORTION     PORTION      '.
049400     05  FILLER                  PIC X(44)  VALUE
049500        'PORTION   SHARE    ADJUST LOS DAYS  CD  RTC '.
049600
049700 01  PPS-HEAD2-CAPI.
049800     05  FILLER                  PIC X(01)  VALUE SPACES.
049900     05  FILLER                  PIC X(44)  VALUE
050000        '  C M S     PRICER  CAPITAL   P R O S P E C '.
050100     05  FILLER                  PIC X(44)  VALUE
050200        'T I V E   P A Y M E N T   T E S T   D A T A '.
050300     05  FILLER                  PIC X(44)  VALUE
050400        '  R E P O R T  CAPI200                      '.
050500
050600 01  PPS-HEAD3-CAPI.
050700     05  FILLER                  PIC X(01)  VALUE SPACES.
050800     05  FILLER                  PIC X(44)  VALUE
050900        ' HI CLAIM  PROVIDER /CAPITAL PAY/      HSP  '.
051000     05  FILLER                  PIC X(44)  VALUE
051100        '  /     FSP     /   OUTLIER   /  OLD-HARM   '.
051200     05  FILLER                  PIC X(44)  VALUE
051300        '/   DSH-ADJ   /   IME-ADJ   /  EXCEPTIONS  /'.
051400
051500*******************************************************
051600*    CAPIITAL PROSPECTIVE PAYMENT REPORT COMPONENTS           *
051700*******************************************************
051800 01  PPS-DETAIL-LINE-CAPI.
051900     05  FILLER                  PIC X(01)  VALUE SPACES.
052000     05  PRT-CAPI-HIC            PIC X(12).
052100     05  FILLER                  PIC X(01)  VALUE SPACES.
052200     05  PRT-CAPI-PROV           PIC X(06).
052300     05  FILLER                  PIC X(01)  VALUE SPACES.
052400     05  PRT-CAPI-TOT-PAY        PIC Z,ZZZ,ZZZ.99.
052500     05  FILLER                  PIC X(02)  VALUE SPACES.
052600     05  PRT-CAPI-HSP            PIC Z,ZZZ,ZZZ.99.
052700     05  FILLER                  PIC X(02)  VALUE SPACES.
052800     05  PRT-CAPI-FSP            PIC Z,ZZZ,ZZZ.99.
052900     05  FILLER                  PIC X(02)  VALUE SPACES.
053000     05  PRT-CAPI-OUTLIER        PIC Z,ZZZ,ZZZ.99.
053100     05  FILLER                  PIC X(02)  VALUE SPACES.
053200     05  PRT-CAPI-OLD-HARM       PIC Z,ZZZ,ZZZ.99.
053300     05  FILLER                  PIC X(02)  VALUE SPACES.
053400     05  PRT-CAPI-DSH-ADJ        PIC Z,ZZZ,ZZZ.99.
053500     05  FILLER                  PIC X(02)  VALUE SPACES.
053600     05  PRT-CAPI-IME-ADJ        PIC Z,ZZZ,ZZZ.99.
053700     05  FILLER                  PIC X(02)  VALUE SPACES.
053800     05  PRT-CAPI-EXCEPTIONS     PIC Z,ZZZ,ZZZ.99.
053900     05  FILLER                  PIC X(03)  VALUE SPACES.
054000
054100*******************************************************
054200*    GROUPER TABLE COMPONENTS                         *
054300*******************************************************
054400 01  DRG-COUNTERS.
054500     03  FILLER                  OCCURS 9.
054600         05  FILLER                  OCCURS 580.
054700             10  DRG-CNT             PIC 9(09) COMP.
054800
054900 01  MDC-COUNTERS.
055000     03  FILLER                  OCCURS 9.
055100         05  FILLER                  OCCURS 32.
055200             10  MDC-CNT             PIC 9(09) COMP.
055300
055400 01  RTC-COUNTERS.
055500     03  FILLER                  OCCURS 9.
055600         05  FILLER                  OCCURS 10.
055700             10  RTC-CNT             PIC 9(09) COMP.
055800
055900 01  TOTAL-COUNTERS.
056000     03  FILLER                  OCCURS 36.
056100         05  COUNT-TOTAL             PIC 9(09) COMP.
056200
056300 01  PRT-LINE.
056400     05  FILLER                  PIC X(01)  VALUE SPACES.
056500     05  PRT-LNE                 OCCURS 9.
056600         10  PRT-XXX             PIC X(02).
056700         10  PRT-DRG             PIC 9(03).
056800         10  PRT-CNT             PIC Z(08)9B.
056900         10  PRT-COL             PIC X(01).
057000
057100 01  PRT-HDG-OLD.
057200     05  FILLER                  PIC X(01)  VALUE SPACES.
057300     05  FILLER                  PIC X(44)  VALUE
057400         '   ****** A L L   R E C O R D S ******      '.
057500     05  FILLER                  PIC X(44)  VALUE
057600         '    DISCHARGES OLDER THEN 5 YEARS           '.
057700     05  FILLER                  PIC X(35)  VALUE
057800        '                C M S ,            '.
057900
058000 01  PRT-HDG-V150.
058100     05  FILLER                  PIC X(01)  VALUE SPACES.
058200     05  FILLER                  PIC X(44)  VALUE
058300         'G R O U P E R  V15.0  COUNTS BY   D R G     '.
058400     05  FILLER                  PIC X(44)  VALUE
058500         'FOR DISCHARGES ON OR AFTER 10/01/97         '.
058600     05  FILLER                  PIC X(35)  VALUE
058700        '                C M S ,            '.
058800
058900 01  PRT-HDG-V160.
059000     05  FILLER                  PIC X(01)  VALUE SPACES.
059100     05  FILLER                  PIC X(44)  VALUE
059200         'G R O U P E R  V16.0  COUNTS BY   D R G     '.
059300     05  FILLER                  PIC X(44)  VALUE
059400         'FOR DISCHARGES ON OR AFTER 10/01/98         '.
059500     05  FILLER                  PIC X(35)  VALUE
059600        '                C M S ,            '.
059700
059800 01  PRT-HDG-V170.
059900     05  FILLER                  PIC X(01)  VALUE SPACES.
060000     05  FILLER                  PIC X(44)  VALUE
060100         'G R O U P E R  V17.0  COUNTS BY   D R G     '.
060200     05  FILLER                  PIC X(44)  VALUE
060300         'FOR DISCHARGES ON OR AFTER 10/01/99         '.
060400     05  FILLER                  PIC X(35)  VALUE
060500        '                C M S ,            '.
060600
060700 01  PRT-HDG-V180.
060800     05  FILLER                  PIC X(01)  VALUE SPACES.
060900     05  FILLER                  PIC X(44)  VALUE
061000         'G R O U P E R  V18.0  COUNTS BY   D R G     '.
061100     05  FILLER                  PIC X(44)  VALUE
061200         'FOR DISCHARGES ON OR AFTER 10/01/2000       '.
061300     05  FILLER                  PIC X(35)  VALUE
061400        '                C M S ,            '.
061500
061600
061700 01  PRT-HDG-V190.
061800     05  FILLER                  PIC X(01)  VALUE SPACES.
061900     05  FILLER                  PIC X(44)  VALUE
062000         'G R O U P E R  V19.0  COUNTS BY   D R G     '.
062100     05  FILLER                  PIC X(44)  VALUE
062200         'FOR DISCHARGES ON OR AFTER 10/01/2001       '.
062300     05  FILLER                  PIC X(35)  VALUE
062400        '                C M S ,            '.
062500
062600
062700 01  PRT-HDG-V200.
062800     05  FILLER                  PIC X(01)  VALUE SPACES.
062900     05  FILLER                  PIC X(44)  VALUE
063000         'G R O U P E R  V20.0  COUNTS BY   D R G     '.
063100     05  FILLER                  PIC X(44)  VALUE
063200         'FOR DISCHARGES ON OR AFTER 10/01/2002       '.
063300     05  FILLER                  PIC X(35)  VALUE
063400        '                C M S ,            '.
063500
063600 01  PRT-HDG-V210.
063700     05  FILLER                  PIC X(01)  VALUE SPACES.
063800     05  FILLER                  PIC X(44)  VALUE
063900         'G R O U P E R  V21.0  COUNTS BY   D R G     '.
064000     05  FILLER                  PIC X(44)  VALUE
064100         'FOR DISCHARGES ON OR AFTER 10/01/2003       '.
064200     05  FILLER                  PIC X(35)  VALUE
064300        '                C M S ,            '.
064400
064500 01  PRT-HDG-V220.
064600     05  FILLER                  PIC X(01)  VALUE SPACES.
064700     05  FILLER                  PIC X(44)  VALUE
064800         'G R O U P E R  V22.0  COUNTS BY   D R G     '.
064900     05  FILLER                  PIC X(44)  VALUE
065000         'FOR DISCHARGES ON OR AFTER 10/01/2004       '.
065100     05  FILLER                  PIC X(35)  VALUE
065200        '                C M S ,            '.
065300
065400 01  PRT-HDG-V230.
065500     05  FILLER                  PIC X(01)  VALUE SPACES.
065600     05  FILLER                  PIC X(44)  VALUE
065700         'G R O U P E R  V23.0  COUNTS BY   D R G     '.
065800     05  FILLER                  PIC X(44)  VALUE
065900         'FOR DISCHARGES ON OR AFTER 10/01/2005       '.
066000     05  FILLER                  PIC X(35)  VALUE
066100        '                C M S ,            '.
066200
066300 01  PRT-HDG-V240.
066400     05  FILLER                  PIC X(01)  VALUE SPACES.
066500     05  FILLER                  PIC X(44)  VALUE
066600         'G R O U P E R  V24.0  COUNTS BY   D R G     '.
066700     05  FILLER                  PIC X(44)  VALUE
066800         'FOR DISCHARGES ON OR AFTER 10/01/2006       '.
066900     05  FILLER                  PIC X(35)  VALUE
067000        '                C M S ,            '.
067100
067200 01  PRT-HDG-V250.
067300     05  FILLER                  PIC X(01)  VALUE SPACES.
067400     05  FILLER                  PIC X(44)  VALUE
067500         'G R O U P E R  V24.0  COUNTS BY   D R G     '.
067600     05  FILLER                  PIC X(44)  VALUE
067700         'FOR DISCHARGES ON OR AFTER 10/01/2007       '.
067800     05  FILLER                  PIC X(35)  VALUE
067900        '                C M S ,            '.
068000
068100 01  PRT-HDG-V260.
068200     05  FILLER                  PIC X(01)  VALUE SPACES.
068300     05  FILLER                  PIC X(44)  VALUE
068400         'G R O U P E R  V24.0  COUNTS BY   D R G     '.
068500     05  FILLER                  PIC X(44)  VALUE
068600         'FOR DISCHARGES ON OR AFTER 10/01/2008       '.
068700     05  FILLER                  PIC X(35)  VALUE
068800        '                C M S ,            '.
068900
069000 01  PRT-HDG-V270.
069100     05  FILLER                  PIC X(01)  VALUE SPACES.
069200     05  FILLER                  PIC X(44)  VALUE
069300         'G R O U P E R  V24.0  COUNTS BY   D R G     '.
069400     05  FILLER                  PIC X(44)  VALUE
069500         'FOR DISCHARGES ON OR AFTER 10/01/2011       '.
069600     05  FILLER                  PIC X(35)  VALUE
069700        '                C M S ,            '.
069800
069900
070000 01  PRT-HDG                     PIC X(132).
070100
070200 PROCEDURE DIVISION.
070300
070400 0000-MAINLINE  SECTION.
070500     OPEN INPUT  BILLFILE.
070600
070700     OPEN OUTPUT PPSOUT.
070800     OPEN OUTPUT PRTOPER.
070900     OPEN OUTPUT PRTCAPI.
071000
071100     MOVE LOW-VALUES  TO DRG-COUNTERS.
071200     MOVE LOW-VALUES  TO MDC-COUNTERS.
071300     MOVE LOW-VALUES  TO RTC-COUNTERS.
071400     MOVE LOW-VALUES  TO TOTAL-COUNTERS.
071500*    MOVE ALL '0'     TO PPS-VERSIONS.
071600
071700     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.
071800
071900     DISPLAY '-- PROGRAM PPMGR___  VERSION ==> ' PPMGR-VERSION.
072000     DISPLAY '-- PROGRAM PPOPN___  VERSION ==> ' PPOPN-VERSION.
072100     DISPLAY '-- PROGRAM PPDRV___  VERSION ==> ' PPDRV-VERSION.
072200
072300     DISPLAY ' '.
072400     IF COUNT-TOTAL (2) > 0
072500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C87.1 '.
072600     IF COUNT-TOTAL (3) > 0
072700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C88.4 '.
072800     IF COUNT-TOTAL (4) > 0
072900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C89.4 '.
073000     IF COUNT-TOTAL (5) > 0
073100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C90.5 '.
073200     IF COUNT-TOTAL (6) > 0
073300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C91.5 '.
073400     IF COUNT-TOTAL (7) > 0
073500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C92.6 '.
073600     IF COUNT-TOTAL (8) > 0
073700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C93.5 '.
073800     IF COUNT-TOTAL (9) > 0
073900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C94.4 '.
074000     IF COUNT-TOTAL (10) > 0
074100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C95.4 '.
074200     IF COUNT-TOTAL (11) > 0
074300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C96.4 '.
074400     IF COUNT-TOTAL (12) > 0
074500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C97.4 '.
074600     IF COUNT-TOTAL (13) > 0
074700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C98.7 '.
074800     IF COUNT-TOTAL (14) > 0
074900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C99.8 '.
075000     IF COUNT-TOTAL (15) > 0
075100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C00.6 '.
075200     IF COUNT-TOTAL (16) > 0
075300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C01.7 '.
075400     IF COUNT-TOTAL (17) > 0
075500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C02.6 '.
075600     IF COUNT-TOTAL (18) > 0
075700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C03.8 '.
075800     IF COUNT-TOTAL (19) > 0
075900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C04.D '.
076000     IF COUNT-TOTAL (20) > 0
076100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C05.8 '.
076200     IF COUNT-TOTAL (21) > 0
076300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C06.9 '.
076400     IF COUNT-TOTAL (22) > 0
076500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C07.B '.
076600     IF COUNT-TOTAL (23) > 0
076700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C08.D '.
076800     IF COUNT-TOTAL (24) > 0
076900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C09.D '.
077000     IF COUNT-TOTAL (25) > 0
077100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C10.O '.
077200     IF COUNT-TOTAL (26) > 0
077300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C10.P '.
077400     IF COUNT-TOTAL (27) > 0
077500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C11.9 '.
077600     IF COUNT-TOTAL (28) > 0
077700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C12.5 '.
077800     IF COUNT-TOTAL (29) > 0
077900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C13.5 '.
078000     IF COUNT-TOTAL (30) > 0
078100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C14.B '.
078200     IF COUNT-TOTAL (31) > 0
078300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C15.6 '.
078400     IF COUNT-TOTAL (32) > 0
078500       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C16.3 '.
078600     IF COUNT-TOTAL (33) > 0
078700       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C17.1 '.
078800     IF COUNT-TOTAL (34) > 0
078900       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C18.2 '.
079000     IF COUNT-TOTAL (35) > 0
079100       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C19.2 '.
079200     IF COUNT-TOTAL (36) > 0
079300       DISPLAY '-- PROGRAM PPCAL___  VERSION ==> C20.0 '.
079400
079500     DISPLAY ' '.
079600     IF COUNT-TOTAL (1) > 0
079700     DISPLAY '--   TOTAL OLD RECORDS   ====> ' COUNT-TOTAL (1).
079800     IF COUNT-TOTAL (3) > 0
079900     DISPLAY '-- FY 1988 RECORD COUNTS ====> ' COUNT-TOTAL (3).
080000     IF COUNT-TOTAL (4) > 0
080100     DISPLAY '-- FY 1989 RECORD COUNTS ====> ' COUNT-TOTAL (4).
080200     IF COUNT-TOTAL (5) > 0
080300     DISPLAY '-- FY 1990 RECORD COUNTS ====> ' COUNT-TOTAL (5).
080400     IF COUNT-TOTAL (6) > 0
080500     DISPLAY '-- FY 1991 RECORD COUNTS ====> ' COUNT-TOTAL (6).
080600     IF COUNT-TOTAL (7) > 0
080700     DISPLAY '-- FY 1992 RECORD COUNTS ====> ' COUNT-TOTAL (7).
080800     IF COUNT-TOTAL (8) > 0
080900     DISPLAY '-- FY 1993 RECORD COUNTS ====> ' COUNT-TOTAL (8).
081000     IF COUNT-TOTAL (9) > 0
081100     DISPLAY '-- FY 1994 RECORD COUNTS ====> ' COUNT-TOTAL (9).
081200     IF COUNT-TOTAL (10) > 0
081300     DISPLAY '-- FY 1995 RECORD COUNTS ====> ' COUNT-TOTAL (10).
081400     IF COUNT-TOTAL (11) > 0
081500     DISPLAY '-- FY 1996 RECORD COUNTS ====> ' COUNT-TOTAL (11).
081600     IF COUNT-TOTAL (12) > 0
081700     DISPLAY '-- FY 1997 RECORD COUNTS ====> ' COUNT-TOTAL (12).
081800     IF COUNT-TOTAL (13) > 0
081900     DISPLAY '-- FY 1998 RECORD COUNTS ====> ' COUNT-TOTAL (13).
082000     IF COUNT-TOTAL (14) > 0
082100     DISPLAY '-- FY 1999 RECORD COUNTS ====> ' COUNT-TOTAL (14).
082200     IF COUNT-TOTAL (15) > 0
082300     DISPLAY '-- FY 2000 RECORD COUNTS ====> ' COUNT-TOTAL (15).
082400     IF COUNT-TOTAL (16) > 0
082500     DISPLAY '-- FY 2001 RECORD COUNTS ====> ' COUNT-TOTAL (16).
082600     IF COUNT-TOTAL (17) > 0
082700     DISPLAY '-- FY 2002 RECORD COUNTS ====> ' COUNT-TOTAL (17).
082800     IF COUNT-TOTAL (18) > 0
082900     DISPLAY '-- FY 2003 RECORD COUNTS ====> ' COUNT-TOTAL (18).
083000     IF COUNT-TOTAL (19) > 0
083100     DISPLAY '-- FY 2004 RECORD COUNTS ====> ' COUNT-TOTAL (19).
083200     IF COUNT-TOTAL (20) > 0
083300     DISPLAY '-- FY 2005 RECORD COUNTS ====> ' COUNT-TOTAL (20).
083400     IF COUNT-TOTAL (21) > 0
083500     DISPLAY '-- FY 2006 RECORD COUNTS ====> ' COUNT-TOTAL (21).
083600     IF COUNT-TOTAL (22) > 0
083700     DISPLAY '-- FY 2007 RECORD COUNTS ====> ' COUNT-TOTAL (22).
083800     IF COUNT-TOTAL (23) > 0
083900     DISPLAY '-- FY 2008 RECORD COUNTS ====> ' COUNT-TOTAL (23).
084000     IF COUNT-TOTAL (24) > 0
084100     DISPLAY '-- FY 2009 RECORD COUNTS ====> ' COUNT-TOTAL (24).
084200     IF COUNT-TOTAL (25) > 0
084300     DISPLAY '-- FY 2010.O RECORD COUNTS ==> ' COUNT-TOTAL (25).
084400     IF COUNT-TOTAL (26) > 0
084500     DISPLAY '-- FY 2010.P RECORD COUNTS ==> ' COUNT-TOTAL (26).
084600     IF COUNT-TOTAL (27) > 0
084700     DISPLAY '-- FY 2011.9 RECORD COUNTS ==> ' COUNT-TOTAL (27).
084800     IF COUNT-TOTAL (28) > 0
084900     DISPLAY '-- FY 2012.5 RECORD COUNTS ==> ' COUNT-TOTAL (28).
085000     IF COUNT-TOTAL (29) > 0
085100     DISPLAY '-- FY 2013.5 RECORD COUNTS ==> ' COUNT-TOTAL (29).
085200     IF COUNT-TOTAL (30) > 0
085300     DISPLAY '-- FY 2014.B RECORD COUNTS ==> ' COUNT-TOTAL (30).
085400     IF COUNT-TOTAL (31) > 0
085500     DISPLAY '-- FY 2015.6 RECORD COUNTS ==> ' COUNT-TOTAL (31).
085600     IF COUNT-TOTAL (32) > 0
085700     DISPLAY '-- FY 2016.3 RECORD COUNTS ==> ' COUNT-TOTAL (32).
085800     IF COUNT-TOTAL (33) > 0
085900     DISPLAY '-- FY 2017.1 RECORD COUNTS ==> ' COUNT-TOTAL (33).
086000     IF COUNT-TOTAL (34) > 0
086100     DISPLAY '-- FY 2018.2 RECORD COUNTS ==> ' COUNT-TOTAL (34).
086200     IF COUNT-TOTAL (35) > 0
086300     DISPLAY '-- FY 2019.2 RECORD COUNTS ==> ' COUNT-TOTAL (35).
086400     IF COUNT-TOTAL (36) > 0
086500     DISPLAY '-- FY 2020.0 RECORD COUNTS ==> ' COUNT-TOTAL (36).
086600
086700     DISPLAY '                                 -----------'.
086800
086900     DISPLAY '-- INPUT  COUNTS FOR SYSUT1 ===> ' BILLFILE-CTR.
087000     DISPLAY '-- OUTPUT COUNTS FOR SYSUT2 ===> ' PPSOUT-CTR.
087100
087200     CLOSE BILLFILE.
087300     CLOSE PPSOUT.
087400
087500     CLOSE PRTOPER PRTCAPI.
087600     STOP RUN.
087700
087800 0100-PROCESS-RECORDS.
087900     READ BILLFILE INTO BILL-WORK
088000         AT END
088100             MOVE 1 TO EOF-SW.
088200
088300     MOVE BILL-PROVIDER-NO      TO B-PROVIDER-NO.
088400     MOVE BILL-REVIEW-CODE      TO B-REVIEW-CODE.
088500     MOVE BILL-DRG              TO B-DRG.
088600     MOVE BILL-LOS              TO B-LOS.
088700     MOVE BILL-COVERED-DAYS     TO B-COVERED-DAYS.
088800     MOVE BILL-LTR-DAYS         TO B-LTR-DAYS.
088900     MOVE BILL-DISCHARGE-DATE   TO B-DISCHARGE-DATE.
089000     MOVE BILL-CHARGES-CLAIMED  TO B-CHARGES-CLAIMED.
089100     MOVE BILL-PRIN-PROC-CODE   TO B-PRIN-PROC-CODE.
089200     MOVE BILL-OTHER-PROC-CODE1 TO B-OTHER-PROC-CODE1.
089300     MOVE BILL-OTHER-PROC-CODE2 TO B-OTHER-PROC-CODE2.
089400     MOVE BILL-OTHER-PROC-CODE3 TO B-OTHER-PROC-CODE3.
089500     MOVE BILL-OTHER-PROC-CODE4 TO B-OTHER-PROC-CODE4.
089600     MOVE BILL-OTHER-PROC-CODE5 TO B-OTHER-PROC-CODE5.
089700     MOVE BILL-OTHER-PROC-CODE6 TO B-OTHER-PROC-CODE6.
089800     MOVE BILL-OTHER-PROC-CODE7 TO B-OTHER-PROC-CODE7.
089900     MOVE BILL-OTHER-PROC-CODE8 TO B-OTHER-PROC-CODE8.
090000     MOVE BILL-OTHER-PROC-CODE9 TO B-OTHER-PROC-CODE9.
090100     MOVE BILL-OTHER-PROC-CODE11 TO B-OTHER-PROC-CODE11.
090200     MOVE BILL-OTHER-PROC-CODE12 TO B-OTHER-PROC-CODE12.
090300     MOVE BILL-OTHER-PROC-CODE13 TO B-OTHER-PROC-CODE13.
090400     MOVE BILL-OTHER-PROC-CODE14 TO B-OTHER-PROC-CODE14.
090500     MOVE BILL-OTHER-PROC-CODE15 TO B-OTHER-PROC-CODE15.
090600     MOVE BILL-OTHER-PROC-CODE16 TO B-OTHER-PROC-CODE16.
090700     MOVE BILL-OTHER-PROC-CODE17 TO B-OTHER-PROC-CODE17.
090800     MOVE BILL-OTHER-PROC-CODE18 TO B-OTHER-PROC-CODE18.
090900     MOVE BILL-OTHER-PROC-CODE19 TO B-OTHER-PROC-CODE19.
091000     MOVE BILL-OTHER-PROC-CODE20 TO B-OTHER-PROC-CODE20.
091100     MOVE BILL-OTHER-PROC-CODE21 TO B-OTHER-PROC-CODE21.
091200     MOVE BILL-OTHER-PROC-CODE22 TO B-OTHER-PROC-CODE22.
091300     MOVE BILL-OTHER-PROC-CODE23 TO B-OTHER-PROC-CODE23.
091400     MOVE BILL-OTHER-PROC-CODE24 TO B-OTHER-PROC-CODE24.
091500     MOVE BILL-OTHER-DIAG-CODE1 TO B-OTHER-DIAG-CODE1.
091600     MOVE BILL-OTHER-DIAG-CODE2 TO B-OTHER-DIAG-CODE2.
091700     MOVE BILL-OTHER-DIAG-CODE3 TO B-OTHER-DIAG-CODE3.
091800     MOVE BILL-OTHER-DIAG-CODE4 TO B-OTHER-DIAG-CODE4.
091900     MOVE BILL-OTHER-DIAG-CODE5 TO B-OTHER-DIAG-CODE5.
092000     MOVE BILL-OTHER-DIAG-CODE6 TO B-OTHER-DIAG-CODE6.
092100     MOVE BILL-OTHER-DIAG-CODE7 TO B-OTHER-DIAG-CODE7.
092200     MOVE BILL-OTHER-DIAG-CODE8 TO B-OTHER-DIAG-CODE8.
092300     MOVE BILL-OTHER-DIAG-CODE9 TO B-OTHER-DIAG-CODE9.
092400     MOVE BILL-OTHER-DIAG-CODE11 TO B-OTHER-DIAG-CODE11.
092500     MOVE BILL-OTHER-DIAG-CODE12 TO B-OTHER-DIAG-CODE12.
092600     MOVE BILL-OTHER-DIAG-CODE13 TO B-OTHER-DIAG-CODE13.
092700     MOVE BILL-OTHER-DIAG-CODE14 TO B-OTHER-DIAG-CODE14.
092800     MOVE BILL-OTHER-DIAG-CODE15 TO B-OTHER-DIAG-CODE15.
092900     MOVE BILL-OTHER-DIAG-CODE16 TO B-OTHER-DIAG-CODE16.
093000     MOVE BILL-OTHER-DIAG-CODE17 TO B-OTHER-DIAG-CODE17.
093100     MOVE BILL-OTHER-DIAG-CODE18 TO B-OTHER-DIAG-CODE18.
093200     MOVE BILL-OTHER-DIAG-CODE19 TO B-OTHER-DIAG-CODE19.
093300     MOVE BILL-OTHER-DIAG-CODE20 TO B-OTHER-DIAG-CODE20.
093400     MOVE BILL-OTHER-DIAG-CODE21 TO B-OTHER-DIAG-CODE21.
093500     MOVE BILL-OTHER-DIAG-CODE22 TO B-OTHER-DIAG-CODE22.
093600     MOVE BILL-OTHER-DIAG-CODE23 TO B-OTHER-DIAG-CODE23.
093700     MOVE BILL-OTHER-DIAG-CODE24 TO B-OTHER-DIAG-CODE24.
093800     MOVE BILL-OTHER-DIAG-CODE25 TO B-OTHER-DIAG-CODE25.
093900     MOVE BILL-DEMO-CODE1        TO B-DEMO-CODE1.
094000     MOVE BILL-DEMO-CODE2        TO B-DEMO-CODE2.
094100     MOVE BILL-DEMO-CODE3        TO B-DEMO-CODE3.
094200     MOVE BILL-DEMO-CODE4        TO B-DEMO-CODE4.
094300     MOVE BILL-NDC-NUMBER        TO B-NDC-NUMBER.
094400
094500     IF  EOF-SW = 0
094600         ADD 1 TO BILLFILE-CTR
094700
094800*    DISPLAY '-- INPUT  COUNTS FOR SYSUT1 ===> ' BILLFILE-CTR
094900*    DISPLAY '-- BILL PROVIDER NO         ===> ' BILL-PROVIDER-NO
095000
095100         PERFORM 0200-APPLY-DRG THRU 0200-EXIT
095200         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT
095300         PERFORM 1100-WRITE-SYSUT2 THRU 1100-EXIT.
095400
095500 0100-EXIT.  EXIT.
095600
095700 0200-APPLY-DRG.
095800***********************************************************
095900*   THIS PROGRAM NO LONGER CALLS THE GROUPERS             *
096000*   TO RETRIEVE THE DRGS. THE TEST BILL DATA HAS BEEN     *
096100*   CHANGED TO CARRY THE DRGS. IF YOU WERE TO CALL        *
096200*   HSI GROUPER SUBROUTINES -- USE                        *
096300* PPCAL993  -                                             *
096400*   DISCHARGE DATES AFTER 09/30/98 USE  GROUPER VERS 16.0 *
096500* PPCAL001  -                                             *
096600*   DISCHARGE DATES AFTER 09/30/99 USE  GROUPER VERS 17.0 *
096700* PPCAL012  -                                             *
096800*   DISCHARGE DATES AFTER 09/30/00 USE  GROUPER VERS 18.0 *
096900*      WITH APR 1, 2001 CHANGES FOR BIPA                  *
097000* PPCAL020  -                                             *
097100*   DISCHARGE DATES AFTER 09/30/01 USE  GROUPER VERS 19.0 *
097200* PPCAL033  -                                             *
097300*   DISCHARGE DATES AFTER 09/30/02 USE  GROUPER VERS 20.0 *
097400* PPCAL048  -                                             *
097500*   DISCHARGE DATES AFTER 09/30/03 USE  GROUPER VERS 21.0 *
097600* PPCAL052  -                                             *
097700*   DISCHARGE DATES AFTER 09/30/04 USE  GROUPER VERS 22.0 *
097800* PPCAL063  -                                             *
097900*   DISCHARGE DATES AFTER 09/30/05 USE  GROUPER VERS 23.0 *
098000* PPCAL063  - CORRECTED DRG 233                           *
098100*   DISCHARGE DATES AFTER 09/30/05 USE  GROUPER VERS 23.0 *
098200* PPCAL063  -  CONVERTED TO CICS ON 01/01/2006            *
098300*           NO LOGIC  CHANGES OTHER THEN CICS CONVERSION  *
098400*   DISCHARGE DATES AFTER 09/30/05 USE  GROUPER VERS 23.0 *
098500* PPCAL063  -                                             *
098600*           LOGIC CHANGES TO DSH AND 401 HOSPITAL 150051  *
098700*   DISCHARGE DATES AFTER 09/30/05 USE  GROUPER VERS 23.0 *
098800* PPCAL074  -                                             *
098900*   DISCHARGE DATES AFTER 09/30/06 USE  GROUPER VERS 24.0 *
099000***********************************************************
099100*******************************************************
099200****  OLD RECORDS
099300****       FY - -PPCAL870
099400*******************************************************
099500     IF BILL-DISCHARGE-DATE < 19871001
099600        MOVE 2 TO X4
099700        ADD 1             TO COUNT-TOTAL (X4)
099800     ELSE
099900
100000*******************************************************
100100****  AFTER 09/30/88 - GROUPER 20.0 IS FOR ALL VERSIONS
100200****       FY - -PPCAL880
100300*******************************************************
100400     IF BILL-DISCHARGE-DATE < 19881001
100500        MOVE 3 TO X4
100600        ADD 1             TO COUNT-TOTAL (X4)
100700     ELSE
100800
100900*******************************************************
101000****  AFTER 09/30/89 - GROUPER 20.0 IS FOR ALL VERSIONS
101100****       FY - -PPCAL891
101200*******************************************************
101300     IF BILL-DISCHARGE-DATE < 19891001
101400        MOVE 4 TO X4
101500        ADD 1             TO COUNT-TOTAL (X4)
101600     ELSE
101700
101800*******************************************************
101900****       FY - -PPCAL900
102000*******************************************************
102100     IF BILL-DISCHARGE-DATE < 19901001
102200        MOVE 5 TO X4
102300        ADD 1             TO COUNT-TOTAL (X4)
102400     ELSE
102500
102600*******************************************************
102700****       FY - -PPCA0910
102800*******************************************************
102900     IF BILL-DISCHARGE-DATE < 19911001
103000        MOVE 6 TO X4
103100        ADD 1             TO COUNT-TOTAL (X4)
103200     ELSE
103300
103400*******************************************************
103500****       FY - -PPCAL920
103600*******************************************************
103700     IF BILL-DISCHARGE-DATE < 19921001
103800        MOVE 7 TO X4
103900        ADD 1             TO COUNT-TOTAL (X4)
104000     ELSE
104100
104200*******************************************************
104300****       FY - -PPCAL930
104400*******************************************************
104500     IF BILL-DISCHARGE-DATE < 19931001
104600        MOVE 8 TO X4
104700        ADD 1             TO COUNT-TOTAL (X4)
104800     ELSE
104900
105000*******************************************************
105100****       FY - -PPCAL940
105200*******************************************************
105300     IF BILL-DISCHARGE-DATE < 19941001
105400        MOVE 9 TO X4
105500        ADD 1             TO COUNT-TOTAL (X4)
105600     ELSE
105700
105800*******************************************************
105900****       FY - -PPCAL950
106000*******************************************************
106100     IF BILL-DISCHARGE-DATE < 19951001
106200        MOVE 10 TO X4
106300        ADD 1             TO COUNT-TOTAL (X4)
106400     ELSE
106500
106600*******************************************************
106700****       FY - -PPCAL960
106800*******************************************************
106900     IF BILL-DISCHARGE-DATE < 19961001
107000        MOVE 11 TO X4
107100        ADD 1             TO COUNT-TOTAL (X4)
107200     ELSE
107300
107400*******************************************************
107500****       FY - -PPCAL970
107600*******************************************************
107700     IF BILL-DISCHARGE-DATE < 19971001
107800        MOVE 12 TO X4
107900        ADD 1             TO COUNT-TOTAL (X4)
108000     ELSE
108100
108200*******************************************************
108300****       FY - -PPCAL980
108400*******************************************************
108500     IF BILL-DISCHARGE-DATE < 19981001
108600        MOVE 13 TO X4
108700        ADD 1             TO COUNT-TOTAL (X4)
108800     ELSE
108900
109000*******************************************************
109100****       FY - -PPCAL990
109200*******************************************************
109300     IF BILL-DISCHARGE-DATE < 19991001
109400        MOVE 14 TO X4
109500        ADD 1             TO COUNT-TOTAL (X4)
109600     ELSE
109700
109800*******************************************************
109900****       FY - -PPCAL000
110000*******************************************************
110100     IF BILL-DISCHARGE-DATE < 20001001
110200        MOVE 15 TO X4
110300        ADD 1             TO COUNT-TOTAL (X4)
110400     ELSE
110500
110600*******************************************************
110700****       FY - -PPCAL010
110800*******************************************************
110900     IF BILL-DISCHARGE-DATE < 20011001
111000        MOVE 16 TO X4
111100        ADD 1             TO COUNT-TOTAL (X4)
111200     ELSE
111300
111400*******************************************************
111500****       FY - -PPCAL020
111600*******************************************************
111700     IF BILL-DISCHARGE-DATE < 20021001
111800        MOVE 17                            TO X4
111900*       ADD 1             TO DRG-CNT (X4 B-DRG)
112000        ADD 1             TO COUNT-TOTAL (X4)
112100     ELSE
112200
112300*******************************************************
112400****       FY - -PPCAL030
112500*******************************************************
112600     IF BILL-DISCHARGE-DATE < 20031001
112700        MOVE 18 TO X4
112800*       ADD 1             TO DRG-CNT (X4 B-DRG)
112900        ADD 1             TO COUNT-TOTAL (X4)
113000     ELSE
113100
113200*******************************************************
113300****       FY - -PPCAL040
113400*******************************************************
113500     IF BILL-DISCHARGE-DATE < 20041001
113600        MOVE 19 TO X4
113700*       ADD 1             TO DRG-CNT (X4 B-DRG)
113800        ADD 1             TO COUNT-TOTAL (X4)
113900     ELSE
114000
114100*******************************************************
114200****       FY - -PPCAL050
114300*******************************************************
114400     IF BILL-DISCHARGE-DATE < 20051001
114500        MOVE 20 TO X4
114600*       ADD 1             TO DRG-CNT (X4 B-DRG)
114700        ADD 1             TO COUNT-TOTAL (X4)
114800     ELSE
114900
115000*******************************************************
115100****       FY - -PPCAL060
115200*******************************************************
115300     IF BILL-DISCHARGE-DATE < 20061001
115400        MOVE 21 TO X4
115500*       ADD 1             TO DRG-CNT (X4 B-DRG)
115600        ADD 1             TO COUNT-TOTAL (X4)
115700     ELSE
115800
115900*******************************************************
116000****       FY - -PPCAL070
116100*******************************************************
116200     IF BILL-DISCHARGE-DATE < 20071001
116300        MOVE 22 TO X4
116400*       ADD 1             TO DRG-CNT (X4 B-DRG)
116500        ADD 1             TO COUNT-TOTAL (X4)
116600     ELSE
116700
116800*******************************************************
116900****       FY - -PPCAL080
117000*******************************************************
117100     IF BILL-DISCHARGE-DATE < 20081001
117200        MOVE 23 TO X4
117300*       ADD 1             TO DRG-CNT (X4 B-DRG)
117400        ADD 1             TO COUNT-TOTAL (X4)
117500     ELSE
117600
117700*******************************************************
117800*******************************************************
117900****       FY - -PPCAL090
118000*******************************************************
118100     IF BILL-DISCHARGE-DATE < 20091001
118200        MOVE 24 TO X4
118300*       ADD 1             TO DRG-CNT (X4 B-DRG)
118400        ADD 1             TO COUNT-TOTAL (X4)
118500     ELSE
118600
118700*******************************************************
118800****       FY - -PPCAL10A
118900*******************************************************
119000     IF BILL-DISCHARGE-DATE < 20100401
119100        MOVE 25 TO X4
119200*       ADD 1             TO DRG-CNT (X4 B-DRG)
119300        ADD 1             TO COUNT-TOTAL (X4)
119400     ELSE
119500
119600*******************************************************
119700*******************************************************
119800****       FY - -PPCAL10B
119900*******************************************************
120000     IF BILL-DISCHARGE-DATE < 20101001
120100        MOVE 26 TO X4
120200*       ADD 1             TO DRG-CNT (X4 B-DRG)
120300        ADD 1             TO COUNT-TOTAL (X4)
120400     ELSE
120500
120600*******************************************************
120700****       FY - -PPCAL110
120800*******************************************************
120900     IF BILL-DISCHARGE-DATE < 20111001
121000        MOVE 27 TO X4
121100*       ADD 1             TO DRG-CNT (X4 B-DRG)
121200        ADD 1             TO COUNT-TOTAL (X4)
121300     ELSE
121400
121500*******************************************************
121600****       FY - -PPCAL120
121700*******************************************************
121800     IF BILL-DISCHARGE-DATE < 20121001
121900        MOVE 28 TO X4
122000*       ADD 1             TO DRG-CNT (X4 B-DRG)
122100        ADD 1             TO COUNT-TOTAL (X4)
122200     ELSE
122300
122400*******************************************************
122500****       FY - -PPCAL134
122600*******************************************************
122700     IF BILL-DISCHARGE-DATE < 20131001
122800        MOVE 29 TO X4
122900*       ADD 1             TO DRG-CNT (X4 B-DRG)
123000        ADD 1             TO COUNT-TOTAL (X4)
123100     ELSE
123200
123300*******************************************************
123400*******************************************************
123500****       FY - -PPCAL149
123600*******************************************************
123700     IF BILL-DISCHARGE-DATE < 20141001
123800        MOVE 30 TO X4
123900*       ADD 1             TO DRG-CNT (X4 B-DRG)
124000        ADD 1             TO COUNT-TOTAL (X4)
124100     ELSE
124200
124300*******************************************************
124400*******************************************************
124500****       FY - -PPCAL155
124600*******************************************************
124700     IF BILL-DISCHARGE-DATE < 20151001
124800        MOVE 31 TO X4
124900*       ADD 1             TO DRG-CNT (X4 B-DRG)
125000        ADD 1             TO COUNT-TOTAL (X4)
125100     ELSE
125200
125300*******************************************************
125400*******************************************************
125500****       FY - -PPCAL162
125600*******************************************************
125700     IF BILL-DISCHARGE-DATE < 20161001
125800        MOVE 32 TO X4
125900*       ADD 1             TO DRG-CNT (X4 B-DRG)
126000        ADD 1             TO COUNT-TOTAL (X4)
126100     ELSE
126200
126300*******************************************************
126400****       FY - -PPCAL171
126500*******************************************************
126600     IF BILL-DISCHARGE-DATE < 20171001
126700        MOVE 33 TO X4
126800*       ADD 1             TO DRG-CNT (X4 B-DRG)
126900        ADD 1             TO COUNT-TOTAL (X4).
127000
127100*******************************************************
127200*******************************************************
127300****       FY - -PPCAL182
127400*******************************************************
127500     IF BILL-DISCHARGE-DATE < 20181001
127600        MOVE 34 TO X4
127700*       ADD 1             TO DRG-CNT (X4 B-DRG)
127800        ADD 1             TO COUNT-TOTAL (X4).
127900
128000*******************************************************
128100*******************************************************
128200****       FY - -PPCAL192
128300*******************************************************
128400     IF BILL-DISCHARGE-DATE < 20191001
128500        MOVE 35 TO X4
128600*       ADD 1             TO DRG-CNT (X4 B-DRG)
128700        ADD 1             TO COUNT-TOTAL (X4).
128800
128900*******************************************************
129000*******************************************************
129100****       FY - -PPCAL200
129200*******************************************************
129300        MOVE 36 TO X4
129400*       ADD 1             TO DRG-CNT (X4 B-DRG)
129500        ADD 1             TO COUNT-TOTAL (X4).
129600
129700*******************************************************
129800*******************************************************
129900 0200-EXIT.  EXIT.
130000
130100
130200 1000-CALC-PAYMENT.
130300*******************************************************
130400*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE      *
130500*    PAYMENT                                          *
130600*******************************************************
130700***************************************************************
130800* OPTION (1)                                                  *
130900*       (1)  MOVE ' ' TO PRICER-OPTION-SW.                    *
131000*            CALL 'PPOPN___' USING BILL-DATA                  *
131100*                                  PPS-DATA                   *
131200*                                  PRICER-OPT-VERS-SW.        *
131300*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *
131400*                        *  *  *  *                           *
131500* OPTION (2)                                                  *
131600*       (2)  MOVE 'M' TO PRICER-OPTION-SW.                    *
131700*            CALL 'PPOPN___' USING BILL-DATA                  *
131800*                                  PPS-DATA                   *
131900*                                  PRICER-OPT-VERS-SW         *
132000*                                  PPS-ADDITIONAL-VARIABLES   *
132100*                                  PPHOLDAR-HOLD-AREA.        *
132200*        THIS PASSES THE STANDARD VARIIABLES AND THE          *
132300*      ADDITIONAL VARIABLES USED FOR PRICING.                 *
132400*                        *  *  *  *                           *
132500* OPTION (3)                                                  *
132600*       (3)  MOVE 'P' TO PRICER-OPTION-SW.                    *
132700*            CALL 'PPOPN___' USING BILL-DATA                  *
132800*                                  PPS-DATA                   *
132900*                                  PRICER-OPT-VERS-SW         *
133000*                                  PPS-ADDITIONAL-VARIABLES   *
133100*                                  PROV-RECORD-FROM-USER.     *
133200*        THIS PASSES THE STANDARD VARIABLES                   *
133300*       AND ADDITIONAL VARIABLES USED FOR PRICING.            *
133400*        THE PROVIDER RECORD FROM THE USER                    *
133500*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *
133600*                        *  *  *  *                           *
133700* OPTION (4)                                                  *
133800*       (4)  MOVE 'A' TO PRICER-OPTION-SW.                    *
133900*            CALL 'PPOPN___' USING BILL-DATA                  *
134000*                                  PPS-DATA                   *
134100*                                  PRICER-OPT-VERS-SW         *
134200*                                  PPS-ADDITIONAL-VARIABLES   *
134300*                                  PROV-RECORD-FROM-USER      *
134400*                                  MSAX-TABLE-FROM-USER.      *
134500*        THIS IS THE ONLINE COMPATIBLE INTERFACE.             *
134600*        THIS PASSES THE STANDARD VARIIABLES AND THE          *
134700*      ADDITIONAL VARIABLES USED FOR PRICING.                 *
134800*        THE PROVIDER RECORD AND THE WAGE INDEX TABLE FROM    *
134900*      THE USERS ARE PASSED.                                  *
135000***************************************************************
135100
135200*** OPTION (1)
135300*    MOVE ' ' TO PRICER-OPTION-SW.
135400*    CALL  PPOPN074   USING BILL-DATA
135500*                           PPS-DATA
135600*                           PRICER-OPT-VERS-SW.
135700*** OPTION (2)
135800     MOVE 'M' TO PRICER-OPTION-SW.
135900     CALL  PPOPN200   USING BILL-DATA
136000                            PPS-DATA
136100                            PRICER-OPT-VERS-SW
136200                            PPS-ADDITIONAL-VARIABLES
136300                            PPHOLDAR-HOLD-AREA.
136400*** OPTION (3)
136500*    MOVE 'P' TO PRICER-OPTION-SW.
136600*    CALL  PPOPN074   USING BILL-DATA
136700*                           PPS-DATA
136800*                           PRICER-OPT-VERS-SW
136900*                           PPS-ADDITIONAL-VARIABLES
137000*                           PROV-RECORD-FROM-USER.
137100*** OPTION (4)
137200*    MOVE 'A' TO PRICER-OPTION-SW.
137300*    CALL  PPOPN074   USING BILL-DATA
137400*                           PPS-DATA
137500*                           PRICER-OPT-VERS-SW
137600*                           PPS-ADDITIONAL-VARIABLES
137700*                           PROV-RECORD-FROM-USER
137800*                           MSAX-TABLE-FROM-USER
137900*                           CBSA-TABLE-FROM-USER.
138000
138100 1000-EXIT.  EXIT.
138200
138300 1100-WRITE-SYSUT2.
138400******************************************************************
138500*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL
138600*    REPORT AND WRITE TEST PAYMENT RECORD ROUTINE
138700******************************************************************
138800     IF  OPERLINE-CTR > 54
138900         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.
139000     MOVE SPACES            TO  PPS-DETAIL-LINE-OPER.
139100     MOVE BILL-HI-CLAIM-NO  TO  PRT-HIC.
139200     MOVE B-PROVIDER-NO     TO  PRT-PROV.
139300     MOVE PPS-WAGE-INDX     TO  PRT-WAGE-INDX.
139400     MOVE B-DRG             TO  PRT-GRP-DRG.
139500     MOVE PPS-AVG-LOS       TO  PRT-ALOS.
139600     MOVE PPS-DAYS-CUTOFF   TO  PRT-DAY-CUT.
139700     MOVE B-DISCHARGE-DATE  TO  PRT-DISCHG-DATE.
139800***  MOVE B-DISCHG-MM       TO  PRT-DISCHG-MM.
139900**   MOVE B-DISCHG-DD       TO  PRT-DISCHG-DD.
140000**   MOVE '/'               TO  PRT-SLASH1.
140100**   MOVE '/'               TO  PRT-SLASH2.
140200
140300
140400     MOVE PPS-TOTAL-PAYMENT TO  PRT-TOT-PAY.
140500     MOVE PPS-OPER-FSP-PART TO  PRT-FSP-PART.
140600     MOVE PPS-OPER-HSP-PART TO  PRT-HSP-PART.
140700     MOVE PPS-OPER-OUTLIER-PART TO PRT-OUTLIER-PART.
140800     MOVE PPS-OPER-DSH-ADJ  TO  PRT-DSH-ADJ.
140900     MOVE PPS-OPER-IME-ADJ  TO  PRT-INDTCH-ADJ.
141000     MOVE B-LOS             TO  PRT-LOS.
141100     MOVE PPS-OUTLIER-DAYS  TO  PRT-OUTLIER-DAYS.
141200     MOVE B-REVIEW-CODE     TO  PRT-REV-CODE.
141300     MOVE PPS-RTC           TO  PRT-PPS-RTC.
141400
141500     WRITE PRTOPER-LINE FROM PPS-DETAIL-LINE-OPER
141600                             AFTER ADVANCING 1.
141700     IF OPR-STAT1 > 0 DISPLAY ' BAD4 WRITE ON PRTOPER FILE'.
141800     ADD 1 TO OPERLINE-CTR.
141900
142000        WRITE OUT-REC FROM BILL-WORK.
142100
142200     IF UT2-STAT1 > 0 DISPLAY ' BAD1 WRITE ON PPSOUT  FILE'.
142300     ADD 1 TO PPSOUT-CTR.
142400
142500**************************************************************
142600**************************************************************
142700**************************************************************
142800******************************************************************
142900*         PRINT CAPIITAL PROSPECTIVE PAYMENT
143000*              TEST DATA DETAIL REPORT
143100******************************************************************
143200     IF  CAPILINE-CTR > 55
143300         PERFORM 1250-PPS-HEADINGS-CAPI THRU 1250-EXIT.
143400
143500     MOVE SPACES              TO PPS-DETAIL-LINE-CAPI.
143600     MOVE 0                   TO PRT-CAPI-TOT-PAY
143700                                 PRT-CAPI-HSP
143800                                 PRT-CAPI-FSP
143900                                 PRT-CAPI-OUTLIER
144000                                 PRT-CAPI-OLD-HARM
144100                                 PRT-CAPI-DSH-ADJ
144200                                 PRT-CAPI-IME-ADJ
144300                                 PRT-CAPI-EXCEPTIONS.
144400     MOVE BILL-HI-CLAIM-NO    TO PRT-CAPI-HIC.
144500     MOVE BILL-PROVIDER-NO    TO PRT-CAPI-PROV.
144600     MOVE PPS-CAPI-TOTAL-PAY  TO PRT-CAPI-TOT-PAY.
144700     MOVE PPS-CAPI-HSP        TO PRT-CAPI-HSP.
144800     MOVE PPS-CAPI-FSP        TO PRT-CAPI-FSP.
144900     MOVE PPS-CAPI-OUTLIER    TO PRT-CAPI-OUTLIER.
145000     MOVE PPS-CAPI-OLD-HARM   TO PRT-CAPI-OLD-HARM.
145100     MOVE PPS-CAPI-DSH-ADJ    TO PRT-CAPI-DSH-ADJ.
145200     MOVE PPS-CAPI-IME-ADJ    TO PRT-CAPI-IME-ADJ.
145300     MOVE PPS-CAPI-EXCEPTIONS TO PRT-CAPI-EXCEPTIONS.
145400
145500     WRITE PRTCAPI-LINE FROM PPS-DETAIL-LINE-CAPI
145600                            AFTER ADVANCING 1.
145700     IF CAP-STAT1 > 0 DISPLAY ' BAD1 WRITE ON PRTCAPI FILE'.
145800     ADD 1 TO CAPILINE-CTR.
145900 1100-EXIT.  EXIT.
146000
146100 1200-PPS-HEADINGS.
146200     WRITE PRTOPER-LINE FROM PPS-HEAD1
146300                             AFTER ADVANCING PAGE.
146400     IF OPR-STAT1 > 0 DISPLAY ' BAD5 WRITE ON PRTOPER FILE'.
146500     WRITE PRTOPER-LINE FROM PPS-HEAD2-OPER
146600                             AFTER ADVANCING 1.
146700     IF OPR-STAT1 > 0 DISPLAY ' BAD6 WRITE ON PRTOPER FILE'.
146800     WRITE PRTOPER-LINE FROM PPS-HEAD3-OPER
146900                             AFTER ADVANCING 2.
147000     IF OPR-STAT1 > 0 DISPLAY ' BAD7 WRITE ON PRTOPER FILE'.
147100     WRITE PRTOPER-LINE FROM PPS-HEAD4-OPER
147200                             AFTER ADVANCING 1.
147300     IF OPR-STAT1 > 0 DISPLAY ' BAD8 WRITE ON PRTOPER FILE'.
147400     MOVE ALL '  -' TO PRTOPER-LINE.
147500     WRITE PRTOPER-LINE AFTER ADVANCING 1.
147600     IF OPR-STAT1 > 0 DISPLAY ' BAD9 WRITE ON PRTOPER FILE'.
147700     MOVE 5 TO OPERLINE-CTR.
147800
147900 1200-EXIT.  EXIT.
148000
148100 1250-PPS-HEADINGS-CAPI.
148200     WRITE PRTCAPI-LINE FROM PPS-HEAD1 AFTER ADVANCING PAGE.
148300     IF CAP-STAT1 > 0 DISPLAY ' BAD2 WRITE ON PRTCAPI FILE'.
148400     WRITE PRTCAPI-LINE FROM PPS-HEAD2-CAPI AFTER ADVANCING 1.
148500     IF CAP-STAT1 > 0 DISPLAY ' BAD3 WRITE ON PRTCAPI FILE'.
148600     WRITE PRTCAPI-LINE FROM PPS-HEAD3-CAPI AFTER ADVANCING 2.
148700     IF CAP-STAT1 > 0 DISPLAY ' BAD4 WRITE ON PRTCAPI FILE'.
148800     MOVE ALL '  -' TO PRTCAPI-LINE.
148900     WRITE PRTCAPI-LINE AFTER ADVANCING 1.
149000     IF CAP-STAT1 > 0 DISPLAY ' BAD5 WRITE ON PRTCAPI FILE'.
149100     MOVE 5 TO CAPILINE-CTR.
149200
149300 1250-EXIT.  EXIT.
149400
149500*****        LAST STATEMENT               *************
