000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.                PPCAL202.
000300*REVISED.                   03-30-2020.
000400*AUTHOR.                    DDS TEAM.
000500*REMARKS.                   CMS.
000600 DATE-COMPILED.
000700
000800 ENVIRONMENT DIVISION.
000900 CONFIGURATION SECTION.
001000 SOURCE-COMPUTER.            IBM-370.
001100 OBJECT-COMPUTER.            IBM-370.
001200 INPUT-OUTPUT SECTION.
001300 FILE-CONTROL.
001400
001500 DATA DIVISION.
001600 FILE SECTION.
001700
001800 WORKING-STORAGE SECTION.
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE
002000     'PPCAL202      - W O R K I N G   S T O R A G E'.
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C20.2'.
002200 01  HMO-FLAG                       PIC X      VALUE 'N'.
002300 01  HMO-TAG                        PIC X      VALUE SPACE.
002400 01  OUTLIER-RECON-FLAG             PIC X      VALUE 'N'.
002500 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
002600 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
002700 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
002800 01  WK-LOW-VOL25PCT                PIC 99V999999 VALUE 01.000.
002900 01  WK-LOW-VOL-ADDON               PIC 9(07)V9(02).
003000 01  WK-MODEL1-BUNDLE-DISPRCNT      PIC S9(01)V9(03).
003100 01  WK-HAC-TOTAL-PAYMENT           PIC 9(07)V9(02).
003200 01  WK-HAC-AMOUNT                  PIC S9(07)V9(02).
003300 01  R1                             PIC S9(04) COMP SYNC.
003400 01  R2                             PIC S9(04) COMP SYNC.
003500 01  R3                             PIC S9(04) COMP SYNC.
003600 01  R4                             PIC S9(04) COMP SYNC.
003700 01  H-OPER-DSH-SCH                 PIC 9(01)V9(04).
003800 01  H-OPER-DSH-RRC                 PIC 9(01)V9(04).
003900 01  H-MB-RATIO-EHR-FULL            PIC 9(01)V9(09).
004000 01  H-MB-RATIO-EHR-QUAL-FULL       PIC 9(01)V9(09).
004100 01  H-EHR-SUBSAV-QUANT             PIC S9(07)V9(02).
004200 01  H-EHR-SUBSAV-LV                PIC S9(07)V9(02).
004300 01  H-EHR-SUBSAV-QUANT-INCLV       PIC S9(07)V9(02).
004400 01  H-EHR-RESTORE-FULL-QUANT       PIC S9(07)V9(02).
004500 01  IDX-TECH                       PIC 9(02).
004600
004700*-----------------------------------------------------*
004800* LABOR & NON-LABOR RATES TABLE                       *
004900*-----------------------------------------------------*
005000
005100 COPY RATEX200.
005200
005300*---------------------------------------------------------*
005400* DIAGNOSIS RELATED GROUP (DRG) WEIGHT TABLE (EFF. FY'19) *
005500*   + TABLE 5 FROM ANNUAL IPPS FINAL RULE                 *
005600*---------------------------------------------------------*
005700
005800 COPY DRGSX200.
005900
006000*---------------------------------------------------------------*
006100* TWO MIDNIGHT STAY POLICY ADJUSTMENT FACTOR TABLE (EFF. FY'01) *
006200*---------------------------------------------------------------*
006300
006400 COPY MIDNIGHT.
006500
006600*-----------------------------------------------------*
006700* NEW TECHNOLOGY ADD-ON PAYMENT ELIGIBILITY VARIABLES *
006800*-----------------------------------------------------*
006900
007000 COPY NTECH200.
007100
007200*-----------------------------------------------------*
007300* COVID-19 DRG ADJUSTMENT ELIGIBILITY VARIABLES       *
007400*-----------------------------------------------------*
007500
007600 01  IDX-COVID                      PIC 9(02).
007700 01  WK-COVID19-VARIABLES.
007800     05  WK-DIAG-COVID19            PIC X(07).
007900         88  DIAG-COVID1
008000               VALUE 'B9729  '.
008100         88  DIAG-COVID2
008200               VALUE 'U071   '.
008300     05  WK-COVID19-FLAGS.
008400         10  DIAG-COVID1-FLAG       PIC X(01).
008500         10  DIAG-COVID2-FLAG       PIC X(01).
008600 01  COVID-ADJ                      PIC 9(01)V9(01).
008700
008800***********************************************************
008900***  PROVIDER ADJUSTMENT TABLE FOR UNCOMPENSATED CARE UCC
009000***  WAS CHANGED TO DATA COMING FROM THE PROVIDER FILE
009100***********************************************************
009200
009300 01  MES-ADD-PROV                   PIC X(53) VALUE SPACES.
009400 01  MES-CHG-PROV                   PIC X(53) VALUE SPACES.
009500 01  MES-PPS-PROV                   PIC X(06).
009600 01  MES-PPS-STATE                  PIC X(02).
009700 01  MES-INTRO                      PIC X(53) VALUE SPACES.
009800 01  MES-TOT-PAY                    PIC 9(07)V9(02) VALUE 0.
009900 01  MES-SSRFBN.
010000     05 MES-SSRFBN-STATE PIC 99.
010100     05 FILLER           PIC XX.
010200     05 MES-SSRFBN-RATE  PIC 9(1)V9(5).
010300     05 FILLER           PIC XX.
010400     05 MES-SSRFBN-CODE2 PIC 99.
010500     05 FILLER           PIC XX.
010600     05 MES-SSRFBN-STNAM PIC X(20).
010700     05 MES-SSRFBN-REST  PIC X(22).
010800
010900 01 WK-HLDDRG-DATA.
011000     05  HLDDRG-DATA.
011100         10  HLDDRG-DRGX               PIC X(03).
011200         10  FILLER1                   PIC X(01).
011300         10  HLDDRG-WEIGHT             PIC 9(02)V9(04).
011400         10  FILLER2                   PIC X(01).
011500         10  HLDDRG-GMALOS             PIC 9(02)V9(01).
011600         10  FILLER3                   PIC X(05).
011700         10  HLDDRG-LOW                PIC X(01).
011800         10  FILLER5                   PIC X(01).
011900         10  HLDDRG-ARITH-ALOS         PIC 9(02)V9(01).
012000         10  FILLER6                   PIC X(02).
012100         10  HLDDRG-PAC                PIC X(01).
012200         10  FILLER7                   PIC X(01).
012300         10  HLDDRG-SPPAC              PIC X(01).
012400         10  FILLER8                   PIC X(02).
012500         10  HLDDRG-DESC               PIC X(26).
012600
012700 01 WK-HLDDRG-DATA2.
012800     05  HLDDRG-DATA2.
012900         10  HLDDRG-DRGX2               PIC X(03).
013000         10  FILLER21                   PIC X(01).
013100         10  HLDDRG-WEIGHT2             PIC 9(02)V9(04).
013200         10  FILLER22                   PIC X(01).
013300         10  HLDDRG-GMALOS2             PIC 9(02)V9(01).
013400         10  FILLER23                   PIC X(05).
013500         10  HLDDRG-LOW2                PIC X(01).
013600         10  FILLER25                   PIC X(01).
013700         10  HLDDRG-ARITH-ALOS2         PIC 9(02)V9(01).
013800         10  FILLER26                   PIC X(02).
013900         10  HLDDRG-TRANS-FLAGS.
014000                   88  D-DRG-POSTACUTE-50-50
014100                   VALUE 'Y Y'.
014200                   88  D-DRG-POSTACUTE-PERDIEM
014300                   VALUE 'Y  '.
014400             15  HLDDRG-PAC2            PIC X(01).
014500             15  FILLER27               PIC X(01).
014600             15  HLDDRG-SPPAC2          PIC X(01).
014700         10  FILLER28                   PIC X(02).
014800         10  HLDDRG-DESC2               PIC X(26).
014900         10  HLDDRG-VALID               PIC X(01).
015000
015100 01  MES-LOWVOL.
015200     05  MES-LOWVOL-PROV             PIC X(6).
015300     05  FILLER                      PIC XXX.
015400     05  MESWK-LOWVOL-PROV-DISCHG    PIC 9999.
015500
015600 01  WK-UNCOMP-CARE.
015700     05  WK-UNCOMP-CARE-PROV         PIC X(6).
015800     05  FILLER                      PIC X.
015900     05  WK-UNCOMP-CARE-AMOUNT       PIC 9(06)V9(02).
016000
016100 01 WK-HLD-MID-DATA.
016200     05  HLD-MID-DATA.
016300         10  HLD-MID-MSAX              PIC X(04).
016400         10  FILLER1                   PIC X(01).
016500         10  HLD-MID-ADJ-FACT          PIC 9(02)V9(06).
016600
016700 01  HLD-PPS-DATA.
016800         10  HLD-PPS-RTC                PIC 9(02).
016900         10  HLD-PPS-WAGE-INDX          PIC 9(02)V9(04).
017000         10  HLD-PPS-OUTLIER-DAYS       PIC 9(03).
017100         10  HLD-PPS-AVG-LOS            PIC 9(02)V9(01).
017200         10  HLD-PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
017300         10  HLD-PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
017400         10  HLD-PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
017500         10  HLD-PPS-OPER-HSP-PART      PIC 9(06)V9(02).
017600         10  HLD-PPS-OPER-FSP-PART      PIC 9(06)V9(02).
017700         10  HLD-PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
017800         10  HLD-PPS-REG-DAYS-USED      PIC 9(03).
017900         10  HLD-PPS-LTR-DAYS-USED      PIC 9(02).
018000         10  HLD-PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
018100         10  HLD-PPS-CALC-VERS          PIC X(05).
018200
018300 LINKAGE SECTION.
018400
018500************************************************************************
018600* REVIEW CODES DIRECT THE PPCAL SUBROUTINE IN HOW TO PAY THE BILL.     *
018700*                                                                      *
018800* COMMENTS:                                                            *
018900* CLAIMS WITH CONDITION CODE 66 SHOULD BE PROCESSED UNDER REVIEW CODE  *
019000* 06, 07, OR 11 AS APPROPRIATE TO EXCLUDE ANY OUTLIER COMPUTATION.     *
019100*                                                                      *
019200* REVIEW-CODE:                                                         *
019300*   00: PAY-WITH-OUTLIER.                                              *
019400*    + WILL CALCULATE THE STANDARD PAYMENT.                            *
019500*    + WILL ALSO ATTEMPT TO PAY ONLY COST OUTLIERS;                    *
019600*      DAY OUTLIERS EXPIRED 10/01/97                                   *
019700*                                                                      *
019800*   03: PAY-PERDIEM-DAYS.                                              *
019900*    + WILL CALCULATE A PERDIEM PAYMENT BASED ON THE STANDARD PAYMENT  *
020000*      IF THE COVERED DAYS ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
020100*      FOR THE DRG. IF COVERED DAYS EQUAL OR EXCEED THE AVERAGE LENGTH *
020200*      OF STAY, THE STANDARD PAYMENT IS CALCULATED.                    *
020300*    + WILL ALSO CALCULATE THE COST OUTLIER PORTION OF THE PAYMENT IF  *
020400*      THE ADJUSTED CHARGES ON THE BILL EXCEED THE COST THRESHOLD.     *
020500*                                                                      *
020600*   06: PAY-XFER-NO-COST                                               *
020700*    + WILL CALCULATE A PERDIEM PAYMENT BASED ON THE STANDARD PAYMENT  *
020800*      IF THE COVERED DAYS ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
020900*      FOR THE DRG. IF COVERED DAYS EQUAL OR EXCEED THE AVERAGE LENGTH *
021000*      OF STAY, THE STANDARD PAYMENT IS CALCULATED.                    *
021100*    + WILL NOT CALCULATE THE COST OUTLIER PORTION OF THE PAYMENT.     *
021200*                                                                      *
021300*   07: PAY-WITHOUT-COST.                                              *
021400*    + WILL CALCULATE THE STANDARD PAYMENT WITHOUT THE COST PORTION.   *
021500*                                                                      *
021600*   09: PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS                       *
021700*    + 50-50                                                           *
021800*      - NOW USES Y INDICATORS ON DRGS                                 *
021900*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
022000*      - THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRGS      *
022100*    + FULL PERDIEM                                                    *
022200*      - NOW USES Y INDICATORS ON DRGS                                 *
022300*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
022400*    + WILL CALCULATE A PERDIEM PAYMENT BASED ON THE STANDARD DRG      *
022500*      PAYMENT IF THE COVERED DAYS ARE LESS THAN THE AVERAGE LENGTH OF *
022600*      STAY FOR THE DRG. IF COVERED DAYS EQUAL OR EXCEED THE AVERAGE   *
022700*      LENGTH OF STAY, THE STANDARD PAYMENT IS CALCULATED.             *
022800*    + WILL ALSO CALCULATE THE COST OUTLIER PORTION OF THE PAYMENT IF  *
022900*      THE ADJUSTED CHARGES ON THE BILL EXCEED THE COST THRESHOLD.     *
023000*                                                                      *
023100*   11: PAY-XFER-SPEC-DRG-NO-COST - POST-ACUTE TRANSFERS               *
023200*    + 50-50                                                           *
023300*      - NOW USES Y INDICATORS ON DRGS                                 *
023400*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
023500*      - THE 50/50 DRG'S DO NOT REPEAT WITH THE FULL PERDIEM DRGS      *
023600*    + FULL PERDIEM                                                    *
023700*      - NOW USES Y INDICATORS ON DRGS                                 *
023800*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
023900*    + WILL CALCULATE A PERDIEM PAYMENT BASED ON THE STANDARD DRG      *
024000*      PAYMENT IF THE COVERED DAYS ARE LESS THAN THE AVERAGE LENGTH OF *
024100*      STAY FOR THE DRG. IF COVERED DAYS EQUAL OR EXCEED THE AVERAGE   *
024200*      LENGTH OF STAY, THE STANDARD PAYMENT IS CALCULATED.             *
024300*    + WILL NOT CALCULATE THE COST OUTLIER PORTION OF THE PAYMENT.     *
024400************************************************************************
024500
024600************************************************************************
024700* NEW BILL FORMAT (MILLINNIUM COMPATIBLE)                              *
024800*                                                                      *
024900* THIS IS THE BILL-RECORD THAT WILL BE PASSED TO THE PPCAL001 PROGRAM  *
025000* AND AFTER FOR PROCESSING IN THE NEW FORMAT.                          *
025100*                                                                      *
025200* B-CHARGES-CLAIMED = TOTAL COVERED CHARGES ON THE 0001 (TOTALS        *
025300* LINE) MINUS BLOOD CLOT COST, KIDNEY COSTS, ACQUISITION COSTS AND     *
025400* TECHNICAL PROVIDER CHARGES.                                          *
025500************************************************************************
025600 01  BILL-NEW-DATA.
025700         10  B-NPI10.
025800             15  B-NPI8             PIC X(08).
025900             15  B-NPI-FILLER       PIC X(02).
026000         10  B-PROVIDER-NO          PIC X(06).
026100             88  B-FORMER-MDH-PROVIDERS
026200                                      VALUE '080006' '140184'
026300                                            '390072' '420019'
026400                                            '440031' '450451'
026500                                            '490019' '510062'.
026600         10  B-REVIEW-CODE          PIC 9(02).
026700             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
026800             88  PAY-WITH-OUTLIER     VALUE 00 07.
026900             88  PAY-PERDIEM-DAYS     VALUE 03.
027000             88  PAY-XFER-NO-COST     VALUE 06.
027100             88  PAY-WITHOUT-COST     VALUE 07.
027200             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
027300             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
027400         10  B-DRG                  PIC 9(03).
027500
027600* ======================================================
027700* THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE DRG'S
027800* ======================================================
027900*
028000*            88  B-DRG-POSTACUTE-PERDIEM
028100*                         VALUE  NOW USES Y INDICATORS ON DRGS
028200*                         SEE TABLE 5
028300*                         D-DRG-POSTACUTE-PERDIEM
028400
028500         10  B-LOS                  PIC 9(03).
028600         10  B-COVERED-DAYS         PIC 9(03).
028700         10  B-LTR-DAYS             PIC 9(02).
028800         10  B-DISCHARGE-DATE.
028900             15  B-DISCHG-CC        PIC 9(02).
029000             15  B-DISCHG-YY        PIC 9(02).
029100             15  B-DISCHG-MM        PIC 9(02).
029200             15  B-DISCHG-DD        PIC 9(02).
029300         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
029400         10  B-PROCEDURE-CODE-TABLE.
029500             15  B-PROCEDURE-CODE    PIC X(07) OCCURS 25 TIMES
029600                 INDEXED BY IDX-PROC.
029700         10  B-DIAGNOSIS-CODE-TABLE.
029800             15  B-DIAGNOSIS-CODE    PIC X(07) OCCURS 25 TIMES
029900                 INDEXED BY IDX-DIAG.
030000         10  B-DEMO-DATA.
030100             15  B-DEMO-CODE1           PIC X(02).
030200             15  B-DEMO-CODE2           PIC X(02).
030300             15  B-DEMO-CODE3           PIC X(02).
030400             15  B-DEMO-CODE4           PIC X(02).
030500         10  B-NDC-DATA.
030600             15  B-NDC-NUMBER           PIC X(11).
030700         10  FILLER                     PIC X(73).
030800
030900************************************************************************
031000* RETURN CODES (PPS-RTC) NOTE HOW THE BILL WAS/WAS NOT PAID.           *
031100*   00-49: HOW THE BILL WAS PAID                                       *
031200*   50-99: WHY THE BILL WAS NOT PAID                                   *
031300*  ----------------------------------------------------------          *
031400*   00,30:                                                             *
031500*    + PAID NORMAL DRG PAYMENT                                         *
031600*                                                                      *
031700*   01:                                                                *
031800*    + PAID AS A DAY-OUTLIER.                                          *
031900*      - DAY-OUTLIER NO LONGER BEING PAID AS OF 10/01/97               *
032000*                                                                      *
032100*   02:                                                                *
032200*    + PAID AS A COST-OUTLIER.                                         *
032300*                                                                      *
032400*   03,33:                                                             *
032500*    + TRANSFER PAID ON PERDIEM BASIS UP TO AND INCLUDING THE FULL DRG *
032600*                                                                      *
032700*   05:                                                                *
032800*    + TRANSFER PAID ON PERDIEM BASIS UP TO AND INCLUDING THE FULL DRG *
032900*    + QUALIFIED FOR A COST OUTLIER PAYMENT                            *
033000*                                                                      *
033100*   06:                                                                *
033200*    + TRANSFER PAID ON PERDIEM BASIS UP TO AND INCLUDING THE FULL DRG *
033300*    + PROVIDER REFUSED COST OUTLIER PAYMENT                           *
033400*                                                                      *
033500*   10,40:                                                             *
033600*    + POST-ACUTE TRANSFER                                             *
033700*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
033800*      - THE 50/50 DRG'S DO NOT REPEAT WITH THE POSTACUTE DRGS         *
033900*                                                                      *
034000*   12,42:                                                             *
034100*    + POST-ACAUTE TRANSFER WITH SPECIFIC DRGS                         *
034200*      - NOW USES Y INDICATORS ON DRGS                                 *
034300*      - SEE TABLE 5 FROM ANNUAL IPPS FINAL RULE                       *
034400*      - D-DRG-POSTACUTE-PERDIEM                                       *
034500*                                                                      *
034600*   14,44:                                                             *
034700*    + PAID NORMAL DRG PAYMENT WITH PERDIEM DAYS = OR > GM ALOS        *
034800*                                                                      *
034900*   16:                                                                *
035000*    + PAID AS A COST-OUTLIER WITH PERDIEM DAYS = OR > GM ALOS         *
035100*                                                                      *
035200*   30,33,40,42,44:                                                    *
035300*    + OUTLIER RECONCILIATION                                          *
035400*                                                                      *
035500*   51:                                                                *
035600*    + NO PROVIDER SPECIFIC INFO FOUND                                 *
035700*                                                                      *
035800*   52:                                                                *
035900*    + INVALID CBSA# IN PROVIDER FILE OR                               *
036000*    + INVALID WAGE INDEX OR                                           *
036100*    + INVALID PROVIDER TYPES ON PROVIDER FILE                         *
036200*                                                                      *
036300*   53:                                                                *
036400*    + WAIVER STATE - NOT CALCULATED BY PPS OR                         *
036500*    + INVALID STATE CODE IN COMBINATION WITH HAC FLAG                 *
036600*                                                                      *
036700*   54:                                                                *
036800*    + INVALID DRG                                                     *
036900*                                                                      *
037000*   55:                                                                *
037100*    + DISCHARGE DATE < PROVIDER EFF START DATE OR                     *
037200*    + DISCHARGE DATE < CBSA EFF START DATE FOR PPS OR                 *
037300*    + PROVIDER HAS BEEN TERMINATED ON OR BEFORE DISCHARGE DATE        *
037400*                                                                      *
037500*   56:                                                                *
037600*    + INVALID LENGTH OF STAY                                          *
037700*                                                                      *
037800*   57:                                                                *
037900*    + REVIEW CODE INVALID (NOT 00 03 06 07 09 11)                     *
038000*                                                                      *
038100*   58:                                                                *
038200*    + TOTAL CHARGES NOT NUMERIC                                       *
038300*                                                                      *
038400*   61:                                                                *
038500*    + LIFETIME RESERVE DAYS NOT NUMERIC OR BILL-LTR-DAYS > 60         *
038600*                                                                      *
038700*   62:                                                                *
038800*    + INVALID NUMBER OF COVERED DAYS                                  *
038900*                                                                      *
039000*   65:                                                                *
039100*    + PAY-CODE NOT = A, B OR C ON PSF FOR CAPITAL OR                  *
039200*    + INVALID READMISSION FLAG IN PSF FILE OR                         *
039300*    + BLANK READMISSION FLAG IN PSF FILE OR                           *
039400*    + READMISSION ADJUSTMENT IS INVALID / OUT OF RANGE IN PSF FILE OR *
039500*    + BLANK READMISSION ADJUSTMENT IN PSF FILE OR                     *
039600*    + INVALID STATE CODE IN COMBO W/ READMISSION FLAG IN PSF FILE OR  *
039700*    + INVALID EHR FLAG IN PSF FILE (MUST BE A "Y" OR BLANK)           *
039800*                                                                      *
039900*   67:                                                                *
040000*    + COST OUTLIER WITH LOS > COVERED DAYS OR                         *
040100*      COST OUTLIER THRESHOLD CALUCULATION                             *
040200*                                                                      *
040300*   68:                                                                *
040400*    + INVALID VALUE BASED PURCHASE FLAG IN PSF FILE OR                *
040500*    + BLANK VALUE BASED PURCHASE FLAG IN PSF FILE OR                  *
040600*    + VALUE BASED PURCHASE ADJUSTMEMT IS INVALID OR OUT OF RANGE IN   *
040700*      PSF FILE INDICATOR OR                                           *
040800*    + BLANK VALUE BASED PURCHASE ADJUSTMEMT IN PSF FILE OR            *
040900*    + INVALID COMBINATION OF HOSPITAL QUALITY INDICATOR AND VALUE     *
041000*      BASED PURCHASE FLAG IN PSF FILE OR                              *
041100*    + INVALID STATE CODE IN COMBINATION WITH VALUE BASED PURCHASE     *
041200*      FLAG IN PSF FILE                                                *
041300*                                                                      *
041400*   98: CANNOT PROCESS BILL OLDER THAN 5 YEARS                         *
041500************************************************************************
041600 01  PPS-DATA.
041700         10  PPS-RTC                PIC 9(02).
041800         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
041900         10  PPS-OUTLIER-DAYS       PIC 9(03).
042000         10  PPS-AVG-LOS            PIC 9(02)V9(01).
042100         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
042200         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
042300         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
042400         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
042500         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
042600         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
042700         10  PPS-REG-DAYS-USED      PIC 9(03).
042800         10  PPS-LTR-DAYS-USED      PIC 9(02).
042900         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
043000         10  PPS-CALC-VERS          PIC X(05).
043100
043200*****************************************************************
043300*            THESE ARE THE VERSIONS OF THE PPCAL
043400*           PROGRAMS THAT WILL BE PASSED BACK----
043500*          ASSOCIATED WITH THE BILL BEING PROCESSED
043600*****************************************************************
043700 01  PRICER-OPT-VERS-SW.
043800     02  PRICER-OPTION-SW          PIC X(01).
043900         88  ALL-TABLES-PASSED          VALUE 'A'.
044000         88  PROV-RECORD-PASSED         VALUE 'P'.
044100         88  ADDITIONAL-VARIABLES       VALUE 'M'.
044200         88  PC-PRICER                  VALUE 'C'.
044300     02  PPS-VERSIONS.
044400         10  PPDRV-VERSION         PIC X(05).
044500
044600*****************************************************************
044700*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
044800*          ASSOCIATED WITH THE BILL BEING PROCESSED
044900*****************************************************************
045000 01  PPS-ADDITIONAL-VARIABLES.
045100     05  PPS-HSP-PCT                PIC 9(01)V9(02).
045200     05  PPS-FSP-PCT                PIC 9(01)V9(02).
045300     05  PPS-NAT-PCT                PIC 9(01)V9(02).
045400     05  PPS-REG-PCT                PIC 9(01)V9(02).
045500     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
045600     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
045700     05  PPS-DRG-WT                 PIC 9(02)V9(04).
045800     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
045900     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
046000     05  PPS-REG-LABOR              PIC 9(05)V9(02).
046100     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
046200     05  PPS-OPER-COLA              PIC 9(01)V9(03).
046300     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
046400     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
046500     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
046600     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
046700     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
046800     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
046900     05  PPS-CAPITAL-VARIABLES.
047000         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
047100         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
047200         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
047300         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
047400         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
047500         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
047600         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
047700         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
047800     05  PPS-CAPITAL2-VARIABLES.
047900         10  PPS-CAPI2-PAY-CODE             PIC X(1).
048000         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
048100         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
048200     05  PPS-OTHER-VARIABLES.
048300         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
048400         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
048500         10  PPS-ISLET-ISOL-PAY-ADD-ON      PIC 9(07)V9(02).
048600         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
048700         10  PPS-VAL-BASED-PURCH-PARTIPNT   PIC X.
048800         10  PPS-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
048900         10  PPS-HOSP-READMISSION-REDU      PIC X.
049000         10  PPS-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
049100         10  PPS-OPERATNG-DATA.
049200             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
049300             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
049400             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
049500     05  PPS-PC-OTH-VARIABLES.
049600         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
049700         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
049800         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
049900         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
050000         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
050100         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
050200         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(04).
050300         10  PPS-PC-HMO-FLAG                PIC X(01).
050400         10  PPS-PC-COT-FLAG                PIC X(01).
050500         10  PPS-OPER-HSP-PART2             PIC 9(07)V9(02).
050600         10  PPS-BUNDLE-ADJUST-PAY          PIC S9(07)V99.
050700     05  PPS-ADDITIONAL-PAY-INFO-DATA.
050800         10 PPS-UNCOMP-CARE-AMOUNT          PIC S9(07)V9(02).
050900         10 PPS-BUNDLE-ADJUST-AMT           PIC S9(07)V9(02).
051000         10 PPS-VAL-BASED-PURCH-ADJUST-AMT  PIC S9(07)V9(02).
051100         10 PPS-READMIS-ADJUST-AMT          PIC S9(07)V9(02).
051200     05  PPS-ADDITIONAL-PAY-INFO-DATA2.
051300         10  PPS-HAC-PROG-REDUC-IND      PIC X.
051400         10  PPS-EHR-PROG-REDUC-IND      PIC X.
051500         10  PPS-EHR-ADJUST-AMT          PIC S9(07)V9(02).
051600         10  PPS-STNDRD-VALUE            PIC S9(07)V9(02).
051700         10  PPS-HAC-PAYMENT-AMT         PIC S9(07)V9(02).
051800         10  PPS-FLX7-PAYMENT            PIC S9(07)V9(02).
051900     05 PPS-FILLER                       PIC X(0897).
052000
052100 01  PROV-NEW-HOLD.
052200     02  PROV-NEWREC-HOLD1.
052300         05  P-NEW-NPI10.
052400             10  P-NEW-NPI8             PIC X(08).
052500             10  P-NEW-NPI-FILLER       PIC X(02).
052600         05  P-NEW-PROVIDER-NO.
052700             88  P-NEW-DSH-ADJ-PROVIDERS
052800                             VALUE '180049' '190044' '190144'
052900                                   '190191' '330047' '340085'
053000                                   '370016' '370149' '420043'.
053100             10  P-NEW-STATE            PIC X(02).
053200                 88  P-VBP-INVALID-STATE
053300                             VALUE '21' '80' '40' '84'.
053400                 88  P-READ-INVALID-STATE
053500                             VALUE '40' '84'.
053600                 88  P-HAC-INVALID-STATE
053700                             VALUE '40' '84'.
053800                 88  P-PR-NEW-STATE
053900                             VALUE '40' '84'.
054000             10  FILLER                 PIC X(04).
054100         05  P-NEW-DATE-DATA.
054200             10  P-NEW-EFF-DATE.
054300                 15  P-NEW-EFF-DT-CC    PIC 9(02).
054400                 15  P-NEW-EFF-DT-YY    PIC 9(02).
054500                 15  P-NEW-EFF-DT-MM    PIC 9(02).
054600                 15  P-NEW-EFF-DT-DD    PIC 9(02).
054700             10  P-NEW-FY-BEGIN-DATE.
054800                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
054900                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
055000                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
055100                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
055200             10  P-NEW-REPORT-DATE.
055300                 15  P-NEW-REPORT-DT-CC PIC 9(02).
055400                 15  P-NEW-REPORT-DT-YY PIC 9(02).
055500                 15  P-NEW-REPORT-DT-MM PIC 9(02).
055600                 15  P-NEW-REPORT-DT-DD PIC 9(02).
055700             10  P-NEW-TERMINATION-DATE.
055800                 15  P-NEW-TERM-DT-CC   PIC 9(02).
055900                 15  P-NEW-TERM-DT-YY   PIC 9(02).
056000                 15  P-NEW-TERM-DT-MM   PIC 9(02).
056100                 15  P-NEW-TERM-DT-DD   PIC 9(02).
056200         05  P-NEW-WAIVER-CODE          PIC X(01).
056300             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
056400         05  P-NEW-INTER-NO             PIC 9(05).
056500         05  P-NEW-PROVIDER-TYPE        PIC X(02).
056600             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
056700             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
056800                                                  '15' '17'
056900                                                  '22'.
057000             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
057100             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
057200             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
057300             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
057400             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
057500             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
057600             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
057700             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
057800             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
057900             88  P-N-EACH                   VALUE '21' '22'.
058000             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
058100             88  P-N-NHCMQ-II-SNF           VALUE '32'.
058200             88  P-N-NHCMQ-III-SNF          VALUE '33'.
058300             88  P-N-INVALID-PROV-TYPES     VALUE '14' '15'.
058400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
058500             88  P-N-NEW-ENGLAND            VALUE  1.
058600             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
058700             88  P-N-SOUTH-ATLANTIC         VALUE  3.
058800             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
058900             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
059000             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
059100             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
059200             88  P-N-MOUNTAIN               VALUE  8.
059300             88  P-N-PACIFIC                VALUE  9.
059400         05  P-NEW-CURRENT-DIV   REDEFINES
059500                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
059600             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
059700         05  P-NEW-MSA-DATA.
059800             10  P-NEW-CHG-CODE-INDEX       PIC X.
059900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
060000             10  P-NEW-GEO-LOC-MSA9   REDEFINES
060100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
060200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
060300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
060400             10  P-NEW-STAND-AMT-LOC-MSA9
060500       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
060600                 15  P-NEW-RURAL-1ST.
060700                     20  P-NEW-STAND-RURAL  PIC XX.
060800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
060900                 15  P-NEW-RURAL-2ND        PIC XX.
061000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
061100                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
061200                 88  P-NEW-SCH-YR82       VALUE   '82'.
061300                 88  P-NEW-SCH-YR87       VALUE   '87'.
061400         05  P-NEW-LUGAR                    PIC X.
061500         05  P-NEW-TEMP-RELIEF-IND          PIC X.
061600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
061700         05  P-NEW-STATE-CODE               PIC 9(02).
061800         05  P-NEW-STATE-CODE-X REDEFINES
061900             P-NEW-STATE-CODE               PIC X(02).
062000         05  FILLER                         PIC X(03).
062100     02  PROV-NEWREC-HOLD2.
062200         05  P-NEW-VARIABLES.
062300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
062400             10  P-NEW-COLA              PIC  9(01)V9(03).
062500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
062600             10  P-NEW-BED-SIZE          PIC  9(05).
062700             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
062800             10  P-NEW-CMI               PIC  9(01)V9(04).
062900             10  P-NEW-SSI-RATIO         PIC  V9(04).
063000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
063100             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
063200             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
063300             10  P-NEW-DSH-PERCENT       PIC  V9(04).
063400             10  P-NEW-FYE-DATE          PIC  X(08).
063500         05  P-NEW-CBSA-DATA.
063600             10  P-NEW-CBSA-SPEC-PAY-IND    PIC X.
063700             10  P-NEW-CBSA-HOSP-QUAL-IND   PIC X.
063800             10  P-NEW-CBSA-GEO-LOC         PIC X(05) JUST RIGHT.
063900             10  P-NEW-CBSA-GEO-RURAL REDEFINES
064000                 P-NEW-CBSA-GEO-LOC.
064100                 15  P-NEW-CBSA-GEO-RURAL1ST PIC XXX.
064200                     88  P-NEW-CBSA-GEO-RURAL1    VALUE '   '.
064300                 15  P-NEW-CBSA-GEO-RURAL2ND PIC XX.
064400
064500             10  P-NEW-CBSA-RECLASS-LOC     PIC X(05) JUST RIGHT.
064600             10  P-NEW-CBSA-STAND-AMT-LOC   PIC X(05) JUST RIGHT.
064700             10  P-NEW-CBSA-SPEC-WAGE-INDEX    PIC 9(02)V9(04).
064800     02  PROV-NEWREC-HOLD3.
064900         05  P-NEW-PASS-AMT-DATA.
065000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
065100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
065200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
065300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
065400         05  P-NEW-CAPI-DATA.
065500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
065600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
065700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
065800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
065900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
066000             15  P-NEW-CAPI-NEW-HOSP       PIC X.
066100             15  P-NEW-CAPI-IME            PIC 9V9999.
066200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
066300         05  P-HVBP-HRR-DATA.
066400             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
066500             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
066600             15  P-HOSP-READMISSION-REDU    PIC X.
066700             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
066800         05  P-MODEL1-BUNDLE-DATA.
066900             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
067000             15  P-HAC-REDUC-IND            PIC X.
067100             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
067200             15  P-EHR-REDUC-IND            PIC X.
067300             15  P-LV-ADJ-FACTOR            PIC 9V9(6).
067400         05  P-NEW-COUNTY-CODE              PIC 9(05).
067500         05  P-NEW-COUNTY-CODE-X REDEFINES
067600             P-NEW-COUNTY-CODE              PIC X(05).
067700         05  FILLER                         PIC X(47).
067800
067900*****************************************************************
068000 01  WAGE-NEW-CBSA-INDEX-RECORD.
068100     05  W-CBSA                        PIC X(5).
068200     05  W-CBSA-SIZE                   PIC X.
068300         88  LARGE-URBAN       VALUE 'L'.
068400         88  OTHER-URBAN       VALUE 'O'.
068500         88  ALL-RURAL         VALUE 'R'.
068600     05  W-CBSA-EFF-DATE               PIC X(8).
068700     05  FILLER                        PIC X.
068800     05  W-CBSA-INDEX-RECORD           PIC S9(02)V9(04).
068900     05  W-CBSA-PR-INDEX-RECORD        PIC S9(02)V9(04).
069000
069100*******************************************************
069200*    HOLD VARIABLES POPULATED IN PPCAL___***          *
069300*******************************************************
069400 COPY PPHOLDAR.
069500
069600******************************************************************
069700 PROCEDURE DIVISION  USING BILL-NEW-DATA
069800                           PPS-DATA
069900                           PRICER-OPT-VERS-SW
070000                           PPS-ADDITIONAL-VARIABLES
070100                           PROV-NEW-HOLD
070200                           WAGE-NEW-CBSA-INDEX-RECORD
070300                           PPHOLDAR-HOLD-AREA.
070400
070500***************************************************************
070600*    PROCESSING:                                              *
070700*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
070800*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
070900*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
071000*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
071100*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
071200*           GOBACK.                                           *
071300*        D. ASSEMBLE PRICING COMPONENTS.                      *
071400*        E. CALCULATE THE PRICE.                              *
071500***************************************************************
071600     INITIALIZE WK-HLDDRG-DATA
071700                WK-HLDDRG-DATA2
071800                WK-HLD-MID-DATA
071900                WK-NEW-TECH-VARIABLES
072000                WK-COVID19-VARIABLES.
072100
072200     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
072300     MOVE ZEROES TO WK-UNCOMP-CARE-AMOUNT.
072400     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT.
072500     MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT.
072600     MOVE ZEROES TO H-READMIS-ADJUST-AMT.
072700     MOVE 'N' TO TEMP-RELIEF-FLAG.
072800     MOVE 'N' TO OUTLIER-RECON-FLAG.
072900     MOVE ZEROES TO WK-HAC-AMOUNT.
073000     MOVE ZEROES TO WK-HAC-TOTAL-PAYMENT.
073100     MOVE ZEROES TO H-NEW-TECH-PAY-ADD-ON.
073200     MOVE ZEROES TO PPS-NEW-TECH-PAY-ADD-ON.
073300     MOVE ZEROES TO PPS-ISLET-ISOL-PAY-ADD-ON.
073400
073500     PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT.
073600
073700     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
073800     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
073900     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
074000     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
074100     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
074200     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
074300     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
074400     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
074500     MOVE H-ADDITIONAL-PAY-INFO-DATA TO
074600                            PPS-ADDITIONAL-PAY-INFO-DATA.
074700     MOVE H-ADDITIONAL-PAY-INFO-DATA2 TO
074800                            PPS-ADDITIONAL-PAY-INFO-DATA2.
074900
075000     COMPUTE PPS-OPER-HSP-PART2 ROUNDED =  1 *  H-HSP-RATE.
075100     MOVE    WK-UNCOMP-CARE-AMOUNT TO PPS-UNCOMP-CARE-AMOUNT.
075200     MOVE    H-BUNDLE-ADJUST-AMT TO PPS-BUNDLE-ADJUST-AMT.
075300     MOVE    H-VAL-BASED-PURCH-ADJUST-AMT TO
075400                           PPS-VAL-BASED-PURCH-ADJUST-AMT.
075500     MOVE    H-READMIS-ADJUST-AMT TO PPS-READMIS-ADJUST-AMT.
075600     MOVE    P-MODEL1-BUNDLE-DISPRCNT TO
075700                               PPS-MODEL1-BUNDLE-DISPRCNT.
075800
075900     MOVE P-HAC-REDUC-IND  TO  PPS-HAC-PROG-REDUC-IND.
076000     MOVE P-EHR-REDUC-IND  TO  PPS-EHR-PROG-REDUC-IND.
076100     MOVE H-EHR-ADJUST-AMT TO  PPS-EHR-ADJUST-AMT.
076200*    MOVE H-STNDRD-VALUE   TO  PPS-STNDRD-VALUE.
076300     MOVE H-STANDARD-ALLOWED-AMOUNT  TO  PPS-STNDRD-VALUE.
076400     MOVE WK-HAC-AMOUNT  TO   PPS-HAC-PAYMENT-AMT.
076500     MOVE 0     TO    PPS-FLX7-PAYMENT.
076600
076700     IF (PPS-RTC = '00' OR '03' OR '10' OR
076800                   '12' OR '14')
076900        MOVE 'Y' TO OUTLIER-RECON-FLAG
077000        MOVE PPS-DATA TO HLD-PPS-DATA
077100        PERFORM 0200-MAINLINE-CONTROL THRU 0200-EXIT
077200        MOVE HLD-PPS-DATA TO PPS-DATA.
077300
077400     IF  PPS-RTC < 50
077500         IF  P-NEW-WAIVER-STATE
077600             MOVE 53 TO PPS-RTC
077700             MOVE ALL '0' TO PPS-OPER-HSP-PART
077800                             PPS-OPER-FSP-PART
077900                             PPS-OPER-OUTLIER-PART
078000                             PPS-OUTLIER-DAYS
078100                             PPS-REG-DAYS-USED
078200                             PPS-LTR-DAYS-USED
078300                             PPS-TOTAL-PAYMENT
078400                             WK-HAC-TOTAL-PAYMENT
078500                             PPS-OPER-DSH-ADJ
078600                             PPS-OPER-IME-ADJ
078700                             H-DSCHG-FRCTN
078800                             H-DRG-WT-FRCTN
078900                             HOLD-ADDITIONAL-VARIABLES
079000                             HOLD-CAPITAL-VARIABLES
079100                             HOLD-CAPITAL2-VARIABLES
079200                             HOLD-OTHER-VARIABLES
079300                             HOLD-PC-OTH-VARIABLES
079400                             H-ADDITIONAL-PAY-INFO-DATA
079500                             H-ADDITIONAL-PAY-INFO-DATA2.
079600     GOBACK.
079700
079800 0200-MAINLINE-CONTROL.
079900
080000     MOVE 'N' TO HMO-TAG.
080100
080200     IF PPS-PC-HMO-FLAG = 'Y' OR
080300               HMO-FLAG = 'Y'
080400        MOVE 'Y' TO HMO-TAG.
080500
080600     MOVE ALL '0' TO PPS-DATA
080700                     H-OPER-DSH-SCH
080800                     H-OPER-DSH-RRC
080900                     HOLD-PPS-COMPONENTS
081000                     HOLD-PPS-COMPONENTS
081100                     HOLD-ADDITIONAL-VARIABLES
081200                     HOLD-CAPITAL-VARIABLES
081300                     HOLD-CAPITAL2-VARIABLES
081400                     HOLD-OTHER-VARIABLES
081500                     HOLD-PC-OTH-VARIABLES
081600                     H-ADDITIONAL-PAY-INFO-DATA
081700                     H-ADDITIONAL-PAY-INFO-DATA2
081800                     H-EHR-SUBSAV-QUANT
081900                     H-EHR-SUBSAV-LV
082000                     H-EHR-SUBSAV-QUANT-INCLV
082100                     H-EHR-RESTORE-FULL-QUANT
082200                     H-OPER-BILL-STDZ-COSTS
082300                     H-CAPI-BILL-STDZ-COSTS
082400                     H-OPER-STDZ-COST-OUTLIER
082500                     H-CAPI-STDZ-COST-OUTLIER
082600                     H-OPER-STDZ-DOLLAR-THRESHOLD
082700                     H-CAPI-STDZ-DOLLAR-THRESHOLD
082800                     WK-LOW-VOL-ADDON
082900                     WK-HAC-AMOUNT
083000                     WK-HAC-TOTAL-PAYMENT.
083100
083200     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
083300        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
083400
083500     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
083600        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
083700
083800     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
083900        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
084000
084100     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
084200        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
084300
084400     IF P-HOSP-HRR-ADJUSTMT     NOT NUMERIC
084500        MOVE 0 TO P-HOSP-HRR-ADJUSTMT.
084600
084700     IF P-VAL-BASED-PURCH-ADJUST NOT NUMERIC
084800        MOVE 0 TO P-VAL-BASED-PURCH-ADJUST.
084900
085000     IF P-MODEL1-BUNDLE-DISPRCNT NOT NUMERIC
085100        MOVE 0 TO P-MODEL1-BUNDLE-DISPRCNT.
085200
085300     PERFORM 1000-EDIT-THE-BILL-INFO.
085400
085500     IF  PPS-RTC = 00
085600         PERFORM 2000-ASSEMBLE-PPS-VARIABLES THRU 2000-EXIT.
085700
085800     IF  PPS-RTC = 00
085900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
086000
086100     IF OUTLIER-RECON-FLAG = 'Y'
086200        MOVE 'N' TO OUTLIER-RECON-FLAG
086300        GO TO 0200-EXIT.
086400
086500     IF PPS-RTC = 00
086600        IF H-PERDIEM-DAYS = H-ALOS OR
086700           H-PERDIEM-DAYS > H-ALOS
086800           MOVE 14 TO PPS-RTC.
086900
087000     IF PPS-RTC = 02
087100        IF H-PERDIEM-DAYS = H-ALOS OR
087200           H-PERDIEM-DAYS > H-ALOS
087300           MOVE 16 TO PPS-RTC.
087400
087500 0200-EXIT.   EXIT.
087600
087700 1000-EDIT-THE-BILL-INFO.
087800
087900     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
088000     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
088100
088200**   IF  PPS-RTC = 00
088300*        IF  P-NEW-WAIVER-STATE
088400*            MOVE 53 TO PPS-RTC.
088500
088600     IF  PPS-RTC = 00
088700         IF   HLDDRG-VALID = 'I'
088800             MOVE 54 TO PPS-RTC.
088900
089000     IF  PPS-RTC = 00
089100            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
089200                 (B-DISCHARGE-DATE < W-CBSA-EFF-DATE))
089300                MOVE 55 TO PPS-RTC.
089400
089500     IF  PPS-RTC = 00
089600         IF P-NEW-TERMINATION-DATE > 00000000
089700            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
089800                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
089900                  MOVE 55 TO PPS-RTC.
090000
090100     IF  PPS-RTC = 00
090200         IF  B-LOS NOT NUMERIC
090300             MOVE 56 TO PPS-RTC
090400         ELSE
090500         IF  B-LOS = 0
090600             IF B-REVIEW-CODE NOT = 00 AND
090700                              NOT = 03 AND
090800                              NOT = 06 AND
090900                              NOT = 07 AND
091000                              NOT = 09 AND
091100                              NOT = 11
091200             MOVE 56 TO PPS-RTC.
091300
091400     IF  PPS-RTC = 00
091500         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
091600             MOVE 61 TO PPS-RTC
091700         ELSE
091800             MOVE B-LTR-DAYS TO H-LTR-DAYS.
091900
092000     IF  PPS-RTC = 00
092100         IF  B-COVERED-DAYS NOT NUMERIC
092200             MOVE 62 TO PPS-RTC
092300         ELSE
092400         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
092500             MOVE 62 TO PPS-RTC
092600         ELSE
092700             MOVE B-COVERED-DAYS TO H-COV-DAYS.
092800
092900     IF  PPS-RTC = 00
093000         IF  H-LTR-DAYS  > H-COV-DAYS
093100             MOVE 62 TO PPS-RTC
093200         ELSE
093300             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
093400
093500     IF  PPS-RTC = 00
093600         IF  NOT VALID-REVIEW-CODE
093700             MOVE 57 TO PPS-RTC.
093800
093900     IF  PPS-RTC = 00
094000         IF  B-CHARGES-CLAIMED NOT NUMERIC
094100             MOVE 58 TO PPS-RTC.
094200
094300     IF PPS-RTC = 00
094400           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
094500                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'B' AND
094600                                            NOT = 'C'
094700                 MOVE 65 TO PPS-RTC.
094800
094900***  MDH PROVISION ENDS 9/30/2018
095000***  CODE COMMENTED OUT IN ORDER TO EXTEND EXPIRING PROVISON
095100
095200     IF PPS-RTC = 00 AND
095300        B-DISCHARGE-DATE > 20220930 AND
095400        P-N-INVALID-PROV-TYPES
095500                 MOVE 52 TO PPS-RTC.
095600
095700 2000-ASSEMBLE-PPS-VARIABLES.
095800***  GET THE PROVIDER SPECIFIC VARIABLES.
095900
096000     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
096100     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
096200
096300     IF (P-NEW-STATE = 02 OR 12)
096400        MOVE P-NEW-COLA TO H-OPER-COLA
096500     ELSE
096600        MOVE 1.000 TO H-OPER-COLA.
096700
096800***************************************************************
096900***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
097000
097100     PERFORM 2600-GET-DRG-WEIGHT THRU 2600-EXIT.
097200
097300     PERFORM 2700-COVID-DRG-ADJ THRU 2700-EXIT.
097400
097500     PERFORM 4410-UNCOMP-CARE-CODE-RTN THRU 4410-EXIT.
097600
097700     MOVE P-NEW-STATE            TO MES-PPS-STATE.
097800
097900*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
098000** USING THE STATE FACTORS TO ALTER THE WAGE INDEX WAS STOPPED*
098100** FOR FY 2011
098200***************************************************************
098300*    PERFORM 4200-SSRFBN-CODE-RTN THRU 4200-EXIT.
098400*****YEARCHANGE 2011.0 ** NOT USED 2012 *******************
098500***************************************************************
098600***  GET THE WAGE-INDEX
098700
098800     MOVE W-CBSA-INDEX-RECORD TO H-WAGE-INDEX.
098900     MOVE P-NEW-STATE            TO MES-PPS-STATE.
099000
099100***************************************************************
099200* GET THE LABOR, NON-LABOR STANDARD RATES FOR CLAIMS          *
099300* WITH DISCHARGE DATES PRIOR TO 01/01/2016                    *
099400***************************************************************
099500
099600     PERFORM 2050-RATES-TB THRU 2050-EXIT.
099700
099800     IF P-NEW-GEO-LOC-MSA9 >= 9400 AND
099900        P-NEW-GEO-LOC-MSA9 <= 9900
100000        PERFORM 2100-MIDNIGHT-FACTORS THRU 2100-EXIT
100100     ELSE
100200        MOVE 1 TO HLD-MID-ADJ-FACT
100300        GO TO 2000-EXIT.
100400
100500 2000-EXIT.  EXIT.
100600
100700 2050-RATES-TB.
100800     MOVE 1 TO R2
100900     MOVE 1 TO R4.
101000
101100     IF LARGE-URBAN
101200         MOVE 1 TO R3
101300     ELSE
101400         MOVE 2 TO R3.
101500
101600     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
101700        (P-EHR-REDUC-IND = ' ')           AND
101800        (H-WAGE-INDEX > 01.0000))
101900        PERFORM 2300-GET-LAB-NONLAB-TB1-RATES
102000           THRU 2300-GET-LAB-NONLAB-TB1-EXIT
102100             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
102200
102300     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
102400        (P-EHR-REDUC-IND = ' ')               AND
102500         (H-WAGE-INDEX > 01.0000))
102600        PERFORM 2300-GET-LAB-NONLAB-TB2-RATES
102700           THRU 2300-GET-LAB-NONLAB-TB2-EXIT
102800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
102900
103000     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
103100        (P-EHR-REDUC-IND = ' ')            AND
103200         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
103300        PERFORM 2300-GET-LAB-NONLAB-TB3-RATES
103400           THRU 2300-GET-LAB-NONLAB-TB3-EXIT
103500             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
103600
103700     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
103800        (P-EHR-REDUC-IND = ' ')               AND
103900         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
104000        PERFORM 2300-GET-LAB-NONLAB-TB4-RATES
104100           THRU 2300-GET-LAB-NONLAB-TB4-EXIT
104200             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
104300
104400     IF ((P-NEW-CBSA-HOSP-QUAL-IND = '1') AND
104500        (P-EHR-REDUC-IND = 'Y')           AND
104600        (H-WAGE-INDEX > 01.0000))
104700        PERFORM 2300-GET-LAB-NONLAB-TB5-RATES
104800           THRU 2300-GET-LAB-NONLAB-TB5-EXIT
104900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
105000
105100     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
105200        (P-EHR-REDUC-IND = 'Y')               AND
105300         (H-WAGE-INDEX > 01.0000))
105400        PERFORM 2300-GET-LAB-NONLAB-TB6-RATES
105500           THRU 2300-GET-LAB-NONLAB-TB6-EXIT
105600             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
105700
105800     IF ((P-NEW-CBSA-HOSP-QUAL-IND  = '1') AND
105900        (P-EHR-REDUC-IND = 'Y')            AND
106000         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
106100        PERFORM 2300-GET-LAB-NONLAB-TB7-RATES
106200           THRU 2300-GET-LAB-NONLAB-TB7-EXIT
106300             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
106400
106500     IF ((P-NEW-CBSA-HOSP-QUAL-IND NOT = '1') AND
106600        (P-EHR-REDUC-IND = 'Y')               AND
106700         (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000))
106800        PERFORM 2300-GET-LAB-NONLAB-TB8-RATES
106900           THRU 2300-GET-LAB-NONLAB-TB8-EXIT
107000             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
107100
107200***************************************************************
107300* GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL              *
107400***************************************************************
107500
107600     MOVE 0.00  TO H-OPER-HSP-PCT.
107700     MOVE 1.00  TO H-OPER-FSP-PCT.
107800
107900***************************************************************
108000*  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL   *
108100***************************************************************
108200
108300      MOVE 1.00 TO H-NAT-PCT.
108400      MOVE 0.00 TO H-REG-PCT.
108500
108600     IF  P-N-SCH-REBASED-FY90 OR
108700         P-N-EACH OR
108800         P-N-MDH-REBASED-FY90
108900         MOVE 1.00 TO H-OPER-HSP-PCT.
109000
109100 2050-EXIT.   EXIT.
109200
109300***************************************************************
109400*  APPLY THE TWO MIDNIGHT POLICY ADJUSTMENT FACTORS           *
109500***************************************************************
109600 2100-MIDNIGHT-FACTORS.
109700
109800     INITIALIZE HLD-MID-ADJ-FACT.
109900
110000     SET MID-IDX TO 1.
110100
110200     SEARCH MID-TAB VARYING MID-IDX
110300     WHEN WK-MID-MSAX(MID-IDX) = P-NEW-GEO-LOC-MSA9
110400       MOVE MID-DATA-TAB(MID-IDX) TO HLD-MID-DATA.
110500
110600 2100-EXIT.   EXIT.
110700
110800***************************************************************
110900* GET THE LABOR, NON-LABOR STANDARD RATES FOR CLAIMS          *
111000* WITH DISCHARGE DATES BEFORE 01/01/2016                      *
111100***************************************************************
111200 2300-GET-LAB-NONLAB-TB1-RATES.
111300
111400     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
111500         MOVE TB1-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
111600         MOVE TB1-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
111700         MOVE TB1-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
111800         MOVE TB1-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
111900
112000 2300-GET-LAB-NONLAB-TB1-EXIT.   EXIT.
112100
112200 2300-GET-LAB-NONLAB-TB2-RATES.
112300
112400     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
112500         MOVE TB2-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
112600         MOVE TB2-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
112700         MOVE TB2-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
112800         MOVE TB2-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
112900
113000 2300-GET-LAB-NONLAB-TB2-EXIT.   EXIT.
113100
113200 2300-GET-LAB-NONLAB-TB3-RATES.
113300
113400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
113500         MOVE TB3-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
113600         MOVE TB3-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
113700         MOVE TB3-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
113800         MOVE TB3-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
113900
114000 2300-GET-LAB-NONLAB-TB3-EXIT.   EXIT.
114100
114200 2300-GET-LAB-NONLAB-TB4-RATES.
114300
114400     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
114500         MOVE TB4-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
114600         MOVE TB4-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
114700         MOVE TB4-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
114800         MOVE TB4-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
114900
115000 2300-GET-LAB-NONLAB-TB4-EXIT.   EXIT.
115100
115200 2300-GET-LAB-NONLAB-TB5-RATES.
115300
115400     IF  B-DISCHARGE-DATE NOT < TB1-RATE-EFF-DATE (R1)
115500         MOVE TB5-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
115600         MOVE TB5-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
115700         MOVE TB5-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
115800         MOVE TB5-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
115900
116000 2300-GET-LAB-NONLAB-TB5-EXIT.   EXIT.
116100
116200 2300-GET-LAB-NONLAB-TB6-RATES.
116300
116400     IF  B-DISCHARGE-DATE NOT < TB2-RATE-EFF-DATE (R1)
116500         MOVE TB6-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
116600         MOVE TB6-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
116700         MOVE TB6-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
116800         MOVE TB6-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
116900
117000 2300-GET-LAB-NONLAB-TB6-EXIT.   EXIT.
117100
117200 2300-GET-LAB-NONLAB-TB7-RATES.
117300
117400     IF  B-DISCHARGE-DATE NOT < TB3-RATE-EFF-DATE (R1)
117500         MOVE TB7-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
117600         MOVE TB7-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
117700         MOVE TB7-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
117800         MOVE TB7-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
117900
118000 2300-GET-LAB-NONLAB-TB7-EXIT.   EXIT.
118100
118200 2300-GET-LAB-NONLAB-TB8-RATES.
118300
118400     IF  B-DISCHARGE-DATE NOT < TB4-RATE-EFF-DATE (R1)
118500         MOVE TB8-REG-LABOR (R1 R2 R3) TO H-REG-LABOR
118600         MOVE TB8-REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
118700         MOVE TB8-REG-LABOR (R1 R4 R3) TO H-NAT-LABOR
118800         MOVE TB8-REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
118900
119000 2300-GET-LAB-NONLAB-TB8-EXIT.   EXIT.
119100
119200***************************************************************
119300* OBTAIN THE APPLICABLE DRG WEIGHTS                           *
119400***************************************************************
119500 2600-GET-DRG-WEIGHT.
119600
119700     IF  B-DISCHARGE-DATE NOT < WK-DRGX-EFF-DATE
119800     SET DRG-IDX TO 1
119900     SEARCH DRG-TAB VARYING DRG-IDX
120000         AT END
120100           MOVE ' NO DRG CODE    FOUND' TO HLDDRG-DESC
120200           MOVE 'I' TO  HLDDRG-VALID
120300           MOVE 0 TO HLDDRG-WEIGHT
120400           MOVE 54 TO PPS-RTC
120500           GO TO 2600-EXIT
120600       WHEN WK-DRG-DRGX(DRG-IDX) = B-DRG
120700         MOVE DRG-DATA-TAB(DRG-IDX) TO HLDDRG-DATA.
120800
120900     MOVE HLDDRG-DATA TO WK-HLDDRG-DATA2.
121000     MOVE  HLDDRG-DRGX         TO HLDDRG-DRGX2.
121100     MOVE  HLDDRG-WEIGHT       TO HLDDRG-WEIGHT2
121200                                  H-DRG-WT.
121300     MOVE  HLDDRG-GMALOS       TO HLDDRG-GMALOS2
121400                                  H-ALOS.
121500     MOVE  HLDDRG-LOW          TO HLDDRG-LOW2.
121600     MOVE  HLDDRG-ARITH-ALOS   TO HLDDRG-ARITH-ALOS2
121700                                  H-ARITH-ALOS.
121800     MOVE  HLDDRG-PAC          TO HLDDRG-PAC2.
121900     MOVE  HLDDRG-SPPAC        TO HLDDRG-SPPAC2.
122000     MOVE  HLDDRG-DESC         TO HLDDRG-DESC2.
122100     MOVE  'V'                 TO HLDDRG-VALID.
122200     MOVE ZEROES               TO H-DAYS-CUTOFF.
122300
122400 2600-EXIT.   EXIT.
122500
122600***************************************************************
122700 2700-COVID-DRG-ADJ.
122800***************************************************************
122900* ADJUSTMENT TO DRG WEIGHT PER COVID-19 DIAGNOSIS
123000*   + 20% INCREASE TO OPERATING DRG PAYMENTS
123100*----------------------------------------------------------------*
123200
123300     MOVE 1 TO IDX-COVID.
123400     MOVE 1.0 TO COVID-ADJ.
123500
123600     PERFORM 10000-COVID19-FLAG THRU 10000-EXIT
123700      VARYING IDX-COVID FROM 1 BY 1 UNTIL IDX-COVID > 25.
123800
123900     IF (B-DISCHARGE-DATE > 20200126 AND
124000        B-DISCHARGE-DATE < 20200401)
124100        IF DIAG-COVID1-FLAG = 'Y'
124200           MOVE 1.2 TO COVID-ADJ.
124300
124400     IF B-DISCHARGE-DATE > 20200331
124500        IF DIAG-COVID2-FLAG = 'Y'
124600           MOVE 1.2 TO COVID-ADJ.
124700
124800 2700-EXIT.   EXIT.
124900***************************************************************
125000*
125100 3000-CALC-PAYMENT.
125200***************************************************************
125300
125400     PERFORM 3100-CALC-STAY-UTILIZATION.
125500     PERFORM 3300-CALC-OPER-FSP-AMT.
125600     PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT.
125700
125800***********************************************************
125900***  OPERATING IME CALCULATION
126000
126100     COMPUTE H-OPER-IME-TEACH ROUNDED =
126200            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
126300
126400***********************************************************
126500
126600     MOVE 00                 TO  PPS-RTC.
126700     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
126800     MOVE H-ALOS             TO  PPS-AVG-LOS.
126900     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
127000
127100     MOVE B-LOS TO H-PERDIEM-DAYS.
127200     IF H-PERDIEM-DAYS < 1
127300         MOVE 1 TO H-PERDIEM-DAYS.
127400     ADD 1 TO H-PERDIEM-DAYS.
127500
127600     MOVE 1 TO H-DSCHG-FRCTN.
127700
127800     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
127900
128000     IF (PAY-PERDIEM-DAYS  OR
128100         PAY-XFER-NO-COST) OR
128200        (PAY-XFER-SPEC-DRG AND
128300         D-DRG-POSTACUTE-PERDIEM)
128400       IF H-ALOS > 0
128500         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
128600         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
128700         IF H-DSCHG-FRCTN > 1
128800              MOVE 1 TO H-DSCHG-FRCTN
128900              MOVE 1 TO H-TRANSFER-ADJ
129000         ELSE
129100              COMPUTE H-DRG-WT-FRCTN ROUNDED =
129200                  H-TRANSFER-ADJ * H-DRG-WT
129300         END-IF
129400        END-IF
129500     END-IF.
129600
129700
129800     IF (PAY-XFER-SPEC-DRG AND
129900         D-DRG-POSTACUTE-50-50) AND
130000         H-ALOS > 0
130100         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
130200         COMPUTE H-DSCHG-FRCTN  ROUNDED =
130300                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
130400         IF H-DSCHG-FRCTN > 1
130500              MOVE 1 TO H-DSCHG-FRCTN
130600              MOVE 1 TO H-TRANSFER-ADJ
130700         ELSE
130800              COMPUTE H-DRG-WT-FRCTN ROUNDED =
130900            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
131000
131100
131200***********************************************************
131300***  CAPITAL DSH CALCULATION
131400
131500     MOVE 0 TO H-CAPI-DSH.
131600
131700     IF P-NEW-BED-SIZE NOT NUMERIC
131800         MOVE 0 TO P-NEW-BED-SIZE.
131900
132000     IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
132100         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
132200                  (.2025 * (P-NEW-SSI-RATIO
132300                          + P-NEW-MEDICAID-RATIO)) - 1.
132400
132500***********************************************************
132600***  CAPITAL IME TEACH CALCULATION
132700
132800     MOVE 0 TO H-WK-CAPI-IME-TEACH.
132900
133000     IF P-NEW-CAPI-IME NUMERIC
133100        IF P-NEW-CAPI-IME > 1.5000
133200           MOVE 1.5000 TO P-NEW-CAPI-IME.
133300
133400*****YEARCHANGE 2009.5 ****************************************
133500***
133600***  PER POLICY, WE REMOVED THE .5 MULTIPLER
133700***
133800***********************************************************
133900     IF P-NEW-CAPI-IME NUMERIC
134000        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
134100         ((2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1).
134200
134300*****YEARCHANGE 2009.5 ****************************************
134400***********************************************************
134500     MOVE 0.00 TO H-DAYOUT-PCT.
134600     MOVE 0.80 TO H-CSTOUT-PCT.
134700
134800*****************************************************************
134900**
135000** BURN DRGS FOR FY14 ARE 927, 928, 929, 933, 934 AND 935.
135100**
135200*****************************************************************
135300
135400     IF  B-DRG = 927 OR 928 OR 929 OR 933 OR 934 OR 935
135500             MOVE 0.90 TO H-CSTOUT-PCT.
135600
135700*****YEARCHANGE 2018.0 *******************************************
135800* NATIONAL PERCENTAGE                                            *
135900******************************************************************
136000
136100       MOVE 0.6830 TO H-LABOR-PCT.
136200       MOVE 0.3170 TO H-NONLABOR-PCT.
136300
136400     IF (H-WAGE-INDEX < 01.0000 OR H-WAGE-INDEX = 01.0000)
136500       MOVE 0.6200 TO H-LABOR-PCT
136600       MOVE 0.3800 TO H-NONLABOR-PCT.
136700
136800     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
136900             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
137000     ELSE
137100             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
137200
137300     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
137400             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
137500     ELSE
137600             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
137700
137800***********************************************************
137900*****YEARCHANGE 2010.0 ************************************
138000***  CAPITAL PAYMENT METHOD B - YEARCHNG
138100***  CAPITAL PAYMENT METHOD B
138200
138300     IF W-CBSA-SIZE = 'L'
138400        MOVE 1.00 TO H-CAPI-LARG-URBAN
138500     ELSE
138600        MOVE 1.00 TO H-CAPI-LARG-URBAN.
138700
138800     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
138900
139000*****YEARCHANGE 2018.0 ************************************
139100
139200     COMPUTE H-FEDERAL-RATE ROUNDED =
139300                              (0462.33 * H-CAPI-GAF).
139400
139500*****YEARCHANGE 2015.1 ************************************
139600
139700     COMPUTE H-CAPI-COLA ROUNDED =
139800                     (.3152 * (H-OPER-COLA - 1) + 1).
139900
140000     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
140100
140200***********************************************************
140300* CAPITAL FSP CALCULATION                                 *
140400***********************************************************
140500
140600     COMPUTE H-CAPI-FSP-PART ROUNDED =
140700                               H-DRG-WT       *
140800                               H-CAPI-FED-RATE *
140900                               H-CAPI-COLA *
141000                               H-CAPI-LARG-URBAN *
141100                               HLD-MID-ADJ-FACT.
141200
141300***********************************************************
141400***  CAPITAL PAYMENT METHOD A
141500***  CAPITAL PAYMENT METHOD A
141600
141700     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
141800        MOVE 1.00 TO H-CAPI-SCH
141900     ELSE
142000        MOVE 0.85 TO H-CAPI-SCH.
142100
142200***********************************************************
142300***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
142400***********  CAPITAL OLD-HOLD-HARMLESS CALCULATION ***********
142500
142600     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
142700                    (P-NEW-CAPI-OLD-HARM-RATE *
142800                    H-CAPI-SCH).
142900
143000***********************************************************
143100        IF PAY-PERDIEM-DAYS
143200            IF  H-PERDIEM-DAYS < H-ALOS
143300                IF  NOT (B-DRG = 789)
143400                    PERFORM 3500-CALC-PERDIEM-AMT
143500                    MOVE 03 TO PPS-RTC.
143600
143700        IF PAY-XFER-SPEC-DRG
143800            IF  H-PERDIEM-DAYS < H-ALOS
143900                IF  NOT (B-DRG = 789)
144000                    PERFORM 3550-CALC-PERDIEM-AMT.
144100
144200        IF  PAY-XFER-NO-COST
144300            MOVE 00 TO PPS-RTC
144400            IF H-PERDIEM-DAYS < H-ALOS
144500               IF  NOT (B-DRG = 789)
144600                   PERFORM 3500-CALC-PERDIEM-AMT
144700                   MOVE 06 TO PPS-RTC.
144800
144900     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
145000
145100     PERFORM 6000-CALC-READMIS-REDU THRU 6000-EXIT.
145200
145300     IF PPS-RTC = 65 OR 67 OR 68
145400               GO TO 3000-CONTINUE.
145500
145600     PERFORM 7000-CALC-VALUE-BASED-PURCH THRU 7000-EXIT.
145700
145800     IF PPS-RTC = 65 OR 67 OR 68
145900               GO TO 3000-CONTINUE.
146000
146100     PERFORM 8000-CALC-BUNDLE-REDU  THRU 8000-EXIT.
146200
146300     IF PPS-RTC = 65 OR 67 OR 68
146400               GO TO 3000-CONTINUE.
146500
146600     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
146700
146800     IF OUTLIER-RECON-FLAG = 'Y' GO TO 3000-EXIT.
146900
147000     IF PPS-RTC = 65 OR 67 OR 68
147100               GO TO 3000-CONTINUE.
147200
147300        IF PAY-XFER-SPEC-DRG
147400            IF  H-PERDIEM-DAYS < H-ALOS
147500                IF  NOT (B-DRG = 789)
147600                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
147700
147800
147900        IF  PAY-PERDIEM-DAYS
148000            IF  H-OPER-OUTCST-PART > 0
148100                MOVE H-OPER-OUTCST-PART TO
148200                     H-OPER-OUTLIER-PART
148300                MOVE 05 TO PPS-RTC
148400            ELSE
148500            IF  PPS-RTC NOT = 03
148600                MOVE 00 TO PPS-RTC
148700                MOVE 0  TO H-OPER-OUTLIER-PART.
148800
148900        IF  PAY-PERDIEM-DAYS
149000            IF  H-CAPI-OUTCST-PART > 0
149100                MOVE H-CAPI-OUTCST-PART TO
149200                     H-CAPI-OUTLIER-PART
149300                MOVE 05 TO PPS-RTC
149400            ELSE
149500            IF  PPS-RTC NOT = 03
149600                MOVE 0  TO H-CAPI-OUTLIER-PART.
149700
149800
149900     IF P-N-SCH-REBASED-FY90 OR
150000        P-N-EACH OR
150100        P-N-MDH-REBASED-FY90
150200         PERFORM 3450-CALC-ADDITIONAL-HSP THRU 3450-EXIT.
150300
150400 3000-CONTINUE.
150500
150600***********************************************************
150700***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
150800***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
150900
151000     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
151100
151200***********************************************************
151300
151400     IF  PPS-RTC = 67
151500         MOVE H-OPER-DOLLAR-THRESHOLD TO
151600              WK-H-OPER-DOLLAR-THRESHOLD.
151700
151800     IF  PPS-RTC < 50
151900         PERFORM 3800-CALC-TOT-AMT THRU 3800-EXIT.
152000
152100     IF  PPS-RTC < 50
152200         NEXT SENTENCE
152300     ELSE
152400         MOVE ALL '0' TO PPS-OPER-HSP-PART
152500                         PPS-OPER-FSP-PART
152600                         PPS-OPER-OUTLIER-PART
152700                         PPS-OUTLIER-DAYS
152800                         PPS-REG-DAYS-USED
152900                         PPS-LTR-DAYS-USED
153000                         PPS-TOTAL-PAYMENT
153100                         WK-HAC-TOTAL-PAYMENT
153200                         PPS-OPER-DSH-ADJ
153300                         PPS-OPER-IME-ADJ
153400                         H-DSCHG-FRCTN
153500                         H-DRG-WT-FRCTN
153600                         HOLD-ADDITIONAL-VARIABLES
153700                         HOLD-CAPITAL-VARIABLES
153800                         HOLD-CAPITAL2-VARIABLES
153900                         HOLD-OTHER-VARIABLES
154000                         HOLD-PC-OTH-VARIABLES
154100                        H-ADDITIONAL-PAY-INFO-DATA
154200                        H-ADDITIONAL-PAY-INFO-DATA2.
154300
154400     IF  PPS-RTC = 67
154500         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
154600                 H-OPER-DOLLAR-THRESHOLD.
154700
154800 3000-EXIT.  EXIT.
154900
155000 3100-CALC-STAY-UTILIZATION.
155100
155200     MOVE 0 TO PPS-REG-DAYS-USED.
155300     MOVE 0 TO PPS-LTR-DAYS-USED.
155400
155500     IF H-REG-DAYS > 0
155600        IF H-REG-DAYS > B-LOS
155700           MOVE B-LOS TO PPS-REG-DAYS-USED
155800        ELSE
155900           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
156000     ELSE
156100        IF H-LTR-DAYS > B-LOS
156200           MOVE B-LOS TO PPS-LTR-DAYS-USED
156300        ELSE
156400           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
156500
156600
156700
156800 3300-CALC-OPER-FSP-AMT.
156900***********************************************************
157000*  OPERATING FSP CALCULATION                              *
157100***********************************************************
157200
157300     COMPUTE H-OPER-FSP-PART ROUNDED =
157400       ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
157500        H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT *
157600        HLD-MID-ADJ-FACT * COVID-ADJ)
157700           ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
157800
157900 3500-CALC-PERDIEM-AMT.
158000***********************************************************
158100***  REVIEW CODE = 03 OR 06
158200***  OPERATING PERDIEM-AMT CALCULATION
158300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
158400
158500        COMPUTE H-OPER-FSP-PART ROUNDED =
158600        H-OPER-FSP-PART * H-TRANSFER-ADJ
158700        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
158800
158900***********************************************************
159000***********************************************************
159100***  REVIEW CODE = 03 OR 06
159200***  CAPITAL   PERDIEM-AMT CALCULATION
159300***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
159400
159500        COMPUTE H-CAPI-FSP-PART ROUNDED =
159600        H-CAPI-FSP-PART * H-TRANSFER-ADJ
159700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
159800
159900***********************************************************
160000***  REVIEW CODE = 03 OR 06
160100***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
160200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
160300
160400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
160500        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
160600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
160700
160800 3550-CALC-PERDIEM-AMT.
160900***********************************************************
161000***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
161100***  OPERATING PERDIEM-AMT CALCULATION
161200***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
161300
161400     IF (D-DRG-POSTACUTE-50-50)
161500        MOVE 10 TO PPS-RTC
161600        COMPUTE H-OPER-FSP-PART ROUNDED =
161700        H-OPER-FSP-PART * H-DSCHG-FRCTN
161800        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
161900
162000     IF (D-DRG-POSTACUTE-PERDIEM)
162100        MOVE 12 TO PPS-RTC
162200        COMPUTE H-OPER-FSP-PART ROUNDED =
162300        H-OPER-FSP-PART *  H-TRANSFER-ADJ
162400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
162500
162600***********************************************************
162700***  CAPITAL PERDIEM-AMT CALCULATION
162800***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
162900
163000     IF (D-DRG-POSTACUTE-50-50)
163100        MOVE 10 TO PPS-RTC
163200        COMPUTE H-CAPI-FSP-PART ROUNDED =
163300        H-CAPI-FSP-PART * H-DSCHG-FRCTN
163400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
163500
163600     IF (D-DRG-POSTACUTE-PERDIEM)
163700        MOVE 12 TO PPS-RTC
163800        COMPUTE H-CAPI-FSP-PART ROUNDED =
163900        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
164000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
164100
164200***********************************************************
164300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
164400***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
164500
164600     IF (D-DRG-POSTACUTE-50-50)
164700        MOVE 10 TO PPS-RTC
164800        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
164900        H-CAPI-OLD-HARMLESS * H-DSCHG-FRCTN
165000        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
165100
165200     IF (D-DRG-POSTACUTE-PERDIEM)
165300        MOVE 12 TO PPS-RTC
165400        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
165500        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
165600        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
165700
165800 3560-CHECK-RTN-CODE.
165900
166000     IF (D-DRG-POSTACUTE-50-50)
166100        MOVE 10 TO PPS-RTC.
166200     IF (D-DRG-POSTACUTE-PERDIEM)
166300        MOVE 12 TO PPS-RTC.
166400
166500 3560-EXIT.    EXIT.
166600
166700***********************************************************
166800 3600-CALC-OUTLIER.
166900***********************************************************
167000*---------------------------------------------------------*
167100* (YEARCHANGE 2016.0)
167200* COST OUTLIER OPERATING AND CAPITAL CALCULATION
167300*---------------------------------------------------------*
167400
167500     IF OUTLIER-RECON-FLAG = 'Y'
167600        COMPUTE H-OPER-CSTCHG-RATIO ROUNDED =
167700               (H-OPER-CSTCHG-RATIO + .2).
167800
167900     IF H-CAPI-CSTCHG-RATIO > 0 OR
168000        H-OPER-CSTCHG-RATIO > 0
168100        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
168200                H-OPER-CSTCHG-RATIO /
168300               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
168400        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
168500                H-CAPI-CSTCHG-RATIO /
168600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
168700     ELSE
168800        MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
168900                  H-CAPI-SHARE-DOLL-THRESHOLD.
169000
169100*-----------------------------*
169200* (YEARCHANGE 2020.0)         *
169300* OUTLIER THRESHOLD AMOUNTS   *
169400*-----------------------------*
169500
169600     MOVE 26552.00 TO H-CST-THRESH.
169700
169800     IF (B-REVIEW-CODE = '03') AND
169900         H-PERDIEM-DAYS < H-ALOS
170000        COMPUTE H-CST-THRESH ROUNDED =
170100                      (H-CST-THRESH * H-TRANSFER-ADJ)
170200                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
170300
170400     IF ((B-REVIEW-CODE = '09') AND
170500         (H-PERDIEM-DAYS < H-ALOS))
170600         IF (D-DRG-POSTACUTE-PERDIEM)
170700            COMPUTE H-CST-THRESH ROUNDED =
170800                      (H-CST-THRESH * H-TRANSFER-ADJ)
170900                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
171000
171100     IF ((B-REVIEW-CODE = '09') AND
171200         (H-PERDIEM-DAYS < H-ALOS))
171300         IF (D-DRG-POSTACUTE-50-50)
171400           COMPUTE H-CST-THRESH ROUNDED =
171500          H-CST-THRESH * H-DSCHG-FRCTN
171600                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
171700
171800     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
171900        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
172000         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
172100          H-OPER-SHARE-DOLL-THRESHOLD.
172200
172300***********************************************************
172400
172500     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
172600          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
172700          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
172800
172900***********************************************************
173000******NOW INCLUDES UNCOMPENSATED CARE**********************
173100
173200     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
173300         ((H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH))
173400                       +
173500           ((H-OPER-FSP-PART * H-OPER-DSH) * .25))
173600                       +
173700             H-OPER-DOLLAR-THRESHOLD
173800                       +
173900                WK-UNCOMP-CARE-AMOUNT
174000                       +
174100                 H-NEW-TECH-PAY-ADD-ON.
174200
174300     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
174400      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
174500                       +
174600             H-CAPI-DOLLAR-THRESHOLD.
174700
174800     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
174900         MOVE 0 TO H-CAPI-COST-OUTLIER.
175000
175100
175200***********************************************************
175300***  OPERATING COST CALCULATION
175400
175500     COMPUTE H-OPER-BILL-COSTS ROUNDED =
175600         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
175700         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
175800
175900
176000     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
176100         COMPUTE H-OPER-OUTCST-PART ROUNDED =
176200         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
176300                         H-OPER-COST-OUTLIER).
176400
176500     IF PAY-WITHOUT-COST OR
176600        PAY-XFER-NO-COST OR
176700        PAY-XFER-SPEC-DRG-NO-COST
176800         MOVE 0 TO H-OPER-OUTCST-PART.
176900
177000***********************************************************
177100***  CAPITAL COST CALCULATION
177200
177300     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
177400             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
177500         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
177600
177700     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
177800         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
177900         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
178000                         H-CAPI-COST-OUTLIER).
178100
178200***********************************************************
178300***  'A' NOT VALID FY 2015 ON
178400
178500*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
178600*      COMPUTE H-CAPI-OUTCST-PART ROUNDED =
178700*             (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
178800
178900     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
179000        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
179100               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
179200
179300     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
179400        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
179500        MOVE 0 TO H-CAPI-OUTCST-PART
179600                  H-OPER-OUTCST-PART.
179700
179800     IF PAY-WITHOUT-COST OR
179900        PAY-XFER-NO-COST OR
180000        PAY-XFER-SPEC-DRG-NO-COST
180100         MOVE 0 TO H-CAPI-OUTCST-PART.
180200
180300***********************************************************
180400***  DETERMINES THE BILL TO BE COST  OUTLIER
180500
180600     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
180700         MOVE 0 TO H-CAPI-OUTDAY-PART
180800                   H-CAPI-OUTCST-PART.
180900
181000     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
181100                 MOVE H-OPER-OUTCST-PART TO
181200                      H-OPER-OUTLIER-PART
181300                 MOVE H-CAPI-OUTCST-PART TO
181400                      H-CAPI-OUTLIER-PART
181500                 MOVE 02 TO PPS-RTC.
181600
181700     IF OUTLIER-RECON-FLAG = 'Y'
181800        IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
181900           COMPUTE HLD-PPS-RTC = HLD-PPS-RTC + 30
182000           GO TO 3600-EXIT
182100        ELSE
182200           GO TO 3600-EXIT
182300     ELSE
182400        NEXT SENTENCE.
182500
182600
182700***********************************************************
182800***  DETERMINES IF COST OUTLIER
182900***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
183000***         RETURN CODE OF 02
183100
183200     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
183300
183400     IF PPS-RTC = 02
183500       IF H-CAPI-CSTCHG-RATIO > 0 OR
183600          H-OPER-CSTCHG-RATIO > 0
183700             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
183800                     (H-CAPI-COST-OUTLIER  +
183900                      H-OPER-COST-OUTLIER)
184000                             /
184100                    (H-CAPI-CSTCHG-RATIO  +
184200                     H-OPER-CSTCHG-RATIO)
184300             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD
184400       ELSE MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
184500
184600***********************************************************
184700***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
184800***         RETURN CODE OF 67
184900
185000     IF PPS-RTC = 02
185100         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
185200            PPS-PC-COT-FLAG = 'Y'
185300             MOVE 67 TO PPS-RTC.
185400***********************************************************
185500
185600***********************************************************
185700***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
185800***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
185900***********************************************************
186000*
186100***********************************************************
186200***  'A' NOT VALID FY 2015 ON
186300*
186400*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
186500*       COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
186600*               H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
186700*        ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
186800
186900     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
187000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
187100                H-CAPI-OUTLIER-PART.
187200
187300     IF P-NEW-CAPI-PPS-PAY-CODE = 'C' AND
187400        H-CAPI-PAYCDE-PCT1 > 0
187500        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
187600                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
187700         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART
187800     ELSE MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
187900
188000 3600-EXIT.   EXIT.
188100
188200***********************************************************
188300 3450-CALC-ADDITIONAL-HSP.
188400***********************************************************
188500*---------------------------------------------------------*
188600* OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR SOLE COMMUNITY
188700* AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
188800* NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
188900*---------------------------------------------------------*
189000***  GET THE RBN UPDATING FACTOR
189100
189200*****YEARCHANGE 2019.0 ****************************************
189300     MOVE 0.997190 TO H-BUDG-NUTR190.
189400
189500*****YEARCHANGE 2020.0 ****************************************
189600     MOVE 0.996859 TO H-BUDG-NUTR200.
189700
189800
189900***  GET THE MARKET BASKET UPDATE FACTOR
190000*****YEARCHANGE 2019.0 ****************************************
190100        MOVE 1.01350 TO H-UPDATE-190.
190200
190300*****YEARCHANGE 2020.0 ****************************************
190400        MOVE 1.02600 TO H-UPDATE-200.
190500
190600*** APPLY APPROPRIATE MARKET BASKET UPDATE FACTOR PER PSF FLAGS
190700*****YEARCHANGE 2020.0 ****************************************
190800     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
190900        P-EHR-REDUC-IND = ' '
191000        MOVE 1.02600 TO H-UPDATE-200.
191100
191200*****YEARCHANGE 2020.0 ****************************************
191300     IF P-NEW-CBSA-HOSP-QUAL-IND = '1' AND
191400        P-EHR-REDUC-IND = 'Y'
191500        MOVE 1.00350 TO H-UPDATE-200.
191600
191700*****YEARCHANGE 2020.0 ****************************************
191800     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
191900        P-EHR-REDUC-IND = ' '
192000        MOVE 1.01850 TO H-UPDATE-200.
192100
192200*****YEARCHANGE 2020.0 ****************************************
192300     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1' AND
192400        P-EHR-REDUC-IND = 'Y'
192500        MOVE 0.99600 TO H-UPDATE-200.
192600
192700
192800********YEARCHANGE 2020.0 *************************************
192900
193000     COMPUTE H-UPDATE-FACTOR ROUNDED =
193100                       (H-UPDATE-190 *
193200                        H-UPDATE-200 *
193300                        H-BUDG-NUTR190 *
193400                        H-BUDG-NUTR200 *
193500                        HLD-MID-ADJ-FACT).
193600
193700     COMPUTE H-HSP-RATE ROUNDED =
193800         H-FAC-SPEC-RATE * H-UPDATE-FACTOR * H-DRG-WT * COVID-ADJ.
193900***************************************************************
194000*
194100*    IF P-NEW-CBSA-HOSP-QUAL-IND = '1'
194200*       COMPUTE H-HSP-RATE ROUNDED =
194300*        (H-FAC-SPEC-RATE * 1) * H-UPDATE-FACTOR
194400*    ELSE
194500*       COMPUTE H-HSP-RATE ROUNDED =
194600*        ((H-FAC-SPEC-RATE / 1.036) * 1.016) * H-UPDATE-FACTOR.
194700*
194800***************************************************************
194900********YEARCHANGE 2011.0 *************************************
195000***     OUTLIER OFFSETS NO LONGER USED IN HSP COMPARISON
195100***     WE NOW USE THE ACTUAL OPERATING OUTLIER PAYMEMT
195200***     IN THE HSP COMPARRISON
195300
195400********YEARCHANGE 2014.0 *XXXXXX******************************
195500*      THE HSP BUCKET FOR SCH                      ************
195600*      ADDED UNCOMPENSATED CARE TO COMPARRISON FOR 2014 *******
195700***************************************************************
195800     COMPUTE H-FSP-RATE ROUNDED =
195900        ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
196000         H-NAT-NONLABOR * H-OPER-COLA)) * H-DRG-WT-FRCTN *
196100         HLD-MID-ADJ-FACT * COVID-ADJ) *
196200             (1 + H-OPER-IME-TEACH + (H-OPER-DSH * .25))
196300                               +
196400                         H-OPER-OUTLIER-PART
196500                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
196600
196700****************************************************************
196800****         INCLUDE UNCOMPENSATED CARE PER CLAIM IN HSP
196900*****        CHOICE
197000
197100     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
197200           COMPUTE H-OPER-HSP-PART ROUNDED =
197300             (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT))
197400                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
197500     ELSE
197600         MOVE 0 TO H-OPER-HSP-PART.
197700
197800***************************************************************
197900***  YEARCHANGE TURNING MDH BACK ON ***************************
198000***************************************************************
198100***  GET THE MDH REBASE
198200
198300     IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
198400         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
198500           COMPUTE H-OPER-HSP-PART ROUNDED =
198600         (H-HSP-RATE - (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)) * .75
198700                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
198800
198900***************************************************************
199000***  TRANSITIONAL PAYMENT FOR FORMER MDHS                     *
199100***************************************************************
199200
199300***  HSP PAYMENT FOR CLAIMS BETWEEN 10/01/2016 - 09/30/2017
199400
199500*    IF  B-FORMER-MDH-PROVIDERS       AND
199600*       (B-DISCHARGE-DATE > 20160930  AND
199700*        B-DISCHARGE-DATE < 20171001)
199800*      IF  H-HSP-RATE > (H-FSP-RATE + WK-UNCOMP-CARE-AMOUNT)
199900*        COMPUTE H-OPER-HSP-PART ROUNDED =
200000*          ((H-HSP-RATE - (H-FSP-RATE +
200100*              WK-UNCOMP-CARE-AMOUNT))* 0.75)*(1 / 3)
200200*            ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
200300*      END-IF
200400*    END-IF.
200500
200600 3450-EXIT.   EXIT.
200700
200800***********************************************************
200900 3800-CALC-TOT-AMT.
201000***********************************************************
201100***  CALCULATE TOTALS FOR CAPITAL
201200
201300     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
201400
201500***********************************************************
201600***  'A' NOT VALID FY 2015 ON
201700*
201800*    IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
201900*       MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
202000*       MOVE 0.00 TO H-CAPI-HSP-PCT.
202100
202200     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
202300        MOVE 0    TO H-CAPI-OLD-HARMLESS
202400        MOVE 1.00 TO H-CAPI-FSP-PCT
202500        MOVE 0.00 TO H-CAPI-HSP-PCT.
202600
202700     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
202800        MOVE 0    TO H-CAPI-OLD-HARMLESS
202900        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
203000        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
203100
203200     COMPUTE H-CAPI-HSP ROUNDED =
203300         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
203400
203500     COMPUTE H-CAPI-FSP ROUNDED =
203600         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
203700
203800     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
203900
204000     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
204100
204200     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
204300             H-CAPI-FSP
204400              * H-CAPI-DSH.
204500
204600     COMPUTE H-CAPI-IME-ADJ ROUNDED =
204700          H-CAPI-FSP *
204800                 H-WK-CAPI-IME-TEACH.
204900
205000     COMPUTE H-CAPI-OUTLIER ROUNDED =
205100             1.00 * H-CAPI-OUTLIER-PART.
205200
205300     COMPUTE H-CAPI2-B-FSP ROUNDED =
205400             1.00 * H-CAPI2-B-FSP-PART.
205500
205600     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
205700             1.00 * H-CAPI2-B-OUTLIER-PART.
205800***********************************************************
205900***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
206000***        THIS ZEROES OUT ALL CAPITAL DATA
206100
206200     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
206300        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
206400***********************************************************
206500
206600***********************************************************
206700***  CALCULATE FINAL TOTALS FOR OPERATING
206800
206900     IF (H-CAPI-OUTLIER > 0 AND
207000         PPS-OPER-OUTLIER-PART = 0)
207100            COMPUTE PPS-OPER-OUTLIER-PART =
207200                    PPS-OPER-OUTLIER-PART + .01.
207300
207400***********************************************************
207500*LOW VOLUME CALCULATIONS
207600***********************************************************
207700*---------------------------------------------------------*
207800* (YEARCHANGE 2016.0)
207900* LOW VOLUME PAYMENT ADD-ON PERCENT
208000*---------------------------------------------------------*
208100
208200     MOVE ZERO TO PPS-OPER-DSH-ADJ.
208300************************************************
208400* FOR FY 2014 WE APPLY AN ADJUSTMENT OF 0.25 TO CALCULATE
208500* EMPERICAL DSH
208600************************************************
208700     IF  H-OPER-DSH NUMERIC
208800         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
208900                     (PPS-OPER-FSP-PART  * H-OPER-DSH) * .25.
209000
209100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
209200                         PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
209300
209400
209500     COMPUTE PPS-OPER-FSP-PART ROUNDED =
209600                           H-OPER-FSP-PART * H-OPER-FSP-PCT.
209700
209800     COMPUTE PPS-OPER-HSP-PART ROUNDED =
209900                           H-OPER-HSP-PART * H-OPER-HSP-PCT.
210000
210100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
210200                         H-OPER-OUTLIER-PART * H-OPER-FSP-PCT.
210300
210400     COMPUTE PPS-NEW-TECH-PAY-ADD-ON ROUNDED =
210500                                H-NEW-TECH-PAY-ADD-ON.
210600
210700     COMPUTE PPS-ISLET-ISOL-PAY-ADD-ON ROUNDED =
210800                                H-NEW-TECH-ADDON-ISLET.
210900
211000     IF P-NEW-TEMP-RELIEF-IND = 'Y'
211100        AND P-LV-ADJ-FACTOR > 0.00
211200        AND P-LV-ADJ-FACTOR <= 0.25
211300     COMPUTE WK-LOW-VOL-ADDON ROUNDED =
211400       (PPS-OPER-HSP-PART +
211500        PPS-OPER-FSP-PART +
211600        PPS-OPER-IME-ADJ +
211700        PPS-OPER-DSH-ADJ +
211800        PPS-OPER-OUTLIER-PART +
211900        H-CAPI-FSP +
212000        H-CAPI-IME-ADJ +
212100        H-CAPI-DSH-ADJ +
212200        H-CAPI-OUTLIER +
212300        WK-UNCOMP-CARE-AMOUNT +
212400        PPS-NEW-TECH-PAY-ADD-ON) * P-LV-ADJ-FACTOR
212500     ELSE
212600     COMPUTE WK-LOW-VOL-ADDON ROUNDED = 0.
212700
212800     COMPUTE H-LOW-VOL-PAYMENT ROUNDED = WK-LOW-VOL-ADDON.
212900     IF HMO-TAG  = 'Y'
213000        PERFORM 3850-HMO-IME-ADJ.
213100
213200***********************************************************
213300***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
213400
213500     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
213600             H-CAPI-FSP + H-CAPI-IME-ADJ +
213700             H-CAPI-DSH-ADJ + H-CAPI-OUTLIER.
213800
213900         PERFORM 9000-CALC-EHR-SAVING   THRU 9000-EXIT.
214000         PERFORM 9010-CALC-STANDARD-CHG THRU 9010-EXIT.
214100
214200***********************************************************
214300* HOSPITAL ACQUIRED CONDITION (HAC) PENALTY & REDUCTION FACTOR
214400***********************************************************
214500*---------------------------------------------------------*
214600* (YEARCHANGE 2016.0)
214700* HOSPITAL ACQUIRED CONDITION (HAC) REDUCTION FACTOR
214800*   + FOR FY 2015 AN ADJUSTMENT OF 0.01 TO CALCULATE
214900*     HOSPITAL ACQUIRED CONDITION (HAC) PENALTY
215000*   + BASED ON INDICATOR FROM THE PPS FILE
215100*   + NOT VALID IN PUERTO RICO
215200*   + TOTAL PAYMENT NOW INCLUDES UNCOMPENSATED CARE AMOUNT
215300*---------------------------------------------------------*
215400
215500     COMPUTE WK-HAC-TOTAL-PAYMENT ROUNDED =
215600        PPS-OPER-HSP-PART +
215700        PPS-OPER-FSP-PART +
215800        PPS-OPER-IME-ADJ +
215900        PPS-OPER-DSH-ADJ +
216000        PPS-OPER-OUTLIER-PART +
216100        H-CAPI-TOTAL-PAY +
216200        WK-UNCOMP-CARE-AMOUNT +
216300        PPS-NEW-TECH-PAY-ADD-ON +
216400        WK-LOW-VOL-ADDON +
216500        H-READMIS-ADJUST-AMT +
216600        H-VAL-BASED-PURCH-ADJUST-AMT.
216700
216800     MOVE ZERO TO WK-HAC-AMOUNT.
216900
217000     IF P-PR-NEW-STATE AND
217100        P-HAC-REDUC-IND = 'Y'
217200           MOVE 53 TO PPS-RTC
217300           GO TO 3800-EXIT.
217400
217500     IF  P-HAC-REDUC-IND = 'Y'
217600         COMPUTE   WK-HAC-AMOUNT     ROUNDED =
217700                   WK-HAC-TOTAL-PAYMENT * -0.01
217800     ELSE
217900         COMPUTE   WK-HAC-AMOUNT     ROUNDED = 0.
218000
218100***********************************************************
218200***  TOTAL PAYMENT NOW INCLUDES HAC PENALTY AMOUNT
218300************************************************
218400     COMPUTE   PPS-TOTAL-PAYMENT ROUNDED =
218500                 WK-HAC-TOTAL-PAYMENT
218600                           +
218700                 H-WK-PASS-AMT-PLUS-MISC
218800                           +
218900                 H-BUNDLE-ADJUST-AMT
219000                           +
219100                 WK-HAC-AMOUNT
219200                           +
219300                 H-NEW-TECH-ADDON-ISLET.
219400
219500     MOVE     P-VAL-BASED-PURCH-PARTIPNT TO
219600              H-VAL-BASED-PURCH-PARTIPNT.
219700
219800     MOVE     P-VAL-BASED-PURCH-ADJUST   TO
219900              H-VAL-BASED-PURCH-ADJUST.
220000
220100     MOVE     P-HOSP-READMISSION-REDU    TO
220200              H-HOSP-READMISSION-REDU.
220300
220400     MOVE     P-HOSP-HRR-ADJUSTMT        TO
220500              H-HOSP-HRR-ADJUSTMT.
220600
220700 3800-EXIT.   EXIT.
220800
220900 3850-HMO-IME-ADJ.
221000***********************************************************
221100***  HMO CALC FOR PASS-THRU ADDON
221200
221300     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
221400          (P-NEW-PASS-AMT-PLUS-MISC -
221500          (P-NEW-PASS-AMT-ORGAN-ACQ +
221600           P-NEW-PASS-AMT-DIR-MED-ED)) * B-LOS.
221700
221800***********************************************************
221900***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
222000
222100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
222200                   PPS-OPER-IME-ADJ * .0.
222300
222400***********************************************************
222500
222600
222700 3900A-CALC-OPER-DSH.
222800
222900***  OPERATING DSH CALCULATION
223000
223100      MOVE 0.0000 TO H-OPER-DSH.
223200
223300      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
223400                                     + P-NEW-MEDICAID-RATIO).
223500
223600***********************************************************
223700**1**    0-99 BEDS
223800***  NOT TO EXCEED 12%
223900
224000      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
224100                               AND H-WK-OPER-DSH > .1499
224200                               AND H-WK-OPER-DSH < .2020
224300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
224400                                      * .65 + .025
224500        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
224600
224700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
224800                               AND H-WK-OPER-DSH > .2019
224900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
225000                                      * .825 + .0588
225100        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
225200
225300***********************************************************
225400**2**   100 + BEDS
225500***  NO CAP >> CAN EXCEED 12%
225600
225700      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
225800                               AND H-WK-OPER-DSH > .1499
225900                               AND H-WK-OPER-DSH < .2020
226000        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
226100                                      * .65 + .025.
226200
226300      IF (W-CBSA-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
226400                               AND H-WK-OPER-DSH > .2019
226500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
226600                                      * .825 + .0588.
226700
226800***********************************************************
226900**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
227000***  NOT TO EXCEED 12%
227100
227200      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
227300                               AND H-WK-OPER-DSH > .1499
227400                               AND H-WK-OPER-DSH < .2020
227500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
227600                                 * .65 + .025
227700        IF H-OPER-DSH > .1200
227800              MOVE .1200 TO H-OPER-DSH.
227900
228000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE < 500
228100                               AND H-WK-OPER-DSH > .2019
228200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
228300                                 * .825 + .0588
228400        IF H-OPER-DSH > .1200
228500                 MOVE .1200 TO H-OPER-DSH.
228600***********************************************************
228700**4**   OTHER RURAL HOSPITALS 500 BEDS +
228800***  NO CAP >> CAN EXCEED 12%
228900
229000      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
229100                               AND H-WK-OPER-DSH > .1499
229200                               AND H-WK-OPER-DSH < .2020
229300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
229400                                 * .65 + .025.
229500
229600      IF W-CBSA-SIZE = 'R'     AND P-NEW-BED-SIZE > 499
229700                               AND H-WK-OPER-DSH > .2019
229800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
229900                                 * .825 + .0588.
230000
230100***********************************************************
230200**7**   RURAL HOSPITALS SCH
230300***  NOT TO EXCEED 12%
230400
230500      IF W-CBSA-SIZE = 'R'
230600         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
230700                               AND H-WK-OPER-DSH > .1499
230800                               AND H-WK-OPER-DSH < .2020
230900         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
231000                                 * .65 + .025
231100        IF H-OPER-DSH > .1200
231200                 MOVE .1200 TO H-OPER-DSH.
231300
231400      IF W-CBSA-SIZE = 'R'
231500         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
231600                               AND H-WK-OPER-DSH > .2019
231700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
231800                                 * .825 + .0588
231900        IF H-OPER-DSH > .1200
232000                 MOVE .1200 TO H-OPER-DSH.
232100
232200***********************************************************
232300**6**   RURAL HOSPITALS RRC   RULE 5 & 6 SAME
232400***  RRC OVERRIDES SCH CAP
232500***  NO CAP >> CAN EXCEED 12%
232600
232700         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
232800                                   '17' OR '22')
232900                               AND H-WK-OPER-DSH > .1499
233000                               AND H-WK-OPER-DSH < .2020
233100         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
233200                                 * .65 + .025.
233300
233400         IF (P-NEW-PROVIDER-TYPE = '07' OR '14' OR '15' OR
233500                                   '17' OR '22')
233600                               AND H-WK-OPER-DSH > .2019
233700         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
233800                                 * .825 + .0588.
233900
234000      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
234100
234200 3900A-EXIT.   EXIT.
234300
234400 4000-CALC-TECH-ADDON.
234500
234600***********************************************************
234700***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
234800
234900     COMPUTE PPS-OPER-HSP-PART ROUNDED =
235000         H-OPER-HSP-PCT * H-OPER-HSP-PART.
235100
235200     COMPUTE PPS-OPER-FSP-PART ROUNDED =
235300         H-OPER-FSP-PCT * H-OPER-FSP-PART.
235400
235500     MOVE ZERO TO PPS-OPER-DSH-ADJ.
235600
235700     IF  H-OPER-DSH NUMERIC
235800             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
235900             (PPS-OPER-FSP-PART
236000              * H-OPER-DSH) * .25.
236100
236200     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
236300             PPS-OPER-FSP-PART *
236400             H-OPER-IME-TEACH.
236500
236600     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
236700             PPS-OPER-FSP-PART +
236800             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ +
236900             WK-UNCOMP-CARE-AMOUNT.
237000
237100***********************************************************
237200* NEW TECHNOLOGY ADD-ON CODE *
237300***********************************************************
237400     MOVE 1 TO IDX-TECH.
237500     INITIALIZE H-CSTMED-STOP.
237600     INITIALIZE H-NEW-TECH-PCT.
237700     INITIALIZE H-TECH-ADDON-ISLET-CNTR.
237800
237900     PERFORM 4010-FLAG-NEW-TECH THRU 4010-EXIT
238000      VARYING IDX-TECH FROM 1 BY 1 UNTIL IDX-TECH > 25.
238100
238200     IF PROC-ANDEXXA-FLAG = 'Y'
238300       MOVE  18281.25 TO H-CSTMED-STOP.
238400       MOVE 0.65 TO H-NEW-TECH-PCT.
238500       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
238600
238700     IF PROC-AQUABEAM-FLAG = 'Y'
238800       MOVE   1625.00 TO H-CSTMED-STOP.
238900       MOVE 0.65 TO H-NEW-TECH-PCT.
239000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
239100
239200     IF PROC-AZEDRA-FLAG = 'Y'
239300       MOVE  98150.00 TO H-CSTMED-STOP.
239400       MOVE 0.65 TO H-NEW-TECH-PCT.
239500       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
239600
239700     IF PROC-BALVERSA-FLAG = 'Y'
239800       MOVE   3563.23 TO H-CSTMED-STOP.
239900       MOVE 0.65 TO H-NEW-TECH-PCT.
240000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
240100
240200     IF PROC-CABLIVI-FLAG = 'Y'
240300       MOVE  33215.00 TO H-CSTMED-STOP.
240400       MOVE 0.65 TO H-NEW-TECH-PCT.
240500       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
240600
240700     IF PROC-ELZONRIS-FLAG = 'Y'
240800       MOVE 125448.05 TO H-CSTMED-STOP.
240900       MOVE 0.65 TO H-NEW-TECH-PCT.
241000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
241100
241200     IF PROC-ERLEADA-FLAG = 'Y'
241300       MOVE   1858.25 TO H-CSTMED-STOP.
241400       MOVE 0.65 TO H-NEW-TECH-PCT.
241500       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
241600
241700     IF PROC-GIAPREZA-FLAG = 'Y'
241800       MOVE   1950.00 TO H-CSTMED-STOP.
241900       MOVE 0.65 TO H-NEW-TECH-PCT.
242000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
242100
242200     IF DIAG-ISLET-FLAG = 'Y' AND PROC-ISLET-FLAG = 'Y'
242300       PERFORM 4100-ISLET-ISOLATION-ADD-ON THRU 4100-EXIT
242400     ELSE
242500       MOVE ZEROES TO H-NEW-TECH-ADDON-ISLET.
242600
242700     IF PROC-JAKAFI-FLAG = 'Y'
242800       MOVE   3977.06 TO H-CSTMED-STOP.
242900       MOVE 0.65 TO H-NEW-TECH-PCT.
243000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
243100
243200     IF PROC-KYMRIAH-FLAG = 'Y'
243300       MOVE 242450.00 TO H-CSTMED-STOP.
243400       MOVE 0.65 TO H-NEW-TECH-PCT.
243500       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
243600
243700     IF PROC-PLAZO-FLAG = 'Y'
243800       MOVE   4083.75 TO H-CSTMED-STOP.
243900       MOVE 0.75 TO H-NEW-TECH-PCT.
244000       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
244100
244200     IF PROC-REMEDE1-FLAG = 'Y' AND PROC-REMEDE2-FLAG = 'Y'
244300       AND PROC-REMEDE3-FLAG = 'Y'
244400       MOVE  22425.00 TO H-CSTMED-STOP.
244500       MOVE 0.65 TO H-NEW-TECH-PCT.
244600       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
244700
244800     IF PROC-SENTINEL-FLAG = 'Y'
244900       MOVE  1820.00 TO H-CSTMED-STOP.
245000       MOVE 0.65 TO H-NEW-TECH-PCT.
245100       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
245200
245300     IF PROC-SPRAVATO-FLAG = 'Y'
245400       MOVE  1014.79 TO H-CSTMED-STOP.
245500       MOVE 0.65 TO H-NEW-TECH-PCT.
245600       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
245700
245800     IF PROC-T2-FLAG = 'Y'
245900       MOVE    97.50 TO H-CSTMED-STOP.
246000       MOVE 0.65 TO H-NEW-TECH-PCT.
246100       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
246200
246300     IF PROC-VABOMERE-FLAG = 'Y' OR NDC-VABOMERE-FLAG = 'Y'
246400       MOVE  8316.00 TO H-CSTMED-STOP.
246500       MOVE 0.75 TO H-NEW-TECH-PCT.
246600       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
246700
246800     IF PROC-VYXEOS-FLAG = 'Y'
246900       MOVE 47352.50 TO H-CSTMED-STOP.
247000       MOVE 0.65 TO H-NEW-TECH-PCT.
247100       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
247200
247300     IF PROC-XOSPATA-FLAG = 'Y'
247400       MOVE  7312.50 TO H-CSTMED-STOP.
247500       MOVE 0.65 TO H-NEW-TECH-PCT.
247600       PERFORM 4020-NEW-TECH-ADD-ON THRU 4020-EXIT.
247700
247800***********************************************************
247900*  ALL NEW TECH MUST BE CALCULATED BEFORE
248000*  5500-CAP-CALC-TECH-ADD-ON
248100***********************************************************
248200     PERFORM 5500-CAP-CALC-TECH-ADD-ON THRU 5500-EXIT.
248300
248400     COMPUTE H-OPER-BASE-DRG-PAY ROUNDED =
248500             H-OPER-FSP-PART +
248600             H-NEW-TECH-PAY-ADD-ON.
248700
248800 4000-EXIT.    EXIT.
248900
249000************************************
249100* NEW TECHNOLOGY ADD-ON FLAG LOGIC *
249200************************************
249300 4010-FLAG-NEW-TECH.
249400
249500     MOVE B-PROCEDURE-CODE(IDX-TECH) TO WK-PROC-NEW-TECH.
249600     MOVE B-DIAGNOSIS-CODE(IDX-TECH) TO WK-DIAG-NEW-TECH.
249700     MOVE B-NDC-NUMBER TO WK-NDC-NEW-TECH.
249800
249900     IF PROC-ANDEXXA
250000       MOVE 'Y' TO PROC-ANDEXXA-FLAG.
250100
250200     IF PROC-AQUABEAM
250300       MOVE 'Y' TO PROC-AQUABEAM-FLAG.
250400
250500     IF PROC-AZEDRA
250600       MOVE 'Y' TO PROC-AZEDRA-FLAG.
250700
250800     IF PROC-BALVERSA
250900       MOVE 'Y' TO PROC-BALVERSA-FLAG.
251000
251100     IF PROC-CABLIVI
251200       MOVE 'Y' TO PROC-CABLIVI-FLAG.
251300
251400     IF PROC-ELZONRIS
251500       MOVE 'Y' TO PROC-ELZONRIS-FLAG.
251600
251700     IF PROC-ERLEADA
251800       MOVE 'Y' TO PROC-ERLEADA-FLAG.
251900
252000     IF PROC-GIAPREZA
252100       MOVE 'Y' TO PROC-GIAPREZA-FLAG.
252200
252300     IF PROC-ISLET
252400       MOVE 'Y' TO PROC-ISLET-FLAG
252500       COMPUTE H-TECH-ADDON-ISLET-CNTR =
252600          H-TECH-ADDON-ISLET-CNTR + 1.
252700
252800     IF PROC-JAKAFI
252900       MOVE 'Y' TO PROC-JAKAFI-FLAG.
253000
253100     IF PROC-KYMRIAH
253200       MOVE 'Y' TO PROC-KYMRIAH-FLAG.
253300
253400     IF PROC-PLAZO
253500       MOVE 'Y' TO PROC-PLAZO-FLAG.
253600
253700     IF PROC-REMEDE1
253800       MOVE 'Y' TO PROC-REMEDE1-FLAG.
253900
254000     IF PROC-REMEDE2
254100       MOVE 'Y' TO PROC-REMEDE2-FLAG.
254200
254300     IF PROC-REMEDE3
254400       MOVE 'Y' TO PROC-REMEDE3-FLAG.
254500
254600     IF PROC-SENTINEL
254700       MOVE 'Y' TO PROC-SENTINEL-FLAG.
254800
254900     IF PROC-SPRAVATO
255000       MOVE 'Y' TO PROC-SPRAVATO-FLAG.
255100
255200     IF PROC-T2
255300       MOVE 'Y' TO PROC-T2-FLAG.
255400
255500     IF PROC-VABOMERE
255600       MOVE 'Y' TO PROC-VABOMERE-FLAG.
255700
255800     IF PROC-VYXEOS
255900       MOVE 'Y' TO PROC-VYXEOS-FLAG.
256000
256100     IF PROC-XOSPATA
256200       MOVE 'Y' TO PROC-XOSPATA-FLAG.
256300
256400     IF DIAG-ISLET
256500       MOVE 'Y' TO DIAG-ISLET-FLAG.
256600
256700     IF NDC-VABOMERE
256800       MOVE 'Y' TO NDC-VABOMERE-FLAG.
256900
257000 4010-EXIT.   EXIT.
257100
257200*******************************************
257300* NEW TECHNOLOGY ADD-ON CALCULATION LOGIC *
257400*******************************************
257500 4020-NEW-TECH-ADD-ON.
257600
257700     MOVE 0 TO H-NEW-TECH-ADDON
257800               H-LESSER-STOP-1
257900               H-LESSER-STOP-2.
258000
258100     COMPUTE H-LESSER-STOP-1 ROUNDED =
258200                  H-CSTMED-STOP.
258300
258400     COMPUTE H-LESSER-STOP-2 ROUNDED =
258500          (((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
258600             H-BASE-DRG-PAYMENT)) * H-NEW-TECH-PCT.
258700
258800     IF H-LESSER-STOP-2 > 0
258900        IF H-LESSER-STOP-1 < H-LESSER-STOP-2
259000         MOVE H-LESSER-STOP-1 TO
259100                                H-NEW-TECH-ADDON
259200        ELSE
259300         MOVE H-LESSER-STOP-2 TO
259400                                H-NEW-TECH-ADDON
259500     ELSE
259600        MOVE ZEROES          TO H-NEW-TECH-ADDON.
259700
259800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
259900             H-NEW-TECH-PAY-ADD-ON +
260000             H-NEW-TECH-ADDON.
260100
260200     MOVE 0 TO H-NEW-TECH-ADDON
260300               H-LESSER-STOP-1
260400               H-LESSER-STOP-2
260500               H-CSTMED-STOP.
260600
260700 4020-EXIT.    EXIT.
260800
260900***********************************************************
261000* TECHNICAL TRANSPLANTATION OF CELLS                      *
261100***********************************************************
261200 4100-ISLET-ISOLATION-ADD-ON.
261300
261400     MOVE 0 TO H-NEW-TECH-ADDON-ISLET.
261500
261600     IF  H-TECH-ADDON-ISLET-CNTR = 1
261700     MOVE 18848.00 TO H-NEW-TECH-ADDON-ISLET
261800           GO TO 4100-EXIT.
261900
262000     IF  H-TECH-ADDON-ISLET-CNTR > 1
262100     MOVE 37696.00 TO H-NEW-TECH-ADDON-ISLET
262200           GO TO 4100-EXIT.
262300
262400 4100-EXIT.    EXIT.
262500
262600***********************************************************
262700* THIS IS A SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR
262800* DISCHARGE COUNTS.
262900***********************************************************
263000*4400-LOWVOL-CODE-RTN.
263100*
263200*    SET LOWVOL-IDX TO 1.
263300*    SEARCH LOWVOL-TAB VARYING LOWVOL-IDX
263400*        AT END
263500*          MOVE ' NO LOWVOL PROVIDER FOUND' TO MES-LOWVOL
263600*          MOVE 1600 TO  MESWK-LOWVOL-PROV-DISCHG
263700*      WHEN WK-LOWVOL-PROV (LOWVOL-IDX) = MES-PPS-PROV
263800*        MOVE WK-LOWVOL-PROV-DISCHG(LOWVOL-IDX)
263900*                           TO MESWK-LOWVOL-PROV-DISCHG.
264000*
264100*4400-EXIT.   EXIT.
264200
264300*****************************************************************
264400* THIS SEARCH FOR LOW VOLUME PROVIDERS BASED ON THEIR DISCHARGE *
264500* COUNTS WAS REPLACED BY A FIELD ON THE PSF PROVIDER FILE       *
264600*****************************************************************
264700 4410-UNCOMP-CARE-CODE-RTN.
264800
264900*    MOVE P-NEW-PROVIDER-NO  TO MES-PPS-PROV.
265000*
265100*    SET UNCOMP-CARE-IDX TO 1.
265200*    SEARCH UNCOMP-CARE-TAB VARYING UNCOMP-CARE-IDX
265300*        AT END
265400*          MOVE 0 TO  WK-UNCOMP-CARE-AMOUNT
265500*      WHEN TB-UNCOMP-CARE-PROV (UNCOMP-CARE-IDX) = MES-PPS-PROV
265600*        MOVE TB-UNCOMP-CARE-AMOUNT (UNCOMP-CARE-IDX)
265700*                           TO WK-UNCOMP-CARE-AMOUNT.
265800*
265900        COMPUTE WK-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
266000
266100        COMPUTE H-UNCOMP-CARE-AMOUNT = P-UNCOMP-CARE-AMOUNT.
266200
266300 4410-EXIT.   EXIT.
266400
266500
266600**************************************************************
266700* CASES INVOLVING TECH-CAP-CALC PROCESS DECOMPRESSION SYSTEM *
266800**************************************************************
266900 5500-CAP-CALC-TECH-ADD-ON.
267000
267100     MOVE 0 TO H-NEW-TECH-ADDON-CAP.
267200     MOVE 0 TO H-NEW-TECH-ADDON-CAPDIF.
267300
267400     COMPUTE H-OPER-BILL-COSTS ROUNDED =
267500         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
267600         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
267700
267800     COMPUTE H-NEW-TECH-ADDON-CAP ROUNDED =
267900                 (H-BASE-DRG-PAYMENT + H-NEW-TECH-PAY-ADD-ON).
268000
268100     COMPUTE H-NEW-TECH-ADDON-CAPDIF ROUNDED =
268200                 (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
268300
268400     IF (H-NEW-TECH-ADDON-CAP > H-OPER-BILL-COSTS) AND
268500         H-NEW-TECH-ADDON-CAPDIF  > 0
268600        COMPUTE H-NEW-TECH-PAY-ADD-ON  ROUNDED =
268700             (H-OPER-BILL-COSTS - H-BASE-DRG-PAYMENT).
268800
268900 5500-EXIT.    EXIT.
269000
269100***********************************************************
269200 6000-CALC-READMIS-REDU.
269300***********************************************************
269400*---------------------------------------------------------*
269500* (YEARCHANGE 2016.0)
269600* READMISSIONS PROCESS ADJUSTMENTS
269700*   + FY16: RANGE OF ALLOWABLE FACTORS (< 0.97 OR > 1.0)
269800*---------------------------------------------------------*
269900
270000     MOVE 0 TO H-READMIS-ADJUST-AMT.
270100
270200     IF P-HOSP-READMISSION-REDU = '1'
270300           GO TO 6000-EDIT-READMISN
270400     ELSE
270500           NEXT SENTENCE.
270600
270700     IF P-HOSP-READMISSION-REDU = '0' AND
270800        P-HOSP-HRR-ADJUSTMT = 0.0000
270900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
271000           GO TO 6000-EXIT.
271100
271200     IF P-HOSP-READMISSION-REDU = '0' AND
271300        P-HOSP-HRR-ADJUSTMT > 0.0000
271400           MOVE 65 TO PPS-RTC
271500           MOVE ZEROES TO H-READMIS-ADJUST-AMT
271600           GO TO 6000-EXIT.
271700
271800     IF P-HOSP-READMISSION-REDU = '2' OR '3' OR '4' OR '5' OR
271900                                  '6' OR '7' OR '8' OR
272000                                  '9' OR ' '
272100           MOVE 65 TO PPS-RTC
272200           MOVE ZEROES TO H-READMIS-ADJUST-AMT
272300           GO TO 6000-EXIT.
272400
272500 6000-EDIT-READMISN.
272600
272700     IF P-HOSP-HRR-ADJUSTMT < 0.9700
272800           MOVE 65 TO PPS-RTC
272900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
273000           GO TO 6000-EXIT.
273100
273200     IF P-HOSP-HRR-ADJUSTMT > 1.0000
273300           MOVE 65 TO PPS-RTC
273400           MOVE ZEROES TO H-READMIS-ADJUST-AMT
273500           GO TO 6000-EXIT.
273600
273700     IF P-READ-INVALID-STATE
273800           MOVE 65 TO PPS-RTC
273900           MOVE ZEROES TO H-READMIS-ADJUST-AMT
274000           GO TO 6000-EXIT.
274100
274200 6000-COMPUTE-READMISN.
274300
274400        COMPUTE H-READMIS-ADJUST-AMT         ROUNDED =
274500              ((P-HOSP-HRR-ADJUSTMT * H-OPER-BASE-DRG-PAY) -
274600                H-OPER-BASE-DRG-PAY).
274700
274800 6000-EXIT.    EXIT.
274900
275000***********************************************************
275100 7000-CALC-VALUE-BASED-PURCH.
275200***********************************************************
275300*---------------------------------------------------------*
275400* (YEARCHANGE 2016.0)
275500* VALUE BASED PURCHASING (VBP) ADJUSTMENTS
275600*   + FY17: RANGE OF ALLOWABLE FACTORS (< 0.98 OR > 2.0)
275700*---------------------------------------------------------*
275800
275900     MOVE 0 TO H-VAL-BASED-PURCH-ADJUST-AMT.
276000
276100     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N' OR 'Y'
276200           NEXT SENTENCE
276300     ELSE
276400           MOVE 68 TO PPS-RTC
276500           GO TO 7000-EXIT.
276600
276700     IF  P-VAL-BASED-PURCH-PARTIPNT = 'N'
276800           GO TO 7000-EXIT.
276900
277000     IF  P-VAL-BASED-PURCH-PARTIPNT = 'Y' AND
277100         P-NEW-CBSA-HOSP-QUAL-IND = '1'
277200           NEXT SENTENCE
277300     ELSE
277400           MOVE 68 TO PPS-RTC
277500           GO TO 7000-EXIT.
277600
277700     IF  P-VBP-INVALID-STATE
277800           MOVE 68 TO PPS-RTC
277900           GO TO 7000-EXIT
278000     ELSE
278100           NEXT SENTENCE.
278200
278300     IF P-VAL-BASED-PURCH-ADJUST < 0.9800000000 OR
278400        P-VAL-BASED-PURCH-ADJUST > 2.0000000000
278500           MOVE 68 TO PPS-RTC
278600           MOVE ZEROES TO H-VAL-BASED-PURCH-ADJUST-AMT
278700           GO TO 7000-EXIT
278800     ELSE
278900           GO TO 7000-COMPUTE-VAL-BASED-PUR.
279000
279100 7000-COMPUTE-VAL-BASED-PUR.
279200
279300     COMPUTE H-VAL-BASED-PURCH-ADJUST-AMT  ROUNDED =
279400              ((P-VAL-BASED-PURCH-ADJUST *
279500                  H-OPER-BASE-DRG-PAY) -
279600                  H-OPER-BASE-DRG-PAY).
279700
279800 7000-EXIT.    EXIT.
279900
280000***********************************************************
280100 8000-CALC-BUNDLE-REDU.
280200***********************************************************
280300***** CASES INVOLVING BUNDLE PROCESS ADJUSTMENTS
280400***********************************************************
280500
280600     MOVE 0 TO H-BUNDLE-ADJUST-AMT.
280700     MOVE 0 TO WK-MODEL1-BUNDLE-DISPRCNT.
280800
280900     IF '61' =  B-DEMO-CODE1  OR
281000                B-DEMO-CODE2  OR
281100                B-DEMO-CODE3  OR
281200                B-DEMO-CODE4
281300         NEXT SENTENCE
281400     ELSE
281500         MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
281600           GO TO 8000-EXIT.
281700
281800     IF P-MODEL1-BUNDLE-DISPRCNT > .00
281900           GO TO 8000-COMPUTE-BUNDLE
282000     ELSE
282100           NEXT SENTENCE.
282200
282300     MOVE ZEROES TO H-BUNDLE-ADJUST-AMT
282400           GO TO 8000-EXIT.
282500
282600 8000-COMPUTE-BUNDLE.
282700
282800     IF  B-DISCHARGE-DATE < 20140401 AND
282900         P-MODEL1-BUNDLE-DISPRCNT = .01
283000         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
283100          (1 - (P-MODEL1-BUNDLE-DISPRCNT * .5))
283200     ELSE
283300         COMPUTE WK-MODEL1-BUNDLE-DISPRCNT =
283400          (1 - (P-MODEL1-BUNDLE-DISPRCNT * 1)).
283500
283600        COMPUTE H-BUNDLE-ADJUST-AMT      ROUNDED =
283700              ((WK-MODEL1-BUNDLE-DISPRCNT *
283800                                     H-OPER-BASE-DRG-PAY) -
283900                H-OPER-BASE-DRG-PAY).
284000
284100        COMPUTE H-BUNDLE-ADJUST-AMT ROUNDED = H-BUNDLE-ADJUST-AMT.
284200
284300 8000-EXIT.    EXIT.
284400
284500***********************************************************
284600 9000-CALC-EHR-SAVING.
284700***********************************************************
284800*---------------------------------------------------------*
284900* (YEARCHANGE 2020.0)
285000* CASES INVOLVING EHR SAVINGS
285100*   + FY20: ANNUAL UPDATE TO BELOW VALUES
285200*   + EHR-FULL = FULL MB / NO EHR MB
285300*   + EHR-QUAL-FULL = NO QUAL MB / NO QUAL & NO EHR MB
285400*---------------------------------------------------------*
285500
285600     MOVE 1.022421525 TO H-MB-RATIO-EHR-FULL.
285700     MOVE 1.022590361 TO H-MB-RATIO-EHR-QUAL-FULL.
285800     MOVE 0 TO H-EHR-SUBSAV-QUANT.
285900     MOVE 0 TO H-EHR-SUBSAV-LV.
286000     MOVE 0 TO H-EHR-SUBSAV-QUANT-INCLV.
286100     MOVE 0 TO H-EHR-RESTORE-FULL-QUANT.
286200
286300     IF P-EHR-REDUC-IND = 'Y'
286400         NEXT SENTENCE
286500     ELSE
286600         GO TO 9000-EXIT.
286700
286800 9000-COMPUTE-EHR.
286900
287000* LOGIC TO IMPLEMENT EHR SAVINGS CALCULATION -
287100* ACTUAL EHR REDUCTIONS WILL BE BUILT INTO NEW RATE
287200* TABLES (5,6,7,&8) UP FRONT BUT OESS WANTS TO HAVE THE
287300* AMOUNT OF MONEY THE EHR POLICY 'SAVED' IN ITS OWN FIELD
287400* WHICH INVOLVES RESTORING THE FULL MARKET  BASKET
287500* TO THE PAYMENT TO GET THE 'WOULD'VE PAID' AND THEN
287600* TAKING THE DIFFERENCE BETWEEN ACTUAL PAID AND
287700* WOULD'VE PAID FOR THE SAVINGS.  OUTLIERS ARE TO BE
287800* LEFT OUT AT MOMENT SINCE OUTLIER SHOULD BE LOWER
287900* ON THE FULL RATE THAN IT WINDS UP BEING ON THE
288000* REDUCED RATE - LIKEWISE NEW TECH IS BEING LEFT
288100* OUT.
288200*
288300* FOR EHR NEED TO EXCLUDE NEW TECH AND OUTLIERS FROM
288400* SAVINGS CALCULATION SO CALCULATE AN OPERATING
288500* PAYMENT SUBTOTAL ON SO CALCULATE AN OPERATING
288600* PAYMENT SUBTOTAL ON EHR PAYMENTS THAT EXCLUDES
288700* OUTLIERS AND NEW TECH FOR CLAIMS WITH AN EHR FLAG
288800
288900      COMPUTE H-EHR-SUBSAV-QUANT =
289000           (PPS-OPER-HSP-PART +
289100            PPS-OPER-FSP-PART +
289200            PPS-OPER-DSH-ADJ +
289300            PPS-OPER-IME-ADJ +
289400            H-READMIS-ADJUST-AMT +
289500            H-VAL-BASED-PURCH-ADJUST-AMT +
289600            H-BUNDLE-ADJUST-AMT).
289700
289800* NEED TO ENSURE THAT LOW VOLUME, IF APPLICABLE IS
289900* INCLUDED - CAN'T USE PRICER'S LOW VOLUME PAYMENT
290000* AS THAT INCLUDES NEW TECH OUTLIERS AND CAPITAL -
290100* READM VBP AND BUNDLE
290200* DON'T MULTIPLY BY LV ADJUSTMENT SO MAKE A NEW LV AMT
290300* FOR EHR SAVINGS FIELD;
290400
290500      MOVE 0 TO H-EHR-SUBSAV-LV.
290600
290700      IF P-NEW-TEMP-RELIEF-IND = 'Y'
290800         AND P-LV-ADJ-FACTOR > 0.00
290900         AND P-LV-ADJ-FACTOR <= 0.25
291000      COMPUTE H-EHR-SUBSAV-LV =
291100          (PPS-OPER-HSP-PART +
291200           PPS-OPER-FSP-PART +
291300           PPS-OPER-DSH-ADJ +
291400           PPS-OPER-IME-ADJ ) * P-LV-ADJ-FACTOR.
291500
291600      COMPUTE H-EHR-SUBSAV-QUANT-INCLV =
291700           H-EHR-SUBSAV-QUANT + H-EHR-SUBSAV-LV.
291800
291900* H-MB-RATIO-EHR-FULL IS THE RATIO OF THE FULL MARKET
292000* BASKET TO THE REDUCED EHR MB - NEED TO CARRY 2 RATIOS
292100* FOR PROVIDERS FAILING EHR AND FOR PROVIDERS FAILING EHR
292200* AND QUALITY IN COMBINATION.  EHR SAVINGS REQUIRES
292300* BACKING OFF THE LOW UPDATE AND MULTIPLYING ON THE
292400* FULL UPDATE SO USING RATIO OF LOW/FULL AND LOW/QUALHIT
292500* OF .625 ONLY.
292600
292700       COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
292800       H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-FULL.
292900
293000     IF P-NEW-CBSA-HOSP-QUAL-IND NOT = '1'
293100        COMPUTE  H-EHR-RESTORE-FULL-QUANT ROUNDED =
293200          H-EHR-SUBSAV-QUANT-INCLV * H-MB-RATIO-EHR-QUAL-FULL.
293300
293400        COMPUTE  H-EHR-ADJUST-AMT ROUNDED =
293500          H-EHR-RESTORE-FULL-QUANT - H-EHR-SUBSAV-QUANT-INCLV.
293600
293700 9000-EXIT.    EXIT.
293800
293900*---------------------------------------------------------*
294000* (YEARCHANGE 2016.0)
294100*---------------------------------------------------------*
294200 9010-CALC-STANDARD-CHG.
294300
294400***********************************************************
294500***ÝCM-P3¨ STANDARDIZED OPERATING COST CALCULATION
294600
294700     IF ((H-LABOR-PCT * H-WAGE-INDEX) +
294800               (H-NONLABOR-PCT * H-OPER-COLA)) > 0
294900        COMPUTE  H-OPER-BILL-STDZ-COSTS ROUNDED =
295000        (B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO) /
295100        ((H-LABOR-PCT * H-WAGE-INDEX) +
295200               (H-NONLABOR-PCT * H-OPER-COLA))
295300     ELSE MOVE 0 TO H-OPER-BILL-STDZ-COSTS.
295400
295500***********************************************************
295600***ÝCM-P3¨ STANDARDIZED CAPITAL COST CALCULATION
295700
295800     IF (H-CAPI-GAF * H-CAPI-COLA) > 0
295900       COMPUTE  H-CAPI-BILL-STDZ-COSTS ROUNDED =
296000        (B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO) /
296100               (H-CAPI-GAF * H-CAPI-COLA)
296200     ELSE MOVE 0 TO H-CAPI-BILL-STDZ-COSTS.
296300
296400***********************************************************
296500***ÝCM-P3¨ STANDARDIZED OPERATING TRESHOLD
296600
296700     MOVE 5796.63 TO H-OPER-BASE.
296800
296900     COMPUTE   H-OPER-STDZ-DOLLAR-THRESHOLD ROUNDED =
297000      (H-CST-THRESH * H-OPER-SHARE-DOLL-THRESHOLD)  +
297100                        +
297200           (H-OPER-BASE * H-DRG-WT-FRCTN)
297300                        +
297400              H-NEW-TECH-PAY-ADD-ON.
297500
297600******************************************************
297700***ÝCM-P3¨ STANDARDIZED CAPITAL TRESHOLD
297800
297900     MOVE 462.33 TO H-CAPI-BASE.
298000
298100     COMPUTE   H-CAPI-STDZ-DOLLAR-THRESHOLD ROUNDED =
298200     (H-CST-THRESH * H-CAPI-SHARE-DOLL-THRESHOLD)
298300                     +
298400     (H-CAPI-BASE * H-DRG-WT-FRCTN).
298500
298600******************************************************
298700***ÝCM-P3¨ STANDARDIZED OPERATING OUTLIER CALCULATION
298800
298900     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
299000        (H-OPER-STDZ-DOLLAR-THRESHOLD +
299100                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
299200                          AND
299300         H-OPER-BILL-STDZ-COSTS > H-OPER-STDZ-DOLLAR-THRESHOLD
299400
299500       COMPUTE  H-OPER-STDZ-COST-OUTLIER ROUNDED =
299600        (H-CSTOUT-PCT  *
299700        (H-OPER-BILL-STDZ-COSTS - H-OPER-STDZ-DOLLAR-THRESHOLD))
299800
299900     ELSE
300000       MOVE 0 TO H-OPER-STDZ-COST-OUTLIER.
300100
300200******************************************************
300300***ÝCM-P3¨ STANDARDIZED CAPITAL OUTLIER CALCULATION
300400
300500     IF (H-OPER-BILL-STDZ-COSTS + H-CAPI-BILL-STDZ-COSTS) >
300600        (H-OPER-STDZ-DOLLAR-THRESHOLD +
300700                           H-CAPI-STDZ-DOLLAR-THRESHOLD)
300800                          AND
300900         H-CAPI-BILL-STDZ-COSTS > H-CAPI-STDZ-DOLLAR-THRESHOLD
301000
301100      COMPUTE  H-CAPI-STDZ-COST-OUTLIER ROUNDED =
301200      (H-CSTOUT-PCT  *
301300      (H-CAPI-BILL-STDZ-COSTS - H-CAPI-STDZ-DOLLAR-THRESHOLD))
301400     ELSE
301500      MOVE 0 TO H-CAPI-STDZ-COST-OUTLIER.
301600
301700*******************************************************
301800***ÝCM-P3¨ STANDARDIZED ALLOWED AMOUNT CALCULATION
301900
302000      COMPUTE H-STANDARD-ALLOWED-AMOUNT ROUNDED =
302100       (H-OPER-BASE + H-CAPI-BASE)
302200                 *
302300       H-DRG-WT-FRCTN
302400                 +
302500       H-OPER-STDZ-COST-OUTLIER
302600                 +
302700       H-CAPI-STDZ-COST-OUTLIER
302800                 +
302900       H-NEW-TECH-PAY-ADD-ON.
303000
303100 9010-EXIT.    EXIT.
303200
303300************************************************************************
303400 10000-COVID19-FLAG.
303500************************************************************************
303600
303700     MOVE B-DIAGNOSIS-CODE(IDX-COVID) TO WK-DIAG-COVID19.
303800
303900     IF DIAG-COVID1
304000       MOVE 'Y' TO DIAG-COVID1-FLAG.
304100
304200     IF DIAG-COVID2
304300       MOVE 'Y' TO DIAG-COVID2-FLAG.
304400
304500 10000-EXIT.    EXIT.
304600************************************************************************
