000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.         LTMGR130.
000400*AUTHOR.             CMS
003200 DATE-COMPILED.
003300 ENVIRONMENT DIVISION.
003500 CONFIGURATION SECTION.
003600 SOURCE-COMPUTER.                IBM-370.
003700 OBJECT-COMPUTER.                IBM-370.

      ******************************************************
      *                                                    *
      * THIS PROGRAM RUNS THE LONG-TERM CARE PPS PRICER    *
      * MODULES FOR TESTING PURPOSES.                      *
      *                                                    *
      *----------------------------------------------------*
      * CHANGE LOG                                         *
      *----------------------------------------------------*
      *                                                    *
      * 04/22/2005 - PPS-CBSA ADDED TO ACCOMODATE THE      *
      *              JULY 1, 2005 CHANGE FROM MSA TO CBSA  *
      *              BASED WAGE INDICES                    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/02/2005 - ADDED PSF FIELDS - SPECIAL PAY IND &  *
      *              SPECIAL WAGE INDEX                    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/28/2005 - PROGRAM NAME CHANGED FROM LTDRIVER TO *
      *              LTMGR___                              *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 01/17/2006 - PROGRAM PREPARED FOR APRIL 2006       *
      *              CICS RELEASE                          *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 01/19/2006 - CALLED PROGRAM CHANGED TO LTOPN___    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/03/2006 - ADDED IPPS-CBSAX RECORD TO OPTION 4   *
      *              OF LTOPN___ CALL                      *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 06/19/2006 - VERSION CHANGED FROM 07.0 TO 07.1     *
      *                                                    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/09/2006 - UPDATED FOR OCTOBER 2006 VERSION 07.3 *
      *                                                    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/06/2006 - UPDATED FOR OCTOBER 2006 VERSION 07.4 *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 11/16/2006 - CREATED VERSION 07.5 FOR OCTOBER 2006 *
      *              DUE TO CORRECTION OF THE IME          *
      *              MULTIPLIER USED IN THE 4TH SSO        *
      *              PROVISION (IPPS PORTION), IPPS WAGE   *
      *              INDEX CHANGE & REMOVAL OF PPS-RTC 23  *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 12/28/2006 - CREATED VERSION 07.6 FOR OCTOBER 2006 *
      *              DUE TO CBSA SIZE LOGIC CORRECTION     *
      *              ** THIS VERSION WAS NOT RELEASED **   *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/03/2007 - UPDATED FOR JULY 2007 VERSION 08.0    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/13/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.1 *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/23/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.2 *
      *              (FOR REVISED IPPS RATES & WAGE INDEX) *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/14/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.3 *
      *              (FOR REVISED IPPS RATES & WAGE INDEX) *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/28/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.4 *
      *              (FOR REVISED IPPS RATES)              *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 12/27/2007 - UPDATED FOR OCTOBER 2007 VERSION 08.5 *
      *              (FOR REVISED SHORT STAY OUTLIER LOGIC)*
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 02/06/2008 - UPDATE FOR OCTOBER 2007 VERSION 08.6  *
      *              (FOR REVISED STANDARD FEDERAL RATE &  *
      *               FIXED LOSS AMOUNT FOR APRIL 2008)    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/08/2008 - CREATED VERSION 09.0 FOR JULY 2008    *
      *              (FOR NEW RATE YEAR 2009, STILL FY2008)*
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/19/2008 - CREATED VERSION 09.1 FOR JULY 2008    *
      *              REVISED IPPS PUERTO RICO RATES        *
      *              EFFECTIVE RETROACTIVE TO 10/01/2007   *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/11/2008 - CREATED VERSION 09.2 FOR OCTOBER 2008 *
      *              (FOR RATE YEAR 2009, FY 2009)         *
      *              ADDED FIELD P-VAL-BASED-PURCH-SCORE   *
      *              TO THE PSF (TO BE USED IN IPPS 1/1/08)*
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/09/2008 - CREATED VERSION 09.3 FOR OCTOBER 2008 *
      *              (FOR RATE YEAR 2009, FY 2009)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 02/17/2009 - CREATED VERSION 09.4 FOR OCTOBER 2008 *
      *              (FOR RATE YEAR 2009, FY 2009)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 05/18/2009 - CREATED VERSION 09.5 FOR JUN-SEPT '09 *
      *              (FOR RATE YEAR 2009, FY 2009)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/05/2009 - CREATED VERSION 10.0 FOR OCTOBER 2009 *
      *              (FOR RATE YEAR 2010, FY 2010)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 09/03/2009 - CREATED VERSION 10.1 FOR OCTOBER 2009 *
      *              (FOR RATE YEAR 2010, FY 2010)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 11/11/2009 - CREATED VERSION 10.2 FOR OCTOBER 2009 *
      *              (FOR RATE YEAR 2010, FY 2010)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 04/07/2010 - CREATED VERSION 10.3 FOR OCTOBER 2009 *
      *              (FOR RATE YEAR 2010, FY 2010)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 04/19/2010 - CREATED VERSION 10.4 FOR OCTOBER 2009 *
      *              (FOR RATE YEAR 2010, FY 2010)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/04/2010 - CREATED VERSION 11.0 FOR OCTOBER 2010 *
      *              (FOR RATE YEAR 2011, FY 2011)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 10/20/2010 - CREATED VERSION 11.1 FOR OCTOBER 2010 *
      *              ALLOWS CLAIMS WITH DATES OF SERVICE   *
      *              OLDER THAN 5 YEARS                    *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/01/2011 - CREATED VERSION 12.0 FOR OCTOBER 2011 *
      *              (FOR RATE YEAR 2012, FY 2012)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 08/31/2011 - CREATED VERSION 12.1 FOR OCTOBER 2011 *
      *              (FOR RATE YEAR 2012, FY 2012)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 10/28/2011 - CREATED VERSION 12.2 FOR OCTOBER 2011 *
      *              (FOR RATE YEAR 2012, FY 2012)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 12/09/2011 - CREATED VERSION 12.3 FOR OCTOBER 2011 *
      *              (FOR RATE YEAR 2012, FY 2012)         *
      *                                                    *
      *----------------------------------------------------*
      *                                                    *
      * 07/31/2012 - CREATED VERSION 13.0 FOR OCTOBER 2012 *
      *              (FOR RATE YEAR 2013, FY 2013)         *
      *                                                    *
      ******************************************************
003800
003900 INPUT-OUTPUT SECTION.
004000 FILE-CONTROL.
004100
004200     SELECT BILLFILE   ASSIGN TO UT-S-SYSUT1
004300         FILE STATUS IS UT1-STAT.
004600     SELECT PRTOPER    ASSIGN TO UT-S-PRTOPER
004700         FILE STATUS IS OPR-STAT.
005000
005100 DATA DIVISION.
005200 FILE SECTION.
005300 FD  BILLFILE
005400     LABEL RECORDS ARE STANDARD
005500     RECORDING MODE IS F
005600     BLOCK CONTAINS 0 RECORDS.
005700 01  BILL-REC                    PIC X(60).
005800
006500 FD  PRTOPER
006600     RECORDING MODE IS F
006700     BLOCK CONTAINS 133 RECORDS
006800     LABEL RECORDS ARE STANDARD.
006900 01  PRTOPER-LINE                PIC X(133).
007600
007700 WORKING-STORAGE SECTION.
007800 77  W-STORAGE-REF               PIC X(51)  VALUE
007900     'L T C M A N A G E R - W O R K I N G   S T O R A G E'.
008000 01  PPMGR-VERSION               PIC X(05)  VALUE 'M13.0'.
008100 01  LTOPN130                    PIC X(08)  VALUE 'LTOPN130'.
008200 01  EOF-SW                      PIC 9(01)  VALUE 0.
008700 01  OPERLINE-CTR                PIC 9(02)  VALUE 65.
009100 01  UT1-STAT.
009200     05  UT1-STAT1               PIC X.
009300     05  UT1-STAT2               PIC X.
009700 01  OPR-STAT.
009800     05  OPR-STAT1               PIC X.
009900     05  OPR-STAT2               PIC X.
010300*******************************************************
010400*******************************************************
010500*    MILLENNIUM BILL RECORD FORMAT                    *
010600*******************************************************
010700 01  BILL-WORK.
019000     05  BILL-NPI10.
019100         10  BILL-NPI8                 PIC X(08).
019200         10  BILL-NPI-FILLER           PIC X(02).
019300     05  BILL-PROVIDER-N.
019400         10  FILLER                    PIC X(02).
019500         10  BILL-LTC-PROV             PIC X(04).
019600     05  BILL-PATIENT-STATUS           PIC X(02).
019600     05  BILL-DRG-CODE                 PIC X(03).
020730     05  BILL-LOS                      PIC 9(03).
020730     05  BILL-COV-DAYS                 PIC 9(03).
020730     05  BILL-LTR-DAYS                 PIC 9(02).
020731     05  BILL-DISCHARGE-DATE.
020732         10  BILL-DISCHG-CC            PIC 9(02).
020733         10  BILL-DISCHG-YY            PIC 9(02).
020733         10  BILL-DISCHG-MM            PIC 9(02).
020100         10  BILL-DISCHG-DD            PIC 9(02).
020200     05  BILL-COV-CHARGES              PIC 9(07)V9(02).
020200     05  BILL-SPEC-PAY-IND             PIC X(01).
020300     05  FILLER                        PIC X(13).
020400
012600*******************************************************
012700*    RETURNED BY LTOPN___                             *
012800*******************************************************
012900  01  PPS-DATA-ALL.
016600      05  PPS-RTC                      PIC 9(02).
016600      05  PPS-CHRG-THRESHOLD           PIC 9(07)V9(02).
016600      05  PPS-DATA.
016600         10  PPS-MSA                   PIC X(04).
016600         10  PPS-WAGE-INDEX            PIC 9(02)V9(04).
016600         10  PPS-AVG-LOS               PIC 9(02)V9(01).
016600         10  PPS-RELATIVE-WGT          PIC 9(01)V9(04).
016600         10  PPS-OUTLIER-PAY-AMT       PIC 9(07)V9(02).
016600         10  PPS-LOS                   PIC 9(03).
016600         10  PPS-DRG-ADJ-PAY-AMT       PIC 9(07)V9(02).
016600         10  PPS-FED-PAY-AMT           PIC 9(07)V9(02).
016600         10  PPS-FINAL-PAY-AMT         PIC 9(07)V9(02).
016600         10  PPS-FAC-COSTS             PIC 9(07)V9(02).
016600         10  PPS-NEW-FAC-SPEC-RATE     PIC 9(07)V9(02).
016600         10  PPS-OUTLIER-THRESHOLD     PIC 9(07)V9(02).
016600         10  PPS-SUBM-DRG-CODE         PIC X(03).
016600         10  PPS-CALC-VERS-CD          PIC X(05).
016600         10  PPS-REG-DAYS-USED         PIC 9(03).
016600         10  PPS-LTR-DAYS-USED         PIC 9(03).
016600         10  PPS-BLEND-YEAR            PIC 9(01).
016600         10  PPS-COLA                  PIC 9(01)V9(03).
016600         10  FILLER                    PIC X(04).
016600      05  PPS-OTHER-DATA.
016600         10  PPS-NAT-LABOR-PCT         PIC 9(01)V9(05).
016600         10  PPS-NAT-NONLABOR-PCT      PIC 9(01)V9(05).
016600         10  PPS-STD-FED-RATE          PIC 9(05)V9(02).
016600         10  PPS-BDGT-NEUT-RATE        PIC 9(01)V9(03).
016600         10  FILLER                    PIC X(20).
016600      05  PPS-PC-DATA.
016600         10  PPS-COT-IND               PIC X(01).
016600         10  FILLER                    PIC X(20).

        01  PPS-CBSA                         PIC X(05).

018600*******************************************************
018700*    PASSED TO LTOPN___     MILLENNIUM                *
018800*******************************************************
018900 01  BILL-NEW-DATA.
019000     05  B-NPI10.
019100         10  B-NPI8                    PIC X(08).
019200         10  B-NPI-FILLER              PIC X(02).
019300     05  B-PROVIDER-NO.
019400         10  FILLER                    PIC X(02).
019500         10  B-LTC-PROV                PIC X(04).
019600     05  B-PATIENT-STATUS              PIC X(02).
019600     05  B-DRG-CODE                    PIC X(03).
020730     05  B-LOS                         PIC 9(03).
020730     05  B-COV-DAYS                    PIC 9(03).
020730     05  B-LTR-DAYS                    PIC 9(02).
020731     05  B-DISCHARGE-DATE.
020732         10  B-DISCHG-CC               PIC 9(02).
020733         10  B-DISCHG-YY               PIC 9(02).
020733         10  B-DISCHG-MM               PIC 9(02).
020100         10  B-DISCHG-DD               PIC 9(02).
020200     05  B-COV-CHARGES                 PIC 9(07)V9(02).
020200     05  B-SPEC-PAY-IND                PIC X(01).
020300     05  FILLER                        PIC X(13).
020400
020800*******************************************************
020900*    PASSED TO LTOPN___                               *
021000*******************************************************
021100 01  PRICER-OPT-VERS-SW.
021200     02  PRICER-OPTION-SW        PIC X.
021300     02  PPS-VERSIONS.
021400         10  PPDRV-VERSION       PIC X(05).
021500
021600*******************************************************
021700*    CAN BE PASSED TO LTOPN___                        *
021800*******************************************************
021900 01  PROV-RECORD-FROM-USER.
022000    02  W-PROV-NEWREC-HOLD1.
022000        05  W-P-NEW-NPI10.
022000            10  W-P-NEW-NPI8           PIC X(08).
022000            10  W-P-NEW-NPI-FILLER     PIC X(02).
022000        05  W-P-NEW-PROVIDER-OSCAR-NO.
022000            10  W-P-NEW-STATE            PIC X(02).
022000            10  FILLER                 PIC X(04).
022000        05  W-P-NEW-DATE-DATA.
022000            10  W-P-NEW-EFF-DATE.
022000                15  W-P-NEW-EFF-DT-CC    PIC 9(02).
022000                15  W-P-NEW-EFF-DT-YY    PIC 9(02).
022000                15  W-P-NEW-EFF-DT-MM    PIC 9(02).
022000                15  W-P-NEW-EFF-DT-DD    PIC 9(02).
022000            10  W-P-NEW-FY-BEGIN-DATE.
022000                15  W-P-NEW-FY-BEG-DT-CC PIC 9(02).
022000                15  W-P-NEW-FY-BEG-DT-YY PIC 9(02).
022000                15  W-P-NEW-FY-BEG-DT-MM PIC 9(02).
022000                15  W-P-NEW-FY-BEG-DT-DD PIC 9(02).
022000            10  W-P-NEW-REPORT-DATE.
022000                15  W-P-NEW-REPORT-DT-CC PIC 9(02).
022000                15  W-P-NEW-REPORT-DT-YY PIC 9(02).
022000                15  W-P-NEW-REPORT-DT-MM PIC 9(02).
022000                15  W-P-NEW-REPORT-DT-DD PIC 9(02).
022000            10  W-P-NEW-TERMINATION-DATE.
022000                15  W-P-NEW-TERM-DT-CC   PIC 9(02).
022000                15  W-P-NEW-TERM-DT-YY   PIC 9(02).
022000                15  W-P-NEW-TERM-DT-MM   PIC 9(02).
022000                15  W-P-NEW-TERM-DT-DD   PIC 9(02).
022000        05  W-P-NEW-WAIVER-CODE          PIC X(01).
022000            88  W-P-NEW-WAIVER-STATE       VALUE 'Y'.
022000        05  W-P-NEW-INTER-NO             PIC X(05).
022000        05  W-P-NEW-PROVIDER-TYPE        PIC X(02).
022000        05  W-P-NEW-CURRENT-CENSUS-DIV   PIC X(01).
022000        05  W-P-NEW-MSA-DATA.
022000            10  W-P-NEW-CHG-CODE-INDEX    PIC X.
022000            10  W-P-NEW-GEO-LOC-MSA        PIC X(04) JUST RIGHT.
022000            10  W-P-NEW-WAGE-INDEX-LOC-MSA PIC X(04) JUST RIGHT.
022000            10  W-P-NEW-STAND-AMT-LOC-MSA  PIC X(04) JUST RIGHT.
022000            10  W-P-NEW-STAND-AMT-LOC-MSA9
022000                REDEFINES W-P-NEW-STAND-AMT-LOC-MSA.
022000                15  W-P-NEW-RURAL-1ST.
022000                    20  W-P-NEW-STAND-RURAL  PIC XX.
022000                15  W-P-NEW-RURAL-2ND        PIC XX.
022000        05  W-P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
022000        05  W-P-NEW-LUGAR               PIC X.
022000        05  W-P-NEW-TEMP-RELIEF-IND     PIC X.
022000        05  W-P-NEW-FED-PPS-BLEND-IND   PIC X.
022000        05  FILLER                      PIC X(05).
022000     02  W-PROV-NEWREC-HOLD2.
022000        05  W-P-NEW-VARIABLES.
022000            10  W-P-NEW-FAC-SPEC-RATE     PIC  X(07).
022000            10  W-P-NEW-COLA              PIC  X(04).
022000            10  W-P-NEW-INTERN-RATIO      PIC  X(05).
022000            10  W-P-NEW-BED-SIZE          PIC  X(05).
022000            10  W-P-NEW-CCR               PIC  X(04).
022000            10  W-P-NEW-CMI               PIC  X(05).
022000            10  W-P-NEW-SSI-RATIO         PIC  X(04).
022000            10  W-P-NEW-MEDICAID-RATIO    PIC  X(04).
022000            10  W-P-NEW-PPS-BLEND-YR-IND  PIC  X(01).
022000            10  W-P-NEW-PRUP-UPDTE-FACTOR PIC  9(01)V9(05).
022000            10  W-P-NEW-DSH-PERCENT       PIC  V9(04).
022000            10  W-P-NEW-FYE-DATE.
022000                15  W-P-NEW-FYE-CC        PIC 99.
022000                15  W-P-NEW-FYE-YY        PIC 99.
022000                15  W-P-NEW-FYE-MM        PIC 99.
022000                15  W-P-NEW-FYE-DD        PIC 99.
              05  W-P-NEW-SPECIAL-PAY-IND       PIC X(01).
              05  FILLER                        PIC X(01).
              05  W-P-NEW-GEO-LOC-CBSAX         PIC X(05).
              05  W-P-NEW-GEO-LOC-CBSA9 REDEFINES
                              W-P-NEW-GEO-LOC-CBSAX PIC 9(05).
              05  W-P-NEW-GEO-LOC-CBSA-AST REDEFINES
                              W-P-NEW-GEO-LOC-CBSA9.
                  10 W-P-NEW-GEO-LOC-CBSA-1ST   PIC X.
                  10 W-P-NEW-GEO-LOC-CBSA-2ND   PIC X.
                  10 W-P-NEW-GEO-LOC-CBSA-3RD   PIC X.
                  10 W-P-NEW-GEO-LOC-CBSA-4TH   PIC X.
                  10 W-P-NEW-GEO-LOC-CBSA-5TH   PIC X.
              05  FILLER                        PIC X(10).
              05  W-P-NEW-SPECIAL-WAGE-INDEX    PIC 9(02)V9(04).
022000    02  W-PROV-NEWREC-HOLD3.
022000        05  W-P-NEW-PASS-AMT-DATA.
022000            10  W-P-NEW-PASS-AMT-CAPITAL    PIC X(06).
022000            10  W-P-NEW-PASS-AMT-DIR-MED-ED PIC X(06).
022000            10  W-P-NEW-PASS-AMT-ORGAN-ACQ  PIC X(06).
022000            10  W-P-NEW-PASS-AMT-PLUS-MISC  PIC X(06).
022000        05  W-P-NEW-CAPI-DATA.
022000            15  W-P-NEW-CAPI-PPS-PAY-CODE   PIC X.
022000            15  W-P-NEW-CAPI-HOSP-SPEC-RATE PIC X(6).
022000            15  W-P-NEW-CAPI-OLD-HARM-RATE  PIC X(6).
022000            15  W-P-NEW-CAPI-NEW-HARM-RATIO PIC X(5).
022000            15  W-P-NEW-CAPI-CSTCHG-RATIO   PIC X(04).
022000            15  W-P-NEW-CAPI-NEW-HOSP       PIC X.
022000            15  W-P-NEW-CAPI-IME            PIC X(05).
022000            15  W-P-NEW-CAPI-EXCEPTIONS     PIC X(6).
022000            15  W-P-VAL-BASED-PURCH-SCORE   PIC X(4).
022000        05  FILLER                          PIC X(18).
022000
022100*******************************************************
022200*    CAN BE PASSED TO LTOPN___  - CBSA WAGE INDEX TBL *
022300*******************************************************
022400 01  CBSAX-TABLE-FROM-USER.
022500     05  FILLER                  PIC X(32000).
022600     05  FILLER                  PIC X(30000).
022700     05  FILLER                  PIC X(30000).
022000
022100*******************************************************
022200*    CAN BE PASSED TO LTOPN___ - IPPS CBSA WI TABLE   *
022300*******************************************************
022400 01  IPPS-CBSAX-TABLE-FROM-USER.
022500     05  FILLER                  PIC X(32000).
022600     05  FILLER                  PIC X(30000).
022700     05  FILLER                  PIC X(30000).
022000
022100*******************************************************
022200*    CAN BE PASSED TO LTOPN___ - MSA WAGE INDEX TBL   *
022300*******************************************************
022400 01  MSAX-TABLE-FROM-USER.
022500     05  FILLER                  PIC X(32000).
022600     05  FILLER                  PIC X(30000).
022700     05  FILLER                  PIC X(30000).
022800
022900*******************************************************
023000*    PROSPECTIVE PAYMENT REPORT COMPONENTS            *
023100*******************************************************
023200 01  PPS-DETAIL-LINE-OPER.
023300     05  FILLER                  PIC X(01)  VALUE SPACES.
023600     05  PRT-PROV                PIC X(06).
023601     05  FILLER                  PIC X(02)  VALUE SPACES.
025200     05  PRT-DRG-ADJ-PAY         PIC Z,ZZZ,ZZZ.99.
025700     05  FILLER                  PIC X(03)  VALUE SPACES.
025400     05  PRT-OUTLIER-PAY         PIC Z,ZZZ,ZZZ.99.
025500     05  FILLER                  PIC X(01)  VALUE SPACES.
025400     05  PRT-FAC-SPEC-RATE       PIC Z,ZZZ,ZZZ.99.
025500     05  FILLER                  PIC X(02)  VALUE SPACES.
025600     05  PRT-TOT-PAY             PIC Z,ZZZ,ZZZ.99.
025300     05  FILLER                  PIC X(02)  VALUE SPACES.
024400     05  PRT-OUT-THRESH          PIC Z,ZZZ,ZZZ.99.
026940     05  FILLER                  PIC X(02)  VALUE SPACES.
026950     05  PRT-FAC-COST            PIC Z,ZZZ,ZZZ.99.
024500     05  FILLER                  PIC X(02)  VALUE SPACES.
025900     05  PRT-LOS                 PIC ZZ9.
026100     05  FILLER                  PIC X(02)  VALUE SPACES.
025800     05  PRT-REG-DAYS-USED       PIC 9(03).
025810     05  FILLER                  PIC X(02)  VALUE SPACES.
026910     05  PRT-LTR-DAYS-USED       PIC 9(03).
026920     05  FILLER                  PIC X(02)  VALUE SPACES.
025501     05  PRT-ALOS                PIC ZZ.9.
025510     05  FILLER                  PIC X(03)  VALUE SPACES.
026800     05  PRT-PPS-RTC             PIC 99.
026900     05  FILLER                  PIC X(02)  VALUE SPACES.
026930     05  PRT-REL-WT              PIC 9.9999.
026940     05  FILLER                  PIC X(02)  VALUE SPACES.
           05  PRT-WAGE-INDEX          PIC 9.9999.
027000
028000 01  PPS-HEAD2-OPER.
028100     05  FILLER                  PIC X(01)  VALUE SPACES.
028200     05  FILLER                  PIC X(44)  VALUE
028300        '  CMS  LTCH PRICER            P R O S P E C '.
028400     05  FILLER                  PIC X(44)  VALUE
028500        'T I V E   P A Y M E N T   T E S T   D A T A '.
028600     05  FILLER                  PIC X(44)  VALUE
028700        '  R E P O R T                               '.
028800
028900 01  PPS-HEAD3-OPER.
029000     05  FILLER                  PIC X(01)  VALUE SPACES.
029100     05  FILLER                  PIC X(42)  VALUE
029200        'PROV          DRG         OUTLIER       FA'.
029300     05  FILLER                  PIC X(47)  VALUE
029400        'C           FINAL        OUTLIER         FAC   '.
029500     05  FILLER                  PIC X(43)  VALUE
029600        '   BILL REG  LTR  AVG   PPS  REL     WAGE'.
029700
029800 01  PPS-HEAD4-OPER.
029900     05  FILLER                  PIC X(01)  VALUE SPACES.
030000     05  FILLER                  PIC X(42)  VALUE
030100        ' NO        ADJ PAY        PAY AMT    SPEC '.
030200     05  FILLER                  PIC X(47)  VALUE
030300        'RATE       PAY AMT      THRESHOLD       COST   '.
030400     05  FILLER                  PIC X(43)  VALUE
030500        '   LOS  USED USED LOS   RTC  WGT     INDEX'.
030600
030600
030600******************************************************************
030600******************************************************************

043600 PROCEDURE  DIVISION.
043700
043800 0000-MAINLINE  SECTION.
043900     OPEN INPUT  BILLFILE.
044000
044200     OPEN OUTPUT PRTOPER.
044400
044900     MOVE ALL '0'     TO PPS-VERSIONS.
045000
045100     PERFORM 0100-PROCESS-RECORDS THRU 0100-EXIT UNTIL EOF-SW = 1.
045200
048700     CLOSE BILLFILE.
048900
052400     CLOSE PRTOPER.
052500     STOP RUN.
052600
052700 0100-PROCESS-RECORDS.
052800     READ BILLFILE INTO BILL-WORK
052900         AT END
053000             MOVE 1 TO EOF-SW.
053100
053200     MOVE BILL-WORK TO BILL-NEW-DATA.
054100     IF  EOF-SW = 0
054400         PERFORM 1000-CALC-PAYMENT THRU 1000-EXIT
054500         PERFORM 1100-WRITE-SYSUT2 THRU 1100-EXIT.
054600
054700 0100-EXIT.  EXIT.
054800
054800
063500 1000-CALC-PAYMENT.
063600***************************************************************
063700*    CALL TO THE PPS SUBROUTINE TO CALCULATE THE              *
063800*    PAYMENT                                                  *
063900***************************************************************
064000***************************************************************
064100* OPTION (1)                                                  *
064200*       (1)  MOVE ' ' TO PRICER-OPTION-SW.                    *
064300*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
064400*                                  PPS-DATA-ALL               *
064400*                                  PPS-CBSA                   *
064500*                                  PRICER-OPT-VERS-SW.        *
064600*        THIS PASSES THE STANDARD VARIABLES USED FOR PRICING. *
064700*                        *  *  *  *                           *
065700* OPTION (2)                                                  *
065800*       (2)  MOVE 'P' TO PRICER-OPTION-SW.                    *
065900*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
066000*                                  PPS-DATA-ALL               *
066000*                                  PPS-CBSA                   *
066100*                                  PRICER-OPT-VERS-SW         *
066300*                                  PROV-RECORD-FROM-USER.     *
066400*        THIS PASSES THE STANDARD VARIABLES AND               *
066600*        THE PROVIDER RECORD FROM THE USER                    *
066700*       USED FOR THIS BILL ONLY IS ALSO PASSED.               *
066800*                        *  *  *  *                           *
066900* OPTION (3)                                                  *
067000*       (3)  MOVE 'A' TO PRICER-OPTION-SW.                    *
067100*            CALL 'LTOPN___' USING BILL-NEW-DATA              *
067200*                                  PPS-DATA-ALL               *
067200*                                  PPS-CBSA                   *
067300*                                  PRICER-OPT-VERS-SW         *
067500*                                  PROV-RECORD-FROM-USER      *
067600*                                  CBSAX-TABLE-FROM-USER      *
067600*                                  IPPS-CBSAX-TABLE-FROM-USER *
067600*                                  MSAX-TABLE-FROM-USER.      *
067700*      THIS IS THE ONLINE COMPATIBLE INTERFACE.               *
067800*      THIS PASSES THE STANDARD VARIABLES AND THE             *
068000*      THE PROVIDER RECORD AND THE WAGE INDEX TABLES FROM     *
068100*      THE USERS (CBSA, IPPS CBSA, & MSA WIX TBLS).           *
068200***************************************************************
068300
      **************************************************************
      *** APRIL 22, 2005 ADDED CBSA FIELD SEPARATE FROM PPS-DATA ***
      *** TO ACCOMODATE OLDER LTCAL VERSIONS                     ***
      **************************************************************
068400*** OPTION (1)
068500     MOVE ' ' TO PRICER-OPTION-SW.
068600     CALL  LTOPN130   USING BILL-NEW-DATA
068700                            PPS-DATA-ALL
068750                            PPS-CBSA
068800                            PRICER-OPT-VERS-SW.
069500*** OPTION (2)
069600*    MOVE 'P' TO PRICER-OPTION-SW.
069700*    CALL  LTOPN130   USING BILL-NEW-DATA
069800*                           PPS-DATA-ALL
068750*                           PPS-CBSA
069900*                           PRICER-OPT-VERS-SW
070100*                           PROV-RECORD-FROM-USER.
070200*** OPTION (3)
070300*    MOVE 'A' TO PRICER-OPTION-SW.
070400*    CALL  LTOPN130   USING BILL-NEW-DATA
070500*                           PPS-DATA-ALL
068750*                           PPS-CBSA
070600*                           PRICER-OPT-VERS-SW
070800*                           PROV-RECORD-FROM-USER
070900*                           CBSAX-TABLE-FROM-USER
070900*                           IPPS-CBSAX-TABLE-FROM-USER
070900*                           MSAX-TABLE-FROM-USER.
071000
071100 1000-EXIT.  EXIT.
071200
071200
071300 1100-WRITE-SYSUT2.
071400******************************************************************
071500*    PRINT OPERATING PROSPECTIVE PAYMENT TEST DATA DETAIL
071700******************************************************************
071800     IF  OPERLINE-CTR > 54
071900         PERFORM 1200-PPS-HEADINGS THRU 1200-EXIT.
072000     MOVE SPACES                TO  PPS-DETAIL-LINE-OPER.
072200     MOVE B-PROVIDER-NO         TO  PRT-PROV.
072301     MOVE PPS-LTR-DAYS-USED     TO  PRT-LTR-DAYS-USED.
072303     MOVE PPS-RELATIVE-WGT      TO  PRT-REL-WT.
072305     MOVE PPS-FAC-COSTS         TO  PRT-FAC-COST.
072500     MOVE PPS-AVG-LOS           TO  PRT-ALOS.
072510     MOVE PPS-LOS               TO  PRT-LOS.
073400     MOVE PPS-FINAL-PAY-AMT     TO  PRT-TOT-PAY.
073510     MOVE PPS-OUTLIER-THRESHOLD TO  PRT-OUT-THRESH.
073600     MOVE PPS-DRG-ADJ-PAY-AMT   TO  PRT-DRG-ADJ-PAY.
073700     MOVE PPS-OUTLIER-PAY-AMT   TO  PRT-OUTLIER-PAY.
073800     MOVE PPS-REG-DAYS-USED     TO  PRT-REG-DAYS-USED.
073800     MOVE PPS-NEW-FAC-SPEC-RATE TO  PRT-FAC-SPEC-RATE.
074300     MOVE PPS-RTC               TO  PRT-PPS-RTC.
074400     MOVE PPS-WAGE-INDEX        TO  PRT-WAGE-INDEX.
074500     IF PPS-RTC = 67
073510        MOVE PPS-CHRG-THRESHOLD TO  PRT-OUT-THRESH.
074400
074500     WRITE PRTOPER-LINE FROM PPS-DETAIL-LINE-OPER
074600                             AFTER ADVANCING 1.
074700     IF OPR-STAT1 > 0
074700        DISPLAY ' BAD4 WRITE ON PRTOPER FILE'.
074800     ADD 1 TO OPERLINE-CTR.
074900
078900 1100-EXIT.  EXIT.
079000
079100 1200-PPS-HEADINGS.
079200     WRITE PRTOPER-LINE FROM PPS-HEAD2-OPER
079300                             AFTER ADVANCING PAGE.
079400     IF OPR-STAT1 > 0
079400        DISPLAY ' BAD5 WRITE ON PRTOPER FILE'.
079800     WRITE PRTOPER-LINE FROM PPS-HEAD3-OPER
079900                             AFTER ADVANCING 2.
080000     IF OPR-STAT1 > 0
080000        DISPLAY ' BAD7 WRITE ON PRTOPER FILE'.
080100     WRITE PRTOPER-LINE FROM PPS-HEAD4-OPER
080200                             AFTER ADVANCING 1.
080300     IF OPR-STAT1 > 0
080300        DISPLAY ' BAD8 WRITE ON PRTOPER FILE'.
080400     MOVE ALL '  -' TO PRTOPER-LINE.
080500     WRITE PRTOPER-LINE AFTER ADVANCING 1.
080600     IF OPR-STAT1 > 0
080600        DISPLAY ' BAD9 WRITE ON PRTOPER FILE'.
080700     MOVE 4 TO OPERLINE-CTR.
080800
080900 1200-EXIT.  EXIT.
086600
086700*****        LAST STATEMENT               *************
