000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID. LTDRV152.
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
059200 ENVIRONMENT DIVISION.
059300 CONFIGURATION SECTION.
059400 SOURCE-COMPUTER.            IBM-370.
059500 OBJECT-COMPUTER.            IBM-370.
059600 INPUT-OUTPUT  SECTION.
059700 FILE-CONTROL.
059800
059900 DATA DIVISION.
060000 FILE SECTION.
060100
060200
060300 WORKING-STORAGE SECTION.
060400 77  W-STORAGE-REF                  PIC X(48) VALUE
060500     'L T D R V _ _ _ - W O R K I N G   S T O R A G E'.
060600 01  DRV-VERSION                    PIC X(05) VALUE 'D15.2'.
060700
060800*-------------------------------------------------------------*
060900* LTCAL MODULES OLDER THAN 5 YEARS                            *
061000*-------------------------------------------------------------*
061100 01  LTCAL032                       PIC X(08) VALUE 'LTCAL032'.
061200 01  LTCAL042                       PIC X(08) VALUE 'LTCAL042'.
061300 01  LTCAL043                       PIC X(08) VALUE 'LTCAL043'.
061400 01  LTCAL058                       PIC X(08) VALUE 'LTCAL058'.
061500 01  LTCAL059                       PIC X(08) VALUE 'LTCAL059'.
061600 01  LTCAL063                       PIC X(08) VALUE 'LTCAL063'.
061700 01  LTCAL064                       PIC X(08) VALUE 'LTCAL064'.
061800 01  LTCAL072                       PIC X(08) VALUE 'LTCAL072'.
061900 01  LTCAL075                       PIC X(08) VALUE 'LTCAL075'.
062000
062100*-------------------------------------------------------------*
062200* LTCAL MODULES CURRENTLY CALLED                              *
062300*-------------------------------------------------------------*
062400 01  LTCAL080                       PIC X(08) VALUE 'LTCAL080'.
062500 01  LTCAL087                       PIC X(08) VALUE 'LTCAL087'.
062600 01  LTCAL091                       PIC X(08) VALUE 'LTCAL091'.
062700 01  LTCAL094                       PIC X(08) VALUE 'LTCAL094'.
062800 01  LTCAL095                       PIC X(08) VALUE 'LTCAL095'.
062900 01  LTCAL103                       PIC X(08) VALUE 'LTCAL103'.
063000 01  LTCAL105                       PIC X(08) VALUE 'LTCAL105'.
063100 01  LTCAL111                       PIC X(08) VALUE 'LTCAL111'.
063200 01  LTCAL123                       PIC X(08) VALUE 'LTCAL123'.
063300 01  LTCAL130                       PIC X(08) VALUE 'LTCAL130'.
063400 01  LTCAL141                       PIC X(08) VALUE 'LTCAL141'.
063500 01  LTCAL152                       PIC X(08) VALUE 'LTCAL152'.
063600
063700*-------------------------------------------------------------*
063800* VARIABLES TO HOLD THE BILL'S FY BEGIN AND END DATES         *
063900*-------------------------------------------------------------*
064000 01  W-FY-BEGIN-DATE.
064100     05  W-FY-BEGIN-CC              PIC 9(02).
064200     05  W-FY-BEGIN-YY              PIC 9(02).
064300     05  W-FY-BEGIN-MM              PIC 9(02) VALUE 10.
064400     05  W-FY-BEGIN-DD              PIC 9(02) VALUE 01.
064500
064600 01  W-FY-END-DATE.
064700     05  W-FY-END-CC                PIC 9(02).
064800     05  W-FY-END-YY                PIC 9(02).
064900     05  W-FY-END-MM                PIC 9(02) VALUE 09.
065000     05  W-FY-END-DD                PIC 9(02) VALUE 30.
065100
065200
065300***************************************************************
065400* MSA AND CBSA HOLD AREAS FOR SEARCH                          *
065500***************************************************************
065600 01  HOLD-PROV-MSA.
065700         10  H-PROV-BLANK             PIC X(2).
065800         10  H-PROV-STATE.
065900             15  FILLER               PIC X.
066000             15  H-MSA-LAST-POS       PIC X.
066100
066200 01  HOLD-PROV-CBSA.
066300         10  H-PROV-BLANK             PIC X(3).
066400         10  H-PROV-STATE.
066500             15  FILLER               PIC X.
066600             15  H-CBSA-LAST-POS      PIC X.
066700
066800 01  HOLD-PROV-IPPS-CBSA.
066900         10  H-PROV-BLANK             PIC X(3).
067000         10  H-PROV-STATE.
067100             15  FILLER               PIC X.
067200             15  H-IPPS-CBSA-LAST-POS PIC X.
067300
067400 01  HOLD-PROV-IPPS-CBSA-RURAL.
067500         10  H-PROV-BLANK-R              PIC X(3).
067600         10  H-PROV-STATE-R.
067700             15  FILLER                  PIC X.
067800             15  H-IPPS-CBSA-LAST-POS-R  PIC X.
067900
068000
068100***************************************************************
068200*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
068300*      THE LTCAL___ PROGRAM (MSA) - USED THROUGH 06/30/2005   *
068400***************************************************************
068500 01  WAGE-NEW-INDEX-RECORD-MSA.
068600     05  W-NEW-MSA                    PIC 9(4).
068700     05  W-NEW-EFF-DATE-M.
068800          10  W-NEW-EFF-DATE-M-CC     PIC 9(2).
068900          10  W-NEW-EFF-DATE-M-YMD.
069000              15  W-NEW-EFF-DATE-M-YY PIC 9(2).
069100              15  W-NEW-EFF-DATE-M-MM PIC 9(2).
069200              15  W-NEW-EFF-DATE-M-DD PIC 9(2).
069300     05  W-NEW-INDEX1-RECORD-M        PIC S9(02)V9(04).
069400     05  W-NEW-INDEX2-RECORD-M        PIC S9(02)V9(04).
069500     05  W-NEW-INDEX3-RECORD-M        PIC S9(02)V9(04).
069600
069700
069800***************************************************************
069900*      THIS IS THE WAGE-INDEX RECORD THAT WILL BE PASSED TO   *
070000*      THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2005    *
070100***************************************************************
070200 01  WAGE-NEW-INDEX-RECORD-CBSA.
070300     05  W-NEW-CBSA                   PIC 9(5).
070400     05  W-NEW-EFF-DATE-C.
070500          10  W-NEW-EFF-DATE-C-CC     PIC 9(2).
070600          10  W-NEW-EFF-DATE-C-YMD.
070700              15  W-NEW-EFF-DATE-C-YY PIC 9(2).
070800              15  W-NEW-EFF-DATE-C-MM PIC 9(2).
070900              15  W-NEW-EFF-DATE-C-DD PIC 9(2).
071000     05  W-NEW-INDEX1-RECORD-C        PIC S9(02)V9(04).
071100     05  W-NEW-INDEX2-RECORD-C        PIC S9(02)V9(04).
071200     05  W-NEW-INDEX3-RECORD-C        PIC S9(02)V9(04).
071300
071400
071500***************************************************************
071600*      THIS IS THE IPPS WAGE-INDEX RECORD THAT WILL BE PASSED *
071700*      TO THE LTCAL___ PROGRAM (CBSA) - USED SINCE 07/01/2006 *
071800***************************************************************
071900 01  WAGE-IPPS-INDEX-RECORD-CBSA.
072000     05  W-CBSA-IPPS.
072100         10 CBSA-IPPS-123              PIC X(3).
072200         10 CBSA-IPPS-45               PIC X(2).
072300     05  W-CBSA-IPPS-SIZE              PIC X.
072400         88  LARGE-URBAN       VALUE 'L'.
072500         88  OTHER-URBAN       VALUE 'O'.
072600         88  ALL-RURAL         VALUE 'R'.
072700     05  W-CBSA-IPPS-EFF-DATE          PIC X(8).
072800     05  FILLER                        PIC X.
072900     05  W-IPPS-WAGE-INDEX             PIC S9(02)V9(04).
073000     05  W-IPPS-PR-WAGE-INDEX          PIC S9(02)V9(04).
073100
073200
073300***************************************************************
073400*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
073500*      HELD                                                   *
073600***************************************************************
073700 01  WAGE-IPPS-INDEX-RURAL-CBSA.
073800     05  W-CBSA-IPPS-RURAL.
073900         10 CBSA-IPPS-RURAL-123        PIC X(3).
074000         10 CBSA-IPPS-RURAL-45         PIC X(2).
074100     05  W-CBSA-IPPS-RUR-EFF-DATE      PIC X(8).
074200     05  W-IPPS-WAGE-INDEX-RURAL       PIC S9(02)V9(04).
074300
074400
074500***************************************************************
074600*      THIS IS THE IPPS RURAL WAGE INDEX INFO THAT WILL BE    *
074700*      HELD - PUERTO RICO SPECIFIC                            *
074800***************************************************************
074900 01  W-IPPS-PR-WAGE-INDEX-RUR          PIC S9(02)V9(04).
075000
075100
075200**************************************************************
075300*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
075400*      LTDRV___ PROGRAM TO THE LTCAL___ PROGRAM              *
075500**************************************************************
075600 01  PROV-NEW-HOLD.
075700     02  PROV-NEWREC-HOLD1.
075800         05  P-NEW-NPI10.
075900             10  P-NEW-NPI8             PIC X(08).
076000             10  P-NEW-NPI-FILLER       PIC X(02).
076100         05  P-NEW-PROVIDER-NO.
076200             10  P-NEW-STATE            PIC 9(02).
076300             10  FILLER                 PIC X(04).
076400         05  P-NEW-DATE-DATA.
076500             10  P-NEW-EFF-DATE.
076600                 15  P-NEW-EFF-DT-CC    PIC 9(02).
076700                 15  P-NEW-EFF-DT-YY    PIC 9(02).
076800                 15  P-NEW-EFF-DT-MM    PIC 9(02).
076900                 15  P-NEW-EFF-DT-DD    PIC 9(02).
077000             10  P-NEW-FY-BEGIN-DATE.
077100                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
077200                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
077300                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
077400                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
077500             10  P-NEW-REPORT-DATE.
077600                 15  P-NEW-REPORT-DT-CC PIC 9(02).
077700                 15  P-NEW-REPORT-DT-YY PIC 9(02).
077800                 15  P-NEW-REPORT-DT-MM PIC 9(02).
077900                 15  P-NEW-REPORT-DT-DD PIC 9(02).
078000             10  P-NEW-TERMINATION-DATE.
078100                 15  P-NEW-TERM-DT-CC   PIC 9(02).
078200                 15  P-NEW-TERM-DT-YY   PIC 9(02).
078300                 15  P-NEW-TERM-DT-MM   PIC 9(02).
078400                 15  P-NEW-TERM-DT-DD   PIC 9(02).
078500         05  P-NEW-WAIVER-CODE          PIC X(01).
078600             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
078700         05  P-NEW-INTER-NO             PIC 9(05).
078800         05  P-NEW-PROVIDER-TYPE        PIC X(02).
078900         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
079000         05  P-NEW-CURRENT-DIV   REDEFINES
079100                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
079200         05  P-NEW-MSA-DATA.
079300             10  P-NEW-CHG-CODE-INDEX       PIC X.
079400             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
079500             10  P-NEW-GEO-LOC-MSA9   REDEFINES
079600                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
079700             10  P-NEW-GEO-LOC-MSA-AST REDEFINES
079800                             P-NEW-GEO-LOC-MSA9.
079900                 15  P-NEW-GEO-MSA-1ST    PIC X.
080000                 15  P-NEW-GEO-MSA-2ND    PIC X.
080100                 15  P-NEW-GEO-MSA-3RD    PIC X.
080200                 15  P-NEW-GEO-MSA-4TH    PIC X.
080300             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
080400             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
080500             10  P-NEW-STAND-AMT-LOC-MSA9
080600                   REDEFINES P-NEW-STAND-AMT-LOC-MSA.
080700                 15  P-NEW-RURAL-1ST.
080800                     20  P-NEW-STAND-RURAL  PIC XX.
080900                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
081000                 15  P-NEW-RURAL-2ND        PIC XX.
081100         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
081200                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
081300                 88  P-NEW-SCH-YR82       VALUE   '82'.
081400                 88  P-NEW-SCH-YR87       VALUE   '87'.
081500         05  P-NEW-LUGAR                    PIC X.
081600         05  P-NEW-TEMP-RELIEF-IND          PIC X.
081700         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
081800         05  FILLER                         PIC X(05).
081900     02  PROV-NEWREC-HOLD2.
082000         05  P-NEW-VARIABLES.
082100             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
082200             10  P-NEW-COLA              PIC  9(01)V9(03).
082300             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
082400             10  P-NEW-BED-SIZE          PIC  9(05).
082500             10  P-NEW-CCR               PIC  9(01)V9(03).
082600             10  P-NEW-CMI               PIC  9(01)V9(04).
082700             10  P-NEW-SSI-RATIO         PIC  V9(04).
082800             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
082900             10  P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
083000             10  P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
083100             10  P-NEW-DSH-PERCENT       PIC  V9(04).
083200             10  P-NEW-FYE-DATE.
083300                 15  P-NEW-FYE-CC        PIC 99.
083400                 15  P-NEW-FYE-YY        PIC 99.
083500                 15  P-NEW-FYE-MM        PIC 99.
083600                 15  P-NEW-FYE-DD        PIC 99.
083700         05  P-NEW-CBSA-SPEC-PAY-IND       PIC X(01).
083800         05  P-NEW-HOSP-QUAL-IND           PIC X(01).
083900         05  P-NEW-GEO-LOC-CBSAX           PIC X(05) JUST RIGHT.
084000         05  P-NEW-GEO-LOC-CBSA9 REDEFINES
084100                          P-NEW-GEO-LOC-CBSAX PIC 9(05).
084200         05  P-NEW-GEO-LOC-CBSA-AST REDEFINES
084300                          P-NEW-GEO-LOC-CBSA9.
084400             10 P-NEW-GEO-LOC-CBSA-1ST     PIC X.
084500             10 P-NEW-GEO-LOC-CBSA-2ND     PIC X.
084600             10 P-NEW-GEO-LOC-CBSA-3RD     PIC X.
084700             10 P-NEW-GEO-LOC-CBSA-4TH     PIC X.
084800             10 P-NEW-GEO-LOC-CBSA-5TH     PIC X.
084900         05 P-NEW-GEO-LOC-CBSA-SIZE REDEFINES
085000                          P-NEW-GEO-LOC-CBSAX.
085100             10 P-NEW-GEO-LOC-CBSA-123     PIC X(03).
085200                88  P-NEW-RURAL-CBSA       VALUE '   '.
085300             10 P-NEW-GEO-LOC-CBSA-45      PIC X(02).
085400         05  FILLER                        PIC X(10).
085500         05  P-NEW-SPECIAL-WAGE-INDEX      PIC 9(02)V9(04).
085600     02  PROV-NEWREC-HOLD3.
085700         05  P-NEW-PASS-AMT-DATA.
085800             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
085900             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
086000             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
086100             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
086200         05  P-NEW-CAPI-DATA.
086300             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
086400             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
086500             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
086600             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
086700             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
086800             15  P-NEW-CAPI-NEW-HOSP       PIC X.
086900             15  P-NEW-CAPI-IME            PIC 9V9999.
087000             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
087100             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.
087200         05  FILLER                        PIC X(18).
087300
087400
087500***************************************************************
087600 LINKAGE SECTION.
087700***************************************************************
087800
087900**************************************************************
088000*      THIS IS THE BILL-RECORD THAT WILL BE PASSED TO        *
088100*      THE LTCAL___ PROGRAM                                  *
088200**************************************************************
088300 01  BILL-NEW-DATA.
088400     05  B-NPI10.
088500         10  B-NPI8                   PIC X(08).
088600         10  B-NPI-FILLER             PIC X(02).
088700     05  B-PROVIDER-NO                PIC X(06).
088800     05  B-PATIENT-STATUS             PIC X(02).
088900     05  B-DRG-CODE                   PIC X(03).
089000     05  B-LOS                        PIC 9(03).
089100     05  B-COV-DAYS                   PIC 9(03).
089200     05  B-LTR-DAYS                   PIC 9(02).
089300     05  B-DISCHARGE-DATE.
089400         10  B-DISCHG-CC              PIC 9(02).
089500         10  B-DISCHG-YY              PIC 9(02).
089600         10  B-DISCHG-MM              PIC 9(02).
089700         10  B-DISCHG-DD              PIC 9(02).
089800     05  B-COV-CHARGES                PIC 9(07)V9(02).
089900     05  B-SPEC-PAY-IND               PIC X(01).
090000     05  FILLER                       PIC X(13).
090100
090200
090300**************************************************************
090400*      THIS IS THE PPS DATA PASSED TO THE LTCAL___ PROGRAM   *
090500*      IT WILL BE PASSED BACK TO THE LTDRV___ PROGRAM        *
090600**************************************************************
090700 01  PPS-DATA-ALL.
090800     05  PPS-RTC                      PIC 9(02).
090900     05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
091000     05  PPS-DATA.
091100         10  PPS-MSA                  PIC X(04).
091200         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).
091300         10  PPS-AVG-LOS              PIC 9(02)V9(01).
091400         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).
091500         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).
091600         10  PPS-LOS                  PIC 9(03).
091700         10  PPS-DRG-ADJ-PAY-AMT      PIC 9(07)V9(02).
091800         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).
091900         10  PPS-FINAL-PAY-AMT        PIC 9(07)V9(02).
092000         10  PPS-FAC-COSTS            PIC 9(07)V9(02).
092100         10  PPS-NEW-FAC-SPEC-RATE    PIC 9(07)V9(02).
092200         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).
092300         10  PPS-SUBM-DRG-CODE        PIC X(03).
092400         10  PPS-CALC-VERS-CD         PIC X(05).
092500         10  PPS-REG-DAYS-USED        PIC 9(03).
092600         10  PPS-LTR-DAYS-USED        PIC 9(03).
092700         10  PPS-BLEND-YEAR           PIC 9(01).
092800         10  PPS-COLA                 PIC 9(01)V9(03).
092900         10  FILLER                   PIC X(04).
093000    05  PPS-OTHER-DATA.
093100         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).
093200         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).
093300         10  PPS-STD-FED-RATE         PIC 9(05)V9(02).
093400         10  PPS-BDGT-NEUT-RATE       PIC 9(01)V9(03).
093500         10  PPS-IPTHRESH             PIC 9(03)V9(01).
093600         10  FILLER                   PIC X(16).
093700    05  PPS-PC-DATA.
093800         10  PPS-COT-IND              PIC X(01).
093900         10  FILLER                   PIC X(20).
094000
094100 01  PPS-CBSA                         PIC X(05).
094200
094300
094400*****************************************************************
094500*            THESE ARE THE VERSIONS OF THE LTDRV___             *
094600*           PROGRAMS THAT WILL BE PASSED BACK----               *
094700*          ASSOCIATED WITH THE BILL BEING PROCESSED             *
094800*****************************************************************
094900 01  PRICER-OPT-VERS-SW.
095000     05  PRICER-OPTION-SW               PIC X(01).
095100         88  ALL-TABLES-PASSED          VALUE 'A'.
095200         88  PROV-RECORD-PASSED         VALUE 'P'.
095300     05  PPS-VERSIONS.
095400         10  PPDRV-VERSION              PIC X(05).
095500
095600
095700
095800**************************************************************
095900*      PROVIDER SPECIFIC RECORD                              *
096000**************************************************************
096100*      THIS IS THE PROV-RECORD THAT IS PASSED FROM THE       *
096200*      LTOPN___ PROGRAM                                      *
096300**************************************************************
096400 01  PROV-RECORD.
096500     05  PROV-REC1                  PIC X(80).
096600     05  PROV-REC2                  PIC X(80).
096700     05  PROV-REC3                  PIC X(80).
096800
096900
097000**************************************************************
097100*      LTCH CBSA WAGE INDEX TABLE                            *
097200**************************************************************
097300*      THIS IS THE CBSA WAGE INDEX TABLE THAT IS PASSED FROM *
097400*      THE LTOPN___ PROGRAM                                  *
097500**************************************************************
097600 01  CBSA-WI-TABLE.
097700     05  C-CBSA-DATA  OCCURS 0 TO 7000 TIMES
097800                      DEPENDING ON CBSA-CNT
097900                      ASCENDING KEY IS CBSAX-CBSA
098000                      INDEXED BY CU1 CU2.
098100         10  CBSAX-CBSA         PIC X(05).
098200         10  CBSAX-EFF-DATE     PIC X(08).
098300         10  CBSAX-WAGE-INDEX1  PIC S9(02)V9(04).
098400         10  CBSAX-WAGE-INDEX2  PIC S9(02)V9(04).
098500         10  CBSAX-WAGE-INDEX3  PIC S9(02)V9(04).
098600
098700
098800**************************************************************
098900*      IPPS CBSA WAGE INDEX TABLE                            *
099000**************************************************************
099100*      THIS IS THE IPPS CBSA WAGE INDEX TABLE THAT IS PASSED *
099200*      FROM THE LTOPN___ PROGRAM                             *
099300**************************************************************
099400 01  IPPS-CBSA-WI-TABLE.
099500     05  T-CBSA-DATA  OCCURS 0 TO 7000 TIMES
099600                      DEPENDING ON IPPS-CBSA-CNT
099700                      ASCENDING KEY IS T-CBSA
099800                      INDEXED BY MA1 MA2 MA3.
099900         10  T-CBSA             PIC X(5).
100000         10  T-CBSA-SIZE        PIC X(01).
100100         10  T-CBSA-EFF-DATE    PIC X(08).
100200         10  T-CBSA-WAGE-INDX1  PIC S9(02)V9(04).
100300         10  T-CBSA-WAGE-INDX2  PIC S9(02)V9(04).
100400
100500
100600**************************************************************
100700*      LTCH MSA WAGE INDEX TABLE                             *
100800**************************************************************
100900*      THIS IS THE MSA WAGE INDEX TABLE THAT IS PASSED FROM  *
101000*      THE LTOPN___ PROGRAM                                  *
101100**************************************************************
101200 01  MSA-WI-TABLE.
101300     05  M-MSA-DATA   OCCURS 0 TO 4000 TIMES
101400                      DEPENDING ON MSA-CNT
101500                      ASCENDING KEY IS MSAX-MSA
101600                      INDEXED BY MU1 MU2.
101700         10  MSAX-MSA          PIC X(4).
101800         10  MSAX-EFF-DATE     PIC X(08).
101900         10  MSAX-WAGE-INDEX1  PIC S9(02)V9(04).
102000         10  MSAX-WAGE-INDEX2  PIC S9(02)V9(04).
102100         10  MSAX-WAGE-INDEX3  PIC S9(02)V9(04).
102200
102300
102400**************************************************************
102500*  INPUT FILE RECORD COUNTS                                  *
102600**************************************************************
102700 01  WORK-COUNTERS.
102800     05  CBSA-CNT              PIC 9(5).
102900     05  MSA-CNT               PIC 9(5).
103000     05  PROV-CNT              PIC 9(5).
103100     05  IPPS-CBSA-CNT         PIC 9(5).
103200
103300
103400
103500
103600 PROCEDURE DIVISION  USING BILL-NEW-DATA
103700                           PPS-DATA-ALL
103800                           PPS-CBSA
103900                           PRICER-OPT-VERS-SW
104000                           PROV-RECORD
104100                           CBSA-WI-TABLE
104200                           IPPS-CBSA-WI-TABLE
104300                           MSA-WI-TABLE
104400                           WORK-COUNTERS.
104500
104600
104700******************************************************************
104800*                                                                *
104900*    PROCESSING:                                                 *
105000*      A. THIS MODULE WILL RETRIEVE THE WAGE INDEX RECORD(S)     *
105100*         NEEDED FOR EACH BILL.                                  *
105200*      B. THIS MODULE WILL CALL THE LTCAL MODULES.               *
105300*      C. THE PROV-RECORD AND WAGE-INDEX-RECORD(S) ASSOCIATED    *
105400*         WITH EACH BILL WILL BE PASSED TO THE LTCAL PROGRAMS.   *
105500*                                                                *
105600******************************************************************
105700
105800     MOVE DRV-VERSION TO PPDRV-VERSION.
105900
106000*----------------------------------------------------------*
106100* INITIALIZE VARIABLES                                     *
106200*----------------------------------------------------------*
106300     INITIALIZE PPS-DATA-ALL
106400                PPS-CBSA
106500                HOLD-PROV-MSA
106600                HOLD-PROV-CBSA
106700                HOLD-PROV-IPPS-CBSA
106800                HOLD-PROV-IPPS-CBSA-RURAL
106900                WAGE-NEW-INDEX-RECORD-MSA
107000                WAGE-NEW-INDEX-RECORD-CBSA
107100                WAGE-IPPS-INDEX-RECORD-CBSA
107200                W-IPPS-PR-WAGE-INDEX-RUR
107300                WAGE-IPPS-INDEX-RURAL-CBSA
107400                W-FY-BEGIN-CC
107500                W-FY-BEGIN-YY
107600                W-FY-END-CC
107700                W-FY-END-YY.
107800
107900     MOVE PROV-RECORD TO PROV-NEW-HOLD.
108000
108100
108200*----------------------------------------------------------*
108300* RTC = 98  --  BILL DISCHARGE DATE BEFORE 10/01/2002      *
108400*----------------------------------------------------------*
108500     IF B-DISCHARGE-DATE < 20021001
108600        MOVE 98 TO PPS-RTC
108700        GOBACK
108800     END-IF.
108900
109000
109100*----------------------------------------------------------*
109200* SET FY BEGIN AND END DATES USING BILL DISCHARGE DATE     *
109300*----------------------------------------------------------*
109400     MOVE B-DISCHG-CC TO W-FY-BEGIN-CC.
109500     MOVE B-DISCHG-CC TO W-FY-END-CC.
109600
109700*----------------------------------*
109800* FOR CLAIMS DISCHARGED JAN - SEPT *
109900*----------------------------------*
110000     IF B-DISCHG-MM >= 01 AND
110100        B-DISCHG-MM <= 09
110200        COMPUTE W-FY-BEGIN-YY = B-DISCHG-YY - 1
110300        MOVE B-DISCHG-YY TO W-FY-END-YY
110400
110500*----------------------------------*
110600* FOR CLAIMS DISCHARGED OCT - DEC  *
110700*----------------------------------*
110800     ELSE
110900        MOVE B-DISCHG-YY TO W-FY-BEGIN-YY
111000        COMPUTE W-FY-END-YY = B-DISCHG-YY + 1
111100     END-IF.
111200
111300
111400
111500************************************************************
111600*    GET THE WAGE-INDEX RECORD                             *
111700************************************************************
111800
111900*------------------------------------------------*
112000* EDIT THE CBSA AND MSA FROM THE PROVIDER RECORD *
112100*------------------------------------------------*
112200     IF P-NEW-GEO-LOC-CBSAX = SPACES
112300        MOVE ZEROS TO P-NEW-GEO-LOC-CBSAX
112400     END-IF.
112500
112600     IF P-NEW-GEO-LOC-MSAX = SPACES
112700        MOVE ZEROS TO P-NEW-GEO-LOC-MSAX
112800     END-IF.
112900
113000     IF P-NEW-EFF-DATE > 20050701
113100        IF '*' = P-NEW-GEO-LOC-CBSA-1ST OR
113200                 P-NEW-GEO-LOC-CBSA-2ND OR
113300                 P-NEW-GEO-LOC-CBSA-3RD OR
113400                 P-NEW-GEO-LOC-CBSA-4TH OR
113500                 P-NEW-GEO-LOC-CBSA-5TH
113600           MOVE 60 TO PPS-RTC
113700           GOBACK
113800        END-IF
113900     END-IF.
114000
114100*----------------------------------------------------------*
114200* DETERMINE WHETHER TO GET THE LTCH MSA OR CBSA WAGE INDEX *
114300*----------------------------------------------------------*
114400     IF B-DISCHARGE-DATE < 20050701
114500       SET MU1 TO 1
114600       PERFORM 0500-GET-MSA THRU 0500-EXIT
114700     ELSE
114800       SET CU1 TO 1
114900       PERFORM 0550-GET-CBSA THRU 0550-EXIT
115000       IF W-NEW-INDEX3-RECORD-C = 0
115100          MOVE 52 TO PPS-RTC
115200     END-IF.
115300
115400*----------------------------------------------------------*
115500* GET THE IPPS CBSA WAGE INDEX FOR CLAIMS DISCHARGED AFTER *
115600* JUNE 30, 2006 FOR USE IN THE 4TH SHORT STAY PROVISION    *
115700*----------------------------------------------------------*
115800     IF B-DISCHARGE-DATE > 20060630
115900       SET MA1 TO 1
116000       PERFORM 0575-GET-IPPS-CBSA THRU 0575-EXIT
116100       IF W-IPPS-WAGE-INDEX = 0
116200          MOVE 52 TO PPS-RTC
116300       END-IF
116400     END-IF.
116500
116600*--------------------------------------------------------------*
116700* RTC = 60  --  LTCH/IPPS CBSA/MSA WAGE INDEX RECORD NOT FOUND *
116800* RTC = 52  --  LTCH/IPPS CBSA/MSA WAGE INDEX INVALID          *
116900*--------------------------------------------------------------*
117000     IF PPS-RTC = 60 OR PPS-RTC = 52
117100        GOBACK
117200     END-IF.
117300
117400
117500
117600******************************************************************
117700******************************************************************
117800**                                                              **
117900**          THIS NEXT CALL WILL PROCESS BILLS WITH              **
118000**          A DISCHARGE DATE ON OR AFTER 20021001               **
118100**                                                              **
118200**--------------------------------------------------------------**
118300**                                                              **
118400** FOR BILLS WITH DISCHARGE DATES AFTER 20050630, INCLUDE FIELD **
118500** PPS-CBSA IN THE CALL USING STATEMENT, OMIT THIS FIELD FOR    **
118600** BILLS WITH DISCHARGE DATES BEFORE 20050701.                  **
118700**                                                              **
118800** FOR BILLS WITH DISCHARGE DATES AFTER 20060630, INCLUDE FIELD **
118900** WAGE-IPPS-INDEX-RECORD-CBSA.                                 **
119000**                                                              **
119100******************************************************************
119200******************************************************************
119300
119400*----------------------------------------------------------------*
119500*        FISCAL YEAR 2015, RATE YEAR 2015 (AFTER 10/1/2014)      *
119600*----------------------------------------------------------------*
119700         IF B-DISCHARGE-DATE > 20140930
119800            CALL LTCAL152 USING BILL-NEW-DATA
119900                                PPS-DATA-ALL
120000                                PPS-CBSA
120100                                PRICER-OPT-VERS-SW
120200                                PROV-NEW-HOLD
120300                                WAGE-NEW-INDEX-RECORD-CBSA
120400                                WAGE-IPPS-INDEX-RECORD-CBSA.
120500
120600*----------------------------------------------------------------*
120700*        FISCAL YEAR 2014, RATE YEAR 2014 (AFTER 10/1/2013)      *
120800*----------------------------------------------------------------*
120900         IF B-DISCHARGE-DATE > 20130930 AND
121000                             < 20141001
121100            CALL LTCAL141 USING BILL-NEW-DATA
121200                                PPS-DATA-ALL
121300                                PPS-CBSA
121400                                PRICER-OPT-VERS-SW
121500                                PROV-NEW-HOLD
121600                                WAGE-NEW-INDEX-RECORD-CBSA
121700                                WAGE-IPPS-INDEX-RECORD-CBSA.
121800
121900*----------------------------------------------------------------*
122000*        FISCAL YEAR 2013, RATE YEAR 2013 (AFTER 10/1/2012)      *
122100*----------------------------------------------------------------*
122200         IF B-DISCHARGE-DATE > 20120930 AND
122300                             < 20131001
122400            CALL LTCAL130 USING BILL-NEW-DATA
122500                                PPS-DATA-ALL
122600                                PPS-CBSA
122700                                PRICER-OPT-VERS-SW
122800                                PROV-NEW-HOLD
122900                                WAGE-NEW-INDEX-RECORD-CBSA
123000                                WAGE-IPPS-INDEX-RECORD-CBSA.
123100
123200*----------------------------------------------------------------*
123300*        FISCAL YEAR 2012, RATE YEAR 2012 (AFTER 10/1/2011)      *
123400*----------------------------------------------------------------*
123500         IF B-DISCHARGE-DATE > 20110930 AND
123600                             < 20121001
123700            CALL LTCAL123 USING BILL-NEW-DATA
123800                                PPS-DATA-ALL
123900                                PPS-CBSA
124000                                PRICER-OPT-VERS-SW
124100                                PROV-NEW-HOLD
124200                                WAGE-NEW-INDEX-RECORD-CBSA
124300                                WAGE-IPPS-INDEX-RECORD-CBSA.
124400
124500*----------------------------------------------------------------*
124600*        FISCAL YEAR 2011, RATE YEAR 2011 (AFTER 10/1/2010)      *
124700*----------------------------------------------------------------*
124800         IF B-DISCHARGE-DATE > 20100930 AND
124900                             < 20111001
125000            CALL LTCAL111 USING BILL-NEW-DATA
125100                                PPS-DATA-ALL
125200                                PPS-CBSA
125300                                PRICER-OPT-VERS-SW
125400                                PROV-NEW-HOLD
125500                                WAGE-NEW-INDEX-RECORD-CBSA
125600                                WAGE-IPPS-INDEX-RECORD-CBSA.
125700
125800*----------------------------------------------------------------*
125900*        FISCAL YEAR 2010, RATE YEAR 2010 (AFTER 3/31/2010)      *
126000*----------------------------------------------------------------*
126100         IF B-DISCHARGE-DATE > 20100331 AND
126200                             < 20101001
126300            CALL LTCAL105 USING BILL-NEW-DATA
126400                                PPS-DATA-ALL
126500                                PPS-CBSA
126600                                PRICER-OPT-VERS-SW
126700                                PROV-NEW-HOLD
126800                                WAGE-NEW-INDEX-RECORD-CBSA
126900                                WAGE-IPPS-INDEX-RECORD-CBSA.
127000
127100*----------------------------------------------------------------*
127200*        FISCAL YEAR 2010, RATE YEAR 2010 (BEFORE 4/1/2010)      *
127300*----------------------------------------------------------------*
127400         IF B-DISCHARGE-DATE > 20090930 AND
127500                             < 20100401
127600            CALL LTCAL103 USING BILL-NEW-DATA
127700                                PPS-DATA-ALL
127800                                PPS-CBSA
127900                                PRICER-OPT-VERS-SW
128000                                PROV-NEW-HOLD
128100                                WAGE-NEW-INDEX-RECORD-CBSA
128200                                WAGE-IPPS-INDEX-RECORD-CBSA.
128300
128400*----------------------------------------------------------------*
128500*        FISCAL YEAR 2009, RATE YEAR 2009 (AFTER 6/2/2009)       *
128600*----------------------------------------------------------------*
128700         IF B-DISCHARGE-DATE > 20090602 AND
128800                             < 20091001
128900            CALL LTCAL095 USING BILL-NEW-DATA
129000                                PPS-DATA-ALL
129100                                PPS-CBSA
129200                                PRICER-OPT-VERS-SW
129300                                PROV-NEW-HOLD
129400                                WAGE-NEW-INDEX-RECORD-CBSA
129500                                WAGE-IPPS-INDEX-RECORD-CBSA.
129600
129700*----------------------------------------------------------------*
129800*        FISCAL YEAR 2009, RATE YEAR 2009 (BEFORE 6/3/2009)      *
129900*----------------------------------------------------------------*
130000         IF B-DISCHARGE-DATE > 20080930 AND
130100                             < 20090603
130200            CALL LTCAL094 USING BILL-NEW-DATA
130300                                PPS-DATA-ALL
130400                                PPS-CBSA
130500                                PRICER-OPT-VERS-SW
130600                                PROV-NEW-HOLD
130700                                WAGE-NEW-INDEX-RECORD-CBSA
130800                                WAGE-IPPS-INDEX-RECORD-CBSA.
130900
131000*----------------------------------------------------------------*
131100*        FISCAL YEAR 2008, RATE YEAR 2009                        *
131200*----------------------------------------------------------------*
131300         IF B-DISCHARGE-DATE > 20080630 AND
131400                             < 20081001
131500            CALL LTCAL091 USING BILL-NEW-DATA
131600                                PPS-DATA-ALL
131700                                PPS-CBSA
131800                                PRICER-OPT-VERS-SW
131900                                PROV-NEW-HOLD
132000                                WAGE-NEW-INDEX-RECORD-CBSA
132100                                WAGE-IPPS-INDEX-RECORD-CBSA.
132200
132300*----------------------------------------------------------------*
132400*        FISCAL YEAR 2008, RATE YEAR 2008                        *
132500*----------------------------------------------------------------*
132600         IF B-DISCHARGE-DATE > 20070930 AND
132700                             < 20080701
132800            CALL LTCAL087 USING BILL-NEW-DATA
132900                                PPS-DATA-ALL
133000                                PPS-CBSA
133100                                PRICER-OPT-VERS-SW
133200                                PROV-NEW-HOLD
133300                                WAGE-NEW-INDEX-RECORD-CBSA
133400                                WAGE-IPPS-INDEX-RECORD-CBSA.
133500
133600*----------------------------------------------------------------*
133700*        FISCAL YEAR 2007, RATE YEAR 2008                        *
133800*----------------------------------------------------------------*
133900         IF B-DISCHARGE-DATE > 20070630 AND
134000                             < 20071001
134100            CALL LTCAL080 USING BILL-NEW-DATA
134200                                PPS-DATA-ALL
134300                                PPS-CBSA
134400                                PRICER-OPT-VERS-SW
134500                                PROV-NEW-HOLD
134600                                WAGE-NEW-INDEX-RECORD-CBSA
134700                                WAGE-IPPS-INDEX-RECORD-CBSA.
134800
134900*----------------------------------------------------------------*
135000*        FISCAL YEAR 2007, RATE YEAR 2007                        *
135100*----------------------------------------------------------------*
135200         IF B-DISCHARGE-DATE > 20060930 AND
135300                             < 20070701
135400            CALL LTCAL075 USING BILL-NEW-DATA
135500                                PPS-DATA-ALL
135600                                PPS-CBSA
135700                                PRICER-OPT-VERS-SW
135800                                PROV-NEW-HOLD
135900                                WAGE-NEW-INDEX-RECORD-CBSA
136000                                WAGE-IPPS-INDEX-RECORD-CBSA.
136100
136200*----------------------------------------------------------------*
136300*        FISCAL YEAR 2006, RATE YEAR 2007                        *
136400*----------------------------------------------------------------*
136500         IF B-DISCHARGE-DATE > 20060630 AND
136600                             < 20061001
136700            CALL LTCAL072 USING BILL-NEW-DATA
136800                                PPS-DATA-ALL
136900                                PPS-CBSA
137000                                PRICER-OPT-VERS-SW
137100                                PROV-NEW-HOLD
137200                                WAGE-NEW-INDEX-RECORD-CBSA
137300                                WAGE-IPPS-INDEX-RECORD-CBSA.
137400
137500*----------------------------------------------------------------*
137600*        FISCAL YEAR 2006, RATE YEAR 2006                        *
137700*----------------------------------------------------------------*
137800         IF B-DISCHARGE-DATE > 20050930 AND
137900                             < 20060701
138000            CALL LTCAL064 USING BILL-NEW-DATA
138100                                PPS-DATA-ALL
138200                                PPS-CBSA
138300                                PRICER-OPT-VERS-SW
138400                                PROV-NEW-HOLD
138500                                WAGE-NEW-INDEX-RECORD-CBSA.
138600
138700*----------------------------------------------------------------*
138800*        FISCAL YEAR 2005, RATE YEAR 2006                        *
138900*----------------------------------------------------------------*
139000         IF B-DISCHARGE-DATE > 20050630 AND
139100                             < 20051001
139200            CALL LTCAL063 USING BILL-NEW-DATA
139300                                PPS-DATA-ALL
139400                                PPS-CBSA
139500                                PRICER-OPT-VERS-SW
139600                                PROV-NEW-HOLD
139700                                WAGE-NEW-INDEX-RECORD-CBSA.
139800
139900*----------------------------------------------------------------*
140000*        FISCAL YEAR 2005, RATE YEAR 2005                        *
140100*----------------------------------------------------------------*
140200         IF B-DISCHARGE-DATE > 20040930 AND
140300            B-DISCHARGE-DATE < 20050701
140400            CALL LTCAL059 USING BILL-NEW-DATA
140500                                PPS-DATA-ALL
140600                                PRICER-OPT-VERS-SW
140700                                PROV-NEW-HOLD
140800                                WAGE-NEW-INDEX-RECORD-MSA.
140900
141000**---------------------------------------------------------------*
141100**       FISCAL YEAR 2004, RATE YEAR 2005                        *
141200**---------------------------------------------------------------*
141300         IF B-DISCHARGE-DATE > 20040630 AND
141400            B-DISCHARGE-DATE < 20041001
141500            CALL LTCAL058 USING BILL-NEW-DATA
141600                                PPS-DATA-ALL
141700                                PRICER-OPT-VERS-SW
141800                                PROV-NEW-HOLD
141900                                WAGE-NEW-INDEX-RECORD-MSA.
142000
142100**---------------------------------------------------------------*
142200**       FISCAL YEAR 2004, RATE YEAR 2004 (NO LONGER CALLED)     *
142300**---------------------------------------------------------------*
142400         IF B-DISCHARGE-DATE > 20030930 AND
142500            B-DISCHARGE-DATE < 20040701
142600            CALL LTCAL043 USING BILL-NEW-DATA
142700                                PPS-DATA-ALL
142800                                PRICER-OPT-VERS-SW
142900                                PROV-NEW-HOLD
143000                                WAGE-NEW-INDEX-RECORD-MSA.
143100
143200**---------------------------------------------------------------*
143300**       FISCAL YEAR 2003, RATE YEAR 2004 (NO LONGER CALLED)     *
143400**---------------------------------------------------------------*
143500         IF B-DISCHARGE-DATE > 20030630 AND
143600            B-DISCHARGE-DATE < 20031001
143700            CALL LTCAL042 USING BILL-NEW-DATA
143800                                PPS-DATA-ALL
143900                                PRICER-OPT-VERS-SW
144000                                PROV-NEW-HOLD
144100                                WAGE-NEW-INDEX-RECORD-MSA.
144200
144300**---------------------------------------------------------------*
144400**       FISCAL YEAR 2003, RATE YEAR 2003 (NO LONGER CALLED)     *
144500**---------------------------------------------------------------*
144600         IF B-DISCHARGE-DATE < 20030701
144700            CALL LTCAL032 USING BILL-NEW-DATA
144800                                PPS-DATA-ALL
144900                                PRICER-OPT-VERS-SW
145000                                PROV-NEW-HOLD
145100                                WAGE-NEW-INDEX-RECORD-MSA.
145200
145300
145400         GOBACK.
145500
145600******************************************************************
145700******************************************************************
145800
145900
146000******************************************************************
146100 0500-GET-MSA.
146200******************************************************************
146300
146400     MOVE P-NEW-GEO-LOC-MSAX TO HOLD-PROV-MSA.
146500
146600     SEARCH M-MSA-DATA VARYING MU1
146700       AT END
146800          MOVE 60 TO PPS-RTC
146900       WHEN MSAX-MSA (MU1) = HOLD-PROV-MSA
147000          SET MU2 TO MU1
147100          PERFORM 0600-N-GET-WAGE-INDX
147200            THRU 0600-N-EXIT VARYING MU2
147300            FROM MU1 BY 1 UNTIL
147400              MSAX-MSA (MU2) NOT = HOLD-PROV-MSA.
147500
147600 0500-EXIT.
147700      EXIT.
147800
147900
148000******************************************************************
148100 0550-GET-CBSA.
148200******************************************************************
148300
148400*----------------------------------------------------------------*
148500* USE SPECIAL WAGE INDEX WHEN INDICATED - FOR LTCH WAGE INDEX    *
148600* TO USE THE SPECIAL WAGE INDEX IT MUST:                         *
148700*   1) BE FOR A CLAIM DISCHARGED ON OR AFTER 07/01/2005          *
148800*      (WHEN SPECIAL WAGE INDEX WAS FIRST USED FOR LTCH)         *
148900*   2) BE NUMERIC,                                               *
149000*   3) BE GREATER THAN 0, AND                                    *
149100*   4) BE IN A PSF RECORD WITH AN EFFECTIVE DATE WITHIN THE      *
149200*      CLAIM'S FISCAL YEAR.                                      *
149300*----------------------------------------------------------------*
149400     IF B-DISCHARGE-DATE > 20050630
149500     IF P-NEW-CBSA-SPEC-PAY-IND = '1'
149600        IF P-NEW-SPECIAL-WAGE-INDEX NUMERIC AND
149700           P-NEW-SPECIAL-WAGE-INDEX > 0 AND
149800           (P-NEW-EFF-DATE >= W-FY-BEGIN-DATE AND
149900            P-NEW-EFF-DATE <= W-FY-END-DATE)
150000            MOVE ZEROS                    TO W-NEW-CBSA
150100            MOVE P-NEW-EFF-DATE           TO W-NEW-EFF-DATE-C
150200            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX1-RECORD-C
150300            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX2-RECORD-C
150400            MOVE P-NEW-SPECIAL-WAGE-INDEX TO W-NEW-INDEX3-RECORD-C
150500            GO TO 0550-EXIT
150600        ELSE
150700            MOVE 52 TO PPS-RTC
150800            GO TO 0550-EXIT
150900        END-IF
151000     END-IF
151100     END-IF.
151200
151300
151400     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-CBSA.
151500
151600     SEARCH C-CBSA-DATA VARYING CU1
151700        AT END
151800           MOVE 60 TO PPS-RTC
151900        WHEN CBSAX-CBSA (CU1) = HOLD-PROV-CBSA
152000           SET CU2 TO CU1
152100           PERFORM 0650-N-GET-WAGE-INDX
152200             THRU 0650-N-EXIT VARYING CU2
152300             FROM CU1 BY 1 UNTIL
152400               CBSAX-CBSA (CU2) NOT = HOLD-PROV-CBSA.
152500
152600 0550-EXIT.
152700      EXIT.
152800
152900
153000******************************************************************
153100 0575-GET-IPPS-CBSA.
153200******************************************************************
153300
153400*------------------------------------------------------------*
153500* SET IPPS CBSA TO GEOGRAPHIC LOCATION CBSA IN PSF           *
153600*------------------------------------------------------------*
153700     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
153800
153900
154000*------------------------------------------------------------*
154100* ASSIGN FY 2006 IPPS WAGE INDEX FLOORS                      *
154200*------------------------------------------------------------*
154300     IF B-DISCHARGE-DATE > 20050930 AND < 20061001
154400        PERFORM 0580-FY2006-FLOOR-CBSA THRU 0580-FY2006-EXIT
154500     END-IF.
154600
154700
154800*------------------------------------------------------------*
154900* ASSIGN FY 2007 IPPS WAGE INDEX FLOORS                      *
155000*------------------------------------------------------------*
155100     IF B-DISCHARGE-DATE > 20060930 AND < 20071001
155200        PERFORM 0580-FY2007-FLOOR-CBSA THRU 0580-FY2007-EXIT
155300     END-IF.
155400
155500
155600*------------------------------------------------------------*
155700* ASSIGN FY 2008 IPPS WAGE INDEX FLOORS                      *
155800*------------------------------------------------------------*
155900     IF B-DISCHARGE-DATE > 20070930 AND < 20081001
156000        PERFORM 0580-FY2008-FLOOR-CBSA THRU 0580-FY2008-EXIT
156100     END-IF.
156200
156300
156400*------------------------------------------------------------*
156500* ASSIGN FY 2009 IPPS WAGE INDEX FLOORS                      *
156600*------------------------------------------------------------*
156700     IF B-DISCHARGE-DATE > 20080930 AND < 20091001
156800        PERFORM 0580-FY2009-FLOOR-CBSA THRU 0580-FY2009-EXIT
156900     END-IF.
157000
157100
157200*------------------------------------------------------------*
157300* ASSIGN FY 2010 IPPS WAGE INDEX FLOORS                      *
157400*------------------------------------------------------------*
157500     IF B-DISCHARGE-DATE > 20090930 AND < 20101001
157600        PERFORM 0580-FY2010-FLOOR-CBSA THRU 0580-FY2010-EXIT
157700     END-IF.
157800
157900*------------------------------------------------------------*
158000* ASSIGN FY 2011 IPPS WAGE INDEX FLOORS                      *
158100*------------------------------------------------------------*
158200     IF B-DISCHARGE-DATE > 20100930 AND < 20111001
158300        PERFORM 0580-FY2011-FLOOR-CBSA THRU 0580-FY2011-EXIT
158400     END-IF.
158500
158600*------------------------------------------------------------*
158700* ASSIGN FY 2012 IPPS WAGE INDEX FLOORS                      *
158800*------------------------------------------------------------*
158900     IF B-DISCHARGE-DATE > 20110930 AND < 20121001
159000        PERFORM 0580-FY2012-FLOOR-CBSA THRU 0580-FY2012-EXIT
159100     END-IF.
159200
159300*------------------------------------------------------------*
159400* ASSIGN FY 2013 IPPS WAGE INDEX FLOORS                      *
159500*------------------------------------------------------------*
159600     IF B-DISCHARGE-DATE > 20120930 AND < 20131001
159700        PERFORM 0580-FY2013-FLOOR-CBSA THRU 0580-FY2013-EXIT
159800     END-IF.
159900
160000*------------------------------------------------------------*
160100* ASSIGN FY 2014 IPPS WAGE INDEX FLOORS                      *
160200*------------------------------------------------------------*
160300     IF B-DISCHARGE-DATE > 20130930 AND < 20141001
160400        PERFORM 0580-FY2014-FLOOR-CBSA THRU 0580-FY2014-EXIT
160500     END-IF.
160600
160700
160800*------------------------------------------------------------*
160900* SEARCH TABLE FOR IPPS CBSA & GET WAGE INDEX                *
161000*------------------------------------------------------------*
161100     SEARCH T-CBSA-DATA VARYING MA1
161200        AT END
161300           MOVE 60 TO PPS-RTC
161400        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
161500           SET MA2 TO MA1
161600           PERFORM 0675-N-GET-IPPS-WAGE-INDX
161700              THRU 0675-N-EXIT VARYING MA2
161800              FROM MA1 BY 1 UNTIL
161900                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
162000
162100
162200*------------------------------------------------------------*
162300* ASSIGN IPPS WAGE INDEX FLOORS FOR FY 2015 AND LATER        *
162400*------------------------------------------------------------*
162500     IF B-DISCHARGE-DATE > 20140930
162600        PERFORM 0580-FY2015-LATER-FLOOR-CBSA
162700           THRU 0580-FY2015-LATER-EXIT
162800     END-IF.
162900
163000
163100*------------------------------------------------------------*
163200* GET THE IPPS CBSA SIZE INDICATOR                           *
163300*------------------------------------------------------------*
163400* LOGIC REVISED 12/28/2006 FOR VERSION 08.0                  *
163500*------------------------------------------------------------*
163600     MOVE P-NEW-GEO-LOC-CBSAX TO HOLD-PROV-IPPS-CBSA.
163700
163800     SET MA1 TO 1.
163900     SEARCH T-CBSA-DATA VARYING MA1
164000        AT END
164100           MOVE 60 TO PPS-RTC
164200        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
164300           SET MA2 TO MA1.
164400
164500     IF PPS-RTC = 00
164600        PERFORM 0585-GET-IPPS-CBSA-SIZE
164700           THRU 0585-EXIT VARYING MA2
164800           FROM MA1 BY 1 UNTIL
164900                T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
165000
165100
165200*------------------------------------------------------------*
165300* GET THE PUERTO RICO SPECIFIC WAGE INDEX FOR PR HOSPITALS   *
165400*------------------------------------------------------------*
165500     IF P-NEW-STATE = 40
165600        PERFORM 0590-GET-IPPS-CBSA-PR THRU 0590-EXIT
165700        IF W-IPPS-PR-WAGE-INDEX = 0
165800           MOVE 52 TO PPS-RTC
165900        END-IF
166000     END-IF.
166100
166200
166300 0575-EXIT.
166400      EXIT.
166500
166600
166700******************************************************************
166800*                                                                *
166900* FLOOR ASSIGNMENTS FOR FY 2006 ONLY:                            *
167000*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
167100*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
167200*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
167300* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV063             *
167400*                                                                *
167500******************************************************************
167600 0580-FY2006-FLOOR-CBSA.
167700******************************************************************
167800
167900     IF HOLD-PROV-IPPS-CBSA = '   10'
168000        AND P-NEW-CBSA-SPEC-PAY-IND = 'Y'
168100        AND P-NEW-STATE = 10
168200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
168300            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
168400
168500     IF HOLD-PROV-IPPS-CBSA = '   50'
168600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
168700        AND P-NEW-STATE = 50
168800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
168900            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
169000
169100     IF HOLD-PROV-IPPS-CBSA = '10900'
169200        AND P-NEW-STATE = 31
169300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
169400            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
169500
169600     IF HOLD-PROV-IPPS-CBSA = '15764'
169700        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
169800        AND P-NEW-STATE = 30
169900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
170000            MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
170100
170200     IF HOLD-PROV-IPPS-CBSA = '16620'
170300        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
170400        AND P-NEW-STATE = 36
170500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
170600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
170700
170800     IF HOLD-PROV-IPPS-CBSA = '19060'
170900        AND P-NEW-STATE = 21
171000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
171100            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
171200
171300     IF HOLD-PROV-IPPS-CBSA = '22020'
171400        AND P-NEW-STATE = 24
171500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
171600            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
171700
171800     IF HOLD-PROV-IPPS-CBSA = '24220'
171900        AND P-NEW-STATE = 24
172000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
172100            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
172200
172300     IF HOLD-PROV-IPPS-CBSA = '24580'
172400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
172500        AND P-NEW-STATE = 52
172600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
172700            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
172800
172900     IF HOLD-PROV-IPPS-CBSA = '25540'
173000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
173100        AND P-NEW-STATE = 07
173200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
173300            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
173400
173500     IF HOLD-PROV-IPPS-CBSA = '30300'
173600        AND P-NEW-STATE = 50
173700            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
173800            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
173900
174000     IF HOLD-PROV-IPPS-CBSA = '37620'
174100        AND P-NEW-STATE = 36
174200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
174300            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
174400
174500     IF HOLD-PROV-IPPS-CBSA = '39900'
174600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
174700        AND P-NEW-STATE = 05
174800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
174900            MOVE '   05' TO HOLD-PROV-IPPS-CBSA.
175000
175100     IF HOLD-PROV-IPPS-CBSA = '48260'
175200        AND P-NEW-STATE = 36
175300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
175400            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
175500
175600     IF HOLD-PROV-IPPS-CBSA = '48540'
175700        AND P-NEW-STATE = 36
175800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
175900            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
176000
176100     IF HOLD-PROV-IPPS-CBSA = '48540'
176200        AND P-NEW-STATE = 51
176300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
176400            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
176500
176600     IF HOLD-PROV-IPPS-CBSA = '48864'
176700        AND P-NEW-STATE = 31
176800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
176900            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
177000
177100     IF HOLD-PROV-IPPS-CBSA = '49660'
177200        AND P-NEW-STATE = 36
177300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
177400            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
177500
177600
177700 0580-FY2006-EXIT.
177800      EXIT.
177900
178000
178100******************************************************************
178200*                                                                *
178300* FLOOR ASSIGNMENTS FOR FY 2007:                                 *
178400*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
178500*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
178600*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
178700* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV071             *
178800*                                                                *
178900******************************************************************
179000 0580-FY2007-FLOOR-CBSA.
179100******************************************************************
179200
179300     IF HOLD-PROV-IPPS-CBSA = '   10'
179400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
179500        AND P-NEW-STATE = 10
179600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
179700            MOVE '   10' TO HOLD-PROV-IPPS-CBSA.
179800
179900     IF HOLD-PROV-IPPS-CBSA = '   14'
180000        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
180100        AND P-NEW-STATE = 14
180200            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
180300            MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
180400
180500     IF HOLD-PROV-IPPS-CBSA = '   26'
180600        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
180700        AND P-NEW-STATE = 26
180800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
180900            MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
181000
181100     IF HOLD-PROV-IPPS-CBSA = '   50'
181200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
181300        AND P-NEW-STATE = 50
181400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
181500            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
181600
181700     IF HOLD-PROV-IPPS-CBSA = '10900'
181800        AND P-NEW-STATE = 31
181900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
182000            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
182100
182200     IF HOLD-PROV-IPPS-CBSA = '19060'
182300        AND P-NEW-STATE = 21
182400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
182500            MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
182600
182700     IF HOLD-PROV-IPPS-CBSA = '22020'
182800        AND P-NEW-STATE = 24
182900            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
183000            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
183100
183200     IF HOLD-PROV-IPPS-CBSA = '24220'
183300        AND P-NEW-STATE = 24
183400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
183500            MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
183600
183700     IF HOLD-PROV-IPPS-CBSA = '24580'
183800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
183900        AND P-NEW-STATE = 52
184000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
184100            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
184200
184300     IF HOLD-PROV-IPPS-CBSA = '25540'
184400        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
184500        AND P-NEW-STATE = 07
184600            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
184700            MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
184800
184900     IF HOLD-PROV-IPPS-CBSA = '26580'
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
185600*----------------------------------------------------------*
185700*  ON AND AFTER 11/03/2006, NO HOSPITALS RECLASSIFYING TO  *
185800*  CBSA 27860 WILL RECEIVE ITS STATE FLOOR DUE TO THE WIX  *
185900*  CHANGE IN THE IPPS FINAL RULE 2007 CORRECTION NOTICE 1  *
186000*----------------------------------------------------------*
186100*  - LOGIC DISABLED 11-20-2006 FOR RELEASE 07.5            *
186200*  - REINSTATED & ALTERED 12-28-2006 FOR RELEASE 08.0 TO   *
186300*    MATCH THE IPPS PRICER (BECAUSE THIS CODE ONLY APPLIES *
186400*    RECLASS PROVIDERS AND THERE ARE NO LTCH RECLASS       *
186500*    PROVIDERS, THESE CHANGES DO NOT AFFECT BILL PAYMENT)  *
186600*----------------------------------------------------------*
186700     IF B-DISCHARGE-DATE < 20061103
186800        IF HOLD-PROV-IPPS-CBSA = '27860'
186900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
187000           AND P-NEW-STATE = 26
187100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
187200               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
187300*----------------------------------------------------------*
187400
187500
187600     IF HOLD-PROV-IPPS-CBSA = '29100'
187700        AND P-NEW-STATE = 52
187800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
187900            MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
188000
188100     IF HOLD-PROV-IPPS-CBSA = '30300'
188200        AND P-NEW-STATE = 50
188300            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
188400            MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
188500
188600     IF HOLD-PROV-IPPS-CBSA = '37620'
188700        AND P-NEW-STATE = 36
188800            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
188900            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
189000
189100     IF HOLD-PROV-IPPS-CBSA = '37964'
189200        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
189300        AND P-NEW-STATE = 31
189400            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
189500            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
189600
189700     IF HOLD-PROV-IPPS-CBSA = '38300'
189800        AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
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 = '39300'
190400        AND P-NEW-STATE = 22
190500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
190600            MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
190700
190800     IF HOLD-PROV-IPPS-CBSA = '39300'
190900        AND P-NEW-STATE = 41
191000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191100            MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
191200
191300     IF HOLD-PROV-IPPS-CBSA = '45500'
191400        AND P-NEW-STATE = 45
191500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
191600            MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
191700
191800     IF HOLD-PROV-IPPS-CBSA = '48260'
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     IF HOLD-PROV-IPPS-CBSA = '48540'
192400        AND P-NEW-STATE = 36
192500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
192600            MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
192700
192800     IF HOLD-PROV-IPPS-CBSA = '48540'
192900        AND P-NEW-STATE = 51
193000            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
193100            MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
193200
193300     IF HOLD-PROV-IPPS-CBSA = '48864'
193400        AND P-NEW-STATE = 31
193500            MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
193600            MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
193700
193800
193900 0580-FY2007-EXIT.
194000      EXIT.
194100
194200
194300******************************************************************
194400*                                                                *
194500* FLOOR ASSIGNMENTS FOR FY 2008:                                 *
194600*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
194700*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
194800*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
194900* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV080             *
195000*                                                                *
195100******************************************************************
195200 0580-FY2008-FLOOR-CBSA.
195300******************************************************************
195400
195500        IF HOLD-PROV-IPPS-CBSA = '   39'
195600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
195700           AND P-NEW-STATE = 33
195800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
195900               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
196000
196100        IF HOLD-PROV-IPPS-CBSA = '   39'
196200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
196300           AND P-NEW-STATE = 39
196400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
196500               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
196600
196700        IF HOLD-PROV-IPPS-CBSA = '10900'
196800           AND P-NEW-STATE = 31
196900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
197100
197200        IF HOLD-PROV-IPPS-CBSA = '19060'
197300           AND P-NEW-STATE = 21
197400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
197500               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
197600
197700        IF HOLD-PROV-IPPS-CBSA = '21780'
197800           AND P-NEW-STATE = 15
197900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
198000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
198100
198200        IF HOLD-PROV-IPPS-CBSA = '21780'
198300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
198400           AND P-NEW-STATE = 15
198500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
198600               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
198700
198800        IF HOLD-PROV-IPPS-CBSA = '22020'
198900           AND P-NEW-STATE = 24
199000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
199100               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
199200
199300        IF HOLD-PROV-IPPS-CBSA = '24220'
199400           AND P-NEW-STATE = 24
199500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
199600               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
199700
199800        IF HOLD-PROV-IPPS-CBSA = '24580'
199900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
200000           AND P-NEW-STATE = 52
200100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
200200               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
200300
200400        IF HOLD-PROV-IPPS-CBSA = '25540'
200500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
200600           AND P-NEW-STATE = 07
200700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
200800               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
200900
201000        IF HOLD-PROV-IPPS-CBSA = '28420'
201100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
201200           AND P-NEW-STATE = 50
201300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
201400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
201500
201600        IF HOLD-PROV-IPPS-CBSA = '28700'
201700           AND P-NEW-STATE = 44
201800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
201900               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
202000
202100        IF HOLD-PROV-IPPS-CBSA = '28700'
202200           AND P-NEW-STATE = 49
202300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202400               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
202500
202600        IF HOLD-PROV-IPPS-CBSA = '30300'
202700           AND P-NEW-STATE = 50
202800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
202900               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
203000
203100        IF HOLD-PROV-IPPS-CBSA = '35084'
203200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
203300           AND P-NEW-STATE = 31
203400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
203500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
203600
203700        IF HOLD-PROV-IPPS-CBSA = '37620'
203800           AND P-NEW-STATE = 36
203900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
204100
204200        IF HOLD-PROV-IPPS-CBSA = '37964'
204300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
204400           AND P-NEW-STATE = 31
204500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
204600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
204700
204800        IF HOLD-PROV-IPPS-CBSA = '38300'
204900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
205000           AND P-NEW-STATE = 36
205100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
205300
205400        IF HOLD-PROV-IPPS-CBSA = '45500'
205500           AND P-NEW-STATE = 45
205600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
205700               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
205800
205900        IF HOLD-PROV-IPPS-CBSA = '48260'
206000           AND P-NEW-STATE = 36
206100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
206200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
206300
206400        IF HOLD-PROV-IPPS-CBSA = '48540'
206500           AND P-NEW-STATE = 36
206600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
206700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
206800
206900        IF HOLD-PROV-IPPS-CBSA = '48540'
207000           AND P-NEW-STATE = 51
207100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
207200               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
207300
207400        IF HOLD-PROV-IPPS-CBSA = '48864'
207500           AND P-NEW-STATE = 31
207600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
207700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
207800
207900        IF HOLD-PROV-IPPS-CBSA = '48864'
208000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
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-FY2008-EXIT.
208700      EXIT.
208800
208900
209000******************************************************************
209100*                                                                *
209200* FLOOR ASSIGNMENTS FOR FY 2009:                                 *
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: PPDRV093             *
209700*                                                                *
209800******************************************************************
209900 0580-FY2009-FLOOR-CBSA.
210000******************************************************************
210100
210200        IF HOLD-PROV-IPPS-CBSA = '   04'
210300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
210400           AND P-NEW-STATE = 04
210500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
210600               MOVE '   04' TO HOLD-PROV-IPPS-CBSA.
210700
210800        IF HOLD-PROV-IPPS-CBSA = '   04'
210900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
211000           AND P-NEW-STATE = 19
211100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211200               MOVE '   19' TO HOLD-PROV-IPPS-CBSA.
211300
211400        IF HOLD-PROV-IPPS-CBSA = '   14'
211500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
211600           AND P-NEW-STATE = 14
211700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
211800               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
211900
212000        IF HOLD-PROV-IPPS-CBSA = '   14'
212100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
212200           AND P-NEW-STATE = 26
212300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212400               MOVE '   26' TO HOLD-PROV-IPPS-CBSA.
212500
212600        IF HOLD-PROV-IPPS-CBSA = '10900'
212700           AND P-NEW-STATE = 31
212800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
212900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
213000
213100        IF HOLD-PROV-IPPS-CBSA = '19340'
213200           AND P-NEW-STATE = 16
213300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
213400               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
213500
213600        IF HOLD-PROV-IPPS-CBSA = '21780'
213700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
213800           AND P-NEW-STATE = 15
213900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
214100
214200        IF HOLD-PROV-IPPS-CBSA = '22020'
214300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
214400           AND P-NEW-STATE = 43
214500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
214600               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
214700
214800        IF HOLD-PROV-IPPS-CBSA = '22900'
214900           AND P-NEW-STATE = 37
215000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
215100               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
215200
215300        IF HOLD-PROV-IPPS-CBSA = '24580'
215400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
215500           AND P-NEW-STATE = 52
215600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
215700               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
215800
215900        IF HOLD-PROV-IPPS-CBSA = '25540'
216000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
216100           AND P-NEW-STATE = 07
216200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216300               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
216400
216500        IF HOLD-PROV-IPPS-CBSA = '28420'
216600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
216700           AND P-NEW-STATE = 50
216800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
216900               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
217000
217100        IF HOLD-PROV-IPPS-CBSA = '28700'
217200           AND P-NEW-STATE = 44
217300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
217500
217600        IF HOLD-PROV-IPPS-CBSA = '28700'
217700           AND P-NEW-STATE = 49
217800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
217900               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
218000
218100        IF HOLD-PROV-IPPS-CBSA = '28700'
218200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
218300           AND P-NEW-STATE = 18
218400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
218500               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
218600
218700        IF HOLD-PROV-IPPS-CBSA = '28700'
218800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
218900           AND P-NEW-STATE = 44
219000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
219200
219300        IF HOLD-PROV-IPPS-CBSA = '28940'
219400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
219500           AND P-NEW-STATE = 18
219600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
219700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
219800
219900        IF HOLD-PROV-IPPS-CBSA = '28940'
220000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
220100           AND P-NEW-STATE = 44
220200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
220400
220500        IF HOLD-PROV-IPPS-CBSA = '34820'
220600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
220700           AND P-NEW-STATE = 34
220800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
220900               MOVE '   34' TO HOLD-PROV-IPPS-CBSA.
221000
221100        IF HOLD-PROV-IPPS-CBSA = '34820'
221200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
221300           AND P-NEW-STATE = 42
221400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
221500               MOVE '   42' TO HOLD-PROV-IPPS-CBSA.
221600
221700        IF HOLD-PROV-IPPS-CBSA = '37620'
221800           AND P-NEW-STATE = 36
221900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
222100
222200        IF HOLD-PROV-IPPS-CBSA = '37964'
222300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
222400           AND P-NEW-STATE = 31
222500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
222600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
222700
222800        IF HOLD-PROV-IPPS-CBSA = '38340'
222900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
223000           AND P-NEW-STATE = 47
223100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223200               MOVE '   47' TO HOLD-PROV-IPPS-CBSA.
223300
223400        IF HOLD-PROV-IPPS-CBSA = '41620'
223500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
223600           AND P-NEW-STATE = 29
223700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
223800               MOVE '   29' TO HOLD-PROV-IPPS-CBSA.
223900
224000        IF HOLD-PROV-IPPS-CBSA = '43580'
224100           AND P-NEW-STATE = 16
224200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224300               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
224400
224500        IF HOLD-PROV-IPPS-CBSA = '48540'
224600           AND P-NEW-STATE = 36
224700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
224800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
224900
225000        IF HOLD-PROV-IPPS-CBSA = '48540'
225100           AND P-NEW-STATE = 51
225200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225300               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
225400
225500        IF HOLD-PROV-IPPS-CBSA = '48864'
225600           AND P-NEW-STATE = 31
225700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
225800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
225900
226000        IF HOLD-PROV-IPPS-CBSA = '48864'
226100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
226200           AND P-NEW-STATE = 31
226300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
226500
226600        IF HOLD-PROV-IPPS-CBSA = '19060'
226700           AND P-NEW-STATE = 21
226800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
226900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
227000
227100        IF HOLD-PROV-IPPS-CBSA = '19060'
227200           AND P-NEW-STATE = 51
227300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227400               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
227500
227600        IF HOLD-PROV-IPPS-CBSA = '22020'
227700           AND P-NEW-STATE = 24
227800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
227900               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
228000
228100        IF HOLD-PROV-IPPS-CBSA = '24220'
228200           AND P-NEW-STATE = 24
228300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
228500
228600        IF HOLD-PROV-IPPS-CBSA = '30300'
228700           AND P-NEW-STATE = 50
228800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
228900               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
229000
229100        IF HOLD-PROV-IPPS-CBSA = '48260'
229200           AND P-NEW-STATE = 36
229300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
229400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
229500
229600
229700 0580-FY2009-EXIT.
229800      EXIT.
229900
230000
230100******************************************************************
230200*                                                                *
230300* FLOOR ASSIGNMENTS FOR FY 2010:                                 *
230400*   ASSIGN IPPS WAGE INDEX STATE FLOORS WHEN NECESSARY -         *
230500*   PROVIDER'S STATE'S WAGE INDEX IS GREATER THAN THE WAGE       *
230600*   WAGE INDEX OF THE CBSA IT IS ASSIGNED TO                     *
230700* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV100             *
230800*                                                                *
230900******************************************************************
231000 0580-FY2010-FLOOR-CBSA.
231100******************************************************************
231200
231300        IF HOLD-PROV-IPPS-CBSA = '   33'
231400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
231500           AND P-NEW-STATE = 30
231600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
231700               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
231800
231900        IF HOLD-PROV-IPPS-CBSA = '   33'
232000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
232100           AND P-NEW-STATE = 33
232200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232300               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
232400
232500        IF HOLD-PROV-IPPS-CBSA = '10900'
232600           AND P-NEW-STATE = 31
232700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
232800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
232900
233000        IF HOLD-PROV-IPPS-CBSA = '19340'
233100           AND P-NEW-STATE = 16
233200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233300               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
233400
233500        IF HOLD-PROV-IPPS-CBSA = '19340'
233600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
233700           AND P-NEW-STATE = 16
233800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
233900               MOVE '   16' TO HOLD-PROV-IPPS-CBSA.
234000
234100        IF HOLD-PROV-IPPS-CBSA = '21780'
234200           AND P-NEW-STATE = 15
234300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
234400               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
234500
234600        IF HOLD-PROV-IPPS-CBSA = '21780'
234700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
234800           AND P-NEW-STATE = 15
234900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235000               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
235100
235200        IF HOLD-PROV-IPPS-CBSA = '25180'
235300           AND P-NEW-STATE = 21
235400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
235500               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
235600
235700        IF HOLD-PROV-IPPS-CBSA = '25540'
235800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
235900           AND P-NEW-STATE = 07
236000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236100               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
236200
236300        IF HOLD-PROV-IPPS-CBSA = '28420'
236400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
236500           AND P-NEW-STATE = 50
236600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
236700               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
236800
236900        IF HOLD-PROV-IPPS-CBSA = '28940'
237000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
237100           AND P-NEW-STATE = 18
237200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237300               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
237400
237500        IF HOLD-PROV-IPPS-CBSA = '28940'
237600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
237700           AND P-NEW-STATE = 44
237800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
237900               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
238000
238100        IF HOLD-PROV-IPPS-CBSA = '35084'
238200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
238300           AND P-NEW-STATE = 31
238400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
238500               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
238600
238700        IF HOLD-PROV-IPPS-CBSA = '37620'
238800           AND P-NEW-STATE = 36
238900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239000               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
239100
239200        IF HOLD-PROV-IPPS-CBSA = '37964'
239300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
239400           AND P-NEW-STATE = 31
239500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
239600               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
239700
239800        IF HOLD-PROV-IPPS-CBSA = '48540'
239900           AND P-NEW-STATE = 36
240000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240100               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
240200
240300        IF HOLD-PROV-IPPS-CBSA = '48540'
240400           AND P-NEW-STATE = 51
240500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
240600               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
240700
240800        IF HOLD-PROV-IPPS-CBSA = '48864'
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 = '48864'
241400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
241500           AND P-NEW-STATE = 31
241600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
241700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
241800
241900        IF HOLD-PROV-IPPS-CBSA = '49660'
242000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
242100           AND P-NEW-STATE = 36
242200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
242400
242500        IF HOLD-PROV-IPPS-CBSA = '19060'
242600           AND P-NEW-STATE = 21
242700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
242800               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
242900
243000        IF HOLD-PROV-IPPS-CBSA = '22020'
243100           AND P-NEW-STATE = 24
243200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243300               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
243400
243500        IF HOLD-PROV-IPPS-CBSA = '24220'
243600           AND P-NEW-STATE = 24
243700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
243800               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
243900
244000        IF HOLD-PROV-IPPS-CBSA = '30300'
244100           AND P-NEW-STATE = 50
244200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244300               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
244400
244500        IF HOLD-PROV-IPPS-CBSA = '35084'
244600           AND P-NEW-STATE = 31
244700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
244800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
244900
245000        IF HOLD-PROV-IPPS-CBSA = '48260'
245100           AND P-NEW-STATE = 36
245200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245300               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
245400
245500        IF HOLD-PROV-IPPS-CBSA = '48260'
245600           AND P-NEW-STATE = 51
245700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
245800               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
245900
246000
246100 0580-FY2010-EXIT.
246200      EXIT.
246300
246400******************************************************************
246500*                                                                *
246600* FLOOR ASSIGNMENTS FOR FY 2011:                                 *
246700* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV110             *
246800*                                                                *
246900******************************************************************
247000
247100 0580-FY2011-FLOOR-CBSA.
247200
247300        IF HOLD-PROV-IPPS-CBSA = '   45'
247400          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
247500          AND P-NEW-STATE = 45
247600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
247700               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
247800
247900        IF HOLD-PROV-IPPS-CBSA = '   37'
248000          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
248100          AND P-NEW-STATE = 37
248200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248300               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
248400
248500        IF HOLD-PROV-IPPS-CBSA = '10900'
248600           AND P-NEW-STATE = 31
248700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
248800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
248900
249000        IF HOLD-PROV-IPPS-CBSA = '21500'
249100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
249200           AND P-NEW-STATE = 33
249300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
249400               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
249500
249600        IF HOLD-PROV-IPPS-CBSA = '21500'
249700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
249800           AND P-NEW-STATE = 39
249900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250000               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
250100
250200        IF HOLD-PROV-IPPS-CBSA = '21780'
250300           AND P-NEW-STATE = 15
250400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
250500               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
250600
250700        IF HOLD-PROV-IPPS-CBSA = '22900'
250800           AND P-NEW-STATE = 37
250900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251000               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
251100
251200        IF HOLD-PROV-IPPS-CBSA = '24540'
251300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
251400           AND P-NEW-STATE = 53
251500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
251600               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
251700
251800        IF HOLD-PROV-IPPS-CBSA = '25540'
251900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
252000           AND P-NEW-STATE = 07
252100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252200               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
252300
252400        IF HOLD-PROV-IPPS-CBSA = '28700'
252500           AND P-NEW-STATE = 44
252600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
252700               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
252800
252900        IF HOLD-PROV-IPPS-CBSA = '28700'
253000           AND P-NEW-STATE = 49
253100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253200               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
253300
253400        IF HOLD-PROV-IPPS-CBSA = '28940'
253500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
253600           AND P-NEW-STATE = 18
253700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
253800               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
253900
254000        IF HOLD-PROV-IPPS-CBSA = '28940'
254100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
254200           AND P-NEW-STATE = 44
254300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
254500
254600        IF HOLD-PROV-IPPS-CBSA = '37620'
254700           AND P-NEW-STATE = 36
254800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
254900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
255000
255100        IF HOLD-PROV-IPPS-CBSA = '37620'
255200           AND P-NEW-STATE = 51
255300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
255400               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
255500
255600        IF HOLD-PROV-IPPS-CBSA = '37964'
255700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
255800           AND P-NEW-STATE = 31
255900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256000               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
256100
256200        IF HOLD-PROV-IPPS-CBSA = '38300'
256300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
256400           AND P-NEW-STATE = 36
256500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
256600               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
256700
256800        IF HOLD-PROV-IPPS-CBSA = '38300'
256900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
257000           AND P-NEW-STATE = 39
257100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257200               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
257300
257400        IF HOLD-PROV-IPPS-CBSA = '43580'
257500           AND P-NEW-STATE = 43
257600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
257700               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
257800
257900        IF HOLD-PROV-IPPS-CBSA = '48540'
258000           AND P-NEW-STATE = 36
258100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258200               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
258300
258400        IF HOLD-PROV-IPPS-CBSA = '48540'
258500           AND P-NEW-STATE = 51
258600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
258700               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
258800
258900        IF HOLD-PROV-IPPS-CBSA = '48864'
259000           AND P-NEW-STATE = 31
259100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
259300
259400        IF HOLD-PROV-IPPS-CBSA = '17300'
259500           AND P-NEW-STATE = 18
259600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
259700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
259800
259900        IF HOLD-PROV-IPPS-CBSA = '17300'
260000           AND P-NEW-STATE = 44
260100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260200               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
260300
260400        IF HOLD-PROV-IPPS-CBSA = '19060'
260500           AND P-NEW-STATE = 21
260600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
260700               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
260800
260900        IF HOLD-PROV-IPPS-CBSA = '22020'
261000           AND P-NEW-STATE = 24
261100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261200               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
261300
261400        IF HOLD-PROV-IPPS-CBSA = '22020'
261500           AND P-NEW-STATE = 35
261600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
261700               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
261800
261900        IF HOLD-PROV-IPPS-CBSA = '24220'
262000           AND P-NEW-STATE = 24
262100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262200               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
262300
262400        IF HOLD-PROV-IPPS-CBSA = '24220'
262500           AND P-NEW-STATE = 35
262600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
262700               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
262800
262900        IF HOLD-PROV-IPPS-CBSA = '30300'
263000           AND P-NEW-STATE = 50
263100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263200               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
263300
263400        IF HOLD-PROV-IPPS-CBSA = '44600'
263500           AND P-NEW-STATE = 36
263600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
263700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
263800
263900        IF HOLD-PROV-IPPS-CBSA = '44600'
264000           AND P-NEW-STATE = 51
264100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264200               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
264300
264400        IF HOLD-PROV-IPPS-CBSA = '45500'
264500           AND P-NEW-STATE = 45
264600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
264700               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
264800
264900
265000 0580-FY2011-EXIT.
265100      EXIT.
265200
265300******************************************************************
265400*                                                                *
265500* FLOOR ASSIGNMENTS FOR FY 2012:                                 *
265600* ** LOGIC COPIED FROM IPPS PRICER PROGRAM: PPDRV120             *
265700*                                                                *
265800* ******* CHANGE HOLD-PROV-CBSA TO HOLD-PROV-IPPS-CBSA ******    *
265900*                                                                *
266000******************************************************************
266100
266200 0580-FY2012-FLOOR-CBSA.
266300
266400**************YEARCHANGE 2012.0 ******************************
266500
266600        IF HOLD-PROV-IPPS-CBSA = '   30'
266700          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
266800          AND P-NEW-STATE = 30
266900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
267000               MOVE '   30' TO HOLD-PROV-IPPS-CBSA.
267100
267200        IF HOLD-PROV-IPPS-CBSA = '   39'
267300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
267400          AND P-NEW-STATE = 39
267500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
267600               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
267700
267800        IF HOLD-PROV-IPPS-CBSA = '   39'
267900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
268000          AND P-NEW-STATE = 33
268100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268200               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
268300
268400        IF HOLD-PROV-IPPS-CBSA = '10900'
268500           AND P-NEW-STATE = 31
268600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
268700               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
268800
268900        IF HOLD-PROV-IPPS-CBSA = '14484'
269000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269100           AND P-NEW-STATE = 22
269200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
269400
269500        IF HOLD-PROV-IPPS-CBSA = '16020'
269600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
269700           AND P-NEW-STATE = 14
269800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
269900               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
270000
270100        IF HOLD-PROV-IPPS-CBSA = '21500'
270200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
270300           AND P-NEW-STATE = 33
270400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
270500               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
270600
270700        IF HOLD-PROV-IPPS-CBSA = '21500'
270800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
270900           AND P-NEW-STATE = 39
271000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271100               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
271200
271300        IF HOLD-PROV-IPPS-CBSA = '22900'
271400           AND P-NEW-STATE = 37
271500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
271600               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
271700
271800        IF HOLD-PROV-IPPS-CBSA = '25180'
271900           AND P-NEW-STATE = 21
272000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272100               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
272200
272300        IF HOLD-PROV-IPPS-CBSA = '25540'
272400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
272500           AND P-NEW-STATE = 07
272600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
272700               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
272800
272900        IF HOLD-PROV-IPPS-CBSA = '25540'
273000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
273100           AND P-NEW-STATE = 22
273200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273300               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
273400
273500        IF HOLD-PROV-IPPS-CBSA = '26820'
273600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
273700           AND P-NEW-STATE = 53
273800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
273900               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
274000
274100        IF HOLD-PROV-IPPS-CBSA = '28700'
274200           AND P-NEW-STATE = 44
274300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274400               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
274500
274600        IF HOLD-PROV-IPPS-CBSA = '28700'
274700           AND P-NEW-STATE = 49
274800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
274900               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
275000
275100        IF HOLD-PROV-IPPS-CBSA = '28700'
275200           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
275300           AND P-NEW-STATE = 18
275400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
275500               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
275600
275700        IF HOLD-PROV-IPPS-CBSA = '28700'
275800           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
275900           AND P-NEW-STATE = 44
276000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
276100               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
276200
276300        IF HOLD-PROV-IPPS-CBSA = '28940'
276400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
276500           AND P-NEW-STATE = 18
276600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
276700               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
276800
276900        IF HOLD-PROV-IPPS-CBSA = '35084'
277000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
277100           AND P-NEW-STATE = 31
277200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
277400
277500        IF HOLD-PROV-IPPS-CBSA = '37620'
277600           AND P-NEW-STATE = 36
277700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
277800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
277900
278000        IF HOLD-PROV-IPPS-CBSA = '37964'
278100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
278200           AND P-NEW-STATE = 31
278300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
278500
278600        IF HOLD-PROV-IPPS-CBSA = '43580'
278700           AND P-NEW-STATE = 43
278800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
278900               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
279000
279100        IF HOLD-PROV-IPPS-CBSA = '44600'
279200           AND P-NEW-STATE = 36
279300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
279500
279600        IF HOLD-PROV-IPPS-CBSA = '44600'
279700           AND P-NEW-STATE = 51
279800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
279900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
280000
280100        IF HOLD-PROV-IPPS-CBSA = '48540'
280200           AND P-NEW-STATE = 36
280300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
280500
280600        IF HOLD-PROV-IPPS-CBSA = '48540'
280700           AND P-NEW-STATE = 51
280800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
280900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
281000
281100        IF HOLD-PROV-IPPS-CBSA = '48864'
281200           AND P-NEW-STATE = 31
281300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
281500
281600        IF HOLD-PROV-IPPS-CBSA = '49660'
281700           AND P-NEW-STATE = 36
281800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
281900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
282000
282100        IF HOLD-PROV-IPPS-CBSA = '49660'
282200           AND P-NEW-STATE = 39
282300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
282500
282600        IF HOLD-PROV-IPPS-CBSA = '19060'
282700           AND P-NEW-STATE = 21
282800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
282900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
283000
283100        IF HOLD-PROV-IPPS-CBSA = '22020'
283200           AND P-NEW-STATE = 24
283300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
283500
283600        IF HOLD-PROV-IPPS-CBSA = '22020'
283700           AND P-NEW-STATE = 35
283800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
283900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
284000
284100        IF HOLD-PROV-IPPS-CBSA = '24220'
284200           AND P-NEW-STATE = 24
284300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
284500
284600        IF HOLD-PROV-IPPS-CBSA = '24220'
284700           AND P-NEW-STATE = 35
284800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
284900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
285000
285100        IF HOLD-PROV-IPPS-CBSA = '30300'
285200           AND P-NEW-STATE = 50
285300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
285500
285600        IF HOLD-PROV-IPPS-CBSA = '30860'
285700           AND P-NEW-STATE = 46
285800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
285900               MOVE '   46' TO HOLD-PROV-IPPS-CBSA.
286000
286100        IF HOLD-PROV-IPPS-CBSA = '35084'
286200           AND P-NEW-STATE = 31
286300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
286400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
286500
286600        IF HOLD-PROV-IPPS-CBSA = '39300'
286700           AND P-NEW-STATE = 22
286800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
286900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
287000
287100        IF HOLD-PROV-IPPS-CBSA = '45500'
287200           AND P-NEW-STATE = 45
287300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
287400               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
287500
287600**************YEARCHANGE 2012.0 ******************************
287700
287800 0580-FY2012-EXIT.
287900      EXIT.
288000
288100 0580-FY2013-FLOOR-CBSA.
288200
288300**************YEARCHANGE 2013.0 ****************************
288400
288500        IF HOLD-PROV-IPPS-CBSA = '10900'
288600           AND P-NEW-STATE = 31
288700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
288800               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
288900
289000        IF HOLD-PROV-IPPS-CBSA = '14484'
289100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
289200           AND P-NEW-STATE = 22
289300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
289400               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
289500
289600        IF HOLD-PROV-IPPS-CBSA = '16020'
289700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
289800           AND P-NEW-STATE = 14
289900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290000               MOVE '   14' TO HOLD-PROV-IPPS-CBSA.
290100
290200        IF HOLD-PROV-IPPS-CBSA = '21500'
290300          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
290400           AND P-NEW-STATE = 33
290500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
290600               MOVE '   33' TO HOLD-PROV-IPPS-CBSA.
290700
290800        IF HOLD-PROV-IPPS-CBSA = '21500'
290900          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
291000           AND P-NEW-STATE = 39
291100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291200               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
291300
291400        IF HOLD-PROV-IPPS-CBSA = '21780'
291500          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
291600           AND P-NEW-STATE = 15
291700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
291800               MOVE '   15' TO HOLD-PROV-IPPS-CBSA.
291900
292000        IF HOLD-PROV-IPPS-CBSA = '24580'
292100          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
292200           AND P-NEW-STATE = 52
292300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
292400               MOVE '   52' TO HOLD-PROV-IPPS-CBSA.
292500
292600        IF HOLD-PROV-IPPS-CBSA = '25540'
292700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
292800           AND P-NEW-STATE = 07
292900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293000               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
293100
293200        IF HOLD-PROV-IPPS-CBSA = '25540'
293300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
293400           AND P-NEW-STATE = 22
293500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
293600               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
293700
293800        IF HOLD-PROV-IPPS-CBSA = '26820'
293900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294000           AND P-NEW-STATE = 53
294100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294200               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
294300
294400        IF HOLD-PROV-IPPS-CBSA = '27900'
294500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
294600           AND P-NEW-STATE = 17
294700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
294800               MOVE '   17' TO HOLD-PROV-IPPS-CBSA.
294900
295000        IF HOLD-PROV-IPPS-CBSA = '28700'
295100           AND P-NEW-STATE = 44
295200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295300               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
295400
295500        IF HOLD-PROV-IPPS-CBSA = '28700'
295600           AND P-NEW-STATE = 49
295700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
295800               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
295900
296000        IF HOLD-PROV-IPPS-CBSA = '28700'
296100           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
296200           AND P-NEW-STATE = 18
296300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
296400               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
296500
296600        IF HOLD-PROV-IPPS-CBSA = '28700'
296700           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
296800           AND P-NEW-STATE = 44
296900               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297000               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
297100
297200        IF HOLD-PROV-IPPS-CBSA = '28940'
297300           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
297400           AND P-NEW-STATE = 18
297500               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
297600               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
297700
297800        IF HOLD-PROV-IPPS-CBSA = '35084'
297900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
298000           AND P-NEW-STATE = 31
298100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298200               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
298300
298400        IF HOLD-PROV-IPPS-CBSA = '37620'
298500           AND P-NEW-STATE = 36
298600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
298700               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
298800
298900        IF HOLD-PROV-IPPS-CBSA = '37964'
299000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
299100           AND P-NEW-STATE = 31
299200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
299400
299500        IF HOLD-PROV-IPPS-CBSA = '38300'
299600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
299700           AND P-NEW-STATE = 36
299800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
299900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
300000
300100        IF HOLD-PROV-IPPS-CBSA = '43580'
300200           AND P-NEW-STATE = 43
300300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300400               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
300500
300600        IF HOLD-PROV-IPPS-CBSA = '48540'
300700           AND P-NEW-STATE = 36
300800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
300900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
301000
301100        IF HOLD-PROV-IPPS-CBSA = '48540'
301200           AND P-NEW-STATE = 51
301300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301400               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
301500
301600        IF HOLD-PROV-IPPS-CBSA = '48864'
301700           AND P-NEW-STATE = 31
301800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
301900               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
302000
302100        IF HOLD-PROV-IPPS-CBSA = '49660'
302200           AND P-NEW-STATE = 36
302300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
302500
302600        IF HOLD-PROV-IPPS-CBSA = '49660'
302700           AND P-NEW-STATE = 39
302800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
302900               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
303000
303100        IF HOLD-PROV-IPPS-CBSA = '22020'
303200           AND P-NEW-STATE = 24
303300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
303500
303600        IF HOLD-PROV-IPPS-CBSA = '22020'
303700           AND P-NEW-STATE = 35
303800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
303900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
304000
304100        IF HOLD-PROV-IPPS-CBSA = '24220'
304200           AND P-NEW-STATE = 24
304300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
304500
304600        IF HOLD-PROV-IPPS-CBSA = '24220'
304700           AND P-NEW-STATE = 35
304800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
304900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
305000
305100        IF HOLD-PROV-IPPS-CBSA = '30300'
305200           AND P-NEW-STATE = 50
305300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
305500
305600        IF HOLD-PROV-IPPS-CBSA = '39300'
305700           AND P-NEW-STATE = 22
305800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
305900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
306000
306100        IF HOLD-PROV-IPPS-CBSA = '39300'
306200           AND P-NEW-STATE = 41
306300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306400               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
306500
306600        IF HOLD-PROV-IPPS-CBSA = '44600'
306700           AND P-NEW-STATE = 36
306800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
306900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
307000
307100 0580-FY2013-EXIT.
307200      EXIT.
307300
307400 0580-FY2014-FLOOR-CBSA.
307500
307600**************YEARCHANGE 2014.0 ******************************
307700
307800        IF HOLD-PROV-IPPS-CBSA = '   07'
307900           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
308000           AND P-NEW-STATE = 07
308100               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308200               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
308300
308400        IF HOLD-PROV-IPPS-CBSA = '   36'
308500           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
308600           AND P-NEW-STATE = 36
308700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
308800               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
308900
309000        IF HOLD-PROV-IPPS-CBSA = '10900'
309100           AND P-NEW-STATE = 31
309200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
309300               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
309400
309500        IF HOLD-PROV-IPPS-CBSA = '14484'
309600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
309700           AND P-NEW-STATE = 22
309800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
309900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
310000
310100        IF HOLD-PROV-IPPS-CBSA = '17300'
310200           AND P-NEW-STATE = 18
310300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
310400               MOVE '   18' TO HOLD-PROV-IPPS-CBSA.
310500
310600        IF HOLD-PROV-IPPS-CBSA = '22900'
310700           AND P-NEW-STATE = 37
310800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
310900               MOVE '   37' TO HOLD-PROV-IPPS-CBSA.
311000
311100        IF HOLD-PROV-IPPS-CBSA = '25540'
311200          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
311300           AND P-NEW-STATE = 07
311400               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
311500               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
311600
311700        IF HOLD-PROV-IPPS-CBSA = '25540'
311800          AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
311900           AND P-NEW-STATE = 22
312000               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
312100               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
312200
312300        IF HOLD-PROV-IPPS-CBSA = '26820'
312400           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
312500           AND P-NEW-STATE = 53
312600               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
312700               MOVE '   53' TO HOLD-PROV-IPPS-CBSA.
312800
312900        IF HOLD-PROV-IPPS-CBSA = '27180'
313000           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
313100           AND P-NEW-STATE = 25
313200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313300               MOVE '   25' TO HOLD-PROV-IPPS-CBSA.
313400
313500        IF HOLD-PROV-IPPS-CBSA = '28700'
313600           AND P-NEW-STATE = 44
313700               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
313800               MOVE '   44' TO HOLD-PROV-IPPS-CBSA.
313900
314000        IF HOLD-PROV-IPPS-CBSA = '28700'
314100           AND P-NEW-STATE = 49
314200               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314300               MOVE '   49' TO HOLD-PROV-IPPS-CBSA.
314400
314500        IF HOLD-PROV-IPPS-CBSA = '35644'
314600           AND P-NEW-CBSA-SPEC-PAY-IND  = 'Y'
314700           AND P-NEW-STATE = 07
314800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
314900               MOVE '   07' TO HOLD-PROV-IPPS-CBSA.
315000
315100        IF HOLD-PROV-IPPS-CBSA = '37620'
315200           AND P-NEW-STATE = 36
315300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
315400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
315500
315600        IF HOLD-PROV-IPPS-CBSA = '43580'
315700           AND P-NEW-STATE = 43
315800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
315900               MOVE '   43' TO HOLD-PROV-IPPS-CBSA.
316000
316100        IF HOLD-PROV-IPPS-CBSA = '48540'
316200           AND P-NEW-STATE = 36
316300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
316400               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
316500
316600        IF HOLD-PROV-IPPS-CBSA = '48540'
316700           AND P-NEW-STATE = 51
316800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
316900               MOVE '   51' TO HOLD-PROV-IPPS-CBSA.
317000
317100        IF HOLD-PROV-IPPS-CBSA = '48864'
317200           AND P-NEW-STATE = 31
317300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317400               MOVE '   31' TO HOLD-PROV-IPPS-CBSA.
317500
317600        IF HOLD-PROV-IPPS-CBSA = '49660'
317700           AND P-NEW-STATE = 36
317800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
317900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
318000
318100        IF HOLD-PROV-IPPS-CBSA = '49660'
318200           AND P-NEW-STATE = 39
318300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318400               MOVE '   39' TO HOLD-PROV-IPPS-CBSA.
318500
318600        IF HOLD-PROV-IPPS-CBSA = '19060'
318700           AND P-NEW-STATE = 21
318800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
318900               MOVE '   21' TO HOLD-PROV-IPPS-CBSA.
319000
319100        IF HOLD-PROV-IPPS-CBSA = '22020'
319200           AND P-NEW-STATE = 24
319300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
319500
319600        IF HOLD-PROV-IPPS-CBSA = '22020'
319700           AND P-NEW-STATE = 35
319800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
319900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
320000
320100        IF HOLD-PROV-IPPS-CBSA = '24220'
320200           AND P-NEW-STATE = 24
320300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
320400               MOVE '   24' TO HOLD-PROV-IPPS-CBSA.
320500
320600        IF HOLD-PROV-IPPS-CBSA = '24220'
320700           AND P-NEW-STATE = 35
320800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
320900               MOVE '   35' TO HOLD-PROV-IPPS-CBSA.
321000
321100        IF HOLD-PROV-IPPS-CBSA = '30300'
321200           AND P-NEW-STATE = 50
321300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
321400               MOVE '   50' TO HOLD-PROV-IPPS-CBSA.
321500
321600        IF HOLD-PROV-IPPS-CBSA = '39300'
321700           AND P-NEW-STATE = 22
321800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
321900               MOVE '   22' TO HOLD-PROV-IPPS-CBSA.
322000
322100        IF HOLD-PROV-IPPS-CBSA = '39300'
322200           AND P-NEW-STATE = 41
322300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322400               MOVE '   41' TO HOLD-PROV-IPPS-CBSA.
322500
322600        IF HOLD-PROV-IPPS-CBSA = '44600'
322700           AND P-NEW-STATE = 36
322800               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
322900               MOVE '   36' TO HOLD-PROV-IPPS-CBSA.
323000
323100        IF HOLD-PROV-IPPS-CBSA = '45500'
323200           AND P-NEW-STATE = 45
323300               MOVE 'N' TO P-NEW-CBSA-SPEC-PAY-IND
323400               MOVE '   45' TO HOLD-PROV-IPPS-CBSA.
323500
323600 0580-FY2014-EXIT.
323700      EXIT.
323800
323900
324000******************************************************************
324100*                                                                *
324200* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
324300* ** LOGIC ADDED 08/06/2014 **                                   *
324400*                                                                *
324500******************************************************************
324600
324700 0580-FY2015-LATER-FLOOR-CBSA.
324800
324900*------------------------------------------------------------*
325000* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
325100* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
325200*------------------------------------------------------------*
325300     MOVE SPACES              TO H-PROV-BLANK-R.
325400     MOVE P-NEW-STATE         TO H-PROV-STATE-R.
325500
325600*------------------------------------------------------------*
325700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - TEXAS        *
325800*------------------------------------------------------------*
325900     IF H-PROV-STATE-R = '67' OR '74' MOVE '45' TO H-PROV-STATE-R.
326000
326100*------------------------------------------------------------*
326200* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - FLORIDA      *
326300*------------------------------------------------------------*
326400     IF H-PROV-STATE-R = '68' OR '69' MOVE '10' TO H-PROV-STATE-R.
326500
326600*------------------------------------------------------------*
326700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - KANSAS       *
326800*------------------------------------------------------------*
326900     IF H-PROV-STATE-R = '70' MOVE '17' TO H-PROV-STATE-R.
327000
327100*------------------------------------------------------------*
327200* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - LOUISIANA    *
327300*------------------------------------------------------------*
327400     IF H-PROV-STATE-R = '71' MOVE '19' TO H-PROV-STATE-R.
327500
327600*------------------------------------------------------------*
327700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - OHIO         *
327800*------------------------------------------------------------*
327900     IF H-PROV-STATE-R = '72' MOVE '36' TO H-PROV-STATE-R.
328000
328100*------------------------------------------------------------*
328200* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - PENNSYLVANIA *
328300*------------------------------------------------------------*
328400     IF H-PROV-STATE-R = '73' MOVE '39' TO H-PROV-STATE-R.
328500
328600*------------------------------------------------------------*
328700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - CALIFORNIA   *
328800*------------------------------------------------------------*
328900     IF H-PROV-STATE-R = '75' MOVE '05' TO H-PROV-STATE-R.
329000
329100*------------------------------------------------------------*
329200* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - IOWA         *
329300*------------------------------------------------------------*
329400     IF H-PROV-STATE-R = '76' MOVE '16' TO H-PROV-STATE-R.
329500
329600*------------------------------------------------------------*
329700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - MINNESOTA    *
329800*------------------------------------------------------------*
329900     IF H-PROV-STATE-R = '77' MOVE '24' TO H-PROV-STATE-R.
330000
330100*------------------------------------------------------------*
330200* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - ILLINOIS     *
330300*------------------------------------------------------------*
330400     IF H-PROV-STATE-R = '78' MOVE '14' TO H-PROV-STATE-R.
330500
330600*------------------------------------------------------------*
330700* CHANGE CBSA CODE TO THE ORIGINAL STATE CODE - MARYLAND     *
330800*------------------------------------------------------------*
330900     IF H-PROV-STATE-R = '80' MOVE '21' TO H-PROV-STATE-R.
331000
331100
331200*------------------------------------------------------------*
331300* SEARCH TABLE FOR RURAL IPPS CBSA & GET RURAL WAGE INDEX    *
331400*------------------------------------------------------------*
331500     SET MA1 TO 1.
331600     SEARCH T-CBSA-DATA VARYING MA1
331700        AT END
331800           MOVE SPACES TO W-CBSA-IPPS-RURAL
331900           MOVE ZEROS TO W-CBSA-IPPS-RUR-EFF-DATE
332000           MOVE ZEROS TO W-IPPS-WAGE-INDEX-RURAL
332100        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
332200           SET MA2 TO MA1
332300           PERFORM 0675-N-GET-IPPS-WAGE-INDX-RUR
332400              THRU 0675-N-RUR-EXIT VARYING MA2
332500              FROM MA1 BY 1 UNTIL
332600                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
332700
332800
332900*------------------------------------------------------------*
333000* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
333100* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
333200*------------------------------------------------------------*
333300     IF W-IPPS-WAGE-INDEX-RURAL > W-IPPS-WAGE-INDEX
333400        MOVE W-CBSA-IPPS-RURAL        TO W-CBSA-IPPS
333500        MOVE W-CBSA-IPPS-RUR-EFF-DATE TO W-CBSA-IPPS-EFF-DATE
333600        MOVE W-IPPS-WAGE-INDEX-RURAL  TO W-IPPS-WAGE-INDEX
333700     END-IF.
333800
333900 0580-FY2015-LATER-EXIT.
334000      EXIT.
334100
334200
334300******************************************************************
334400 0585-GET-IPPS-CBSA-SIZE.
334500******************************************************************
334600
334700     IF B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
334800        IF P-NEW-RURAL-CBSA
334900           MOVE 'R' TO W-CBSA-IPPS-SIZE
335000        ELSE
335100          IF T-CBSA-SIZE (MA2) = 'L'
335200             MOVE 'L' TO W-CBSA-IPPS-SIZE
335300          ELSE
335400             MOVE 'O' TO W-CBSA-IPPS-SIZE
335500          END-IF
335600        END-IF
335700     END-IF.
335800
335900 0585-EXIT.
336000      EXIT.
336100
336200
336300******************************************************************
336400 0590-GET-IPPS-CBSA-PR.
336500******************************************************************
336600
336700*--------------------------------------*
336800* SET PUERTO RICO CBSA INDICATOR       *
336900*--------------------------------------*
337000     MOVE '*' TO H-IPPS-CBSA-LAST-POS.
337100
337200*------------------------------------------------------------*
337300* SEARCH TABLE FOR PR CBSA & GET PR SPECIFIC WAGE INDEX      *
337400*------------------------------------------------------------*
337500     SET MA1 TO 1.
337600     SEARCH T-CBSA-DATA VARYING MA1
337700        AT END
337800           MOVE 60 TO PPS-RTC
337900        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA
338000           SET MA2 TO MA1
338100               PERFORM 0680-N-GET-IPPS-PR-WAGE-INDX
338200                  THRU 0680-N-EXIT VARYING MA2
338300                  FROM MA1 BY 1 UNTIL
338400                       T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA.
338500
338600
338700*------------------------------------------------------------*
338800* ASSIGN PR IPPS WAGE INDEX FLOOR FOR FY 2015 AND LATER      *
338900*------------------------------------------------------------*
339000     IF B-DISCHARGE-DATE > 20140930
339100        PERFORM 0590-FY2015-LATER-PR-FLOOR
339200           THRU 0590-FY2015-LATER-PR-EXIT
339300     END-IF.
339400
339500 0590-EXIT.
339600      EXIT.
339700
339800
339900******************************************************************
340000*                                                                *
340100* PUERTO RICO SPECIFIC WAGE INDEX:                               *
340200* IPPS WAGE INDEX FLOOR ASSIGNMENT LOGIC FOR FY 2015 AND LATER   *
340300* ** LOGIC ADDED 08/06/2014 **                                   *
340400*                                                                *
340500******************************************************************
340600
340700 0590-FY2015-LATER-PR-FLOOR.
340800
340900*------------------------------------------------------------*
341000* SET RURAL IPPS CBSA TO PROVIDER'S STATE CODE               *
341100* (HOLD-PROV-IPPS-CBSA-RURAL)                                *
341200*------------------------------------------------------------*
341300     MOVE SPACES              TO H-PROV-BLANK-R.
341400     MOVE P-NEW-STATE         TO H-PROV-STATE-R.
341500     MOVE '*'                 TO H-IPPS-CBSA-LAST-POS-R.
341600
341700
341800*------------------------------------------------------------*
341900* SEARCH TABLE FOR RURAL PR IPPS CBSA & GET WAGE INDEX       *
342000*------------------------------------------------------------*
342100     SET MA1 TO 1.
342200     SEARCH T-CBSA-DATA VARYING MA1
342300        AT END
342400           MOVE ZEROS TO W-IPPS-PR-WAGE-INDEX-RUR
342500        WHEN T-CBSA (MA1) = HOLD-PROV-IPPS-CBSA-RURAL
342600           SET MA2 TO MA1
342700           PERFORM 0680-N-GET-IPPS-PR-WAGE-IDX-RU
342800              THRU 0680-N-RU-EXIT VARYING MA2
342900              FROM MA1 BY 1 UNTIL
343000                   T-CBSA (MA2) NOT = HOLD-PROV-IPPS-CBSA-RURAL.
343100
343200
343300*------------------------------------------------------------*
343400* REPLACE CBSA WAGE INDEX & CBSA WITH RURAL FLOOR WAGE INDEX *
343500* & CBSA IF RURAL FLOOR WAGE INDEX IS HIGHER                 *
343600*------------------------------------------------------------*
343700     IF W-IPPS-PR-WAGE-INDEX-RUR > W-IPPS-PR-WAGE-INDEX
343800        MOVE W-IPPS-PR-WAGE-INDEX-RUR TO W-IPPS-PR-WAGE-INDEX
343900     END-IF.
344000
344100
344200 0590-FY2015-LATER-PR-EXIT.
344300      EXIT.
344400
344500
344600******************************************************************
344700 0600-N-GET-WAGE-INDX.
344800******************************************************************
344900
345000     IF  B-DISCHARGE-DATE NOT < MSAX-EFF-DATE (MU2)
345100         MOVE MSAX-MSA (MU2)         TO W-NEW-MSA
345200         MOVE MSAX-EFF-DATE (MU2)    TO W-NEW-EFF-DATE-M
345300         MOVE MSAX-WAGE-INDEX1 (MU2) TO W-NEW-INDEX1-RECORD-M
345400         MOVE MSAX-WAGE-INDEX2 (MU2) TO W-NEW-INDEX2-RECORD-M
345500         MOVE MSAX-WAGE-INDEX3 (MU2) TO W-NEW-INDEX3-RECORD-M
345600     END-IF.
345700
345800 0600-N-EXIT.
345900     EXIT.
346000
346100
346200******************************************************************
346300 0650-N-GET-WAGE-INDX.
346400******************************************************************
346500
346600*----------------------------------------------------------------*
346700* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
346800* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
346900*    OR BEFORE THE CLAIM DISCHARGE DATE, OR                      *
347000* 2) A CBSA WITH AN EFFECTIVE DATE ON OR BEFORE THE CLAIM
347100*    DISCHARGE DATE AND A CLAIM DISCHARGE DATE ON OR BEFORE
347200*    09/30/2009 OR
347300* 3) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
347400*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
347500*----------------------------------------------------------------*
347600     IF  B-DISCHARGE-DATE NOT < CBSAX-EFF-DATE (CU2)
347700
347800         IF (HOLD-PROV-CBSA = '   98' OR
347900             HOLD-PROV-CBSA = '   99') OR
348000
348100*THE FOLLOWING LINE ADDED WITH VERSION 15.2 TO FIX A PROBLEM
348200*FOUND BY FISS THAT CAUSED AN UNEXPECTED WAGE INDEX ERROR CODE
348300*TO BE REPORTED
348400
348500            (B-DISCHARGE-DATE <= 20090930) OR
348600
348700            (CBSAX-EFF-DATE (CU2)  >= W-FY-BEGIN-DATE AND
348800             CBSAX-EFF-DATE (CU2)  <= W-FY-END-DATE)
348900
349000             MOVE CBSAX-CBSA (CU2)        TO W-NEW-CBSA
349100             MOVE CBSAX-EFF-DATE (CU2)    TO W-NEW-EFF-DATE-C
349200             MOVE CBSAX-WAGE-INDEX1 (CU2) TO W-NEW-INDEX1-RECORD-C
349300             MOVE CBSAX-WAGE-INDEX2 (CU2) TO W-NEW-INDEX2-RECORD-C
349400             MOVE CBSAX-WAGE-INDEX3 (CU2) TO W-NEW-INDEX3-RECORD-C
349500         END-IF
349600     END-IF.
349700
349800 0650-N-EXIT.
349900     EXIT.
350000
350100
350200******************************************************************
350300 0675-N-GET-IPPS-WAGE-INDX.
350400******************************************************************
350500
350600*----------------------------------------------------------------*
350700* TO SELECT THE WAGE INDEX, IT MUST BE EITHER:                   *
350800* 1) AN INDIAN HEALTH CBSA (98 OR 99) WITH AN EFFECTIVE DATE ON  *
350900*    OR BEFORE THE CLAIM DISCHARGE DATE, -OR-                    *
351000* 2) A NON-INDIAN HEATLH CBSA WITH AN EFFECTIVE DATE ON OR BEFORE*
351100*    THE CLAIM DISHARGE DATE AND WITHIN THE CLAIM'S FISCAL YEAR  *
351200*----------------------------------------------------------------*
351300     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2)
351400
351500         IF (HOLD-PROV-IPPS-CBSA = '   98' OR
351600             HOLD-PROV-IPPS-CBSA = '   99') OR
351700
351800            (T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
351900             T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE)
352000
352100         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS
352200         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-EFF-DATE
352300         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX
352400     END-IF.
352500
352600 0675-N-EXIT.
352700     EXIT.
352800
352900
353000******************************************************************
353100 0675-N-GET-IPPS-WAGE-INDX-RUR.
353200******************************************************************
353300
353400*----------------------------------------------------------------*
353500* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
353600* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
353700* YEAR.                                                          *
353800*----------------------------------------------------------------*
353900     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
354000         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
354100         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
354200         MOVE T-CBSA (MA2)            TO W-CBSA-IPPS-RURAL
354300         MOVE T-CBSA-EFF-DATE (MA2)   TO W-CBSA-IPPS-RUR-EFF-DATE
354400         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-WAGE-INDEX-RURAL
354500     END-IF.
354600
354700 0675-N-RUR-EXIT.
354800     EXIT.
354900
355000
355100******************************************************************
355200 0680-N-GET-IPPS-PR-WAGE-INDX.
355300******************************************************************
355400
355500*----------------------------------------------------------------*
355600* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
355700* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
355800* YEAR.                                                          *
355900*----------------------------------------------------------------*
356000     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
356100         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
356200         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
356300         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX
356400     END-IF.
356500
356600 0680-N-EXIT.
356700     EXIT.
356800
356900
357000******************************************************************
357100 0680-N-GET-IPPS-PR-WAGE-IDX-RU.
357200******************************************************************
357300
357400*----------------------------------------------------------------*
357500* TO SELECT THE WAGE INDEX, ITS EFFECTIVE DATE MUST BE ON OR     *
357600* BEFORE THE CLAIM DISCHARGE DATE AND WITHIN THE CLAIM'S FISCAL  *
357700* YEAR.                                                          *
357800*----------------------------------------------------------------*
357900     IF  B-DISCHARGE-DATE NOT < T-CBSA-EFF-DATE (MA2) AND
358000         T-CBSA-EFF-DATE (MA2) >= W-FY-BEGIN-DATE AND
358100         T-CBSA-EFF-DATE (MA2) <= W-FY-END-DATE
358200         MOVE T-CBSA-WAGE-INDX1 (MA2) TO W-IPPS-PR-WAGE-INDEX-RUR
358300     END-IF.
358400
358500 0680-N-RU-EXIT.
358600     EXIT.
358700
358800******************************************************************
358900********************   END OF PROGRAM   **************************
359000******************************************************************
