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