000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL905.
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 '001PPCAL905  09/22/93'.
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE
002000     'PPCAL905 - WORKING   STORAGE'.
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C90.5'.
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  F1                             PIC S9(04) COMP SYNC.
003300 01  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.
003400 01  HSP-FY                         PIC S9(04) COMP SYNC VALUE +1.
003500 01  MO-DIFF                        PIC  9(02).
003600
003700 01  BLEND-TABLE.
003800     05  BLEND-PCTS.
003900         10  FILLER      PIC X(15)  VALUE '075050045025000'.
004000         10  FILLER      PIC X(15)  VALUE '025050055075100'.
004100     05  FILLER REDEFINES BLEND-PCTS.
004200         10  HSP                    PIC 9(01)V9(02)  OCCURS 5.
004300         10  FSP                    PIC 9(01)V9(02)  OCCURS 5.
004400
004500 01  CAL-MO-DAYS.
004600     05  CAL-YYMMDD.
004700         10  T-YY                   PIC 99.
004800         10  T-MM                   PIC 99.
004900         10  T-DD                   PIC 99.
005000     05  DAYS-MO.
005100         10  FILLER                 PIC X(36)  VALUE
005200            '000031059090120151181212243273304334'.
005300     05  FILLER           REDEFINES DAYS-MO.
005400         10  T-DAYS                 PIC 999 OCCURS 12.
005500
005600 01  HOLD-AREA.
005700     02  HOLD-DATES.
005800         05  HOLD-BILL-DATE.
005900             10  H-BILL-YY              PIC 9(02).
006000             10  H-BILL-MM              PIC 9(02).
006100             10  H-BILL-DD              PIC 9(02).
006200         05  HOLD-BILL-DATE-9 REDEFINES HOLD-BILL-DATE
006300                                        PIC 9(06).
006400         05  HOLD-BILL-DAYS             PIC 9(06).
006500
006600         05  HOLD-PROV-DATE.
006700             10  H-PROV-YY              PIC 9(02).
006800             10  H-PROV-MM              PIC 9(02).
006900             10  H-PROV-DD              PIC 9(02).
007000         05  HOLD-PROV-DATE-9 REDEFINES HOLD-PROV-DATE
007100                                        PIC 9(06).
007200         05  HOLD-PROV-FYE-DATE.
007300             10  H-FYE-YY               PIC 9(02).
007400             10  H-FYE-MMDD.
007500             15  H-FYE-MM           PIC 9(02).
007600             15  H-FYE-DD           PIC 9(02).
007700         05  HOLD-PROV-FYE-9  REDEFINES HOLD-PROV-FYE-DATE
007800                                        PIC 9(06).
007900         05  HOLD-PROV-DAYS             PIC 9(06).
008000
008100     02  H-IND-TEACHING                 PIC  9(06)V9(09).
008200     02  H-DSH-PERCENT                  PIC  V9(04).
008300
008400     02  HOLD-PROV-MSA.
008500         05  H-PROV-BLANK               PIC X(02).
008600         05  H-PROV-STATE               PIC X(02).
008700
008800     02  HOLD-PPS-COMPONENTS.
008900         05  H-HSP-PART                 PIC 9(06)V9(09).
009000         05  H-FSP-PART                 PIC 9(06)V9(09).
009100         05  H-OUTLIER-PART             PIC 9(07)V9(09).
009200         05  H-OUTDAY-PART              PIC 9(07)V9(09).
009300         05  H-OUTCST-PART              PIC 9(07)V9(09).
009400         05  H-COV-DAYS                 PIC 9(03).
009500         05  H-REG-DAYS                 PIC 9(03).
009600         05  H-LTR-DAYS                 PIC 9(03).
009700         05  H-WAGE-INDX                PIC 9(02)V9(04).
009800         05  H-ALOS                     PIC 9(02)V9(01).
009900         05  H-DAYS-CUTOFF              PIC 9(02)V9(01).
010000         05  H-DAYOUT-PCT               PIC 9(01)V9(02).
010100         05  H-CSTOUT-PCT               PIC 9(01)V9(02).
010200         05  H-CSTCHG-RATIO             PIC 9(01)V9(03).
010300         05  H-CST-MULTIPLE             PIC 9(01)V9(03).
010400         05  H-CST-THRESH               PIC 9(05)V9(02).
010500         05  H-LABOR-PCT                PIC 9(01)V9(04).
010600         05  H-NLABOR-PCT               PIC 9(01)V9(04).
010700
010800     02  HOLD-ADDITIONAL-VARIABLES.
010900         05  H-HSP-PCT                  PIC 9(01)V9(02).
011000         05  H-FSP-PCT                  PIC 9(01)V9(02).
011100         05  H-NAT-PCT                  PIC 9(01)V9(02).
011200         05  H-REG-PCT                  PIC 9(01)V9(02).
011300         05  H-CMI-ADJ-CPD              PIC 9(05)V9(02).
011400         05  H-UPDATE-FACTOR            PIC 9(01)V9(05).
011500         05  H-DRG-WT                   PIC 9(02)V9(04).
011600         05  H-NAT-LABOR                PIC 9(05)V9(02).
011700         05  H-NAT-NLABOR               PIC 9(05)V9(02).
011800         05  H-REG-LABOR                PIC 9(05)V9(02).
011900         05  H-REG-NLABOR               PIC 9(05)V9(02).
012000         05  H-COLA                     PIC 9(01)V9(03).
012100         05  H-INTERN-RATIO             PIC 9(01)V9(04).
012200         05  H-COST-OUTLIER             PIC 9(07)V9(09).
012300         05  H-BILL-COSTS               PIC 9(07)V9(09).
012400         05  H-DOLLAR-THRESHOLD         PIC 9(07)V9(09).
012500
012600     02  HOLD-WORK-VARIABLES.
012700         05  H-HSP-RATE                 PIC 9(06)V9(09).
012800         05  H-FSP-RATE                 PIC 9(06)V9(09).
012900         05  OUTLIER-FACT               PIC 9(01)V9(06).
013000
013100***************************************************************
013200*    LAYUP TABLE AREA FOR RATES                               *
013300***************************************************************
013400 01  RATE-TABLE2.
013500     02  RATE-WORK2.
013600*RATE 891001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
013700     05  FILLER PIC X(06) VALUE '891001'.
013800     05  FILLER PIC X(45) VALUE
013900        ' 0263058 092619 0260496 091716 0259278 076852'.
014000     05  FILLER PIC X(45) VALUE
014100        ' 0236335 087890 0234033 087034 0248311 072653'.
014200     05  FILLER PIC X(45) VALUE
014300        ' 0252275 080979 0249818 080190 0237367 062999'.
014400     05  FILLER PIC X(45) VALUE
014500        ' 0266091 095811 0263500 094878 0240367 070019'.
014600     05  FILLER PIC X(45) VALUE
014700        ' 0242118 073325 0239760 072611 0235254 058747'.
014800     05  FILLER PIC X(45) VALUE
014900        ' 0252345 087301 0249888 086451 0228658 062763'.
015000     05  FILLER PIC X(45) VALUE
015100        ' 0250892 080431 0248449 079647 0219292 057720'.
015200     05  FILLER PIC X(45) VALUE
015300        ' 0241944 086226 0239588 085387 0222943 066821'.
015400     05  FILLER PIC X(45) VALUE
015500        ' 0235423 098411 0233130 097452 0215683 074788'.
015600     05  FILLER PIC X(45) VALUE
015700        ' 0250503 088728 0248065 087863 0233906 064783'.
015800     05  FILLER PIC X(45) VALUE
015900        ' 0222510 039808 0220346 039419 0156345 028941'.
016000     05  FILLER PIC X(45) VALUE
016100        ' 0245417 082355 0245417 082355 0245417 082355'.
016200*RATE 900101 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
016300     05  FILLER PIC X(06) VALUE '900101'.
016400     05  FILLER PIC X(45) VALUE
016500        ' 0263387 092735 0259217 091266 0269721 079948'.
016600     05  FILLER PIC X(45) VALUE
016700        ' 0236631 088000 0232884 086607 0258313 075579'.
016800     05  FILLER PIC X(45) VALUE
016900        ' 0252591 081081 0248592 079797 0246928 065537'.
017000     05  FILLER PIC X(45) VALUE
017100        ' 0266424 095931 0262206 094413 0250049 072839'.
017200     05  FILLER PIC X(45) VALUE
017300        ' 0242422 073417 0238584 072254 0244730 061113'.
017400     05  FILLER PIC X(45) VALUE
017500        ' 0252661 087411 0248661 086026 0237868 065291'.
017600     05  FILLER PIC X(45) VALUE
017700        ' 0251207 080532 0247229 079256 0228125 060045'.
017800     05  FILLER PIC X(45) VALUE
017900        ' 0242248 086334 0238412 084968 0231923 069512'.
018000     05  FILLER PIC X(45) VALUE
018100        ' 0235718 098534 0231986 096973 0224370 077800'.
018200     05  FILLER PIC X(45) VALUE
018300        ' 0250817 088839 0246847 087432 0243328 067392'.
018400     05  FILLER PIC X(45) VALUE
018500        ' 0222789 039858 0219264 039226 0162642 030107'.
018600     05  FILLER PIC X(45) VALUE
018700        ' 0247478 082901 0247478 082901 0247478 082901'.
018800*RATE 900401 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
018900     05  FILLER PIC X(06) VALUE '900401'.
019000     05  FILLER PIC X(45) VALUE
019100        ' 0263324 092712 0259155 091244 0269696 079940'.
019200     05  FILLER PIC X(45) VALUE
019300        ' 0236574 087979 0232828 086586 0258289 075572'.
019400     05  FILLER PIC X(45) VALUE
019500        ' 0252531 081062 0248532 079778 0246905 065531'.
019600     05  FILLER PIC X(45) VALUE
019700        ' 0266361 095908 0262144 094390 0250026 072833'.
019800     05  FILLER PIC X(45) VALUE
019900        ' 0242364 073399 0238526 072237 0244707 061108'.
020000     05  FILLER PIC X(45) VALUE
020100        ' 0252601 087390 0248602 086006 0237846 065285'.
020200     05  FILLER PIC X(45) VALUE
020300        ' 0251146 080512 0247170 079237 0228104 060039'.
020400     05  FILLER PIC X(45) VALUE
020500        ' 0242190 086314 0238355 084948 0231901 069506'.
020600     05  FILLER PIC X(45) VALUE
020700        ' 0235662 098511 0231931 096950 0224350 077793'.
020800     05  FILLER PIC X(45) VALUE
020900        ' 0250757 088818 0246788 087411 0243305 067386'.
021000     05  FILLER PIC X(45) VALUE
021100        ' 0222736 039848 0219212 039216 0162627 030104'.
021200     05  FILLER PIC X(45) VALUE
021300        ' 0247428 082884 0247428 082884 0247428 082884'.
021400     02  RATE-TAB2 REDEFINES RATE-WORK2.
021500     05  RATE-PERIOD2            OCCURS 3.
021600         10  RATE-EFF-DATE2      PIC X(06).
021700         10  REG-NAT2            OCCURS 12.
021800             15  R-URBAN-RURAL2  OCCURS 3.
021900                 20  FILLER      PIC X(01).
022000                 20  REG-LABOR2  PIC 9(05)V9(02).
022100                 20  FILLER      PIC X(01).
022200                 20  REG-NLABOR2 PIC 9(04)V9(02).
022300
022400 01  UPDT-ENTRIES               PIC 9(02) VALUE 6.
022500 01  UPDT-TABLE.
022600     02  UPDT-WORK.
022700*UPDT 831001 UPDATING FACTORS EFFECTIVE DATE
022800     05  FILLER PIC X(06) VALUE '831001'.
022900     05  FILLER PIC X(18) VALUE 'UP01 830131 112509'.
023000     05  FILLER PIC X(18) VALUE 'UP02 830228 112570'.
023100     05  FILLER PIC X(18) VALUE 'UP03 830331 112631'.
023200     05  FILLER PIC X(18) VALUE 'UP04 830430 112693'.
023300     05  FILLER PIC X(18) VALUE 'UP05 830531 112754'.
023400     05  FILLER PIC X(18) VALUE 'UP06 830630 112815'.
023500     05  FILLER PIC X(18) VALUE 'UP07 830731 112877'.
023600     05  FILLER PIC X(18) VALUE 'UP08 830831 112938'.
023700     05  FILLER PIC X(18) VALUE 'UP09 820930 113570'.
023800     05  FILLER PIC X(18) VALUE 'UP10 821031 113265'.
023900     05  FILLER PIC X(18) VALUE 'UP11 821130 112961'.
024000     05  FILLER PIC X(18) VALUE 'UP12 821231 112448'.
024100*UPDT 840203 UPDATING FACTORS EFFECTIVE DATE
024200     05  FILLER PIC X(06) VALUE '840203'.
024300     05  FILLER PIC X(18) VALUE 'UP01 830131 112395'.
024400     05  FILLER PIC X(18) VALUE 'UP02 830228 112456'.
024500     05  FILLER PIC X(18) VALUE 'UP03 830331 112517'.
024600     05  FILLER PIC X(18) VALUE 'UP04 830430 112578'.
024700     05  FILLER PIC X(18) VALUE 'UP05 830531 112639'.
024800     05  FILLER PIC X(18) VALUE 'UP06 830630 112701'.
024900     05  FILLER PIC X(18) VALUE 'UP07 830731 112762'.
025000     05  FILLER PIC X(18) VALUE 'UP08 830831 112823'.
025100     05  FILLER PIC X(18) VALUE 'UP09 820930 113242'.
025200     05  FILLER PIC X(18) VALUE 'UP10 821031 112938'.
025300     05  FILLER PIC X(18) VALUE 'UP11 821130 112635'.
025400     05  FILLER PIC X(18) VALUE 'UP12 821231 112333'.
025500*UPDT 841001 UPDATING FACTORS EFFECTIVE DATE
025600     05  FILLER PIC X(06) VALUE '841001'.
025700     05  FILLER PIC X(18) VALUE 'UP01 830131 119197'.
025800     05  FILLER PIC X(18) VALUE 'UP02 830228 119318'.
025900     05  FILLER PIC X(18) VALUE 'UP03 830331 119438'.
026000     05  FILLER PIC X(18) VALUE 'UP04 830430 119559'.
026100     05  FILLER PIC X(18) VALUE 'UP05 830531 119680'.
026200     05  FILLER PIC X(18) VALUE 'UP06 830630 119801'.
026300     05  FILLER PIC X(18) VALUE 'UP07 830731 119922'.
026400     05  FILLER PIC X(18) VALUE 'UP08 830831 120044'.
026500     05  FILLER PIC X(18) VALUE 'UP09 820930 119898'.
026600     05  FILLER PIC X(18) VALUE 'UP10 821031 119624'.
026700     05  FILLER PIC X(18) VALUE 'UP11 821130 119349'.
026800     05  FILLER PIC X(18) VALUE 'UP12 821231 119076'.
026900*UPDT 860501 UPDATING FACTORS EFFECTIVE DATE  ----1.0050
027000     05  FILLER PIC X(06) VALUE '860501'.
027100     05  FILLER PIC X(18) VALUE 'UP01 830131 119793'.
027200     05  FILLER PIC X(18) VALUE 'UP02 830228 119915'.
027300     05  FILLER PIC X(18) VALUE 'UP03 830331 120035'.
027400     05  FILLER PIC X(18) VALUE 'UP04 830430 120157'.
027500     05  FILLER PIC X(18) VALUE 'UP05 830531 120278'.
027600     05  FILLER PIC X(18) VALUE 'UP06 830630 120400'.
027700     05  FILLER PIC X(18) VALUE 'UP07 830731 120522'.
027800     05  FILLER PIC X(18) VALUE 'UP08 830831 120644'.
027900     05  FILLER PIC X(18) VALUE 'UP09 820930 120497'.
028000     05  FILLER PIC X(18) VALUE 'UP10 821031 120222'.
028100     05  FILLER PIC X(18) VALUE 'UP11 821130 119946'.
028200     05  FILLER PIC X(18) VALUE 'UP12 821231 119671'.
028300*UPDT 861001 UPDATING FACTORS EFFECTIVE DATE  ----1.0115
028400     05  FILLER PIC X(06) VALUE '861001'.
028500     05  FILLER PIC X(18) VALUE 'UP01 830131 121171'.
028600     05  FILLER PIC X(18) VALUE 'UP02 830228 121294'.
028700     05  FILLER PIC X(18) VALUE 'UP03 830331 121415'.
028800     05  FILLER PIC X(18) VALUE 'UP04 830430 121539'.
028900     05  FILLER PIC X(18) VALUE 'UP05 830531 121661'.
029000     05  FILLER PIC X(18) VALUE 'UP06 830630 121785'.
029100     05  FILLER PIC X(18) VALUE 'UP07 830731 121908'.
029200     05  FILLER PIC X(18) VALUE 'UP08 830831 122031'.
029300     05  FILLER PIC X(18) VALUE 'UP09 820930 121883'.
029400     05  FILLER PIC X(18) VALUE 'UP10 821031 121605'.
029500     05  FILLER PIC X(18) VALUE 'UP11 821130 121325'.
029600     05  FILLER PIC X(18) VALUE 'UP12 821231 121047'.
029700*UPDT 871121 UPDATING FACTORS EFFECTIVE DATE  ----1.0270
029800     05  FILLER PIC X(06) VALUE '871121'.
029900     05  FILLER PIC X(18) VALUE 'UP01 830131 124443'.
030000     05  FILLER PIC X(18) VALUE 'UP02 830228 124569'.
030100     05  FILLER PIC X(18) VALUE 'UP03 830331 124693'.
030200     05  FILLER PIC X(18) VALUE 'UP04 830430 124821'.
030300     05  FILLER PIC X(18) VALUE 'UP05 830531 124946'.
030400     05  FILLER PIC X(18) VALUE 'UP06 830630 125073'.
030500     05  FILLER PIC X(18) VALUE 'UP07 830731 125200'.
030600     05  FILLER PIC X(18) VALUE 'UP08 830831 125326'.
030700     05  FILLER PIC X(18) VALUE 'UP09 820930 125174'.
030800     05  FILLER PIC X(18) VALUE 'UP10 821031 124888'.
030900     05  FILLER PIC X(18) VALUE 'UP11 821130 124601'.
031000     05  FILLER PIC X(18) VALUE 'UP12 821231 124315'.
031100     02  UPDATE-TABLE REDEFINES UPDT-WORK.
031200     05  UPDT-PERIOD             OCCURS 6.
031300         10  UPDT-EFF-DATE       PIC X(06).
031400         10  UPDT-MONTH          OCCURS 12.
031500             15  FILLER          PIC X(05).
031600             15  UP-BASE-DATE    PIC X(06).
031700             15  FILLER          PIC X(01).
031800             15  UPDATE-FACTOR   PIC 9(01)V9(05).
031900
032000 01  UPDT-ENTRIES2              PIC 9(02) VALUE 4.
032100 01  UPDT-TABLE2.
032200     02  UPDT-WORK2.
032300*UPDT 880401 UPDATING FACTORS EFFECTIVE DATE
032400*     LURBAN=1.0150 OURBAN=1.0100 RURAL=1.0300
032500     05  FILLER PIC X(06) VALUE '880401'.
032600     05  FILLER PIC X(27) VALUE '830131 122989 122383 124806'.
032700     05  FILLER PIC X(27) VALUE '830228 123113 122507 124933'.
032800     05  FILLER PIC X(27) VALUE '830331 123236 122629 125057'.
032900     05  FILLER PIC X(27) VALUE '830430 123362 122754 125185'.
033000     05  FILLER PIC X(27) VALUE '830531 123486 122878 125311'.
033100     05  FILLER PIC X(27) VALUE '830630 123612 123003 125439'.
033200     05  FILLER PIC X(27) VALUE '830731 123737 123127 125565'.
033300     05  FILLER PIC X(27) VALUE '830831 123861 123251 125692'.
033400     05  FILLER PIC X(27) VALUE '820930 123711 123102 125539'.
033500     05  FILLER PIC X(27) VALUE '821031 123429 122821 125253'.
033600     05  FILLER PIC X(27) VALUE '821130 123145 122538 124965'.
033700     05  FILLER PIC X(27) VALUE '821231 122863 122257 124678'.
033800*UPDT 881001 UPDATING FACTORS EFFECTIVE DATE
033900*     LURBAN=1.0340 OURBAN=1.0290 RURAL=1.0390
034000     05  FILLER PIC X(06) VALUE '881001'.
034100     05  FILLER PIC X(27) VALUE '830131 127171 125932 129673'.
034200     05  FILLER PIC X(27) VALUE '830228 127299 126060 129805'.
034300     05  FILLER PIC X(27) VALUE '830331 127426 126185 129934'.
034400     05  FILLER PIC X(27) VALUE '830430 127556 126314 130067'.
034500     05  FILLER PIC X(27) VALUE '830531 127685 126441 130198'.
034600     05  FILLER PIC X(27) VALUE '830630 127815 126570 130331'.
034700     05  FILLER PIC X(27) VALUE '830731 127944 126698 130462'.
034800     05  FILLER PIC X(27) VALUE '830831 128072 126825 130594'.
034900     05  FILLER PIC X(27) VALUE '820930 127917 126672 130435'.
035000     05  FILLER PIC X(27) VALUE '821031 127626 126383 130138'.
035100     05  FILLER PIC X(27) VALUE '821130 127332 126092 129839'.
035200     05  FILLER PIC X(27) VALUE '821231 127040 125802 129540'.
035300*UPDT 891001 UPDATING FACTORS EFFECTIVE DATE
035400*     LURBAN=1.0550 OURBAN=1.0550 RURAL=1.0550 (OCT - DEC)
035500     05  FILLER PIC X(06) VALUE '891001'.
035600     05  FILLER PIC X(27) VALUE '830131 134165 132858 136805'.
035700     05  FILLER PIC X(27) VALUE '830228 134300 132993 136944'.
035800     05  FILLER PIC X(27) VALUE '830331 134434 133125 137080'.
035900     05  FILLER PIC X(27) VALUE '830430 134572 133261 137221'.
036000     05  FILLER PIC X(27) VALUE '830531 134708 133395 137359'.
036100     05  FILLER PIC X(27) VALUE '830630 134845 133531 137499'.
036200     05  FILLER PIC X(27) VALUE '830731 134981 133666 137637'.
036300     05  FILLER PIC X(27) VALUE '830831 135116 133800 137777'.
036400     05  FILLER PIC X(27) VALUE '820930 134952 133639 137609'.
036500     05  FILLER PIC X(27) VALUE '821031 134645 133334 137296'.
036600     05  FILLER PIC X(27) VALUE '821130 134335 133027 136980'.
036700     05  FILLER PIC X(27) VALUE '821231 134027 132721 136665'.
036800*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE
036900*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)
037000     05  FILLER PIC X(06) VALUE '900101'.
037100     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.
037200     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.
037300     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.
037400     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.
037500     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.
037600     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.
037700     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.
037800     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.
037900     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.
038000     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.
038100     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.
038200     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.
038300     02  UPDATE-TABLE2 REDEFINES UPDT-WORK2.
038400     05  UPDT-PERIOD2             OCCURS 4.
038500         10  UPDT-EFF-DATE2       PIC X(06).
038600         10  UPDT-MONTH2          OCCURS 12.
038700             15  UP-BASE-DATE2    PIC X(06).
038800             15  UP-L-O-R2        OCCURS 3.
038900                 20  FILLER           PIC X(01).
039000                 20  UPDATE-FACTOR2   PIC 9(01)V9(05).
039100
039200 01  DRG-TABLE3.
039300     05  D-TAB3.
039400         10  FILLER                  PIC X(06) VALUE
039500        '891001'.
039600         10  FILLER                  PIC X(44) VALUE
039700        '03567013842041379128410288301274102648311840'.
039800         10  FILLER                  PIC X(44) VALUE
039900        '01521406134004709020170311101324100735503231'.
040000         10  FILLER                  PIC X(44) VALUE
040100        '01405807035012449078360074510473300939106935'.
040200         10  FILLER                  PIC X(44) VALUE
040300        '00869907035012260074350063500423201094906835'.
040400         10  FILLER                  PIC X(44) VALUE
040500        '00645204633009640063340058690413201781708136'.
040600         10  FILLER                  PIC X(44) VALUE
040700        '01419007636006981044320086980443200966905433'.
040800         10  FILLER                  PIC X(44) VALUE
040900        '00527003629007313035310161240463301275006134'.
041000         10  FILLER                  PIC X(44) VALUE
041100        '00573003431003496020170070070433200403802725'.
041200         10  FILLER                  PIC X(44) VALUE
041300        '00242701609012069060340055970373200644302614'.
041400         10  FILLER                  PIC X(44) VALUE
041500        '00741503131003550021160044940170700476202020'.
041600         10  FILLER                  PIC X(44) VALUE
041700        '00361301607006305023160033500372400603505533'.
041800         10  FILLER                  PIC X(44) VALUE
041900        '00545403330006495040320035390262800396902930'.
042000         10  FILLER                  PIC X(44) VALUE
042100        '02863311039006298023150056470211800812902726'.
042200         10  FILLER                  PIC X(44) VALUE
042300        '00616102020006806032220048790171400488101814'.
042400         10  FILLER                  PIC X(44) VALUE
042500        '00931303532003060015040038780161100258401504'.
042600         10  FILLER                  PIC X(44) VALUE
042700        '00694502330003052013050118820433201176205133'.
042800         10  FILLER                  PIC X(44) VALUE
042900        '00456403423004496033240085890443200723205033'.
043000         10  FILLER                  PIC X(44) VALUE
043100        '00528103925004589033220073070453200552803331'.
043200         10  FILLER                  PIC X(44) VALUE
043300        '00752504032003386021200296031194002303810538'.
043400         10  FILLER                  PIC X(44) VALUE
043500        '01089504933014320088370185300943701138207135'.
043600         10  FILLER                  PIC X(44) VALUE
043700        '01089906134012016066350100640653500500903932'.
043800         10  FILLER                  PIC X(44) VALUE
043900        '01143706835007223046330145970613401015306134'.
044000         10  FILLER                  PIC X(44) VALUE
044100        '01205907235007790057320074650463001218206935'.
044200         10  FILLER                  PIC X(44) VALUE
044300        '00793605233013378074350066650483300973406034'.
044400         10  FILLER                  PIC X(44) VALUE
044500        '00681004727008942062340084930443200512502820'.
044600         10  FILLER                  PIC X(44) VALUE
044700        '00996605333005593034311323522645407843218446'.
044800         10  FILLER                  PIC X(44) VALUE
044900        '05996513241056558142420422601083905733211539'.
045000         10  FILLER                  PIC X(44) VALUE
045100        '03774607536035967123400203510833601910605333'.
045200         10  FILLER                  PIC X(44) VALUE
045300        '02461614342016119098380385411264102579306134'.
045400         10  FILLER                  PIC X(44) VALUE
045500        '01886704833020267039320082690373202705910839'.
045600         10  FILLER                  PIC X(44) VALUE
045700        '01622808637011233062340139340303101187604532'.
045800         10  FILLER                  PIC X(44) VALUE
045900        '00687402320029894168450101690623400812907835'.
046000         10  FILLER                  PIC X(44) VALUE
046100        '01398602731008921059340058140423200756504332'.
046200         10  FILLER                  PIC X(44) VALUE
046300        '00542003227005964043320090180513300548803429'.
046400         10  FILLER                  PIC X(44) VALUE
046500        '00623903331008707048330057150342600638703925'.
046600         10  FILLER                  PIC X(44) VALUE
046700        '00692004532005149033230052260291901103505634'.
046800         10  FILLER                  PIC X(44) VALUE
046900        '00623603531027386138420173490993703270514342'.
047000         10  FILLER                  PIC X(44) VALUE
047100        '01663609932026617124400134780803601467807736'.
047200         10  FILLER                  PIC X(44) VALUE
047300        '01014906534038172130410160500803600828106034'.
047400         10  FILLER                  PIC X(44) VALUE
047500        '00957105433005136029230110570553300631403323'.
047600         10  FILLER                  PIC X(44) VALUE
047700        '00733703532004485021140077290352602373710839'.
047800         10  FILLER                  PIC X(44) VALUE
047900        '01337707626013991068350079220441701005003732'.
048000         10  FILLER                  PIC X(44) VALUE
048100        '00546302219028091114390125630613401221607135'.
048200         10  FILLER                  PIC X(44) VALUE
048300        '00665704032009620055340059830412500983106034'.
048400         10  FILLER                  PIC X(44) VALUE
048500        '00763705332005650041230106480723500913405834'.
048600         10  FILLER                  PIC X(44) VALUE
048700        '00522904128007414049330052150362600540803131'.
048800         10  FILLER                  PIC X(44) VALUE
048900        '00762704232004062029230048560222000973005233'.
049000         10  FILLER                  PIC X(44) VALUE
049100        '00476702931007671043320506741694502181609938'.
049200         10  FILLER                  PIC X(44) VALUE
049300        '03002614643017802104380228101154001510608930'.
049400         10  FILLER                  PIC X(44) VALUE
049500        '01737808837009865060210225851204002716009738'.
049600         10  FILLER                  PIC X(44) VALUE
049700        '02409308937011953072350111740673501038706134'.
049800         10  FILLER                  PIC X(44) VALUE
049900        '01206806835006124037320095660563400565803529'.
050000         10  FILLER                  PIC X(44) VALUE
050100        '02343711239020536127410147161013801402307331'.
050200         10  FILLER                  PIC X(44) VALUE
050300        '01770109938019997111390121550753501785209237'.
050400         10  FILLER                  PIC X(44) VALUE
050500        '03064014042015359082360093630523300913005333'.
050600         10  FILLER                  PIC X(44) VALUE
050700        '01540806935008855037320084050383200624802819'.
050800         10  FILLER                  PIC X(44) VALUE
050900        '00706303231014308069350066130313000791102828'.
051000         10  FILLER                  PIC X(44) VALUE
051100        '00511701915008763043320091070363201122903732'.
051200         10  FILLER                  PIC X(44) VALUE
051300        '01728008637008477046330115750813600856506935'.
051400         10  FILLER                  PIC X(44) VALUE
051500        '00566204533015778104380098430763601076907135'.
051600         10  FILLER                  PIC X(44) VALUE
051700        '00621805033013229086370065010503300713405433'.
051800         10  FILLER                  PIC X(44) VALUE
051900        '00510804132005910046330052850373200612004432'.
052000         10  FILLER                  PIC X(44) VALUE
052100        '00628704132006806046330042300252400345401815'.
052200         10  FILLER                  PIC X(44) VALUE
052300        '00798305934004346037320045820293100625103932'.
052400         10  FILLER                  PIC X(44) VALUE
052500        '00940205527007467044180099870483300565402718'.
052600         10  FILLER                  PIC X(44) VALUE
052700        '00628502416004464020130266911564401419709738'.
052800         10  FILLER                  PIC X(44) VALUE
052900        '01390306635006867032310057380273100643102530'.
053000         10  FILLER                  PIC X(44) VALUE
053100        '01728708336006744032310118080853701018307335'.
053200         10  FILLER                  PIC X(44) VALUE
053300        '00681105734010610064340057930343100560203331'.
053400         10  FILLER                  PIC X(44) VALUE
053500        '00939207135006492056320072780422400659704733'.
053600         10  FILLER                  PIC X(44) VALUE
053700        '00423303331003383022190076240553400465903732'.
053800         10  FILLER                  PIC X(44) VALUE
053900        '02819116244025261109390223721374201865607435'.
054000         10  FILLER                  PIC X(44) VALUE
054100        '01058704733007805034210045890191002777912440'.
054200         10  FILLER                  PIC X(44) VALUE
054300        '01128906234007509059340072520443200940406134'.
054400         10  FILLER                  PIC X(44) VALUE
054500        '00548004232006768036320086230483301108607135'.
054600         10  FILLER                  PIC X(44) VALUE
054700        '00625004432037905154430267731234002494411039'.
054800         10  FILLER                  PIC X(44) VALUE
054900        '01280706034014060078360079310462801506706935'.
055000         10  FILLER                  PIC X(44) VALUE
055100        '00788203632009014044320052110251800807104132'.
055200         10  FILLER                  PIC X(44) VALUE
055300        '00475702421004271023260233660823601268806434'.
055400         10  FILLER                  PIC X(44) VALUE
055500        '00381402322010637061340054530283101026106935'.
055600         10  FILLER                  PIC X(44) VALUE
055700        '00683005231007006046330077260303100396402216'.
055800         10  FILLER                  PIC X(44) VALUE
055900        '00667304532004276030250054440313100644503932'.
056000         10  FILLER                  PIC X(44) VALUE
056100        '00402002319002754016090095010533300555703331'.
056200         10  FILLER                  PIC X(44) VALUE
056300        '00888404933018224103380134620842400982705830'.
056400         10  FILLER                  PIC X(44) VALUE
056500        '00660304215007604031310058470253000428302413'.
056600         10  FILLER                  PIC X(44) VALUE
056700        '00985103829004806021230037420170601056905333'.
056800         10  FILLER                  PIC X(44) VALUE
056900        '00787704132009214055340046640252900663503832'.
057000         10  FILLER                  PIC X(44) VALUE
057100        '00382802119006716049290032930130500550003131'.
057200         10  FILLER                  PIC X(44) VALUE
057300        '02064511439014248082360089430571500729104819'.
057400         10  FILLER                  PIC X(44) VALUE
057500        '02170510839012032071290081320541400776003832'.
057600         10  FILLER                  PIC X(44) VALUE
057700        '00685902731003490015060069870363200466902321'.
057800         10  FILLER                  PIC X(44) VALUE
057900        '01892808837011726066350048960293100892705934'.
058000         10  FILLER                  PIC X(44) VALUE
058100        '00510903131009848062340065440451300454003120'.
058200         10  FILLER                  PIC X(44) VALUE
058300        '00298702208004981027080067350442900350202825'.
058400         10  FILLER                  PIC X(44) VALUE
058500        '01511903632007232042150024930201400264401814'.
058600         10  FILLER                  PIC X(44) VALUE
058700        '00376901713001186012040037590343100327902229'.
058800         10  FILLER                  PIC X(44) VALUE
058900        '01208401830036039179460180461334101143108637'.
059000         10  FILLER                  PIC X(44) VALUE
059100        '02409807335008111038320021910311103589112440'.
059200         10  FILLER                  PIC X(44) VALUE
059300        '01502209137015355057340074660463300357501815'.
059400         10  FILLER                  PIC X(44) VALUE
059500        '01095505534012279067350069060413202698110538'.
059600         10  FILLER                  PIC X(44) VALUE
059700        '02257210438008945041320160440833600775304633'.
059800         10  FILLER                  PIC X(44) VALUE
059900        '01028104933027445119400130420643400959204132'.
060000         10  FILLER                  PIC X(44) VALUE
060100        '01035706935004890026200045430272700404602120'.
060200         10  FILLER                  PIC X(44) VALUE
060300        '01285307335007557047330364241514301534607435'.
060400         10  FILLER                  PIC X(44) VALUE
060500        '00892905333009641066350095520593400680504733'.
060600         10  FILLER                  PIC X(44) VALUE
060700        '00633704331005874040270158450803602341813742'.
060800         10  FILLER                  PIC X(44) VALUE
060900        '00647004532006255056340061330543300732506334'.
061000         10  FILLER                  PIC X(44) VALUE
061100        '00901607535008957088370063470593400732904532'.
061200         10  FILLER                  PIC X(44) VALUE
061300        '00397403231007886057340055100493300987312040'.
061400         10  FILLER                  PIC X(44) VALUE
061500        '01200513842000000000000167310673502499210739'.
061600         10  FILLER                  PIC X(44) VALUE
061700        '00738102531018642056340119060423200769405333'.
061800         10  FILLER                  PIC X(44) VALUE
061900        '00495003732004738024220047020262400342802917'.
062000         10  FILLER                  PIC X(44) VALUE
062100        '00798304432004648027280039470261600893204633'.
062200         10  FILLER                  PIC X(44) VALUE
062300        '00472503131009104046330042260272703111405634'.
062400         10  FILLER                  PIC X(44) VALUE
062500        '01872502731038130164440191641003801016506334'.
062600         10  FILLER                  PIC X(44) VALUE
062700        '00776202531019047144420075400513300471903331'.
062800         10  FILLER                  PIC X(44) VALUE
062900        '00328201812005463026310043390243003315012741'.
063000         10  FILLER                  PIC X(44) VALUE
063100        '00000000000000000000000396721544312712919147'.
063200         10  FILLER                  PIC X(44) VALUE
063300        '03096309437134688376660362900993802242515043'.
063400         10  FILLER                  PIC X(44) VALUE
063500        '01431806635000000000000000000000015264522852'.
063600         10  FILLER                  PIC X(44) VALUE
063700        '00000000000000000000000000000000000000000000'.
063800         10  FILLER                  PIC X(44) VALUE
063900        '00000000000000000000000000000000000000000000'.
064000         10  FILLER                  PIC X(44) VALUE
064100        '00000000000000000000000000000000000000000000'.
064200     05  DRGX-TAB3 REDEFINES D-TAB3.
064300     10  DRGX-PERIOD3               OCCURS 1
064400                                    INDEXED BY DX5.
064500         15  DRGX-EFF-DATE3         PIC X(06).
064600         15  DRG-DATA3              OCCURS 492
064700                                    INDEXED BY DX6.
064800             20  DRG-WT3            PIC 9(02)V9(04).
064900             20  DRG-ALOS3          PIC 9(02)V9(01).
065000             20  DRG-DAYS-TRIM3     PIC 9(02).
065100
065200 LINKAGE SECTION.
065300***************************************************************
065400*                 * * * * * * * * *                           *
065500*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
065600*    IN HOW TO PAY THE BILL.                                  *
065700*         REVIEW-CODE:                                        *
065800*            00 = PAY-WITH-OUTLIER.                           *
065900*                 WILL CALCULATE THE STANDARD PAYMENT.        *
066000*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
066100*                 OUTLIERS. PPS-RTC CODES 01 AND 02 NOW SENT  *
066200*                 TO THE PRO FOR POST PAYMENT REVIEW.       . *
066300*            01 = PAY-DAYS-OUTLIER.                           *
066400*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
066500*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
066600*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
066700*                 OUTLIER CUTOFF FOR THE DRG.                 *
066800*            02 = PAY-COST-OUTLIER.                           *
066900*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
067000*                 ALSO CALCULATE THE COST OUTLIER PORTION OF  *
067100*                 THE PAYMENT IF THE ADJUSTED CHARGES ON THE  *
067200*                 BILL EXCEED THE COST THRESHOLD.             *
067300*                 IF  LENGTH OF STAY EXCEED OUTLIER CUTOFF, NO*
067400*                 PAYMENT WILL BE MADE AND A RETURN-CODE OF   *
067500*                 60 WILL BE RETURNED.                        *
067600*            03 = PAY-PERDIEM-DAYS.                           *
067700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
067800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
067900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
068000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
068100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
068200*                 STANDARD PAYMENT IS CALCULATED.             *
068300*                 TRANSFERS AFTER 093084 POTENTIALLY          *
068400*                 ELIGABLE FOR COST OUTLIER PAYMENT.          *
068500*            04 = PAY-AVG-STAY-ONLY.                          *
068600*                 WILL CALCULATE THE STANDARD PAYMENT.        *
068700*                 WILL NOT TEST FOR DAYS OR COST OUTLIERS.    *
068800*            05 = PAY-XFER-WITH-COST                          *
068900*                 PAY TRANSFER WITH COST OUTLIER APPROVED.    *
069000*            06 = PAY-XFER-NO-COST                            *
069100*                 PAY TRANSFER WITH COST OUTLIER DENIED.      *
069200*            07 = PAY-WITHOUT-COST                            *
069300*                 PAY WITHOUT COST OUTLIER.                   *
069400*            08 = PAY BY DRG 480 -- IF DISCHARGE-DATE         *
069500*                     GREATER THAN '900307' AND GROUPER DRG   *
069600*                     EQUALS 191 OR 192.                      *
069700*                                                             *
069800***************************************************************
069900 01  BILL-DATA.
070000         10  B-PROVIDER-NO          PIC X(06).
070100         10  B-REVIEW-CODE          PIC 9(02).
070200             88  VALID-REVIEW-CODE  VALUE 00 THRU 08.
070300             88  PAY-WITH-OUTLIER   VALUE 00 07.
070400             88  PAY-DAYS-OUTLIER   VALUE 01.
070500             88  PAY-COST-OUTLIER   VALUE 02.
070600             88  PAY-PERDIEM-DAYS   VALUE 03.
070700             88  PAY-AVG-STAY-ONLY  VALUE 04.
070800             88  PAY-XFER-WITH-COST VALUE 05.
070900             88  PAY-XFER-NO-COST   VALUE 06.
071000             88  PAY-WITHOUT-COST   VALUE 07.
071100             88  PAY-BY-DRG480      VALUE 08.
071200         10  B-DRG                  PIC 9(03).
071300         10  B-LOS                  PIC 9(03).
071400         10  B-COVERED-DAYS         PIC 9(03).
071500         10  B-LTR-DAYS             PIC 9(02).
071600         10  B-DISCHARGE-DATE.
071700             15  B-DISCHG-MM        PIC 9(02).
071800             15  B-DISCHG-DD        PIC 9(02).
071900             15  B-DISCHG-YY        PIC 9(02).
072000         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
072100***************************************************************
072200*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
072300*    AND PASSED BACK TO THE CALLING PROGRAM                   *
072400*            RETURN CODE VALUES (PPS-RTC)                     *
072500*                                                             *
072600*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
072700*              00 = PAID NORMAL DRG PAYMENT                   *
072800*                                                             *
072900*              01 = PAID AS A DAY-OUTLIER. SEND TO PRO FOR    *
073000*                   POST PAYMENT REVIEW.                      *
073100*              02 = PAID AS A COST-OUTLIER. SEND TO PRO FOR   *
073200*                   POST PAYMENT REVIEW.                      *
073300*              03 = PAID ON PERDIEM BASIS (XFER OR REVIEW 03) *
073400*                   NOT POTENTIALLY ELIGEABLE FOR COST OUTLIER*
073500*              04 = PAID NORMAL DRG PAYMENT ONLY. DAY AND     *
073600*                   COST OUTLIER CRITERIA IGNORED.            *
073700*              05 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
073800*                   OUTLIER APPROVED.                         *
073900*              06 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
074000*                   OUTLIER DENIED.                           *
074100*                                                             *
074200*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
074300*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
074400*              52 = INVALID MSA # IN PROVIDER FILE            *
074500*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
074600*              54 = DRG NOT 001-468,471-480 OR = 478 OR = 479 *
074700*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
074800*              56 = INVALID LENGTH OF STAY                    *
074900*              57 = REVIEW CODE INVALID (NOT 00 - 07)         *
075000*              58 = TOTAL CHARGES NOT NUMERIC                 *
075100*              59 = POSSIBLE DAY OUTLIER CANDIDATE            *
075200*              60 = REVIEW CODE 02 (POSSIBLE COST OUTLIER)    *
075300*                   AND POSSIBLE DAY OUTLIER CANDIDATE. NOT   *
075400*                   ELIGABLE FOR COST OUTLIER.                *
075500*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
075600*              62 = INVALID NUMBER OF COVERED DAYS            *
075700*              63 = POSSIBLE COST OUTLIER CANDIDATE.          *
075800*              64 = DISPROPORTIONATE SHARE PERCENTAGE AND     *
075900*                   BED-SIZE CONFLICT ON PROVIDER SPECIFIC FILE
076000*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
076100***************************************************************
076200 01  PPS-DATA.
076300         10  PPS-RTC                PIC 9(02).
076400         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
076500         10  PPS-OUTLIER-DAYS       PIC 9(03).
076600         10  PPS-AVG-LOS            PIC 9(02)V9(01).
076700         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
076800         10  PPS-INDTEACH-ADJ       PIC 9(06)V9(02).
076900         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
077000         10  PPS-HSP-PART           PIC 9(06)V9(02).
077100         10  PPS-FSP-PART           PIC 9(06)V9(02).
077200         10  PPS-OUTLIER-PART       PIC 9(07)V9(02).
077300         10  PPS-REG-DAYS-USED      PIC 9(03).
077400         10  PPS-LTR-DAYS-USED      PIC 9(02).
077500         10  PPS-DSH-ADJ            PIC 9(06)V9(02).
077600         10  PPS-CALC-VERS          PIC X(05).
077700
077800******************************************************************
077900*            THESE ARE THE VERSIONS OF THE PPCAL
078000*           PROGRAMS THAT WILL BE PASSED BACK----
078100*          ASSOCIATED WITH THE BILL BEING PROCESSED
078200******************************************************************
078300 01  PRICER-OPT-VERS-SW.
078400     02  PRICER-OPTION-SW          PIC X(01).
078500         88  ALL-TABLES-PASSED          VALUE 'A'.
078600         88  PROV-RECORD-PASSED         VALUE 'P'.
078700         88  ADDITIONAL-VARIABLES       VALUE 'M'.
078800     02  PPS-VERSIONS.
078900         10  PPDRV-VERSION        PIC X(05).
079000
079100******************************************************************
079200*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
079300*          ASSOCIATED WITH THE BILL BEING PROCESSED
079400******************************************************************
079500 01  PPS-ADDITIONAL-VARIABLES.
079600     05  PPS-HSP-PCT                PIC 9(01)V9(02).
079700     05  PPS-FSP-PCT                PIC 9(01)V9(02).
079800     05  PPS-NAT-PCT                PIC 9(01)V9(02).
079900     05  PPS-REG-PCT                PIC 9(01)V9(02).
080000     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
080100     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
080200     05  PPS-DRG-WT                 PIC 9(02)V9(04).
080300     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
080400     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
080500     05  PPS-REG-LABOR              PIC 9(05)V9(02).
080600     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
080700     05  PPS-COLA                   PIC 9(01)V9(03).
080800     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
080900     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
081000     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
081100     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
081200
081300******************************************************************
081400*               THIS IS THE PROVIDER RECORD
081500*          ASSOCIATED WITH THE BILL BEING PROCESSED
081600******************************************************************
081700 01  PROV-HOLD.
081800     02  PROV-REC-HOLD.
081900         05  P-PROVIDER-NO.
082000             10  P-STATE                PIC 9(02).
082100             10  FILLER                 PIC X(04).
082200         05  P-EFF-DATE.
082300             10  P-EFF-YY               PIC 9(02).
082400             10  P-EFF-MM               PIC 9(02).
082500             10  P-EFF-DD               PIC 9(02).
082600         05  P-WAIVER-CODE              PIC X(01).
082700             88  WAIVER-STATE           VALUE 'Y'.
082800         05  P-PROVIDER-TYPE            PIC X(02).
082900             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.
083000             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.
083100             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
083200             88  REDESIGNATED-RURAL-YR1 VALUE '09'.
083300             88  REDESIGNATED-RURAL-YR2 VALUE '10'.
083400             88  SOLE-COM-REF-CENT      VALUE '11'.
083500             88  MDH-REBASED-FY90       VALUE '14' '15'.
083600             88  MDH-RRC-REBASED-FY90   VALUE '15'.
083700             88  SCH-REBASED-FY90       VALUE '16' '17'.
083800             88  SCH-RRC-REBASED-FY90   VALUE '17'.
083900         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
084000             88  NEW-ENGLAND            VALUE  1.
084100             88  MIDDLE-ATLANTIC        VALUE  2.
084200             88  SOUTH-ATLANTIC         VALUE  3.
084300             88  EAST-NORTH-CENTRAL     VALUE  4.
084400             88  EAST-SOUTH-CENTRAL     VALUE  5.
084500             88  WEST-NORTH-CENTRAL     VALUE  6.
084600             88  WEST-SOUTH-CENTRAL     VALUE  7.
084700             88  MOUNTAIN               VALUE  8.
084800             88  PACIFIC                VALUE  9.
084900         05  P-PPS-BLEND-YEAR           PIC 9(01).
085000             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
085100         05  P-MSA-X.
085200             10  P-RURAL                PIC X(04).
085300                 88  RURAL              VALUE  '9999'.
085400         05  P-MSA-9 REDEFINES P-MSA-X  PIC 9(04).
085500         05  P-FISCAL-YEAR-END.
085600             10  P-MM                   PIC 9(02).
085700             10  P-DD                   PIC 9(02).
085800             10  P-YY                   PIC 9(02).
085900         05  P-VARIABLES.
086000             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
086100             10  P-COLA                 PIC S9(01)V9(03).
086200             10  P-INTERN-RATIO         PIC S9(01)V9(04).
086300             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
086400             10  P-BED-SIZE             PIC  9(05).
086500             10  P-DSH-PERCENT          PIC V9(04).
086600             10  P-CCR                  PIC  9(01)V9(03).
086700             10  P-CMI                  PIC  9(01)V9(04).
086800             10  FILLER                 PIC  9(01).
086900             10  P-REPORT-DATE          PIC  9(06).
087000             10  FILLER                 PIC  9(01).
087100             10  P-INTER-NO             PIC  9(05).
087200     02  FILLER                         PIC X(80).
087300
087400******************************************************************
087500*                   THIS IS THE WAGE-INDEX
087600*          ASSOCIATED WITH THE BILL BEING PROCESSED
087700******************************************************************
087800 01  WAGE-INDEX-RECORD.
087900     05  W-MSA               PIC X(4).
088000     05  W-SIZE              PIC X(01).
088100         88  LARGE-URBAN       VALUE 'L'.
088200         88  OTHER-URBAN       VALUE 'O'.
088300         88  ALL-RURAL         VALUE 'R'.
088400     05  W-EFF-DATE          PIC X(6).
088500     05  FILLER              PIC X.
088600     05  W-INDEX-RECORD      PIC S9(02)V9(04).
088700
088800 PROCEDURE DIVISION  USING BILL-DATA
088900                           PPS-DATA
089000                           PRICER-OPT-VERS-SW
089100                           PPS-ADDITIONAL-VARIABLES
089200                           PROV-HOLD
089300                           WAGE-INDEX-RECORD.
089400
089500***************************************************************
089600*    PROCESSING:                                              *
089700*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
089800*        B. INITIALIZE PPCAL  WORK VARIABLES.                 *
089900*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
090000*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
090100*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
090200*           GOBACK.                                           *
090300*        D. ASSEMBLE PRICING COMPONENTS.                      *
090400*        E. CALCULATE THE BLENDED PRICE.                      *
090500***************************************************************
090600
090700     PERFORM 0200-MAINLINE-CONTROL.
090800
090900     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
091000     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
091100
091200     GOBACK.
091300
091400 0200-MAINLINE-CONTROL.
091500     MOVE ALL '0' TO PPS-DATA.
091600     MOVE ALL '0' TO HOLD-PPS-COMPONENTS.
091700     MOVE ALL '0' TO HOLD-ADDITIONAL-VARIABLES.
091800     PERFORM 1000-EDIT-THE-BILL-INFO.
091900     IF  PPS-RTC = 00
092000         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
092100         PERFORM 3000-CALC-BLENDED-PAYMENT.
092200
092300 1000-EDIT-THE-BILL-INFO.
092400***************************************************************
092500*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
092600*    AND DO NOT ATTEMPT TO PRICE.                             *
092700***************************************************************
092800     MOVE B-DISCHG-YY TO H-BILL-YY.
092900     MOVE B-DISCHG-MM TO H-BILL-MM.
093000     MOVE B-DISCHG-DD TO H-BILL-DD.
093100     IF HOLD-BILL-DATE > '900307'
093200         IF PAY-BY-DRG480
093300            IF B-DRG = 191 OR = 192
093400               MOVE 480 TO B-DRG.
093500     IF  PPS-RTC = 00
093600         IF  WAIVER-STATE
093700             MOVE 53 TO PPS-RTC.
093800     IF  PPS-RTC = 00
093900         IF  B-DRG < 001 OR > 480 OR = 469 OR = 470
094000                                  OR = 478 OR = 479
094100             MOVE 54 TO PPS-RTC.
094200
094300     IF  PPS-RTC = 00
094400         MOVE P-EFF-DATE  TO HOLD-PROV-DATE
094500         MOVE P-YY        TO H-FYE-YY
094600         MOVE P-MM        TO H-FYE-MM
094700         MOVE P-DD        TO H-FYE-DD
094800         IF  HOLD-BILL-DATE < HOLD-PROV-DATE
094900             MOVE 55 TO PPS-RTC.
095000     IF  PPS-RTC = 00
095100         IF  B-REVIEW-CODE NOT NUMERIC
095200             MOVE 57 TO PPS-RTC.
095300     IF  PPS-RTC = 00
095400         IF  B-LOS NOT NUMERIC
095500             MOVE 56 TO PPS-RTC
095600         ELSE
095700         IF  B-LOS = 0 AND B-REVIEW-CODE NOT = 03
095800             MOVE 56 TO PPS-RTC.
095900     IF  PPS-RTC = 00
096000         IF  B-LTR-DAYS NOT NUMERIC
096100             MOVE 61 TO PPS-RTC
096200         ELSE
096300             MOVE B-LTR-DAYS TO H-LTR-DAYS.
096400     IF  PPS-RTC = 00
096500         IF  B-COVERED-DAYS NOT NUMERIC
096600             MOVE 62 TO PPS-RTC
096700         ELSE
096800         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
096900             MOVE 62 TO PPS-RTC
097000         ELSE
097100             MOVE B-COVERED-DAYS TO H-COV-DAYS.
097200     IF  PPS-RTC = 00
097300         IF  H-LTR-DAYS  > H-COV-DAYS
097400             MOVE 62 TO PPS-RTC
097500         ELSE
097600             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
097700     IF  PPS-RTC = 00
097800         IF  NOT VALID-REVIEW-CODE
097900             MOVE 57 TO PPS-RTC.
098000     IF  PPS-RTC = 00
098100         IF  B-CHARGES-CLAIMED NOT NUMERIC
098200             MOVE 58 TO PPS-RTC.
098300
098400
098500 2000-ASSEMBLE-PPS-VARIABLES.
098600***************************************************************
098700*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
098800*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
098900*    OF THAT VARIABLE.                                        *
099000***************************************************************
099100***  GET THE PROVIDER SPECIFIC VARIABLES.
099200
099300     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
099400     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
099500     IF  NOT (P-STATE = 02 OR 12)
099600         MOVE 1 TO H-COLA
099700     ELSE
099800         MOVE P-COLA TO H-COLA.
099900***************************************************************
100000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
100100
100200     PERFORM 2600-GET-DRG-WEIGHT3 VARYING DX5
100300             FROM 1 BY 1 UNTIL DX5 > 1.
100400
100500***************************************************************
100600***  GET THE WAGE-INDEX
100700
100800     MOVE W-INDEX-RECORD TO H-WAGE-INDX.
100900
101000***************************************************************
101100***  GET THE LABOR, NON-LABOR STANDARD RATES
101200
101300     IF  P-CURRENT-CENSUS-DIV NUMERIC
101400         MOVE P-CURRENT-CENSUS-DIV TO R2
101500     ELSE
101600         MOVE 10 TO R2.
101700     MOVE 10 TO R4.
101800     IF  P-STATE = 40
101900         MOVE 11 TO R2
102000         MOVE 12 TO R4.
102100     IF  RURAL
102200         MOVE 2 TO R3
102300     ELSE
102400         MOVE 1 TO R3.
102500     IF  REFERRAL-CENTER
102600         MOVE 1 TO R3.
102700
102800     PERFORM 2300-GET-LABOR-NLABOR-RATES2 VARYING R1
102900             FROM 1 BY 1 UNTIL R1 > 3.
103000
103100***************************************************************
103200***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
103300
103400     IF  H-FYE-MMDD > '0929'
103500         MOVE 83 TO H-FYE-YY
103600     ELSE
103700         MOVE 84 TO H-FYE-YY.
103800
103900     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30
104000         MOVE 31 TO H-FYE-DD
104100     ELSE
104200     IF  H-FYE-MM = 02 AND H-FYE-DD > 27
104300         MOVE 31 TO H-FYE-DD.
104400
104500     COMPUTE MO-DIFF =
104600         ((H-BILL-YY - 83) * 12 + H-BILL-MM) -
104700         ((H-FYE-YY  - 83) * 12 + H-FYE-MM).
104800
104900     IF  H-BILL-DD > H-FYE-DD
105000         ADD 1 TO MO-DIFF.
105100
105200     IF  MO-DIFF < 13 MOVE 1 TO HSP-FY
105300     ELSE
105400     IF  MO-DIFF < 32 MOVE 2 TO HSP-FY
105500     ELSE
105600     IF  MO-DIFF < 37 MOVE 3 TO HSP-FY
105700     ELSE
105800     IF  MO-DIFF < 49 MOVE 4 TO HSP-FY.
105900
106000     IF  MO-DIFF > 48 AND < 61
106100         MOVE 4 TO HSP-FY
106200         PERFORM 2100-CHECK-HSP-FY5.
106300
106400     IF  MO-DIFF > 60 MOVE 7 TO HSP-FY.
106500
106600     IF  MO-DIFF > 72
106700         MOVE 8 TO HSP-FY
106800         IF  HOLD-BILL-DATE > '891231'
106900             MOVE 9 TO HSP-FY.
107000
107100     IF  P-PPS-BLEND-YEAR NUMERIC AND VALID-PPS-BLEND-YEAR
107200         MOVE P-PPS-BLEND-YEAR TO HSP-FY.
107300
107400     IF  HSP-FY < 5
107500         MOVE HSP (HSP-FY) TO H-HSP-PCT
107600         MOVE FSP (HSP-FY) TO H-FSP-PCT
107700     ELSE
107800         MOVE 0.00  TO H-HSP-PCT
107900         MOVE 1.00  TO H-FSP-PCT.
108000
108100     IF  P-STATE = 38
108200         IF HSP-FY = 3
108300            MOVE 0.25  TO H-HSP-PCT MOVE 0.75 TO H-FSP-PCT
108400         ELSE
108500         IF HSP-FY > 3
108600            MOVE 0.00  TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.
108700
108800***************************************************************
108900***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
109000
109100     MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.
109200
109300     IF  P-STATE = 38
109400             MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.
109500
109600***************************************************************
109700*    REGIONAL FLOOR
109800
109900     IF  (H-REG-LABOR + H-REG-NLABOR) >
110000             (H-NAT-LABOR + H-NAT-NLABOR)
110100             MOVE 0.85 TO H-NAT-PCT MOVE 0.15 TO H-REG-PCT.
110200
110300     IF  P-STATE = 40
110400         MOVE 0.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT
110500         MOVE 0.25 TO H-NAT-PCT MOVE 0.75 TO H-REG-PCT.
110600
110700     IF  SOLE-COMMUNITY-PROV
110800         MOVE 0.75 TO H-HSP-PCT MOVE 0.25 TO H-FSP-PCT
110900         MOVE 0.00 TO H-NAT-PCT MOVE 1.00 TO H-REG-PCT.
111000
111100     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
111200         MOVE 1.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.
111300
111400***************************************************************
111500***  GET THE STANDARD UPDATING FACTOR
111600
111700     MOVE HSP-FY TO U1.
111800     ADD 1 TO U1.
111900     MOVE P-MM TO U2.
112000
112100     IF  H-FYE-MM = 01 AND H-FYE-DD < 16
112200         MOVE 12 TO U2
112300     ELSE
112400     IF  H-FYE-MM = 02 AND H-FYE-DD < 15
112500         MOVE 01 TO U2
112600     ELSE
112700     IF  H-FYE-MM > 02 AND H-FYE-DD < 16
112800         COMPUTE U2 = U2 - 1.
112900
113000     MOVE R3 TO U3.
113100
113200     IF  REFERRAL-CENTER
113300         MOVE 3 TO U3.
113400
113500     IF  U1 > 6
113600         SUBTRACT 6 FROM U1
113700         MOVE UPDATE-FACTOR2 (U1 U2 U3) TO H-UPDATE-FACTOR
113800     ELSE
113900         MOVE UPDATE-FACTOR  (U1 U2)    TO H-UPDATE-FACTOR.
114000
114100***************************************************************
114200***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE
114300
114400     IF  PRUP-UPDT-FACTOR NUMERIC
114500         IF  PRUP-UPDT-FACTOR > 0
114600             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.
114700
114800 2100-CHECK-HSP-FY5.
114900     COMPUTE HOLD-BILL-DAYS =
115000         H-BILL-YY * 365 + T-DAYS (H-BILL-MM) + H-BILL-DD.
115100
115200     IF  (H-BILL-YY = 84 OR 88 OR 92) AND H-BILL-MM > 2
115300         ADD 1 TO HOLD-BILL-DAYS.
115400
115500     IF  H-FYE-MMDD > '0929'
115600         MOVE 87 TO H-FYE-YY
115700     ELSE
115800         MOVE 88 TO H-FYE-YY.
115900
116000     MOVE P-DD TO H-FYE-DD.
116100
116200     COMPUTE HOLD-PROV-DAYS =
116300         H-FYE-YY * 365 + T-DAYS (H-FYE-MM) + H-FYE-DD.
116400
116500     IF  (H-FYE-YY = 84 OR 88 OR 92) AND H-FYE-MM > 2
116600         ADD 1 TO HOLD-PROV-DAYS.
116700
116800     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 51)
116900         MOVE 5 TO HSP-FY.
117000
117100     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 183)
117200         MOVE 6 TO HSP-FY.
117300
117400 2300-GET-LABOR-NLABOR-RATES2.
117500     IF  LARGE-URBAN
117600         MOVE 1 TO R3
117700     ELSE
117800     IF  OTHER-URBAN OR REFERRAL-CENTER
117900         MOVE 2 TO R3
118000     ELSE
118100         MOVE 3 TO R3.
118200
118300     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE2 (R1)
118400         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR
118500         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NLABOR
118600         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR
118700         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NLABOR
118800         IF REDESIGNATED-RURAL-YR1 OR REDESIGNATED-RURAL-YR2
118900            PERFORM 2350-BLEND-RURAL-RATES2.
119000
119100 2350-BLEND-RURAL-RATES2.
119200      IF  REDESIGNATED-RURAL-YR1
119300          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3
119400      ELSE
119500          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
119600
119700      COMPUTE H-REG-LABOR  ROUNDED =
119800          (REG-LABOR2  (R1 R2 2) - REG-LABOR2  (R1 R2 3))
119900            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R2 3).
120000
120100      COMPUTE H-REG-NLABOR ROUNDED =
120200          (REG-NLABOR2 (R1 R2 2) - REG-NLABOR2 (R1 R2 3))
120300            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R2 3).
120400
120500      COMPUTE H-NAT-LABOR  ROUNDED =
120600          (REG-LABOR2  (R1 R4 2) - REG-LABOR2  (R1 R4 3))
120700            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R4 3).
120800
120900      COMPUTE H-NAT-NLABOR ROUNDED =
121000          (REG-NLABOR2 (R1 R4 2) - REG-NLABOR2 (R1 R4 3))
121100            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R4 3).
121200
121300 2600-GET-DRG-WEIGHT3.
121400     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE3 (DX5)
121500         SET DX6 TO B-DRG
121600         MOVE DRG-WT3 (DX5 DX6)        TO H-DRG-WT
121700         MOVE DRG-ALOS3 (DX5 DX6)      TO H-ALOS
121800         MOVE DRG-DAYS-TRIM3 (DX5 DX6) TO H-DAYS-CUTOFF.
121900
122000
122100 3000-CALC-BLENDED-PAYMENT.
122200***************************************************************
122300*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
122400*        CALCULATE COVERED DAYS UTILIZATION.                  *
122500*        CALCULATE THE FEDERAL PORTION.                       *
122600*        CALCULATE THE HOSPITAL PORTION.                      *
122700*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
122800*        CALCULATE THE COST-OUTLIER PORTION.                  *
122900*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
123000*        CALCULATE THE INDIRECT TEACHING ADJUSTMENT.          *
123100***************************************************************
123200     PERFORM 3100-CALC-STAY-UTILIZATION.
123300     PERFORM 3300-CALC-FSP-AMT.
123400     PERFORM 3400-CALC-HSP-AMT.
123500
123600     IF  HOLD-BILL-DATE > '900331'
123700         IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
123800             PERFORM 3450-CALC-ADDITIONAL-HSP.
123900
124000     MOVE 00            TO  PPS-RTC.
124100     MOVE H-WAGE-INDX   TO  PPS-WAGE-INDX.
124200     MOVE H-ALOS        TO  PPS-AVG-LOS.
124300     MOVE H-DAYS-CUTOFF TO  PPS-DAYS-CUTOFF.
124400
124500     PERFORM 3600-CALC-OUTLIER.
124600
124700     IF  PAY-AVG-STAY-ONLY
124800         MOVE 0 TO H-OUTLIER-PART
124900         MOVE 04 TO PPS-RTC.
125000
125100     IF  PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST
125200         IF  B-LOS < H-ALOS
125300             IF  NOT (B-DRG = 385 OR 456)
125400                 PERFORM 3500-CALC-PERDIEM-AMT
125500                 MOVE 03 TO PPS-RTC.
125600
125700     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)
125800         IF  H-OUTCST-PART > 0
125900             MOVE H-OUTCST-PART TO H-OUTLIER-PART
126000             MOVE 05 TO PPS-RTC
126100         ELSE
126200         IF  PPS-RTC NOT = 03
126300             MOVE 00 TO PPS-RTC
126400             MOVE 0  TO H-OUTLIER-PART.
126500
126600     IF  PAY-DAYS-OUTLIER
126700         IF  PPS-RTC NOT = 01
126800             MOVE 0  TO H-OUTLIER-PART
126900             MOVE 00 TO PPS-RTC.
127000
127100     IF  PAY-COST-OUTLIER
127200         IF  PPS-RTC = 01
127300             MOVE 0  TO H-OUTLIER-PART
127400             MOVE 60 TO PPS-RTC.
127500
127600     IF  PAY-XFER-NO-COST
127700         MOVE 0  TO H-OUTLIER-PART
127800         MOVE 00 TO PPS-RTC
127900         IF B-LOS < H-ALOS
128000         IF  NOT (B-DRG = 385 OR 456)
128100             PERFORM 3500-CALC-PERDIEM-AMT
128200             MOVE 06 TO PPS-RTC.
128300
128400     IF  PPS-RTC < 50
128500         PERFORM 3800-CALC-BLEND-AMT
128600     ELSE
128700         MOVE 0 TO PPS-HSP-PART
128800                   PPS-FSP-PART
128900                   PPS-OUTLIER-PART
129000                   PPS-OUTLIER-DAYS
129100                   PPS-REG-DAYS-USED
129200                   PPS-LTR-DAYS-USED
129300                   PPS-TOTAL-PAYMENT
129400                   PPS-DSH-ADJ
129500                   PPS-INDTEACH-ADJ.
129600
129700 3100-CALC-STAY-UTILIZATION.
129800     IF  H-REG-DAYS > 0
129900         IF  H-REG-DAYS < H-DAYS-CUTOFF
130000             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
130100             MOVE 0          TO H-REG-DAYS
130200         ELSE
130300             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
130400             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
130500     ELSE
130600     IF  H-LTR-DAYS < H-DAYS-CUTOFF
130700         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
130800         MOVE 0          TO H-LTR-DAYS
130900     ELSE
131000         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
131100         SUBTRACT H-DAYS-CUTOFF  FROM H-LTR-DAYS.
131200
131300     IF  B-LOS > H-DAYS-CUTOFF
131400         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
131500
131600 3200-CALC-OUTLIER-UTILIZATION.
131700     COMPUTE PPS-OUTLIER-DAYS =
131800         B-LOS - H-DAYS-CUTOFF.
131900
132000     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
132100         COMPUTE PPS-OUTLIER-DAYS =
132200             H-REG-DAYS + H-LTR-DAYS
132300         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
132400         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
132500     ELSE
132600     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
132700         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
132800         COMPUTE PPS-LTR-DAYS-USED =
132900             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS - H-REG-DAYS)
133000     ELSE
133100         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
133200     IF  B-REVIEW-CODE = 03 OR 04
133300         IF  PPS-REG-DAYS-USED > 0
133400             MOVE 0 TO PPS-LTR-DAYS-USED.
133500
133600 3300-CALC-FSP-AMT.
133700     COMPUTE H-FSP-PART ROUNDED =
133800         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +
133900         H-NAT-NLABOR * H-COLA) * H-DRG-WT)
134000                           +
134100         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +
134200         H-REG-NLABOR * H-COLA) * H-DRG-WT).
134300
134400 3400-CALC-HSP-AMT.
134500     COMPUTE H-HSP-PART ROUNDED =
134600         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.
134700
134800 3450-CALC-ADDITIONAL-HSP.
134900***********************************************************
135000*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
135100*    SOLE COMMUNITY AND MEDICARE DEPENDENT HOSPITALS
135200*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
135300***********************************************************
135400**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
135500
135600     IF  HOLD-BILL-DATE > '900331'
135700         IF  RURAL AND NOT REFERRAL-CENTER
135800             MOVE 1.022000 TO OUTLIER-FACT
135900         ELSE
136000             MOVE 1.059700 TO OUTLIER-FACT.
136100
136200***********************************************************
136300**** CHANGE HSP UPDATE FACTORS WHEN HOSPITAL PERIOD CHANGES
136400**** FORCE FYE SO THAT NEW CALC STARTS ON OR AFTER 04/01/90
136500
136600     ADD 6 TO H-FYE-YY.
136700     MOVE 1.00000 TO H-UPDATE-FACTOR.
136800
136900     ADD 1 TO H-FYE-YY.
137000
137100     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE
137200         COMPUTE H-UPDATE-FACTOR =
137300             1.052 * .998637.
137400
137500     COMPUTE H-HSP-RATE ROUNDED =
137600         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
137700
137800     IF  P-DSH-PERCENT NOT NUMERIC
137900         MOVE 0 TO P-DSH-PERCENT.
138000
138100     PERFORM 3700-CALC-IND-TEACHING.
138200
138300     COMPUTE H-FSP-RATE ROUNDED =
138400         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +
138500         H-NAT-NLABOR * H-COLA))
138600                           +
138700          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +
138800         H-REG-NLABOR * H-COLA)))
138900                           *
139000         OUTLIER-FACT * (1 + H-IND-TEACHING + P-DSH-PERCENT).
139100
139200     IF  H-HSP-RATE > H-FSP-RATE
139300         COMPUTE H-HSP-PART =
139400             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
139500     ELSE
139600         MOVE 0 TO H-HSP-PART.
139700
139800 3500-CALC-PERDIEM-AMT.
139900     MOVE B-LOS TO H-COV-DAYS.
140000
140100     IF  H-COV-DAYS = 0
140200         MOVE 1 TO H-COV-DAYS.
140300
140400     COMPUTE H-HSP-PART ROUNDED =
140500        H-HSP-PART / H-ALOS * H-COV-DAYS
140600        ON SIZE ERROR MOVE 0 TO H-HSP-PART.
140700
140800     COMPUTE H-FSP-PART ROUNDED =
140900        H-FSP-PART / H-ALOS * H-COV-DAYS
141000        ON SIZE ERROR MOVE 0 TO H-FSP-PART.
141100
141200 3600-CALC-OUTLIER.
141300     MOVE 0.60 TO H-DAYOUT-PCT.
141400     MOVE 0.75 TO H-CSTOUT-PCT.
141500
141600     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
141700             MOVE 0.60 TO H-DAYOUT-PCT
141800             MOVE 0.90 TO H-CSTOUT-PCT.
141900
142000     MOVE 0.7439   TO H-LABOR-PCT.
142100     MOVE 0.2561   TO H-NLABOR-PCT.
142200     MOVE 0.660    TO H-CSTCHG-RATIO.
142300
142400     IF  P-CCR NUMERIC
142500        MOVE P-CCR TO H-CSTCHG-RATIO
142600     ELSE
142700        MOVE 0.000 TO H-CSTCHG-RATIO.
142800
142900     MOVE 2.000    TO H-CST-MULTIPLE.
143000     MOVE 34000.00 TO H-CST-THRESH.
143100
143200***********************************************************
143300***  DAY OUTLIER CALCULATION
143400
143500     IF  PPS-OUTLIER-DAYS > 0
143600     COMPUTE H-OUTDAY-PART  =
143700         H-DAYOUT-PCT *  H-FSP-PART / H-ALOS * PPS-OUTLIER-DAYS
143800         ON SIZE ERROR MOVE 0 TO H-OUTDAY-PART.
143900
144000***********************************************************
144100***  COST OUTLIER CALCULATION
144200
144300     COMPUTE H-DOLLAR-THRESHOLD ROUNDED =
144400         (H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDX) +
144500         (H-CST-THRESH * H-NLABOR-PCT * H-COLA).
144600
144700     COMPUTE H-COST-OUTLIER ROUNDED =
144800         H-CST-MULTIPLE * H-FSP-PART.
144900
145000     IF  H-DOLLAR-THRESHOLD > H-COST-OUTLIER
145100         MOVE H-DOLLAR-THRESHOLD TO H-COST-OUTLIER.
145200
145300     PERFORM 3700-CALC-IND-TEACHING.
145400
145500     MOVE 0 TO H-DSH-PERCENT.
145600
145700     IF  P-DSH-PERCENT NUMERIC
145800         MOVE P-DSH-PERCENT TO H-DSH-PERCENT.
145900
146000     COMPUTE H-BILL-COSTS ROUNDED =
146100         B-CHARGES-CLAIMED * H-CSTCHG-RATIO /
146200         (1 + H-IND-TEACHING + H-DSH-PERCENT)
146300         ON SIZE ERROR MOVE 0 TO H-BILL-COSTS.
146400
146500     IF  H-BILL-COSTS > H-COST-OUTLIER
146600         COMPUTE H-OUTCST-PART =
146700         H-CSTOUT-PCT * (H-BILL-COSTS - H-COST-OUTLIER).
146800
146900     IF  PAY-WITHOUT-COST
147000         MOVE 0 TO H-OUTCST-PART.
147100
147200***********************************************************
147300***  GREATER OF DAY OR COST
147400
147500     IF  H-OUTDAY-PART > 0 OR H-OUTCST-PART > 0
147600             IF  H-OUTDAY-PART > H-OUTCST-PART
147700                 MOVE H-OUTDAY-PART TO H-OUTLIER-PART
147800                 MOVE 01 TO PPS-RTC
147900             ELSE
148000                 MOVE H-OUTCST-PART TO H-OUTLIER-PART
148100                 MOVE 02 TO PPS-RTC.
148200
148300 3700-CALC-IND-TEACHING.
148400
148500     COMPUTE H-IND-TEACHING =
148600            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
148700
148800 3800-CALC-BLEND-AMT.
148900     IF  H-CMI-ADJ-CPD = 0
149000         MOVE 0.00 TO H-HSP-PCT
149100         MOVE 1.00 TO H-FSP-PCT.
149200
149300     COMPUTE PPS-HSP-PART ROUNDED =
149400         H-HSP-PCT * H-HSP-PART.
149500
149600     COMPUTE PPS-FSP-PART ROUNDED =
149700         H-FSP-PCT * H-FSP-PART.
149800
149900     COMPUTE PPS-OUTLIER-PART ROUNDED =
150000             H-FSP-PCT * H-OUTLIER-PART.
150100
150200     MOVE ZERO TO PPS-DSH-ADJ.
150300
150400     IF  P-DSH-PERCENT NUMERIC
150500             COMPUTE PPS-DSH-ADJ ROUNDED =
150600             (PPS-FSP-PART + PPS-OUTLIER-PART) * P-DSH-PERCENT.
150700
150800     PERFORM 3700-CALC-IND-TEACHING.
150900
151000     COMPUTE PPS-INDTEACH-ADJ ROUNDED =
151100         (PPS-FSP-PART + PPS-OUTLIER-PART) * H-IND-TEACHING.
151200
151300     COMPUTE PPS-TOTAL-PAYMENT =
151400             PPS-HSP-PART     + PPS-FSP-PART +
151500             PPS-OUTLIER-PART + PPS-DSH-ADJ  +
151600             PPS-INDTEACH-ADJ.
151700
151800******        L A S T   S O U R C E   S T A T E M E N T   *****
