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