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