000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.         LTMGR212
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* 03/20/15 - VERSION 15.3 CREATED TO ADD NEW DATA NAMES
022600*
022700* 06/29/15 - VERSION 16.B CREATED TO TEST LOGIC CHANGES
022800*
022900* 08/05/15 - VERSION 16.0 CREATED TO TEST LOGIC CHANGES
023000*
023100* 11/25/15 - VERSION 16.C CREATED TO TEST UPDATED INTERFACE
023200*            (BILL-NEW-DATA - ADDED COST REPORT DAYS) &
023300*            LOGIC
023400*
023500* 12/11/15 - VERSION 16.1 TO IMPLEMENT CR9401 ON 4/1/16
023600*
023700* 01/08/16 - VERSION 16.2
023800*
023900* 5-23-16 - VERSION 17.B
024000* 7-18-16 - VERSION 17.0
024100* 8-9-17 - VERSION 18.0
024200* 10-13-17 - VERSION 18.2
024300* 2-8-18 - VERSION 18.3
024400* 7-30-18 - VERSION 19.0
024500* 8-1-19 - VERSION 20.0
024600* 3-4-20 - VERSION 20.1
024700* 4-3-20 - VERSION 20.2
024800* 6-17-20- VERSION 21.B
024900* 9-14-20- VERSION 21.0
025000* 10-9-20- VERSION 21.1
025100* 11-20-20- VERSION 21.2
025200*******************************************************
025300
025400 INPUT-OUTPUT SECTION.
025500 FILE-CONTROL.
025600
025700     SELECT BILLFILE   ASSIGN TO UT-S-SYSUT1
025800         FILE STATUS IS UT1-STAT.
025900     SELECT PRTOPER    ASSIGN TO UT-S-PRTOPER
026000         FILE STATUS IS OPR-STAT.
026100
026200 DATA DIVISION.
026300 FILE SECTION.
026400 FD  BILLFILE
026500     LABEL RECORDS ARE STANDARD
026600     RECORDING MODE IS F
026700     BLOCK CONTAINS 0 RECORDS.
026800 01  BILL-REC                    PIC X(422).
026900
027000 FD  PRTOPER
027100     RECORDING MODE IS F
027200     BLOCK CONTAINS 133 RECORDS
027300     LABEL RECORDS ARE STANDARD.
027400 01  PRTOPER-LINE                PIC X(133).
027500
027600 WORKING-STORAGE SECTION.
027700 77  W-STORAGE-REF               PIC X(51)  VALUE
027800     'L T C M A N A G E R - W O R K I N G   S T O R A G E'.
027900 01  PPMGR-VERSION               PIC X(05)  VALUE 'M21.2'.
028000 01  LTOPN212                    PIC X(08)  VALUE 'LTOPN212'.
028100 01  EOF-SW                      PIC 9(01)  VALUE 0.
028200 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.
028300 01  UT1-STAT.
028400     05  UT1-STAT1               PIC X.
028500     05  UT1-STAT2               PIC X.
028600 01  OPR-STAT.
028700     05  OPR-STAT1               PIC X.
028800     05  OPR-STAT2               PIC X.
028900*******************************************************
029000*******************************************************
029100*    MILLENNIUM BILL RECORD FORMAT                    *
029200*******************************************************
029300 01  BILL-WORK.
029400     05  BILL-NPI10.
029500         10  BILL-NPI8                 PIC X(08).
029600         10  BILL-NPI-FILLER           PIC X(02).
029700     05  BILL-PROVIDER-N.
029800         10  FILLER                    PIC X(02).
029900         10  BILL-LTC-PROV             PIC X(04).
030000     05  BILL-PATIENT-STATUS           PIC X(02).
030100     05  BILL-DRG-CODE                 PIC X(03).
030200     05  BILL-LOS                      PIC 9(03).
030300     05  BILL-COV-DAYS                 PIC 9(03).
030400     05  BILL-LTR-DAYS                 PIC 9(02).
030500     05  BILL-CST-RPT-DAYS             PIC 9(03).
030600     05  BILL-DISCHARGE-DATE.
030700         10  BILL-DISCHG-CC            PIC 9(02).
030800         10  BILL-DISCHG-YY            PIC 9(02).
030900         10  BILL-DISCHG-MM            PIC 9(02).
031000         10  BILL-DISCHG-DD            PIC 9(02).
031100     05  BILL-COV-CHARGES              PIC 9(07)V9(02).
031200     05  BILL-SPEC-PAY-IND             PIC X(01).
031300     05  BILL-REVIEW-CODE              PIC 9(02).
031400     05  BILL-DIAGNOSIS-CODE-TABLE.
031500         10  BILL-DIAGNOSIS-CODE    PIC X(07) OCCURS 25 TIMES
031600                                     INDEXED BY IDX-DIAG.
031700     05  BILL-PROCEDURE-CODE-TABLE.
031800         10 BILL-PROCEDURE-CODE     PIC X(07) OCCURS 25 TIMES
031900                                     INDEXED BY IDX-PROC.
032000     05  FILLER                       PIC X(20).
032100
032200*******************************************************
032300*    RETURNED BY LTOPN___                             *
032400*******************************************************
032500  01  PPS-DATA-ALL.
032600      05  PPS-RTC                      PIC X(02).
032700      05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
032800      05  PPS-DATA.
032900         10  PPS-MSA                   PIC X(04).
033000         10  PPS-WAGE-INDEX            PIC 9(02)V9(04).
033100         10  PPS-AVG-LOS               PIC 9(02)V9(01).
033200         10  PPS-RELATIVE-WGT          PIC 9(01)V9(04).
033300         10  PPS-OUTLIER-PAY-AMT       PIC 9(07)V9(02).
033400         10  PPS-LOS                   PIC 9(03).
033500         10  PPS-DRG-ADJ-PAY-AMT       PIC 9(07)V9(02).
033600         10  PPS-FED-PAY-AMT           PIC 9(07)V9(02).
033700         10  PPS-FINAL-PAY-AMT         PIC 9(07)V9(02).
033800         10  PPS-FAC-COSTS             PIC 9(07)V9(02).
033900         10  PPS-NEW-FAC-SPEC-RATE     PIC 9(07)V9(02).
034000         10  PPS-OUTLIER-THRESHOLD     PIC 9(07)V9(02).
034100         10  PPS-SUBM-DRG-CODE         PIC X(03).
034200         10  PPS-CALC-VERS-CD          PIC X(05).
034300         10  PPS-REG-DAYS-USED         PIC 9(03).
034400         10  PPS-LTR-DAYS-USED         PIC 9(03).
034500         10  PPS-BLEND-YEAR            PIC 9(01).
034600         10  PPS-COLA                  PIC 9(01)V9(03).
034700         10  FILLER                    PIC X(04).
034800      05  PPS-OTHER-DATA.
034900         10  PPS-NAT-LABOR-PCT         PIC 9(01)V9(05).
035000         10  PPS-NAT-NONLABOR-PCT      PIC 9(01)V9(05).
035100         10  PPS-STD-FED-RATE          PIC 9(05)V9(02).
035200         10  PPS-BDGT-NEUT-RATE        PIC 9(01)V9(03).
035300         10  PPS-IPTHRESH              PIC 9(03)V9(01).
035400         10  PPS-LTCH-DPP-ADJ-AMT      PIC S9(09)V99.
035500         10  FILLER                    PIC X(05).
035600      05  PPS-PC-DATA.
035700         10  PPS-COT-IND               PIC X(01).
035800         10  FILLER                    PIC X(20).
035900
036000  01  PPS-CBSA                         PIC X(05).
036100
036200  01  PPS-PAYMENT-DATA.
036300      05  PPS-SITE-NEUTRAL-COST-PMT    PIC 9(07)V99.
036400      05  PPS-SITE-NEUTRAL-IPPS-PMT    PIC 9(07)V99.
036500      05  PPS-STANDARD-FULL-PMT        PIC 9(07)V99.
036600      05  PPS-STANDARD-SSO-PMT         PIC 9(07)V99.
036700
036800*******************************************************
036900*    PASSED TO LTOPN___     MILLENNIUM                *
037000*******************************************************
037100 01  BILL-NEW-DATA.
037200     05  B-NPI10.
037300         10  B-NPI8                   PIC X(08).
037400         10  B-NPI-FILLER             PIC X(02).
037500     05  B-PROVIDER-NO                PIC X(06).
037600     05  B-PATIENT-STATUS             PIC X(02).
037700     05  B-DRG-CODE                   PIC X(03).
037800     05  B-LOS                        PIC 9(03).
037900     05  B-COV-DAYS                   PIC 9(03).
038000     05  B-LTR-DAYS                   PIC 9(02).
038100     05  B-CST-RPT-DAYS               PIC 9(03).
038200     05  B-DISCHARGE-DATE.
038300         10  B-DISCHG-CC              PIC 9(02).
038400         10  B-DISCHG-YY              PIC 9(02).
038500         10  B-DISCHG-MM              PIC 9(02).
038600         10  B-DISCHG-DD              PIC 9(02).
038700     05  B-COV-CHARGES                PIC 9(07)V9(02).
038800     05  B-SPEC-PAY-IND               PIC X(01).
038900     05  B-REVIEW-CODE                PIC 9(02).
039000     05  B-DIAGNOSIS-CODE-TABLE.
039100         10  B-DIAGNOSIS-CODE         PIC X(07) OCCURS 25 TIMES
039200                                      INDEXED BY IDX-DIAG.
039300     05  B-PROCEDURE-CODE-TABLE.
039400         10 B-PROCEDURE-CODE          PIC X(07) OCCURS 25 TIMES
039500                                      INDEXED BY IDX-PROC.
039600     05  B-LTCH-DPP-INDICATOR-SW      PIC X.
039700         88 B-LTCH-DPP-ADJUSTMENT     VALUE 'Y'.
039800     05  FILLER                       PIC X(19).
039900
040000*******************************************************
040100*    PASSED TO LTOPN___                               *
040200*******************************************************
040300 01  PRICER-OPT-VERS-SW.
040400     02  PRICER-OPTION-SW        PIC X.
040500     02  PPS-VERSIONS.
040600         10  PPDRV-VERSION       PIC X(05).
040700
040800*******************************************************
040900*    CAN BE PASSED TO LTOPN___                        *
041000*******************************************************
041100 01  PROV-RECORD-FROM-USER.
041200    02  W-PROV-NEWREC-HOLD1.
041300        05  W-P-NEW-NPI10.
041400            10  W-P-NEW-NPI8           PIC X(08).
041500            10  W-P-NEW-NPI-FILLER     PIC X(02).
041600        05  W-P-NEW-PROVIDER-OSCAR-NO.
041700            10  W-P-NEW-STATE            PIC 9(02).
041800            10  W-P-NEW-STATE-X REDEFINES
041900                W-P-NEW-STATE            PIC X(02).
042000            10  FILLER                   PIC X(04).
042100        05  W-P-NEW-DATE-DATA.
042200            10  W-P-NEW-EFF-DATE.
042300                15  W-P-NEW-EFF-DT-CC    PIC 9(02).
042400                15  W-P-NEW-EFF-DT-YY    PIC 9(02).
042500                15  W-P-NEW-EFF-DT-MM    PIC 9(02).
042600                15  W-P-NEW-EFF-DT-DD    PIC 9(02).
042700            10  W-P-NEW-FY-BEGIN-DATE.
042800                15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
042900                15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
043000                15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
043100                15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
043200            10  W-P-NEW-REPORT-DATE.
043300                15  W-P-NEW-REPORT-DT-CC PIC 9(02).
043400                15  W-P-NEW-REPORT-DT-YY PIC 9(02).
043500                15  W-P-NEW-REPORT-DT-MM PIC 9(02).
043600                15  W-P-NEW-REPORT-DT-DD PIC 9(02).
043700            10  W-P-NEW-TERMINATION-DATE.
043800                15  W-P-NEW-TERM-DT-CC   PIC 9(02).
043900                15  W-P-NEW-TERM-DT-YY   PIC 9(02).
044000                15  W-P-NEW-TERM-DT-MM   PIC 9(02).
044100                15  W-P-NEW-TERM-DT-DD   PIC 9(02).
044200        05  W-P-NEW-WAIVER-CODE          PIC X(01).
044300            88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
044400        05  W-P-NEW-INTER-NO             PIC X(05).
044500        05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
044600        05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
044700        05  W-P-NEW-MSA-DATA.
044800            10  W-P-NEW-CHG-CODE-INDEX    PIC X.
044900            10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
045000            10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
045100            10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
045200            10  W-P-NEW-STAND-AMT-LOC-MSA9
045300                REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
045400                15  W-P-NEW-RURAL-1ST.
045500                    20  W-P-NEW-STAND-RURAL  PIC XX.
045600                15  W-P-NEW-RURAL-2ND        PIC XX.
045700        05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
045800        05  W-P-NEW-LUGAR               PIC X.
045900        05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
046000        05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
046100        05  W-P-NEW-STATE-CODE          PIC 9(02).
046200        05  W-P-NEW-STATE-CODE-X REDEFINES
046300              W-P-NEW-STATE-CODE        PIC X(02).
046400        05  FILLER                      PIC X(03).
046500     02  W-PROV-NEWREC-HOLD2.
046600        05  W-P-NEW-VARIABLES.
046700            10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
046800            10  W-P-NEW-COLA              PIC  X(04).
046900            10  W-P-NEW-INTERN-RATIO      PIC  X(05).
047000            10  W-P-NEW-BED-SIZE          PIC  X(05).
047100            10  W-P-NEW-CCR               PIC  X(04).
047200            10  W-P-NEW-CMI               PIC  X(05).
047300            10  W-P-NEW-SSI-RATIO         PIC  X(04).
047400            10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
047500            10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
047600            10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
047700            10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
047800            10  W-P-NEW-FYE-DATE.
047900                15  W-P-NEW-FYE-CC        PIC 99.
048000                15  W-P-NEW-FYE-YY        PIC 99.
048100                15  W-P-NEW-FYE-MM        PIC 99.
048200                15  W-P-NEW-FYE-DD        PIC 99.
048300        05  W-P-NEW-SPECIAL-PAY-IND       PIC X(01).
048400        05  W-P-NEW-HOSP-QUAL-IND         PIC X(01).
048500        05  W-P-NEW-GEO-LOC-CBSAX         PIC X(05).
048600        05  W-P-NEW-GEO-LOC-CBSA9 REDEFINES
048700                        W-P-NEW-GEO-LOC-CBSAX PIC 9(05).
048800        05  W-P-NEW-GEO-LOC-CBSA-AST REDEFINES
048900                        W-P-NEW-GEO-LOC-CBSA9.
049000            10 W-P-NEW-GEO-LOC-CBSA-1ST   PIC X.
049100            10 W-P-NEW-GEO-LOC-CBSA-2ND   PIC X.
049200            10 W-P-NEW-GEO-LOC-CBSA-3RD   PIC X.
049300            10 W-P-NEW-GEO-LOC-CBSA-4TH   PIC X.
049400            10 W-P-NEW-GEO-LOC-CBSA-5TH   PIC X.
049500        05  FILLER                        PIC X(10).
049600        05  W-P-NEW-SPECIAL-WAGE-INDEX    PIC 9(02)V9(04).
049700    02  W-PROV-NEWREC-HOLD3.
049800        05  W-P-NEW-PASS-AMT-DATA.
049900            10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
050000            10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
050100            10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
050200            10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
050300        05  W-P-NEW-CAPI-DATA.
050400            15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
050500            15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
050600            15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
050700            15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
050800            15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
050900            15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
051000            15  W-P-NEW-CAPI-IME            PIC X(05).
051100            15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
051200            15  W-P-VAL-BASED-PURCH-SCORE   PIC X(4).
051300        05  W-P-SUPP-WI-IND                 PIC X.
051400        05  W-P-SUPP-WI                     PIC 9(02)V9(04).
051500        05  FILLER                        PIC X(11).
051600
051700*******************************************************
051800*    CAN BE PASSED TO LTOPN___  - CBSA WAGE INDEX TBL *
051900*******************************************************
052000 01  CBSAX-TABLE-FROM-USER.
052100     05  FILLER                  PIC X(32000).
052200     05  FILLER                  PIC X(30000).
052300     05  FILLER                  PIC X(30000).
052400
052500*******************************************************
052600*    CAN BE PASSED TO LTOPN___ - IPPS CBSA WI TABLE   *
052700*******************************************************
052800 01  IPPS-CBSAX-TABLE-FROM-USER.
052900     05  FILLER                  PIC X(32000).
053000     05  FILLER                  PIC X(30000).
053100     05  FILLER                  PIC X(30000).
053200
053300*******************************************************
053400*    CAN BE PASSED TO LTOPN___ - MSA WAGE INDEX TBL   *
053500*******************************************************
053600 01  MSAX-TABLE-FROM-USER.
053700     05  FILLER                  PIC X(32000).
053800     05  FILLER                  PIC X(30000).
053900     05  FILLER                  PIC X(30000).
054000
054100*******************************************************
054200*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *
054300*******************************************************
054400 01  PPS-DETAIL-LINE-OPER.
054500     05  FILLER                  PIC X(01)  VALUE SPACES.
054600     05  PRT-PROV                PIC X(06).
054700     05  FILLER                  PIC X(02)  VALUE SPACES.
054800     05  PRT-DRG-ADJ-PAY         PIC Z,ZZZ,ZZZ.99.
054900     05  FILLER                  PIC X(03)  VALUE SPACES.
055000     05  PRT-OUTLIER-PAY         PIC Z,ZZZ,ZZZ.99.
055100     05  FILLER                  PIC X(01)  VALUE SPACES.
055200     05  PRT-FAC-SPEC-RATE       PIC Z,ZZZ,ZZZ.99.
055300     05  FILLER                  PIC X(02)  VALUE SPACES.
055400     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.
055500     05  FILLER                  PIC X(02)  VALUE SPACES.
055600     05  PRT-OUT-THRESH          PIC Z,ZZZ,ZZZ.99.
055700     05  FILLER                  PIC X(02)  VALUE SPACES.
055800     05  PRT-FAC-COST            PIC Z,ZZZ,ZZZ.99.
055900     05  FILLER                  PIC X(02)  VALUE SPACES.
056000     05  PRT-LOS                 PIC ZZ9.
056100     05  FILLER                  PIC X(02)  VALUE SPACES.
056200     05  PRT-REG-DAYS-USED       PIC 9(03).
056300     05  FILLER                  PIC X(02)  VALUE SPACES.
056400     05  PRT-LTR-DAYS-USED       PIC 9(03).
056500     05  FILLER                  PIC X(02)  VALUE SPACES.
056600     05  PRT-ALOS                PIC ZZ.9.
056700     05  FILLER                  PIC X(03)  VALUE SPACES.
056800     05  PRT-PPS-RTC             PIC XX.
056900     05  FILLER                  PIC X(02)  VALUE SPACES.
057000     05  PRT-REL-WT              PIC 9.9999.
057100     05  FILLER                  PIC X(02)  VALUE SPACES.
057200     05  PRT-WAGE-INDEX          PIC 9.9999.
057300
057400 01  PPS-HEAD2-OPER.
057500     05  FILLER                  PIC X(01)  VALUE SPACES.
057600     05  FILLER                  PIC X(44)  VALUE
057700        '  CMS  LTCH PRICER            P R O S P E C '.
057800     05  FILLER                  PIC X(44)  VALUE
057900        'T I V E   P A Y M E N T   T E S T   D A T A '.
058000     05  FILLER                  PIC X(44)  VALUE
058100        '  R E P O R T                               '.
058200
058300 01  PPS-HEAD3-OPER.
058400     05  FILLER                  PIC X(01)  VALUE SPACES.
058500     05  FILLER                  PIC X(42)  VALUE
058600        'PROV          DRG         OUTLIER       FA'.
058700     05  FILLER                  PIC X(47)  VALUE
058800        'C           FINAL        OUTLIER         FAC   '.
058900     05  FILLER                  PIC X(43)  VALUE
059000        '   BILL REG  LTR  AVG   PPS  REL     WAGE'.
059100
059200 01  PPS-HEAD4-OPER.
059300     05  FILLER                  PIC X(01)  VALUE SPACES.
059400     05  FILLER                  PIC X(42)  VALUE
059500        ' NO        ADJ PAY        PAY AMT    SPEC '.
059600     05  FILLER                  PIC X(47)  VALUE
059700        'RATE       PAY AMT      THRESHOLD       COST   '.
059800     05  FILLER                  PIC X(43)  VALUE
059900        '   LOS  USED USED LOS   RTC  WGT     INDEX'.
060000
060100
060200******************************************************************
060300******************************************************************
060400
060500 PROCEDURE  DIVISION.
060600
060700 0000-MAINLINE  SECTION.
060800     OPEN INPUT  BILLFILE.
060900
061000     OPEN OUTPUT PRTOPER.
061100
061200     MOVE ALL '0'     TO PPS-VERSIONS.
061300
061400     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.
061500
061600     CLOSE BILLFILE.
061700
061800     CLOSE PRTOPER.
061900     STOP RUN.
062000
062100 0100-PROCESS-RECORDS.
062200     READ BILLFILE INTO BILL-WORK
062300         AT END
062400             MOVE 1 TO EOF-SW.
062500
062600     MOVE BILL-WORK TO BILL-NEW-DATA.
062700     IF  EOF-SW = 0
062800         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT
062900         PERFORM 1100-WRITE-SYSUT2 THRU 1100-EXIT.
063000
063100 0100-EXIT.  EXIT.
063200
063300
063400 1000-CALC-PAYMENT.
063500***************************************************************
063600*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE              *
063700*    PAYMENT                                                  *
063800***************************************************************
063900***************************************************************
064000* OPTION (1)                                                  *
064100*       (1)  MOVE ' ' TO PRICER-OPTION-SW.                    *
064200*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
064300*                                  PPS-DATA-ALL               *
064400*                                  PPS-CBSA                   *
064500*                                  PRICER-OPT-VERS-SW.        *
064600*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *
064700*                        *  *  *  *                           *
064800* OPTION (2)                                                  *
064900*       (2)  MOVE 'P' TO PRICER-OPTION-SW.                    *
065000*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
065100*                                  PPS-DATA-ALL               *
065200*                                  PPS-CBSA                   *
065300*                                  PRICER-OPT-VERS-SW         *
065400*                                  PROV-RECORD-FROM-USER.     *
065500*        THIS PASSES THE STANDARD VARIABLES AND               *
065600*        THE PROVIDER RECORD FROM THE USER                    *
065700*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *
065800*                        *  *  *  *                           *
065900* OPTION (3)                                                  *
066000*       (3)  MOVE 'A' TO PRICER-OPTION-SW.                    *
066100*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
066200*                                  PPS-DATA-ALL               *
066300*                                  PPS-CBSA                   *
066400*                                  PRICER-OPT-VERS-SW         *
066500*                                  PROV-RECORD-FROM-USER      *
066600*                                  CBSAX-TABLE-FROM-USER      *
066700*                                  IPPS-CBSAX-TABLE-FROM-USER *
066800*                                  MSAX-TABLE-FROM-USER.      *
066900*      THIS IS THE ONLINE COMPATIBLE INTERFACE.               *
067000*      THIS PASSES THE STANDARD VARIABLES AND THE             *
067100*      THE PROVIDER RECORD AND THE WAGE INDEX TABLES FROM     *
067200*      THE USERS (CBSA, IPPS CBSA, & MSA WIX TBLS).           *
067300***************************************************************
067400
067500**************************************************************
067600*** APRIL 22, 2005 ADDED CBSA FIELD SEPARATE FROM PPS-DATA ***
067700*** TO ACCOMODATE OLDER LTCAL VERSIONS                     ***
067800**************************************************************
067900*** OPTION (1)
068000     MOVE ' ' TO PRICER-OPTION-SW.
068100     CALL  LTOPN212   USING BILL-NEW-DATA
068200                            PPS-DATA-ALL
068300                            PPS-CBSA
068400                            PPS-PAYMENT-DATA
068500                            PRICER-OPT-VERS-SW.
068600*** OPTION (2)
068700*    MOVE 'P' TO PRICER-OPTION-SW.
068800*    CALL  LTOPN212   USING BILL-NEW-DATA
068900*                           PPS-DATA-ALL
069000*                           PPS-CBSA
069100*                           PRICER-OPT-VERS-SW
069200*                           PROV-RECORD-FROM-USER.
069300*** OPTION (3)
069400*    MOVE 'A' TO PRICER-OPTION-SW.
069500*    CALL  LTOPN212   USING BILL-NEW-DATA
069600*                           PPS-DATA-ALL
069700*                           PPS-CBSA
069800*                           PRICER-OPT-VERS-SW
069900*                           PROV-RECORD-FROM-USER
070000*                           CBSAX-TABLE-FROM-USER
070100*                           IPPS-CBSAX-TABLE-FROM-USER
070200*                           MSAX-TABLE-FROM-USER.
070300
070400 1000-EXIT.  EXIT.
070500
070600
070700 1100-WRITE-SYSUT2.
070800******************************************************************
070900*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL
071000******************************************************************
071100     IF  OPERLINE-CTR > 54
071200         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.
071300     MOVE SPACES                TO  PPS-DETAIL-LINE-OPER.
071400     MOVE B-PROVIDER-NO         TO  PRT-PROV.
071500     MOVE PPS-LTR-DAYS-USED     TO  PRT-LTR-DAYS-USED.
071600     MOVE PPS-RELATIVE-WGT      TO  PRT-REL-WT.
071700     MOVE PPS-FAC-COSTS         TO  PRT-FAC-COST.
071800     MOVE PPS-AVG-LOS           TO  PRT-ALOS.
071900     MOVE PPS-LOS               TO  PRT-LOS.
072000     MOVE PPS-FINAL-PAY-AMT     TO  PRT-TOT-PAY.
072100     MOVE PPS-OUTLIER-THRESHOLD TO  PRT-OUT-THRESH.
072200     MOVE PPS-DRG-ADJ-PAY-AMT   TO  PRT-DRG-ADJ-PAY.
072300     MOVE PPS-OUTLIER-PAY-AMT   TO  PRT-OUTLIER-PAY.
072400     MOVE PPS-REG-DAYS-USED     TO  PRT-REG-DAYS-USED.
072500     MOVE PPS-NEW-FAC-SPEC-RATE TO  PRT-FAC-SPEC-RATE.
072600     MOVE PPS-RTC               TO  PRT-PPS-RTC.
072700     MOVE PPS-WAGE-INDEX        TO  PRT-WAGE-INDEX.
072800     IF PPS-RTC = 67
072900        MOVE PPS-CHRG-THRESHOLD TO  PRT-OUT-THRESH.
073000
073100     WRITE PRTOPER-LINE FROM PPS-DETAIL-LINE-OPER
073200                             AFTER ADVANCING 1.
073300     IF OPR-STAT1 > 0
073400        DISPLAY ' BAD4 WRITE ON PRTOPER FILE'.
073500     ADD 1 TO OPERLINE-CTR.
073600
073700 1100-EXIT.  EXIT.
073800
073900 1200-PPS-HEADINGS.
074000     WRITE PRTOPER-LINE FROM PPS-HEAD2-OPER
074100                             AFTER ADVANCING PAGE.
074200     IF OPR-STAT1 > 0
074300        DISPLAY ' BAD5 WRITE ON PRTOPER FILE'.
074400     WRITE PRTOPER-LINE FROM PPS-HEAD3-OPER
074500                             AFTER ADVANCING 2.
074600     IF OPR-STAT1 > 0
074700        DISPLAY ' BAD7 WRITE ON PRTOPER FILE'.
074800     WRITE PRTOPER-LINE FROM PPS-HEAD4-OPER
074900                             AFTER ADVANCING 1.
075000     IF OPR-STAT1 > 0
075100        DISPLAY ' BAD8 WRITE ON PRTOPER FILE'.
075200     MOVE ALL '  -' TO PRTOPER-LINE.
075300     WRITE PRTOPER-LINE AFTER ADVANCING 1.
075400     IF OPR-STAT1 > 0
075500        DISPLAY ' BAD9 WRITE ON PRTOPER FILE'.
075600     MOVE 4 TO OPERLINE-CTR.
075700
075800 1200-EXIT.  EXIT.
075900
076000*****        LAST STATEMENT               *************
