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