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