000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. LTDRV212.
000300*AUTHOR.     CENTERS FOR MEDICARE AND MEDICAID SERVICES
000400*REMARKS.    - FINDS WAGE-INDEX RECORD(S) FOR GIVEN BILL TO
000500*              BE PASSED TO LTCALYYV MODULES
000600*            - LOADS THE PPS TABLES
000700*            - CALLS THE LTCALYYV MODULES
000800*            - YYV MEANS YEAR AND VERSION
000900 DATE-COMPILED.
001000****************************************************************
001100*                                                              *
001200*   THIS SUBROUTINE IS FURNISHED BY THE CENTERS FOR MEDICARE   *
001300*   AND MEDICAID SERVICES.                                     *
001400*   IT IS TO BE USED AS AN AID IN IMPLEMENTING PROSPECTIVE     *
001500*   PAYMENT FOR LONG TERM CARE HOSPITALS.                      *
001600*   THE RESPONSIBILITY FOR INSTALLING, MODIFYING, TESTING,     *
001700*   MAINTAINING, AND VERIFYING THE ACCURACY OF THIS PROGRAM    *
001800*   IS THAT OF THE USER.                                       *
001900*                  *  *  *  *  *  *  *  *                      *
002000*   ONCE GROUPED THE PROSPECTIVE PAYMENT SUBROUTINE IS CALLED  *
002100*   TO CALCULATE THE TOTAL PAYMENT PRIOR TO DEDUCTIBLE,        *
002200*   CO-INSURANCE, AND CASES WHERE MEDICARE IS SECONDARY PAYOR. *
002300*   THE PROGRAM WILL:                                          *
002400*       1. EDIT THE BILL INFORMATION.                          *
002500*       2. PASS BACK RETURN CODES.                             *
002600*       3. CALCULATE WHEN APPLICABLE:                          *
002700*          A. THE HOSPITAL SPECIFIC PART OF PAYMENT.           *
002800*          B. THE FEDERAL SPECIFIC PART OF PAYMENT.            *
002900*          C. THE OUTLIER PORTION.                             *
003000*          D. TOTAL PAYMENT (B + C + D  ABOVE).                *
003100*                                                              *
003200*                  *  *  *  *  *  *  *  *                      *
003300*   THIS SUBROUTINE CALCULATES THE PROVIDER SPECIFIC           *
003400*   ELEMENTS ON A PROVIDER BREAK, THEREFORE IT WILL RUN FASTER *
003500*   WHEN BILLS ARE BATCHED BY PROVIDER.                        *
003600*                  *  *  *  *  *  *  *  *                      *
003700*                                                              *
003800*--------------------------------------------------------------*
003900*   CHANGE LOG.                                                *
004000*--------------------------------------------------------------*
004100*                                                              *
004200*   04/07/2005 - AT THE REQUEST OF FISS, LTSEL___ CREATED.     *
004300*                THIS PROGRAM IS CALLED BY LTDRV___ AND        *
004400*                RECEIVES THE PROVIDER RECORD, CBSA TABLE,     *
004500*                BILL RECORD, AND PPS DATA.  IT GETS THE       *
004600*                APPROPRIATE CBSA RECORD AND CALLS THE         *
004700*                APPROPRIATE LTCAL___ MODULE FOR THE BILL      *
004800*                                                              *
004900*--------------------------------------------------------------*
005000*                                                              *
005100*   04/21/2005 - EFFECTIVE JULY 1, 2005, CBSA (CORE-BASED      *
005200*                STATISTICAL AREA) IS USED IN PLACE OF MSA     *
005300*                (METROPOLITAN STATISTICAL AREA), THE PROGRAM  *
005400*                DETERMINES WHETHER TO USE THE CBSA WAGE INDEX *
005500*                FILE OR MSA WAGE INDEX FILE BASED ON THE BILL *
005600*                DISCHARGE DATE                                *
005700*                                                              *
005800*--------------------------------------------------------------*
005900*                                                              *
006000*   05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY INDICATOR &    *
006100*                SPECIAL WAGE INDEX                            *
006200*                                                              *
006300*--------------------------------------------------------------*
006400*                                                              *
006500*   12/07/2005 - REMOVED TIME RESTRAINT FROM THE CALL TO THE   *
006600*                LATEST VERSION OF THE LTCAL PROGRAM           *
006700*                                                              *
006800*--------------------------------------------------------------*
006900*                                                              *
007000*   01/17/2006 - MODIFIED FOR 1ST CICS PACKAGE RELEASE;        *
007100*                FOR APRIL 1, 2006 RELEASE                     *
007200*                                                              *
007300*--------------------------------------------------------------*
007400*                                                              *
007500*   01/19/2006 - PROGRAM NAME CHANGED FROM LTSEL___ TO LTDRV___*
007600*                                                              *
007700*--------------------------------------------------------------*
007800*                                                              *
007900*   05/03/2006 - MODIFY PROGRAM FOR JULY 2006 RELEASE:         *
008000*                ADD LTCAL071 CALL, ADD IPPS CBSA WAGE INDEX   *
008100*                TABLE STORAGE & LOGIC.  DELETED LAYOUT FOR    *
008200*                W-PROV-NEW-HOLD - NOT NEEDED.                 *
008300*                IPPS WAGE INDEX LOGIC: ONLY THE IPPS CBSA     *
008400*                FLOOR POLICY IS APPLIED WHEN ASSIGNING THE    *
008500*                IPPS WAGE INDEX.  PUERTO RICO HOSPITALS ARE   *
008600*                GIVEN THE NATIONAL AND PUERTO RICO SPECIFIC   *
008700*                WAGE INDEX VALUES.                            *
008800*                                                              *
008900*--------------------------------------------------------------*
009000*                                                              *
009100*   06/15/2006 - CHANGE THE PLACEMENT OF THE MOVE OF THE PSF   *
009200*                CBSA TO THE IPPS CBSA HOLD AREA & REMOVE THAT *
009300*                MOVE FROM THE IPPS PR SEARCH LOGIC.           *
009400*                                                              *
009500*--------------------------------------------------------------*
009600*                                                              *
009700*   06/19/2006 - CHANGE THE VERSION FROM 07.0 TO 07.1          *
009800*                                                              *
009900*--------------------------------------------------------------*
010000*                                                              *
010100*   08/04/2006 - UPDATE PROGRAM FOR OCTOBER 2006 RELEASE 07.3  *
010200*                ADD FY 2007 FLOOR IF STATEMENT                *
010300*                STILL NEED TO ADD FLOOR CODE                  *
010400*                NEW VERSIONS OF LTCAL CALLED DUE TO THE SIZE  *
010500*                CHANGE OF THE FIELD: PPS-NEW-FAC-SPEC-RATE    *
010600*                FROM 9(5)V9(02) TO 9(7)V9(2).                 *
010700*                                                              *
010800*--------------------------------------------------------------*
010900*                                                              *
011000*   08/08/2006 - BECAUSE THE FY 2007 WAGE INDEX TABLE WILL NOT *
011100*                BE FINAL UNTIL LATE AUGUST, THE FOLLOWING     *
011200*                ITEMS ARE NOT INCLUDED IN VERSION 7.3 OF THE  *
011300*                LTCH PRICER:                                  *
011400*                                                              *
011500*                1) FY 2007 IPPS WAGE INDEX TABLE              *
011600*                2) FY 2007 IPPS WAGE INDEX FLOORS             *
011700*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *
011800*                4) FY 2007 IPPS STANDARD RATES:               *
011900*                    H-IPPS-CAPI-STD-FED-RATE  (LTCAL073)      *
012000*                    H-IPPS-CAPI-STD-PR-RATE   (LTCAL073)      *
012100*                                                              *
012200*                FOR TESTING PURPOSES, THE FOLLOWING           *
012300*                SUBSTITUTES WERE MADE:                        *
012400*                                                              *
012500*                1) THE FY 2006 IPPS WAGE INDEX TABLE VERSION  *
012600*                   06.3 WILL BE USED IN PLACE OF THE FY 2007  *
012700*                   IPPS WAGE INDEX TABLE.                     *
012800*                2) THERE IS NO MODULE THAT ASSIGNS FY 2007    *
012900*                   IPPS WAGE INDEX FLOORS.  THE CODE THAT     *
013000*                   REFERENCES THIS FUTURE MODULE IS COMMENTED *
013100*                   OUT.                                       *
013200*                3) THE CURRENT FY 2007 DRG WEIGHTS ARE USED.  *
013300*                   THESE MAY OR MAY NOT CHANGE.               *
013400*                4) THE FY 2006 IPPS STANDARD RATES ARE USED.  *
013500*                                                              *
013600*--------------------------------------------------------------*
013700*                                                              *
013800*   08/09/2006 - DELETED RETURN CODES 02 & 03 AND ADDED CODES  *
013900*                20, 21, 22, 23, 24, & 25 FOR SHORT STAY       *
014000*                PAYMENT DESCRIPTIONS IN PROGRAM LTCAL073.     *
014100*                                                              *
014200*--------------------------------------------------------------*
014300*                                                              *
014400*   09/06/2006 - CREATE VERSION 07.4 OF THE LTCH PPS PRICER    *
014500*                UPDATED WITH THE FOLLOWING:                   *
014600*                1) FY 2007 IPPS WAGE INDEX TABLE              *
014700*                2) FY 2007 IPPS WAGE INDEX FLOORS             *
014800*                3) FINAL FY 2007 IPPS DRG WEIGHTS             *
014900*                4) FY 2007 IPPS STANDARD RATES (LTCAL074)     *
015000*                                                              *
015100*--------------------------------------------------------------*
015200*                                                              *
015300*   11/16/2006 - CREATE VERSION 07.5 OF THE LTCH PPS PRICER    *
015400*                UPDATED WITH THE FOLLOWING:                   *
015500*                1) IME MULTIPLIER IN PROGRAM LTCAL075 CHANGED *
015600*                   FROM 1.37 TO 1.32 (TO MATCH FY2007 IPPS)   *
015700*                2) PPS RETURN CODE 23 REMOVED FROM LTCAL075   *
015800*                   BECAUSE IT COULD NEVER BE REACHED          *
015900*                3) REMOVED CBSA 27860 FROM THE FY 2007 FLOOR  *
016000*                   CODE (DUE TO IPPS CN1 WAGE INDEX CHANGE)   *
016100*                                                              *
016200*--------------------------------------------------------------*
016300*                                                              *
016400*   12/28/2006 - CREATE VERSION 07.6 OF THE LTCH PPS PRICER    *
016500*                TO CORRECT THE CBSA SIZE LOGIC.  ALWAYS USE   *
016600*                THE GEOGRAPHIC CBSA'S SIZE; STOP USING THE    *
016700*                RURAL FLOOR CBSA'S SIZE.  ALSO, CBSA 27860    *
016800*                WAS REINSTATED INTO THE FLOOR LOGIC, IGNORED  *
016900*                11/03/2006 AND AFTER.                         *
017000*                *** THIS VERSION WAS NOT RELEASED ***         *
017100*                THE NEW LOGIC IS INTRODUCED IN VERSION 08.0.  *
017200*                                                              *
017300*--------------------------------------------------------------*
017400*                                                              *
017500*   05/03/2007 - CREATE VERSION 08.0 OF THE LTCH PPS PRICER    *
017600*                UPDATED WITH THE FOLLOWING:                   *
017700*                1) LTCH WAGE INDEX TABLE - 4/5 & 5/5 COLUMNS  *
017800*                2) LTCH RATES (LTCAL080)                      *
017900*                3) NEW SSO POLICY (IPPS COMPARABLE AMT)       *
018000*                4) 25% RULE (NOT APPLIED IN PRICER)           *
018100*                5) NEW RETURN CODES 26 & 27                   *
018200*                6) NEW IPPS COMPARABLE THRESHOLD COLUMN IN    *
018300*                   DRG TABLE                                  *
018400*                7) WAGE INDEX SELECTION CODE UPDATED          *
018500*                                                              *
018600*--------------------------------------------------------------*
018700*                                                              *
018800*   08/10/2007 - CREATE VERSION 08.1 OF THE LTCH PPS PRICER    *
018900*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
019000*                1) LTCH DRG TBL (W/ NEW IPPS COMP THRESHOLDS) *
019100*                2) IPPS DRG TABLE                             *
019200*                3) IPPS WAGE INDEX TABLE                      *
019300*                4) IPPS RATES (IN LTCAL081)                   *
019400*                5) IPPS WAGE INDEX FLOORS                     *
019500*                6) NEW OPERATING IME FACTOR (1.35)            *
019600*                7) 3% LARGE URBAN ADD-ON ELIMINTATED          *
019700*                8) CHANGED MESSAGE FOR RETURN CODE 98         *
019800*                                                              *
019900*--------------------------------------------------------------*
020000*                                                              *
020100*   08/22/2007 - CREATE VERSION 08.2 OF THE LTCH PPS PRICER    *
020200*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
020300*                1) REVISED IPPS WAGE INDEX TABLE              *
020400*                2) REVISED IPPS RATES (IN LTCAL082)           *
020500*                VERSION 08.2 REPLACES VERSION 08.1            *
020600*                                                              *
020700*--------------------------------------------------------------*
020800*                                                              *
020900*   09/14/2007 - CREATE VERSION 08.3 OF THE LTCH PPS PRICER    *
021000*                UPDATED WITH THE FOLLOWING FY 2008 ITEMS:     *
021100*                1) REVISED IPPS WAGE INDEX TABLE              *
021200*                2) REVISED IPPS RATES (IN LTCAL083)           *
021300*                VERSION 08.3 REPLACES VERSION 08.2            *
021400*                                                              *
021500*--------------------------------------------------------------*
021600*                                                              *
021700*   09/28/2007 - CREATE VERSION 08.4 OF THE LTCH PPS PRICER    *
021800*                UPDATED WITH CONGRESS MANDATED REVISION OF    *
021900*                IPPS RATES (IN LTCAL084)                      *
022000*                VERSION 08.4 REPLACES VERSION 08.3            *
022100*                                                              *
022200*--------------------------------------------------------------*
022300*                                                              *
022400*   12/27/2007 - CREATE VERSION 08.5 OF THE LTCH PPS PRICER    *
022500*                5TH SHORT STAY OUTLIER PROVISION NO LONGER    *
022600*                AVAILABLE TO BILLS DISCHARGED ON AND AFTER    *
022700*                12/29/2007 PER A CONGRESS MANDATE             *
022800*                UPDATED LTCAL085 TO REFLECT THIS CHANGE       *
022900*                                                              *
023000*--------------------------------------------------------------*
023100*                                                              *
023200*   02/06/2008 - CREATE VERSION 08.6 OF THE LTCH PPS PRICER    *
023300*                EFFECTIVE OCT 1, 2007 (REPLACES VERSION 08.5) *
023400*                CHANGES EFFECTIVE APRIL 1, 2008:              *
023500*                 1) CHANGED LTCH STANDARD FEDERAL RATE FROM   *
023600*                    $38,356.45 TO $38,086.04 IN PGM LTCAL086  *
023700*                 2) CHANGED FIXED LOSS AMOUNT FROM $20,738.00 *
023800*                    TO $20,707.00 IN PROGRAM LTCAL086         *
023900*                THESE CHANGES WERE MADE IN ACCORD WITH        *
024000*                SECTION 114(E)(2) AND (3) OF THE MEDICARE,    *
024100*                MEDICAID AND SCHIP EXTENSION ACT OF 2007,     *
024200*                ENACTED ON DECEMBER 29, 2007.                 *
024300*                                                              *
024400*--------------------------------------------------------------*
024500*                                                              *
024600*   05/08/2008 - CREATE VERSION 09.0 OF THE LTCH PPS PRICER    *
024700*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *
024800*                CHANGES EFFECTIVE JULY 1, 2008:               *
024900*                - NEW WAGE INDEX TABLE W/ 1 WAGE INDEX COLUMN *
025000*                - ALL CLAIMS RECEIVE THE FULL WAGE INDEX      *
025100*                  REGARDLESS OF ITS PROVIDER FY BEGIN DATE    *
025200*                - ALL SHORT STAY CLAIMS ELIGIBLE FOR THE      *
025300*                  BLENDED PAYMENT, NO CLAIMS ELIGIBLE FOR     *
025400*                  THE IPPS COMPARABLE PAYMENT                 *
025500*                - NEW LTCH RATES                              *
025600*                - DISABLE CALL TO LTCAL042 (5 YEAR RULE)      *
025700*                                                              *
025800*--------------------------------------------------------------*
025900*                                                              *
026000*   05/19/2008 - CREATE VERSION 09.1 OF THE LTCH PPS PRICER    *
026100*                EFFECTIVE JULY 1, 2008 (FY 2008, RY 2009)     *
026200*                CHANGED IPPS PUERTO RICO RATES EFFECTIVE      *
026300*                RETROACTIVE TO 10/01/2007.  CREATED TWO NEW   *
026400*                LTCAL MODULES FOR THIS CHANGE:                *
026500*                1) LTCAL087: FOR CLAIMS DISCHARGED            *
026600*                   10/01/2007 - 06/30/2008, REPLACED LTCAL086 *
026700*                2) LTCAL091: FOR CLAIMS DISCHARGED            *
026800*                   07/01/2008 & AFTER, REPLACED LTCAL090      *
026900*                                                              *
027000*--------------------------------------------------------------*
027100*                                                              *
027200*   08/04/2008 - CREATE VERSION 09.2 OF THE LTCH PPS PRICER    *
027300*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *
027400*                UPDATED WITH THE FOLLOWING FY 2009 ITEMS:     *
027500*                1) LTCH DRG TBL (NO IPPS COMP THRESHOLDS)     *
027600*                2) IPPS DRG TABLE                             *
027700*                3) IPPS RATES (IN LTCAL092)                   *
027800*                4) OPERATING IME FACTOR (STILL 1.35)          *
027900*                5) FY 2009 FLOOR IF STATEMENT & PARAGRAPH     *
028000*                   USING FY 2008 FLOOR ASSIGNMENTS            *
028100*                                                              *
028200*                THE FOLLOWING FY 2009 UPDATES WERE NOT MADE   *
028300*                IN THIS VERSION BECAUSE THEY ARE NOT YET      *
028400*                AVAILABLE.  A NEW PRICER WILL BE RELEASED TO  *
028500*                INCLUDE THESE ITEMS.                          *
028600*                1) IPPS WAGE INDEX TABLE                      *
028700*                2) IPPS WAGE INDEX FLOORS                     *
028800*                                                              *
028900*                FOR TESTING PURPOSES, THE FOLLOWING           *
029000*                SUBSTITUTIONS WERE MADE:                      *
029100*                1) THE FY 2008 IPPS WAGE INDEX TABLE IS USED  *
029200*                   IN PLACE OF THE FY 2009 TABLE.             *
029300*                2) THE FY 2008 WAGE INDEX FLOORS ARE USED     *
029400*                   IN PLACE OF THE FY 2009 FLOORS.            *
029500*                                                              *
029600*--------------------------------------------------------------*
029700*                                                              *
029800*   08/11/2008 - COMMENTED OUT REFERENCES TO THE IPPS          *
029900*                COMPARABLE THRESHOLD IN LTCAL092 BECAUSE      *
030000*                SHORT STAY CLAIMS ARE NO LONGER ELIGIBLE      *
030100*                FOR THE IPPS COMPARABLE PER DIEM AND,         *
030200*                THEREFORE, THE IPPS THRESHOLD IS NOT INCLUDED *
030300*                IN THE LTCH DRG TABLE FOR FY 2009.  RETURN    *
030400*                CODES 26 & 27 WILL NO LONGER BE RETURNED.     *
030500*                ADDED FIELD P-VAL-BASED-PURCH-SCORE TO THE    *
030600*                PSF LAYOUT (TO BE USED IN IPPS 1/1/2008).     *
030700*                                                              *
030800*--------------------------------------------------------------*
030900*                                                              *
031000*   08/14/2008 - REDUCE H-CAPI-IME-TEACH ROUNDED BY 50%        *
031100*                IN LTCAL092.                                  *
031200*                                                              *
031300*                                                              *
031400*--------------------------------------------------------------*
031500*                                                              *
031600*   08/15/2008 - ADDED STATE SPECIFIC RURAL FLOOR BUDGET       *
031700*                NEUTRALITY (SSRFBN) TABLE AND LOGIC TO        *
031800*                LTCAL092 FOR FY 2009.                         *
031900*              - ADDED NEW RETURN CODE FOR SSRFBN LOGIC:       *
032000*                68 = PROVIDER SPECIFIC STATE CODE INVALID     *
032100*                                                              *
032200*--------------------------------------------------------------*
032300*                                                              *
032400*   09/09/2008 - CREATE VERSION 09.3 OF THE LTCH PPS PRICER    *
032500*                EFFECTIVE OCTOBER 1, 2008 (FY 2009, RY 2009)  *
032600*                REPLACES VERSION 09.2                         *
032700*                ADDED THE FOLLOWING ITEMS IN THIS VERSION:    *
032800*                - FY 2009 IPPS CBSA WAGE INDEX TABLE          *
032900*                  CHANGED NEW CBSA 14600 TO 42260 FOR LTCH    *
033000*                - FY 2009 IPPS RURAL FLOOR ASSIGNMENT CODE    *
033100*                - REVISED FY 2009 IPPS STANDARD RATES         *
033200*                - REVISED FY 2009 IPPS RFBN FACTOR TABLE      *
033300*                                                              *
033400*--------------------------------------------------------------*
033500*                                                              *
033600*   09/12/2008 - REVISED SSRFBN LOGIC IN LTCAL093 TO EXCLUDE   *
033700*                SPECIAL WAGE INDICES ENTERED INTO THE PSF     *
033800*                FROM THE SSRFBN ADJUSTMENT                    *
033900*                                                              *
034000*--------------------------------------------------------------*
034100*                                                              *
034200*   02/17/2009 - CREATE VERSION 09.4 OF THE LTCH PPS PRICER    *
034300*                EFFECTIVE RETROACTIVE BACK TO 10/01/2008      *
034400*                TO CONFORM TO ECONOMIC STIMULUS BILL SIGNED   *
034500*                02/17/2009, THE H-CAPI-IME-TEACH AMOUNT       *
034600*                CALCULATED IN PROGRAM LTCAL094 IS NO LONGER   *
034700*                REDUCED BY 50%.  NOW PAY 100% CAPITAL IME.    *
034800*                THIS VERSION REPLACES VERSION 09.3.           *
034900*                                                              *
035000*--------------------------------------------------------------*
035100*                                                              *
035200*   05/18/2009 - CREATE VERSION 09.5 OF THE LTCH PPS PRICER    *
035300*                EFFECTIVE 06/03/2009                          *
035400*                - ADDED NEW LTCH DRG WEIGHT TABLE (LTDRG095)  *
035500*                  AND CALCULATION PROGRAM (LTCAL095)          *
035600*                  NEW TABLE HAS CORRECTED WEIGHTS AND IS USED *
035700*                  TO PROCESS CLAIMS DISCHARGED ON AND AFTER   *
035800*                  JUNE 3, 2009 THROUGH SEPTEMBER 30, 2009     *
035900*                                                              *
036000*--------------------------------------------------------------*
036100*                                                              *
036200*   08/04/2009 - CREATE VERSION 10.0 OF THE LTCH PPS PRICER    *
036300*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
036400*                - STARTING THIS YEAR, THE RATE YEAR AND       *
036500*                  FISCAL YEAR BOTH START ON OCTOBER 1ST       *
036600*                - THERE ARE NO POLICY OR FORMULA CHANGES      *
036700*                - RATE YEAR 2005 ITEMS REMOVED FROM PACKAGE   *
036800*                UPDATED WITH THE FOLLOWING FY 2010 ITEMS:     *
036900*                1) LTCH DRG TBL                               *
037000*                2) LTCH CBSA WAGE INDEX TABLE                 *
037100*                3) IPPS DRG TBL                               *
037200*                4) IPPS CBSA WAGE INDEX TABLE                 *
037300*                5) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
037400*                   NEUTRALITY (SSRFBN) FACTOR TABLE           *
037500*                6) IPPS CBSA WAGE INDEX FLOOR ASSIGNMENT LOGIC*
037600*                7) LTCH STANDARD RATES IN PROGRAM LTCAL100    *
037700*                8) IPPS STANDARD RATES IN PROGRAM LTCAL100    *
037800*                                                              *
037900*--------------------------------------------------------------*
038000*                                                              *
038100*   09/03/2009 - CREATE VERSION 10.1 OF THE LTCH PPS PRICER    *
038200*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
038300*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
038400*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX101)      *
038500*                2) IPPS CAPITAL RATES IN PROGRAM LTCAL101     *
038600*                                                              *
038700*--------------------------------------------------------------*
038800*                                                              *
038900*   11/11/2009 - CREATE VERSION 10.2 OF THE LTCH PPS PRICER    *
039000*                EFFECTIVE 10/01/2009 (FY 2010, RY 2010)       *
039100*                REPLACES VERSION 10.1                         *
039200*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
039300*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX103)      *
039400*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
039500*                   NEUTRALITY (SSRFBN) FACTOR TABLE (IRFBN102)*
039600*                   (KANSAS RFBN CORRECTED - CHANGED FROM      *
039700*                    0.99826 TO 0.99829)                       *
039800*                                                              *
039900*--------------------------------------------------------------*
040000*                                                              *
040100*   04/07/2010 - CREATE VERSION 10.3 OF THE LTCH PPS PRICER    *
040200*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *
040300*                REPLACES VERSION 10.2                         *
040400*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
040500*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX104)      *
040600*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
040700*                   NEUTRALITY TABLE (IRFBN105)                *
040800*                3) IPPS DRG TABLE (IPDRG104)                  *
040900*                4) LTCH STANDARD RATES IN PROGRAM LTCAL104    *
041000*                5) IPPS STANDARD RATES IN PROGRAM LTCAL104    *
041100*                                                              *
041200*--------------------------------------------------------------*
041300*                                                              *
041400*   04/19/2010 - CREATE VERSION 10.4 OF THE LTCH PPS PRICER    *
041500*                EFFECTIVE 10/01/2010 (FY 2010, RY 2010)       *
041600*                REPLACES VERSION 10.3                         *
041700*                UPDATED W/ THE FOLLOWING REVISED FY2010 ITEMS:*
041800*                1) LTCH STANDARD RATES IN PROGRAM LTCAL105    *
041900*                2) IPPS STANDARD RATES IN PROGRAM LTCAL105    *
042000*                                                              *
042100*--------------------------------------------------------------*
042200*                                                              *
042300*   08/04/2010 - CREATE VERSION 11.0 OF THE LTCH PPS PRICER    *
042400*                EFFECTIVE 10/01/2010 (FY 2011, RY 2011)       *
042500*                REPLACES VERSION 10.4                         *
042600*                UPDATED W/ THE FOLLOWING REVISED FY2011 ITEMS:*
042700*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX110)      *
042800*                2) IPPS STATE SPECIFIC RURAL FLOOR BUDGET     *
042900*                   NEUTRALITY TABLE (IRFBN110)                *
043000*                3) IPPS DRG TABLE (IPDRG110)                  *
043100*                4) LTCH STANDARD RATES IN PROGRAM LTCAL110    *
043200*                5) IPPS STANDARD RATES IN PROGRAM LTCAL110    *
043300*                                                              *
043400*--------------------------------------------------------------*
043500*                                                              *
043600*   08/13/2010 - CORRECTED FY 2008 - FY 2011 FLOOR LOGIC TO    *
043700*                REFERENCE THE IPPS CBSA INSTEAD OF THE LTCH   *
043800*                CBSA (TAMARA HOWARD)                          *
043900*                                                              *
044000*--------------------------------------------------------------*
044100*                                                              *
044200*   10/19/2010 - CHANGED TO ALLOW ADJUSTMENTS TO CLAIMS WITH   *
044300*                DATES OF SERVICE OLDER THAN 5 YEARS           *
044400*--------------------------------------------------------------*
044500*                                                              *
044600*   08/01/2011 - CREATE VERSION 12.0 OF THE LTCH PPS PRICER    *
044700*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
044800*                REPLACES VERSION 11.1                         *
044900*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
045000*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX120)      *
045100*                2) IPPS DRG TABLE (IPDRG120)                  *
045200*                3) LTCH STANDARD RATES IN PROGRAM LTCAL120    *
045300*                4) IPPS STANDARD RATES IN PROGRAM LTCAL120    *
045400*                                                              *
045500*--------------------------------------------------------------*
045600*                                                              *
045700*   08/31/2011 - CREATE VERSION 12.1 OF THE LTCH PPS PRICER    *
045800*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
045900*                REPLACES VERSION 12.0                         *
046000*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
046100*                1) IPPS CBSA WAGE INDEX TABLE (IPWIX121)      *
046200*                2) IPPS DRG TABLE (IPDRG121)                  *
046300*                3) LTCH CBSA WAGE INDEX TABLE (LTWIX121)      *
046400*--------------------------------------------------------------*
046500*                                                              *
046600*   10/28/2011 - CREATE VERSION 12.2 OF THE LTCH PPS PRICER    *
046700*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
046800*                REPLACES VERSION 12.1                         *
046900*                UPDATED W/ THE FOLLOWING REVISED FY2012 ITEMS:*
047000*                1) LTCH DRG TABLE (IPDRG122)                  *
047100*                                                              *
047200*--------------------------------------------------------------*
047300*                                                              *
047400*   12/09/2011 - CREATE VERSION 12.3 OF THE LTCH PPS PRICER    *
047500*                EFFECTIVE 10/01/2011 (FY 2012, RY 2012)       *
047600*                REPLACES VERSION 12.2                         *
047700*                REVISED FY 2012 IPPS WAGE INDEX FLOOR         *
047800*                                                              *
047900*--------------------------------------------------------------*
048000*                                                              *
048100*   07/30/2012 - CREATE VERSION 13.0 OF THE LTCH PPS PRICER    *
048200*                EFFECTIVE 10/01/2012 (FY 2013, RY 2013)       *
048300*                REPLACES VERSION 12.3                         *
048400*                UPDATED W/ THE FOLLOWING REVISED FY2013 ITEMS:*
048500*                1) LTCH WAGE INDEX TABLE (LTWIX130)           *
048600*                2) LTCH DRG TABLE (LTDRG130)                  *
048700*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX130)      *
048800*                4) IPPS DRG TABLE (IPDRG130)                  *
048900*                5) LTCH STANDARD RATES IN PROGRAM LTCAL130    *
049000*                6) IPPS STANDARD RATES IN PROGRAM LTCAL130    *
049100*                                                              *
049200*--------------------------------------------------------------*
049300*                                                              *
049400*   11/16/2012 - IN VERSION 13.0 OF THE LTCH PPS PRICER        *
049500*                CHANGED "T-CBSA-DATA  OCCURS 0 TO 4000 TIMES" *
049600*                     TO "T-CBSA-DATA  OCCURS 0 TO 7000 TIMES" *
049700*                FOR IPPS-CBSA-WI-TABLE IN RESPONSE TO         *
049800*                HPAR CR8041H2 (R41212).  NO VERSION NUMBERS   *
049900*                CHANGED AND ONLY MODULES LTDRV130 AND         *
050000*                LTOPN130 CHANGED AS DESCRIBED ABOVE.          *
050100*                                                              *
050200*--------------------------------------------------------------*
050300*                                                              *
050400*   08/08/2013 - CREATE VERSION 14.0 OF THE LTCH PPS PRICER    *
050500*                EFFECTIVE 10/01/2013 (FY 2014, RY 2014)       *
050600*                REPLACES VERSION 13.0                         *
050700*                UPDATED W/ THE FOLLOWING REVISED FY2014 ITEMS:*
050800*                1) LTCH WAGE INDEX TABLE (LTWIX140)           *
050900*                2) LTCH DRG TABLE (LTDRG140)                  *
051000*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX140)      *
051100*                4) IPPS DRG TABLE (IPDRG140) - NEW TABLE      *
051200*                   LAYOUT & SEARCH LOGIC IN LTCAL140          *
051300*                5) LTCH STANDARD RATES IN PROGRAM LTCAL140    *
051400*                6) IPPS STANDARD RATES IN PROGRAM LTCAL140    *
051500*                7) ADDED HOSPITAL QUALITY INDICATOR TO PSF    *
051600*                8) ADDED OPERATING DSH PAYMENT REDUCTION FOR  *
051700*                   UNCOMPENSATED CARE PAYMENT IN LTCAL140     *
051800*                                                              *
051900*--------------------------------------------------------------*
052000*                                                              *
052100*   09/03/2013 - CREATE VERION 141 TO INCORPORATE THE NEW LTCH *
052200*                AND PPS WAGE INDEX TABLES                     *
052300*                                                              *
052400*--------------------------------------------------------------*
052500*                                                              *
052600*   08/06/2014 - CREATE VERSION 15.0 OF THE LTCH PPS PRICER    *
052700*                EFFECTIVE 10/01/2014 (FY 2015)                *
052800*                REPLACES VERSION 14.1                         *
052900*                UPDATED W/ THE FOLLOWING REVISED FY2015 ITEMS:*
053000*                1) LTCH WAGE INDEX TABLE (LTWIX150)           *
053100*                2) LTCH DRG TABLE (LTDRG150)                  *
053200*                3) IPPS CBSA WAGE INDEX TABLE (IPWIX150)      *
053300*                4) IPPS DRG TABLE (IPDRG150)                  *
053400*                5) LTCH STANDARD RATES IN PROGRAM LTCAL150    *
053500*                6) IPPS STANDARD RATES IN PROGRAM LTCAL150    *
053600*                7) IPPS BLENDED WAGE INDEX TABLE              *
053700*                   (BLEND150) - NEW FOR FY 2015               *
053800*                8) NEW LOGIC IN LTCAL150 TO USE THE IPPS CBSA *
053900*                   BLENDED WAGE INDEX IN TABLE BLEND150       *
054000*                   FOR ALL PROVIDERS IN THAT TABLE            *
054100*                9) NEW LOGIC TO ASSIGN IPPS CBSA WAGE INDEX   *
054200*                   FLOORS IN LTDRV150                         *
054300*               10) CORRECTED DATE RANGES FOR FYS 2011 - 2014  *
054400*                   RURAL FLOOR ASSIGNMENT LOGIC IN LTDRV150   *
054500*               11) CORRECTED FY 2014 RURAL FLOOR LOGIC TO     *
054600*                   CHANGE THE IPPS CBSA INSTEAD OF THE LTCH   *
054700*                   CBSA IN LTDRV150                           *
054800*               12) INCREASE SIZE OF LTCH CBSA TABLE FROM      *
054900*                   4,000 TO 7,000                             *
055000*                                                              *
055100*--------------------------------------------------------------*
055200*                                                              *
055300*   08/28/2014 - CREATE VERSION 15.1 OF THE LTCH PPS PRICER    *
055400*                EFFECTIVE 10/01/2014 (FY 2015)                *
055500*                REPLACES VERSION 15.0                         *
055600*              - ADDED CONDITIONS TO THE CBSA WAGE INDEX       *
055700*                SEARCH TO ONLY SELECT THE WAGE INDEX IF ITS   *
055800*                EFFECTIVE DATE IS WITHIN THE SAME FY AS THE   *
055900*                THE CLAIM'S DISCHARGE DATE. CODE WAS CHANGED  *
056000*                IN THE FOLLOWING THREE PLACES:                *
056100*                - NATIONAL LTCH WAGE INDEX SEARCH,            *
056200*                - NATIONAL IPPS WAGE INDEX SEARCH, AND        *
056300*                - PUERTO RICO IPPS WAGE INDEX SEARCH.         *
056400*              - MOVED LOGIC THAT ASSIGNS THE SPECIAL WAGE     *
056500*                INDEX WHEN APPLICABLE FROM LTCAL151 TO        *
056600*                LTDRV151 (0550-GET-CBSA).                     *
056700*              - MODIFIED SPECIAL WAGE INDEX ASSIGNMENT LOGIC  *
056800*                TO ONLY SELECT THE WAGE INDEX IF THE PSF      *
056900*                RECORD'S EFFECTIVE DATE FALLS WITHIN THE      *
057000*                CLAIM'S FISCAL YEAR (0550-GET-CBSA).          *
057100*              - ADDED LOGIC TO INITIALIZE LTCH AND IPPS WAGE  *
057200*                INDEX TABLES AND HOLD CBSA FIELDS             *
057300*              - ADDED LOGIC TO SET RTC TO 52 IF THE THIRD     *
057400*                COLUMN OF THE LTCH CBSA WAGE INDEX IS ZERO    *
057500*                                   *
057600*--------------------------------------------------------------*
057700*                                                              *
057800* 11/20/14 - VERSION 15.2 CREATED TO ADDRESS A PROBLEM         *
057900*   REPORTED BY FISS WHERE A CLAIM DATED 12/31/2007 RECEIVES   *
058000*   UNEXPECTED WAGE INDEX ERROR (RTC 52).                      *
058100*                                                              *
058200* ADDED CONDITION TO PROCEDURE 0650-N-GET-WAGE-INDX SO THAT TO *
058300* SELECT THE WAGE INDEX, IT MUST BE A CBSA WITH AN EFFECTIVE   *
058400* DATE ON OR BEFORE THE CLAIM DISCHARGE DATE AND A CLAIM       *
058500* DISCHARGE DATE ON OR BEFORE 09/30/2009                       *
058600*                                                              *
058700* THE CODE ADDED IS AS FOLLOWS:                                *
058800*   (B-DISCHARGE-DATE <= 20090930) OR                          *
058900*                                                              *
059000*--------------------------------------------------------------*
059100*                                                              *
059200* 03/16/15 - VERSION 15.3 CREATED TO ADD NEW DATA NAMES.       *
059300* THE FIRST STAGE OF BUILDING THE FY 2016 LTCH PRICER.         *
059400* WAS BUILT TO TEST THE CHANGES IN THE DATA LAYOUT, AND        *
059500* ONLY MADE CHANGES TO THE DRIVER MODULE (LTDRV153)            *
059600*                                                              *
059700*--------------------------------------------------------------*
059800* 06/11/15 - VERSION 16.B CREATED TO ADD NEW LOGIC.            *
059900* THE SECOND STAGE OF BUILDING THE FY 2016 LTCH PRICER.        *
060000* DONE IN ORDER TO GIVE THE PROGRAMMERS MORE TIME              *
060100* TO BE ABLE TO CREATE THE LOGIC AND TEST IT WITHOUT HAVING TO *
060200* FIRST GET THE FY 2016 RATES.                                 *
060300*                                                              *
060400*--------------------------------------------------------------*
060500*                                                              *
060600*   08/04/2015 - CREATE VERSION 16.0 OF THE LTCH PPS PRICER    *
060700*                EFFECTIVE 10/01/2015 (FY 2016)                *
060800*                REPLACES VERSION 15.3                         *
060900*              - ADDED NEW STATE CODES FOR RURAL FLOOR WAGE    *
061000*                INDEX LOGIC (TO BE USED STARTING APRIL 2016)  *
061100*              - CORRECTED CRITERIA TO SEARCH FOR CBSA SIZE    *
061200*              - ROUTINE FISCAL YEAR UPDATES TO VERSION AND    *
061300*                NEW CALL TO LTCAL160                          *
061400*                                                              *
061500*--------------------------------------------------------------*
061600*                                                              *
061700*   11/25/2015 - CREATE VERSION 16.C OF THE LTCH PPS PRICER    *
061800*                EFFECTIVE 04/01/2016 (FY 2016)                *
061900*                ** BETA VERSION FOR APRIL 2016 TESTING **     *
062000*              - ADDED NEW STATE CODES FOR RURAL FLOOR WAGE    *
062100*                INDEX LOGIC (TO BE USED STARTING APRIL 2016)  *
062200*                (ADDITIONAL CODES 95, 96, & 97)               *
062300*              - CREATED LTCAL15C TO PROCESS CLAIMS DISCHARGED *
062400*                01/01/2015 - 09/30/2015.                      *
062500*              - CREATED LTCAL16C TO PROCESS CLAIMS DISCHARGED *
062600*                10/01/2015 - 09/30/2016.                      *
062700*              - ADDED NEW COST REPORT DAYS VARIABLE TO INPUT  *
062800*                RECORD TO PRICE SUBCLAUSE (II) LTCH PAYMENTS  *
062900*                (LTDRV16C, LTCAL15C, LTCAL16C)                *
063000*              - NEW CALLS TO LTCAL15C & LTCAL16C              *
063100*              - ALTERED CALL TO LTCAL152 TO PROCESS CLAIMS    *
063200*                DISCHARGED 10/01/2014 - 12/31/2014.           *
063300*                                                              *
063400*--------------------------------------------------------------*
063500*                                                              *
063600*   12/11/2015 - VERSION 16.1 EFFECTIVE APRIL 1, 2016          *
063700*                DUE TO CR 9401                                *
063800*                                                              *
063900*--------------------------------------------------------------*
064000*                                                              *
064100*   01/28/2016 - VERSION 16.2 EFFECTIVE APRIL 1, 2016          *
064200*              - CHANGE TO CALL LTCAL162                       *
064300*              - LTCAL162 UPDATED DUE TO CR 9300 AND CR 9527   *
064400*                                                              *
064500* JUNE 20, 2016 - FOR VERSION 17.B CHANGED THE FOLLOWING:      *
064600*                                                              *
064700*   1.THE LAYOUT OF THE PROVIDER RECORD TO INCLUDE A           *
064800*        STATE CODE.                                           *
064900*      - REPLACE 05 FILLER PIC X(05). ON LINE 76 OF            *
065000*        PROV-NEW-HOLD WITH THE FOLLOWING:                     *
065100*             05  P-NEW-STATE-CODE           PIC 9(02).        *
065200*             05  P-NEW-STATE-CODE-X REDEFINES                 *
065300*                   P-NEW-STATE-CODE         PIC X(02).        *
065400*             05  FILLER                     PIC X(03).        *
065500*   2.THE LOGIC OF THE DRIVER MODULE TO MOVE THE NEW           *
065600*     STATE CODE INTO THE SEARCH VARIABLE AND TO               *
065700*     COMMENT-OUT THE LINES OF CODE THAT DO THE                *
065800*     FLOOR ASSIGNMENTS.                                       *
065900*   3.ADDED COBOL CODE TO ALLOW THE LTCH PRICER TO WORK WITH   *
066000*     THE NEW ARIZONA STATE CODE OF '00'                       *
066100*                                                              *
066200* 8-9-16 - VERSION 17.0                                        *
066300*  - MADE ANNUAL UPDATE                                        *
066400*  - ADDED CALL TO LTCAL170                                    *
066500*  - CHANGED TO NO LONGER GET THE PUERTO RICO SPECIFIC WAGE    *
066600*    INDEX FOR PR HOSPITALS BEGINNING FY 2016                  *
066700*                                                              *
066800* 8-8-17 - VERSION 18.0                                        *
066900*  - MADE ANNUAL UPDATE                                        *
067000*  - ADDED CALL TO LTCAL180                                    *
067100*                                                              *
067200* 9-21-17 - VERSION 18.1                                       *
067300*  - CHANGE TO CALL LTCAL181 INSTEAD OF LTCAL180               *
067400*                                                              *
067500* 10-20-17 - VERSION 18.2 - IMPLEMENTATION DATE = 1/1/18.      *
067600*  CR10368 - OFF-CYCLE UPDATE TO THE LONG TERM CARE HOSPITAL   *
067700*  (LTCH) PROSPECTIVE PAYMENT SYSTEM (PPS) FISCAL YEAR (FY)    *
067800*  2018 PRICER.                                                *
067900*  UPDATED LTCH WAGE INDEX.                                    *
068000*                                                              *
068100* 3-8-18 - VERSION 18.3 - IMPLEMENTATION DATE = 1/1/18         *
068200*  - CHANGE TO CALL LTCAL183                                   *
068300*  - IMPLEMENTS CR10547 - INPATIENT PROSPECTIVE PAYMENT SYSTEM *
068400*  (IPPS) AND LONG-TERM CARE HOSPITAL (LTCH) PER THE ADVANCING *
068500*  CHRONIC CARE, EXTENDERS, AND SOCIAL SERVICES (ACCESS) ACT   *
068600*  INCLUDED IN THE BIPARTISAN BUDGET ACT OF 2018.              *
068700*                                                              *
068800* 7-30-18 - VERSION 19.0 - IMPLEMENTATION DATE = 10/1/18       *
068900*  - CHANGE TO ADD CALL LTCAL190                               *
069000* 9-16-19 - VERSION 20.0 - IMPLEMENTATION DATE = 10/1/19       *
069100*  - CHANGE TO ADD CALL LTCAL201                               *
069200*  - CHANGED "T-CBSA-DATA  OCCURS 0 TO 7000 TIMES"             *
069300*        TO "T-CBSA-DATA  OCCURS 0 TO 10000 TIMES"             *
069400*     FOR IPPS-CBSA-WI-TABLE                                   *
069500*  - CHANGES TO LOGIC FOR WAGE INDEX RURAL FLOOR CALCULATION   *
069600*  - ADD REDEFINES FOR P-NEW-STATE TO ALLOW ALPHANUMERIC       *
069700*    STATE CODES IN THE PROVIDER NUMBER                        *
069800*                                                              *
069900* 3-6-20 - VERSION 20.1 - IMPLEMENT CHANGES FROM CR11616       *
070000* INCLUDES THE DISCHARGE PAYMENT PERCENTAGE PAYMENT ADJUSTMENT *
070100* ADDS THE FOLLOWING TWO NEW VARIABLES TO THE INTERFACE WITH   *
070200*    FISS AND THE MEDICARE CONTRACTORS:                        *
070300*       B-LTCH-DPP-INDICATOR-SW                                *
070400*       PPS-LTCH-DPP-ADJ-AMT                                   *
070500*                                                              *
070600* 4-3-20 - VERSION 20.2 - CR11742                              *
070700*  - CHANGE TO CALL LTCAL202                                   *
070800*                                                              *
070900* 6-17-20 - VERSION 21.B - CR11707 - BETA TEST                 *
071000*  - BETA FOR TESTING NEW DATA LAYOUT                          *
071100*  - ADDED A THIRD INDEX COLUMN TO THE IPPS CBSA RECORD        *
071200*     LAYOUT WITH FOLLOWING DATA NAME:                         *
071300*        T-CBSA-WAGE-INDX3  PIC S9(02)V9(04)                   *
071400*  - ADD NEW INPUT FIELDS SPECIFIED IN CR11707 TO BE USED FOR  *
071500*    SUPPLEMENTAL WAGE INDEX IN VERSION 21.0                   *
071600*       P-SUPP-WI-IND                 PIC X.                   *
071700*       P-SUPP-WI                     PIC 9(02)V9(04).         *
071800*  - CHANGE TO CALL LTCAL21B                                   *
071900*                                                              *
072000* 9-1-20 - VERSION 21.0 - CR11707 - PRODUCTION                 *
072100*  - CHANGE TO CALL LTCAL210                                   *
072200*  - INCLUDE CHANGES FROM BETA                                 *
072300*  - CHANGE TO GET RURAL WAGE INDEX FROM THE THIRD COLUMN OF   *
072400*    THE IPPS CBSA WAGE INDEX TABLE                            *
072500*  - CHANGE TO USE NEW SUPPLEMENTAL WAGE INDEX                 *
072600*                                                              *
072700* 10-9-20 - VERSION 21.1 - CORRECTION NOTICE                   *
072800*  - CHANGE TO CALL LTCAL211                                   *
072900*                                                              *
073000* 11-20-20 - VERSION 21.2                                      *
073100*  - CHANGE TO CALL LTCAL212                                   *
073200*                                                              *
073300****************************************************************
073400
073500
073600 ENVIRONMENT DIVISION.
073700 CONFIGURATION SECTION.
073800 SOURCE-COMPUTER.            IBM-370.
073900 OBJECT-COMPUTER.            IBM-370.
074000 INPUT-OUTPUT  SECTION.
074100 FILE-CONTROL.
074200
074300 DATA DIVISION.
074400 FILE SECTION.
074500
074600
074700 WORKING-STORAGE SECTION.
074800 77  W-STORAGE-REF                  PIC X(48) VALUE
074900     'L T D R V _ _ _ - W O R K I N G   S T O R A G E'.
075000 01  DRV-VERSION                    PIC X(05) VALUE 'D21.2'.
075100
075200*-------------------------------------------------------------*
075300* LTCAL MODULES OLDER THAN 5 YEARS                            *
075400*-------------------------------------------------------------*
075500 01  LTCAL032                       PIC X(08) VALUE 'LTCAL032'.
075600 01  LTCAL042                       PIC X(08) VALUE 'LTCAL042'.
075700 01  LTCAL043                       PIC X(08) VALUE 'LTCAL043'.
075800 01  LTCAL058                       PIC X(08) VALUE 'LTCAL058'.
075900 01  LTCAL059                       PIC X(08) VALUE 'LTCAL059'.
076000 01  LTCAL063                       PIC X(08) VALUE 'LTCAL063'.
076100 01  LTCAL064                       PIC X(08) VALUE 'LTCAL064'.
076200 01  LTCAL072                       PIC X(08) VALUE 'LTCAL072'.
076300 01  LTCAL075                       PIC X(08) VALUE 'LTCAL075'.
076400
076500*-------------------------------------------------------------*
076600* LTCAL MODULES CURRENTLY CALLED                              *
076700*-------------------------------------------------------------*
076800 01  LTCAL080                       PIC X(08) VALUE 'LTCAL080'.
076900 01  LTCAL087                       PIC X(08) VALUE 'LTCAL087'.
077000 01  LTCAL091                       PIC X(08) VALUE 'LTCAL091'.
077100 01  LTCAL094                       PIC X(08) VALUE 'LTCAL094'.
077200 01  LTCAL095                       PIC X(08) VALUE 'LTCAL095'.
077300 01  LTCAL103                       PIC X(08) VALUE 'LTCAL103'.
077400 01  LTCAL105                       PIC X(08) VALUE 'LTCAL105'.
077500 01  LTCAL111                       PIC X(08) VALUE 'LTCAL111'.
077600 01  LTCAL123                       PIC X(08) VALUE 'LTCAL123'.
077700 01  LTCAL130                       PIC X(08) VALUE 'LTCAL130'.
077800 01  LTCAL141                       PIC X(08) VALUE 'LTCAL141'.
077900 01  LTCAL152                       PIC X(08) VALUE 'LTCAL152'.
078000 01  LTCAL154                       PIC X(08) VALUE 'LTCAL154'.
078100 01  LTCAL162                       PIC X(08) VALUE 'LTCAL162'.
078200 01  LTCAL170                       PIC X(08) VALUE 'LTCAL170'.
078300 01  LTCAL183                       PIC X(08) VALUE 'LTCAL183'.
078400 01  LTCAL190                       PIC X(08) VALUE 'LTCAL190'.
078500 01  LTCAL202                       PIC X(08) VALUE 'LTCAL202'.
078600 01  LTCAL212                       PIC X(08) VALUE 'LTCAL212'.
078700
078800 01  WS-9S                          PIC X(08) VALUE '99999999'.
078900
079000 01  WI_QUARTILE_FY2020       PIC 9(02)V9(04)  VALUE 0.8457.
079100 01  WI_PCT_REDUC_FY2020      PIC S9(01)V9(02) VALUE -0.05.
079200 01  WI_PCT_ADJ_FY2020        PIC 9(01)V9(02)  VALUE 0.95.
079300
079400*---------------------------------------------------------*
079500* RURAL FLOOR FACTOR TABLE                                *
079600*---------------------------------------------------------*
079700 COPY RUFL200.
079800
079900 01  HOLD-RUFL-DATA.
080000     05  RUFL-IDX2                      PIC 9(03) VALUE 0.
080100
080200*---------------------------------------------------------*
080300* PREVIOUS FY WAGE INDEX TABLE                            *
080400*---------------------------------------------------------*
080500*COPY PREV200.
080600*
080700*01  HOLD-PREV-DATA.
080800*    05  HLD-PREV-WI                    PIC S9(02)V9(04).
080900
081000*-------------------------------------------------------------*
081100* VARIABLES TO HOLD THE BILL'S FY BEGIN AND END DATES         *
081200*-------------------------------------------------------------*
081300 01  W-FY-BEGIN-DATE.
081400     05  W-FY-BEGIN-CC              PIC 9(02).
081500     05  W-FY-BEGIN-YY              PIC 9(02).
081600     05  W-FY-BEGIN-MM              PIC 9(02) VALUE 10.
081700     05  W-FY-BEGIN-DD              PIC 9(02) VALUE 01.
081800
081900 01  W-FY-END-DATE.
082000     05  W-FY-END-CC                PIC 9(02).
082100     05  W-FY-END-YY                PIC 9(02).
082200     05  W-FY-END-MM                PIC 9(02) VALUE 09.
082300     05  W-FY-END-DD                PIC 9(02) VALUE 30.
082400
082500
082600***************************************************************
082700* MSA AND CBSA HOLD AREAS FOR SEARCH                          *
082800***************************************************************
082900 01  HOLD-PROV-MSA.
083000         10  H-PROV-BLANK             PIC X(2).
083100         10  H-PROV-STATE.
083200             15  FILLER               PIC X.
083300             15  H-MSA-LAST-POS       PIC X.
083400
083500 01  HOLD-PROV-CBSA.
083600         10  H-PROV-BLANK             PIC X(3).
083700         10  H-PROV-STATE.
083800             15  FILLER               PIC X.
083900             15  H-CBSA-LAST-POS      PIC X.
084000
084100 01  HOLD-PROV-IPPS-CBSA.
084200         10  H-PROV-BLANK             PIC X(3).
084300         10  H-PROV-STATE.
084400             15  FILLER               PIC X.
084500             15  H-IPPS-CBSA-LAST-POS PIC X.
084600
084700 01  HOLD-PROV-IPPS-CBSA-RURAL.
084800         10  H-PROV-BLANK-R              PIC X(3).
084900         10  H-PROV-STATE-R.
085000             15  FILLER                  PIC X.
085100             15  H-IPPS-CBSA-LAST-POS-R  PIC X.
085200
085300
085400***************************************************************
085500*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
085600*      THE LTCAL___ PROGRAM (MSA) - USED THROUGH 06/30/2005   *
085700***************************************************************
085800 01  WAGE-NEW-INDEX-RECORD-MSA.
085900     05  W-NEW-MSA                    PIC 9(4).
086000     05  W-NEW-EFF-DATE-M.
086100          10  W-NEW-EFF-DATE-M-CC     PIC 9(2).
086200          10  W-NEW-EFF-DATE-M-YMD.
086300              15  W-NEW-EFF-DATE-M-YY PIC 9(2).
086400              15  W-NEW-EFF-DATE-M-MM PIC 9(2).
086500              15  W-NEW-EFF-DATE-M-DD PIC 9(2).
086600     05  W-NEW-INDEX1-RECORD-M        PIC S9(02)V9(04).
086700     05  W-NEW-INDEX2-RECORD-M        PIC S9(02)V9(04).
086800     05  W-NEW-INDEX3-RECORD-M        PIC S9(02)V9(04).
086900
087000
087100***************************************************************
087200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
087300*      THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2005    *
087400***************************************************************
087500 01  WAGE-NEW-INDEX-RECORD-CBSA.
087600     05  W-NEW-CBSA                   PIC 9(5).
087700     05  W-NEW-EFF-DATE-C.
087800          10  W-NEW-EFF-DATE-C-CC     PIC 9(2).
087900          10  W-NEW-EFF-DATE-C-YMD.
088000              15  W-NEW-EFF-DATE-C-YY PIC 9(2).
088100              15  W-NEW-EFF-DATE-C-MM PIC 9(2).
088200              15  W-NEW-EFF-DATE-C-DD PIC 9(2).
088300     05  W-NEW-INDEX1-RECORD-C        PIC S9(02)V9(04).
088400     05  W-NEW-INDEX2-RECORD-C        PIC S9(02)V9(04).
088500     05  W-NEW-INDEX3-RECORD-C        PIC S9(02)V9(04).
088600
088700
088800***************************************************************
088900*      THIS IS THE IPPS WAGE-INDEX RECORD THAT WILL BE PASSED *
089000*      TO THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2006 *
089100***************************************************************
089200 01  WAGE-IPPS-INDEX-RECORD-CBSA.
089300     05  W-CBSA-IPPS.
089400         10 CBSA-IPPS-123              PIC X(3).
089500         10 CBSA-IPPS-45               PIC X(2).
089600     05  W-CBSA-IPPS-SIZE              PIC X.
089700         88  LARGE-URBAN       VALUE 'L'.
089800         88  OTHER-URBAN       VALUE 'O'.
089900         88  ALL-RURAL         VALUE 'R'.
090000     05  W-CBSA-IPPS-EFF-DATE          PIC X(8).
090100     05  FILLER                        PIC X.
090200     05  W-IPPS-WAGE-INDEX             PIC S9(02)V9(04).
090300     05  W-IPPS-PR-WAGE-INDEX          PIC S9(02)V9(04).
090400
090500
090600***************************************************************
090700*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
090800*      HELD                                                   *
090900***************************************************************
091000 01  WAGE-IPPS-INDEX-RURAL-CBSA.
091100     05  W-CBSA-IPPS-RURAL.
091200         10 CBSA-IPPS-RURAL-123        PIC X(3).
091300         10 CBSA-IPPS-RURAL-45         PIC X(2).
091400     05  W-CBSA-IPPS-RUR-EFF-DATE      PIC X(8).
091500     05  W-IPPS-WAGE-INDEX-RURAL       PIC S9(02)V9(04).
091600
091700
091800***************************************************************
091900*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
092000*      HELD - PUERTO RICO SPECIFIC                            *
092100***************************************************************
092200 01  W-IPPS-PR-WAGE-INDEX-RUR          PIC S9(02)V9(04).
092300
092400
092500* 9-10-20 ADDED FOR SUPPLEMENTAL WAGE INDEX
092600 01  H-LTCH-SUPP-WI-RATIO      PIC S9V9(5) VALUE ZERO.
092700
092800
092900**************************************************************
093000*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
093100*      LTDRV___ PROGRAM TO THE LTCAL___ PROGRAM              *
093200**************************************************************
093300 01  PROV-NEW-HOLD.
093400     02  PROV-NEWREC-HOLD1.
093500         05  P-NEW-NPI10.
093600             10  P-NEW-NPI8             PIC X(08).
093700             10  P-NEW-NPI-FILLER       PIC X(02).
093800         05  P-NEW-PROVIDER-NO.
093900             10  P-NEW-STATE            PIC 9(02).
094000             10  P-NEW-STATE-X REDEFINES
094100                 P-NEW-STATE            PIC X(02).
094200             10  FILLER                 PIC X(04).
094300         05  P-NEW-DATE-DATA.
094400             10  P-NEW-EFF-DATE.
094500                 15  P-NEW-EFF-DT-CC    PIC 9(02).
094600                 15  P-NEW-EFF-DT-YY    PIC 9(02).
094700                 15  P-NEW-EFF-DT-MM    PIC 9(02).
094800                 15  P-NEW-EFF-DT-DD    PIC 9(02).
094900             10  P-NEW-FY-BEGIN-DATE.
095000                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
095100                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
095200                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
095300                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
095400             10  P-NEW-REPORT-DATE.
095500                 15  P-NEW-REPORT-DT-CC PIC 9(02).
095600                 15  P-NEW-REPORT-DT-YY PIC 9(02).
095700                 15  P-NEW-REPORT-DT-MM PIC 9(02).
095800                 15  P-NEW-REPORT-DT-DD PIC 9(02).
095900             10  P-NEW-TERMINATION-DATE.
096000                 15  P-NEW-TERM-DT-CC   PIC 9(02).
096100                 15  P-NEW-TERM-DT-YY   PIC 9(02).
096200                 15  P-NEW-TERM-DT-MM   PIC 9(02).
096300                 15  P-NEW-TERM-DT-DD   PIC 9(02).
096400         05  P-NEW-WAIVER-CODE          PIC X(01).
096500             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
096600         05  P-NEW-INTER-NO             PIC 9(05).
096700         05  P-NEW-PROVIDER-TYPE        PIC X(02).
096800         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
096900         05  P-NEW-CURRENT-DIV   REDEFINES
097000                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
097100         05  P-NEW-MSA-DATA.
097200             10  P-NEW-CHG-CODE-INDEX       PIC X.
097300             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
097400             10  P-NEW-GEO-LOC-MSA9   REDEFINES
097500                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
097600             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
097700                             P-NEW-GEO-LOC-MSA9.
097800                 15  P-NEW-GEO-MSA-1ST    PIC X.
097900                 15  P-NEW-GEO-MSA-2ND    PIC X.
098000                 15  P-NEW-GEO-MSA-3RD    PIC X.
098100                 15  P-NEW-GEO-MSA-4TH    PIC X.
098200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
098300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
098400             10  P-NEW-STAND-AMT-LOC-MSA9
098500                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
098600                 15  P-NEW-RURAL-1ST.
098700                     20  P-NEW-STAND-RURAL  PIC XX.
098800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
098900                 15  P-NEW-RURAL-2ND        PIC XX.
099000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
099100                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
099200                 88  P-NEW-SCH-YR82       VALUE   '82'.
099300                 88  P-NEW-SCH-YR87       VALUE   '87'.
099400         05  P-NEW-LUGAR                    PIC X.
099500         05  P-NEW-TEMP-RELIEF-IND          PIC X.
099600         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
099700         05  P-NEW-STATE-CODE               PIC 9(02).
099800         05  P-NEW-STATE-CODE-X REDEFINES
099900               P-NEW-STATE-CODE             PIC X(02).
100000         05  FILLER                         PIC X(03).
100100     02  PROV-NEWREC-HOLD2.
100200         05  P-NEW-VARIABLES.
100300             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
100400             10  P-NEW-COLA              PIC  9(01)V9(03).
100500             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
100600             10  P-NEW-BED-SIZE          PIC  9(05).
100700             10  P-NEW-CCR               PIC  9(01)V9(03).
100800             10  P-NEW-CMI               PIC  9(01)V9(04).
100900             10  P-NEW-SSI-RATIO         PIC  V9(04).
101000             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
101100             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
101200             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
101300             10  P-NEW-DSH-PERCENT       PIC  V9(04).
101400             10  P-NEW-FYE-DATE.
101500                 15  P-NEW-FYE-CC        PIC 99.
101600                 15  P-NEW-FYE-YY        PIC 99.
101700                 15  P-NEW-FYE-MM        PIC 99.
101800                 15  P-NEW-FYE-DD        PIC 99.
101900         05  P-NEW-CBSA-SPEC-PAY-IND       PIC X(01).
102000         05  P-NEW-HOSP-QUAL-IND           PIC X(01).
102100         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.
102200         05  P-NEW-GEO-LOC-CBSA9 REDEFINES
102300                          P-NEW-GEO-LOC-CBSAX PIC 9(05).
102400         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES
102500                          P-NEW-GEO-LOC-CBSA9.
102600             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.
102700             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.
102800             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.
102900             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.
103000             10 P-NEW-GEO-LOC-CBSA-5TH     PIC X.
103100         05 P-NEW-GEO-LOC-CBSA-SIZE REDEFINES
103200                          P-NEW-GEO-LOC-CBSAX.
103300             10 P-NEW-GEO-LOC-CBSA-123     PIC X(03).
103400                88  P-NEW-RURAL-CBSA       VALUE '   '.
103500             10 P-NEW-GEO-LOC-CBSA-45      PIC X(02).
103600         05  FILLER                        PIC X(10).
103700         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).
103800     02  PROV-NEWREC-HOLD3.
103900         05  P-NEW-PASS-AMT-DATA.
104000             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
104100             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
104200             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
104300             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
104400         05  P-NEW-CAPI-DATA.
104500             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
104600             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
104700             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
104800             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
104900             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
105000             15  P-NEW-CAPI-NEW-HOSP       PIC X.
105100             15  P-NEW-CAPI-IME            PIC 9V9999.
105200             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
105300             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.
105400         05  P-SUPP-WI-IND                 PIC X.
105500         05  P-SUPP-WI                     PIC 9(02)V9(04).
105600         05  FILLER                        PIC X(11).
105700
105800
105900**************************************************************
106000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
106100*      THE LTCAL___ PROGRAM FOR FYS 2003 - 2015 OCT - DEC    *
106200**************************************************************
106300 01  BILL-DATA-FY03-FY15.
106400     05  B-03TO15-NPI10.
106500         10  B-03TO15-NPI8            PIC X(08).
106600         10  B-03TO15-NPI-FILLER      PIC X(02).
106700     05  B-03TO15-PROVIDER-NO         PIC X(06).
106800     05  B-03TO15-PATIENT-STATUS      PIC X(02).
106900     05  B-03TO15-DRG-CODE            PIC X(03).
107000     05  B-03TO15-LOS                 PIC 9(03).
107100     05  B-03TO15-COV-DAYS            PIC 9(03).
107200     05  B-03TO15-LTR-DAYS            PIC 9(02).
107300     05  B-03TO15-DISCHARGE-DATE.
107400         10  B-03TO15-DISCHG-CC       PIC 9(02).
107500         10  B-03TO15-DISCHG-YY       PIC 9(02).
107600         10  B-03TO15-DISCHG-MM       PIC 9(02).
107700         10  B-03TO15-DISCHG-DD       PIC 9(02).
107800     05  B-03TO15-COV-CHARGES         PIC 9(07)V9(02).
107900     05  B-03TO15-SPEC-PAY-IND        PIC X(01).
108000     05  FILLER                       PIC X(13).
108100
108200
108300***************************************************************
108400 LINKAGE SECTION.
108500***************************************************************
108600
108700**************************************************************
108800*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
108900*      THE LTCAL___ PROGRAM FOR FYS 2015 (JANUARY) & LATER   *
109000**************************************************************
109100 01  BILL-NEW-DATA.
109200     05  B-NPI10.
109300         10  B-NPI8                   PIC X(08).
109400         10  B-NPI-FILLER             PIC X(02).
109500     05  B-PROVIDER-NO                PIC X(06).
109600     05  B-PATIENT-STATUS             PIC X(02).
109700     05  B-DRG-CODE                   PIC X(03).
109800     05  B-LOS                        PIC 9(03).
109900     05  B-COV-DAYS                   PIC 9(03).
110000     05  B-LTR-DAYS                   PIC 9(02).
110100     05  B-CST-RPT-DAYS               PIC 9(03).
110200     05  B-DISCHARGE-DATE.
110300         10  B-DISCHG-CC              PIC 9(02).
110400         10  B-DISCHG-YY              PIC 9(02).
110500         10  B-DISCHG-MM              PIC 9(02).
110600         10  B-DISCHG-DD              PIC 9(02).
110700     05  B-COV-CHARGES                PIC 9(07)V9(02).
110800     05  B-SPEC-PAY-IND               PIC X(01).
110900     05  B-REVIEW-CODE                PIC 9(02).
111000     05  B-DIAGNOSIS-CODE-TABLE.
111100         10  B-DIAGNOSIS-CODE         PIC X(07) OCCURS 25 TIMES
111200                                      INDEXED BY IDX-DIAG.
111300     05  B-PROCEDURE-CODE-TABLE.
111400         10 B-PROCEDURE-CODE          PIC X(07) OCCURS 25 TIMES
111500                                      INDEXED BY IDX-PROC.
111600     05  B-LTCH-DPP-INDICATOR-SW      PIC X.
111700         88 B-LTCH-DPP-ADJUSTMENT     VALUE 'Y'.
111800     05  FILLER                       PIC X(19).
111900
112000
112100**************************************************************
112200*      THIS IS THE PPS DATA PASSED TO THE LTCAL___ PROGRAM   *
112300*      IT WILL BE PASSED BACK TO THE LTDRV___ PROGRAM        *
112400**************************************************************
112500 01  PPS-DATA-ALL.
112600     05  PPS-RTC                      PIC X(02).
112700     05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
112800     05  PPS-DATA.
112900         10  PPS-MSA                  PIC X(04).
113000         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
113100         10  PPS-AVG-LOS              PIC 9(02)V9(01).
113200         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
113300         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
113400         10  PPS-LOS                  PIC 9(03).
113500         10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).
113600         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
113700         10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).
113800         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
113900         10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).
114000         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
114100         10  PPS-SUBM-DRG-CODE        PIC X(03).
114200         10  PPS-CALC-VERS-CD         PIC X(05).
114300         10  PPS-REG-DAYS-USED        PIC 9(03).
114400         10  PPS-LTR-DAYS-USED        PIC 9(03).
114500         10  PPS-BLEND-YEAR           PIC 9(01).
114600         10  PPS-COLA                 PIC 9(01)V9(03).
114700         10  FILLER                   PIC X(04).
114800    05  PPS-OTHER-DATA.
114900         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
115000         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
115100         10  PPS-STD-FED-RATE         PIC 9(05)V9(02).
115200         10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).
115300         10  PPS-IPTHRESH             PIC 9(03)V9(01).
115400         10  PPS-LTCH-DPP-ADJ-AMT     PIC S9(09)V99.
115500         10  FILLER                   PIC X(05).
115600    05  PPS-PC-DATA.
115700         10  PPS-COT-IND              PIC X(01).
115800         10  FILLER                   PIC X(20).
115900
116000 01  PPS-CBSA                         PIC X(05).
116100
116200 01  PPS-PAYMENT-DATA.
116300     05  PPS-SITE-NEUTRAL-COST-PMT    PIC 9(07)V99.
116400     05  PPS-SITE-NEUTRAL-IPPS-PMT    PIC 9(07)V99.
116500     05  PPS-STANDARD-FULL-PMT        PIC 9(07)V99.
116600     05  PPS-STANDARD-SSO-PMT         PIC 9(07)V99.
116700
116800*****************************************************************
116900*            THESE ARE THE VERSIONS OF THE LTDRV___             *
117000*           PROGRAMS THAT WILL BE PASSED BACK----               *
117100*          ASSOCIATED WITH THE BILL BEING PROCESSED             *
117200*****************************************************************
117300 01  PRICER-OPT-VERS-SW.
117400     05  PRICER-OPTION-SW               PIC X(01).
117500         88  ALL-TABLES-PASSED          VALUE 'A'.
117600         88  PROV-RECORD-PASSED         VALUE 'P'.
117700     05  PPS-VERSIONS.
117800         10  PPDRV-VERSION              PIC X(05).
117900
118000
118100
118200**************************************************************
118300*      PROVIDER SPECIFIC RECORD                              *
118400**************************************************************
118500*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
118600*      LTOPN___ PROGRAM                                      *
118700**************************************************************
118800 01  PROV-RECORD.
118900     05  PROV-REC1                  PIC X(80).
119000     05  PROV-REC2                  PIC X(80).
119100     05  PROV-REC3                  PIC X(80).
119200
119300
119400**************************************************************
119500*      LTCH CBSA WAGE INDEX TABLE                            *
119600**************************************************************
119700*      THIS IS THE CBSA WAGE INDEX TABLE THAT IS PASSED FROM *
119800*      THE LTOPN___ PROGRAM                                  *
119900**************************************************************
120000 01  CBSA-WI-TABLE.
120100     05  C-CBSA-DATA  OCCURS 0 TO 10000 TIMES
120200                      DEPENDING ON CBSA-CNT
120300                      ASCENDING KEY IS CBSAX-CBSA
120400                      INDEXED BY CU1 CU2.
120500         10  CBSAX-CBSA         PIC X(05).
120600         10  CBSAX-EFF-DATE     PIC X(08).
120700         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).
120800         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).
120900         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).
121000
121100
121200**************************************************************
121300*      IPPS CBSA WAGE INDEX TABLE                            *
121400**************************************************************
121500*      THIS IS THE IPPS CBSA WAGE INDEX TABLE THAT IS PASSED *
121600*      FROM THE LTOPN___ PROGRAM                             *
121700**************************************************************
121800 01  IPPS-CBSA-WI-TABLE.
121900     05  T-CBSA-DATA  OCCURS 0 TO 10000 TIMES
122000                      DEPENDING ON IPPS-CBSA-CNT
122100                      ASCENDING KEY IS T-CBSA
122200                      INDEXED BY MA1 MA2 MA3.
122300         10  T-CBSA             PIC X(5).
122400         10  T-CBSA-SIZE        PIC X(01).
122500         10  T-CBSA-EFF-DATE    PIC X(08).
122600         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).
122700         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).
122800         10  T-CBSA-WAGE-INDX3  PIC S9(02)V9(04).
122900
123000
123100**************************************************************
123200*      LTCH MSA WAGE INDEX TABLE                             *
123300**************************************************************
123400*      THIS IS THE MSA WAGE INDEX TABLE THAT IS PASSED FROM  *
123500*      THE LTOPN___ PROGRAM                                  *
123600**************************************************************
123700 01  MSA-WI-TABLE.
123800     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES
123900                      DEPENDING ON MSA-CNT
124000                      ASCENDING KEY IS MSAX-MSA
124100                      INDEXED BY MU1 MU2.
124200         10  MSAX-MSA          PIC X(4).
124300         10  MSAX-EFF-DATE     PIC X(08).
124400         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).
124500         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).
124600         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).
124700
124800
124900**************************************************************
125000*  INPUT FILE RECORD COUNTS                                  *
125100**************************************************************
125200 01  WORK-COUNTERS.
125300     05  CBSA-CNT              PIC 9(5).
125400     05  MSA-CNT               PIC 9(5).
125500     05  PROV-CNT              PIC 9(5).
125600     05  IPPS-CBSA-CNT         PIC 9(5).
125700
125800
125900
126000
126100 PROCEDURE DIVISION  USING BILL-NEW-DATA
126200                           PPS-DATA-ALL
126300                           PPS-CBSA
126400                           PPS-PAYMENT-DATA
126500                           PRICER-OPT-VERS-SW
126600                           PROV-RECORD
126700                           CBSA-WI-TABLE
126800                           IPPS-CBSA-WI-TABLE
126900                           MSA-WI-TABLE
127000                           WORK-COUNTERS.
127100
127200
127300******************************************************************
127400*                                                                *
127500*    PROCESSING:                                                 *
127600*      A. THIS MODULE WILL RETRIEVE THE WAGE INDEX RECORD(S)     *
127700*         NEEDED FOR EACH BILL.                                  *
127800*      B. THIS MODULE WILL CALL THE LTCAL MODULES.               *
127900*      C. THE PROV-RECORD AND WAGE-INDEX-RECORD(S) ASSOCIATED    *
128000*         WITH EACH BILL WILL BE PASSED TO THE LTCAL PROGRAMS.   *
128100*                                                                *
128200******************************************************************
128300
128400     MOVE DRV-VERSION TO PPDRV-VERSION.
128500
128600*----------------------------------------------------------*
128700* INITIALIZE VARIABLES                                     *
128800*----------------------------------------------------------*
128900     INITIALIZE PPS-DATA-ALL
129000                PPS-CBSA
129100                HOLD-PROV-MSA
129200                HOLD-PROV-CBSA
129300                HOLD-PROV-IPPS-CBSA
129400                HOLD-PROV-IPPS-CBSA-RURAL
129500                WAGE-NEW-INDEX-RECORD-MSA
129600                WAGE-NEW-INDEX-RECORD-CBSA
129700                WAGE-IPPS-INDEX-RECORD-CBSA
129800                W-IPPS-PR-WAGE-INDEX-RUR
129900                WAGE-IPPS-INDEX-RURAL-CBSA
130000                W-FY-BEGIN-CC
130100                W-FY-BEGIN-YY
130200                W-FY-END-CC
130300                W-FY-END-YY
130400                BILL-DATA-FY03-FY15
130500                PPS-PAYMENT-DATA.
130600
130700     MOVE PROV-RECORD TO PROV-NEW-HOLD.
130800
130900
131000*----------------------------------------------------------*
131100* RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002      *
131200*----------------------------------------------------------*
131300     IF B-DISCHARGE-DATE < 20021001
131400        MOVE 98 TO PPS-RTC
131500        GOBACK
131600     END-IF.
131700
131800
131900*-----------------------------------------------------------*
132000* IF CLAIM DISCHARGED BEFORE JAN 2015, MOVE INPUT BILL DATA *
132100* TO OLD BILL RECORD LAYOUT TO PASS TO PRE-JAN 2015 VERSIONS*
132200* OF PROGRAM LTCAL***                                       *
132300*-----------------------------------------------------------*
132400     IF B-DISCHARGE-DATE < 20150101
132500        MOVE B-NPI8           TO B-03TO15-NPI8
132600        MOVE B-PROVIDER-NO    TO B-03TO15-PROVIDER-NO
132700        MOVE B-PATIENT-STATUS TO B-03TO15-PATIENT-STATUS
132800        MOVE B-DRG-CODE       TO B-03TO15-DRG-CODE
132900        MOVE B-LOS            TO B-03TO15-LOS
133000        MOVE B-COV-DAYS       TO B-03TO15-COV-DAYS
133100        MOVE B-LTR-DAYS       TO B-03TO15-LTR-DAYS
133200        MOVE B-DISCHG-CC      TO B-03TO15-DISCHG-CC
133300        MOVE B-DISCHG-YY      TO B-03TO15-DISCHG-YY
133400        MOVE B-DISCHG-MM      TO B-03TO15-DISCHG-MM
133500        MOVE B-DISCHG-DD      TO B-03TO15-DISCHG-DD
133600        MOVE B-COV-CHARGES    TO B-03TO15-COV-CHARGES
133700        MOVE B-SPEC-PAY-IND   TO B-03TO15-SPEC-PAY-IND
133800     END-IF.
133900
134000
134100*----------------------------------------------------------*
134200* SET FY BEGIN AND END DATES USING BILL DISCHARGE DATE     *
134300*----------------------------------------------------------*
134400     MOVE B-DISCHG-CC TO W-FY-BEGIN-CC.
134500     MOVE B-DISCHG-CC TO W-FY-END-CC.
134600
134700*----------------------------------*
134800* FOR CLAIMS DISCHARGED JAN - SEPT *
134900*----------------------------------*
135000     IF B-DISCHG-MM >= 01 AND
135100        B-DISCHG-MM <= 09
135200        COMPUTE W-FY-BEGIN-YY = B-DISCHG-YY - 1
135300        MOVE B-DISCHG-YY TO W-FY-END-YY
135400
135500*----------------------------------*
135600* FOR CLAIMS DISCHARGED OCT - DEC  *
135700*----------------------------------*
135800     ELSE
135900        MOVE B-DISCHG-YY TO W-FY-BEGIN-YY
136000        COMPUTE W-FY-END-YY = B-DISCHG-YY + 1
136100     END-IF.
136200
136300
136400
136500************************************************************
136600*    GET THE WAGE-INDEX RECORD                             *
136700************************************************************
136800
136900*------------------------------------------------*
137000* EDIT THE CBSA AND MSA FROM THE PROVIDER RECORD *
137100*------------------------------------------------*
137200     IF P-NEW-GEO-LOC-CBSAX = SPACES
137300        MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX
137400     END-IF.
137500
137600     IF P-NEW-GEO-LOC-MSAX = SPACES
137700        MOVE ZEROS TO P-NEW-GEO-LOC-MSAX
137800     END-IF.
137900
138000     IF P-NEW-EFF-DATE > 20050701
138100        IF '*' = P-NEW-GEO-LOC-CBSA-1ST OR
138200                 P-NEW-GEO-LOC-CBSA-2ND OR
138300                 P-NEW-GEO-LOC-CBSA-3RD OR
138400                 P-NEW-GEO-LOC-CBSA-4TH OR
138500                 P-NEW-GEO-LOC-CBSA-5TH
138600           MOVE 60 TO PPS-RTC
138700           GOBACK
138800        END-IF
138900     END-IF.
139000
139100
139200*----------------------------------------------------------*
139300* SUPPLEMENTAL WAGE INDEX EDIT                             *
139400*----------------------------------------------------------*
139500     IF B-DISCHARGE-DATE > 20200930
139600        IF P-SUPP-WI-IND = '1' OR '2'
139700           IF P-SUPP-WI  > ZERO
139800              NEXT SENTENCE
139900           ELSE
140000              MOVE 52 TO PPS-RTC
140100              GOBACK.
140200     IF B-DISCHARGE-DATE > 20200930
140300        IF P-SUPP-WI-IND = '1' OR '2'
140400           IF P-NEW-EFF-DATE < W-FY-BEGIN-DATE OR
140500              P-NEW-EFF-DATE > W-FY-END-DATE
140600                MOVE 52 TO PPS-RTC
140700                GOBACK.
140800
140900
141000*----------------------------------------------------------*
141100* GET THE LTCH WAGE INDEX                                  *
141200*----------------------------------------------------------*
141300     IF B-DISCHARGE-DATE < 20050701
141400       SET MU1 TO 1
141500       PERFORM 0500-GET-MSA THRU 0500-EXIT
141600     ELSE
141700       SET CU1 TO 1
141800       PERFORM 0550-GET-CBSA THRU 0550-EXIT
141900       IF W-NEW-INDEX3-RECORD-C = 0
142000          MOVE 52 TO PPS-RTC
142100     END-IF.
142200
142300*----------------------------------------------------------*
142400* GET THE IPPS WAGE INDEX                                  *
142500*----------------------------------------------------------*
142600     IF B-DISCHARGE-DATE > 20060630
142700       SET MA1 TO 1
142800       PERFORM 0575-GET-IPPS-CBSA THRU 0575-EXIT
142900       IF W-IPPS-WAGE-INDEX = 0
143000          MOVE 52 TO PPS-RTC
143100       END-IF
143200     END-IF.
143300
143400*--------------------------------------------------------------*
143500* RTC = 60  --  LTCH/IPPS CBSA/MSA WAGE INDEX RECORD NOT FOUND *
143600* RTC = 52  --  LTCH/IPPS CBSA/MSA WAGE INDEX INVALID          *
143700*--------------------------------------------------------------*
143800     IF PPS-RTC = 60 OR PPS-RTC = 52
143900        GOBACK
144000     END-IF.
144100
144200
144300
144400******************************************************************
144500******************************************************************
144600**                                                              **
144700**          THIS NEXT CALL WILL PROCESS BILLS WITH              **
144800**          A DISCHARGE DATE ON OR AFTER 20021001               **
144900**                                                              **
145000**--------------------------------------------------------------**
145100**                                                              **
145200** FOR BILLS WITH DISCHARGE DATES AFTER 20050630, INCLUDE FIELD **
145300** PPS-CBSA IN THE CALL USING STATEMENT, OMIT THIS FIELD FOR    **
145400** BILLS WITH DISCHARGE DATES BEFORE 20050701.                  **
145500**                                                              **
145600** FOR BILLS WITH DISCHARGE DATES AFTER 20060630, INCLUDE FIELD **
145700** WAGE-IPPS-INDEX-RECORD-CBSA.                                 **
145800**                                                              **
145900******************************************************************
146000******************************************************************
146100
146200
146300*----------------------------------------------------------------*
146400*        FISCAL YEAR 2021
146500*----------------------------------------------------------------*
146600         IF B-DISCHARGE-DATE > 20200930
146700            CALL LTCAL212 USING BILL-NEW-DATA
146800                                PPS-DATA-ALL
146900                                PPS-CBSA
147000                                PPS-PAYMENT-DATA
147100                                PRICER-OPT-VERS-SW
147200                                PROV-NEW-HOLD
147300                                WAGE-NEW-INDEX-RECORD-CBSA
147400                                WAGE-IPPS-INDEX-RECORD-CBSA.
147500
147600
147700*----------------------------------------------------------------*
147800*        FISCAL YEAR 2020
147900*----------------------------------------------------------------*
148000         IF B-DISCHARGE-DATE > 20190930 AND
148100                             < 20201001
148200            CALL LTCAL202 USING BILL-NEW-DATA
148300                                PPS-DATA-ALL
148400                                PPS-CBSA
148500                                PPS-PAYMENT-DATA
148600                                PRICER-OPT-VERS-SW
148700                                PROV-NEW-HOLD
148800                                WAGE-NEW-INDEX-RECORD-CBSA
148900                                WAGE-IPPS-INDEX-RECORD-CBSA.
149000
149100
149200*----------------------------------------------------------------*
149300*        FISCAL YEAR 2019
149400*----------------------------------------------------------------*
149500         IF B-DISCHARGE-DATE > 20180930 AND
149600                             < 20191001
149700            CALL LTCAL190 USING BILL-NEW-DATA
149800                                PPS-DATA-ALL
149900                                PPS-CBSA
150000                                PPS-PAYMENT-DATA
150100                                PRICER-OPT-VERS-SW
150200                                PROV-NEW-HOLD
150300                                WAGE-NEW-INDEX-RECORD-CBSA
150400                                WAGE-IPPS-INDEX-RECORD-CBSA.
150500
150600
150700*----------------------------------------------------------------*
150800*        FISCAL YEAR 2018
150900*----------------------------------------------------------------*
151000         IF B-DISCHARGE-DATE > 20170930 AND
151100                             < 20181001
151200            CALL LTCAL183 USING BILL-NEW-DATA
151300                                PPS-DATA-ALL
151400                                PPS-CBSA
151500                                PPS-PAYMENT-DATA
151600                                PRICER-OPT-VERS-SW
151700                                PROV-NEW-HOLD
151800                                WAGE-NEW-INDEX-RECORD-CBSA
151900                                WAGE-IPPS-INDEX-RECORD-CBSA.
152000
152100
152200*----------------------------------------------------------------*
152300*        FISCAL YEAR 2017
152400*----------------------------------------------------------------*
152500         IF B-DISCHARGE-DATE > 20160930 AND
152600                             < 20171001
152700            CALL LTCAL170 USING BILL-NEW-DATA
152800                                PPS-DATA-ALL
152900                                PPS-CBSA
153000                                PPS-PAYMENT-DATA
153100                                PRICER-OPT-VERS-SW
153200                                PROV-NEW-HOLD
153300                                WAGE-NEW-INDEX-RECORD-CBSA
153400                                WAGE-IPPS-INDEX-RECORD-CBSA.
153500
153600
153700*----------------------------------------------------------------*
153800*        FISCAL YEAR 2016
153900*----------------------------------------------------------------*
154000         IF B-DISCHARGE-DATE > 20150930 AND
154100                             < 20161001
154200            CALL LTCAL162 USING BILL-NEW-DATA
154300                                PPS-DATA-ALL
154400                                PPS-CBSA
154500                                PPS-PAYMENT-DATA
154600                                PRICER-OPT-VERS-SW
154700                                PROV-NEW-HOLD
154800                                WAGE-NEW-INDEX-RECORD-CBSA
154900                                WAGE-IPPS-INDEX-RECORD-CBSA.
155000
155100*----------------------------------------------------------------*
155200*        FISCAL YEAR 2015, 01/01/2015 - 09/30/2015               *
155300*----------------------------------------------------------------*
155400         IF B-DISCHARGE-DATE > 20141231 AND
155500                             < 20151001
155600            CALL LTCAL154 USING BILL-NEW-DATA
155700                                PPS-DATA-ALL
155800                                PPS-CBSA
155900                                PRICER-OPT-VERS-SW
156000                                PROV-NEW-HOLD
156100                                WAGE-NEW-INDEX-RECORD-CBSA
156200                                WAGE-IPPS-INDEX-RECORD-CBSA.
156300
156400*----------------------------------------------------------------*
156500*        FISCAL YEAR 2015, 10/01/2014 - 12/31/2014               *
156600*----------------------------------------------------------------*
156700         IF B-DISCHARGE-DATE > 20140930 AND
156800                             < 20150101
156900            CALL LTCAL152 USING BILL-DATA-FY03-FY15
157000                                PPS-DATA-ALL
157100                                PPS-CBSA
157200                                PRICER-OPT-VERS-SW
157300                                PROV-NEW-HOLD
157400                                WAGE-NEW-INDEX-RECORD-CBSA
157500                                WAGE-IPPS-INDEX-RECORD-CBSA.
157600
157700*----------------------------------------------------------------*
157800*        FISCAL YEAR 2014, RATE YEAR 2014 (AFTER 10/1/2013)      *
157900*----------------------------------------------------------------*
158000         IF B-DISCHARGE-DATE > 20130930 AND
158100                             < 20141001
158200            CALL LTCAL141 USING BILL-DATA-FY03-FY15
158300                                PPS-DATA-ALL
158400                                PPS-CBSA
158500                                PRICER-OPT-VERS-SW
158600                                PROV-NEW-HOLD
158700                                WAGE-NEW-INDEX-RECORD-CBSA
158800                                WAGE-IPPS-INDEX-RECORD-CBSA.
158900
159000*----------------------------------------------------------------*
159100*        FISCAL YEAR 2013, RATE YEAR 2013 (AFTER 10/1/2012)      *
159200*----------------------------------------------------------------*
159300         IF B-DISCHARGE-DATE > 20120930 AND
159400                             < 20131001
159500            CALL LTCAL130 USING BILL-DATA-FY03-FY15
159600                                PPS-DATA-ALL
159700                                PPS-CBSA
159800                                PRICER-OPT-VERS-SW
159900                                PROV-NEW-HOLD
160000                                WAGE-NEW-INDEX-RECORD-CBSA
160100                                WAGE-IPPS-INDEX-RECORD-CBSA.
160200
160300*----------------------------------------------------------------*
160400*        FISCAL YEAR 2012, RATE YEAR 2012 (AFTER 10/1/2011)      *
160500*----------------------------------------------------------------*
160600         IF B-DISCHARGE-DATE > 20110930 AND
160700                             < 20121001
160800            CALL LTCAL123 USING BILL-DATA-FY03-FY15
160900                                PPS-DATA-ALL
161000                                PPS-CBSA
161100                                PRICER-OPT-VERS-SW
161200                                PROV-NEW-HOLD
161300                                WAGE-NEW-INDEX-RECORD-CBSA
161400                                WAGE-IPPS-INDEX-RECORD-CBSA.
161500
161600*----------------------------------------------------------------*
161700*        FISCAL YEAR 2011, RATE YEAR 2011 (AFTER 10/1/2010)      *
161800*----------------------------------------------------------------*
161900         IF B-DISCHARGE-DATE > 20100930 AND
162000                             < 20111001
162100            CALL LTCAL111 USING BILL-DATA-FY03-FY15
162200                                PPS-DATA-ALL
162300                                PPS-CBSA
162400                                PRICER-OPT-VERS-SW
162500                                PROV-NEW-HOLD
162600                                WAGE-NEW-INDEX-RECORD-CBSA
162700                                WAGE-IPPS-INDEX-RECORD-CBSA.
162800
162900*----------------------------------------------------------------*
163000*        FISCAL YEAR 2010, RATE YEAR 2010 (AFTER 3/31/2010)      *
163100*----------------------------------------------------------------*
163200         IF B-DISCHARGE-DATE > 20100331 AND
163300                             < 20101001
163400            CALL LTCAL105 USING BILL-DATA-FY03-FY15
163500                                PPS-DATA-ALL
163600                                PPS-CBSA
163700                                PRICER-OPT-VERS-SW
163800                                PROV-NEW-HOLD
163900                                WAGE-NEW-INDEX-RECORD-CBSA
164000                                WAGE-IPPS-INDEX-RECORD-CBSA.
164100
164200*----------------------------------------------------------------*
164300*        FISCAL YEAR 2010, RATE YEAR 2010 (BEFORE 4/1/2010)      *
164400*----------------------------------------------------------------*
164500         IF B-DISCHARGE-DATE > 20090930 AND
164600                             < 20100401
164700            CALL LTCAL103 USING BILL-DATA-FY03-FY15
164800                                PPS-DATA-ALL
164900                                PPS-CBSA
165000                                PRICER-OPT-VERS-SW
165100                                PROV-NEW-HOLD
165200                                WAGE-NEW-INDEX-RECORD-CBSA
165300                                WAGE-IPPS-INDEX-RECORD-CBSA.
165400
165500*----------------------------------------------------------------*
165600*        FISCAL YEAR 2009, RATE YEAR 2009 (AFTER 6/2/2009)       *
165700*----------------------------------------------------------------*
165800         IF B-DISCHARGE-DATE > 20090602 AND
165900                             < 20091001
166000            CALL LTCAL095 USING BILL-DATA-FY03-FY15
166100                                PPS-DATA-ALL
166200                                PPS-CBSA
166300                                PRICER-OPT-VERS-SW
166400                                PROV-NEW-HOLD
166500                                WAGE-NEW-INDEX-RECORD-CBSA
166600                                WAGE-IPPS-INDEX-RECORD-CBSA.
166700
166800*----------------------------------------------------------------*
166900*        FISCAL YEAR 2009, RATE YEAR 2009 (BEFORE 6/3/2009)      *
167000*----------------------------------------------------------------*
167100         IF B-DISCHARGE-DATE > 20080930 AND
167200                             < 20090603
167300            CALL LTCAL094 USING BILL-DATA-FY03-FY15
167400                                PPS-DATA-ALL
167500                                PPS-CBSA
167600                                PRICER-OPT-VERS-SW
167700                                PROV-NEW-HOLD
167800                                WAGE-NEW-INDEX-RECORD-CBSA
167900                                WAGE-IPPS-INDEX-RECORD-CBSA.
168000
168100*----------------------------------------------------------------*
168200*        FISCAL YEAR 2008, RATE YEAR 2009                        *
168300*----------------------------------------------------------------*
168400         IF B-DISCHARGE-DATE > 20080630 AND
168500                             < 20081001
168600            CALL LTCAL091 USING BILL-DATA-FY03-FY15
168700                                PPS-DATA-ALL
168800                                PPS-CBSA
168900                                PRICER-OPT-VERS-SW
169000                                PROV-NEW-HOLD
169100                                WAGE-NEW-INDEX-RECORD-CBSA
169200                                WAGE-IPPS-INDEX-RECORD-CBSA.
169300
169400*----------------------------------------------------------------*
169500*        FISCAL YEAR 2008, RATE YEAR 2008                        *
169600*----------------------------------------------------------------*
169700         IF B-DISCHARGE-DATE > 20070930 AND
169800                             < 20080701
169900            CALL LTCAL087 USING BILL-DATA-FY03-FY15
170000                                PPS-DATA-ALL
170100                                PPS-CBSA
170200                                PRICER-OPT-VERS-SW
170300                                PROV-NEW-HOLD
170400                                WAGE-NEW-INDEX-RECORD-CBSA
170500                                WAGE-IPPS-INDEX-RECORD-CBSA.
170600
170700*----------------------------------------------------------------*
170800*        FISCAL YEAR 2007, RATE YEAR 2008                        *
170900*----------------------------------------------------------------*
171000         IF B-DISCHARGE-DATE > 20070630 AND
171100                             < 20071001
171200            CALL LTCAL080 USING BILL-DATA-FY03-FY15
171300                                PPS-DATA-ALL
171400                                PPS-CBSA
171500                                PRICER-OPT-VERS-SW
171600                                PROV-NEW-HOLD
171700                                WAGE-NEW-INDEX-RECORD-CBSA
171800                                WAGE-IPPS-INDEX-RECORD-CBSA.
171900
172000*----------------------------------------------------------------*
172100*        FISCAL YEAR 2007, RATE YEAR 2007                        *
172200*----------------------------------------------------------------*
172300         IF B-DISCHARGE-DATE > 20060930 AND
172400                             < 20070701
172500            CALL LTCAL075 USING BILL-DATA-FY03-FY15
172600                                PPS-DATA-ALL
172700                                PPS-CBSA
172800                                PRICER-OPT-VERS-SW
172900                                PROV-NEW-HOLD
173000                                WAGE-NEW-INDEX-RECORD-CBSA
173100                                WAGE-IPPS-INDEX-RECORD-CBSA.
173200
173300*----------------------------------------------------------------*
173400*        FISCAL YEAR 2006, RATE YEAR 2007                        *
173500*----------------------------------------------------------------*
173600         IF B-DISCHARGE-DATE > 20060630 AND
173700                             < 20061001
173800            CALL LTCAL072 USING BILL-DATA-FY03-FY15
173900                                PPS-DATA-ALL
174000                                PPS-CBSA
174100                                PRICER-OPT-VERS-SW
174200                                PROV-NEW-HOLD
174300                                WAGE-NEW-INDEX-RECORD-CBSA
174400                                WAGE-IPPS-INDEX-RECORD-CBSA.
174500
174600*----------------------------------------------------------------*
174700*        FISCAL YEAR 2006, RATE YEAR 2006                        *
174800*----------------------------------------------------------------*
174900         IF B-DISCHARGE-DATE > 20050930 AND
175000                             < 20060701
175100            CALL LTCAL064 USING BILL-DATA-FY03-FY15
175200                                PPS-DATA-ALL
175300                                PPS-CBSA
175400                                PRICER-OPT-VERS-SW
175500                                PROV-NEW-HOLD
175600                                WAGE-NEW-INDEX-RECORD-CBSA.
175700
175800*----------------------------------------------------------------*
175900*        FISCAL YEAR 2005, RATE YEAR 2006                        *
176000*----------------------------------------------------------------*
176100         IF B-DISCHARGE-DATE > 20050630 AND
176200                             < 20051001
176300            CALL LTCAL063 USING BILL-DATA-FY03-FY15
176400                                PPS-DATA-ALL
176500                                PPS-CBSA
176600                                PRICER-OPT-VERS-SW
176700                                PROV-NEW-HOLD
176800                                WAGE-NEW-INDEX-RECORD-CBSA.
176900
177000*----------------------------------------------------------------*
177100*        FISCAL YEAR 2005, RATE YEAR 2005                        *
177200*----------------------------------------------------------------*
177300         IF B-DISCHARGE-DATE > 20040930 AND
177400            B-DISCHARGE-DATE < 20050701
177500            CALL LTCAL059 USING BILL-DATA-FY03-FY15
177600                                PPS-DATA-ALL
177700                                PRICER-OPT-VERS-SW
177800                                PROV-NEW-HOLD
177900                                WAGE-NEW-INDEX-RECORD-MSA.
178000
178100*----------------------------------------------------------------*
178200*        FISCAL YEAR 2004, RATE YEAR 2005                        *
178300*----------------------------------------------------------------*
178400         IF B-DISCHARGE-DATE > 20040630 AND
178500            B-DISCHARGE-DATE < 20041001
178600            CALL LTCAL058 USING BILL-DATA-FY03-FY15
178700                                PPS-DATA-ALL
178800                                PRICER-OPT-VERS-SW
178900                                PROV-NEW-HOLD
179000                                WAGE-NEW-INDEX-RECORD-MSA.
179100
179200*----------------------------------------------------------------*
179300*        FISCAL YEAR 2004, RATE YEAR 2004 (NO LONGER CALLED)     *
179400*----------------------------------------------------------------*
179500         IF B-DISCHARGE-DATE > 20030930 AND
179600            B-DISCHARGE-DATE < 20040701
179700            CALL LTCAL043 USING BILL-DATA-FY03-FY15
179800                                PPS-DATA-ALL
179900                                PRICER-OPT-VERS-SW
180000                                PROV-NEW-HOLD
180100                                WAGE-NEW-INDEX-RECORD-MSA.
180200
180300*----------------------------------------------------------------*
180400*        FISCAL YEAR 2003, RATE YEAR 2004 (NO LONGER CALLED)     *
180500*----------------------------------------------------------------*
180600         IF B-DISCHARGE-DATE > 20030630 AND
180700            B-DISCHARGE-DATE < 20031001
180800            CALL LTCAL042 USING BILL-DATA-FY03-FY15
180900                                PPS-DATA-ALL
181000                                PRICER-OPT-VERS-SW
181100                                PROV-NEW-HOLD
181200                                WAGE-NEW-INDEX-RECORD-MSA.
181300
181400*----------------------------------------------------------------*
181500*        FISCAL YEAR 2003, RATE YEAR 2003 (NO LONGER CALLED)     *
181600*----------------------------------------------------------------*
181700         IF B-DISCHARGE-DATE < 20030701
181800            CALL LTCAL032 USING BILL-DATA-FY03-FY15
181900                                PPS-DATA-ALL
182000                                PRICER-OPT-VERS-SW
182100                                PROV-NEW-HOLD
182200                                WAGE-NEW-INDEX-RECORD-MSA.
182300
182400
182500         GOBACK.
182600
182700******************************************************************
182800******************************************************************
182900
183000 0190-GET-RURAL-FLOOR-IPPS.
183100
183200*    IF H-CBSA-PROV-BLANK = '   ' AND P-NEW-CBSA-WI-BLANK
183300*      GO TO 0190-EXIT.
183400
183500     SET RUFL-IDX TO 1.
183600
183700     SEARCH RUFL-TAB VARYING RUFL-IDX
183800     AT END
183900       MOVE '   00'              TO W-CBSA-IPPS-RURAL
184000       MOVE 99999999             TO W-CBSA-IPPS-RUR-EFF-DATE
184100       MOVE 0                    TO W-IPPS-WAGE-INDEX-RURAL
184200       GO TO 0190-EXIT
184300     WHEN RUFL-CBSA(RUFL-IDX) = HOLD-PROV-IPPS-CBSA-RURAL
184400          SET RUFL-IDX2 TO RUFL-IDX.
184500
184600 0190-EXIT.  EXIT.
184700
184800******************************************************************
184900 0500-GET-MSA.
185000******************************************************************
185100
185200     MOVE P-NEW-GEO-LOC-MSAX TO HOLD-PROV-MSA.
185300
185400     SEARCH M-MSA-DATA VARYING MU1
185500       AT END
185600          MOVE 60 TO PPS-RTC
185700       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA
185800          SET MU2 TO MU1
185900          PERFORM 0600-N-GET-WAGE-INDX
186000            THRU 0600-N-EXIT VARYING MU2
186100            FROM MU1 BY 1 UNTIL
186200              MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.
186300
186400 0500-EXIT.
186500      EXIT.
186600
186700
186800******************************************************************
186900 0550-GET-CBSA.
187000******************************************************************
187100* GET LTCH WAGE INDEX
187200*----------------------------------------------------------------*
187300* USE SPECIAL WAGE INDEX WHEN INDICATED - FOR LTCH WAGE INDEX    *
187400* TO USE THE SPECIAL WAGE INDEX IT MUST:                         *
187500*   1) BE FOR A CLAIM DISCHARGED ON OR AFTER 07/01/2005          *
187600*      (WHEN SPECIAL WAGE INDEX WAS FIRST USED FOR LTCH)         *
187700*   2) BE NUMERIC,                                               *
187800*   3) BE GREATER THAN 0, AND                                    *
187900*   4) BE IN A PSF RECORD WITH AN EFFECTIVE DATE WITHIN THE      *
188000*      CLAIM'S FISCAL YEAR.                                      *
188100*----------------------------------------------------------------*
188200     IF B-DISCHARGE-DATE > 20050630
188300     IF P-NEW-CBSA-SPEC-PAY-IND = '1'
188400        IF P-NEW-SPECIAL-WAGE-INDEX NUMERIC AND
188500           P-NEW-SPECIAL-WAGE-INDEX > 0 AND
188600           (P-NEW-EFF-DATE >= W-FY-BEGIN-DATE AND
188700            P-NEW-EFF-DATE <= W-FY-END-DATE)
188800            MOVE ZEROS                    TO W-NEW-CBSA
188900            MOVE P-NEW-EFF-DATE           TO W-NEW-EFF-DATE-C
189000            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX1-RECORD-C
189100            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX2-RECORD-C
189200            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX3-RECORD-C
189300            GO TO 0550-EXIT
189400        ELSE
189500            MOVE 52 TO PPS-RTC
189600            GO TO 0550-EXIT
189700        END-IF
189800     END-IF
189900     END-IF.
190000
190100
190200     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-CBSA.
190300
190400*6-20-16
190500*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
190600*WITH THE NEW ARIZONA STATE CODE OF 00 -->
190700
190800     IF HOLD-PROV-CBSA = '   00' MOVE '   03' TO HOLD-PROV-CBSA.
190900
191000     SEARCH C-CBSA-DATA VARYING CU1
191100        AT END
191200           MOVE 60 TO PPS-RTC
191300        WHEN CBSAX-CBSA (CU1) = HOLD-PROV-CBSA
191400           SET CU2 TO CU1
191500           PERFORM 0650-N-GET-WAGE-INDX
191600             THRU 0650-N-EXIT VARYING CU2
191700             FROM CU1 BY 1 UNTIL
191800               CBSAX-CBSA (CU2) NOT = HOLD-PROV-CBSA.
191900
192000
192100*** SUPPLEMENTAL WAGE INDEX ***
192200* WHEN P-SUPP-WI-IND = '1' THE SUPPLEMENTAL WAGE INDEX FIELD
192300* CONTAINS THE PRIOR YEAR'S LTCH WAGE INDEX.
192400* THIS CALCULATION CAPS THE LTCH WAGE INDEX DECREASE AT 5%.
192500
192600     IF B-DISCHARGE-DATE > 20200930
192700        IF P-SUPP-WI-IND = '1'
192800           IF P-SUPP-WI > 0
192900              COMPUTE H-LTCH-SUPP-WI-RATIO =
193000               (W-NEW-INDEX3-RECORD-C - P-SUPP-WI) / P-SUPP-WI
193100              IF H-LTCH-SUPP-WI-RATIO <  -0.05
193200                 COMPUTE W-NEW-INDEX3-RECORD-C ROUNDED =
193300                         P-SUPP-WI * 0.95
193400                 GO TO 0550-EXIT
193500              ELSE
193600                MOVE 52 TO PPS-RTC
193700                GO TO 0550-EXIT
193800              END-IF
193900           ELSE
194000             MOVE 52 TO PPS-RTC
194100             GO TO 0550-EXIT
194200           END-IF
194300        END-IF
194400        GO TO 0550-EXIT
194500     END-IF.
194600
194700 0550-EXIT.
194800      EXIT.
194900
195000
195100******************************************************************
195200 0575-GET-IPPS-CBSA.
195300******************************************************************
195400
195500*------------------------------------------------------------*
195600* SET IPPS CBSA TO GEOGRAPHIC LOCATION CBSA IN PSF           *
195700*------------------------------------------------------------*
195800     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
195900
196000
196100*6-20-16
196200*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
196300*WITH THE NEW ARIZONA STATE CODE OF 00 -->
196400
196500     IF HOLD-PROV-IPPS-CBSA = '   00'
196600        MOVE '   03' TO HOLD-PROV-IPPS-CBSA.
196700
196800*------------------------------------------------------------*
196900* ASSIGN FY 2006 IPPS WAGE INDEX FLOORS                      *
197000*------------------------------------------------------------*
197100     IF B-DISCHARGE-DATE > 20050930 AND < 20061001
197200        PERFORM 0580-FY2006-FLOOR-CBSA THRU 0580-FY2006-EXIT
197300     END-IF.
197400
197500
197600*------------------------------------------------------------*
197700* ASSIGN FY 2007 IPPS WAGE INDEX FLOORS                      *
197800*------------------------------------------------------------*
197900     IF B-DISCHARGE-DATE > 20060930 AND < 20071001
198000        PERFORM 0580-FY2007-FLOOR-CBSA THRU 0580-FY2007-EXIT
198100     END-IF.
198200
198300
198400*------------------------------------------------------------*
198500* ASSIGN FY 2008 IPPS WAGE INDEX FLOORS                      *
198600*------------------------------------------------------------*
198700     IF B-DISCHARGE-DATE > 20070930 AND < 20081001
198800        PERFORM 0580-FY2008-FLOOR-CBSA THRU 0580-FY2008-EXIT
198900     END-IF.
199000
199100
199200*------------------------------------------------------------*
199300* ASSIGN FY 2009 IPPS WAGE INDEX FLOORS                      *
199400*------------------------------------------------------------*
199500     IF B-DISCHARGE-DATE > 20080930 AND < 20091001
199600        PERFORM 0580-FY2009-FLOOR-CBSA THRU 0580-FY2009-EXIT
199700     END-IF.
199800
199900
200000*------------------------------------------------------------*
200100* ASSIGN FY 2010 IPPS WAGE INDEX FLOORS                      *
200200*------------------------------------------------------------*
200300     IF B-DISCHARGE-DATE > 20090930 AND < 20101001
200400        PERFORM 0580-FY2010-FLOOR-CBSA THRU 0580-FY2010-EXIT
200500     END-IF.
200600
200700*------------------------------------------------------------*
200800* ASSIGN FY 2011 IPPS WAGE INDEX FLOORS                      *
200900*------------------------------------------------------------*
201000     IF B-DISCHARGE-DATE > 20100930 AND < 20111001
201100        PERFORM 0580-FY2011-FLOOR-CBSA THRU 0580-FY2011-EXIT
201200     END-IF.
201300
201400*------------------------------------------------------------*
201500* ASSIGN FY 2012 IPPS WAGE INDEX FLOORS                      *
201600*------------------------------------------------------------*
201700     IF B-DISCHARGE-DATE > 20110930 AND < 20121001
201800        PERFORM 0580-FY2012-FLOOR-CBSA THRU 0580-FY2012-EXIT
201900     END-IF.
202000
202100*------------------------------------------------------------*
202200* ASSIGN FY 2013 IPPS WAGE INDEX FLOORS                      *
202300*------------------------------------------------------------*
202400     IF B-DISCHARGE-DATE > 20120930 AND < 20131001
202500        PERFORM 0580-FY2013-FLOOR-CBSA THRU 0580-FY2013-EXIT
202600     END-IF.
202700
202800*------------------------------------------------------------*
202900* ASSIGN FY 2014 IPPS WAGE INDEX FLOORS                      *
203000*------------------------------------------------------------*
203100     IF B-DISCHARGE-DATE > 20130930 AND < 20141001
203200        PERFORM 0580-FY2014-FLOOR-CBSA THRU 0580-FY2014-EXIT
203300     END-IF.
203400
203500*------------------------------------------------------------*
203600* SEARCH TABLE FOR IPPS CBSA & GET WAGE INDEX                *
203700*------------------------------------------------------------*
203800     SEARCH T-CBSA-DATA VARYING MA1
203900        AT END
204000           MOVE 60 TO PPS-RTC
204100        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
204200           SET MA2 TO MA1
204300           PERFORM 0675-N-GET-IPPS-WAGE-INDX
204400              THRU 0675-N-EXIT VARYING MA2
204500              FROM MA1 BY 1 UNTIL
204600                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
204700
204800
204900*------------------------------------------------------------*
205000* ASSIGN IPPS WAGE INDEX FLOORS FOR FY 2015 AND LATER        *
205100*------------------------------------------------------------*
205200     IF B-DISCHARGE-DATE > 20140930
205300        PERFORM 0580-FY2015-LATER-FLOOR-CBSA
205400           THRU 0580-FY2015-LATER-EXIT
205500     END-IF.
205600
205700
205800*------------------------------------------------------------*
205900* GET THE IPPS CBSA SIZE INDICATOR                           *
206000*------------------------------------------------------------*
206100* LOGIC REVISED 12/28/2006 FOR VERSION 08.0                  *
206200*------------------------------------------------------------*
206300     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
206400
206500*6-20-16
206600*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
206700*WITH THE NEW ARIZONA STATE CODE OF 00 -->
206800
206900     IF HOLD-PROV-IPPS-CBSA = '   00'
207000        MOVE '   03' TO HOLD-PROV-IPPS-CBSA.
207100
207200
207300     SET MA1 TO 1.
207400     SEARCH T-CBSA-DATA VARYING MA1
207500        AT END
207600           MOVE 60 TO PPS-RTC
207700        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
207800           SET MA2 TO MA1.
207900
208000     IF PPS-RTC NOT = 60
208100        PERFORM 0585-GET-IPPS-CBSA-SIZE
208200           THRU 0585-EXIT VARYING MA2
208300           FROM MA1 BY 1 UNTIL
208400                T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
208500
208600
208700*------------------------------------------------------------*
208800* GET THE PUERTO RICO SPECIFIC WAGE INDEX FOR PR HOSPITALS   *
208900*------------------------------------------------------------*
209000     IF (B-DISCHARGE-DATE < 20161001) AND
209100        (P-NEW-STATE = 40 OR 84)
209200        PERFORM 0590-GET-IPPS-CBSA-PR THRU 0590-EXIT
209300        IF W-IPPS-PR-WAGE-INDEX = 0
209400           MOVE 52 TO PPS-RTC
209500        END-IF
209600     END-IF.
209700
209800
209900* ADDED 9-10-20 FOR SUPPLEMENTAL WAGE INDEX.
210000* WHEN P-SUPP-WI-IND = '2' THE SUPPLEMENTAL WAGE INDEX FIELD
210100* CONTAINS THE IPPS WAGE INDEX VALUE.
210200     IF B-DISCHARGE-DATE > 20200930
210300        IF P-SUPP-WI-IND = '2'
210400           IF P-SUPP-WI > 0
210500              MOVE P-SUPP-WI TO W-IPPS-WAGE-INDEX
210600* MOVED CALCULATION OF H-CAPI-GAF TO LTCAL MODULE BECAUSE ITS
210700* VALUE IS NOT PASSED BY THE LTDRV MODULE TO THE LTCAL MODULE
210800*             COMPUTE H-CAPI-GAF = P-SUPP-WI ** 0.6848
210900              GO TO 0575-EXIT
211000           ELSE
211100              MOVE 52 TO PPS-RTC
211200              GO TO 0575-EXIT
211300           END-IF
211400        END-IF
211500     END-IF.
211600
211700 0575-EXIT.
211800      EXIT.
211900
212000
212100******************************************************************
212200*                                                                *
212300* FLOOR ASSIGNMENTS FOR FY 2006 ONLY:                            *
212400*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
212500*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
212600*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
212700* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV063             *
212800*                                                                *
212900******************************************************************
213000 0580-FY2006-FLOOR-CBSA.
213100******************************************************************
213200
213300     IF HOLD-PROV-IPPS-CBSA = '   10'
213400        AND P-NEW-CBSA-SPEC-PAY-IND = 'Y'
213500        AND P-NEW-STATE = 10
213600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213700            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
213800
213900     IF HOLD-PROV-IPPS-CBSA = '   50'
214000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
214100        AND P-NEW-STATE = 50
214200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214300            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
214400
214500     IF HOLD-PROV-IPPS-CBSA = '10900'
214600        AND P-NEW-STATE = 31
214700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214800            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
214900
215000     IF HOLD-PROV-IPPS-CBSA = '15764'
215100        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
215200        AND P-NEW-STATE = 30
215300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
215400            MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
215500
215600     IF HOLD-PROV-IPPS-CBSA = '16620'
215700        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
215800        AND P-NEW-STATE = 36
215900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216000            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
216100
216200     IF HOLD-PROV-IPPS-CBSA = '19060'
216300        AND P-NEW-STATE = 21
216400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216500            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
216600
216700     IF HOLD-PROV-IPPS-CBSA = '22020'
216800        AND P-NEW-STATE = 24
216900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217000            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
217100
217200     IF HOLD-PROV-IPPS-CBSA = '24220'
217300        AND P-NEW-STATE = 24
217400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217500            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
217600
217700     IF HOLD-PROV-IPPS-CBSA = '24580'
217800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
217900        AND P-NEW-STATE = 52
218000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218100            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
218200
218300     IF HOLD-PROV-IPPS-CBSA = '25540'
218400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
218500        AND P-NEW-STATE = 07
218600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218700            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
218800
218900     IF HOLD-PROV-IPPS-CBSA = '30300'
219000        AND P-NEW-STATE = 50
219100            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219200            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
219300
219400     IF HOLD-PROV-IPPS-CBSA = '37620'
219500        AND P-NEW-STATE = 36
219600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219700            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
219800
219900     IF HOLD-PROV-IPPS-CBSA = '39900'
220000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
220100        AND P-NEW-STATE = 05
220200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220300            MOVE '   05' TO HOLD-PROV-IPPS-CBSA.
220400
220500     IF HOLD-PROV-IPPS-CBSA = '48260'
220600        AND P-NEW-STATE = 36
220700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
220900
221000     IF HOLD-PROV-IPPS-CBSA = '48540'
221100        AND P-NEW-STATE = 36
221200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
221400
221500     IF HOLD-PROV-IPPS-CBSA = '48540'
221600        AND P-NEW-STATE = 51
221700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221800            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
221900
222000     IF HOLD-PROV-IPPS-CBSA = '48864'
222100        AND P-NEW-STATE = 31
222200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222300            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
222400
222500     IF HOLD-PROV-IPPS-CBSA = '49660'
222600        AND P-NEW-STATE = 36
222700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222800            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
222900
223000
223100 0580-FY2006-EXIT.
223200      EXIT.
223300
223400
223500******************************************************************
223600*                                                                *
223700* FLOOR ASSIGNMENTS FOR FY 2007:                                 *
223800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
223900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
224000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
224100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV071             *
224200*                                                                *
224300******************************************************************
224400 0580-FY2007-FLOOR-CBSA.
224500******************************************************************
224600
224700     IF HOLD-PROV-IPPS-CBSA = '   10'
224800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
224900        AND P-NEW-STATE = 10
225000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225100            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
225200
225300     IF HOLD-PROV-IPPS-CBSA = '   14'
225400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
225500        AND P-NEW-STATE = 14
225600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225700            MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
225800
225900     IF HOLD-PROV-IPPS-CBSA = '   26'
226000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
226100        AND P-NEW-STATE = 26
226200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226300            MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
226400
226500     IF HOLD-PROV-IPPS-CBSA = '   50'
226600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
226700        AND P-NEW-STATE = 50
226800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226900            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
227000
227100     IF HOLD-PROV-IPPS-CBSA = '10900'
227200        AND P-NEW-STATE = 31
227300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227400            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
227500
227600     IF HOLD-PROV-IPPS-CBSA = '19060'
227700        AND P-NEW-STATE = 21
227800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227900            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
228000
228100     IF HOLD-PROV-IPPS-CBSA = '22020'
228200        AND P-NEW-STATE = 24
228300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228400            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
228500
228600     IF HOLD-PROV-IPPS-CBSA = '24220'
228700        AND P-NEW-STATE = 24
228800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228900            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
229000
229100     IF HOLD-PROV-IPPS-CBSA = '24580'
229200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
229300        AND P-NEW-STATE = 52
229400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
229500            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
229600
229700     IF HOLD-PROV-IPPS-CBSA = '25540'
229800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
229900        AND P-NEW-STATE = 07
230000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
230100            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
230200
230300     IF HOLD-PROV-IPPS-CBSA = '26580'
230400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
230500        AND P-NEW-STATE = 36
230600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
230700            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
230800
230900
231000*----------------------------------------------------------*
231100*  ON AND AFTER 11/03/2006, NO HOSPITALS RECLASSIFYING TO  *
231200*  CBSA 27860 WILL RECEIVE ITS STATE FLOOR DUE TO THE WIX  *
231300*  CHANGE IN THE IPPS FINAL RULE 2007 CORRECTION NOTICE 1  *
231400*----------------------------------------------------------*
231500*  - LOGIC DISABLED 11-20-2006 FOR RELEASE 07.5            *
231600*  - REINSTATED & ALTERED 12-28-2006 FOR RELEASE 08.0 TO   *
231700*    MATCH THE IPPS PRICER (BECAUSE THIS CODE ONLY APPLIES *
231800*    RECLASS PROVIDERS AND THERE ARE NO LTCH RECLASS       *
231900*    PROVIDERS, THESE CHANGES DO NOT AFFECT BILL PAYMENT)  *
232000*----------------------------------------------------------*
232100     IF B-DISCHARGE-DATE < 20061103
232200        IF HOLD-PROV-IPPS-CBSA = '27860'
232300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
232400           AND P-NEW-STATE = 26
232500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232600               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
232700*----------------------------------------------------------*
232800
232900
233000     IF HOLD-PROV-IPPS-CBSA = '29100'
233100        AND P-NEW-STATE = 52
233200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233300            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
233400
233500     IF HOLD-PROV-IPPS-CBSA = '30300'
233600        AND P-NEW-STATE = 50
233700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233800            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
233900
234000     IF HOLD-PROV-IPPS-CBSA = '37620'
234100        AND P-NEW-STATE = 36
234200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
234400
234500     IF HOLD-PROV-IPPS-CBSA = '37964'
234600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
234700        AND P-NEW-STATE = 31
234800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234900            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
235000
235100     IF HOLD-PROV-IPPS-CBSA = '38300'
235200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235300        AND P-NEW-STATE = 36
235400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
235600
235700     IF HOLD-PROV-IPPS-CBSA = '39300'
235800        AND P-NEW-STATE = 22
235900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236000            MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
236100
236200     IF HOLD-PROV-IPPS-CBSA = '39300'
236300        AND P-NEW-STATE = 41
236400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236500            MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
236600
236700     IF HOLD-PROV-IPPS-CBSA = '45500'
236800        AND P-NEW-STATE = 45
236900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237000            MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
237100
237200     IF HOLD-PROV-IPPS-CBSA = '48260'
237300        AND P-NEW-STATE = 36
237400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237500            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
237600
237700     IF HOLD-PROV-IPPS-CBSA = '48540'
237800        AND P-NEW-STATE = 36
237900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238000            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
238100
238200     IF HOLD-PROV-IPPS-CBSA = '48540'
238300        AND P-NEW-STATE = 51
238400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238500            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
238600
238700     IF HOLD-PROV-IPPS-CBSA = '48864'
238800        AND P-NEW-STATE = 31
238900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239000            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
239100
239200
239300 0580-FY2007-EXIT.
239400      EXIT.
239500
239600
239700******************************************************************
239800*                                                                *
239900* FLOOR ASSIGNMENTS FOR FY 2008:                                 *
240000*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
240100*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
240200*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
240300* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV080             *
240400*                                                                *
240500******************************************************************
240600 0580-FY2008-FLOOR-CBSA.
240700******************************************************************
240800
240900        IF HOLD-PROV-IPPS-CBSA = '   39'
241000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
241100           AND P-NEW-STATE = 33
241200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241300               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
241400
241500        IF HOLD-PROV-IPPS-CBSA = '   39'
241600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
241700           AND P-NEW-STATE = 39
241800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241900               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
242000
242100        IF HOLD-PROV-IPPS-CBSA = '10900'
242200           AND P-NEW-STATE = 31
242300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
242500
242600        IF HOLD-PROV-IPPS-CBSA = '19060'
242700           AND P-NEW-STATE = 21
242800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
243000
243100        IF HOLD-PROV-IPPS-CBSA = '21780'
243200           AND P-NEW-STATE = 15
243300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
243500
243600        IF HOLD-PROV-IPPS-CBSA = '21780'
243700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
243800           AND P-NEW-STATE = 15
243900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
244100
244200        IF HOLD-PROV-IPPS-CBSA = '22020'
244300           AND P-NEW-STATE = 24
244400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244500               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
244600
244700        IF HOLD-PROV-IPPS-CBSA = '24220'
244800           AND P-NEW-STATE = 24
244900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245000               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
245100
245200        IF HOLD-PROV-IPPS-CBSA = '24580'
245300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
245400           AND P-NEW-STATE = 52
245500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245600               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
245700
245800        IF HOLD-PROV-IPPS-CBSA = '25540'
245900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
246000           AND P-NEW-STATE = 07
246100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
246200               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
246300
246400        IF HOLD-PROV-IPPS-CBSA = '28420'
246500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
246600           AND P-NEW-STATE = 50
246700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
246800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
246900
247000        IF HOLD-PROV-IPPS-CBSA = '28700'
247100           AND P-NEW-STATE = 44
247200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
247400
247500        IF HOLD-PROV-IPPS-CBSA = '28700'
247600           AND P-NEW-STATE = 49
247700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247800               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
247900
248000        IF HOLD-PROV-IPPS-CBSA = '30300'
248100           AND P-NEW-STATE = 50
248200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
248400
248500        IF HOLD-PROV-IPPS-CBSA = '35084'
248600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
248700           AND P-NEW-STATE = 31
248800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
249000
249100        IF HOLD-PROV-IPPS-CBSA = '37620'
249200           AND P-NEW-STATE = 36
249300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
249500
249600        IF HOLD-PROV-IPPS-CBSA = '37964'
249700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
249800           AND P-NEW-STATE = 31
249900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
250100
250200        IF HOLD-PROV-IPPS-CBSA = '38300'
250300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
250400           AND P-NEW-STATE = 36
250500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
250700
250800        IF HOLD-PROV-IPPS-CBSA = '45500'
250900           AND P-NEW-STATE = 45
251000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
251200
251300        IF HOLD-PROV-IPPS-CBSA = '48260'
251400           AND P-NEW-STATE = 36
251500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
251700
251800        IF HOLD-PROV-IPPS-CBSA = '48540'
251900           AND P-NEW-STATE = 36
252000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
252200
252300        IF HOLD-PROV-IPPS-CBSA = '48540'
252400           AND P-NEW-STATE = 51
252500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
252700
252800        IF HOLD-PROV-IPPS-CBSA = '48864'
252900           AND P-NEW-STATE = 31
253000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
253200
253300        IF HOLD-PROV-IPPS-CBSA = '48864'
253400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
253500           AND P-NEW-STATE = 31
253600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
253800
253900
254000 0580-FY2008-EXIT.
254100      EXIT.
254200
254300
254400******************************************************************
254500*                                                                *
254600* FLOOR ASSIGNMENTS FOR FY 2009:                                 *
254700*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
254800*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
254900*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
255000* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV093             *
255100*                                                                *
255200******************************************************************
255300 0580-FY2009-FLOOR-CBSA.
255400******************************************************************
255500
255600        IF HOLD-PROV-IPPS-CBSA = '   04'
255700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
255800           AND P-NEW-STATE = 04
255900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256000               MOVE '   04' TO HOLD-PROV-IPPS-CBSA.
256100
256200        IF HOLD-PROV-IPPS-CBSA = '   04'
256300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
256400           AND P-NEW-STATE = 19
256500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256600               MOVE '   19' TO HOLD-PROV-IPPS-CBSA.
256700
256800        IF HOLD-PROV-IPPS-CBSA = '   14'
256900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257000           AND P-NEW-STATE = 14
257100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257200               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
257300
257400        IF HOLD-PROV-IPPS-CBSA = '   14'
257500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257600           AND P-NEW-STATE = 26
257700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257800               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
257900
258000        IF HOLD-PROV-IPPS-CBSA = '10900'
258100           AND P-NEW-STATE = 31
258200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
258400
258500        IF HOLD-PROV-IPPS-CBSA = '19340'
258600           AND P-NEW-STATE = 16
258700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258800               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
258900
259000        IF HOLD-PROV-IPPS-CBSA = '21780'
259100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
259200           AND P-NEW-STATE = 15
259300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
259500
259600        IF HOLD-PROV-IPPS-CBSA = '22020'
259700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
259800           AND P-NEW-STATE = 43
259900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260000               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
260100
260200        IF HOLD-PROV-IPPS-CBSA = '22900'
260300           AND P-NEW-STATE = 37
260400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260500               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
260600
260700        IF HOLD-PROV-IPPS-CBSA = '24580'
260800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
260900           AND P-NEW-STATE = 52
261000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261100               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
261200
261300        IF HOLD-PROV-IPPS-CBSA = '25540'
261400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
261500           AND P-NEW-STATE = 07
261600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
261800
261900        IF HOLD-PROV-IPPS-CBSA = '28420'
262000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
262100           AND P-NEW-STATE = 50
262200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
262400
262500        IF HOLD-PROV-IPPS-CBSA = '28700'
262600           AND P-NEW-STATE = 44
262700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
262900
263000        IF HOLD-PROV-IPPS-CBSA = '28700'
263100           AND P-NEW-STATE = 49
263200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263300               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
263400
263500        IF HOLD-PROV-IPPS-CBSA = '28700'
263600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
263700           AND P-NEW-STATE = 18
263800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
264000
264100        IF HOLD-PROV-IPPS-CBSA = '28700'
264200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
264300           AND P-NEW-STATE = 44
264400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
264600
264700        IF HOLD-PROV-IPPS-CBSA = '28940'
264800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
264900           AND P-NEW-STATE = 18
265000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
265200
265300        IF HOLD-PROV-IPPS-CBSA = '28940'
265400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
265500           AND P-NEW-STATE = 44
265600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
265700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
265800
265900        IF HOLD-PROV-IPPS-CBSA = '34820'
266000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
266100           AND P-NEW-STATE = 34
266200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266300               MOVE '   34' TO HOLD-PROV-IPPS-CBSA.
266400
266500        IF HOLD-PROV-IPPS-CBSA = '34820'
266600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
266700           AND P-NEW-STATE = 42
266800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
266900               MOVE '   42' TO HOLD-PROV-IPPS-CBSA.
267000
267100        IF HOLD-PROV-IPPS-CBSA = '37620'
267200           AND P-NEW-STATE = 36
267300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
267400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
267500
267600        IF HOLD-PROV-IPPS-CBSA = '37964'
267700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
267800           AND P-NEW-STATE = 31
267900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
268100
268200        IF HOLD-PROV-IPPS-CBSA = '38340'
268300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
268400           AND P-NEW-STATE = 47
268500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268600               MOVE '   47' TO HOLD-PROV-IPPS-CBSA.
268700
268800        IF HOLD-PROV-IPPS-CBSA = '41620'
268900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269000           AND P-NEW-STATE = 29
269100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269200               MOVE '   29' TO HOLD-PROV-IPPS-CBSA.
269300
269400        IF HOLD-PROV-IPPS-CBSA = '43580'
269500           AND P-NEW-STATE = 16
269600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269700               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
269800
269900        IF HOLD-PROV-IPPS-CBSA = '48540'
270000           AND P-NEW-STATE = 36
270100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
270300
270400        IF HOLD-PROV-IPPS-CBSA = '48540'
270500           AND P-NEW-STATE = 51
270600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270700               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
270800
270900        IF HOLD-PROV-IPPS-CBSA = '48864'
271000           AND P-NEW-STATE = 31
271100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
271300
271400        IF HOLD-PROV-IPPS-CBSA = '48864'
271500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
271600           AND P-NEW-STATE = 31
271700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
271900
272000        IF HOLD-PROV-IPPS-CBSA = '19060'
272100           AND P-NEW-STATE = 21
272200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
272400
272500        IF HOLD-PROV-IPPS-CBSA = '19060'
272600           AND P-NEW-STATE = 51
272700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
272900
273000        IF HOLD-PROV-IPPS-CBSA = '22020'
273100           AND P-NEW-STATE = 24
273200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273300               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
273400
273500        IF HOLD-PROV-IPPS-CBSA = '24220'
273600           AND P-NEW-STATE = 24
273700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
273900
274000        IF HOLD-PROV-IPPS-CBSA = '30300'
274100           AND P-NEW-STATE = 50
274200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
274400
274500        IF HOLD-PROV-IPPS-CBSA = '48260'
274600           AND P-NEW-STATE = 36
274700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
274900
275000
275100 0580-FY2009-EXIT.
275200      EXIT.
275300
275400
275500******************************************************************
275600*                                                                *
275700* FLOOR ASSIGNMENTS FOR FY 2010:                                 *
275800*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
275900*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
276000*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
276100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV100             *
276200*                                                                *
276300******************************************************************
276400 0580-FY2010-FLOOR-CBSA.
276500******************************************************************
276600
276700        IF HOLD-PROV-IPPS-CBSA = '   33'
276800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
276900           AND P-NEW-STATE = 30
277000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277100               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
277200
277300        IF HOLD-PROV-IPPS-CBSA = '   33'
277400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
277500           AND P-NEW-STATE = 33
277600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277700               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
277800
277900        IF HOLD-PROV-IPPS-CBSA = '10900'
278000           AND P-NEW-STATE = 31
278100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
278300
278400        IF HOLD-PROV-IPPS-CBSA = '19340'
278500           AND P-NEW-STATE = 16
278600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278700               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
278800
278900        IF HOLD-PROV-IPPS-CBSA = '19340'
279000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
279100           AND P-NEW-STATE = 16
279200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279300               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
279400
279500        IF HOLD-PROV-IPPS-CBSA = '21780'
279600           AND P-NEW-STATE = 15
279700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279800               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
279900
280000        IF HOLD-PROV-IPPS-CBSA = '21780'
280100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
280200           AND P-NEW-STATE = 15
280300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
280500
280600        IF HOLD-PROV-IPPS-CBSA = '25180'
280700           AND P-NEW-STATE = 21
280800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
281000
281100        IF HOLD-PROV-IPPS-CBSA = '25540'
281200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
281300           AND P-NEW-STATE = 07
281400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281500               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
281600
281700        IF HOLD-PROV-IPPS-CBSA = '28420'
281800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
281900           AND P-NEW-STATE = 50
282000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282100               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
282200
282300        IF HOLD-PROV-IPPS-CBSA = '28940'
282400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
282500           AND P-NEW-STATE = 18
282600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
282800
282900        IF HOLD-PROV-IPPS-CBSA = '28940'
283000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
283100           AND P-NEW-STATE = 44
283200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
283400
283500        IF HOLD-PROV-IPPS-CBSA = '35084'
283600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
283700           AND P-NEW-STATE = 31
283800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
284000
284100        IF HOLD-PROV-IPPS-CBSA = '37620'
284200           AND P-NEW-STATE = 36
284300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
284500
284600        IF HOLD-PROV-IPPS-CBSA = '37964'
284700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
284800           AND P-NEW-STATE = 31
284900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
285100
285200        IF HOLD-PROV-IPPS-CBSA = '48540'
285300           AND P-NEW-STATE = 36
285400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285500               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
285600
285700        IF HOLD-PROV-IPPS-CBSA = '48540'
285800           AND P-NEW-STATE = 51
285900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
286000               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
286100
286200        IF HOLD-PROV-IPPS-CBSA = '48864'
286300           AND P-NEW-STATE = 31
286400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
286500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
286600
286700        IF HOLD-PROV-IPPS-CBSA = '48864'
286800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
286900           AND P-NEW-STATE = 31
287000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
287100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
287200
287300        IF HOLD-PROV-IPPS-CBSA = '49660'
287400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
287500           AND P-NEW-STATE = 36
287600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
287700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
287800
287900        IF HOLD-PROV-IPPS-CBSA = '19060'
288000           AND P-NEW-STATE = 21
288100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288200               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
288300
288400        IF HOLD-PROV-IPPS-CBSA = '22020'
288500           AND P-NEW-STATE = 24
288600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288700               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
288800
288900        IF HOLD-PROV-IPPS-CBSA = '24220'
289000           AND P-NEW-STATE = 24
289100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289200               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
289300
289400        IF HOLD-PROV-IPPS-CBSA = '30300'
289500           AND P-NEW-STATE = 50
289600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289700               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
289800
289900        IF HOLD-PROV-IPPS-CBSA = '35084'
290000           AND P-NEW-STATE = 31
290100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
290300
290400        IF HOLD-PROV-IPPS-CBSA = '48260'
290500           AND P-NEW-STATE = 36
290600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
290800
290900        IF HOLD-PROV-IPPS-CBSA = '48260'
291000           AND P-NEW-STATE = 51
291100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291200               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
291300
291400
291500 0580-FY2010-EXIT.
291600      EXIT.
291700
291800******************************************************************
291900*                                                                *
292000* FLOOR ASSIGNMENTS FOR FY 2011:                                 *
292100* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV110             *
292200*                                                                *
292300******************************************************************
292400
292500 0580-FY2011-FLOOR-CBSA.
292600
292700        IF HOLD-PROV-IPPS-CBSA = '   45'
292800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
292900          AND P-NEW-STATE = 45
293000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
293200
293300        IF HOLD-PROV-IPPS-CBSA = '   37'
293400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
293500          AND P-NEW-STATE = 37
293600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293700               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
293800
293900        IF HOLD-PROV-IPPS-CBSA = '10900'
294000           AND P-NEW-STATE = 31
294100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
294300
294400        IF HOLD-PROV-IPPS-CBSA = '21500'
294500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294600           AND P-NEW-STATE = 33
294700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294800               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
294900
295000        IF HOLD-PROV-IPPS-CBSA = '21500'
295100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
295200           AND P-NEW-STATE = 39
295300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
295500
295600        IF HOLD-PROV-IPPS-CBSA = '21780'
295700           AND P-NEW-STATE = 15
295800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295900               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
296000
296100        IF HOLD-PROV-IPPS-CBSA = '22900'
296200           AND P-NEW-STATE = 37
296300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296400               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
296500
296600        IF HOLD-PROV-IPPS-CBSA = '24540'
296700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
296800           AND P-NEW-STATE = 53
296900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297000               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
297100
297200        IF HOLD-PROV-IPPS-CBSA = '25540'
297300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
297400           AND P-NEW-STATE = 07
297500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297600               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
297700
297800        IF HOLD-PROV-IPPS-CBSA = '28700'
297900           AND P-NEW-STATE = 44
298000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
298200
298300        IF HOLD-PROV-IPPS-CBSA = '28700'
298400           AND P-NEW-STATE = 49
298500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298600               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
298700
298800        IF HOLD-PROV-IPPS-CBSA = '28940'
298900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
299000           AND P-NEW-STATE = 18
299100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299200               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
299300
299400        IF HOLD-PROV-IPPS-CBSA = '28940'
299500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
299600           AND P-NEW-STATE = 44
299700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
299900
300000        IF HOLD-PROV-IPPS-CBSA = '37620'
300100           AND P-NEW-STATE = 36
300200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
300400
300500        IF HOLD-PROV-IPPS-CBSA = '37620'
300600           AND P-NEW-STATE = 51
300700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
300900
301000        IF HOLD-PROV-IPPS-CBSA = '37964'
301100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
301200           AND P-NEW-STATE = 31
301300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
301500
301600        IF HOLD-PROV-IPPS-CBSA = '38300'
301700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
301800           AND P-NEW-STATE = 36
301900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
302100
302200        IF HOLD-PROV-IPPS-CBSA = '38300'
302300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
302400           AND P-NEW-STATE = 39
302500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
302700
302800        IF HOLD-PROV-IPPS-CBSA = '43580'
302900           AND P-NEW-STATE = 43
303000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303100               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
303200
303300        IF HOLD-PROV-IPPS-CBSA = '48540'
303400           AND P-NEW-STATE = 36
303500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
303700
303800        IF HOLD-PROV-IPPS-CBSA = '48540'
303900           AND P-NEW-STATE = 51
304000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304100               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
304200
304300        IF HOLD-PROV-IPPS-CBSA = '48864'
304400           AND P-NEW-STATE = 31
304500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
304700
304800        IF HOLD-PROV-IPPS-CBSA = '17300'
304900           AND P-NEW-STATE = 18
305000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
305200
305300        IF HOLD-PROV-IPPS-CBSA = '17300'
305400           AND P-NEW-STATE = 44
305500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305600               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
305700
305800        IF HOLD-PROV-IPPS-CBSA = '19060'
305900           AND P-NEW-STATE = 21
306000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
306200
306300        IF HOLD-PROV-IPPS-CBSA = '22020'
306400           AND P-NEW-STATE = 24
306500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
306700
306800        IF HOLD-PROV-IPPS-CBSA = '22020'
306900           AND P-NEW-STATE = 35
307000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
307100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
307200
307300        IF HOLD-PROV-IPPS-CBSA = '24220'
307400           AND P-NEW-STATE = 24
307500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
307600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
307700
307800        IF HOLD-PROV-IPPS-CBSA = '24220'
307900           AND P-NEW-STATE = 35
308000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308100               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
308200
308300        IF HOLD-PROV-IPPS-CBSA = '30300'
308400           AND P-NEW-STATE = 50
308500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308600               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
308700
308800        IF HOLD-PROV-IPPS-CBSA = '44600'
308900           AND P-NEW-STATE = 36
309000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
309100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
309200
309300        IF HOLD-PROV-IPPS-CBSA = '44600'
309400           AND P-NEW-STATE = 51
309500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
309600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
309700
309800        IF HOLD-PROV-IPPS-CBSA = '45500'
309900           AND P-NEW-STATE = 45
310000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
310100               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
310200
310300
310400 0580-FY2011-EXIT.
310500      EXIT.
310600
310700******************************************************************
310800*                                                                *
310900* FLOOR ASSIGNMENTS FOR FY 2012:                                 *
311000* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV120             *
311100*                                                                *
311200* ******* CHANGE HOLD-PROV-CBSA TO HOLD-PROV-IPPS-CBSA ******    *
311300*                                                                *
311400******************************************************************
311500
311600 0580-FY2012-FLOOR-CBSA.
311700
311800**************YEARCHANGE 2012.0 ******************************
311900
312000        IF HOLD-PROV-IPPS-CBSA = '   30'
312100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
312200          AND P-NEW-STATE = 30
312300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
312400               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
312500
312600        IF HOLD-PROV-IPPS-CBSA = '   39'
312700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
312800          AND P-NEW-STATE = 39
312900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313000               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
313100
313200        IF HOLD-PROV-IPPS-CBSA = '   39'
313300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
313400          AND P-NEW-STATE = 33
313500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313600               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
313700
313800        IF HOLD-PROV-IPPS-CBSA = '10900'
313900           AND P-NEW-STATE = 31
314000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314100               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
314200
314300        IF HOLD-PROV-IPPS-CBSA = '14484'
314400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
314500           AND P-NEW-STATE = 22
314600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314700               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
314800
314900        IF HOLD-PROV-IPPS-CBSA = '16020'
315000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
315100           AND P-NEW-STATE = 14
315200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
315300               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
315400
315500        IF HOLD-PROV-IPPS-CBSA = '21500'
315600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
315700           AND P-NEW-STATE = 33
315800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
315900               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
316000
316100        IF HOLD-PROV-IPPS-CBSA = '21500'
316200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
316300           AND P-NEW-STATE = 39
316400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
316500               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
316600
316700        IF HOLD-PROV-IPPS-CBSA = '22900'
316800           AND P-NEW-STATE = 37
316900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317000               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
317100
317200        IF HOLD-PROV-IPPS-CBSA = '25180'
317300           AND P-NEW-STATE = 21
317400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317500               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
317600
317700        IF HOLD-PROV-IPPS-CBSA = '25540'
317800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
317900           AND P-NEW-STATE = 07
318000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318100               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
318200
318300        IF HOLD-PROV-IPPS-CBSA = '25540'
318400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
318500           AND P-NEW-STATE = 22
318600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318700               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
318800
318900        IF HOLD-PROV-IPPS-CBSA = '26820'
319000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
319100           AND P-NEW-STATE = 53
319200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319300               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
319400
319500        IF HOLD-PROV-IPPS-CBSA = '28700'
319600           AND P-NEW-STATE = 44
319700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
319900
320000        IF HOLD-PROV-IPPS-CBSA = '28700'
320100           AND P-NEW-STATE = 49
320200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
320300               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
320400
320500        IF HOLD-PROV-IPPS-CBSA = '28700'
320600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
320700           AND P-NEW-STATE = 18
320800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
320900               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
321000
321100        IF HOLD-PROV-IPPS-CBSA = '28700'
321200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
321300           AND P-NEW-STATE = 44
321400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
321500               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
321600
321700        IF HOLD-PROV-IPPS-CBSA = '28940'
321800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
321900           AND P-NEW-STATE = 18
322000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322100               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
322200
322300        IF HOLD-PROV-IPPS-CBSA = '35084'
322400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
322500           AND P-NEW-STATE = 31
322600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
322800
322900        IF HOLD-PROV-IPPS-CBSA = '37620'
323000           AND P-NEW-STATE = 36
323100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
323200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
323300
323400        IF HOLD-PROV-IPPS-CBSA = '37964'
323500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
323600           AND P-NEW-STATE = 31
323700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
323800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
323900
324000        IF HOLD-PROV-IPPS-CBSA = '43580'
324100           AND P-NEW-STATE = 43
324200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
324300               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
324400
324500        IF HOLD-PROV-IPPS-CBSA = '44600'
324600           AND P-NEW-STATE = 36
324700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
324800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
324900
325000        IF HOLD-PROV-IPPS-CBSA = '44600'
325100           AND P-NEW-STATE = 51
325200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
325300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
325400
325500        IF HOLD-PROV-IPPS-CBSA = '48540'
325600           AND P-NEW-STATE = 36
325700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
325800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
325900
326000        IF HOLD-PROV-IPPS-CBSA = '48540'
326100           AND P-NEW-STATE = 51
326200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
326300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
326400
326500        IF HOLD-PROV-IPPS-CBSA = '48864'
326600           AND P-NEW-STATE = 31
326700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
326800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
326900
327000        IF HOLD-PROV-IPPS-CBSA = '49660'
327100           AND P-NEW-STATE = 36
327200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
327300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
327400
327500        IF HOLD-PROV-IPPS-CBSA = '49660'
327600           AND P-NEW-STATE = 39
327700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
327800               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
327900
328000        IF HOLD-PROV-IPPS-CBSA = '19060'
328100           AND P-NEW-STATE = 21
328200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
328300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
328400
328500        IF HOLD-PROV-IPPS-CBSA = '22020'
328600           AND P-NEW-STATE = 24
328700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
328800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
328900
329000        IF HOLD-PROV-IPPS-CBSA = '22020'
329100           AND P-NEW-STATE = 35
329200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
329300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
329400
329500        IF HOLD-PROV-IPPS-CBSA = '24220'
329600           AND P-NEW-STATE = 24
329700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
329800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
329900
330000        IF HOLD-PROV-IPPS-CBSA = '24220'
330100           AND P-NEW-STATE = 35
330200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
330300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
330400
330500        IF HOLD-PROV-IPPS-CBSA = '30300'
330600           AND P-NEW-STATE = 50
330700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
330800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
330900
331000        IF HOLD-PROV-IPPS-CBSA = '30860'
331100           AND P-NEW-STATE = 46
331200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
331300               MOVE '   46' TO HOLD-PROV-IPPS-CBSA.
331400
331500        IF HOLD-PROV-IPPS-CBSA = '35084'
331600           AND P-NEW-STATE = 31
331700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
331800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
331900
332000        IF HOLD-PROV-IPPS-CBSA = '39300'
332100           AND P-NEW-STATE = 22
332200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
332300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
332400
332500        IF HOLD-PROV-IPPS-CBSA = '45500'
332600           AND P-NEW-STATE = 45
332700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
332800               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
332900
333000**************YEARCHANGE 2012.0 ******************************
333100
333200 0580-FY2012-EXIT.
333300      EXIT.
333400
333500 0580-FY2013-FLOOR-CBSA.
333600
333700**************YEARCHANGE 2013.0 ****************************
333800
333900        IF HOLD-PROV-IPPS-CBSA = '10900'
334000           AND P-NEW-STATE = 31
334100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
334200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
334300
334400        IF HOLD-PROV-IPPS-CBSA = '14484'
334500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
334600           AND P-NEW-STATE = 22
334700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
334800               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
334900
335000        IF HOLD-PROV-IPPS-CBSA = '16020'
335100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
335200           AND P-NEW-STATE = 14
335300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
335400               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
335500
335600        IF HOLD-PROV-IPPS-CBSA = '21500'
335700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
335800           AND P-NEW-STATE = 33
335900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
336000               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
336100
336200        IF HOLD-PROV-IPPS-CBSA = '21500'
336300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
336400           AND P-NEW-STATE = 39
336500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
336600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
336700
336800        IF HOLD-PROV-IPPS-CBSA = '21780'
336900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
337000           AND P-NEW-STATE = 15
337100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
337200               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
337300
337400        IF HOLD-PROV-IPPS-CBSA = '24580'
337500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
337600           AND P-NEW-STATE = 52
337700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
337800               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
337900
338000        IF HOLD-PROV-IPPS-CBSA = '25540'
338100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
338200           AND P-NEW-STATE = 07
338300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
338400               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
338500
338600        IF HOLD-PROV-IPPS-CBSA = '25540'
338700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
338800           AND P-NEW-STATE = 22
338900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
339000               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
339100
339200        IF HOLD-PROV-IPPS-CBSA = '26820'
339300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
339400           AND P-NEW-STATE = 53
339500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
339600               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
339700
339800        IF HOLD-PROV-IPPS-CBSA = '27900'
339900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
340000           AND P-NEW-STATE = 17
340100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
340200               MOVE '   17' TO HOLD-PROV-IPPS-CBSA.
340300
340400        IF HOLD-PROV-IPPS-CBSA = '28700'
340500           AND P-NEW-STATE = 44
340600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
340700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
340800
340900        IF HOLD-PROV-IPPS-CBSA = '28700'
341000           AND P-NEW-STATE = 49
341100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
341200               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
341300
341400        IF HOLD-PROV-IPPS-CBSA = '28700'
341500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
341600           AND P-NEW-STATE = 18
341700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
341800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
341900
342000        IF HOLD-PROV-IPPS-CBSA = '28700'
342100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
342200           AND P-NEW-STATE = 44
342300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
342400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
342500
342600        IF HOLD-PROV-IPPS-CBSA = '28940'
342700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
342800           AND P-NEW-STATE = 18
342900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
343000               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
343100
343200        IF HOLD-PROV-IPPS-CBSA = '35084'
343300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
343400           AND P-NEW-STATE = 31
343500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
343600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
343700
343800        IF HOLD-PROV-IPPS-CBSA = '37620'
343900           AND P-NEW-STATE = 36
344000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
344100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
344200
344300        IF HOLD-PROV-IPPS-CBSA = '37964'
344400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
344500           AND P-NEW-STATE = 31
344600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
344700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
344800
344900        IF HOLD-PROV-IPPS-CBSA = '38300'
345000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
345100           AND P-NEW-STATE = 36
345200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
345300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
345400
345500        IF HOLD-PROV-IPPS-CBSA = '43580'
345600           AND P-NEW-STATE = 43
345700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
345800               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
345900
346000        IF HOLD-PROV-IPPS-CBSA = '48540'
346100           AND P-NEW-STATE = 36
346200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
346300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
346400
346500        IF HOLD-PROV-IPPS-CBSA = '48540'
346600           AND P-NEW-STATE = 51
346700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
346800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
346900
347000        IF HOLD-PROV-IPPS-CBSA = '48864'
347100           AND P-NEW-STATE = 31
347200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
347300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
347400
347500        IF HOLD-PROV-IPPS-CBSA = '49660'
347600           AND P-NEW-STATE = 36
347700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
347800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
347900
348000        IF HOLD-PROV-IPPS-CBSA = '49660'
348100           AND P-NEW-STATE = 39
348200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
348300               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
348400
348500        IF HOLD-PROV-IPPS-CBSA = '22020'
348600           AND P-NEW-STATE = 24
348700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
348800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
348900
349000        IF HOLD-PROV-IPPS-CBSA = '22020'
349100           AND P-NEW-STATE = 35
349200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
349300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
349400
349500        IF HOLD-PROV-IPPS-CBSA = '24220'
349600           AND P-NEW-STATE = 24
349700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
349800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
349900
350000        IF HOLD-PROV-IPPS-CBSA = '24220'
350100           AND P-NEW-STATE = 35
350200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
350300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
350400
350500        IF HOLD-PROV-IPPS-CBSA = '30300'
350600           AND P-NEW-STATE = 50
350700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
350800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
350900
351000        IF HOLD-PROV-IPPS-CBSA = '39300'
351100           AND P-NEW-STATE = 22
351200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
351300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
351400
351500        IF HOLD-PROV-IPPS-CBSA = '39300'
351600           AND P-NEW-STATE = 41
351700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
351800               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
351900
352000        IF HOLD-PROV-IPPS-CBSA = '44600'
352100           AND P-NEW-STATE = 36
352200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
352300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
352400
352500 0580-FY2013-EXIT.
352600      EXIT.
352700
352800 0580-FY2014-FLOOR-CBSA.
352900
353000**************YEARCHANGE 2014.0 ******************************
353100
353200        IF HOLD-PROV-IPPS-CBSA = '   07'
353300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
353400           AND P-NEW-STATE = 07
353500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
353600               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
353700
353800        IF HOLD-PROV-IPPS-CBSA = '   36'
353900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
354000           AND P-NEW-STATE = 36
354100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
354200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
354300
354400        IF HOLD-PROV-IPPS-CBSA = '10900'
354500           AND P-NEW-STATE = 31
354600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
354700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
354800
354900        IF HOLD-PROV-IPPS-CBSA = '14484'
355000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
355100           AND P-NEW-STATE = 22
355200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
355300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
355400
355500        IF HOLD-PROV-IPPS-CBSA = '17300'
355600           AND P-NEW-STATE = 18
355700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
355800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
355900
356000        IF HOLD-PROV-IPPS-CBSA = '22900'
356100           AND P-NEW-STATE = 37
356200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
356300               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
356400
356500        IF HOLD-PROV-IPPS-CBSA = '25540'
356600          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
356700           AND P-NEW-STATE = 07
356800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
356900               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
357000
357100        IF HOLD-PROV-IPPS-CBSA = '25540'
357200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
357300           AND P-NEW-STATE = 22
357400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
357500               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
357600
357700        IF HOLD-PROV-IPPS-CBSA = '26820'
357800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
357900           AND P-NEW-STATE = 53
358000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
358100               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
358200
358300        IF HOLD-PROV-IPPS-CBSA = '27180'
358400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
358500           AND P-NEW-STATE = 25
358600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
358700               MOVE '   25' TO HOLD-PROV-IPPS-CBSA.
358800
358900        IF HOLD-PROV-IPPS-CBSA = '28700'
359000           AND P-NEW-STATE = 44
359100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
359200               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
359300
359400        IF HOLD-PROV-IPPS-CBSA = '28700'
359500           AND P-NEW-STATE = 49
359600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
359700               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
359800
359900        IF HOLD-PROV-IPPS-CBSA = '35644'
360000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
360100           AND P-NEW-STATE = 07
360200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
360300               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
360400
360500        IF HOLD-PROV-IPPS-CBSA = '37620'
360600           AND P-NEW-STATE = 36
360700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
360800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
360900
361000        IF HOLD-PROV-IPPS-CBSA = '43580'
361100           AND P-NEW-STATE = 43
361200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
361300               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
361400
361500        IF HOLD-PROV-IPPS-CBSA = '48540'
361600           AND P-NEW-STATE = 36
361700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
361800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
361900
362000        IF HOLD-PROV-IPPS-CBSA = '48540'
362100           AND P-NEW-STATE = 51
362200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
362300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
362400
362500        IF HOLD-PROV-IPPS-CBSA = '48864'
362600           AND P-NEW-STATE = 31
362700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
362800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
362900
363000        IF HOLD-PROV-IPPS-CBSA = '49660'
363100           AND P-NEW-STATE = 36
363200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
363300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
363400
363500        IF HOLD-PROV-IPPS-CBSA = '49660'
363600           AND P-NEW-STATE = 39
363700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
363800               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
363900
364000        IF HOLD-PROV-IPPS-CBSA = '19060'
364100           AND P-NEW-STATE = 21
364200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
364300               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
364400
364500        IF HOLD-PROV-IPPS-CBSA = '22020'
364600           AND P-NEW-STATE = 24
364700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
364800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
364900
365000        IF HOLD-PROV-IPPS-CBSA = '22020'
365100           AND P-NEW-STATE = 35
365200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
365300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
365400
365500        IF HOLD-PROV-IPPS-CBSA = '24220'
365600           AND P-NEW-STATE = 24
365700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
365800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
365900
366000        IF HOLD-PROV-IPPS-CBSA = '24220'
366100           AND P-NEW-STATE = 35
366200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
366300               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
366400
366500        IF HOLD-PROV-IPPS-CBSA = '30300'
366600           AND P-NEW-STATE = 50
366700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
366800               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
366900
367000        IF HOLD-PROV-IPPS-CBSA = '39300'
367100           AND P-NEW-STATE = 22
367200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
367300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
367400
367500        IF HOLD-PROV-IPPS-CBSA = '39300'
367600           AND P-NEW-STATE = 41
367700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
367800               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
367900
368000        IF HOLD-PROV-IPPS-CBSA = '44600'
368100           AND P-NEW-STATE = 36
368200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
368300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
368400
368500        IF HOLD-PROV-IPPS-CBSA = '45500'
368600           AND P-NEW-STATE = 45
368700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
368800               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
368900
369000 0580-FY2014-EXIT.
369100      EXIT.
369200
369300
369400******************************************************************
369500*                                                                *
369600* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
369700* ** LOGIC ADDED 08/06/2014 **                                   *
369800*                                                                *
369900******************************************************************
370000
370100 0580-FY2015-LATER-FLOOR-CBSA.
370200
370300*------------------------------------------------------------*
370400* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
370500* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
370600*------------------------------------------------------------*
370700     MOVE SPACES              TO H-PROV-BLANK-R.
370800*    MOVE P-NEW-STATE         TO H-PROV-STATE-R.
370900     MOVE P-NEW-STATE-CODE-X  TO H-PROV-STATE-R.
371000
371100*6-20-16
371200*ADDED FOLLOWING LINE TO ALLOW LTCH PRICER TO WORK
371300*WITH THE NEW ARIZONA STATE CODE OF 00 -->
371400
371500     IF H-PROV-STATE-R = '00' MOVE '03' TO H-PROV-STATE-R.
371600
371700*------------------------------------------------------------*
371800* SEARCH TABLE FOR RURAL IPPS CBSA & GET RURAL WAGE INDEX    *
371900*------------------------------------------------------------*
372000     SET MA1 TO 1.
372100
372200*------------------------------------------------------------*
372300* FOR FY 2015 - 2019: USE STATE CODE AREA WAGE INDEX         *
372400*                     IN ORIGINAL CBSA WAGE INDEX TABLE      *
372500*------------------------------------------------------------*
372600     IF B-DISCHARGE-DATE < 20191001
372700       SEARCH T-CBSA-DATA VARYING MA1
372800          AT END
372900             MOVE SPACES TO W-CBSA-IPPS-RURAL
373000             MOVE ZEROS TO W-CBSA-IPPS-RUR-EFF-DATE
373100             MOVE ZEROS TO W-IPPS-WAGE-INDEX-RURAL
373200          WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
373300             SET MA2 TO MA1
373400             PERFORM 0675-N-GET-IPPS-WAGE-INDX-RUR
373500                THRU 0675-N-RUR-EXIT VARYING MA2
373600                FROM MA1 BY 1 UNTIL
373700                  T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
373800
373900
374000*------------------------------------------------------------*
374100* FOR FY 2020: USE STATE CODE RURAL WAGE INDEX               *
374200*              FROM RURAL WAGE INDEX COPYBOOK                *
374300*------------------------------------------------------------*
374400     IF B-DISCHARGE-DATE > 20190930 AND < 20201001
374500      IF PPS-RTC = '  '
374600       IF W-CBSA-IPPS-RUR-EFF-DATE NOT = WS-9S
374700         PERFORM 0190-GET-RURAL-FLOOR-IPPS THRU 0190-EXIT
374800         PERFORM 0690-GET-RURAL-FLOOR-IPPS-WI
374900          THRU 0690-EXIT VARYING RUFL-IDX2
375000          FROM RUFL-IDX BY 1 UNTIL
375100           RUFL-CBSA (RUFL-IDX2) NOT = HOLD-PROV-IPPS-CBSA-RURAL
375200       END-IF
375300      END-IF
375400     END-IF.
375500
375600
375700*------------------------------------------------------------*
375800* FOR FY 2021 & LATER: USE STATE CODE AREA WAGE INDEX        *
375900*                      IN ORIGINAL CBSA WAGE INDEX TABLE AND *
376000*                      GET THE RURAL WAGE INDEX FROM THE     *
376100*                      THIRD COLUMN                          .*
376200*------------------------------------------------------------*
376300     IF B-DISCHARGE-DATE > 20201001
376400       SEARCH T-CBSA-DATA VARYING MA1
376500          AT END
376600             MOVE SPACES TO W-CBSA-IPPS-RURAL
376700             MOVE ZEROS TO W-CBSA-IPPS-RUR-EFF-DATE
376800             MOVE ZEROS TO W-IPPS-WAGE-INDEX-RURAL
376900          WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
377000             SET MA2 TO MA1
377100             PERFORM 0695-N-GET-IPPS-WAGE-INDX-RUR
377200                THRU 0695-N-RUR-EXIT VARYING MA2
377300                FROM MA1 BY 1 UNTIL
377400                  T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
377500
377600
377700*------------------------------------------------------------*
377800* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
377900* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
378000*------------------------------------------------------------*
378100     IF W-IPPS-WAGE-INDEX-RURAL > W-IPPS-WAGE-INDEX
378200        MOVE W-CBSA-IPPS-RURAL        TO W-CBSA-IPPS
378300        MOVE W-CBSA-IPPS-RUR-EFF-DATE TO W-CBSA-IPPS-EFF-DATE
378400        MOVE W-IPPS-WAGE-INDEX-RURAL  TO W-IPPS-WAGE-INDEX
378500     END-IF.
378600
378700 0580-FY2015-LATER-EXIT.
378800      EXIT.
378900
379000
379100******************************************************************
379200 0585-GET-IPPS-CBSA-SIZE.
379300******************************************************************
379400
379500     IF B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
379600        IF P-NEW-RURAL-CBSA
379700           MOVE 'R' TO W-CBSA-IPPS-SIZE
379800        ELSE
379900          IF T-CBSA-SIZE (MA2) = 'L'
380000             MOVE 'L' TO W-CBSA-IPPS-SIZE
380100          ELSE
380200             MOVE 'O' TO W-CBSA-IPPS-SIZE
380300          END-IF
380400        END-IF
380500     END-IF.
380600
380700 0585-EXIT.
380800      EXIT.
380900
381000
381100******************************************************************
381200 0590-GET-IPPS-CBSA-PR.
381300******************************************************************
381400
381500*--------------------------------------*
381600* SET PUERTO RICO CBSA INDICATOR       *
381700*--------------------------------------*
381800     MOVE '*' TO H-IPPS-CBSA-LAST-POS.
381900
382000*------------------------------------------------------------*
382100* SEARCH TABLE FOR PR CBSA & GET PR SPECIFIC WAGE INDEX      *
382200*------------------------------------------------------------*
382300     SET MA1 TO 1.
382400     SEARCH T-CBSA-DATA VARYING MA1
382500        AT END
382600           MOVE 60 TO PPS-RTC
382700        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
382800           SET MA2 TO MA1
382900               PERFORM 0680-N-GET-IPPS-PR-WAGE-INDX
383000                  THRU 0680-N-EXIT VARYING MA2
383100                  FROM MA1 BY 1 UNTIL
383200                       T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
383300
383400
383500*------------------------------------------------------------*
383600* ASSIGN PR IPPS WAGE INDEX FLOOR FOR FY 2015 AND LATER      *
383700*------------------------------------------------------------*
383800     IF B-DISCHARGE-DATE > 20140930
383900        PERFORM 0590-FY2015-LATER-PR-FLOOR
384000           THRU 0590-FY2015-LATER-PR-EXIT
384100     END-IF.
384200
384300 0590-EXIT.
384400      EXIT.
384500
384600
384700******************************************************************
384800*                                                                *
384900* PUERTO RICO SPECIFIC WAGE INDEX:                               *
385000* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
385100* ** LOGIC ADDED 08/06/2014 **                                   *
385200*                                                                *
385300******************************************************************
385400
385500 0590-FY2015-LATER-PR-FLOOR.
385600
385700*------------------------------------------------------------*
385800* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
385900* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
386000*------------------------------------------------------------*
386100     MOVE SPACES              TO H-PROV-BLANK-R.
386200*    MOVE P-NEW-STATE         TO H-PROV-STATE-R.
386300     MOVE P-NEW-STATE-CODE-X  TO H-PROV-STATE-R.
386400     MOVE '*'                 TO H-IPPS-CBSA-LAST-POS-R.
386500
386600
386700*------------------------------------------------------------*
386800* SEARCH TABLE FOR RURAL PR IPPS CBSA & GET WAGE INDEX       *
386900*------------------------------------------------------------*
387000     SET MA1 TO 1.
387100     SEARCH T-CBSA-DATA VARYING MA1
387200        AT END
387300           MOVE ZEROS TO W-IPPS-PR-WAGE-INDEX-RUR
387400        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
387500           SET MA2 TO MA1
387600           PERFORM 0680-N-GET-IPPS-PR-WAGE-IDX-RU
387700              THRU 0680-N-RU-EXIT VARYING MA2
387800              FROM MA1 BY 1 UNTIL
387900                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
388000
388100
388200*------------------------------------------------------------*
388300* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
388400* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
388500*------------------------------------------------------------*
388600     IF W-IPPS-PR-WAGE-INDEX-RUR > W-IPPS-PR-WAGE-INDEX
388700        MOVE W-IPPS-PR-WAGE-INDEX-RUR TO W-IPPS-PR-WAGE-INDEX
388800     END-IF.
388900
389000
389100 0590-FY2015-LATER-PR-EXIT.
389200      EXIT.
389300
389400
389500******************************************************************
389600 0600-N-GET-WAGE-INDX.
389700******************************************************************
389800
389900     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)
390000         MOVE MSAX-MSA (MU2)         TO W-NEW-MSA
390100         MOVE MSAX-EFF-DATE (MU2)    TO W-NEW-EFF-DATE-M
390200         MOVE MSAX-WAGE-INDEX1 (MU2) TO W-NEW-INDEX1-RECORD-M
390300         MOVE MSAX-WAGE-INDEX2 (MU2) TO W-NEW-INDEX2-RECORD-M
390400         MOVE MSAX-WAGE-INDEX3 (MU2) TO W-NEW-INDEX3-RECORD-M
390500     END-IF.
390600
390700 0600-N-EXIT.
390800     EXIT.
390900
391000
391100******************************************************************
391200 0650-N-GET-WAGE-INDX.
391300******************************************************************
391400*GET THE LTCH WAGE INDEX
391500*----------------------------------------------------------------*
391600* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
391700* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
391800*    OR BEFORE THE CLAIM DISCHARGE DATE, OR                      *
391900* 2) A CBSA WITH AN EFFECTIVE DATE ON OR BEFORE THE CLAIM
392000*    DISCHARGE DATE AND A CLAIM DISCHARGE DATE ON OR BEFORE
392100*    09/30/2009 OR
392200* 3) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
392300*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
392400*----------------------------------------------------------------*
392500     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (CU2)
392600
392700         IF (HOLD-PROV-CBSA = '   98' OR
392800             HOLD-PROV-CBSA = '   99') OR
392900
393000*THE FOLLOWING LINE ADDED WITH VERSION 15.2 TO FIX A PROBLEM
393100*FOUND BY FISS THAT CAUSED AN UNEXPECTED WAGE INDEX ERROR CODE
393200*TO BE REPORTED
393300
393400            (B-DISCHARGE-DATE <= 20090930) OR
393500
393600            (CBSAX-EFF-DATE (CU2)  >= W-FY-BEGIN-DATE AND
393700             CBSAX-EFF-DATE (CU2)  <= W-FY-END-DATE)
393800
393900             MOVE CBSAX-CBSA (CU2)        TO W-NEW-CBSA
394000             MOVE CBSAX-EFF-DATE (CU2)    TO W-NEW-EFF-DATE-C
394100             MOVE CBSAX-WAGE-INDEX1 (CU2) TO W-NEW-INDEX1-RECORD-C
394200             MOVE CBSAX-WAGE-INDEX2 (CU2) TO W-NEW-INDEX2-RECORD-C
394300             MOVE CBSAX-WAGE-INDEX3 (CU2) TO W-NEW-INDEX3-RECORD-C
394400         END-IF
394500     END-IF.
394600
394700 0650-N-EXIT.
394800     EXIT.
394900
395000
395100******************************************************************
395200 0675-N-GET-IPPS-WAGE-INDX.
395300******************************************************************
395400
395500*----------------------------------------------------------------*
395600* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
395700* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
395800*    OR BEFORE THE CLAIM DISCHARGE DATE, -OR-                    *
395900* 2) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
396000*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
396100*----------------------------------------------------------------*
396200     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
396300
396400         IF (HOLD-PROV-IPPS-CBSA = '   98' OR
396500             HOLD-PROV-IPPS-CBSA = '   99') OR
396600
396700            (T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
396800             T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE)
396900
397000         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS
397100         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-EFF-DATE
397200         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX
397300     END-IF.
397400
397500 0675-N-EXIT.
397600     EXIT.
397700
397800
397900******************************************************************
398000 0675-N-GET-IPPS-WAGE-INDX-RUR.
398100******************************************************************
398200
398300*----------------------------------------------------------------*
398400* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
398500* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
398600* YEAR.                                                          *
398700*----------------------------------------------------------------*
398800     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
398900         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
399000         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
399100         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS-RURAL
399200         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-RUR-EFF-DATE
399300         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX-RURAL
399400     END-IF.
399500
399600 0675-N-RUR-EXIT.
399700     EXIT.
399800
399900
400000******************************************************************
400100 0680-N-GET-IPPS-PR-WAGE-INDX.
400200******************************************************************
400300
400400*----------------------------------------------------------------*
400500* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
400600* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
400700* YEAR.                                                          *
400800*----------------------------------------------------------------*
400900     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
401000         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
401100         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
401200         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX
401300     END-IF.
401400
401500 0680-N-EXIT.
401600     EXIT.
401700
401800
401900******************************************************************
402000 0680-N-GET-IPPS-PR-WAGE-IDX-RU.
402100******************************************************************
402200
402300*----------------------------------------------------------------*
402400* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
402500* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
402600* YEAR.                                                          *
402700*----------------------------------------------------------------*
402800     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
402900         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
403000         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
403100         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX-RUR
403200     END-IF.
403300
403400 0680-N-RU-EXIT.
403500     EXIT.
403600
403700
403800******************************************************************
403900 0690-GET-RURAL-FLOOR-IPPS-WI.
404000******************************************************************
404100
404200     IF B-DISCHARGE-DATE NOT < RUFL-EFF-DATE (RUFL-IDX2) AND
404300        RUFL-EFF-DATE (RUFL-IDX2) >= W-FY-BEGIN-DATE AND
404400        RUFL-EFF-DATE (RUFL-IDX2) <= W-FY-END-DATE
404500        MOVE RUFL-CBSA     (RUFL-IDX2) TO W-CBSA-IPPS-RURAL
404600        MOVE RUFL-EFF-DATE (RUFL-IDX2) TO W-CBSA-IPPS-RUR-EFF-DATE
404700        MOVE RUFL-WI3      (RUFL-IDX2) TO W-IPPS-WAGE-INDEX-RURAL.
404800
404900 0690-EXIT.  EXIT.
405000
405100
405200******************************************************************
405300 0695-N-GET-IPPS-WAGE-INDX-RUR.
405400******************************************************************
405500
405600*----------------------------------------------------------------*
405700* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
405800* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
405900* YEAR.                                                          *
406000*----------------------------------------------------------------*
406100     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
406200         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
406300         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
406400         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS-RURAL
406500         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-RUR-EFF-DATE
406600         MOVE T-CBSA-WAGE-INDX3 (MA2) TO W-IPPS-WAGE-INDEX-RURAL
406700     END-IF.
406800
406900 0695-N-RUR-EXIT.
407000     EXIT.
407100
407200******************************************************************
407300********************   END OF PROGRAM   **************************
407400******************************************************************
