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