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