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