000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.         LTMGR152.
000300*AUTHOR.             CMS
000400 DATE-COMPILED.
000500 ENVIRONMENT DIVISION.
000600 CONFIGURATION SECTION.
000700 SOURCE-COMPUTER.                IBM-370.
000800 OBJECT-COMPUTER.                IBM-370.
000900
001000******************************************************
001100*                                                    *
001200* THIS PROGRAM RUNS THE LONG-TERM CARE PPS PRICER    *
001300* MODULES FOR TESTING PURPOSES.                      *
001400*                                                    *
001500*----------------------------------------------------*
001600* CHANGE LOG                                         *
001700*----------------------------------------------------*
001800*                                                    *
001900* 04/22/2005 - PPS-CBSA ADDED TO ACCOMODATE THE      *
002000*              JULY 1, 2005 CHANGE FROM MSA TO CBSA  *
002100*              BASED WAGE INDICES                    *
002200*                                                    *
002300*----------------------------------------------------*
002400*                                                    *
002500* 05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY IND &  *
002600*              SPECIAL WAGE INDEX                    *
002700*                                                    *
002800*----------------------------------------------------*
002900*                                                    *
003000* 09/28/2005 - PROGRAM NAME CHANGED FROM LTDRIVER TO *
003100*              LTMGR___                              *
003200*                                                    *
003300*----------------------------------------------------*
003400*                                                    *
003500* 01/17/2006 - PROGRAM PREPARED FOR APRIL 2006       *
003600*              CICS RELEASE                          *
003700*                                                    *
003800*----------------------------------------------------*
003900*                                                    *
004000* 01/19/2006 - CALLED PROGRAM CHANGED TO LTOPN___    *
004100*                                                    *
004200*----------------------------------------------------*
004300*                                                    *
004400* 05/03/2006 - ADDED IPPS-CBSAX RECORD TO OPTION 4   *
004500*              OF LTOPN___ CALL                      *
004600*                                                    *
004700*----------------------------------------------------*
004800*                                                    *
004900* 06/19/2006 - VERSION CHANGED FROM 07.0 TO 07.1     *
005000*                                                    *
005100*                                                    *
005200*----------------------------------------------------*
005300*                                                    *
005400* 08/09/2006 - UPDATED FOR OCTOBER 2006 VERSION 07.3 *
005500*                                                    *
005600*                                                    *
005700*----------------------------------------------------*
005800*                                                    *
005900* 09/06/2006 - UPDATED FOR OCTOBER 2006 VERSION 07.4 *
006000*                                                    *
006100*----------------------------------------------------*
006200*                                                    *
006300* 11/16/2006 - CREATED VERSION 07.5 FOR OCTOBER 2006 *
006400*              DUE TO CORRECTION OF THE IME          *
006500*              MULTIPLIER USED IN THE 4TH SSO        *
006600*              PROVISION (IPPS PORTION), IPPS WAGE   *
006700*              INDEX CHANGE & REMOVAL OF PPS-RTC 23  *
006800*                                                    *
006900*----------------------------------------------------*
007000*                                                    *
007100* 12/28/2006 - CREATED VERSION 07.6 FOR OCTOBER 2006 *
007200*              DUE TO CBSA SIZE LOGIC CORRECTION     *
007300*              ** THIS VERSION WAS NOT RELEASED **   *
007400*                                                    *
007500*----------------------------------------------------*
007600*                                                    *
007700* 05/03/2007 - UPDATED FOR JULY 2007 VERSION 08.0    *
007800*                                                    *
007900*----------------------------------------------------*
008000*                                                    *
008100* 08/13/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.1 *
008200*                                                    *
008300*----------------------------------------------------*
008400*                                                    *
008500* 08/23/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.2 *
008600*              (FOR REVISED IPPS RATES & WAGE INDEX) *
008700*                                                    *
008800*----------------------------------------------------*
008900*                                                    *
009000* 09/14/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.3 *
009100*              (FOR REVISED IPPS RATES & WAGE INDEX) *
009200*                                                    *
009300*----------------------------------------------------*
009400*                                                    *
009500* 09/28/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.4 *
009600*              (FOR REVISED IPPS RATES)              *
009700*                                                    *
009800*----------------------------------------------------*
009900*                                                    *
010000* 12/27/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.5 *
010100*              (FOR REVISED SHORT STAY OUTLIER LOGIC)*
010200*                                                    *
010300*----------------------------------------------------*
010400*                                                    *
010500* 02/06/2008 - UPDATE FOR OCTOBER 2007 VERSION 08.6  *
010600*              (FOR REVISED STANDARD FEDERAL RATE &  *
010700*               FIXED LOSS AMOUNT FOR APRIL 2008)    *
010800*                                                    *
010900*----------------------------------------------------*
011000*                                                    *
011100* 05/08/2008 - CREATED VERSION 09.0 FOR JULY 2008    *
011200*              (FOR NEW RATE YEAR 2009, STILL FY2008)*
011300*                                                    *
011400*----------------------------------------------------*
011500*                                                    *
011600* 05/19/2008 - CREATED VERSION 09.1 FOR JULY 2008    *
011700*              REVISED IPPS PUERTO RICO RATES        *
011800*              EFFECTIVE RETROACTIVE TO 10/01/2007   *
011900*                                                    *
012000*----------------------------------------------------*
012100*                                                    *
012200* 08/11/2008 - CREATED VERSION 09.2 FOR OCTOBER 2008 *
012300*              (FOR RATE YEAR 2009, FY 2009)         *
012400*              ADDED FIELD P-VAL-BASED-PURCH-SCORE   *
012500*              TO THE PSF (TO BE USED IN IPPS 1/1/08)*
012600*                                                    *
012700*----------------------------------------------------*
012800*                                                    *
012900* 09/09/2008 - CREATED VERSION 09.3 FOR OCTOBER 2008 *
013000*              (FOR RATE YEAR 2009, FY 2009)         *
013100*                                                    *
013200*----------------------------------------------------*
013300*                                                    *
013400* 02/17/2009 - CREATED VERSION 09.4 FOR OCTOBER 2008 *
013500*              (FOR RATE YEAR 2009, FY 2009)         *
013600*                                                    *
013700*----------------------------------------------------*
013800*                                                    *
013900* 05/18/2009 - CREATED VERSION 09.5 FOR JUN-SEPT '09 *
014000*              (FOR RATE YEAR 2009, FY 2009)         *
014100*                                                    *
014200*----------------------------------------------------*
014300*                                                    *
014400* 08/05/2009 - CREATED VERSION 10.0 FOR OCTOBER 2009 *
014500*              (FOR RATE YEAR 2010, FY 2010)         *
014600*                                                    *
014700*----------------------------------------------------*
014800*                                                    *
014900* 09/03/2009 - CREATED VERSION 10.1 FOR OCTOBER 2009 *
015000*              (FOR RATE YEAR 2010, FY 2010)         *
015100*                                                    *
015200*----------------------------------------------------*
015300*                                                    *
015400* 11/11/2009 - CREATED VERSION 10.2 FOR OCTOBER 2009 *
015500*              (FOR RATE YEAR 2010, FY 2010)         *
015600*                                                    *
015700*----------------------------------------------------*
015800*                                                    *
015900* 04/07/2010 - CREATED VERSION 10.3 FOR OCTOBER 2009 *
016000*              (FOR RATE YEAR 2010, FY 2010)         *
016100*                                                    *
016200*----------------------------------------------------*
016300*                                                    *
016400* 04/19/2010 - CREATED VERSION 10.4 FOR OCTOBER 2009 *
016500*              (FOR RATE YEAR 2010, FY 2010)         *
016600*                                                    *
016700*----------------------------------------------------*
016800*                                                    *
016900* 08/04/2010 - CREATED VERSION 11.0 FOR OCTOBER 2010 *
017000*              (FOR RATE YEAR 2011, FY 2011)         *
017100*                                                    *
017200*----------------------------------------------------*
017300*                                                    *
017400* 10/20/2010 - CREATED VERSION 11.1 FOR OCTOBER 2010 *
017500*              ALLOWS CLAIMS WITH DATES OF SERVICE   *
017600*              OLDER THAN 5 YEARS                    *
017700*                                                    *
017800*----------------------------------------------------*
017900*                                                    *
018000* 08/01/2011 - CREATED VERSION 12.0 FOR OCTOBER 2011 *
018100*              (FOR RATE YEAR 2012, FY 2012)         *
018200*                                                    *
018300*----------------------------------------------------*
018400*                                                    *
018500* 08/31/2011 - CREATED VERSION 12.1 FOR OCTOBER 2011 *
018600*              (FOR RATE YEAR 2012, FY 2012)         *
018700*                                                    *
018800*----------------------------------------------------*
018900*                                                    *
019000* 10/28/2011 - CREATED VERSION 12.2 FOR OCTOBER 2011 *
019100*              (FOR RATE YEAR 2012, FY 2012)         *
019200*                                                    *
019300*----------------------------------------------------*
019400*                                                    *
019500* 12/09/2011 - CREATED VERSION 12.3 FOR OCTOBER 2011 *
019600*              (FOR RATE YEAR 2012, FY 2012)         *
019700*                                                    *
019800*----------------------------------------------------*
019900*                                                    *
020000* 07/31/2012 - CREATED VERSION 13.0 FOR OCTOBER 2012 *
020100*              (FOR RATE YEAR 2013, FY 2013)         *
020200*                                                    *
020300*----------------------------------------------------*
020400*                                                    *
020500* 08/09/2013 - CREATED VERSION 14.0 FOR OCTOBER 2013 *
020600*              (FOR RATE YEAR 2014, FY 2014)         *
020700*            - ADDED HOSPITAL QUALITY INDICATOR TO   *
020800*              TO PSF                                *
020900*                                                    *
021000*----------------------------------------------------*
021100*                                                    *
021200* 09/04/2013 - CREATED VERSION 14.1 TO INCORPORATE   *
021300*              CHANGES TO WAGE INDEX TABLES FOR      *
021400*              LTCH AND IPPS                         *
021500*                                                    *
021600*                                                    *
021700*----------------------------------------------------*
021800*                                                    *
021900* 08/07/2014 - CREATED VERSION 15.0                  *
022000*                                                    *
022100*----------------------------------------------------*
022200*                                                    *
022300* 09/03/2014 - CREATED VERSION 15.1                  *
022400*                                                    *
022500******************************************************
022600
022700 INPUT-OUTPUT SECTION.
022800 FILE-CONTROL.
022900
023000     SELECT BILLFILE   ASSIGN TO UT-S-SYSUT1
023100         FILE STATUS IS UT1-STAT.
023200     SELECT PRTOPER    ASSIGN TO UT-S-PRTOPER
023300         FILE STATUS IS OPR-STAT.
023400
023500 DATA DIVISION.
023600 FILE SECTION.
023700 FD  BILLFILE
023800     LABEL RECORDS ARE STANDARD
023900     RECORDING MODE IS F
024000     BLOCK CONTAINS 0 RECORDS.
024100 01  BILL-REC                    PIC X(60).
024200
024300 FD  PRTOPER
024400     RECORDING MODE IS F
024500     BLOCK CONTAINS 133 RECORDS
024600     LABEL RECORDS ARE STANDARD.
024700 01  PRTOPER-LINE                PIC X(133).
024800
024900 WORKING-STORAGE SECTION.
025000 77  W-STORAGE-REF               PIC X(51)  VALUE
025100     'L T C M A N A G E R - W O R K I N G   S T O R A G E'.
025200 01  PPMGR-VERSION               PIC X(05)  VALUE 'M15.2'.
025300 01  LTOPN152                    PIC X(08)  VALUE 'LTOPN152'.
025400 01  EOF-SW                      PIC 9(01)  VALUE 0.
025500 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.
025600 01  UT1-STAT.
025700     05  UT1-STAT1               PIC X.
025800     05  UT1-STAT2               PIC X.
025900 01  OPR-STAT.
026000     05  OPR-STAT1               PIC X.
026100     05  OPR-STAT2               PIC X.
026200*******************************************************
026300*******************************************************
026400*    MILLENNIUM BILL RECORD FORMAT                    *
026500*******************************************************
026600 01  BILL-WORK.
026700     05  BILL-NPI10.
026800         10  BILL-NPI8                 PIC X(08).
026900         10  BILL-NPI-FILLER           PIC X(02).
027000     05  BILL-PROVIDER-N.
027100         10  FILLER                    PIC X(02).
027200         10  BILL-LTC-PROV             PIC X(04).
027300     05  BILL-PATIENT-STATUS           PIC X(02).
027400     05  BILL-DRG-CODE                 PIC X(03).
027500     05  BILL-LOS                      PIC 9(03).
027600     05  BILL-COV-DAYS                 PIC 9(03).
027700     05  BILL-LTR-DAYS                 PIC 9(02).
027800     05  BILL-DISCHARGE-DATE.
027900         10  BILL-DISCHG-CC            PIC 9(02).
028000         10  BILL-DISCHG-YY            PIC 9(02).
028100         10  BILL-DISCHG-MM            PIC 9(02).
028200         10  BILL-DISCHG-DD            PIC 9(02).
028300     05  BILL-COV-CHARGES              PIC 9(07)V9(02).
028400     05  BILL-SPEC-PAY-IND             PIC X(01).
028500     05  FILLER                        PIC X(13).
028600
028700*******************************************************
028800*    RETURNED BY LTOPN___                             *
028900*******************************************************
029000  01  PPS-DATA-ALL.
029100      05  PPS-RTC                      PIC 9(02).
029200      05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
029300      05  PPS-DATA.
029400         10  PPS-MSA                   PIC X(04).
029500         10  PPS-WAGE-INDEX            PIC 9(02)V9(04).
029600         10  PPS-AVG-LOS               PIC 9(02)V9(01).
029700         10  PPS-RELATIVE-WGT          PIC 9(01)V9(04).
029800         10  PPS-OUTLIER-PAY-AMT       PIC 9(07)V9(02).
029900         10  PPS-LOS                   PIC 9(03).
030000         10  PPS-DRG-ADJ-PAY-AMT       PIC 9(07)V9(02).
030100         10  PPS-FED-PAY-AMT           PIC 9(07)V9(02).
030200         10  PPS-FINAL-PAY-AMT         PIC 9(07)V9(02).
030300         10  PPS-FAC-COSTS             PIC 9(07)V9(02).
030400         10  PPS-NEW-FAC-SPEC-RATE     PIC 9(07)V9(02).
030500         10  PPS-OUTLIER-THRESHOLD     PIC 9(07)V9(02).
030600         10  PPS-SUBM-DRG-CODE         PIC X(03).
030700         10  PPS-CALC-VERS-CD          PIC X(05).
030800         10  PPS-REG-DAYS-USED         PIC 9(03).
030900         10  PPS-LTR-DAYS-USED         PIC 9(03).
031000         10  PPS-BLEND-YEAR            PIC 9(01).
031100         10  PPS-COLA                  PIC 9(01)V9(03).
031200         10  FILLER                    PIC X(04).
031300      05  PPS-OTHER-DATA.
031400         10  PPS-NAT-LABOR-PCT         PIC 9(01)V9(05).
031500         10  PPS-NAT-NONLABOR-PCT      PIC 9(01)V9(05).
031600         10  PPS-STD-FED-RATE          PIC 9(05)V9(02).
031700         10  PPS-BDGT-NEUT-RATE        PIC 9(01)V9(03).
031800         10  FILLER                    PIC X(20).
031900      05  PPS-PC-DATA.
032000         10  PPS-COT-IND               PIC X(01).
032100         10  FILLER                    PIC X(20).
032200
032300  01  PPS-CBSA                         PIC X(05).
032400
032500*******************************************************
032600*    PASSED TO LTOPN___     MILLENNIUM                *
032700*******************************************************
032800 01  BILL-NEW-DATA.
032900     05  B-NPI10.
033000         10  B-NPI8                    PIC X(08).
033100         10  B-NPI-FILLER              PIC X(02).
033200     05  B-PROVIDER-NO.
033300         10  FILLER                    PIC X(02).
033400         10  B-LTC-PROV                PIC X(04).
033500     05  B-PATIENT-STATUS              PIC X(02).
033600     05  B-DRG-CODE                    PIC X(03).
033700     05  B-LOS                         PIC 9(03).
033800     05  B-COV-DAYS                    PIC 9(03).
033900     05  B-LTR-DAYS                    PIC 9(02).
034000     05  B-DISCHARGE-DATE.
034100         10  B-DISCHG-CC               PIC 9(02).
034200         10  B-DISCHG-YY               PIC 9(02).
034300         10  B-DISCHG-MM               PIC 9(02).
034400         10  B-DISCHG-DD               PIC 9(02).
034500     05  B-COV-CHARGES                 PIC 9(07)V9(02).
034600     05  B-SPEC-PAY-IND                PIC X(01).
034700     05  FILLER                        PIC X(13).
034800
034900*******************************************************
035000*    PASSED TO LTOPN___                               *
035100*******************************************************
035200 01  PRICER-OPT-VERS-SW.
035300     02  PRICER-OPTION-SW        PIC X.
035400     02  PPS-VERSIONS.
035500         10  PPDRV-VERSION       PIC X(05).
035600
035700*******************************************************
035800*    CAN BE PASSED TO LTOPN___                        *
035900*******************************************************
036000 01  PROV-RECORD-FROM-USER.
036100    02  W-PROV-NEWREC-HOLD1.
036200        05  W-P-NEW-NPI10.
036300            10  W-P-NEW-NPI8           PIC X(08).
036400            10  W-P-NEW-NPI-FILLER     PIC X(02).
036500        05  W-P-NEW-PROVIDER-OSCAR-NO.
036600            10  W-P-NEW-STATE            PIC X(02).
036700            10  FILLER                 PIC X(04).
036800        05  W-P-NEW-DATE-DATA.
036900            10  W-P-NEW-EFF-DATE.
037000                15  W-P-NEW-EFF-DT-CC    PIC 9(02).
037100                15  W-P-NEW-EFF-DT-YY    PIC 9(02).
037200                15  W-P-NEW-EFF-DT-MM    PIC 9(02).
037300                15  W-P-NEW-EFF-DT-DD    PIC 9(02).
037400            10  W-P-NEW-FY-BEGIN-DATE.
037500                15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
037600                15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
037700                15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
037800                15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
037900            10  W-P-NEW-REPORT-DATE.
038000                15  W-P-NEW-REPORT-DT-CC PIC 9(02).
038100                15  W-P-NEW-REPORT-DT-YY PIC 9(02).
038200                15  W-P-NEW-REPORT-DT-MM PIC 9(02).
038300                15  W-P-NEW-REPORT-DT-DD PIC 9(02).
038400            10  W-P-NEW-TERMINATION-DATE.
038500                15  W-P-NEW-TERM-DT-CC   PIC 9(02).
038600                15  W-P-NEW-TERM-DT-YY   PIC 9(02).
038700                15  W-P-NEW-TERM-DT-MM   PIC 9(02).
038800                15  W-P-NEW-TERM-DT-DD   PIC 9(02).
038900        05  W-P-NEW-WAIVER-CODE          PIC X(01).
039000            88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
039100        05  W-P-NEW-INTER-NO             PIC X(05).
039200        05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
039300        05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
039400        05  W-P-NEW-MSA-DATA.
039500            10  W-P-NEW-CHG-CODE-INDEX    PIC X.
039600            10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
039700            10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
039800            10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
039900            10  W-P-NEW-STAND-AMT-LOC-MSA9
040000                REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
040100                15  W-P-NEW-RURAL-1ST.
040200                    20  W-P-NEW-STAND-RURAL  PIC XX.
040300                15  W-P-NEW-RURAL-2ND        PIC XX.
040400        05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
040500        05  W-P-NEW-LUGAR               PIC X.
040600        05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
040700        05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
040800        05  FILLER                      PIC X(05).
040900     02  W-PROV-NEWREC-HOLD2.
041000        05  W-P-NEW-VARIABLES.
041100            10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
041200            10  W-P-NEW-COLA              PIC  X(04).
041300            10  W-P-NEW-INTERN-RATIO      PIC  X(05).
041400            10  W-P-NEW-BED-SIZE          PIC  X(05).
041500            10  W-P-NEW-CCR               PIC  X(04).
041600            10  W-P-NEW-CMI               PIC  X(05).
041700            10  W-P-NEW-SSI-RATIO         PIC  X(04).
041800            10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
041900            10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
042000            10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
042100            10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
042200            10  W-P-NEW-FYE-DATE.
042300                15  W-P-NEW-FYE-CC        PIC 99.
042400                15  W-P-NEW-FYE-YY        PIC 99.
042500                15  W-P-NEW-FYE-MM        PIC 99.
042600                15  W-P-NEW-FYE-DD        PIC 99.
042700        05  W-P-NEW-SPECIAL-PAY-IND       PIC X(01).
042800        05  W-P-NEW-HOSP-QUAL-IND         PIC X(01).
042900        05  W-P-NEW-GEO-LOC-CBSAX         PIC X(05).
043000        05  W-P-NEW-GEO-LOC-CBSA9 REDEFINES
043100                        W-P-NEW-GEO-LOC-CBSAX PIC 9(05).
043200        05  W-P-NEW-GEO-LOC-CBSA-AST REDEFINES
043300                        W-P-NEW-GEO-LOC-CBSA9.
043400            10 W-P-NEW-GEO-LOC-CBSA-1ST   PIC X.
043500            10 W-P-NEW-GEO-LOC-CBSA-2ND   PIC X.
043600            10 W-P-NEW-GEO-LOC-CBSA-3RD   PIC X.
043700            10 W-P-NEW-GEO-LOC-CBSA-4TH   PIC X.
043800            10 W-P-NEW-GEO-LOC-CBSA-5TH   PIC X.
043900        05  FILLER                        PIC X(10).
044000        05  W-P-NEW-SPECIAL-WAGE-INDEX    PIC 9(02)V9(04).
044100    02  W-PROV-NEWREC-HOLD3.
044200        05  W-P-NEW-PASS-AMT-DATA.
044300            10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
044400            10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
044500            10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
044600            10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
044700        05  W-P-NEW-CAPI-DATA.
044800            15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
044900            15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
045000            15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
045100            15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
045200            15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
045300            15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
045400            15  W-P-NEW-CAPI-IME            PIC X(05).
045500            15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
045600            15  W-P-VAL-BASED-PURCH-SCORE   PIC X(4).
045700        05  FILLER                          PIC X(18).
045800
045900*******************************************************
046000*    CAN BE PASSED TO LTOPN___  - CBSA WAGE INDEX TBL *
046100*******************************************************
046200 01  CBSAX-TABLE-FROM-USER.
046300     05  FILLER                  PIC X(32000).
046400     05  FILLER                  PIC X(30000).
046500     05  FILLER                  PIC X(30000).
046600
046700*******************************************************
046800*    CAN BE PASSED TO LTOPN___ - IPPS CBSA WI TABLE   *
046900*******************************************************
047000 01  IPPS-CBSAX-TABLE-FROM-USER.
047100     05  FILLER                  PIC X(32000).
047200     05  FILLER                  PIC X(30000).
047300     05  FILLER                  PIC X(30000).
047400
047500*******************************************************
047600*    CAN BE PASSED TO LTOPN___ - MSA WAGE INDEX TBL   *
047700*******************************************************
047800 01  MSAX-TABLE-FROM-USER.
047900     05  FILLER                  PIC X(32000).
048000     05  FILLER                  PIC X(30000).
048100     05  FILLER                  PIC X(30000).
048200
048300*******************************************************
048400*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *
048500*******************************************************
048600 01  PPS-DETAIL-LINE-OPER.
048700     05  FILLER                  PIC X(01)  VALUE SPACES.
048800     05  PRT-PROV                PIC X(06).
048900     05  FILLER                  PIC X(02)  VALUE SPACES.
049000     05  PRT-DRG-ADJ-PAY         PIC Z,ZZZ,ZZZ.99.
049100     05  FILLER                  PIC X(03)  VALUE SPACES.
049200     05  PRT-OUTLIER-PAY         PIC Z,ZZZ,ZZZ.99.
049300     05  FILLER                  PIC X(01)  VALUE SPACES.
049400     05  PRT-FAC-SPEC-RATE       PIC Z,ZZZ,ZZZ.99.
049500     05  FILLER                  PIC X(02)  VALUE SPACES.
049600     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.
049700     05  FILLER                  PIC X(02)  VALUE SPACES.
049800     05  PRT-OUT-THRESH          PIC Z,ZZZ,ZZZ.99.
049900     05  FILLER                  PIC X(02)  VALUE SPACES.
050000     05  PRT-FAC-COST            PIC Z,ZZZ,ZZZ.99.
050100     05  FILLER                  PIC X(02)  VALUE SPACES.
050200     05  PRT-LOS                 PIC ZZ9.
050300     05  FILLER                  PIC X(02)  VALUE SPACES.
050400     05  PRT-REG-DAYS-USED       PIC 9(03).
050500     05  FILLER                  PIC X(02)  VALUE SPACES.
050600     05  PRT-LTR-DAYS-USED       PIC 9(03).
050700     05  FILLER                  PIC X(02)  VALUE SPACES.
050800     05  PRT-ALOS                PIC ZZ.9.
050900     05  FILLER                  PIC X(03)  VALUE SPACES.
051000     05  PRT-PPS-RTC             PIC 99.
051100     05  FILLER                  PIC X(02)  VALUE SPACES.
051200     05  PRT-REL-WT              PIC 9.9999.
051300     05  FILLER                  PIC X(02)  VALUE SPACES.
051400     05  PRT-WAGE-INDEX          PIC 9.9999.
051500
051600 01  PPS-HEAD2-OPER.
051700     05  FILLER                  PIC X(01)  VALUE SPACES.
051800     05  FILLER                  PIC X(44)  VALUE
051900        '  CMS  LTCH PRICER            P R O S P E C '.
052000     05  FILLER                  PIC X(44)  VALUE
052100        'T I V E   P A Y M E N T   T E S T   D A T A '.
052200     05  FILLER                  PIC X(44)  VALUE
052300        '  R E P O R T                               '.
052400
052500 01  PPS-HEAD3-OPER.
052600     05  FILLER                  PIC X(01)  VALUE SPACES.
052700     05  FILLER                  PIC X(42)  VALUE
052800        'PROV          DRG         OUTLIER       FA'.
052900     05  FILLER                  PIC X(47)  VALUE
053000        'C           FINAL        OUTLIER         FAC   '.
053100     05  FILLER                  PIC X(43)  VALUE
053200        '   BILL REG  LTR  AVG   PPS  REL     WAGE'.
053300
053400 01  PPS-HEAD4-OPER.
053500     05  FILLER                  PIC X(01)  VALUE SPACES.
053600     05  FILLER                  PIC X(42)  VALUE
053700        ' NO        ADJ PAY        PAY AMT    SPEC '.
053800     05  FILLER                  PIC X(47)  VALUE
053900        'RATE       PAY AMT      THRESHOLD       COST   '.
054000     05  FILLER                  PIC X(43)  VALUE
054100        '   LOS  USED USED LOS   RTC  WGT     INDEX'.
054200
054300
054400******************************************************************
054500******************************************************************
054600
054700 PROCEDURE  DIVISION.
054800
054900 0000-MAINLINE  SECTION.
055000     OPEN INPUT  BILLFILE.
055100
055200     OPEN OUTPUT PRTOPER.
055300
055400     MOVE ALL '0'     TO PPS-VERSIONS.
055500
055600     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.
055700
055800     CLOSE BILLFILE.
055900
056000     CLOSE PRTOPER.
056100     STOP RUN.
056200
056300 0100-PROCESS-RECORDS.
056400     READ BILLFILE INTO BILL-WORK
056500         AT END
056600             MOVE 1 TO EOF-SW.
056700
056800     MOVE BILL-WORK TO BILL-NEW-DATA.
056900     IF  EOF-SW = 0
057000         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT
057100         PERFORM 1100-WRITE-SYSUT2 THRU 1100-EXIT.
057200
057300 0100-EXIT.  EXIT.
057400
057500
057600 1000-CALC-PAYMENT.
057700***************************************************************
057800*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE              *
057900*    PAYMENT                                                  *
058000***************************************************************
058100***************************************************************
058200* OPTION (1)                                                  *
058300*       (1)  MOVE ' ' TO PRICER-OPTION-SW.                    *
058400*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
058500*                                  PPS-DATA-ALL               *
058600*                                  PPS-CBSA                   *
058700*                                  PRICER-OPT-VERS-SW.        *
058800*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *
058900*                        *  *  *  *                           *
059000* OPTION (2)                                                  *
059100*       (2)  MOVE 'P' TO PRICER-OPTION-SW.                    *
059200*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
059300*                                  PPS-DATA-ALL               *
059400*                                  PPS-CBSA                   *
059500*                                  PRICER-OPT-VERS-SW         *
059600*                                  PROV-RECORD-FROM-USER.     *
059700*        THIS PASSES THE STANDARD VARIABLES AND               *
059800*        THE PROVIDER RECORD FROM THE USER                    *
059900*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *
060000*                        *  *  *  *                           *
060100* OPTION (3)                                                  *
060200*       (3)  MOVE 'A' TO PRICER-OPTION-SW.                    *
060300*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
060400*                                  PPS-DATA-ALL               *
060500*                                  PPS-CBSA                   *
060600*                                  PRICER-OPT-VERS-SW         *
060700*                                  PROV-RECORD-FROM-USER      *
060800*                                  CBSAX-TABLE-FROM-USER      *
060900*                                  IPPS-CBSAX-TABLE-FROM-USER *
061000*                                  MSAX-TABLE-FROM-USER.      *
061100*      THIS IS THE ONLINE COMPATIBLE INTERFACE.               *
061200*      THIS PASSES THE STANDARD VARIABLES AND THE             *
061300*      THE PROVIDER RECORD AND THE WAGE INDEX TABLES FROM     *
061400*      THE USERS (CBSA, IPPS CBSA, & MSA WIX TBLS).           *
061500***************************************************************
061600
061700**************************************************************
061800*** APRIL 22, 2005 ADDED CBSA FIELD SEPARATE FROM PPS-DATA ***
061900*** TO ACCOMODATE OLDER LTCAL VERSIONS                     ***
062000**************************************************************
062100*** OPTION (1)
062200     MOVE ' ' TO PRICER-OPTION-SW.
062300     CALL  LTOPN152   USING BILL-NEW-DATA
062400                            PPS-DATA-ALL
062500                            PPS-CBSA
062600                            PRICER-OPT-VERS-SW.
062700*** OPTION (2)
062800*    MOVE 'P' TO PRICER-OPTION-SW.
062900*    CALL  LTOPN152   USING BILL-NEW-DATA
063000*                           PPS-DATA-ALL
063100*                           PPS-CBSA
063200*                           PRICER-OPT-VERS-SW
063300*                           PROV-RECORD-FROM-USER.
063400*** OPTION (3)
063500*    MOVE 'A' TO PRICER-OPTION-SW.
063600*    CALL  LTOPN152   USING BILL-NEW-DATA
063700*                           PPS-DATA-ALL
063800*                           PPS-CBSA
063900*                           PRICER-OPT-VERS-SW
064000*                           PROV-RECORD-FROM-USER
064100*                           CBSAX-TABLE-FROM-USER
064200*                           IPPS-CBSAX-TABLE-FROM-USER
064300*                           MSAX-TABLE-FROM-USER.
064400
064500 1000-EXIT.  EXIT.
064600
064700
064800 1100-WRITE-SYSUT2.
064900******************************************************************
065000*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL
065100******************************************************************
065200     IF  OPERLINE-CTR > 54
065300         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.
065400     MOVE SPACES                TO  PPS-DETAIL-LINE-OPER.
065500     MOVE B-PROVIDER-NO         TO  PRT-PROV.
065600     MOVE PPS-LTR-DAYS-USED     TO  PRT-LTR-DAYS-USED.
065700     MOVE PPS-RELATIVE-WGT      TO  PRT-REL-WT.
065800     MOVE PPS-FAC-COSTS         TO  PRT-FAC-COST.
065900     MOVE PPS-AVG-LOS           TO  PRT-ALOS.
066000     MOVE PPS-LOS               TO  PRT-LOS.
066100     MOVE PPS-FINAL-PAY-AMT     TO  PRT-TOT-PAY.
066200     MOVE PPS-OUTLIER-THRESHOLD TO  PRT-OUT-THRESH.
066300     MOVE PPS-DRG-ADJ-PAY-AMT   TO  PRT-DRG-ADJ-PAY.
066400     MOVE PPS-OUTLIER-PAY-AMT   TO  PRT-OUTLIER-PAY.
066500     MOVE PPS-REG-DAYS-USED     TO  PRT-REG-DAYS-USED.
066600     MOVE PPS-NEW-FAC-SPEC-RATE TO  PRT-FAC-SPEC-RATE.
066700     MOVE PPS-RTC               TO  PRT-PPS-RTC.
066800     MOVE PPS-WAGE-INDEX        TO  PRT-WAGE-INDEX.
066900     IF PPS-RTC = 67
067000        MOVE PPS-CHRG-THRESHOLD TO  PRT-OUT-THRESH.
067100
067200     WRITE PRTOPER-LINE FROM PPS-DETAIL-LINE-OPER
067300                             AFTER ADVANCING 1.
067400     IF OPR-STAT1 > 0
067500        DISPLAY ' BAD4 WRITE ON PRTOPER FILE'.
067600     ADD 1 TO OPERLINE-CTR.
067700
067800 1100-EXIT.  EXIT.
067900
068000 1200-PPS-HEADINGS.
068100     WRITE PRTOPER-LINE FROM PPS-HEAD2-OPER
068200                             AFTER ADVANCING PAGE.
068300     IF OPR-STAT1 > 0
068400        DISPLAY ' BAD5 WRITE ON PRTOPER FILE'.
068500     WRITE PRTOPER-LINE FROM PPS-HEAD3-OPER
068600                             AFTER ADVANCING 2.
068700     IF OPR-STAT1 > 0
068800        DISPLAY ' BAD7 WRITE ON PRTOPER FILE'.
068900     WRITE PRTOPER-LINE FROM PPS-HEAD4-OPER
069000                             AFTER ADVANCING 1.
069100     IF OPR-STAT1 > 0
069200        DISPLAY ' BAD8 WRITE ON PRTOPER FILE'.
069300     MOVE ALL '  -' TO PRTOPER-LINE.
069400     WRITE PRTOPER-LINE AFTER ADVANCING 1.
069500     IF OPR-STAT1 > 0
069600        DISPLAY ' BAD9 WRITE ON PRTOPER FILE'.
069700     MOVE 4 TO OPERLINE-CTR.
069800
069900 1200-EXIT.  EXIT.
070000
070100*****        LAST STATEMENT               *************
