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