000100 IDENTIFICATION DIVISION.                                         08/28/92
000200 PROGRAM-ID.           PPCAL894.                                  PPCAL891
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 '001PPCAL894  08/28/92'.          CL**1
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE                 CL**1
002000     'PPCAL894 - WORKING   STORAGE'.                                 CL**1
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C89.4'.        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  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.            CL**1
003300 01  HSP-FY                         PIC S9(04) COMP SYNC VALUE +1.   CL**1
003400 01  MO-DIFF                        PIC  9(02).                      CL**1
003500                                                                     CL**1
003600 01  BLEND-TABLE.                                                    CL**1
003700     05  BLEND-PCTS.                                                 CL**1
003800         10  FILLER      PIC X(15)  VALUE '075050045025000'.         CL**1
003900         10  FILLER      PIC X(15)  VALUE '025050055075100'.         CL**1
004000     05  FILLER REDEFINES BLEND-PCTS.                                CL**1
004100         10  HSP                    PIC 9(01)V9(02)  OCCURS 5.       CL**1
004200         10  FSP                    PIC 9(01)V9(02)  OCCURS 5.       CL**1
004300                                                                     CL**1
004400 01  CAL-MO-DAYS.                                                    CL**1
004500     05  CAL-YYMMDD.                                                 CL**1
004600         10  T-YY                   PIC 99.                          CL**1
004700         10  T-MM                   PIC 99.                          CL**1
004800         10  T-DD                   PIC 99.                          CL**1
004900     05  DAYS-MO.                                                    CL**1
005000         10  FILLER                 PIC X(36)  VALUE                 CL**1
005100            '000031059090120151181212243273304334'.                  CL**1
005200     05  FILLER           REDEFINES DAYS-MO.                         CL**1
005300         10  T-DAYS                 PIC 999 OCCURS 12.               CL**1
005400                                                                     CL**1
005500 01  HOLD-AREA.                                                      CL**1
005600     02  HOLD-DATES.                                                 CL**1
005700         05  HOLD-BILL-DATE.                                         CL**1
005800             10  H-BILL-YY              PIC 9(02).                   CL**1
005900             10  H-BILL-MM              PIC 9(02).                   CL**1
006000             10  H-BILL-DD              PIC 9(02).                   CL**1
006100         05  HOLD-BILL-DATE-9 REDEFINES HOLD-BILL-DATE               CL**1
006200                                        PIC 9(06).                   CL**1
006300         05  HOLD-BILL-DAYS             PIC 9(06).                   CL**1
006400                                                                     CL**1
006500         05  HOLD-PROV-DATE.                                         CL**1
006600             10  H-PROV-YY              PIC 9(02).                   CL**1
006700             10  H-PROV-MM              PIC 9(02).                   CL**1
006800             10  H-PROV-DD              PIC 9(02).                   CL**1
006900         05  HOLD-PROV-DATE-9 REDEFINES HOLD-PROV-DATE               CL**1
007000                                        PIC 9(06).                   CL**1
007100         05  HOLD-PROV-FYE-DATE.                                     CL**1
007200             10  H-FYE-YY               PIC 9(02).                   CL**1
007300             10  H-FYE-MMDD.                                         CL**1
007400             15  H-FYE-MM           PIC 9(02).                       CL**1
007500             15  H-FYE-DD           PIC 9(02).                       CL**1
007600         05  HOLD-PROV-FYE-9  REDEFINES HOLD-PROV-FYE-DATE           CL**1
007700                                        PIC 9(06).                   CL**1
007800         05  HOLD-PROV-DAYS             PIC 9(06).                   CL**1
007900                                                                     CL**1
008000     02  H-IND-TEACHING                 PIC  9(06)V9(09).            CL**1
008100     02  H-DSH-PERCENT                  PIC  V9(04).                 CL**1
008200                                                                     CL**1
008300     02  HOLD-PROV-MSA.                                              CL**1
008400         05  H-PROV-BLANK               PIC X(02).                   CL**1
008500         05  H-PROV-STATE               PIC X(02).                   CL**1
008600                                                                     CL**1
008700     02  HOLD-PPS-COMPONENTS.                                        CL**1
008800         05  H-HSP-PART                 PIC 9(06)V9(09).             CL**1
008900         05  H-FSP-PART                 PIC 9(06)V9(09).             CL**1
009000         05  H-OUTLIER-PART             PIC 9(07)V9(09).             CL**1
009100         05  H-OUTDAY-PART              PIC 9(07)V9(09).             CL**1
009200         05  H-OUTCST-PART              PIC 9(07)V9(09).             CL**1
009300         05  H-COV-DAYS                 PIC 9(03).                   CL**1
009400         05  H-REG-DAYS                 PIC 9(03).                   CL**1
009500         05  H-LTR-DAYS                 PIC 9(03).                   CL**1
009600         05  H-WAGE-INDX                PIC 9(02)V9(04).             CL**1
009700         05  H-ALOS                     PIC 9(02)V9(01).             CL**1
009800         05  H-DAYS-CUTOFF              PIC 9(02)V9(01).             CL**1
009900         05  H-DAYOUT-PCT               PIC 9(01)V9(02).             CL**1
010000         05  H-CSTOUT-PCT               PIC 9(01)V9(02).             CL**1
010100         05  H-CSTCHG-RATIO             PIC 9(01)V9(03).             CL**1
010200         05  H-CST-MULTIPLE             PIC 9(01)V9(03).             CL**1
010300         05  H-CST-THRESH               PIC 9(05)V9(02).             CL**1
010400         05  H-LABOR-PCT                PIC 9(01)V9(04).             CL**1
010500         05  H-NLABOR-PCT               PIC 9(01)V9(04).             CL**1
010600                                                                     CL**1
010700     02  HOLD-ADDITIONAL-VARIABLES.                                  CL**1
010800         05  H-HSP-PCT                  PIC 9(01)V9(02).             CL**1
010900         05  H-FSP-PCT                  PIC 9(01)V9(02).             CL**1
011000         05  H-NAT-PCT                  PIC 9(01)V9(02).             CL**1
011100         05  H-REG-PCT                  PIC 9(01)V9(02).             CL**1
011200         05  H-CMI-ADJ-CPD              PIC 9(05)V9(02).             CL**1
011300         05  H-UPDATE-FACTOR            PIC 9(01)V9(05).             CL**1
011400         05  H-DRG-WT                   PIC 9(02)V9(04).             CL**1
011500         05  H-NAT-LABOR                PIC 9(05)V9(02).             CL**1
011600         05  H-NAT-NLABOR               PIC 9(05)V9(02).             CL**1
011700         05  H-REG-LABOR                PIC 9(05)V9(02).             CL**1
011800         05  H-REG-NLABOR               PIC 9(05)V9(02).             CL**1
011900         05  H-COLA                     PIC 9(01)V9(03).             CL**1
012000         05  H-INTERN-RATIO             PIC 9(01)V9(04).             CL**1
012100         05  H-COST-OUTLIER             PIC 9(07)V9(09).             CL**1
012200         05  H-BILL-COSTS               PIC 9(07)V9(09).             CL**1
012300         05  H-DOLLAR-THRESHOLD         PIC 9(07)V9(09).             CL**1
012400                                                                     CL**1
012500     02  HOLD-WORK-VARIABLES.                                        CL**1
012600         05  H-HSP-RATE                 PIC 9(06)V9(09).             CL**1
012700         05  H-FSP-RATE                 PIC 9(06)V9(09).             CL**1
012800         05  OUTLIER-FACT               PIC 9(01)V9(06).             CL**1
012900                                                                     CL**1
013000***************************************************************      CL**1
013100*    LAYUP TABLE AREA                                         *      CL**1
013200***************************************************************      CL**1
013300                                                                     CL**1
013400 01  RATE-TABLE2.                                                    CL**1
013500     02  RATE-WORK2.                                                 CL**1
013600*RATE 881001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
013700     05  FILLER PIC X(06) VALUE '881001'.                            CL**1
013800     05  FILLER PIC X(45) VALUE                                      CL**1
013900        ' 0249276 087787 0246848 086932 0245967 072925'.             CL**1
014000     05  FILLER PIC X(45) VALUE                                      CL**1
014100        ' 0223944 083305 0221763 082494 0235850 068799'.             CL**1
014200     05  FILLER PIC X(45) VALUE                                      CL**1
014300        ' 0239057 076755 0236729 076007 0225181 059780'.             CL**1
014400     05  FILLER PIC X(45) VALUE                                      CL**1
014500        ' 0252039 090778 0249585 089894 0228173 066415'.             CL**1
014600     05  FILLER PIC X(45) VALUE                                      CL**1
014700        ' 0229431 069500 0227196 068823 0223178 055745'.             CL**1
014800     05  FILLER PIC X(45) VALUE                                      CL**1
014900        ' 0239122 082747 0236793 081941 0216919 059556'.             CL**1
015000     05  FILLER PIC X(45) VALUE                                      CL**1
015100        ' 0238408 076235 0236087 075492 0208031 054770'.             CL**1
015200     05  FILLER PIC X(45) VALUE                                      CL**1
015300        ' 0229260 081728 0227027 080933 0211498 063406'.             CL**1
015400     05  FILLER PIC X(45) VALUE                                      CL**1
015500        ' 0223084 093277 0220912 092368 0204607 070966'.             CL**1
015600     05  FILLER PIC X(45) VALUE                                      CL**1
015700        ' 0237422 084095 0235110 083275 0221989 061482'.             CL**1
015800     05  FILLER PIC X(45) VALUE                                      CL**1
015900        ' 0210903 037731 0208851 037363 0148355 027462'.             CL**1
016000     05  FILLER PIC X(45) VALUE                                      CL**1
016100        ' 0232677 078076 0232677 078076 0232677 078076'.             CL**1
016200*RATE 891001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
016300     05  FILLER PIC X(06) VALUE '891001'.                            CL**1
016400     05  FILLER PIC X(45) VALUE                                      CL**1
016500        ' 0263058 092619 0260496 091716 0259278 076852'.             CL**1
016600     05  FILLER PIC X(45) VALUE                                      CL**1
016700        ' 0236335 087890 0234033 087034 0248311 072653'.             CL**1
016800     05  FILLER PIC X(45) VALUE                                      CL**1
016900        ' 0252275 080979 0249818 080190 0237367 062999'.             CL**1
017000     05  FILLER PIC X(45) VALUE                                      CL**1
017100        ' 0266091 095811 0263500 094878 0240367 070019'.             CL**1
017200     05  FILLER PIC X(45) VALUE                                      CL**1
017300        ' 0242118 073325 0239760 072611 0235254 058747'.             CL**1
017400     05  FILLER PIC X(45) VALUE                                      CL**1
017500        ' 0252345 087301 0249888 086451 0228658 062763'.             CL**1
017600     05  FILLER PIC X(45) VALUE                                      CL**1
017700        ' 0250892 080431 0248449 079647 0219292 057720'.             CL**1
017800     05  FILLER PIC X(45) VALUE                                      CL**1
017900        ' 0241944 086226 0239588 085387 0222943 066821'.             CL**1
018000     05  FILLER PIC X(45) VALUE                                      CL**1
018100        ' 0235423 098411 0233130 097452 0215683 074788'.             CL**1
018200     05  FILLER PIC X(45) VALUE                                      CL**1
018300        ' 0250503 088728 0248065 087863 0233906 064783'.             CL**1
018400     05  FILLER PIC X(45) VALUE                                      CL**1
018500        ' 0222510 039808 0220346 039419 0156345 028941'.             CL**1
018600     05  FILLER PIC X(45) VALUE                                      CL**1
018700        ' 0245417 082355 0245417 082355 0245417 082355'.             CL**1
018800*RATE 900101 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
018900     05  FILLER PIC X(06) VALUE '900101'.                            CL**1
019000     05  FILLER PIC X(45) VALUE                                      CL**1
019100        ' 0263387 092735 0259217 091266 0269721 079948'.             CL**1
019200     05  FILLER PIC X(45) VALUE                                      CL**1
019300        ' 0236631 088000 0232884 086607 0258313 075579'.             CL**1
019400     05  FILLER PIC X(45) VALUE                                      CL**1
019500        ' 0252591 081081 0248592 079797 0246928 065537'.             CL**1
019600     05  FILLER PIC X(45) VALUE                                      CL**1
019700        ' 0266424 095931 0262206 094413 0250049 072839'.             CL**1
019800     05  FILLER PIC X(45) VALUE                                      CL**1
019900        ' 0242422 073417 0238584 072254 0244730 061113'.             CL**1
020000     05  FILLER PIC X(45) VALUE                                      CL**1
020100        ' 0252661 087411 0248661 086026 0237868 065291'.             CL**1
020200     05  FILLER PIC X(45) VALUE                                      CL**1
020300        ' 0251207 080532 0247229 079256 0228125 060045'.             CL**1
020400     05  FILLER PIC X(45) VALUE                                      CL**1
020500        ' 0242248 086334 0238412 084968 0231923 069512'.             CL**1
020600     05  FILLER PIC X(45) VALUE                                      CL**1
020700        ' 0235718 098534 0231986 096973 0224370 077800'.             CL**1
020800     05  FILLER PIC X(45) VALUE                                      CL**1
020900        ' 0250817 088839 0246847 087432 0243328 067392'.             CL**1
021000     05  FILLER PIC X(45) VALUE                                      CL**1
021100        ' 0222789 039858 0219264 039226 0162642 030107'.             CL**1
021200     05  FILLER PIC X(45) VALUE                                      CL**1
021300        ' 0247478 082901 0247478 082901 0247478 082901'.             CL**1
021400*RATE 900401 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
021500     05  FILLER PIC X(06) VALUE '900401'.                            CL**1
021600     05  FILLER PIC X(45) VALUE                                      CL**1
021700        ' 0263324 092712 0259155 091244 0269696 079940'.             CL**1
021800     05  FILLER PIC X(45) VALUE                                      CL**1
021900        ' 0236574 087979 0232828 086586 0258289 075572'.             CL**1
022000     05  FILLER PIC X(45) VALUE                                      CL**1
022100        ' 0252531 081062 0248532 079778 0246905 065531'.             CL**1
022200     05  FILLER PIC X(45) VALUE                                      CL**1
022300        ' 0266361 095908 0262144 094390 0250026 072833'.             CL**1
022400     05  FILLER PIC X(45) VALUE                                      CL**1
022500        ' 0242364 073399 0238526 072237 0244707 061108'.             CL**1
022600     05  FILLER PIC X(45) VALUE                                      CL**1
022700        ' 0252601 087390 0248602 086006 0237846 065285'.             CL**1
022800     05  FILLER PIC X(45) VALUE                                      CL**1
022900        ' 0251146 080512 0247170 079237 0228104 060039'.             CL**1
023000     05  FILLER PIC X(45) VALUE                                      CL**1
023100        ' 0242190 086314 0238355 084948 0231901 069506'.             CL**1
023200     05  FILLER PIC X(45) VALUE                                      CL**1
023300        ' 0235662 098511 0231931 096950 0224350 077793'.             CL**1
023400     05  FILLER PIC X(45) VALUE                                      CL**1
023500        ' 0250757 088818 0246788 087411 0243305 067386'.             CL**1
023600     05  FILLER PIC X(45) VALUE                                      CL**1
023700        ' 0222736 039848 0219212 039216 0162627 030104'.             CL**1
023800     05  FILLER PIC X(45) VALUE                                      CL**1
023900        ' 0247428 082884 0247428 082884 0247428 082884'.             CL**1
024000*RATE 901001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
024100     05  FILLER PIC X(06) VALUE '901001'.                            CL**1
024200     05  FILLER PIC X(45) VALUE                                      CL**1
024300        ' 0265371 108711 0261170 106989 0271225 093539'.             CL**1
024400     05  FILLER PIC X(45) VALUE                                      CL**1
024500        ' 0238412 102990 0234638 101360 0259752 088428'.             CL**1
024600     05  FILLER PIC X(45) VALUE                                      CL**1
024700        ' 0254497 095049 0250468 093544 0248312 076678'.             CL**1
024800     05  FILLER PIC X(45) VALUE                                      CL**1
024900        ' 0268432 112459 0264183 110678 0251448 085222'.             CL**1
025000     05  FILLER PIC X(45) VALUE                                      CL**1
025100        ' 0244247 086065 0240380 084703 0246102 071504'.             CL**1
025200     05  FILLER PIC X(45) VALUE                                      CL**1
025300        ' 0254569 102469 0250539 100846 0239194 076391'.             CL**1
025400     05  FILLER PIC X(45) VALUE                                      CL**1
025500        ' 0253105 094406 0249097 092911 0229396 070253'.             CL**1
025600     05  FILLER PIC X(45) VALUE                                      CL**1
025700        ' 0244155 101122 0240290 099520 0231980 080800'.             CL**1
025800     05  FILLER PIC X(45) VALUE                                      CL**1
025900        ' 0237496 115510 0233736 113681 0225621 091026'.             CL**1
026000     05  FILLER PIC X(45) VALUE                                      CL**1
026100        ' 0252696 104108 0248695 102460 0244635 078818'.             CL**1
026200     05  FILLER PIC X(45) VALUE                                      CL**1
026300        ' 0227274 047267 0223675 046519 0166750 035948'.             CL**1
026400     05  FILLER PIC X(45) VALUE                                      CL**1
026500        ' 0249201 097111 0249201 097111 0249201 097111'.             CL**1
026600*RATE 901021 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
026700     05  FILLER PIC X(06) VALUE '901021'.                            CL**1
026800     05  FILLER PIC X(45) VALUE                                      CL**1
026900        ' 0252711 103525 0248711 101885 0258286 089077'.             CL**1
027000     05  FILLER PIC X(45) VALUE                                      CL**1
027100        ' 0227038 098077 0223444 096525 0247360 084209'.             CL**1
027200     05  FILLER PIC X(45) VALUE                                      CL**1
027300        ' 0242356 090514 0238519 089082 0236466 073020'.             CL**1
027400     05  FILLER PIC X(45) VALUE                                      CL**1
027500        ' 0255626 107094 0251580 105398 0239452 081157'.             CL**1
027600     05  FILLER PIC X(45) VALUE                                      CL**1
027700        ' 0232595 081959 0228913 080663 0234361 068093'.             CL**1
027800     05  FILLER PIC X(45) VALUE                                      CL**1
027900        ' 0242425 097581 0238587 096035 0227783 072747'.             CL**1
028000     05  FILLER PIC X(45) VALUE                                      CL**1
028100        ' 0241030 089902 0237214 088478 0218452 066901'.             CL**1
028200     05  FILLER PIC X(45) VALUE                                      CL**1
028300        ' 0232508 096298 0228827 094772 0220913 076946'.             CL**1
028400     05  FILLER PIC X(45) VALUE                                      CL**1
028500        ' 0226166 109999 0222586 108258 0214857 086683'.             CL**1
028600     05  FILLER PIC X(45) VALUE                                      CL**1
028700        ' 0240641 099142 0236831 097572 0232965 075058'.             CL**1
028800     05  FILLER PIC X(45) VALUE                                      CL**1
028900        ' 0216432 045012 0213005 044299 0158795 034233'.             CL**1
029000     05  FILLER PIC X(45) VALUE                                      CL**1
029100        ' 0237313 092478 0237313 092478 0237313 092478'.             CL**1
029200*RATE 910101 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR          CL**1
029300     05  FILLER PIC X(06) VALUE '910101'.                            CL**1
029400     05  FILLER PIC X(45) VALUE                                      CL**1
029500        ' 0260503 106716 0256378 105026 0269937 093096'.             CL**1
029600     05  FILLER PIC X(45) VALUE                                      CL**1
029700        ' 0234038 101101 0230333 099500 0258518 088007'.             CL**1
029800     05  FILLER PIC X(45) VALUE                                      CL**1
029900        ' 0249828 093305 0245872 091828 0247132 076314'.             CL**1
030000     05  FILLER PIC X(45) VALUE                                      CL**1
030100        ' 0263508 110396 0259336 108648 0250254 084817'.             CL**1
030200     05  FILLER PIC X(45) VALUE                                      CL**1
030300        ' 0239766 084486 0235969 083149 0244934 071164'.             CL**1
030400     05  FILLER PIC X(45) VALUE                                      CL**1
030500        ' 0249899 100589 0245943 098996 0238058 076028'.             CL**1
030600     05  FILLER PIC X(45) VALUE                                      CL**1
030700        ' 0248461 092673 0244527 091207 0228307 069919'.             CL**1
030800     05  FILLER PIC X(45) VALUE                                      CL**1
030900        ' 0239676 099266 0235882 097694 0230879 080417'.             CL**1
031000     05  FILLER PIC X(45) VALUE                                      CL**1
031100        ' 0233139 113390 0229448 111595 0224550 090593'.             CL**1
031200     05  FILLER PIC X(45) VALUE                                      CL**1
031300        ' 0248060 102198 0244133 100580 0243474 078443'.             CL**1
031400     05  FILLER PIC X(45) VALUE                                      CL**1
031500        ' 0223104 046400 0219571 045665 0165958 035777'.             CL**1
031600     05  FILLER PIC X(45) VALUE                                      CL**1
031700        ' 0245471 095600 0245471 095600 0245471 095600'.             CL**1
031800     02  RATE-TAB2 REDEFINES RATE-WORK2.                             CL**1
031900     05  RATE-PERIOD2            OCCURS 7.                           CL**1
032000         10  RATE-EFF-DATE2      PIC X(06).                          CL**1
032100         10  REG-NAT2            OCCURS 12.                          CL**1
032200             15  R-URBAN-RURAL2  OCCURS 3.                           CL**1
032300                 20  FILLER      PIC X(01).                          CL**1
032400                 20  REG-LABOR2  PIC 9(05)V9(02).                    CL**1
032500                 20  FILLER      PIC X(01).                          CL**1
032600                 20  REG-NLABOR2 PIC 9(04)V9(02).                    CL**1
032700                                                                     CL**1
032800 01  UPDT-ENTRIES               PIC 9(02) VALUE 6.                   CL**1
032900 01  UPDT-TABLE.                                                     CL**1
033000     02  UPDT-WORK.                                                  CL**1
033100*UPDT 831001 UPDATING FACTORS EFFECTIVE DATE                         CL**1
033200     05  FILLER PIC X(06) VALUE '831001'.                            CL**1
033300     05  FILLER PIC X(18) VALUE 'UP01 830131 112509'.                CL**1
033400     05  FILLER PIC X(18) VALUE 'UP02 830228 112570'.                CL**1
033500     05  FILLER PIC X(18) VALUE 'UP03 830331 112631'.                CL**1
033600     05  FILLER PIC X(18) VALUE 'UP04 830430 112693'.                CL**1
033700     05  FILLER PIC X(18) VALUE 'UP05 830531 112754'.                CL**1
033800     05  FILLER PIC X(18) VALUE 'UP06 830630 112815'.                CL**1
033900     05  FILLER PIC X(18) VALUE 'UP07 830731 112877'.                CL**1
034000     05  FILLER PIC X(18) VALUE 'UP08 830831 112938'.                CL**1
034100     05  FILLER PIC X(18) VALUE 'UP09 820930 113570'.                CL**1
034200     05  FILLER PIC X(18) VALUE 'UP10 821031 113265'.                CL**1
034300     05  FILLER PIC X(18) VALUE 'UP11 821130 112961'.                CL**1
034400     05  FILLER PIC X(18) VALUE 'UP12 821231 112448'.                CL**1
034500*UPDT 840203 UPDATING FACTORS EFFECTIVE DATE                         CL**1
034600     05  FILLER PIC X(06) VALUE '840203'.                            CL**1
034700     05  FILLER PIC X(18) VALUE 'UP01 830131 112395'.                CL**1
034800     05  FILLER PIC X(18) VALUE 'UP02 830228 112456'.                CL**1
034900     05  FILLER PIC X(18) VALUE 'UP03 830331 112517'.                CL**1
035000     05  FILLER PIC X(18) VALUE 'UP04 830430 112578'.                CL**1
035100     05  FILLER PIC X(18) VALUE 'UP05 830531 112639'.                CL**1
035200     05  FILLER PIC X(18) VALUE 'UP06 830630 112701'.                CL**1
035300     05  FILLER PIC X(18) VALUE 'UP07 830731 112762'.                CL**1
035400     05  FILLER PIC X(18) VALUE 'UP08 830831 112823'.                CL**1
035500     05  FILLER PIC X(18) VALUE 'UP09 820930 113242'.                CL**1
035600     05  FILLER PIC X(18) VALUE 'UP10 821031 112938'.                CL**1
035700     05  FILLER PIC X(18) VALUE 'UP11 821130 112635'.                CL**1
035800     05  FILLER PIC X(18) VALUE 'UP12 821231 112333'.                CL**1
035900*UPDT 841001 UPDATING FACTORS EFFECTIVE DATE                         CL**1
036000     05  FILLER PIC X(06) VALUE '841001'.                            CL**1
036100     05  FILLER PIC X(18) VALUE 'UP01 830131 119197'.                CL**1
036200     05  FILLER PIC X(18) VALUE 'UP02 830228 119318'.                CL**1
036300     05  FILLER PIC X(18) VALUE 'UP03 830331 119438'.                CL**1
036400     05  FILLER PIC X(18) VALUE 'UP04 830430 119559'.                CL**1
036500     05  FILLER PIC X(18) VALUE 'UP05 830531 119680'.                CL**1
036600     05  FILLER PIC X(18) VALUE 'UP06 830630 119801'.                CL**1
036700     05  FILLER PIC X(18) VALUE 'UP07 830731 119922'.                CL**1
036800     05  FILLER PIC X(18) VALUE 'UP08 830831 120044'.                CL**1
036900     05  FILLER PIC X(18) VALUE 'UP09 820930 119898'.                CL**1
037000     05  FILLER PIC X(18) VALUE 'UP10 821031 119624'.                CL**1
037100     05  FILLER PIC X(18) VALUE 'UP11 821130 119349'.                CL**1
037200     05  FILLER PIC X(18) VALUE 'UP12 821231 119076'.                CL**1
037300*UPDT 860501 UPDATING FACTORS EFFECTIVE DATE  ----1.0050             CL**1
037400     05  FILLER PIC X(06) VALUE '860501'.                            CL**1
037500     05  FILLER PIC X(18) VALUE 'UP01 830131 119793'.                CL**1
037600     05  FILLER PIC X(18) VALUE 'UP02 830228 119915'.                CL**1
037700     05  FILLER PIC X(18) VALUE 'UP03 830331 120035'.                CL**1
037800     05  FILLER PIC X(18) VALUE 'UP04 830430 120157'.                CL**1
037900     05  FILLER PIC X(18) VALUE 'UP05 830531 120278'.                CL**1
038000     05  FILLER PIC X(18) VALUE 'UP06 830630 120400'.                CL**1
038100     05  FILLER PIC X(18) VALUE 'UP07 830731 120522'.                CL**1
038200     05  FILLER PIC X(18) VALUE 'UP08 830831 120644'.                CL**1
038300     05  FILLER PIC X(18) VALUE 'UP09 820930 120497'.                CL**1
038400     05  FILLER PIC X(18) VALUE 'UP10 821031 120222'.                CL**1
038500     05  FILLER PIC X(18) VALUE 'UP11 821130 119946'.                CL**1
038600     05  FILLER PIC X(18) VALUE 'UP12 821231 119671'.                CL**1
038700*UPDT 861001 UPDATING FACTORS EFFECTIVE DATE  ----1.0115             CL**1
038800     05  FILLER PIC X(06) VALUE '861001'.                            CL**1
038900     05  FILLER PIC X(18) VALUE 'UP01 830131 121171'.                CL**1
039000     05  FILLER PIC X(18) VALUE 'UP02 830228 121294'.                CL**1
039100     05  FILLER PIC X(18) VALUE 'UP03 830331 121415'.                CL**1
039200     05  FILLER PIC X(18) VALUE 'UP04 830430 121539'.                CL**1
039300     05  FILLER PIC X(18) VALUE 'UP05 830531 121661'.                CL**1
039400     05  FILLER PIC X(18) VALUE 'UP06 830630 121785'.                CL**1
039500     05  FILLER PIC X(18) VALUE 'UP07 830731 121908'.                CL**1
039600     05  FILLER PIC X(18) VALUE 'UP08 830831 122031'.                CL**1
039700     05  FILLER PIC X(18) VALUE 'UP09 820930 121883'.                CL**1
039800     05  FILLER PIC X(18) VALUE 'UP10 821031 121605'.                CL**1
039900     05  FILLER PIC X(18) VALUE 'UP11 821130 121325'.                CL**1
040000     05  FILLER PIC X(18) VALUE 'UP12 821231 121047'.                CL**1
040100*UPDT 871121 UPDATING FACTORS EFFECTIVE DATE  ----1.0270             CL**1
040200     05  FILLER PIC X(06) VALUE '871121'.                            CL**1
040300     05  FILLER PIC X(18) VALUE 'UP01 830131 124443'.                CL**1
040400     05  FILLER PIC X(18) VALUE 'UP02 830228 124569'.                CL**1
040500     05  FILLER PIC X(18) VALUE 'UP03 830331 124693'.                CL**1
040600     05  FILLER PIC X(18) VALUE 'UP04 830430 124821'.                CL**1
040700     05  FILLER PIC X(18) VALUE 'UP05 830531 124946'.                CL**1
040800     05  FILLER PIC X(18) VALUE 'UP06 830630 125073'.                CL**1
040900     05  FILLER PIC X(18) VALUE 'UP07 830731 125200'.                CL**1
041000     05  FILLER PIC X(18) VALUE 'UP08 830831 125326'.                CL**1
041100     05  FILLER PIC X(18) VALUE 'UP09 820930 125174'.                CL**1
041200     05  FILLER PIC X(18) VALUE 'UP10 821031 124888'.                CL**1
041300     05  FILLER PIC X(18) VALUE 'UP11 821130 124601'.                CL**1
041400     05  FILLER PIC X(18) VALUE 'UP12 821231 124315'.                CL**1
041500     02  UPDATE-TABLE REDEFINES UPDT-WORK.                           CL**1
041600     05  UPDT-PERIOD             OCCURS 6.                           CL**1
041700         10  UPDT-EFF-DATE       PIC X(06).                          CL**1
041800         10  UPDT-MONTH          OCCURS 12.                          CL**1
041900             15  FILLER          PIC X(05).                          CL**1
042000             15  UP-BASE-DATE    PIC X(06).                          CL**1
042100             15  FILLER          PIC X(01).                          CL**1
042200             15  UPDATE-FACTOR   PIC 9(01)V9(05).                    CL**1
042300                                                                     CL**1
042400 01  UPDT-ENTRIES2              PIC 9(02) VALUE 4.                   CL**1
042500 01  UPDT-TABLE2.                                                    CL**1
042600     02  UPDT-WORK2.                                                 CL**1
042700*UPDT 880401 UPDATING FACTORS EFFECTIVE DATE                         CL**1
042800*     LURBAN=1.0150 OURBAN=1.0100 RURAL=1.0300                       CL**1
042900     05  FILLER PIC X(06) VALUE '880401'.                            CL**1
043000     05  FILLER PIC X(27) VALUE '830131 122989 122383 124806'.       CL**1
043100     05  FILLER PIC X(27) VALUE '830228 123113 122507 124933'.       CL**1
043200     05  FILLER PIC X(27) VALUE '830331 123236 122629 125057'.       CL**1
043300     05  FILLER PIC X(27) VALUE '830430 123362 122754 125185'.       CL**1
043400     05  FILLER PIC X(27) VALUE '830531 123486 122878 125311'.       CL**1
043500     05  FILLER PIC X(27) VALUE '830630 123612 123003 125439'.       CL**1
043600     05  FILLER PIC X(27) VALUE '830731 123737 123127 125565'.       CL**1
043700     05  FILLER PIC X(27) VALUE '830831 123861 123251 125692'.       CL**1
043800     05  FILLER PIC X(27) VALUE '820930 123711 123102 125539'.       CL**1
043900     05  FILLER PIC X(27) VALUE '821031 123429 122821 125253'.       CL**1
044000     05  FILLER PIC X(27) VALUE '821130 123145 122538 124965'.       CL**1
044100     05  FILLER PIC X(27) VALUE '821231 122863 122257 124678'.       CL**1
044200*UPDT 881001 UPDATING FACTORS EFFECTIVE DATE                         CL**1
044300*     LURBAN=1.0340 OURBAN=1.0290 RURAL=1.0390                       CL**1
044400     05  FILLER PIC X(06) VALUE '881001'.                            CL**1
044500     05  FILLER PIC X(27) VALUE '830131 127171 125932 129673'.       CL**1
044600     05  FILLER PIC X(27) VALUE '830228 127299 126060 129805'.       CL**1
044700     05  FILLER PIC X(27) VALUE '830331 127426 126185 129934'.       CL**1
044800     05  FILLER PIC X(27) VALUE '830430 127556 126314 130067'.       CL**1
044900     05  FILLER PIC X(27) VALUE '830531 127685 126441 130198'.       CL**1
045000     05  FILLER PIC X(27) VALUE '830630 127815 126570 130331'.       CL**1
045100     05  FILLER PIC X(27) VALUE '830731 127944 126698 130462'.       CL**1
045200     05  FILLER PIC X(27) VALUE '830831 128072 126825 130594'.       CL**1
045300     05  FILLER PIC X(27) VALUE '820930 127917 126672 130435'.       CL**1
045400     05  FILLER PIC X(27) VALUE '821031 127626 126383 130138'.       CL**1
045500     05  FILLER PIC X(27) VALUE '821130 127332 126092 129839'.       CL**1
045600     05  FILLER PIC X(27) VALUE '821231 127040 125802 129540'.       CL**1
045700*UPDT 891001 UPDATING FACTORS EFFECTIVE DATE                         CL**1
045800*     LURBAN=1.0550 OURBAN=1.0550 RURAL=1.0550 (OCT - DEC)           CL**1
045900     05  FILLER PIC X(06) VALUE '891001'.                            CL**1
046000     05  FILLER PIC X(27) VALUE '830131 134165 132858 136805'.       CL**1
046100     05  FILLER PIC X(27) VALUE '830228 134300 132993 136944'.       CL**1
046200     05  FILLER PIC X(27) VALUE '830331 134434 133125 137080'.       CL**1
046300     05  FILLER PIC X(27) VALUE '830430 134572 133261 137221'.       CL**1
046400     05  FILLER PIC X(27) VALUE '830531 134708 133395 137359'.       CL**1
046500     05  FILLER PIC X(27) VALUE '830630 134845 133531 137499'.       CL**1
046600     05  FILLER PIC X(27) VALUE '830731 134981 133666 137637'.       CL**1
046700     05  FILLER PIC X(27) VALUE '830831 135116 133800 137777'.       CL**1
046800     05  FILLER PIC X(27) VALUE '820930 134952 133639 137609'.       CL**1
046900     05  FILLER PIC X(27) VALUE '821031 134645 133334 137296'.       CL**1
047000     05  FILLER PIC X(27) VALUE '821130 134335 133027 136980'.       CL**1
047100     05  FILLER PIC X(27) VALUE '821231 134027 132721 136665'.       CL**1
047200*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE                         CL**1
047300*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)           CL**1
047400     05  FILLER PIC X(06) VALUE '900101'.                            CL**1
047500     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.       CL**1
047600     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.       CL**1
047700     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.       CL**1
047800     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.       CL**1
047900     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.       CL**1
048000     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.       CL**1
048100     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.       CL**1
048200     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.       CL**1
048300     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.       CL**1
048400     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.       CL**1
048500     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.       CL**1
048600     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.       CL**1
048700     02  UPDATE-TABLE2 REDEFINES UPDT-WORK2.                         CL**1
048800     05  UPDT-PERIOD2             OCCURS 4.                          CL**1
048900         10  UPDT-EFF-DATE2       PIC X(06).                         CL**1
049000         10  UPDT-MONTH2          OCCURS 12.                         CL**1
049100             15  UP-BASE-DATE2    PIC X(06).                         CL**1
049200             15  UP-L-O-R2        OCCURS 3.                          CL**1
049300                 20  FILLER           PIC X(01).                     CL**1
049400                 20  UPDATE-FACTOR2   PIC 9(01)V9(05).               CL**1
049500                                                                     CL**1
049600 01  DRG-TABLE2.                                                     CL**1
049700     05  D-TAB2.                                                     CL**1
049800         10  FILLER                  PIC X(06) VALUE                 CL**1
049900        '881001'.                                                    CL**1
050000         10  FILLER                  PIC X(52) VALUE                 CL**1
050100        '0348731403638041406130353702918312734370268371223436'.      CL**1
050200         10  FILLER                  PIC X(52) VALUE                 CL**1
050300        '0155850652130004496020081602843311834360074320332027'.      CL**1
050400         10  FILLER                  PIC X(52) VALUE                 CL**1
050500        '0128570702931012443078303200785205027290092960692931'.      CL**1
050600         10  FILLER                  PIC X(52) VALUE                 CL**1
050700        '0092810742931012348075293100633304217280105120662931'.      CL**1
050800         10  FILLER                  PIC X(52) VALUE                 CL**1
050900        '0063020452029009585063283000608504322280170830793032'.      CL**1
051000         10  FILLER                  PIC X(52) VALUE                 CL**1
051100        '0136010722931007025045182900944104527290095280532529'.      CL**1
051200         10  FILLER                  PIC X(52) VALUE                 CL**1
051300        '0053320361528009116029202701652604727290121700602830'.      CL**1
051400         10  FILLER                  PIC X(52) VALUE                 CL**1
051500        '0059370352028003539020081700666704222280040630281327'.      CL**1
051600         10  FILLER                  PIC X(52) VALUE                 CL**1
051700        '0024570160509012705062283000577003919280065710290916'.      CL**1
051800         10  FILLER                  PIC X(52) VALUE                 CL**1
051900        '0072740301527003692022091700472201705070047630200818'.      CL**1
052000         10  FILLER                  PIC X(52) VALUE                 CL**1
052100        '0036570160407006424024091700369903716280063460582030'.      CL**1
052200         10  FILLER                  PIC X(52) VALUE                 CL**1
052300        '0055320341427006321039242800365202613270040180291427'.      CL**1
052400         10  FILLER                  PIC X(52) VALUE                 CL**1
052500        '0284181123335006448026091700570802309160084990301627'.      CL**1
052600         10  FILLER                  PIC X(52) VALUE                 CL**1
052700        '0061720211020006889032112200461301706120046840180713'.      CL**1
052800         10  FILLER                  PIC X(52) VALUE                 CL**1
052900        '0093210362528003097015030400390101606100026160150304'.      CL**1
053000         10  FILLER                  PIC X(52) VALUE                 CL**1
053100        '0079940262027003089013030501181104426280108830492729'.      CL**1
053200         10  FILLER                  PIC X(52) VALUE                 CL**1
053300        '0045570341223004394032132501047004820290078060511929'.      CL**1
053400         10  FILLER                  PIC X(52) VALUE                 CL**1
053500        '0053490391427005853034142700893304422280052560321627'.      CL**1
053600         10  FILLER                  PIC X(52) VALUE                 CL**1
053700        '0076290382328003427021092003033512234360243241033234'.      CL**1
053800         10  FILLER                  PIC X(52) VALUE                 CL**1
053900        '0104880412628014685089313302037509732340123390752931'.      CL**1
054000         10  FILLER                  PIC X(52) VALUE                 CL**1
054100        '0110320612730012367066293101010706528300052140411728'.      CL**1
054200         10  FILLER                  PIC X(52) VALUE                 CL**1
054300        '0116630692931007357047222901510805828300112100632530'.      CL**1
054400         10  FILLER                  PIC X(52) VALUE                 CL**1
054500        '0126950732931008268059193000760304315280131420692931'.      CL**1
054600         10  FILLER                  PIC X(52) VALUE                 CL**1
054700        '0083640512429013972075293100710405020290101370612130'.      CL**1
054800         10  FILLER                  PIC X(52) VALUE                 CL**1
054900        '0070760481527006356038142700745004017280050800281019'.      CL**1
055000         10  FILLER                  PIC X(52) VALUE                 CL**1
055100        '0098410542629005818036172814708032955570756311804042'.      CL**1
055200         10  FILLER                  PIC X(52) VALUE                 CL**1
055300        '0594391323537055493143363804210211028350558171143335'.      CL**1
055400         10  FILLER                  PIC X(52) VALUE                 CL**1
055500        '0377560742931036677127353702161708927330190420572830'.      CL**1
055600         10  FILLER                  PIC X(52) VALUE                 CL**1
055700        '0246731473739017145102323403980012835370266320652530'.      CL**1
055800         10  FILLER                  PIC X(52) VALUE                 CL**1
055900        '0122230462329016529028132700826404023280274031133335'.      CL**1
056000         10  FILLER                  PIC X(52) VALUE                 CL**1
056100        '0165450913133011455068263101423203025270118540452428'.      CL**1
056200         10  FILLER                  PIC X(52) VALUE                 CL**1
056300        '0068230241020030532173394101036506226300083590802232'.      CL**1
056400         10  FILLER                  PIC X(52) VALUE                 CL**1
056500        '0151320282527008896058283000588604224280077380451928'.      CL**1
056600         10  FILLER                  PIC X(52) VALUE                 CL**1
056700        '0056240341427006026043172800892705224290057130361428'.      CL**1
056800         10  FILLER                  PIC X(52) VALUE                 CL**1
056900        '0063150332127008488048202900574203514270065590411426'.      CL**1
057000         10  FILLER                  PIC X(52) VALUE                 CL**1
057100        '0068820451828005203034132400539703011200114830582830'.      CL**1
057200         10  FILLER                  PIC X(52) VALUE                 CL**1
057300        '0064340361628027773143363801866410726350327451463739'.      CL**1
057400         10  FILLER                  PIC X(52) VALUE                 CL**1
057500        '0177561042334027173126353701452708725330148070813032'.      CL**1
057600         10  FILLER                  PIC X(52) VALUE                 CL**1
057700        '0106360682131038125133353701720908530320083820602130'.      CL**1
057800         10  FILLER                  PIC X(52) VALUE                 CL**1
057900        '0097790552530005287032122501110305723300065850371325'.      CL**1
058000         10  FILLER                  PIC X(52) VALUE                 CL**1
058100        '0073310371628004714024081500938804623290240651123135'.      CL**1
058200         10  FILLER                  PIC X(52) VALUE                 CL**1
058300        '0142360791827014556070233100800804511180097130362428'.      CL**1
058400         10  FILLER                  PIC X(52) VALUE                 CL**1
058500        '0053200220919027677114333501379706629310120260702931'.      CL**1
058600         10  FILLER                  PIC X(52) VALUE                 CL**1
058700        '0070040422528009816057233000637604314260099270612530'.      CL**1
058800         10  FILLER                  PIC X(52) VALUE                 CL**1
058900        '0077330541829005684042132301092907329310091650592730'.      CL**1
059000         10  FILLER                  PIC X(52) VALUE                 CL**1
059100        '0053400411528007386050192900528403714270064460291627'.      CL**1
059200         10  FILLER                  PIC X(52) VALUE                 CL**1
059300        '0074880432328004112029112300457902108160095750512729'.      CL**1
059400         10  FILLER                  PIC X(52) VALUE                 CL**1
059500        '0048720301527007933042192805313517840420248011173436'.      CL**1
059600         10  FILLER                  PIC X(52) VALUE                 CL**1
059700        '0305661483739018809107333502336312132360156280932131'.      CL**1
059800         10  FILLER                  PIC X(52) VALUE                 CL**1
059900        '0177570922633010456065152202289412534360268440963234'.      CL**1
060000         10  FILLER                  PIC X(52) VALUE                 CL**1
060100        '0248750903133012400074293101090406629310102660612430'.      CL**1
060200         10  FILLER                  PIC X(52) VALUE                 CL**1
060300        '0123860682931006406040232800957405724300057980371528'.      CL**1
060400         10  FILLER                  PIC X(52) VALUE                 CL**1
060500        '0238291192736021237132353701541810726350146110732931'.      CL**1
060600         10  FILLER                  PIC X(52) VALUE                 CL**1
060700        '0176671023234020618120343601305308424320163310853032'.      CL**1
060800         10  FILLER                  PIC X(52) VALUE                 CL**1
060900        '0299851393638015637087313300984805620300092420532629'.      CL**1
061000         10  FILLER                  PIC X(52) VALUE                 CL**1
061100        '0151640652830008259035202701062104821290063780291120'.      CL**1
061200         10  FILLER                  PIC X(52) VALUE                 CL**1
061300        '0069720321627013916067293100665603215270080980301427'.      CL**1
061400         10  FILLER                  PIC X(52) VALUE                 CL**1
061500        '0051530200816008502043252800877303623280095930332527'.      CL**1
061600         10  FILLER                  PIC X(52) VALUE                 CL**1
061700        '0167450883133008595046222901195608330320088690712931'.      CL**1
061800         10  FILLER                  PIC X(52) VALUE                 CL**1
061900        '0057240472129016503108333500978707630320111860732931'.      CL**1
062000         10  FILLER                  PIC X(52) VALUE                 CL**1
062100        '0063540512129013247085313300656005126290071810552630'.      CL**1
062200         10  FILLER                  PIC X(52) VALUE                 CL**1
062300        '0052140421828005672045182900536503818280061760442028'.      CL**1
062400         10  FILLER                  PIC X(52) VALUE                 CL**1
062500        '0066780442628006679044242800420302511240034960180715'.      CL**1
062600         10  FILLER                  PIC X(52) VALUE                 CL**1
062700        '0078310602830004426037182800463802916270064190402028'.      CL**1
062800         10  FILLER                  PIC X(52) VALUE                 CL**1
062900        '0098930601729007915048122000987305027290060230291121'.      CL**1
063000         10  FILLER                  PIC X(52) VALUE                 CL**1
063100        '0063770260917004375019071202701815738400158811063335'.      CL**1
063200         10  FILLER                  PIC X(52) VALUE                 CL**1
063300        '0143030692931006895033192700606803116270061730251327'.      CL**1
063400         10  FILLER                  PIC X(52) VALUE                 CL**1
063500        '0168540813032006966034192701217408831330103660742931'.      CL**1
063600         10  FILLER                  PIC X(52) VALUE                 CL**1
063700        '0070790592630010508064283000573503421270053200311727'.      CL**1
063800         10  FILLER                  PIC X(52) VALUE                 CL**1
063900        '0096240732531006829058183000736704213240064030462329'.      CL**1
064000         10  FILLER                  PIC X(52) VALUE                 CL**1
064100        '0042490331527003424022091900776005526300048390371828'.      CL**1
064200         10  FILLER                  PIC X(52) VALUE                 CL**1
064300        '0302831754042025944113333502220113736380208730793032'.      CL**1
064400         10  FILLER                  PIC X(52) VALUE                 CL**1
064500        '0109520512029008046037122300510302207140271201233436'.      CL**1
064600         10  FILLER                  PIC X(52) VALUE                 CL**1
064700        '0119540662931007587061223000771304620290093960612830'.      CL**1
064800         10  FILLER                  PIC X(52) VALUE                 CL**1
064900        '0057280441728006434033152700845104827290111790722931'.      CL**1
065000         10  FILLER                  PIC X(52) VALUE                 CL**1
065100        '0064200462129037012158384002749112635370246031093335'.      CL**1
065200         10  FILLER                  PIC X(52) VALUE                 CL**1
065300        '0133340622830014321081303200863405217290154800732931'.      CL**1
065400         10  FILLER                  PIC X(52) VALUE                 CL**1
065500        '0083430402028009112046222900543402710200082820422228'.      CL**1
065600         10  FILLER                  PIC X(52) VALUE                 CL**1
065700        '0050540261123004323023122602414208531330128110642830'.      CL**1
065800         10  FILLER                  PIC X(52) VALUE                 CL**1
065900        '0034940200919010683062283000577703017270104270702631'.      CL**1
066000         10  FILLER                  PIC X(52) VALUE                 CL**1
066100        '0072470551829007487052182900791503115270040340230917'.      CL**1
066200         10  FILLER                  PIC X(52) VALUE                 CL**1
066300        '0068330462129004357031132600551103115270062000391728'.      CL**1
066400         10  FILLER                  PIC X(52) VALUE                 CL**1
066500        '0042270251021002788016050900914305427290056360351827'.      CL**1
066600         10  FILLER                  PIC X(52) VALUE                 CL**1
066700        '0066450352127018513111273501361708918260101620621830'.      CL**1
066800         10  FILLER                  PIC X(52) VALUE                 CL**1
066900        '0069500451116007524032222700586702713270043350240713'.      CL**1
067000         10  FILLER                  PIC X(52) VALUE                 CL**1
067100        '0098280401528004489021092000378801704060108150552330'.      CL**1
067200         10  FILLER                  PIC X(52) VALUE                 CL**1
067300        '0079070412128009178056283000483302613270067170382128'.      CL**1
067400         10  FILLER                  PIC X(52) VALUE                 CL**1
067500        '0038700210917006780050162900333301303050053600301527'.      CL**1
067600         10  FILLER                  PIC X(52) VALUE                 CL**1
067700        '0227041263537014985087233300945306312170075960531320'.      CL**1
067800         10  FILLER                  PIC X(52) VALUE                 CL**1
067900        '0221071123335012466077193000852505811150074390372128'.      CL**1
068000         10  FILLER                  PIC X(52) VALUE                 CL**1
068100        '0071850281627003701016051000682803517280044110220918'.      CL**1
068200         10  FILLER                  PIC X(52) VALUE                 CL**1
068300        '0194120963234011233063283000511003016270086830582330'.      CL**1
068400         10  FILLER                  PIC X(52) VALUE                 CL**1
068500        '0050580331727009456063193000709904810140044420311120'.      CL**1
068600         10  FILLER                  PIC X(52) VALUE                 CL**1
068700        '0030990230609005542029071100681704416280038870281121'.      CL**1
068800         10  FILLER                  PIC X(52) VALUE                 CL**1
068900        '0065740311427007938045122000295602109180025310160611'.      CL**1
069000         10  FILLER                  PIC X(52) VALUE                 CL**1
069100        '0038720170611001242013030500441603618280032000231226'.      CL**1
069200         10  FILLER                  PIC X(52) VALUE                 CL**1
069300        '0122320181526036480179394201826713334370115710863033'.      CL**1
069400         10  FILLER                  PIC X(52) VALUE                 CL**1
069500        '0178960702931011117054272900221803107110369721293537'.      CL**1
069600         10  FILLER                  PIC X(52) VALUE                 CL**1
069700        '0152060913033014618055283000742704523290045390181024'.      CL**1
069800         10  FILLER                  PIC X(52) VALUE                 CL**1
069900        '0104260562830012472066293100689904121280275131113335'.      CL**1
070000         10  FILLER                  PIC X(52) VALUE                 CL**1
070100        '0216881033234009001043262801582408230320080240482729'.      CL**1
070200         10  FILLER                  PIC X(52) VALUE                 CL**1
070300        '0104070492629027843127353701453707029310092740412428'.      CL**1
070400         10  FILLER                  PIC X(52) VALUE                 CL**1
070500        '0104730692931004811026102000473302813270043340221021'.      CL**1
070600         10  FILLER                  PIC X(52) VALUE                 CL**1
070700        '0124120722931007876049272903599215037390158960763032'.      CL**1
070800         10  FILLER                  PIC X(52) VALUE                 CL**1
070900        '0103540592730010188069293100965405924300067600461729'.      CL**1
071000         10  FILLER                  PIC X(52) VALUE                 CL**1
071100        '0065290441728007780035202801605908230320228651283537'.      CL**1
071200         10  FILLER                  PIC X(52) VALUE                 CL**1
071300        '0062150442228006286058283000599405327290073510612830'.      CL**1
071400         10  FILLER                  PIC X(52) VALUE                 CL**1
071500        '0089320732931009089088313300702806128300070040442628'.      CL**1
071600         10  FILLER                  PIC X(52) VALUE                 CL**1
071700        '0041100322127008095059283000573805027290101641123335'.      CL**1
071800         10  FILLER                  PIC X(52) VALUE                 CL**1
071900        '0127601443638000000000000001715107129310249941053335'.      CL**1
072000         10  FILLER                  PIC X(52) VALUE                 CL**1
072100        '0070380251426019165059283001190304226280078240522529'.      CL**1
072200         10  FILLER                  PIC X(52) VALUE                 CL**1
072300        '0052070381728004796024102200473402612240034700290917'.      CL**1
072400         10  FILLER                  PIC X(52) VALUE                 CL**1
072500        '0080770452228004800029142700481902918270094550482729'.      CL**1
072600         10  FILLER                  PIC X(52) VALUE                 CL**1
072700        '0050640321627008993044262800440502713270158270472729'.      CL**1
072800         10  FILLER                  PIC X(52) VALUE                 CL**1
072900        '0267660382628040349171394102030510332340101930652830'.      CL**1
073000         10  FILLER                  PIC X(52) VALUE                 CL**1
073100        '0073330241726018085136363800769205225290048310351527'.      CL**1
073200         10  FILLER                  PIC X(52) VALUE                 CL**1
073300        '0034360190713005566027202700446103125270330451253537'.      CL**1
073400         10  FILLER                  PIC X(52) VALUE                 CL**1
073500        '0000000000000000000000000004150316939411222651914143'.      CL**1
073600         10  FILLER                  PIC X(52) VALUE                 CL**1
073700        '0292960903133123838345575903143708931330222251493739'.      CL**1
073800         10  FILLER                  PIC X(52) VALUE                 CL**1
073900        '0137630632830000000000000000000000000000000000000000'.      CL**1
074000                                                                     CL**1
074100     05  DRGX-TAB2 REDEFINES D-TAB2.                                 CL**1
074200     10  DRGX-PERIOD2               OCCURS 1                         CL**1
074300                                    INDEXED BY DX3.                  CL**1
074400         15  DRGX-EFF-DATE2         PIC X(06).                       CL**1
074500         15  DRG-DATA2              OCCURS 480                       CL**1
074600                                    INDEXED BY DX4.                  CL**1
074700             20  DRG-WT2            PIC 9(02)V9(04).                 CL**1
074800             20  DRG-ALOS2          PIC 9(02)V9(01).                 CL**1
074900             20  DRG-DAYS-TRIMA     PIC 9(02).                       CL**1
075000             20  DRG-DAYS-TRIMB     PIC 9(02).                       CL**1
075100                                                                     CL**1
075200                                                                     CL**1
075300 LINKAGE SECTION.                                                    CL**1
075400                                                                     CL**1
075500***************************************************************      CL**1
075600*                 * * * * * * * * *                           *      CL**1
075700*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *      CL**1
075800*    IN HOW TO PAY THE BILL.                                  *      CL**1
075900*         REVIEW-CODE:                                        *      CL**1
076000*            00 = PAY-WITH-OUTLIER.                           *      CL**1
076100*                 WILL CALCULATE THE STANDARD PAYMENT.        *      CL**1
076200*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *      CL**1
076300*                 OUTLIERS. PPS-RTC CODES 01 AND 02 NOW SENT  *      CL**1
076400*                 TO THE PRO FOR POST PAYMENT REVIEW.       . *      CL**1
076500*            01 = PAY-DAYS-OUTLIER.                           *      CL**1
076600*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *      CL**1
076700*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *      CL**1
076800*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *      CL**1
076900*                 OUTLIER CUTOFF FOR THE DRG.                 *      CL**1
077000*            02 = PAY-COST-OUTLIER.                           *      CL**1
077100*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *      CL**1
077200*                 ALSO CALCULATE THE COST OUTLIER PORTION OF  *      CL**1
077300*                 THE PAYMENT IF THE ADJUSTED CHARGES ON THE  *      CL**1
077400*                 BILL EXCEED THE COST THRESHOLD.             *      CL**1
077500*                 IF  LENGTH OF STAY EXCEED OUTLIER CUTOFF, NO*      CL**1
077600*                 PAYMENT WILL BE MADE AND A RETURN-CODE OF   *      CL**1
077700*                 60 WILL BE RETURNED.                        *      CL**1
077800*            03 = PAY-PERDIEM-DAYS.                           *      CL**1
077900*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *      CL**1
078000*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *      CL**1
078100*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *      CL**1
078200*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *      CL**1
078300*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *      CL**1
078400*                 STANDARD PAYMENT IS CALCULATED.             *      CL**1
078500*                 TRANSFERS AFTER 093084 POTENTIALLY          *      CL**1
078600*                 ELIGABLE FOR COST OUTLIER PAYMENT.          *      CL**1
078700*            04 = PAY-AVG-STAY-ONLY.                          *      CL**1
078800*                 WILL CALCULATE THE STANDARD PAYMENT.        *      CL**1
078900*                 WILL NOT TEST FOR DAYS OR COST OUTLIERS.    *      CL**1
079000*            05 = PAY-XFER-WITH-COST                          *      CL**1
079100*                 PAY TRANSFER WITH COST OUTLIER APPROVED.    *      CL**1
079200*            06 = PAY-XFER-NO-COST                            *      CL**1
079300*                 PAY TRANSFER WITH COST OUTLIER DENIED.      *      CL**1
079400*            07 = PAY-WITHOUT-COST                            *      CL**1
079500*                 PAY WITHOUT COST OUTLIER.                   *      CL**1
079600*                                                             *      CL**1
079700***************************************************************      CL**1
079800 01  BILL-DATA.                                                      CL**1
079900         10  B-PROVIDER-NO          PIC X(06).                       CL**1
080000         10  B-REVIEW-CODE          PIC 9(02).                       CL**1
080100             88  VALID-REVIEW-CODE  VALUE 00 THRU 07.                CL**1
080200             88  PAY-WITH-OUTLIER   VALUE 00 07.                     CL**1
080300             88  PAY-DAYS-OUTLIER   VALUE 01.                        CL**1
080400             88  PAY-COST-OUTLIER   VALUE 02.                        CL**1
080500             88  PAY-PERDIEM-DAYS   VALUE 03.                        CL**1
080600             88  PAY-AVG-STAY-ONLY  VALUE 04.                        CL**1
080700             88  PAY-XFER-WITH-COST VALUE 05.                        CL**1
080800             88  PAY-XFER-NO-COST   VALUE 06.                        CL**1
080900             88  PAY-WITHOUT-COST   VALUE 07.                        CL**1
081000         10  B-DRG                  PIC 9(03).                       CL**1
081100         10  B-LOS                  PIC 9(03).                       CL**1
081200         10  B-COVERED-DAYS         PIC 9(03).                       CL**1
081300         10  B-LTR-DAYS             PIC 9(02).                       CL**1
081400         10  B-DISCHARGE-DATE.                                       CL**1
081500             15  B-DISCHG-MM        PIC 9(02).                       CL**1
081600             15  B-DISCHG-DD        PIC 9(02).                       CL**1
081700             15  B-DISCHG-YY        PIC 9(02).                       CL**1
081800         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).                 CL**1
081900***************************************************************      CL**1
082000*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *      CL**1
082100*    AND PASSED BACK TO THE CALLING PROGRAM                   *      CL**1
082200*            RETURN CODE VALUES (PPS-RTC)                     *      CL**1
082300*                                                             *      CL**1
082400*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *      CL**1
082500*              00 = PAID NORMAL DRG PAYMENT                   *      CL**1
082600*                                                             *      CL**1
082700*              01 = PAID AS A DAY-OUTLIER. SEND TO PRO FOR    *      CL**1
082800*                   POST PAYMENT REVIEW.                      *      CL**1
082900*              02 = PAID AS A COST-OUTLIER. SEND TO PRO FOR   *      CL**1
083000*                   POST PAYMENT REVIEW.                      *      CL**1
083100*              03 = PAID ON PERDIEM BASIS (XFER OR REVIEW 03) *      CL**1
083200*                   NOT POTENTIALLY ELIGEABLE FOR COST OUTLIER*      CL**1
083300*              04 = PAID NORMAL DRG PAYMENT ONLY. DAY AND     *      CL**1
083400*                   COST OUTLIER CRITERIA IGNORED.            *      CL**1
083500*              05 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *      CL**1
083600*                   OUTLIER APPROVED.                         *      CL**1
083700*              06 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *      CL**1
083800*                   OUTLIER DENIED.                           *      CL**1
083900*                                                             *      CL**1
084000*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *      CL**1
084100*              51 = NO PROVIDER SPECIFIC INFO FOUND           *      CL**1
084200*              52 = INVALID MSA # IN PROVIDER FILE            *      CL**1
084300*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *      CL**1
084400*              54 = DRG NOT 001-468 OR 471-477                *      CL**1
084500*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *      CL**1
084600*              56 = INVALID LENGTH OF STAY                    *      CL**1
084700*              57 = REVIEW CODE INVALID (NOT 00 - 07)         *      CL**1
084800*              58 = TOTAL CHARGES NOT NUMERIC                 *      CL**1
084900*              59 = POSSIBLE DAY OUTLIER CANDIDATE            *      CL**1
085000*              60 = REVIEW CODE 02 (POSSIBLE COST OUTLIER)    *      CL**1
085100*                   AND POSSIBLE DAY OUTLIER CANDIDATE. NOT   *      CL**1
085200*                   ELIGABLE FOR COST OUTLIER.                *      CL**1
085300*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *      CL**1
085400*              62 = INVALID NUMBER OF COVERED DAYS            *      CL**1
085500*              63 = POSSIBLE COST OUTLIER CANDIDATE.          *      CL**1
085600*              64 = DISPROPORTIONATE SHARE PERCENTAGE AND     *      CL**1
085700*                   BED-SIZE CONFLICT ON PROVIDER SPECIFIC FILE      CL**1
085800*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *      CL**1
085900***************************************************************      CL**1
086000 01  PPS-DATA.                                                       CL**1
086100         10  PPS-RTC                PIC 9(02).                       CL**1
086200         10  PPS-WAGE-INDX          PIC 9(02)V9(04).                 CL**1
086300         10  PPS-OUTLIER-DAYS       PIC 9(03).                       CL**1
086400         10  PPS-AVG-LOS            PIC 9(02)V9(01).                 CL**1
086500         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).                 CL**1
086600         10  PPS-INDTEACH-ADJ       PIC 9(06)V9(02).                 CL**1
086700         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).                 CL**1
086800         10  PPS-HSP-PART           PIC 9(06)V9(02).                 CL**1
086900         10  PPS-FSP-PART           PIC 9(06)V9(02).                 CL**1
087000         10  PPS-OUTLIER-PART       PIC 9(07)V9(02).                 CL**1
087100         10  PPS-REG-DAYS-USED      PIC 9(03).                       CL**1
087200         10  PPS-LTR-DAYS-USED      PIC 9(02).                       CL**1
087300         10  PPS-DSH-ADJ            PIC 9(06)V9(02).                 CL**1
087400         10  PPS-CALC-VERS          PIC X(05).                       CL**1
087500                                                                     CL**1
087600******************************************************************   CL**1
087700*            THESE ARE THE VERSIONS OF THE PPCAL                     CL**1
087800*           PROGRAMS THAT WILL BE PASSED BACK----                    CL**1
087900*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
088000******************************************************************   CL**1
088100 01  PRICER-OPT-VERS-SW.                                             CL**1
088200     02  PRICER-OPTION-SW          PIC X(01).                        CL**1
088300         88  ALL-TABLES-PASSED          VALUE 'A'.                   CL**1
088400         88  PROV-RECORD-PASSED         VALUE 'P'.                   CL**1
088500         88  ADDITIONAL-VARIABLES       VALUE 'M'.                   CL**1
088600     02  PPS-VERSIONS.                                               CL**1
088700         10  PPDRV-VERSION        PIC X(05).                         CL**1
088800                                                                     CL**1
088900******************************************************************   CL**1
089000*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK              CL**1
089100*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
089200******************************************************************   CL**1
089300 01  PPS-ADDITIONAL-VARIABLES.                                       CL**1
089400     05  PPS-HSP-PCT                PIC 9(01)V9(02).                 CL**1
089500     05  PPS-FSP-PCT                PIC 9(01)V9(02).                 CL**1
089600     05  PPS-NAT-PCT                PIC 9(01)V9(02).                 CL**1
089700     05  PPS-REG-PCT                PIC 9(01)V9(02).                 CL**1
089800     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).                 CL**1
089900     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).                 CL**1
090000     05  PPS-DRG-WT                 PIC 9(02)V9(04).                 CL**1
090100     05  PPS-NAT-LABOR              PIC 9(05)V9(02).                 CL**1
090200     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).                 CL**1
090300     05  PPS-REG-LABOR              PIC 9(05)V9(02).                 CL**1
090400     05  PPS-REG-NLABOR             PIC 9(05)V9(02).                 CL**1
090500     05  PPS-COLA                   PIC 9(01)V9(03).                 CL**1
090600     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).                 CL**1
090700     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).                 CL**1
090800     05  PPS-BILL-COSTS             PIC 9(07)V9(09).                 CL**1
090900     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).                 CL**1
091000                                                                     CL**1
091100******************************************************************   CL**1
091200*               THIS IS THE PROVIDER RECORD                          CL**1
091300*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
091400******************************************************************   CL**1
091500 01  PROV-HOLD.                                                      CL**1
091600     02  PROV-REC-HOLD.                                              CL**1
091700         05  P-PROVIDER-NO.                                          CL**1
091800             10  P-STATE                PIC 9(02).                   CL**1
091900             10  FILLER                 PIC X(04).                   CL**1
092000         05  P-EFF-DATE.                                             CL**1
092100             10  P-EFF-YY               PIC 9(02).                   CL**1
092200             10  P-EFF-MM               PIC 9(02).                   CL**1
092300             10  P-EFF-DD               PIC 9(02).                   CL**1
092400         05  P-WAIVER-CODE              PIC X(01).                   CL**1
092500             88  WAIVER-STATE           VALUE 'Y'.                   CL**1
092600         05  P-PROVIDER-TYPE            PIC X(02).                   CL**1
092700             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.             CL**1
092800             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.   CL**1
092900             88  INDIAN-HEALTH-SERVICE  VALUE '08'.                  CL**1
093000             88  REDESIGNATED-RURAL-YR1 VALUE '09'.                  CL**1
093100             88  REDESIGNATED-RURAL-YR2 VALUE '10'.                  CL**1
093200             88  SOLE-COM-REF-CENT      VALUE '11'.                  CL**1
093300             88  MDH-REBASED-FY90       VALUE '14' '15'.             CL**1
093400             88  MDH-RRC-REBASED-FY90   VALUE '15'.                  CL**1
093500             88  SCH-REBASED-FY90       VALUE '16' '17'.             CL**1
093600             88  SCH-RRC-REBASED-FY90   VALUE '17'.                  CL**1
093700         05  P-CURRENT-CENSUS-DIV       PIC 9(01).                   CL**1
093800             88  NEW-ENGLAND            VALUE  1.                    CL**1
093900             88  MIDDLE-ATLANTIC        VALUE  2.                    CL**1
094000             88  SOUTH-ATLANTIC         VALUE  3.                    CL**1
094100             88  EAST-NORTH-CENTRAL     VALUE  4.                    CL**1
094200             88  EAST-SOUTH-CENTRAL     VALUE  5.                    CL**1
094300             88  WEST-NORTH-CENTRAL     VALUE  6.                    CL**1
094400             88  WEST-SOUTH-CENTRAL     VALUE  7.                    CL**1
094500             88  MOUNTAIN               VALUE  8.                    CL**1
094600             88  PACIFIC                VALUE  9.                    CL**1
094700         05  P-PPS-BLEND-YEAR           PIC 9(01).                   CL**1
094800             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.              CL**1
094900         05  P-MSA-X.                                                CL**1
095000             10  P-RURAL                PIC X(04).                   CL**1
095100                 88  RURAL              VALUE  '9999'.               CL**1
095200         05  P-MSA-9 REDEFINES P-MSA-X  PIC 9(04).                   CL**1
095300         05  P-FISCAL-YEAR-END.                                      CL**1
095400             10  P-MM                   PIC 9(02).                   CL**1
095500             10  P-DD                   PIC 9(02).                   CL**1
095600             10  P-YY                   PIC 9(02).                   CL**1
095700         05  P-VARIABLES.                                            CL**1
095800             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).            CL**1
095900             10  P-COLA                 PIC S9(01)V9(03).            CL**1
096000             10  P-INTERN-RATIO         PIC S9(01)V9(04).            CL**1
096100             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).            CL**1
096200             10  P-BED-SIZE             PIC  9(05).                  CL**1
096300             10  P-DSH-PERCENT          PIC V9(04).                  CL**1
096400             10  P-CCR                  PIC  9(01)V9(03).            CL**1
096500             10  P-CMI                  PIC  9(01)V9(04).            CL**1
096600             10  FILLER                 PIC  9(01).                  CL**1
096700             10  P-REPORT-DATE          PIC  9(06).                  CL**1
096800             10  FILLER                 PIC  9(01).                  CL**1
096900             10  P-INTER-NO             PIC  9(05).                  CL**1
097000     02  FILLER                         PIC X(80).                   CL**1
097100                                                                     CL**1
097200******************************************************************   CL**1
097300*                   THIS IS THE WAGE-INDEX                           CL**1
097400*          ASSOCIATED WITH THE BILL BEING PROCESSED                  CL**1
097500******************************************************************   CL**1
097600 01  WAGE-INDEX-RECORD.                                              CL**1
097700     05  W-MSA               PIC X(4).                               CL**1
097800     05  W-SIZE              PIC X(01).                              CL**1
097900         88  LARGE-URBAN       VALUE 'L'.                            CL**1
098000         88  OTHER-URBAN       VALUE 'O'.                            CL**1
098100         88  ALL-RURAL         VALUE 'R'.                            CL**1
098200     05  W-EFF-DATE          PIC X(6).                               CL**1
098300     05  FILLER              PIC X.                                  CL**1
098400     05  W-INDEX-RECORD      PIC S9(02)V9(04).                       CL**1
098500                                                                     CL**1
098600 PROCEDURE DIVISION  USING BILL-DATA                                 CL**1
098700                           PPS-DATA                                  CL**1
098800                           PRICER-OPT-VERS-SW                        CL**1
098900                           PPS-ADDITIONAL-VARIABLES                  CL**1
099000                           PROV-HOLD                                 CL**1
099100                           WAGE-INDEX-RECORD.                        CL**1
099200                                                                     CL**1
099300***************************************************************      CL**1
099400*    PROCESSING:                                              *      CL**1
099500*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE               CL**1
099600*        B. INITIALIZE PPCAL  WORK VARIABLES.                 *      CL**1
099700*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *      CL**1
099800*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *      CL**1
099900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *      CL**1
100000*           GOBACK.                                           *      CL**1
100100*        D. ASSEMBLE PRICING COMPONENTS.                      *      CL**1
100200*        E. CALCULATE THE BLENDED PRICE.                      *      CL**1
100300***************************************************************      CL**1
100400                                                                     CL**1
100500     PERFORM 0200-MAINLINE-CONTROL.                                  CL**1
100600                                                                     CL**1
100700     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.    CL**1
100800     MOVE CAL-VERSION               TO  PPS-CALC-VERS.               CL**1
100900                                                                     CL**1
101000     GOBACK.                                                         CL**1
101100                                                                     CL**1
101200 0200-MAINLINE-CONTROL.                                              CL**1
101300     MOVE ALL '0' TO PPS-DATA.                                       CL**1
101400     MOVE ALL '0' TO HOLD-PPS-COMPONENTS.                            CL**1
101500     MOVE ALL '0' TO HOLD-ADDITIONAL-VARIABLES.                      CL**1
101600     PERFORM 1000-EDIT-THE-BILL-INFO.                                CL**1
101700     IF  PPS-RTC = 00                                                CL**1
101800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES                         CL**1
101900         PERFORM 3000-CALC-BLENDED-PAYMENT.                          CL**1
102000                                                                     CL**1
102100 1000-EDIT-THE-BILL-INFO.                                            CL**1
102200***************************************************************      CL**1
102300*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *      CL**1
102400*    AND DO NOT ATTEMPT TO PRICE.                             *      CL**1
102500***************************************************************      CL**1
102600     MOVE B-DISCHG-YY TO H-BILL-YY.                                  CL**1
102700     MOVE B-DISCHG-MM TO H-BILL-MM.                                  CL**1
102800     MOVE B-DISCHG-DD TO H-BILL-DD.                                  CL**1
102900     IF  PPS-RTC = 00                                                CL**1
103000         IF  WAIVER-STATE                                            CL**1
103100             MOVE 53 TO PPS-RTC.                                     CL**1
103200     IF  PPS-RTC = 00                                                CL**1
103300         IF  B-DRG < 001 OR > 477 OR = 469 OR = 470                  CL**1
103400             MOVE 54 TO PPS-RTC.                                     CL**1
103500     IF  PPS-RTC = 00                                                CL**1
103600         MOVE P-EFF-DATE  TO HOLD-PROV-DATE                          CL**1
103700         MOVE P-YY        TO H-FYE-YY                                CL**1
103800         MOVE P-MM        TO H-FYE-MM                                CL**1
103900         MOVE P-DD        TO H-FYE-DD                                CL**1
104000         IF  HOLD-BILL-DATE < HOLD-PROV-DATE                         CL**1
104100             MOVE 55 TO PPS-RTC.                                     CL**1
104200     IF  PPS-RTC = 00                                                CL**1
104300         IF  B-REVIEW-CODE NOT NUMERIC                               CL**1
104400             MOVE 57 TO PPS-RTC.                                     CL**1
104500     IF  PPS-RTC = 00                                                CL**1
104600         IF  B-LOS NOT NUMERIC                                       CL**1
104700             MOVE 56 TO PPS-RTC                                      CL**1
104800         ELSE                                                        CL**1
104900         IF  B-LOS = 0 AND B-REVIEW-CODE NOT = 03                    CL**1
105000             MOVE 56 TO PPS-RTC.                                     CL**1
105100     IF  PPS-RTC = 00                                                CL**1
105200         IF  B-LTR-DAYS NOT NUMERIC                                  CL**1
105300             MOVE 61 TO PPS-RTC                                      CL**1
105400         ELSE                                                        CL**1
105500             MOVE B-LTR-DAYS TO H-LTR-DAYS.                          CL**1
105600     IF  PPS-RTC = 00                                                CL**1
105700         IF  B-COVERED-DAYS NOT NUMERIC                              CL**1
105800             MOVE 62 TO PPS-RTC                                      CL**1
105900         ELSE                                                        CL**1
106000         IF  B-COVERED-DAYS = 0 AND B-LOS > 0                        CL**1
106100             MOVE 62 TO PPS-RTC                                      CL**1
106200         ELSE                                                        CL**1
106300             MOVE B-COVERED-DAYS TO H-COV-DAYS.                      CL**1
106400     IF  PPS-RTC = 00                                                CL**1
106500         IF  H-LTR-DAYS  > H-COV-DAYS                                CL**1
106600             MOVE 62 TO PPS-RTC                                      CL**1
106700         ELSE                                                        CL**1
106800             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.           CL**1
106900     IF  PPS-RTC = 00                                                CL**1
107000         IF  NOT VALID-REVIEW-CODE                                   CL**1
107100             MOVE 57 TO PPS-RTC.                                     CL**1
107200     IF  PPS-RTC = 00                                                CL**1
107300         IF  B-CHARGES-CLAIMED NOT NUMERIC                           CL**1
107400             MOVE 58 TO PPS-RTC.                                     CL**1
107500                                                                     CL**1
107600 2000-ASSEMBLE-PPS-VARIABLES.                                        CL**1
107700***************************************************************      CL**1
107800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *      CL**1
107900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *      CL**1
108000*    OF THAT VARIABLE.                                        *      CL**1
108100***************************************************************      CL**1
108200***  GET THE PROVIDER SPECIFIC VARIABLES.                            CL**1
108300                                                                     CL**1
108400     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.                           CL**1
108500     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.                          CL**1
108600     IF  NOT (P-STATE = 02 OR 12)                                    CL**1
108700         MOVE 1 TO H-COLA                                            CL**1
108800     ELSE                                                            CL**1
108900         MOVE P-COLA TO H-COLA.                                      CL**1
109000***************************************************************      CL**1
109100***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF                 CL**1
109200                                                                     CL**1
109300     PERFORM 2500-GET-DRG-WEIGHT2 VARYING DX3                        CL**1
109400             FROM 1 BY 1 UNTIL DX3 > 1.                              CL**1
109500                                                                     CL**1
109600***************************************************************      CL**1
109700***  GET THE WAGE-INDEX                                              CL**1
109800                                                                     CL**1
109900     MOVE W-INDEX-RECORD TO H-WAGE-INDX.                             CL**1
110000                                                                     CL**1
110100***************************************************************      CL**1
110200***  GET THE LABOR, NON-LABOR STANDARD RATES                         CL**1
110300                                                                     CL**1
110400     IF  P-CURRENT-CENSUS-DIV NUMERIC                                CL**1
110500         MOVE P-CURRENT-CENSUS-DIV TO R2                             CL**1
110600     ELSE                                                            CL**1
110700         MOVE 10 TO R2.                                              CL**1
110800                                                                     CL**1
110900     MOVE 10 TO R4.                                                  CL**1
111000                                                                     CL**1
111100     IF  P-STATE = 40                                                CL**1
111200         MOVE 11 TO R2                                               CL**1
111300         MOVE 12 TO R4.                                              CL**1
111400                                                                     CL**1
111500     IF  RURAL                                                       CL**1
111600         MOVE 2 TO R3                                                CL**1
111700     ELSE                                                            CL**1
111800         MOVE 1 TO R3.                                               CL**1
111900                                                                     CL**1
112000     IF  REFERRAL-CENTER                                             CL**1
112100         MOVE 1 TO R3.                                               CL**1
112200                                                                     CL**1
112300     PERFORM 2300-GET-LABOR-NLABOR-RATES2 VARYING R1                 CL**1
112400             FROM 1 BY 1 UNTIL R1 > 7.                               CL**1
112500                                                                     CL**1
112600***************************************************************      CL**1
112700***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL                  CL**1
112800                                                                     CL**1
112900     IF  H-FYE-MMDD > '0929'                                         CL**1
113000         MOVE 83 TO H-FYE-YY                                         CL**1
113100     ELSE                                                            CL**1
113200         MOVE 84 TO H-FYE-YY.                                        CL**1
113300                                                                     CL**1
113400     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30         CL**1
113500         MOVE 31 TO H-FYE-DD                                         CL**1
113600     ELSE                                                            CL**1
113700     IF  H-FYE-MM = 02 AND H-FYE-DD > 27                             CL**1
113800         MOVE 31 TO H-FYE-DD.                                        CL**1
113900                                                                     CL**1
114000     COMPUTE MO-DIFF =                                               CL**1
114100         ((H-BILL-YY - 83) * 12 + H-BILL-MM) -                       CL**1
114200         ((H-FYE-YY  - 83) * 12 + H-FYE-MM).                         CL**1
114300                                                                     CL**1
114400     IF  H-BILL-DD > H-FYE-DD                                        CL**1
114500         ADD 1 TO MO-DIFF.                                           CL**1
114600                                                                     CL**1
114700     IF  MO-DIFF < 13 MOVE 1 TO HSP-FY                               CL**1
114800     ELSE                                                            CL**1
114900     IF  MO-DIFF < 32 MOVE 2 TO HSP-FY                               CL**1
115000     ELSE                                                            CL**1
115100     IF  MO-DIFF < 37 MOVE 3 TO HSP-FY                               CL**1
115200     ELSE                                                            CL**1
115300     IF  MO-DIFF < 49 MOVE 4 TO HSP-FY.                              CL**1
115400                                                                     CL**1
115500     IF  MO-DIFF > 48 AND < 61                                       CL**1
115600         MOVE 4 TO HSP-FY                                            CL**1
115700         PERFORM 2100-CHECK-HSP-FY5.                                 CL**1
115800                                                                     CL**1
115900     IF  MO-DIFF > 60 MOVE 7 TO HSP-FY.                              CL**1
116000                                                                     CL**1
116100     IF  MO-DIFF > 72                                                CL**1
116200         MOVE 8 TO HSP-FY.                                           CL**1
116300                                                                     CL**1
116400     IF  P-PPS-BLEND-YEAR NUMERIC AND VALID-PPS-BLEND-YEAR           CL**1
116500         MOVE P-PPS-BLEND-YEAR TO HSP-FY.                            CL**1
116600                                                                     CL**1
116700     IF  HSP-FY < 5                                                  CL**1
116800         MOVE HSP (HSP-FY) TO H-HSP-PCT                              CL**1
116900         MOVE FSP (HSP-FY) TO H-FSP-PCT                              CL**1
117000     ELSE                                                            CL**1
117100         MOVE 0.00  TO H-HSP-PCT                                     CL**1
117200         MOVE 1.00  TO H-FSP-PCT.                                    CL**1
117300                                                                     CL**1
117400     IF  P-STATE = 38                                                CL**1
117500         IF HSP-FY = 3                                               CL**1
117600            MOVE 0.25  TO H-HSP-PCT MOVE 0.75 TO H-FSP-PCT           CL**1
117700         ELSE                                                        CL**1
117800         IF HSP-FY > 3                                               CL**1
117900            MOVE 0.00  TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.          CL**1
118000                                                                     CL**1
118100***************************************************************      CL**1
118200***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL        CL**1
118300                                                                     CL**1
118400         MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.              CL**1
118500                                                                     CL**1
118600     IF  P-STATE = 38                                                CL**1
118700             MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.          CL**1
118800                                                                     CL**1
118900***************************************************************      CL**1
119000*    REGIONAL FLOOR                                                  CL**1
119100                                                                     CL**1
119200         IF  (H-REG-LABOR + H-REG-NLABOR) >                          CL**1
119300             (H-NAT-LABOR + H-NAT-NLABOR)                            CL**1
119400             MOVE 0.85 TO H-NAT-PCT MOVE 0.15 TO H-REG-PCT.          CL**1
119500                                                                     CL**1
119600     IF  P-STATE = 40                                                CL**1
119700         MOVE 0.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT               CL**1
119800         MOVE 0.25 TO H-NAT-PCT MOVE 0.75 TO H-REG-PCT.              CL**1
119900                                                                     CL**1
120000     IF  SOLE-COMMUNITY-PROV                                         CL**1
120100         MOVE 0.75 TO H-HSP-PCT MOVE 0.25 TO H-FSP-PCT               CL**1
120200         MOVE 0.00 TO H-NAT-PCT MOVE 1.00 TO H-REG-PCT.              CL**1
120300                                                                     CL**1
120400     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90                        CL**1
120500         MOVE 1.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.              CL**1
120600                                                                     CL**1
120700***************************************************************      CL**1
120800***  GET THE STANDARD UPDATING FACTOR                                CL**1
120900                                                                     CL**1
121000     MOVE HSP-FY TO U1.                                              CL**1
121100     ADD 1 TO U1.                                                    CL**1
121200     MOVE P-MM TO U2.                                                CL**1
121300                                                                     CL**1
121400     IF  H-FYE-MM = 01 AND H-FYE-DD < 16                             CL**1
121500         MOVE 12 TO U2                                               CL**1
121600     ELSE                                                            CL**1
121700     IF  H-FYE-MM = 02 AND H-FYE-DD < 15                             CL**1
121800         MOVE 01 TO U2                                               CL**1
121900     ELSE                                                            CL**1
122000     IF  H-FYE-MM > 02 AND H-FYE-DD < 16                             CL**1
122100         COMPUTE U2 = U2 - 1.                                        CL**1
122200                                                                     CL**1
122300     MOVE R3 TO U3.                                                  CL**1
122400                                                                     CL**1
122500     IF  REFERRAL-CENTER                                             CL**1
122600         MOVE 3 TO U3.                                               CL**1
122700                                                                     CL**1
122800     IF  U1 > 6                                                      CL**1
122900         SUBTRACT 6 FROM U1                                          CL**1
123000         MOVE UPDATE-FACTOR2 (U1 U2 U3) TO H-UPDATE-FACTOR           CL**1
123100     ELSE                                                            CL**1
123200         MOVE UPDATE-FACTOR  (U1 U2)    TO H-UPDATE-FACTOR.          CL**1
123300                                                                     CL**1
123400***************************************************************      CL**1
123500***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE                   CL**1
123600                                                                     CL**1
123700     IF  PRUP-UPDT-FACTOR NUMERIC                                    CL**1
123800         IF  PRUP-UPDT-FACTOR > 0                                    CL**1
123900             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.               CL**1
124000                                                                     CL**1
124100 2100-CHECK-HSP-FY5.                                                 CL**1
124200     COMPUTE HOLD-BILL-DAYS =                                        CL**1
124300         H-BILL-YY * 365 + T-DAYS (H-BILL-MM) + H-BILL-DD.           CL**1
124400                                                                     CL**1
124500     IF  (H-BILL-YY = 84 OR 88 OR 92) AND H-BILL-MM > 2              CL**1
124600         ADD 1 TO HOLD-BILL-DAYS.                                    CL**1
124700                                                                     CL**1
124800     IF  H-FYE-MMDD > '0929'                                         CL**1
124900         MOVE 87 TO H-FYE-YY                                         CL**1
125000     ELSE                                                            CL**1
125100         MOVE 88 TO H-FYE-YY.                                        CL**1
125200                                                                     CL**1
125300     IF P-DD NOT NUMERIC                                             CL**1
125400     MOVE 1 TO  P-DD.                                                CL**1
125500                                                                     CL**1
125600     MOVE P-DD TO H-FYE-DD.                                          CL**1
125700                                                                     CL**1
125800     COMPUTE HOLD-PROV-DAYS =                                        CL**1
125900         H-FYE-YY * 365 + T-DAYS (H-FYE-MM) + H-FYE-DD.              CL**1
126000                                                                     CL**1
126100     IF  (H-FYE-YY = 84 OR 88 OR 92) AND H-FYE-MM > 2                CL**1
126200         ADD 1 TO HOLD-PROV-DAYS.                                    CL**1
126300                                                                     CL**1
126400     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 51)                      CL**1
126500         MOVE 5 TO HSP-FY.                                           CL**1
126600                                                                     CL**1
126700     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 183)                     CL**1
126800         MOVE 6 TO HSP-FY.                                           CL**1
126900                                                                     CL**1
127000 2300-GET-LABOR-NLABOR-RATES2.                                       CL**1
127100     IF  LARGE-URBAN                                                 CL**1
127200         MOVE 1 TO R3                                                CL**1
127300     ELSE                                                            CL**1
127400     IF  OTHER-URBAN OR REFERRAL-CENTER                              CL**1
127500         MOVE 2 TO R3                                                CL**1
127600     ELSE                                                            CL**1
127700         MOVE 3 TO R3.                                               CL**1
127800                                                                     CL**1
127900     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE2 (R1)                    CL**1
128000         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR                  CL**1
128100         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NLABOR                 CL**1
128200         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR                  CL**1
128300         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NLABOR                 CL**1
128400         IF REDESIGNATED-RURAL-YR1 OR REDESIGNATED-RURAL-YR2         CL**1
128500            PERFORM 2350-BLEND-RURAL-RATES2.                         CL**1
128600                                                                     CL**1
128700 2350-BLEND-RURAL-RATES2.                                            CL**1
128800      IF  REDESIGNATED-RURAL-YR1                                     CL**1
128900          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3                    CL**1
129000      ELSE                                                           CL**1
129100          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.                   CL**1
129200                                                                     CL**1
129300      COMPUTE H-REG-LABOR  ROUNDED =                                 CL**1
129400          (REG-LABOR2  (R1 R2 2) - REG-LABOR2  (R1 R2 3))            CL**1
129500            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R2 3).            CL**1
129600                                                                     CL**1
129700      COMPUTE H-REG-NLABOR ROUNDED =                                 CL**1
129800          (REG-NLABOR2 (R1 R2 2) - REG-NLABOR2 (R1 R2 3))            CL**1
129900            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R2 3).            CL**1
130000                                                                     CL**1
130100      COMPUTE H-NAT-LABOR  ROUNDED =                                 CL**1
130200          (REG-LABOR2  (R1 R4 2) - REG-LABOR2  (R1 R4 3))            CL**1
130300            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R4 3).            CL**1
130400                                                                     CL**1
130500      COMPUTE H-NAT-NLABOR ROUNDED =                                 CL**1
130600          (REG-NLABOR2 (R1 R4 2) - REG-NLABOR2 (R1 R4 3))            CL**1
130700            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R4 3).            CL**1
130800                                                                     CL**1
130900 2500-GET-DRG-WEIGHT2.                                               CL**1
131000     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE2 (DX3)                   CL**1
131100         SET DX4 TO B-DRG                                            CL**1
131200         MOVE DRG-WT2 (DX3 DX4)         TO H-DRG-WT                  CL**1
131300         MOVE DRG-ALOS2 (DX3 DX4)       TO H-ALOS                    CL**1
131400         IF  HOLD-BILL-DATE > '881031'                               CL**1
131500             MOVE DRG-DAYS-TRIMB (DX3 DX4) TO H-DAYS-CUTOFF          CL**1
131600         ELSE                                                        CL**1
131700             MOVE DRG-DAYS-TRIMA (DX3 DX4) TO H-DAYS-CUTOFF.         CL**1
131800                                                                     CL**1
131900 3000-CALC-BLENDED-PAYMENT.                                          CL**1
132000***************************************************************      CL**1
132100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *      CL**1
132200*        CALCULATE COVERED DAYS UTILIZATION.                  *      CL**1
132300*        CALCULATE THE FEDERAL PORTION.                       *      CL**1
132400*        CALCULATE THE HOSPITAL PORTION.                      *      CL**1
132500*        CALCULATE THE DAYS-OUTLIER PORTION.                  *      CL**1
132600*        CALCULATE THE COST-OUTLIER PORTION.                  *      CL**1
132700*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *      CL**1
132800*        CALCULATE THE INDIRECT TEACHING ADJUSTMENT.          *      CL**1
132900***************************************************************      CL**1
133000     PERFORM 3100-CALC-STAY-UTILIZATION.                             CL**1
133100     PERFORM 3300-CALC-FSP-AMT.                                      CL**1
133200     PERFORM 3400-CALC-HSP-AMT.                                      CL**1
133300     MOVE 00            TO  PPS-RTC.                                 CL**1
133400     MOVE H-WAGE-INDX   TO  PPS-WAGE-INDX.                           CL**1
133500     MOVE H-ALOS        TO  PPS-AVG-LOS.                             CL**1
133600     MOVE H-DAYS-CUTOFF TO  PPS-DAYS-CUTOFF.                         CL**1
133700                                                                     CL**1
133800     PERFORM 3600-CALC-OUTLIER.                                      CL**1
133900                                                                     CL**1
134000     IF  PAY-AVG-STAY-ONLY                                           CL**1
134100         MOVE 0  TO H-OUTLIER-PART                                   CL**1
134200         MOVE 04 TO PPS-RTC.                                         CL**1
134300                                                                     CL**1
134400     IF  PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST                      CL**1
134500         IF  B-LOS < H-ALOS                                          CL**1
134600             IF  NOT (B-DRG = 385 OR 456)                            CL**1
134700                 PERFORM 3500-CALC-PERDIEM-AMT                       CL**1
134800                 MOVE 03 TO PPS-RTC.                                 CL**1
134900                                                                     CL**1
135000     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)                    CL**1
135100         IF  H-OUTCST-PART > 0                                       CL**1
135200             MOVE H-OUTCST-PART TO H-OUTLIER-PART                    CL**1
135300             MOVE 05 TO PPS-RTC                                      CL**1
135400         ELSE                                                        CL**1
135500         IF  PPS-RTC NOT = 03                                        CL**1
135600             MOVE 00 TO PPS-RTC                                      CL**1
135700             MOVE 0  TO H-OUTLIER-PART.                              CL**1
135800                                                                     CL**1
135900     IF  PAY-DAYS-OUTLIER                                            CL**1
136000         IF  PPS-RTC NOT = 01                                        CL**1
136100             MOVE 0  TO H-OUTLIER-PART                               CL**1
136200             MOVE 00 TO PPS-RTC.                                     CL**1
136300                                                                     CL**1
136400     IF  PAY-COST-OUTLIER                                            CL**1
136500         IF  PPS-RTC = 01                                            CL**1
136600             MOVE 0  TO H-OUTLIER-PART                               CL**1
136700             MOVE 60 TO PPS-RTC.                                     CL**1
136800                                                                     CL**1
136900     IF  PAY-XFER-NO-COST                                            CL**1
137000         MOVE 0  TO H-OUTLIER-PART                                   CL**1
137100         MOVE 00 TO PPS-RTC                                          CL**1
137200         IF B-LOS < H-ALOS                                           CL**1
137300         IF  NOT (B-DRG = 385 OR 456)                                CL**1
137400             PERFORM 3500-CALC-PERDIEM-AMT                           CL**1
137500             MOVE 06 TO PPS-RTC.                                     CL**1
137600                                                                     CL**1
137700     IF  PPS-RTC < 50                                                CL**1
137800         PERFORM 3800-CALC-BLEND-AMT                                 CL**1
137900     ELSE                                                            CL**1
138000         MOVE 0 TO PPS-HSP-PART                                      CL**1
138100                   PPS-FSP-PART                                      CL**1
138200                   PPS-OUTLIER-PART                                  CL**1
138300                   PPS-OUTLIER-DAYS                                  CL**1
138400                   PPS-REG-DAYS-USED                                 CL**1
138500                   PPS-LTR-DAYS-USED                                 CL**1
138600                   PPS-TOTAL-PAYMENT                                 CL**1
138700                   PPS-DSH-ADJ                                       CL**1
138800                   PPS-INDTEACH-ADJ.                                 CL**1
138900                                                                     CL**1
139000 3100-CALC-STAY-UTILIZATION.                                         CL**1
139100     IF  H-REG-DAYS > 0                                              CL**1
139200         IF  H-REG-DAYS < H-DAYS-CUTOFF                              CL**1
139300             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED                    CL**1
139400             MOVE 0          TO H-REG-DAYS                           CL**1
139500         ELSE                                                        CL**1
139600             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED                 CL**1
139700             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS                  CL**1
139800     ELSE                                                            CL**1
139900     IF  H-LTR-DAYS < H-DAYS-CUTOFF                                  CL**1
140000         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED                        CL**1
140100         MOVE 0          TO H-LTR-DAYS                               CL**1
140200     ELSE                                                            CL**1
140300         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED                     CL**1
140400         SUBTRACT H-DAYS-CUTOFF  FROM H-LTR-DAYS.                    CL**1
140500                                                                     CL**1
140600     IF  B-LOS > H-DAYS-CUTOFF                                       CL**1
140700         PERFORM 3200-CALC-OUTLIER-UTILIZATION.                      CL**1
140800                                                                     CL**1
140900 3200-CALC-OUTLIER-UTILIZATION.                                      CL**1
141000     COMPUTE PPS-OUTLIER-DAYS =                                      CL**1
141100         B-LOS - H-DAYS-CUTOFF.                                      CL**1
141200                                                                     CL**1
141300     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS                CL**1
141400         COMPUTE PPS-OUTLIER-DAYS =                                  CL**1
141500             H-REG-DAYS + H-LTR-DAYS                                 CL**1
141600         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                         CL**1
141700         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED                         CL**1
141800     ELSE                                                            CL**1
141900     IF  H-REG-DAYS < PPS-OUTLIER-DAYS                               CL**1
142000         ADD H-REG-DAYS TO PPS-REG-DAYS-USED                         CL**1
142100         COMPUTE PPS-LTR-DAYS-USED =                                 CL**1
142200             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS - H-REG-DAYS)     CL**1
142300     ELSE                                                            CL**1
142400         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.                  CL**1
142500                                                                     CL**1
142600     IF  B-REVIEW-CODE = 03 OR 04                                    CL**1
142700         IF  PPS-REG-DAYS-USED > 0                                   CL**1
142800             MOVE 0 TO PPS-LTR-DAYS-USED.                            CL**1
142900                                                                     CL**1
143000 3300-CALC-FSP-AMT.                                                  CL**1
143100     COMPUTE H-FSP-PART ROUNDED =                                    CL**1
143200         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +                   CL**1
143300         H-NAT-NLABOR * H-COLA) * H-DRG-WT)                          CL**1
143400                           +                                         CL**1
143500         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +                   CL**1
143600         H-REG-NLABOR * H-COLA) * H-DRG-WT).                         CL**1
143700                                                                     CL**1
143800 3400-CALC-HSP-AMT.                                                  CL**1
143900     COMPUTE H-HSP-PART ROUNDED =                                    CL**1
144000         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.                 CL**1
144100                                                                     CL**1
144200 3500-CALC-PERDIEM-AMT.                                              CL**1
144300     MOVE B-LOS TO H-COV-DAYS.                                       CL**1
144400                                                                     CL**1
144500     IF  H-COV-DAYS = 0                                              CL**1
144600         MOVE 1 TO H-COV-DAYS.                                       CL**1
144700                                                                     CL**1
144800     COMPUTE H-HSP-PART ROUNDED =                                    CL**1
144900        H-HSP-PART / H-ALOS * H-COV-DAYS                             CL**1
145000        ON SIZE ERROR MOVE 0 TO H-HSP-PART.                          CL**1
145100                                                                     CL**1
145200     COMPUTE H-FSP-PART ROUNDED =                                    CL**1
145300        H-FSP-PART / H-ALOS * H-COV-DAYS                             CL**1
145400        ON SIZE ERROR MOVE 0 TO H-FSP-PART.                          CL**1
145500                                                                     CL**1
145600 3600-CALC-OUTLIER.                                                  CL**1
145700     MOVE 0.60 TO H-DAYOUT-PCT H-CSTOUT-PCT.                         CL**1
145800                                                                     CL**1
145900     IF  HOLD-BILL-DATE > '881031'                                   CL**1
146000         MOVE 0.75 TO H-CSTOUT-PCT.                                  CL**1
146100                                                                     CL**1
146200     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472              CL**1
146300             MOVE 0.90 TO H-DAYOUT-PCT H-CSTOUT-PCT.                 CL**1
146400                                                                     CL**1
146500     MOVE 0.7439   TO H-LABOR-PCT.                                   CL**1
146600     MOVE 0.2561   TO H-NLABOR-PCT.                                  CL**1
146700     MOVE 0.660    TO H-CSTCHG-RATIO.                                CL**1
146800                                                                     CL**1
146900     IF  HOLD-BILL-DATE > '881031'                                   CL**1
147000         IF  P-CCR NUMERIC                                           CL**1
147100             MOVE P-CCR TO H-CSTCHG-RATIO                            CL**1
147200         ELSE                                                        CL**1
147300             MOVE 0.000 TO H-CSTCHG-RATIO.                           CL**1
147400                                                                     CL**1
147500     MOVE 2.000 TO H-CST-MULTIPLE.                                   CL**1
147600                                                                     CL**1
147700     IF  HOLD-BILL-DATE < '881101'                                   CL**1
147800         MOVE 23750.00 TO H-CST-THRESH                               CL**1
147900     ELSE                                                            CL**1
148000     IF  HOLD-BILL-DATE < '891001'                                   CL**1
148100         MOVE 28000.00 TO H-CST-THRESH.                              CL**1
148200                                                                     CL**1
148300***********************************************************          CL**1
148400***  DAY OUTLIER CALCULATION                                         CL**1
148500                                                                     CL**1
148600     IF  PPS-OUTLIER-DAYS > 0                                        CL**1
148700     COMPUTE H-OUTDAY-PART  =                                        CL**1
148800         H-DAYOUT-PCT *  H-FSP-PART / H-ALOS * PPS-OUTLIER-DAYS      CL**1
148900         ON SIZE ERROR MOVE 0 TO H-OUTDAY-PART.                      CL**1
149000                                                                     CL**1
149100***********************************************************          CL**1
149200***  COST OUTLIER CALCULATION                                        CL**1
149300                                                                     CL**1
149400     COMPUTE H-DOLLAR-THRESHOLD ROUNDED =                            CL**1
149500         (H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDX) +               CL**1
149600         (H-CST-THRESH * H-NLABOR-PCT * H-COLA).                     CL**1
149700                                                                     CL**1
149800     COMPUTE H-COST-OUTLIER ROUNDED =                                CL**1
149900         H-CST-MULTIPLE * H-FSP-PART.                                CL**1
150000                                                                     CL**1
150100     IF  H-DOLLAR-THRESHOLD > H-COST-OUTLIER                         CL**1
150200         MOVE H-DOLLAR-THRESHOLD TO H-COST-OUTLIER.                  CL**1
150300                                                                     CL**1
150400     PERFORM 3700-CALC-IND-TEACHING.                                 CL**1
150500     MOVE 0 TO H-DSH-PERCENT.                                        CL**1
150600                                                                     CL**1
150700     IF  P-DSH-PERCENT NUMERIC                                       CL**1
150800         MOVE P-DSH-PERCENT TO H-DSH-PERCENT.                        CL**1
150900                                                                     CL**1
151000     COMPUTE H-BILL-COSTS ROUNDED =                                  CL**1
151100         B-CHARGES-CLAIMED * H-CSTCHG-RATIO /                        CL**1
151200         (1 + H-IND-TEACHING + H-DSH-PERCENT)                        CL**1
151300         ON SIZE ERROR MOVE 0 TO H-BILL-COSTS.                       CL**1
151400                                                                     CL**1
151500     IF  H-BILL-COSTS > H-COST-OUTLIER                               CL**1
151600         COMPUTE H-OUTCST-PART =                                     CL**1
151700         H-CSTOUT-PCT * (H-BILL-COSTS - H-COST-OUTLIER).             CL**1
151800                                                                     CL**1
151900     IF  H-OUTCST-PART NOT NUMERIC                                   CL**1
152000         MOVE 0 TO H-OUTCST-PART.                                    CL**1
152100                                                                     CL**1
152200     IF  PAY-WITHOUT-COST                                            CL**1
152300         MOVE 0 TO H-OUTCST-PART.                                    CL**1
152400                                                                     CL**1
152500***********************************************************          CL**1
152600***  DAY OUTLIER PRECEDENCE                                          CL**1
152700                                                                     CL**1
152800     IF  HOLD-BILL-DATE < '881101'                                   CL**1
152900         IF  H-OUTDAY-PART > 0 OR H-OUTCST-PART > 0                  CL**1
153000             IF  H-OUTDAY-PART > 0                                   CL**1
153100                 MOVE H-OUTDAY-PART TO H-OUTLIER-PART                CL**1
153200                 MOVE 01 TO PPS-RTC                                  CL**1
153300             ELSE                                                    CL**1
153400                 MOVE H-OUTCST-PART TO H-OUTLIER-PART                CL**1
153500                 MOVE 02 TO PPS-RTC.                                 CL**1
153600                                                                     CL**1
153700***********************************************************          CL**1
153800***  GREATER OF DAY OR COST                                          CL**1
153900                                                                     CL**1
154000     IF  HOLD-BILL-DATE > '881031'                                   CL**1
154100         IF  H-OUTDAY-PART > 0 OR H-OUTCST-PART > 0                  CL**1
154200             IF  H-OUTDAY-PART > H-OUTCST-PART                       CL**1
154300                 MOVE H-OUTDAY-PART TO H-OUTLIER-PART                CL**1
154400                 MOVE 01 TO PPS-RTC                                  CL**1
154500             ELSE                                                    CL**1
154600                 MOVE H-OUTCST-PART TO H-OUTLIER-PART                CL**1
154700                 MOVE 02 TO PPS-RTC.                                 CL**1
154800                                                                     CL**1
154900 3700-CALC-IND-TEACHING.                                             CL**1
155000                                                                     CL**1
155100      COMPUTE H-IND-TEACHING =                                       CL**1
155200            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).              CL**1
155300                                                                     CL**1
155400 3800-CALC-BLEND-AMT.                                                CL**1
155500     IF  H-CMI-ADJ-CPD = 0                                           CL**1
155600         MOVE 0.00 TO H-HSP-PCT                                      CL**1
155700         MOVE 1.00 TO H-FSP-PCT.                                     CL**1
155800                                                                     CL**1
155900     COMPUTE PPS-HSP-PART ROUNDED =                                  CL**1
156000         H-HSP-PCT * H-HSP-PART.                                     CL**1
156100                                                                     CL**1
156200     COMPUTE PPS-FSP-PART ROUNDED =                                  CL**1
156300         H-FSP-PCT * H-FSP-PART.                                     CL**1
156400                                                                     CL**1
156500     COMPUTE PPS-OUTLIER-PART ROUNDED =                              CL**1
156600             H-FSP-PCT * H-OUTLIER-PART.                             CL**1
156700                                                                     CL**1
156800     MOVE ZERO TO PPS-DSH-ADJ.                                       CL**1
156900                                                                     CL**1
157000     IF  P-DSH-PERCENT NUMERIC                                       CL**1
157100             COMPUTE PPS-DSH-ADJ ROUNDED =                           CL**1
157200             (PPS-FSP-PART + PPS-OUTLIER-PART) * P-DSH-PERCENT.      CL**1
157300                                                                     CL**1
157400     PERFORM 3700-CALC-IND-TEACHING.                                 CL**1
157500                                                                     CL**1
157600     COMPUTE PPS-INDTEACH-ADJ ROUNDED =                              CL**1
157700         (PPS-FSP-PART + PPS-OUTLIER-PART) * H-IND-TEACHING.         CL**1
157800                                                                     CL**1
157900     COMPUTE PPS-TOTAL-PAYMENT =                                     CL**1
158000             PPS-HSP-PART     + PPS-FSP-PART +                       CL**1
158100             PPS-OUTLIER-PART + PPS-DSH-ADJ  +                       CL**1
158200             PPS-INDTEACH-ADJ.                                       CL**1
158300                                                                     CL**1
158400******      L A S T   S O U R C E   S T A T E M E N T     *****      CL**1
