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