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