000100 IDENTIFICATION DIVISION.                                         09/22/93
000200 PROGRAM-ID.           PPCAL915.                                  PPCAL912
000300*AUTHOR.              DDS TEAM.                                      LV001
000400*REMARKS.         MODIFIED BY DDS TEAM.                              CL**1
000500*                        HCFA.                                       CL**1
000600 DATE-COMPILED.                                                      CL**1
000700 ENVIRONMENT DIVISION.                                               CL**1
000800 CONFIGURATION SECTION.                                              CL**1
000900 SOURCE-COMPUTER.            IBM-370.                                CL**1
001000 OBJECT-COMPUTER.            IBM-370.                                CL**1
001100 INPUT-OUTPUT  SECTION.                                              CL**1
001200 FILE-CONTROL.                                                       CL**1
001300                                                                     CL**1
001400 DATA DIVISION.                                                      CL**1
001500 FILE SECTION.                                                       CL**1
001600                                                                     CL**1
001700 WORKING-STORAGE SECTION.                                            CL**1
001800 77  PAN-VALET PICTURE X(24) VALUE '001PPCAL915  09/22/93'.          CL**1
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE                 CL**1
002000     'PPCAL915 - WORKING   STORAGE'.                                 CL**1
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C91.5'.        CL**1
002200 01  TABLES-LOADED-SW               PIC 9(01)  VALUE 0.              CL**1
002300 01  EOF-SW                         PIC 9(01)  VALUE 0.              CL**1
002400 01  SUBV                           PIC S9(04) COMP SYNC.            CL**1
002500 01  R1                             PIC S9(04) COMP SYNC.            CL**1
002600 01  R2                             PIC S9(04) COMP SYNC.            CL**1
002700 01  R3                             PIC S9(04) COMP SYNC.            CL**1
002800 01  R4                             PIC S9(04) COMP SYNC.            CL**1
002900 01  U1                             PIC S9(04) COMP SYNC.            CL**1
003000 01  U2                             PIC S9(04) COMP SYNC.            CL**1
003100 01  U3                             PIC S9(04) COMP SYNC.            CL**1
003200 01  F1                             PIC S9(04) COMP SYNC.            CL**1
003300 01  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.            CL**1
003400 01  HSP-FY                         PIC S9(04) COMP SYNC VALUE +1.   CL**1
003500 01  MO-DIFF                        PIC  9(03).                      CL**1
003600                                                                     CL**1
003700 01  BLEND-TABLE.                                                    CL**1
003800     05  BLEND-PCTS.                                                 CL**1
003900         10  FILLER      PIC X(15)  VALUE '075050045025000'.         CL**1
004000         10  FILLER      PIC X(15)  VALUE '025050055075100'.         CL**1
004100     05  FILLER REDEFINES BLEND-PCTS.                                CL**1
004200         10  HSP                    PIC 9(01)V9(02)  OCCURS 5.       CL**1
004300         10  FSP                    PIC 9(01)V9(02)  OCCURS 5.       CL**1
004400                                                                     CL**1
004500 01  CAL-MO-DAYS.                                                    CL**1
004600     05  CAL-YYMMDD.                                                 CL**1
004700         10  T-YY                   PIC 99.                          CL**1
004800         10  T-MM                   PIC 99.                          CL**1
004900         10  T-DD                   PIC 99.                          CL**1
005000     05  DAYS-MO.                                                    CL**1
005100         10  FILLER                 PIC X(36)  VALUE                 CL**1
005200            '000031059090120151181212243273304334'.                  CL**1
005300     05  FILLER           REDEFINES DAYS-MO.                         CL**1
005400         10  T-DAYS                 PIC 999 OCCURS 12.               CL**1
005500                                                                     CL**1
005600 01  HOLD-AREA.                                                      CL**1
005700     02  HOLD-DATES.                                                 CL**1
005800         05  HOLD-BILL-DATE.                                         CL**1
005900             10  H-BILL-YY              PIC 9(02).                   CL**1
006000             10  H-BILL-MM              PIC 9(02).                   CL**1
006100             10  H-BILL-DD              PIC 9(02).                   CL**1
006200         05  HOLD-BILL-DATE-9 REDEFINES HOLD-BILL-DATE               CL**1
006300                                        PIC 9(06).                   CL**1
006400         05  HOLD-BILL-DAYS             PIC 9(06).                   CL**1
006500                                                                     CL**1
006600         05  HOLD-PROV-DATE.                                         CL**1
006700             10  H-PROV-YY              PIC 9(02).                   CL**1
006800             10  H-PROV-MM              PIC 9(02).                   CL**1
006900             10  H-PROV-DD              PIC 9(02).                   CL**1
007000         05  HOLD-PROV-DATE-9 REDEFINES HOLD-PROV-DATE               CL**1
007100                                        PIC 9(06).                   CL**1
007200         05  HOLD-PROV-FYE-DATE.                                     CL**1
007300             10  H-FYE-YY               PIC 9(02).                   CL**1
007400             10  H-FYE-MMDD.                                         CL**1
007500             15  H-FYE-MM           PIC 9(02).                       CL**1
007600             15  H-FYE-DD           PIC 9(02).                       CL**1
007700         05  HOLD-PROV-FYE-9  REDEFINES HOLD-PROV-FYE-DATE           CL**1
007800                                        PIC 9(06).                   CL**1
007900         05  HOLD-PROV-DAYS             PIC 9(06).                   CL**1
008000                                                                     CL**1
008100     02  H-IND-TEACHING                 PIC  9(06)V9(09).            CL**1
008200     02  H-DSH-PERCENT                  PIC  V9(04).                 CL**1
008300                                                                     CL**1
008400     02  HOLD-PROV-MSA.                                              CL**1
008500         05  H-PROV-BLANK               PIC X(02).                   CL**1
008600         05  H-PROV-STATE               PIC X(02).                   CL**1
008700                                                                     CL**1
008800     02  HOLD-PPS-COMPONENTS.                                        CL**1
008900         05  H-HSP-PART                 PIC 9(06)V9(09).             CL**1
009000         05  H-FSP-PART                 PIC 9(06)V9(09).             CL**1
009100         05  H-OUTLIER-PART             PIC 9(07)V9(09).             CL**1
009200         05  H-OUTDAY-PART              PIC 9(07)V9(09).             CL**1
009300         05  H-OUTCST-PART              PIC 9(07)V9(09).             CL**1
009400         05  H-COV-DAYS                 PIC 9(03).                   CL**1
009500         05  H-REG-DAYS                 PIC 9(03).                   CL**1
009600         05  H-LTR-DAYS                 PIC 9(03).                   CL**1
009700         05  H-WAGE-INDX                PIC 9(02)V9(04).             CL**1
009800         05  H-ALOS                     PIC 9(02)V9(01).             CL**1
009900         05  H-DAYS-CUTOFF              PIC 9(02)V9(01).             CL**1
010000         05  H-DAYOUT-PCT               PIC 9(01)V9(02).             CL**1
010100         05  H-CSTOUT-PCT               PIC 9(01)V9(02).             CL**1
010200         05  H-CSTCHG-RATIO             PIC 9(01)V9(03).             CL**1
010300         05  H-CST-MULTIPLE             PIC 9(01)V9(03).             CL**1
010400         05  H-CST-THRESH               PIC 9(05)V9(02).             CL**1
010500         05  H-LABOR-PCT                PIC 9(01)V9(04).             CL**1
010600         05  H-NLABOR-PCT               PIC 9(01)V9(04).             CL**1
010700                                                                     CL**1
010800     02  HOLD-ADDITIONAL-VARIABLES.                                  CL**1
010900         05  H-HSP-PCT                  PIC 9(01)V9(02).             CL**1
011000         05  H-FSP-PCT                  PIC 9(01)V9(02).             CL**1
011100         05  H-NAT-PCT                  PIC 9(01)V9(02).             CL**1
011200         05  H-REG-PCT                  PIC 9(01)V9(02).             CL**1
011300         05  H-CMI-ADJ-CPD              PIC 9(05)V9(02).             CL**1
011400         05  H-UPDATE-FACTOR            PIC 9(01)V9(05).             CL**1
011500         05  H-DRG-WT                   PIC 9(02)V9(04).             CL**1
011600         05  H-NAT-LABOR                PIC 9(05)V9(02).             CL**1
011700         05  H-NAT-NLABOR               PIC 9(05)V9(02).             CL**1
011800         05  H-REG-LABOR                PIC 9(05)V9(02).             CL**1
011900         05  H-REG-NLABOR               PIC 9(05)V9(02).             CL**1
012000         05  H-COLA                     PIC 9(01)V9(03).             CL**1
012100         05  H-INTERN-RATIO             PIC 9(01)V9(04).             CL**1
012200         05  H-COST-OUTLIER             PIC 9(07)V9(09).             CL**1
012300         05  H-BILL-COSTS               PIC 9(07)V9(09).             CL**1
012400         05  H-DOLLAR-THRESHOLD         PIC 9(07)V9(09).             CL**1
012500                                                                     CL**1
012600     02  HOLD-WORK-VARIABLES.                                        CL**1
012700         05  H-HSP-RATE                 PIC 9(06)V9(09).             CL**1
012800         05  H-FSP-RATE                 PIC 9(06)V9(09).             CL**1
012900         05  OUTLIER-FACT               PIC 9(01)V9(06).             CL**1
013000                                                                     CL**1
013100***************************************************************      CL**1
013200*    LAYUP TABLE AREA                                         *      CL**1
013300***************************************************************      CL**1
013400 01  RATE-TABLE2.                                                    CL**1
013500     02  RATE-WORK2.                                                 CL**1
013600*RATE 901001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
013700     05  FILLER PIC X(06) VALUE '901001'.                            CL**1
013800     05  FILLER PIC X(45) VALUE                                      CL**1
013900        ' 0265371 108711 0261170 106989 0271225 093539'.             CL**1
014000     05  FILLER PIC X(45) VALUE                                      CL**1
014100        ' 0238412 102990 0234638 101360 0259752 088428'.             CL**1
014200     05  FILLER PIC X(45) VALUE                                      CL**1
014300        ' 0254497 095049 0250468 093544 0248312 076678'.             CL**1
014400     05  FILLER PIC X(45) VALUE                                      CL**1
014500        ' 0268432 112459 0264183 110678 0251448 085222'.             CL**1
014600     05  FILLER PIC X(45) VALUE                                      CL**1
014700        ' 0244247 086065 0240380 084703 0246102 071504'.             CL**1
014800     05  FILLER PIC X(45) VALUE                                      CL**1
014900        ' 0254569 102469 0250539 100846 0239194 076391'.             CL**1
015000     05  FILLER PIC X(45) VALUE                                      CL**1
015100        ' 0253105 094406 0249097 092911 0229396 070253'.             CL**1
015200     05  FILLER PIC X(45) VALUE                                      CL**1
015300        ' 0244155 101122 0240290 099520 0231980 080800'.             CL**1
015400     05  FILLER PIC X(45) VALUE                                      CL**1
015500        ' 0237496 115510 0233736 113681 0225621 091026'.             CL**1
015600     05  FILLER PIC X(45) VALUE                                      CL**1
015700        ' 0252696 104108 0248695 102460 0244635 078818'.             CL**1
015800     05  FILLER PIC X(45) VALUE                                      CL**1
015900        ' 0227274 047267 0223675 046519 0166750 035948'.             CL**1
016000     05  FILLER PIC X(45) VALUE                                      CL**1
016100        ' 0249201 097111 0249201 097111 0249201 097111'.             CL**1
016200*RATE 901021 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
016300     05  FILLER PIC X(06) VALUE '901021'.                            CL**1
016400     05  FILLER PIC X(45) VALUE                                      CL**1
016500        ' 0252711 103525 0248711 101885 0258286 089077'.             CL**1
016600     05  FILLER PIC X(45) VALUE                                      CL**1
016700        ' 0227038 098077 0223444 096525 0247360 084209'.             CL**1
016800     05  FILLER PIC X(45) VALUE                                      CL**1
016900        ' 0242356 090514 0238519 089082 0236466 073020'.             CL**1
017000     05  FILLER PIC X(45) VALUE                                      CL**1
017100        ' 0255626 107094 0251580 105398 0239452 081157'.             CL**1
017200     05  FILLER PIC X(45) VALUE                                      CL**1
017300        ' 0232595 081959 0228913 080663 0234361 068093'.             CL**1
017400     05  FILLER PIC X(45) VALUE                                      CL**1
017500        ' 0242425 097581 0238587 096035 0227783 072747'.             CL**1
017600     05  FILLER PIC X(45) VALUE                                      CL**1
017700        ' 0241030 089902 0237214 088478 0218452 066901'.             CL**1
017800     05  FILLER PIC X(45) VALUE                                      CL**1
017900        ' 0232508 096298 0228827 094772 0220913 076946'.             CL**1
018000     05  FILLER PIC X(45) VALUE                                      CL**1
018100        ' 0226166 109999 0222586 108258 0214857 086683'.             CL**1
018200     05  FILLER PIC X(45) VALUE                                      CL**1
018300        ' 0240641 099142 0236831 097572 0232965 075058'.             CL**1
018400     05  FILLER PIC X(45) VALUE                                      CL**1
018500        ' 0216432 045012 0213005 044299 0158795 034233'.             CL**1
018600     05  FILLER PIC X(45) VALUE                                      CL**1
018700        ' 0237313 092478 0237313 092478 0237313 092478'.             CL**1
018800*RATE 910101 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
018900     05  FILLER PIC X(06) VALUE '910101'.                            CL**1
019000     05  FILLER PIC X(45) VALUE                                      CL**1
019100        ' 0260503 106716 0256378 105026 0269937 093096'.             CL**1
019200     05  FILLER PIC X(45) VALUE                                      CL**1
019300        ' 0234038 101101 0230333 099500 0258518 088007'.             CL**1
019400     05  FILLER PIC X(45) VALUE                                      CL**1
019500        ' 0249828 093305 0245872 091828 0247132 076314'.             CL**1
019600     05  FILLER PIC X(45) VALUE                                      CL**1
019700        ' 0263508 110396 0259336 108648 0250254 084817'.             CL**1
019800     05  FILLER PIC X(45) VALUE                                      CL**1
019900        ' 0239766 084486 0235969 083149 0244934 071164'.             CL**1
020000     05  FILLER PIC X(45) VALUE                                      CL**1
020100        ' 0249899 100589 0245943 098996 0238058 076028'.             CL**1
020200     05  FILLER PIC X(45) VALUE                                      CL**1
020300        ' 0248461 092673 0244527 091207 0228307 069919'.             CL**1
020400     05  FILLER PIC X(45) VALUE                                      CL**1
020500        ' 0239676 099266 0235882 097694 0230879 080417'.             CL**1
020600     05  FILLER PIC X(45) VALUE                                      CL**1
020700        ' 0233139 113390 0229448 111595 0224550 090593'.             CL**1
020800     05  FILLER PIC X(45) VALUE                                      CL**1
020900        ' 0248060 102198 0244133 100580 0243474 078443'.             CL**1
021000     05  FILLER PIC X(45) VALUE                                      CL**1
021100        ' 0223104 046400 0219571 045665 0165958 035777'.             CL**1
021200     05  FILLER PIC X(45) VALUE                                      CL**1
021300        ' 0245471 095600 0245471 095600 0245471 095600'.             CL**1
021400     02  RATE-TAB2 REDEFINES RATE-WORK2.                             CL**1
021500     05  RATE-PERIOD2            OCCURS 3.                           CL**1
021600         10  RATE-EFF-DATE2      PIC X(06).                          CL**1
021700         10  REG-NAT2            OCCURS 12.                          CL**1
021800             15  R-URBAN-RURAL2  OCCURS 3.                           CL**1
021900                 20  FILLER      PIC X(01).                          CL**1
022000                 20  REG-LABOR2  PIC 9(05)V9(02).                    CL**1
022100                 20  FILLER      PIC X(01).                          CL**1
022200                 20  REG-NLABOR2 PIC 9(04)V9(02).                    CL**1
022300                                                                     CL**1
022400                                                                     CL**1
022500 01  UPDT-ENTRIES2              PIC 9(02) VALUE 2.                   CL**1
022600 01  UPDT-TABLE2.                                                    CL**1
022700     02  UPDT-WORK2.                                                 CL**1
022800*UPDT 891001 UPDATING FACTORS EFFECTIVE DATE                         CL**1
022900*     LURBAN=1.0550 OURBAN=1.0550 RURAL=1.0550 (OCT - DEC)           CL**1
023000     05  FILLER PIC X(06) VALUE '891001'.                            CL**1
023100     05  FILLER PIC X(27) VALUE '830131 134165 132858 136805'.       CL**1
023200     05  FILLER PIC X(27) VALUE '830228 134300 132993 136944'.       CL**1
023300     05  FILLER PIC X(27) VALUE '830331 134434 133125 137080'.       CL**1
023400     05  FILLER PIC X(27) VALUE '830430 134572 133261 137221'.       CL**1
023500     05  FILLER PIC X(27) VALUE '830531 134708 133395 137359'.       CL**1
023600     05  FILLER PIC X(27) VALUE '830630 134845 133531 137499'.       CL**1
023700     05  FILLER PIC X(27) VALUE '830731 134981 133666 137637'.       CL**1
023800     05  FILLER PIC X(27) VALUE '830831 135116 133800 137777'.       CL**1
023900     05  FILLER PIC X(27) VALUE '820930 134952 133639 137609'.       CL**1
024000     05  FILLER PIC X(27) VALUE '821031 134645 133334 137296'.       CL**1
024100     05  FILLER PIC X(27) VALUE '821130 134335 133027 136980'.       CL**1
024200     05  FILLER PIC X(27) VALUE '821231 134027 132721 136665'.       CL**1
024300*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE                         CL**1
024400*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)           CL**1
024500     05  FILLER PIC X(06) VALUE '900101'.                            CL**1
024600     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.       CL**1
024700     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.       CL**1
024800     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.       CL**1
024900     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.       CL**1
025000     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.       CL**1
025100     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.       CL**1
025200     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.       CL**1
025300     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.       CL**1
025400     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.       CL**1
025500     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.       CL**1
025600     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.       CL**1
025700     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.       CL**1
025800     02  UPDATE-TABLE2 REDEFINES UPDT-WORK2.                         CL**1
025900     05  UPDT-PERIOD2             OCCURS 2.                          CL**1
026000         10  UPDT-EFF-DATE2       PIC X(06).                         CL**1
026100         10  UPDT-MONTH2          OCCURS 12.                         CL**1
026200             15  UP-BASE-DATE2    PIC X(06).                         CL**1
026300             15  UP-L-O-R2        OCCURS 3.                          CL**1
026400                 20  FILLER           PIC X(01).                     CL**1
026500                 20  UPDATE-FACTOR2   PIC 9(01)V9(05).               CL**1
026600                                                                     CL**1
026700 01  DRG-TABLE3.                                                     CL**1
026800     05  D-TAB3.                                                     CL**1
026900         10  FILLER                  PIC X(06) VALUE                 CL**1
027000        '901001'.                                                    CL**1
027100         10  FILLER                  PIC X(44) VALUE                 CL**1
027200        '03358012942035485121410288301274202453210840'.              CL**1
027300         10  FILLER                  PIC X(44) VALUE                 CL**1
027400        '01524605835004823020190268231154100745103032'.              CL**1
027500         10  FILLER                  PIC X(44) VALUE                 CL**1
027600        '01222906936012765078370077710473400925606936'.              CL**1
027700         10  FILLER                  PIC X(44) VALUE                 CL**1
027800        '00872607136012212073360064200423301070306736'.              CL**1
027900         10  FILLER                  PIC X(44) VALUE                 CL**1
028000        '00632604433008749060350056290393301868308437'.              CL**1
028100         10  FILLER                  PIC X(44) VALUE                 CL**1
028200        '01443907537007206044330083220433300960205334'.              CL**1
028300         10  FILLER                  PIC X(44) VALUE                 CL**1
028400        '00519703528008176040330134810433301206005935'.              CL**1
028500         10  FILLER                  PIC X(44) VALUE                 CL**1
028600        '00567403332003496020170069330423300410002725'.              CL**1
028700         10  FILLER                  PIC X(44) VALUE                 CL**1
028800        '00242701609011714060350054640363300648702313'.              CL**1
028900         10  FILLER                  PIC X(44) VALUE                 CL**1
029000        '00743102932003614022170044560160800492302021'.              CL**1
029100         10  FILLER                  PIC X(44) VALUE                 CL**1
029200        '00361301607006202022160038670403200597905535'.              CL**1
029300         10  FILLER                  PIC X(44) VALUE                 CL**1
029400        '00565003429006701042330036080262800396902930'.              CL**1
029500         10  FILLER                  PIC X(44) VALUE                 CL**1
029600        '02327307436006413022140058220212000739402625'.              CL**1
029700         10  FILLER                  PIC X(44) VALUE                 CL**1
029800        '00630801919006806032220049050161300498201713'.              CL**1
029900         10  FILLER                  PIC X(44) VALUE                 CL**1
030000        '00877403432003060015040041920161200258401504'.              CL**1
030100         10  FILLER                  PIC X(44) VALUE                 CL**1
030200        '00765602331003052013050101110383301065105034'.              CL**1
030300         10  FILLER                  PIC X(44) VALUE                 CL**1
030400        '00463603323004528033240084780433300720904933'.              CL**1
030500         10  FILLER                  PIC X(44) VALUE                 CL**1
030600        '00508603824002830023130070300432700554703232'.              CL**1
030700         10  FILLER                  PIC X(44) VALUE                 CL**1
030800        '00729104133003386021200298601174102307410539'.              CL**1
030900         10  FILLER                  PIC X(44) VALUE                 CL**1
031000        '01041304634014372088380181440933801040406836'.              CL**1
031100         10  FILLER                  PIC X(44) VALUE                 CL**1
031200        '01089906135012178067360096280633500484603728'.              CL**1
031300         10  FILLER                  PIC X(44) VALUE                 CL**1
031400        '01150906836006961044330138950603500997305935'.              CL**1
031500         10  FILLER                  PIC X(44) VALUE                 CL**1
031600        '01187807236007538056310081410523401213106936'.              CL**1
031700         10  FILLER                  PIC X(44) VALUE                 CL**1
031800        '00759804934012763072360065330463400956806035'.              CL**1
031900         10  FILLER                  PIC X(44) VALUE                 CL**1
032000        '00656104626006135046220083610443300509002719'.              CL**1
032100         10  FILLER                  PIC X(44) VALUE                 CL**1
032200        '00918105134005400034321290862505408064118347'.              CL**1
032300         10  FILLER                  PIC X(44) VALUE                 CL**1
032400        '06075013042054227139430478991124005964912942'.              CL**1
032500         10  FILLER                  PIC X(44) VALUE                 CL**1
032600        '00000000000042644105390244930813701991004934'.              CL**1
032700         10  FILLER                  PIC X(44) VALUE                 CL**1
032800        '02627914544015827093380377051214102519005835'.              CL**1
032900         10  FILLER                  PIC X(44) VALUE                 CL**1
033000        '01352003833017375030320081690343202514310239'.              CL**1
033100         10  FILLER                  PIC X(44) VALUE                 CL**1
033200        '01577208237011152059350137040303201181604333'.              CL**1
033300         10  FILLER                  PIC X(44) VALUE                 CL**1
033400        '00701502221029543170460100400613500806107734'.              CL**1
033500         10  FILLER                  PIC X(44) VALUE                 CL**1
033600        '01324202632008969060350058410443300725204133'.              CL**1
033700         10  FILLER                  PIC X(44) VALUE                 CL**1
033800        '00520503126005992042330086230493400550703326'.              CL**1
033900         10  FILLER                  PIC X(44) VALUE                 CL**1
034000        '00623903332008331046340053250322400629603825'.              CL**1
034100         10  FILLER                  PIC X(44) VALUE                 CL**1
034200        '00689904433005012032220051400281801084905534'.              CL**1
034300         10  FILLER                  PIC X(44) VALUE                 CL**1
034400        '00593303229025864130420164060953603199613943'.              CL**1
034500         10  FILLER                  PIC X(44) VALUE                 CL**1
034600        '01604409431025312118410127770743601476907637'.              CL**1
034700         10  FILLER                  PIC X(44) VALUE                 CL**1
034800        '01017006433036320124410147680743600828106035'.              CL**1
034900         10  FILLER                  PIC X(44) VALUE                 CL**1
035000        '00924804834004877026190107970513400616603122'.              CL**1
035100         10  FILLER                  PIC X(44) VALUE                 CL**1
035200        '00723803332004428020120063970323202269910339'.              CL**1
035300         10  FILLER                  PIC X(44) VALUE                 CL**1
035400        '01294407225013818066360077450421600980603733'.              CL**1
035500         10  FILLER                  PIC X(44) VALUE                 CL**1
035600        '00555802118027171111400115830573501244507236'.              CL**1
035700         10  FILLER                  PIC X(44) VALUE                 CL**1
035800        '00635803833009537055340057560392400983005935'.              CL**1
035900         10  FILLER                  PIC X(44) VALUE                 CL**1
036000        '00780305233005564039220108950713600916505835'.              CL**1
036100         10  FILLER                  PIC X(44) VALUE                 CL**1
036200        '00513004027007497049340052000352500680103232'.              CL**1
036300         10  FILLER                  PIC X(44) VALUE                 CL**1
036400        '00754804333004062029230048140222200963205134'.              CL**1
036500         10  FILLER                  PIC X(44) VALUE                 CL**1
036600        '00480202932006312040280469411594501966209238'.              CL**1
036700         10  FILLER                  PIC X(44) VALUE                 CL**1
036800        '03010214343017387098390221751104001418308230'.              CL**1
036900         10  FILLER                  PIC X(44) VALUE                 CL**1
037000        '01733608638009445055200231681194102894010139'.              CL**1
037100         10  FILLER                  PIC X(44) VALUE                 CL**1
037200        '02421008938012019072360113010683601061706135'.              CL**1
037300         10  FILLER                  PIC X(44) VALUE                 CL**1
037400        '01198506736006210038330095690553500559903427'.              CL**1
037500         10  FILLER                  PIC X(44) VALUE                 CL**1
037600        '02368910638019939120410143020963800998104516'.              CL**1
037700         10  FILLER                  PIC X(44) VALUE                 CL**1
037800        '01756209739019298100390115500663501850209538'.              CL**1
037900         10  FILLER                  PIC X(44) VALUE                 CL**1
038000        '03117314143014748077370091940493100913005334'.              CL**1
038100         10  FILLER                  PIC X(44) VALUE                 CL**1
038200        '01591906936009134038330082600352800622402617'.              CL**1
038300         10  FILLER                  PIC X(44) VALUE                 CL**1
038400        '00742103232013371063350066040292600814802730'.              CL**1
038500         10  FILLER                  PIC X(44) VALUE                 CL**1
038600        '00535801916008508040330093060363300998103633'.              CL**1
038700         10  FILLER                  PIC X(44) VALUE                 CL**1
038800        '01841608938008322041330113830783700851606736'.              CL**1
038900         10  FILLER                  PIC X(44) VALUE                 CL**1
039000        '00542404333015682104390100350753701119707136'.              CL**1
039100         10  FILLER                  PIC X(44) VALUE                 CL**1
039200        '00585204834012566082370065800503400722805434'.              CL**1
039300         10  FILLER                  PIC X(44) VALUE                 CL**1
039400        '00500804033005736045330053320373300634204433'.              CL**1
039500         10  FILLER                  PIC X(44) VALUE                 CL**1
039600        '00632003933006757044330043150252400345401815'.              CL**1
039700         10  FILLER                  PIC X(44) VALUE                 CL**1
039800        '00787105935004303036330045820293200626703933'.              CL**1
039900         10  FILLER                  PIC X(44) VALUE                 CL**1
040000        '00921905026007178040160095810443300576402516'.              CL**1
040100         10  FILLER                  PIC X(44) VALUE                 CL**1
040200        '00650902315004537019150277501604501356909238'.              CL**1
040300         10  FILLER                  PIC X(44) VALUE                 CL**1
040400        '01353806135006682030320060030283200721002732'.              CL**1
040500         10  FILLER                  PIC X(44) VALUE                 CL**1
040600        '01706308337006709032320125680903801017707236'.              CL**1
040700         10  FILLER                  PIC X(44) VALUE                 CL**1
040800        '00666405535011101066360054430323200571003633'.              CL**1
040900         10  FILLER                  PIC X(44) VALUE                 CL**1
041000        '00926907136006278054310072780422400653804634'.              CL**1
041100         10  FILLER                  PIC X(44) VALUE                 CL**1
041200        '00416903231003383022190074010543400454403633'.              CL**1
041300         10  FILLER                  PIC X(44) VALUE                 CL**1
041400        '02782215545024946101390223111364301969107436'.              CL**1
041500         10  FILLER                  PIC X(44) VALUE                 CL**1
041600        '00995404333007394030180048820181002820312141'.              CL**1
041700         10  FILLER                  PIC X(44) VALUE                 CL**1
041800        '01068605635007533059350074330443300938706135'.              CL**1
041900         10  FILLER                  PIC X(44) VALUE                 CL**1
042000        '00536104132005694032320080090463401121607136'.              CL**1
042100         10  FILLER                  PIC X(44) VALUE                 CL**1
042200        '00618704333039581146440264161194102419210339'.              CL**1
042300         10  FILLER                  PIC X(44) VALUE                 CL**1
042400        '01216805534013240072360073340422401473606536'.              CL**1
042500         10  FILLER                  PIC X(44) VALUE                 CL**1
042600        '00781503332008741041330051780241700789803833'.              CL**1
042700         10  FILLER                  PIC X(44) VALUE                 CL**1
042800        '00476902320004271023260219220753601268406435'.              CL**1
042900         10  FILLER                  PIC X(44) VALUE                 CL**1
043000        '00349902221010885061350055860273201005506736'.              CL**1
043100         10  FILLER                  PIC X(44) VALUE                 CL**1
043200        '00650705029006387044290075100293200393202215'.              CL**1
043300         10  FILLER                  PIC X(44) VALUE                 CL**1
043400        '00666604433004286030250054440313200634603833'.              CL**1
043500         10  FILLER                  PIC X(44) VALUE                 CL**1
043600        '00416802318002754016090094930533400544703232'.              CL**1
043700         10  FILLER                  PIC X(44) VALUE                 CL**1
043800        '01041505134017911094360133750792300932605328'.              CL**1
043900         10  FILLER                  PIC X(44) VALUE                 CL**1
044000        '00632903913007662030320058800242900428302413'.              CL**1
044100         10  FILLER                  PIC X(44) VALUE                 CL**1
044200        '00985003528004971023240037420170601081104834'.              CL**1
044300         10  FILLER                  PIC X(44) VALUE                 CL**1
044400        '00745003833009561058350048520253200683503933'.              CL**1
044500         10  FILLER                  PIC X(44) VALUE                 CL**1
044600        '00384702220006657049290032930130500515803030'.              CL**1
044700         10  FILLER                  PIC X(44) VALUE                 CL**1
044800        '02114810940013937076350086760541500713904418'.              CL**1
044900         10  FILLER                  PIC X(44) VALUE                 CL**1
045000        '02228610640011515065260078870491300764304233'.              CL**1
045100         10  FILLER                  PIC X(44) VALUE                 CL**1
045200        '00812503232004921021230064210333000487602424'.              CL**1
045300         10  FILLER                  PIC X(44) VALUE                 CL**1
045400        '01752107937011937066360047910283200863906035'.              CL**1
045500         10  FILLER                  PIC X(44) VALUE                 CL**1
045600        '00519803332009284060330062770431100454103019'.              CL**1
045700         10  FILLER                  PIC X(44) VALUE                 CL**1
045800        '00296302108005204028120067350442900364602622'.              CL**1
045900         10  FILLER                  PIC X(44) VALUE                 CL**1
046000        '00675703032006686036160026510211800294301912'.              CL**1
046100         10  FILLER                  PIC X(44) VALUE                 CL**1
046200        '00372701510001101011030038540343200283302327'.              CL**1
046300         10  FILLER                  PIC X(44) VALUE                 CL**1
046400        '01208401831036039179470180461334201143108638'.              CL**1
046500         10  FILLER                  PIC X(44) VALUE                 CL**1
046600        '01426605334010001045340021910311103261112141'.              CL**1
046700         10  FILLER                  PIC X(44) VALUE                 CL**1
046800        '01502209138015388057350074710463400361502123'.              CL**1
046900         10  FILLER                  PIC X(44) VALUE                 CL**1
047000        '01157705535011795065350065760393302707310139'.              CL**1
047100         10  FILLER                  PIC X(44) VALUE                 CL**1
047200        '02207110239008877039330160190823700747404333'.              CL**1
047300         10  FILLER                  PIC X(44) VALUE                 CL**1
047400        '01028104934026994114400124380603501051104233'.              CL**1
047500         10  FILLER                  PIC X(44) VALUE                 CL**1
047600        '01021306736005123027190043200252800407202221'.              CL**1
047700         10  FILLER                  PIC X(44) VALUE                 CL**1
047800        '01307307436007062044330359571504401532007537'.              CL**1
047900         10  FILLER                  PIC X(44) VALUE                 CL**1
048000        '01076805334009816067360095150593500661204531'.              CL**1
048100         10  FILLER                  PIC X(44) VALUE                 CL**1
048200        '00651704332007604037330159280803702365213342'.              CL**1
048300         10  FILLER                  PIC X(44) VALUE                 CL**1
048400        '00689004634006290057350064280563500706506435'.              CL**1
048500         10  FILLER                  PIC X(44) VALUE                 CL**1
048600        '00921607637009026089380064220543400740504333'.              CL**1
048700         10  FILLER                  PIC X(44) VALUE                 CL**1
048800        '00382903132007649055350050070453400997913543'.              CL**1
048900         10  FILLER                  PIC X(44) VALUE                 CL**1
049000        '01143713943000000000000166890723602537410640'.              CL**1
049100         10  FILLER                  PIC X(44) VALUE                 CL**1
049200        '00718902632018473056350114670403300762105134'.              CL**1
049300         10  FILLER                  PIC X(44) VALUE                 CL**1
049400        '00490603632004738024220048220262400342802917'.              CL**1
049500         10  FILLER                  PIC X(44) VALUE                 CL**1
049600        '00790404333004485026250051260383300931704734'.              CL**1
049700         10  FILLER                  PIC X(44) VALUE                 CL**1
049800        '00477503132009488045340042820252501513804133'.              CL**1
049900         10  FILLER                  PIC X(44) VALUE                 CL**1
050000        '02131702932037539158450207111094001060706435'.              CL**1
050100         10  FILLER                  PIC X(44) VALUE                 CL**1
050200        '00777102431018435141430074620513400470003231'.              CL**1
050300         10  FILLER                  PIC X(44) VALUE                 CL**1
050400        '00399501921005749026320042260253103414613442'.              CL**1
050500         10  FILLER                  PIC X(44) VALUE                 CL**1
050600        '00000000000000000000000394921424311763721050'.              CL**1
050700         10  FILLER                  PIC X(44) VALUE                 CL**1
050800        '03295309939000000000000354920973902181614443'.              CL**1
050900         10  FILLER                  PIC X(44) VALUE                 CL**1
051000        '01439506235024189091380132080463415264522852'.              CL**1
051100         10  FILLER                  PIC X(44) VALUE                 CL**1
051200        '12448536666032660142431405974006906997213543'.              CL**1
051300         10  FILLER                  PIC X(44) VALUE                 CL**1
051400        '03262114644049603125410183240763704129618848'.              CL**1
051500         10  FILLER                  PIC X(44) VALUE                 CL**1
051600        '02067410239011808059350000000000000000000000'.              CL**1
051700     05  DRGX-TAB3 REDEFINES D-TAB3.                                 CL**1
051800     10  DRGX-PERIOD3               OCCURS 1                         CL**1
051900                                    INDEXED BY DX5.                  CL**1
052000         15  DRGX-EFF-DATE3         PIC X(06).                       CL**1
052100         15  DRG-DATA3              OCCURS 492                       CL**1
052200                                    INDEXED BY DX6.                  CL**1
052300             20  DRG-WT3            PIC 9(02)V9(04).                 CL**1
052400             20  DRG-ALOS3          PIC 9(02)V9(01).                 CL**1
052500             20  DRG-DAYS-TRIM3     PIC 9(02).                       CL**1
052600                                                                     CL**1
052700 LINKAGE SECTION.                                                    CL**1
052800***************************************************************      CL**1
052900*                 * * * * * * * * *                           *      CL**1
053000*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *      CL**1
053100*    IN HOW TO PAY THE BILL.                                  *      CL**1
053200*         REVIEW-CODE:                                        *      CL**1
053300*            00 = PAY-WITH-OUTLIER.                           *      CL**1
053400*                 WILL CALCULATE THE STANDARD PAYMENT.        *      CL**1
053500*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *      CL**1
053600*                 OUTLIERS. PPS-RTC CODES 01 AND 02 NOW SENT  *      CL**1
053700*                 TO THE PRO FOR POST PAYMENT REVIEW.       . *      CL**1
053800*            01 = PAY-DAYS-OUTLIER.                           *      CL**1
053900*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *      CL**1
054000*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *      CL**1
054100*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *      CL**1
054200*                 OUTLIER CUTOFF FOR THE DRG.                 *      CL**1
054300*            02 = PAY-COST-OUTLIER.                           *      CL**1
054400*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *      CL**1
054500*                 ALSO CALCULATE THE COST OUTLIER PORTION OF  *      CL**1
054600*                 THE PAYMENT IF THE ADJUSTED CHARGES ON THE  *      CL**1
054700*                 BILL EXCEED THE COST THRESHOLD.             *      CL**1
054800*                 IF  LENGTH OF STAY EXCEED OUTLIER CUTOFF, NO*      CL**1
054900*                 PAYMENT WILL BE MADE AND A RETURN-CODE OF   *      CL**1
055000*                 60 WILL BE RETURNED.                        *      CL**1
055100*            03 = PAY-PERDIEM-DAYS.                           *      CL**1
055200*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *      CL**1
055300*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *      CL**1
055400*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *      CL**1
055500*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *      CL**1
055600*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *      CL**1
055700*                 STANDARD PAYMENT IS CALCULATED.             *      CL**1
055800*                 TRANSFERS AFTER 093084 POTENTIALLY          *      CL**1
055900*                 ELIGABLE FOR COST OUTLIER PAYMENT.          *      CL**1
056000*            04 = PAY-AVG-STAY-ONLY.                          *      CL**1
056100*                 WILL CALCULATE THE STANDARD PAYMENT.        *      CL**1
056200*                 WILL NOT TEST FOR DAYS OR COST OUTLIERS.    *      CL**1
056300*            05 = PAY-XFER-WITH-COST                          *      CL**1
056400*                 PAY TRANSFER WITH COST OUTLIER APPROVED.    *      CL**1
056500*            06 = PAY-XFER-NO-COST                            *      CL**1
056600*                 PAY TRANSFER WITH COST OUTLIER DENIED.      *      CL**1
056700*            07 = PAY-WITHOUT-COST                            *      CL**1
056800*                 PAY WITHOUT COST OUTLIER.                   *      CL**1
056900*                                                             *      CL**1
057000***************************************************************      CL**1
057100 01  BILL-DATA.                                                      CL**1
057200         10  B-PROVIDER-NO          PIC X(06).                       CL**1
057300         10  B-REVIEW-CODE          PIC 9(02).                       CL**1
057400             88  VALID-REVIEW-CODE  VALUE 00 THRU 07.                CL**1
057500             88  PAY-WITH-OUTLIER   VALUE 00 07.                     CL**1
057600             88  PAY-DAYS-OUTLIER   VALUE 01.                        CL**1
057700             88  PAY-COST-OUTLIER   VALUE 02.                        CL**1
057800             88  PAY-PERDIEM-DAYS   VALUE 03.                        CL**1
057900             88  PAY-AVG-STAY-ONLY  VALUE 04.                        CL**1
058000             88  PAY-XFER-WITH-COST VALUE 05.                        CL**1
058100             88  PAY-XFER-NO-COST   VALUE 06.                        CL**1
058200             88  PAY-WITHOUT-COST   VALUE 07.                        CL**1
058300         10  B-DRG                  PIC 9(03).                       CL**1
058400         10  B-LOS                  PIC 9(03).                       CL**1
058500         10  B-COVERED-DAYS         PIC 9(03).                       CL**1
058600         10  B-LTR-DAYS             PIC 9(02).                       CL**1
058700         10  B-DISCHARGE-DATE.                                       CL**1
058800             15  B-DISCHG-MM        PIC 9(02).                       CL**1
058900             15  B-DISCHG-DD        PIC 9(02).                       CL**1
059000             15  B-DISCHG-YY        PIC 9(02).                       CL**1
059100         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).                 CL**1
059200                                                                     CL**1
059300***************************************************************      CL**1
059400*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *      CL**1
059500*    AND PASSED BACK TO THE CALLING PROGRAM                   *      CL**1
059600*            RETURN CODE VALUES (PPS-RTC)                     *      CL**1
059700*                                                             *      CL**1
059800*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *      CL**1
059900*              00 = PAID NORMAL DRG PAYMENT                   *      CL**1
060000*                                                             *      CL**1
060100*              01 = PAID AS A DAY-OUTLIER. SEND TO PRO FOR    *      CL**1
060200*                   POST PAYMENT REVIEW.                      *      CL**1
060300*              02 = PAID AS A COST-OUTLIER. SEND TO PRO FOR   *      CL**1
060400*                   POST PAYMENT REVIEW.                      *      CL**1
060500*              03 = PAID ON PERDIEM BASIS (XFER OR REVIEW 03) *      CL**1
060600*                   NOT POTENTIALLY ELIGEABLE FOR COST OUTLIER*      CL**1
060700*              04 = PAID NORMAL DRG PAYMENT ONLY. DAY AND     *      CL**1
060800*                   COST OUTLIER CRITERIA IGNORED.            *      CL**1
060900*              05 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *      CL**1
061000*                   OUTLIER APPROVED.                         *      CL**1
061100*              06 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *      CL**1
061200*                   OUTLIER DENIED.                           *      CL**1
061300*                                                             *      CL**1
061400*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *      CL**1
061500*              51 = NO PROVIDER SPECIFIC INFO FOUND           *      CL**1
061600*              52 = INVALID MSA # IN PROVIDER FILE            *      CL**1
061700*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *      CL**1
061800*              54 = DRG NOT 001-468 OR 471-490                *      CL**1
061900*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *      CL**1
062000*              56 = INVALID LENGTH OF STAY                    *      CL**1
062100*              57 = REVIEW CODE INVALID (NOT 00 - 07)         *      CL**1
062200*              58 = TOTAL CHARGES NOT NUMERIC                 *      CL**1
062300*              59 = POSSIBLE DAY OUTLIER CANDIDATE            *      CL**1
062400*              60 = REVIEW CODE 02 (POSSIBLE COST OUTLIER)    *      CL**1
062500*                   AND POSSIBLE DAY OUTLIER CANDIDATE. NOT   *      CL**1
062600*                   ELIGABLE FOR COST OUTLIER.                *      CL**1
062700*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *      CL**1
062800*              62 = INVALID NUMBER OF COVERED DAYS            *      CL**1
062900*              63 = POSSIBLE COST OUTLIER CANDIDATE.          *      CL**1
063000*              64 = DISPROPORTIONATE SHARE PERCENTAGE AND     *      CL**1
063100*                   BED-SIZE CONFLICT ON PROVIDER SPECIFIC FILE      CL**1
063200*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *      CL**1
063300***************************************************************      CL**1
063400 01  PPS-DATA.                                                       CL**1
063500         10  PPS-RTC                PIC 9(02).                       CL**1
063600         10  PPS-WAGE-INDX          PIC 9(02)V9(04).                 CL**1
063700         10  PPS-OUTLIER-DAYS       PIC 9(03).                       CL**1
063800         10  PPS-AVG-LOS            PIC 9(02)V9(01).                 CL**1
063900         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).                 CL**1
064000         10  PPS-INDTEACH-ADJ       PIC 9(06)V9(02).                 CL**1
064100         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).                 CL**1
064200         10  PPS-HSP-PART           PIC 9(06)V9(02).                 CL**1
064300         10  PPS-FSP-PART           PIC 9(06)V9(02).                 CL**1
064400         10  PPS-OUTLIER-PART       PIC 9(07)V9(02).                 CL**1
064500         10  PPS-REG-DAYS-USED      PIC 9(03).                       CL**1
064600         10  PPS-LTR-DAYS-USED      PIC 9(02).                       CL**1
064700         10  PPS-DSH-ADJ            PIC 9(06)V9(02).                 CL**1
064800         10  PPS-CALC-VERS          PIC X(05).                       CL**1
064900                                                                     CL**1
065000******************************************************************   CL**1
065100*            THESE ARE THE VERSIONS OF THE PPCAL                     CL**1
065200*           PROGRAMS THAT WILL BE PASSED BACK----                    CL**1
065300*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
065400******************************************************************   CL**1
065500 01  PRICER-OPT-VERS-SW.                                             CL**1
065600     02  PRICER-OPTION-SW          PIC X(01).                        CL**1
065700         88  ALL-TABLES-PASSED          VALUE 'A'.                   CL**1
065800         88  PROV-RECORD-PASSED         VALUE 'P'.                   CL**1
065900         88  ADDITIONAL-VARIABLES       VALUE 'M'.                   CL**1
066000     02  PPS-VERSIONS.                                               CL**1
066100         10  PPDRV-VERSION        PIC X(05).                         CL**1
066200                                                                     CL**1
066300******************************************************************   CL**1
066400*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK              CL**1
066500*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
066600******************************************************************   CL**1
066700 01  PPS-ADDITIONAL-VARIABLES.                                       CL**1
066800     05  PPS-HSP-PCT                PIC 9(01)V9(02).                 CL**1
066900     05  PPS-FSP-PCT                PIC 9(01)V9(02).                 CL**1
067000     05  PPS-NAT-PCT                PIC 9(01)V9(02).                 CL**1
067100     05  PPS-REG-PCT                PIC 9(01)V9(02).                 CL**1
067200     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).                 CL**1
067300     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).                 CL**1
067400     05  PPS-DRG-WT                 PIC 9(02)V9(04).                 CL**1
067500     05  PPS-NAT-LABOR              PIC 9(05)V9(02).                 CL**1
067600     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).                 CL**1
067700     05  PPS-REG-LABOR              PIC 9(05)V9(02).                 CL**1
067800     05  PPS-REG-NLABOR             PIC 9(05)V9(02).                 CL**1
067900     05  PPS-COLA                   PIC 9(01)V9(03).                 CL**1
068000     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).                 CL**1
068100     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).                 CL**1
068200     05  PPS-BILL-COSTS             PIC 9(07)V9(09).                 CL**1
068300     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).                 CL**1
068400                                                                     CL**1
068500******************************************************************   CL**1
068600*               THIS IS THE PROVIDER RECORD                          CL**1
068700*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
068800******************************************************************   CL**1
068900 01  PROV-HOLD.                                                      CL**1
069000     02  PROV-REC-HOLD.                                              CL**1
069100         05  P-PROVIDER-NO.                                          CL**1
069200             10  P-STATE                PIC 9(02).                   CL**1
069300             10  FILLER                 PIC X(04).                   CL**1
069400         05  P-EFF-DATE.                                             CL**1
069500             10  P-EFF-YY               PIC 9(02).                   CL**1
069600             10  P-EFF-MM               PIC 9(02).                   CL**1
069700             10  P-EFF-DD               PIC 9(02).                   CL**1
069800         05  P-WAIVER-CODE              PIC X(01).                   CL**1
069900             88  WAIVER-STATE           VALUE 'Y'.                   CL**1
070000         05  P-PROVIDER-TYPE            PIC X(02).                   CL**1
070100             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.             CL**1
070200             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.   CL**1
070300             88  INDIAN-HEALTH-SERVICE  VALUE '08'.                  CL**1
070400             88  REDESIGNATED-RURAL-YR1 VALUE '09'.                  CL**1
070500             88  REDESIGNATED-RURAL-YR2 VALUE '10'.                  CL**1
070600             88  SOLE-COM-REF-CENT      VALUE '11'.                  CL**1
070700             88  MDH-REBASED-FY90       VALUE '14' '15'.             CL**1
070800             88  MDH-RRC-REBASED-FY90   VALUE '15'.                  CL**1
070900             88  SCH-REBASED-FY90       VALUE '16' '17'.             CL**1
071000             88  SCH-RRC-REBASED-FY90   VALUE '17'.                  CL**1
071100         05  P-CURRENT-CENSUS-DIV       PIC 9(01).                   CL**1
071200             88  NEW-ENGLAND            VALUE  1.                    CL**1
071300             88  MIDDLE-ATLANTIC        VALUE  2.                    CL**1
071400             88  SOUTH-ATLANTIC         VALUE  3.                    CL**1
071500             88  EAST-NORTH-CENTRAL     VALUE  4.                    CL**1
071600             88  EAST-SOUTH-CENTRAL     VALUE  5.                    CL**1
071700             88  WEST-NORTH-CENTRAL     VALUE  6.                    CL**1
071800             88  WEST-SOUTH-CENTRAL     VALUE  7.                    CL**1
071900             88  MOUNTAIN               VALUE  8.                    CL**1
072000             88  PACIFIC                VALUE  9.                    CL**1
072100         05  P-PPS-BLEND-YEAR           PIC 9(01).                   CL**1
072200             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.              CL**1
072300         05  P-MSA-X.                                                CL**1
072400             10  P-RURAL                PIC X(04).                   CL**1
072500                 88  RURAL              VALUE  '9999'.               CL**1
072600         05  P-MSA-9 REDEFINES P-MSA-X  PIC 9(04).                   CL**1
072700         05  P-FISCAL-YEAR-END.                                      CL**1
072800             10  P-MM                   PIC 9(02).                   CL**1
072900             10  P-DD                   PIC 9(02).                   CL**1
073000             10  P-YY                   PIC 9(02).                   CL**1
073100         05  P-VARIABLES.                                            CL**1
073200             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).            CL**1
073300             10  P-COLA                 PIC S9(01)V9(03).            CL**1
073400             10  P-INTERN-RATIO         PIC S9(01)V9(04).            CL**1
073500             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).            CL**1
073600             10  P-BED-SIZE             PIC  9(05).                  CL**1
073700             10  P-DSH-PERCENT          PIC V9(04).                  CL**1
073800             10  P-CCR                  PIC  9(01)V9(03).            CL**1
073900             10  P-CMI                  PIC  9(01)V9(04).            CL**1
074000             10  FILLER                 PIC  9(01).                  CL**1
074100             10  P-REPORT-DATE          PIC  9(06).                  CL**1
074200             10  FILLER                 PIC  9(01).                  CL**1
074300             10  P-INTER-NO             PIC  9(05).                  CL**1
074400     02  FILLER                         PIC X(80).                   CL**1
074500                                                                     CL**1
074600******************************************************************   CL**1
074700*                   THIS IS THE WAGE-INDEX                           CL**1
074800*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
074900******************************************************************   CL**1
075000 01  WAGE-INDEX-RECORD.                                              CL**1
075100     05  W-MSA               PIC X(4).                               CL**1
075200     05  W-SIZE              PIC X(01).                              CL**1
075300         88  LARGE-URBAN       VALUE 'L'.                            CL**1
075400         88  OTHER-URBAN       VALUE 'O'.                            CL**1
075500         88  ALL-RURAL         VALUE 'R'.                            CL**1
075600     05  W-EFF-DATE          PIC X(6).                               CL**1
075700     05  FILLER              PIC X.                                  CL**1
075800     05  W-INDEX-RECORD      PIC S9(02)V9(04).                       CL**1
075900                                                                     CL**1
076000                                                                     CL**1
076100 PROCEDURE DIVISION  USING BILL-DATA                                 CL**1
076200                           PPS-DATA                                  CL**1
076300                           PRICER-OPT-VERS-SW                        CL**1
076400                           PPS-ADDITIONAL-VARIABLES                  CL**1
076500                           PROV-HOLD                                 CL**1
076600                           WAGE-INDEX-RECORD.                        CL**1
076700                                                                     CL**1
076800***************************************************************      CL**1
076900*    PROCESSING:                                              *      CL**1
077000*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE               CL**1
077100*        B. INITIALIZE PPCAL  WORK VARIABLES.                 *      CL**1
077200*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *      CL**1
077300*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *      CL**1
077400*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *      CL**1
077500*           GOBACK.                                           *      CL**1
077600*        D. ASSEMBLE PRICING COMPONENTS.                      *      CL**1
077700*        E. CALCULATE THE BLENDED PRICE.                      *      CL**1
077800***************************************************************      CL**1
077900                                                                     CL**1
078000     PERFORM 0200-MAINLINE-CONTROL.                                  CL**1
078100                                                                     CL**1
078200     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.    CL**1
078300     MOVE CAL-VERSION               TO  PPS-CALC-VERS.               CL**1
078400                                                                     CL**1
078500     GOBACK.                                                         CL**1
078600                                                                     CL**1
078700 0200-MAINLINE-CONTROL.                                              CL**1
078800     MOVE ALL '0' TO PPS-DATA.                                       CL**1
078900     MOVE ALL '0' TO HOLD-PPS-COMPONENTS.                            CL**1
079000     MOVE ALL '0' TO HOLD-ADDITIONAL-VARIABLES.                      CL**1
079100     PERFORM 1000-EDIT-THE-BILL-INFO.                                CL**1
079200     IF  PPS-RTC = 00                                                CL**1
079300         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                         CL**1
079400         PERFORM 3000-CALC-BLENDED-PAYMENT.                          CL**1
079500                                                                     CL**1
079600 1000-EDIT-THE-BILL-INFO.                                            CL**1
079700***************************************************************      CL**1
079800*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *      CL**1
079900*    AND DO NOT ATTEMPT TO PRICE.                             *      CL**1
080000***************************************************************      CL**1
080100     MOVE B-DISCHG-YY TO H-BILL-YY.                                  CL**1
080200     MOVE B-DISCHG-MM TO H-BILL-MM.                                  CL**1
080300     MOVE B-DISCHG-DD TO H-BILL-DD.                                  CL**1
080400     IF  PPS-RTC = 00                                                CL**1
080500         IF  WAIVER-STATE                                            CL**1
080600             MOVE 53 TO PPS-RTC.                                     CL**1
080700     IF  PPS-RTC = 00                                                CL**1
080800         IF  B-DRG < 001 OR > 490 OR = 469 OR = 470                  CL**1
080900             MOVE 54 TO PPS-RTC.                                     CL**1
081000     IF  PPS-RTC = 00                                                CL**1
081100         MOVE P-EFF-DATE  TO HOLD-PROV-DATE                          CL**1
081200         MOVE P-YY        TO H-FYE-YY                                CL**1
081300         MOVE P-MM        TO H-FYE-MM                                CL**1
081400         MOVE P-DD        TO H-FYE-DD                                CL**1
081500         IF  HOLD-BILL-DATE < HOLD-PROV-DATE                         CL**1
081600             MOVE 55 TO PPS-RTC.                                     CL**1
081700     IF  PPS-RTC = 00                                                CL**1
081800         IF  B-REVIEW-CODE NOT NUMERIC                               CL**1
081900             MOVE 57 TO PPS-RTC.                                     CL**1
082000     IF  PPS-RTC = 00                                                CL**1
082100         IF  B-LOS NOT NUMERIC                                       CL**1
082200             MOVE 56 TO PPS-RTC                                      CL**1
082300         ELSE                                                        CL**1
082400         IF  B-LOS = 0 AND B-REVIEW-CODE NOT = 03                    CL**1
082500             MOVE 56 TO PPS-RTC.                                     CL**1
082600     IF  PPS-RTC = 00                                                CL**1
082700         IF  B-LTR-DAYS NOT NUMERIC                                  CL**1
082800             MOVE 61 TO PPS-RTC                                      CL**1
082900         ELSE                                                        CL**1
083000             MOVE B-LTR-DAYS TO H-LTR-DAYS.                          CL**1
083100     IF  PPS-RTC = 00                                                CL**1
083200         IF  B-COVERED-DAYS NOT NUMERIC                              CL**1
083300             MOVE 62 TO PPS-RTC                                      CL**1
083400         ELSE                                                        CL**1
083500         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                        CL**1
083600             MOVE 62 TO PPS-RTC                                      CL**1
083700         ELSE                                                        CL**1
083800             MOVE B-COVERED-DAYS TO H-COV-DAYS.                      CL**1
083900     IF  PPS-RTC = 00                                                CL**1
084000         IF  H-LTR-DAYS  > H-COV-DAYS                                CL**1
084100             MOVE 62 TO PPS-RTC                                      CL**1
084200         ELSE                                                        CL**1
084300             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.           CL**1
084400     IF  PPS-RTC = 00                                                CL**1
084500         IF  NOT VALID-REVIEW-CODE                                   CL**1
084600             MOVE 57 TO PPS-RTC.                                     CL**1
084700     IF  PPS-RTC = 00                                                CL**1
084800         IF  B-CHARGES-CLAIMED NOT NUMERIC                           CL**1
084900             MOVE 58 TO PPS-RTC.                                     CL**1
085000                                                                     CL**1
085100 2000-ASSEMBLE-PPS-VARIABLES.                                        CL**1
085200***************************************************************      CL**1
085300*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *      CL**1
085400*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *      CL**1
085500*    OF THAT VARIABLE.                                        *      CL**1
085600***************************************************************      CL**1
085700***  GET THE PROVIDER SPECIFIC VARIABLES.                            CL**1
085800                                                                     CL**1
085900     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.                           CL**1
086000     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.                          CL**1
086100                                                                     CL**1
086200     IF  NOT (P-STATE = 02 OR 12)                                    CL**1
086300         MOVE 1 TO H-COLA                                            CL**1
086400     ELSE                                                            CL**1
086500         MOVE P-COLA TO H-COLA.                                      CL**1
086600                                                                     CL**1
086700***************************************************************      CL**1
086800***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF                 CL**1
086900                                                                     CL**1
087000     PERFORM 2600-GET-DRG-WEIGHT3                                    CL**1
087100             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.                  CL**1
087200                                                                     CL**1
087300***************************************************************      CL**1
087400***  GET THE WAGE-INDEX                                              CL**1
087500                                                                     CL**1
087600     MOVE W-INDEX-RECORD TO H-WAGE-INDX.                             CL**1
087700                                                                     CL**1
087800***************************************************************      CL**1
087900***  GET THE LABOR, NON-LABOR STANDARD RATES                         CL**1
088000                                                                     CL**1
088100     IF  P-CURRENT-CENSUS-DIV NUMERIC                                CL**1
088200         MOVE P-CURRENT-CENSUS-DIV TO R2                             CL**1
088300     ELSE                                                            CL**1
088400         MOVE 10 TO R2.                                              CL**1
088500     MOVE 10 TO R4.                                                  CL**1
088600     IF  P-STATE = 40                                                CL**1
088700         MOVE 11 TO R2                                               CL**1
088800         MOVE 12 TO R4.                                              CL**1
088900     IF  RURAL                                                       CL**1
089000         MOVE 2 TO R3                                                CL**1
089100     ELSE                                                            CL**1
089200         MOVE 1 TO R3.                                               CL**1
089300     IF  REFERRAL-CENTER                                             CL**1
089400         MOVE 1 TO R3.                                               CL**1
089500                                                                     CL**1
089600     PERFORM 2300-GET-LABOR-NLABOR-RATES2                            CL**1
089700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 3.                    CL**1
089800                                                                     CL**1
089900***************************************************************      CL**1
090000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL                  CL**1
090100                                                                     CL**1
090200     IF  H-FYE-MMDD > '0929'                                         CL**1
090300         MOVE 83 TO H-FYE-YY                                         CL**1
090400     ELSE                                                            CL**1
090500         MOVE 84 TO H-FYE-YY.                                        CL**1
090600                                                                     CL**1
090700     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30         CL**1
090800         MOVE 31 TO H-FYE-DD                                         CL**1
090900     ELSE                                                            CL**1
091000     IF  H-FYE-MM = 02 AND H-FYE-DD > 27                             CL**1
091100         MOVE 31 TO H-FYE-DD.                                        CL**1
091200                                                                     CL**1
091300     COMPUTE MO-DIFF =                                               CL**1
091400         ((H-BILL-YY - 83) * 12 + H-BILL-MM) -                       CL**1
091500         ((H-FYE-YY  - 83) * 12 + H-FYE-MM).                         CL**1
091600                                                                     CL**1
091700     IF  H-BILL-DD > H-FYE-DD                                        CL**1
091800         ADD 1 TO MO-DIFF.                                           CL**1
091900                                                                     CL**1
092000     MOVE 8 TO HSP-FY.                                               CL**1
092100                                                                     CL**1
092200     IF  MO-DIFF > 72                                                CL**1
092300             MOVE 9 TO HSP-FY.                                       CL**1
092400                                                                     CL**1
092500     MOVE 0.00  TO H-HSP-PCT.                                        CL**1
092600     MOVE 1.00  TO H-FSP-PCT.                                        CL**1
092700                                                                     CL**1
092800***************************************************************      CL**1
092900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL        CL**1
093000                                                                     CL**1
093100      MOVE 1.00 TO H-NAT-PCT.                                        CL**1
093200      MOVE 0.00 TO H-REG-PCT.                                        CL**1
093300                                                                     CL**1
093400***************************************************************      CL**1
093500*    REGIONAL FLOOR                                                  CL**1
093600                                                                     CL**1
093700     IF  (H-REG-LABOR + H-REG-NLABOR) >                              CL**1
093800             (H-NAT-LABOR + H-NAT-NLABOR)                            CL**1
093900             MOVE 0.85 TO H-NAT-PCT MOVE 0.15 TO H-REG-PCT.          CL**1
094000                                                                     CL**1
094100     IF  P-STATE = 40                                                CL**1
094200         MOVE 0.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT               CL**1
094300         MOVE 0.25 TO H-NAT-PCT MOVE 0.75 TO H-REG-PCT.              CL**1
094400                                                                     CL**1
094500     IF  SOLE-COMMUNITY-PROV                                         CL**1
094600         MOVE 0.75 TO H-HSP-PCT MOVE 0.25 TO H-FSP-PCT               CL**1
094700         MOVE 0.00 TO H-NAT-PCT MOVE 1.00 TO H-REG-PCT.              CL**1
094800                                                                     CL**1
094900     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90                        CL**1
095000         MOVE 1.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.              CL**1
095100                                                                     CL**1
095200***************************************************************      CL**1
095300***  GET THE STANDARD UPDATING FACTOR                                CL**1
095400                                                                     CL**1
095500     MOVE HSP-FY TO U1.                                              CL**1
095600     ADD 1 TO U1.                                                    CL**1
095700                                                                     CL**1
095800     MOVE P-MM TO U2.                                                CL**1
095900                                                                     CL**1
096000     IF  H-FYE-MM = 01 AND H-FYE-DD < 16                             CL**1
096100         MOVE 12 TO U2                                               CL**1
096200     ELSE                                                            CL**1
096300     IF  H-FYE-MM = 02 AND H-FYE-DD < 15                             CL**1
096400         MOVE 01 TO U2                                               CL**1
096500     ELSE                                                            CL**1
096600     IF  H-FYE-MM > 02 AND H-FYE-DD < 16                             CL**1
096700         COMPUTE U2 = U2 - 1.                                        CL**1
096800                                                                     CL**1
096900     MOVE R3 TO U3.                                                  CL**1
097000                                                                     CL**1
097100     IF  REFERRAL-CENTER                                             CL**1
097200         MOVE 3 TO U3.                                               CL**1
097300                                                                     CL**1
097400     SUBTRACT 8 FROM U1                                              CL**1
097500     MOVE UPDATE-FACTOR2 (U1 U2 U3) TO H-UPDATE-FACTOR.              CL**1
097600                                                                     CL**1
097700***************************************************************      CL**1
097800*    THIS IS THE FY91 70 DAY UPDATE FREEZE                           CL**1
097900                                                                     CL**1
098000     IF  HOLD-BILL-DATE > '901020' AND < '910101'                    CL**1
098100         COMPUTE H-UPDATE-FACTOR =                                   CL**1
098200         H-UPDATE-FACTOR / 1.055.                                    CL**1
098300                                                                     CL**1
098400***************************************************************      CL**1
098500***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE                   CL**1
098600                                                                     CL**1
098700     IF  PRUP-UPDT-FACTOR NUMERIC                                    CL**1
098800         IF  PRUP-UPDT-FACTOR > 0                                    CL**1
098900             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.               CL**1
099000                                                                     CL**1
099100 2300-GET-LABOR-NLABOR-RATES2.                                       CL**1
099200     IF  LARGE-URBAN                                                 CL**1
099300         MOVE 1 TO R3                                                CL**1
099400     ELSE                                                            CL**1
099500     IF  OTHER-URBAN OR REFERRAL-CENTER                              CL**1
099600         MOVE 2 TO R3                                                CL**1
099700     ELSE                                                            CL**1
099800         MOVE 3 TO R3.                                               CL**1
099900                                                                     CL**1
100000     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE2 (R1)                    CL**1
100100         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR                  CL**1
100200         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NLABOR                 CL**1
100300         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR                  CL**1
100400         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NLABOR                 CL**1
100500         IF REDESIGNATED-RURAL-YR1 OR REDESIGNATED-RURAL-YR2         CL**1
100600            PERFORM 2350-BLEND-RURAL-RATES2.                         CL**1
100700 2350-BLEND-RURAL-RATES2.                                            CL**1
100800      IF  REDESIGNATED-RURAL-YR1                                     CL**1
100900          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3                    CL**1
101000      ELSE                                                           CL**1
101100          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.                   CL**1
101200      COMPUTE H-REG-LABOR  ROUNDED =                                 CL**1
101300          (REG-LABOR2  (R1 R2 2) - REG-LABOR2  (R1 R2 3))            CL**1
101400            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R2 3).            CL**1
101500                                                                     CL**1
101600      COMPUTE H-REG-NLABOR ROUNDED =                                 CL**1
101700          (REG-NLABOR2 (R1 R2 2) - REG-NLABOR2 (R1 R2 3))            CL**1
101800            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R2 3).            CL**1
101900                                                                     CL**1
102000      COMPUTE H-NAT-LABOR  ROUNDED =                                 CL**1
102100          (REG-LABOR2  (R1 R4 2) - REG-LABOR2  (R1 R4 3))            CL**1
102200            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R4 3).            CL**1
102300                                                                     CL**1
102400      COMPUTE H-NAT-NLABOR ROUNDED =                                 CL**1
102500          (REG-NLABOR2 (R1 R4 2) - REG-NLABOR2 (R1 R4 3))            CL**1
102600            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R4 3).            CL**1
102700                                                                     CL**1
102800 2600-GET-DRG-WEIGHT3.                                               CL**1
102900     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE3 (DX5)                   CL**1
103000         SET DX6 TO B-DRG                                            CL**1
103100         MOVE DRG-WT3 (DX5 DX6)        TO H-DRG-WT                   CL**1
103200         MOVE DRG-ALOS3 (DX5 DX6)      TO H-ALOS                     CL**1
103300         MOVE DRG-DAYS-TRIM3 (DX5 DX6) TO H-DAYS-CUTOFF.             CL**1
103400                                                                     CL**1
103500 3000-CALC-BLENDED-PAYMENT.                                          CL**1
103600***************************************************************      CL**1
103700*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *      CL**1
103800*        CALCULATE COVERED DAYS UTILIZATION.                  *      CL**1
103900*        CALCULATE THE FEDERAL PORTION.                       *      CL**1
104000*        CALCULATE THE HOSPITAL PORTION.                      *      CL**1
104100*        CALCULATE THE DAYS-OUTLIER PORTION.                  *      CL**1
104200*        CALCULATE THE COST-OUTLIER PORTION.                  *      CL**1
104300*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *      CL**1
104400*        CALCULATE THE INDIRECT TEACHING ADJUSTMENT.          *      CL**1
104500***************************************************************      CL**1
104600     PERFORM 3100-CALC-STAY-UTILIZATION.                             CL**1
104700     PERFORM 3300-CALC-FSP-AMT.                                      CL**1
104800     PERFORM 3400-CALC-HSP-AMT.                                      CL**1
104900                                                                     CL**1
105000     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90                        CL**1
105100         PERFORM 3450-CALC-ADDITIONAL-HSP.                           CL**1
105200                                                                     CL**1
105300     MOVE 00            TO  PPS-RTC.                                 CL**1
105400     MOVE H-WAGE-INDX   TO  PPS-WAGE-INDX.                           CL**1
105500     MOVE H-ALOS        TO  PPS-AVG-LOS.                             CL**1
105600     MOVE H-DAYS-CUTOFF TO  PPS-DAYS-CUTOFF.                         CL**1
105700                                                                     CL**1
105800     PERFORM 3600-CALC-OUTLIER.                                      CL**1
105900                                                                     CL**1
106000     IF  PAY-AVG-STAY-ONLY                                           CL**1
106100         MOVE 0  TO H-OUTLIER-PART                                   CL**1
106200         MOVE 04 TO PPS-RTC.                                         CL**1
106300                                                                     CL**1
106400     IF  PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST                      CL**1
106500         IF  B-LOS < H-ALOS                                          CL**1
106600             IF  NOT (B-DRG = 385 OR 456)                            CL**1
106700                 PERFORM 3500-CALC-PERDIEM-AMT                       CL**1
106800                 MOVE 03 TO PPS-RTC.                                 CL**1
106900                                                                     CL**1
107000     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)                    CL**1
107100         IF  H-OUTCST-PART > 0                                       CL**1
107200             MOVE H-OUTCST-PART TO H-OUTLIER-PART                    CL**1
107300             MOVE 05 TO PPS-RTC                                      CL**1
107400         ELSE                                                        CL**1
107500         IF  PPS-RTC NOT = 03                                        CL**1
107600             MOVE 00 TO PPS-RTC                                      CL**1
107700             MOVE 0  TO H-OUTLIER-PART.                              CL**1
107800                                                                     CL**1
107900     IF  PAY-DAYS-OUTLIER                                            CL**1
108000         IF  PPS-RTC NOT = 01                                        CL**1
108100             MOVE 0  TO H-OUTLIER-PART                               CL**1
108200             MOVE 00 TO PPS-RTC.                                     CL**1
108300                                                                     CL**1
108400     IF  PAY-COST-OUTLIER                                            CL**1
108500         IF  PPS-RTC = 01                                            CL**1
108600             MOVE 0  TO H-OUTLIER-PART                               CL**1
108700             MOVE 60 TO PPS-RTC.                                     CL**1
108800                                                                     CL**1
108900     IF  PAY-XFER-NO-COST                                            CL**1
109000         MOVE 0  TO H-OUTLIER-PART                                   CL**1
109100         MOVE 00 TO PPS-RTC                                          CL**1
109200         IF B-LOS < H-ALOS                                           CL**1
109300         IF  NOT (B-DRG = 385 OR 456)                                CL**1
109400             PERFORM 3500-CALC-PERDIEM-AMT                           CL**1
109500             MOVE 06 TO PPS-RTC.                                     CL**1
109600                                                                     CL**1
109700     IF  PPS-RTC < 50                                                CL**1
109800         PERFORM 3800-CALC-BLEND-AMT                                 CL**1
109900     ELSE                                                            CL**1
110000         MOVE 0 TO PPS-HSP-PART                                      CL**1
110100                   PPS-FSP-PART                                      CL**1
110200                   PPS-OUTLIER-PART                                  CL**1
110300                   PPS-OUTLIER-DAYS                                  CL**1
110400                   PPS-REG-DAYS-USED                                 CL**1
110500                   PPS-LTR-DAYS-USED                                 CL**1
110600                   PPS-TOTAL-PAYMENT                                 CL**1
110700                   PPS-DSH-ADJ                                       CL**1
110800                   PPS-INDTEACH-ADJ.                                 CL**1
110900                                                                     CL**1
111000 3100-CALC-STAY-UTILIZATION.                                         CL**1
111100     IF  H-REG-DAYS > 0                                              CL**1
111200         IF  H-REG-DAYS < H-DAYS-CUTOFF                              CL**1
111300             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                    CL**1
111400             MOVE 0          TO H-REG-DAYS                           CL**1
111500         ELSE                                                        CL**1
111600             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED                 CL**1
111700             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS                  CL**1
111800     ELSE                                                            CL**1
111900     IF  H-LTR-DAYS < H-DAYS-CUTOFF                                  CL**1
112000         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED                        CL**1
112100         MOVE 0          TO H-LTR-DAYS                               CL**1
112200     ELSE                                                            CL**1
112300         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED                     CL**1
112400         SUBTRACT H-DAYS-CUTOFF  FROM H-LTR-DAYS.                    CL**1
112500                                                                     CL**1
112600     IF  B-LOS > H-DAYS-CUTOFF                                       CL**1
112700         PERFORM 3200-CALC-OUTLIER-UTILIZATION.                      CL**1
112800                                                                     CL**1
112900 3200-CALC-OUTLIER-UTILIZATION.                                      CL**1
113000     COMPUTE PPS-OUTLIER-DAYS =                                      CL**1
113100         B-LOS - H-DAYS-CUTOFF.                                      CL**1
113200                                                                     CL**1
113300     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS                CL**1
113400         COMPUTE PPS-OUTLIER-DAYS =                                  CL**1
113500             H-REG-DAYS + H-LTR-DAYS                                 CL**1
113600         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                         CL**1
113700         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED                         CL**1
113800     ELSE                                                            CL**1
113900     IF  H-REG-DAYS < PPS-OUTLIER-DAYS                               CL**1
114000         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                         CL**1
114100         COMPUTE PPS-LTR-DAYS-USED =                                 CL**1
114200             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS - H-REG-DAYS)     CL**1
114300     ELSE                                                            CL**1
114400         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.                  CL**1
114500     IF  B-REVIEW-CODE = 03 OR 04                                    CL**1
114600         IF  PPS-REG-DAYS-USED > 0                                   CL**1
114700             MOVE 0 TO PPS-LTR-DAYS-USED.                            CL**1
114800                                                                     CL**1
114900 3300-CALC-FSP-AMT.                                                  CL**1
115000     COMPUTE H-FSP-PART ROUNDED =                                    CL**1
115100         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +                   CL**1
115200         H-NAT-NLABOR * H-COLA) * H-DRG-WT)                          CL**1
115300                           +                                         CL**1
115400         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +                   CL**1
115500         H-REG-NLABOR * H-COLA) * H-DRG-WT).                         CL**1
115600                                                                     CL**1
115700 3400-CALC-HSP-AMT.                                                  CL**1
115800     COMPUTE H-HSP-PART ROUNDED =                                    CL**1
115900         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.                 CL**1
116000                                                                     CL**1
116100 3450-CALC-ADDITIONAL-HSP.                                           CL**1
116200***********************************************************          CL**1
116300*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR                    CL**1
116400*    SOLE COMMUNITY AND MEDICARE DEPENDENT HOSPITALS                 CL**1
116500*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES                 CL**1
116600***********************************************************          CL**1
116700**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE          CL**1
116800                                                                     CL**1
116900     IF  HOLD-BILL-DATE > '900930'                                   CL**1
117000         IF  RURAL AND NOT REFERRAL-CENTER                           CL**1
117100             MOVE 1.023151 TO OUTLIER-FACT                           CL**1
117200         ELSE                                                        CL**1
117300             MOVE 1.058488 TO OUTLIER-FACT.                          CL**1
117400                                                                     CL**1
117500     IF  HOLD-BILL-DATE > '901231'                                   CL**1
117600         IF  RURAL AND NOT REFERRAL-CENTER                           CL**1
117700             MOVE 1.023072 TO OUTLIER-FACT                           CL**1
117800         ELSE                                                        CL**1
117900             MOVE 1.059235 TO OUTLIER-FACT.                          CL**1
118000                                                                     CL**1
118100***********************************************************          CL**1
118200**** CHANGE HSP UPDATE FACTORS WHEN HOSPITAL PERIOD CHANGES          CL**1
118300**** FORCE FYE SO THAT NEW CALC STARTS ON OR AFTER 04/01/90          CL**1
118400                                                                     CL**1
118500     ADD 7 TO H-FYE-YY.                                              CL**1
118600     MOVE 1.00000 TO H-UPDATE-FACTOR.                                CL**1
118700                                                                     CL**1
118800***********************************************************          CL**1
118900*    THIS IS THE FY91 70 DAY UPDATE FREEZE                           CL**1
119000                                                                     CL**1
119100     IF  HOLD-BILL-DATE > '901020' AND < '910101'                    CL**1
119200         COMPUTE H-UPDATE-FACTOR =                                   CL**1
119300         H-UPDATE-FACTOR / 1.055.                                    CL**1
119400                                                                     CL**1
119500     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE                         CL**1
119600         COMPUTE H-UPDATE-FACTOR =                                   CL**1
119700             1.052 * .998637.                                        CL**1
119800                                                                     CL**1
119900***********************************************************          CL**1
120000*    THIS IS THE FY91 70 DAY UPDATE FREEZE                           CL**1
120100                                                                     CL**1
120200     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE                         CL**1
120300         IF  HOLD-BILL-DATE > '901020' AND < '910101'                CL**1
120400             COMPUTE H-UPDATE-FACTOR =                               CL**1
120500             H-UPDATE-FACTOR / 1.052.                                CL**1
120600                                                                     CL**1
120700***********************************************************          CL**1
120800*    THIS IS BUDGET NEUTRALITY FACTOR CHANGE EFF 1/1/91              CL**1
120900                                                                     CL**1
121000     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE                         CL**1
121100         IF  HOLD-BILL-DATE > '901231'                               CL**1
121200             COMPUTE H-UPDATE-FACTOR =                               CL**1
121300             1.052 * .998526.                                        CL**1
121400                                                                     CL**1
121500     COMPUTE H-HSP-RATE ROUNDED =                                    CL**1
121600         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.                            CL**1
121700                                                                     CL**1
121800     IF  P-DSH-PERCENT NOT NUMERIC                                   CL**1
121900         MOVE 0 TO P-DSH-PERCENT.                                    CL**1
122000                                                                     CL**1
122100     PERFORM 3700-CALC-IND-TEACHING.                                 CL**1
122200                                                                     CL**1
122300     COMPUTE H-FSP-RATE ROUNDED =                                    CL**1
122400         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +                  CL**1
122500         H-NAT-NLABOR * H-COLA))                                     CL**1
122600                           +                                         CL**1
122700          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +                  CL**1
122800         H-REG-NLABOR * H-COLA)))                                    CL**1
122900                           *                                         CL**1
123000         OUTLIER-FACT * (1 + H-IND-TEACHING + P-DSH-PERCENT).        CL**1
123100     IF  H-HSP-RATE > H-FSP-RATE                                     CL**1
123200         COMPUTE H-HSP-PART =                                        CL**1
123300             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT                    CL**1
123400     ELSE                                                            CL**1
123500         MOVE 0 TO H-HSP-PART.                                       CL**1
123600                                                                     CL**1
123700 3500-CALC-PERDIEM-AMT.                                              CL**1
123800     MOVE B-LOS TO H-COV-DAYS.                                       CL**1
123900     IF  H-COV-DAYS = 0                                              CL**1
124000         MOVE 1 TO H-COV-DAYS.                                       CL**1
124100     COMPUTE H-HSP-PART ROUNDED =                                    CL**1
124200        H-HSP-PART / H-ALOS * H-COV-DAYS                             CL**1
124300        ON SIZE ERROR MOVE 0 TO H-HSP-PART.                          CL**1
124400     COMPUTE H-FSP-PART ROUNDED =                                    CL**1
124500        H-FSP-PART / H-ALOS * H-COV-DAYS                             CL**1
124600        ON SIZE ERROR MOVE 0 TO H-FSP-PART.                          CL**1
124700                                                                     CL**1
124800 3600-CALC-OUTLIER.                                                  CL**1
124900     MOVE 0.60 TO H-DAYOUT-PCT.                                      CL**1
125000     MOVE 0.75 TO H-CSTOUT-PCT.                                      CL**1
125100                                                                     CL**1
125200     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472              CL**1
125300             MOVE 0.60 TO H-DAYOUT-PCT                               CL**1
125400             MOVE 0.90 TO H-CSTOUT-PCT.                              CL**1
125500                                                                     CL**1
125600     MOVE 0.7140   TO H-LABOR-PCT.                                   CL**1
125700     MOVE 0.2860   TO H-NLABOR-PCT.                                  CL**1
125800     MOVE 0.660    TO H-CSTCHG-RATIO.                                CL**1
125900                                                                     CL**1
126000     IF  P-CCR NUMERIC                                               CL**1
126100             MOVE P-CCR TO H-CSTCHG-RATIO                            CL**1
126200     ELSE                                                            CL**1
126300             MOVE 0.000 TO H-CSTCHG-RATIO.                           CL**1
126400                                                                     CL**1
126500     MOVE 2.000    TO H-CST-MULTIPLE.                                CL**1
126600     MOVE 35000.00 TO H-CST-THRESH.                                  CL**1
126700                                                                     CL**1
126800***********************************************************          CL**1
126900***  DAY OUTLIER CALCULATION                                         CL**1
127000                                                                     CL**1
127100     IF  PPS-OUTLIER-DAYS > 0                                        CL**1
127200     COMPUTE H-OUTDAY-PART  =                                        CL**1
127300         H-DAYOUT-PCT *  H-FSP-PART / H-ALOS * PPS-OUTLIER-DAYS      CL**1
127400         ON SIZE ERROR MOVE 0 TO H-OUTDAY-PART.                      CL**1
127500                                                                     CL**1
127600***********************************************************          CL**1
127700***  COST OUTLIER CALCULATION                                        CL**1
127800                                                                     CL**1
127900     COMPUTE H-DOLLAR-THRESHOLD ROUNDED =                            CL**1
128000         (H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDX) +               CL**1
128100         (H-CST-THRESH * H-NLABOR-PCT * H-COLA).                     CL**1
128200     COMPUTE H-COST-OUTLIER ROUNDED =                                CL**1
128300         H-CST-MULTIPLE * H-FSP-PART.                                CL**1
128400                                                                     CL**1
128500     IF  H-DOLLAR-THRESHOLD > H-COST-OUTLIER                         CL**1
128600         MOVE H-DOLLAR-THRESHOLD TO H-COST-OUTLIER.                  CL**1
128700                                                                     CL**1
128800     PERFORM 3700-CALC-IND-TEACHING.                                 CL**1
128900     MOVE 0 TO H-DSH-PERCENT.                                        CL**1
129000                                                                     CL**1
129100     IF  P-DSH-PERCENT NUMERIC                                       CL**1
129200         MOVE P-DSH-PERCENT TO H-DSH-PERCENT.                        CL**1
129300                                                                     CL**1
129400     COMPUTE H-BILL-COSTS ROUNDED =                                  CL**1
129500         B-CHARGES-CLAIMED * H-CSTCHG-RATIO /                        CL**1
129600         (1 + H-IND-TEACHING + H-DSH-PERCENT)                        CL**1
129700         ON SIZE ERROR MOVE 0 TO H-BILL-COSTS.                       CL**1
129800                                                                     CL**1
129900     IF  H-BILL-COSTS > H-COST-OUTLIER                               CL**1
130000         COMPUTE H-OUTCST-PART =                                     CL**1
130100         H-CSTOUT-PCT * (H-BILL-COSTS - H-COST-OUTLIER).             CL**1
130200                                                                     CL**1
130300     IF  PAY-WITHOUT-COST                                            CL**1
130400         MOVE 0 TO H-OUTCST-PART.                                    CL**1
130500                                                                     CL**1
130600***********************************************************          CL**1
130700***  GREATER OF DAY OR COST                                          CL**1
130800                                                                     CL**1
130900      IF  H-OUTDAY-PART > 0 OR H-OUTCST-PART > 0                     CL**1
131000             IF  H-OUTDAY-PART > H-OUTCST-PART                       CL**1
131100                 MOVE H-OUTDAY-PART TO H-OUTLIER-PART                CL**1
131200                 MOVE 01 TO PPS-RTC                                  CL**1
131300             ELSE                                                    CL**1
131400                 MOVE H-OUTCST-PART TO H-OUTLIER-PART                CL**1
131500                 MOVE 02 TO PPS-RTC.                                 CL**1
131600                                                                     CL**1
131700 3700-CALC-IND-TEACHING.                                             CL**1
131800     IF  HOLD-BILL-DATE < '951001'                                   CL**1
131900         COMPUTE H-IND-TEACHING =                                    CL**1
132000            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1)               CL**1
132100     ELSE                                                            CL**1
132200         COMPUTE H-IND-TEACHING =                                    CL**1
132300            1.43 * ((1 + H-INTERN-RATIO) ** .5795 - 1).              CL**1
132400                                                                     CL**1
132500 3800-CALC-BLEND-AMT.                                                CL**1
132600     IF  H-CMI-ADJ-CPD = 0                                           CL**1
132700         MOVE 0.00 TO H-HSP-PCT                                      CL**1
132800         MOVE 1.00 TO H-FSP-PCT.                                     CL**1
132900                                                                     CL**1
133000     COMPUTE PPS-HSP-PART ROUNDED =                                  CL**1
133100         H-HSP-PCT * H-HSP-PART.                                     CL**1
133200                                                                     CL**1
133300     COMPUTE PPS-FSP-PART ROUNDED =                                  CL**1
133400         H-FSP-PCT * H-FSP-PART.                                     CL**1
133500                                                                     CL**1
133600     COMPUTE PPS-OUTLIER-PART ROUNDED =                              CL**1
133700             H-FSP-PCT * H-OUTLIER-PART.                             CL**1
133800                                                                     CL**1
133900     MOVE ZERO TO PPS-DSH-ADJ.                                       CL**1
134000                                                                     CL**1
134100     IF  P-DSH-PERCENT NUMERIC                                       CL**1
134200             COMPUTE PPS-DSH-ADJ ROUNDED =                           CL**1
134300             (PPS-FSP-PART + PPS-OUTLIER-PART) * P-DSH-PERCENT.      CL**1
134400                                                                     CL**1
134500     PERFORM 3700-CALC-IND-TEACHING.                                 CL**1
134600                                                                     CL**1
134700     COMPUTE PPS-INDTEACH-ADJ ROUNDED =                              CL**1
134800         (PPS-FSP-PART + PPS-OUTLIER-PART) * H-IND-TEACHING.         CL**1
134900     COMPUTE PPS-TOTAL-PAYMENT =                                     CL**1
135000             PPS-HSP-PART     + PPS-FSP-PART +                       CL**1
135100             PPS-OUTLIER-PART + PPS-DSH-ADJ  +                       CL**1
135200             PPS-INDTEACH-ADJ.                                       CL**1
135300                                                                     CL**1
135400******        L A S T   S O U R C E   S T A T E M E N T   *****      CL**1
