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