000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL884.
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 '005PPCAL884  08/31/92'.
001900 01  W-STORAGE-REF                  PIC X(46)  VALUE
002000     'PPCAL884 - WORKING   STORAGE'.
002100 01  CAL-VERSION                    PIC X(05)  VALUE 'C88.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 01  RATE-TABLE.
013400     02  RATE-WORK.
013500*RATE 871001 REGION-NATION/URBAN-RURAL/LABOR-NLABOR
013600     05  FILLER PIC X(06) VALUE '871001'.
013700     05  FILLER PIC X(30) VALUE ' 0237806 083725 0228844 067856'.
013800     05  FILLER PIC X(30) VALUE ' 0215625 080262 0219454 064020'.
013900     05  FILLER PIC X(30) VALUE ' 0228631 073403 0209887 055719'.
014000     05  FILLER PIC X(30) VALUE ' 0241197 086870 0212345 061812'.
014100     05  FILLER PIC X(30) VALUE ' 0219578 066666 0208012 051945'.
014200     05  FILLER PIC X(30) VALUE ' 0228493 079076 0201819 055442'.
014300     05  FILLER PIC X(30) VALUE ' 0229457 073356 0193847 051039'.
014400     05  FILLER PIC X(30) VALUE ' 0218932 078040 0196971 059055'.
014500     05  FILLER PIC X(30) VALUE ' 0214109 089549 0190692 066141'.
014600     05  FILLER PIC X(30) VALUE ' 0227565 080635 0206738 057251'.
014700     05  FILLER PIC X(30) VALUE ' 0199258 035826 0133054 025358'.
014800     05  FILLER PIC X(30) VALUE ' 0222501 074950 0222501 074950'.
014900*RATE 871121 REGION-NATION/URBAN-RURAL/LABOR-NLABOR
015000     05  FILLER PIC X(06) VALUE '871121'.
015100     05  FILLER PIC X(30) VALUE ' 0244227 085986 0235023 069688'.
015200     05  FILLER PIC X(30) VALUE ' 0221447 082429 0225379 065749'.
015300     05  FILLER PIC X(30) VALUE ' 0234804 075385 0215554 057223'.
015400     05  FILLER PIC X(30) VALUE ' 0247709 089215 0218078 063481'.
015500     05  FILLER PIC X(30) VALUE ' 0225507 068466 0213628 053347'.
015600     05  FILLER PIC X(30) VALUE ' 0234662 081211 0207268 056939'.
015700     05  FILLER PIC X(30) VALUE ' 0235652 075337 0199081 052417'.
015800     05  FILLER PIC X(30) VALUE ' 0224843 080147 0202289 060649'.
015900     05  FILLER PIC X(30) VALUE ' 0219890 091967 0195841 067927'.
016000     05  FILLER PIC X(30) VALUE ' 0233709 082812 0212320 058797'.
016100     05  FILLER PIC X(30) VALUE ' 0204638 036793 0136646 026043'.
016200     05  FILLER PIC X(30) VALUE ' 0228509 076974 0228509 076974'.
016300     02  RATE-TAB REDEFINES RATE-WORK.
016400     05  RATE-PERIOD            OCCURS 2.
016500         10  RATE-EFF-DATE      PIC X(06).
016600         10  REG-NAT            OCCURS 12.
016700             15  R-URBAN-RURAL  OCCURS 2.
016800                 20  FILLER     PIC X(01).
016900                 20  REG-LABOR  PIC 9(05)V9(02).
017000                 20  FILLER     PIC X(01).
017100                 20  REG-NLABOR PIC 9(04)V9(02).
017200
017300 01  RATE-TABLE2.
017400     02  RATE-WORK2.
017500*RATE 880401 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
017600     05  FILLER PIC X(06) VALUE '880401'.
017700     05  FILLER PIC X(45) VALUE
017800        ' 0240746 084760 0239560 084342 0235108 069714'.
017900     05  FILLER PIC X(45) VALUE
018000        ' 0218290 081254 0217215 080854 0225462 065773'.
018100     05  FILLER PIC X(45) VALUE
018200        ' 0231457 074310 0230317 073944 0215633 057245'.
018300     05  FILLER PIC X(45) VALUE
018400        ' 0244179 087944 0242976 087511 0218158 063504'.
018500     05  FILLER PIC X(45) VALUE
018600        ' 0222293 067490 0221198 067158 0213706 053367'.
018700     05  FILLER PIC X(45) VALUE
018800        ' 0231317 080053 0230178 079659 0207344 056960'.
018900     05  FILLER PIC X(45) VALUE
019000        ' 0232294 074263 0231150 073897 0199153 052436'.
019100     05  FILLER PIC X(45) VALUE
019200        ' 0221639 079005 0220546 078615 0202363 060672'.
019300     05  FILLER PIC X(45) VALUE
019400        ' 0216756 090656 0215688 090209 0195912 067951'.
019500     05  FILLER PIC X(45) VALUE
019600        ' 0230378 081632 0229244 081229 0212397 058819'.
019700     05  FILLER PIC X(45) VALUE
019800        ' 0201721 036269 0200728 036090 0136697 026052'.
019900     05  FILLER PIC X(45) VALUE
020000        ' 0225416 075714 0225416 075714 0225416 075714'.
020100*RATE 881001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
020200     05  FILLER PIC X(06) VALUE '881001'.
020300     05  FILLER PIC X(45) VALUE
020400        ' 0249276 087787 0246848 086932 0245967 072925'.
020500     05  FILLER PIC X(45) VALUE
020600        ' 0223944 083305 0221763 082494 0235850 068799'.
020700     05  FILLER PIC X(45) VALUE
020800        ' 0239057 076755 0236729 076007 0225181 059780'.
020900     05  FILLER PIC X(45) VALUE
021000        ' 0252039 090778 0249585 089894 0228173 066415'.
021100     05  FILLER PIC X(45) VALUE
021200        ' 0229431 069500 0227196 068823 0223178 055745'.
021300     05  FILLER PIC X(45) VALUE
021400        ' 0239122 082747 0236793 081941 0216919 059556'.
021500     05  FILLER PIC X(45) VALUE
021600        ' 0238408 076235 0236087 075492 0208031 054770'.
021700     05  FILLER PIC X(45) VALUE
021800        ' 0229260 081728 0227027 080933 0211498 063406'.
021900     05  FILLER PIC X(45) VALUE
022000        ' 0223084 093277 0220912 092368 0204607 070966'.
022100     05  FILLER PIC X(45) VALUE
022200        ' 0237422 084095 0235110 083275 0221989 061482'.
022300     05  FILLER PIC X(45) VALUE
022400        ' 0210903 037731 0208851 037363 0148355 027462'.
022500     05  FILLER PIC X(45) VALUE
022600        ' 0232677 078076 0232677 078076 0232677 078076'.
022700     02  RATE-TAB2 REDEFINES RATE-WORK2.
022800     05  RATE-PERIOD2           OCCURS 2.
022900         10  RATE-EFF-DATE2     PIC X(06).
023000         10  REG-NAT2           OCCURS 12.
023100             15  R-URBAN-RURAL2   OCCURS 3.
023200                 20  FILLER       PIC X(01).
023300                 20  REG-LABOR2   PIC 9(05)V9(02).
023400                 20  FILLER       PIC X(01).
023500                 20  REG-NLABOR2  PIC 9(04)V9(02).
023600
023700 01  UPDT-ENTRIES               PIC 9(02) VALUE 6.
023800 01  UPDT-TABLE.
023900     02  UPDT-WORK.
024000*UPDT 831001 UPDATING FACTORS EFFECTIVE DATE
024100     05  FILLER PIC X(06) VALUE '831001'.
024200     05  FILLER PIC X(18) VALUE 'UP01 830131 112509'.
024300     05  FILLER PIC X(18) VALUE 'UP02 830228 112570'.
024400     05  FILLER PIC X(18) VALUE 'UP03 830331 112631'.
024500     05  FILLER PIC X(18) VALUE 'UP04 830430 112693'.
024600     05  FILLER PIC X(18) VALUE 'UP05 830531 112754'.
024700     05  FILLER PIC X(18) VALUE 'UP06 830630 112815'.
024800     05  FILLER PIC X(18) VALUE 'UP07 830731 112877'.
024900     05  FILLER PIC X(18) VALUE 'UP08 830831 112938'.
025000     05  FILLER PIC X(18) VALUE 'UP09 820930 113570'.
025100     05  FILLER PIC X(18) VALUE 'UP10 821031 113265'.
025200     05  FILLER PIC X(18) VALUE 'UP11 821130 112961'.
025300     05  FILLER PIC X(18) VALUE 'UP12 821231 112448'.
025400*UPDT 840203 UPDATING FACTORS EFFECTIVE DATE
025500     05  FILLER PIC X(06) VALUE '840203'.
025600     05  FILLER PIC X(18) VALUE 'UP01 830131 112395'.
025700     05  FILLER PIC X(18) VALUE 'UP02 830228 112456'.
025800     05  FILLER PIC X(18) VALUE 'UP03 830331 112517'.
025900     05  FILLER PIC X(18) VALUE 'UP04 830430 112578'.
026000     05  FILLER PIC X(18) VALUE 'UP05 830531 112639'.
026100     05  FILLER PIC X(18) VALUE 'UP06 830630 112701'.
026200     05  FILLER PIC X(18) VALUE 'UP07 830731 112762'.
026300     05  FILLER PIC X(18) VALUE 'UP08 830831 112823'.
026400     05  FILLER PIC X(18) VALUE 'UP09 820930 113242'.
026500     05  FILLER PIC X(18) VALUE 'UP10 821031 112938'.
026600     05  FILLER PIC X(18) VALUE 'UP11 821130 112635'.
026700     05  FILLER PIC X(18) VALUE 'UP12 821231 112333'.
026800*UPDT 841001 UPDATING FACTORS EFFECTIVE DATE
026900     05  FILLER PIC X(06) VALUE '841001'.
027000     05  FILLER PIC X(18) VALUE 'UP01 830131 119197'.
027100     05  FILLER PIC X(18) VALUE 'UP02 830228 119318'.
027200     05  FILLER PIC X(18) VALUE 'UP03 830331 119438'.
027300     05  FILLER PIC X(18) VALUE 'UP04 830430 119559'.
027400     05  FILLER PIC X(18) VALUE 'UP05 830531 119680'.
027500     05  FILLER PIC X(18) VALUE 'UP06 830630 119801'.
027600     05  FILLER PIC X(18) VALUE 'UP07 830731 119922'.
027700     05  FILLER PIC X(18) VALUE 'UP08 830831 120044'.
027800     05  FILLER PIC X(18) VALUE 'UP09 820930 119898'.
027900     05  FILLER PIC X(18) VALUE 'UP10 821031 119624'.
028000     05  FILLER PIC X(18) VALUE 'UP11 821130 119349'.
028100     05  FILLER PIC X(18) VALUE 'UP12 821231 119076'.
028200*UPDT 860501 UPDATING FACTORS EFFECTIVE DATE  ----1.0050
028300     05  FILLER PIC X(06) VALUE '860501'.
028400     05  FILLER PIC X(18) VALUE 'UP01 830131 119793'.
028500     05  FILLER PIC X(18) VALUE 'UP02 830228 119915'.
028600     05  FILLER PIC X(18) VALUE 'UP03 830331 120035'.
028700     05  FILLER PIC X(18) VALUE 'UP04 830430 120157'.
028800     05  FILLER PIC X(18) VALUE 'UP05 830531 120278'.
028900     05  FILLER PIC X(18) VALUE 'UP06 830630 120400'.
029000     05  FILLER PIC X(18) VALUE 'UP07 830731 120522'.
029100     05  FILLER PIC X(18) VALUE 'UP08 830831 120644'.
029200     05  FILLER PIC X(18) VALUE 'UP09 820930 120497'.
029300     05  FILLER PIC X(18) VALUE 'UP10 821031 120222'.
029400     05  FILLER PIC X(18) VALUE 'UP11 821130 119946'.
029500     05  FILLER PIC X(18) VALUE 'UP12 821231 119671'.
029600*UPDT 861001 UPDATING FACTORS EFFECTIVE DATE  ----1.0115
029700     05  FILLER PIC X(06) VALUE '861001'.
029800     05  FILLER PIC X(18) VALUE 'UP01 830131 121171'.
029900     05  FILLER PIC X(18) VALUE 'UP02 830228 121294'.
030000     05  FILLER PIC X(18) VALUE 'UP03 830331 121415'.
030100     05  FILLER PIC X(18) VALUE 'UP04 830430 121539'.
030200     05  FILLER PIC X(18) VALUE 'UP05 830531 121661'.
030300     05  FILLER PIC X(18) VALUE 'UP06 830630 121785'.
030400     05  FILLER PIC X(18) VALUE 'UP07 830731 121908'.
030500     05  FILLER PIC X(18) VALUE 'UP08 830831 122031'.
030600     05  FILLER PIC X(18) VALUE 'UP09 820930 121883'.
030700     05  FILLER PIC X(18) VALUE 'UP10 821031 121605'.
030800     05  FILLER PIC X(18) VALUE 'UP11 821130 121325'.
030900     05  FILLER PIC X(18) VALUE 'UP12 821231 121047'.
031000*UPDT 871121 UPDATING FACTORS EFFECTIVE DATE  ----1.0270
031100     05  FILLER PIC X(06) VALUE '871121'.
031200     05  FILLER PIC X(18) VALUE 'UP01 830131 124443'.
031300     05  FILLER PIC X(18) VALUE 'UP02 830228 124569'.
031400     05  FILLER PIC X(18) VALUE 'UP03 830331 124693'.
031500     05  FILLER PIC X(18) VALUE 'UP04 830430 124821'.
031600     05  FILLER PIC X(18) VALUE 'UP05 830531 124946'.
031700     05  FILLER PIC X(18) VALUE 'UP06 830630 125073'.
031800     05  FILLER PIC X(18) VALUE 'UP07 830731 125200'.
031900     05  FILLER PIC X(18) VALUE 'UP08 830831 125326'.
032000     05  FILLER PIC X(18) VALUE 'UP09 820930 125174'.
032100     05  FILLER PIC X(18) VALUE 'UP10 821031 124888'.
032200     05  FILLER PIC X(18) VALUE 'UP11 821130 124601'.
032300     05  FILLER PIC X(18) VALUE 'UP12 821231 124315'.
032400     02  UPDATE-TABLE REDEFINES UPDT-WORK.
032500     05  UPDT-PERIOD             OCCURS 6.
032600         10  UPDT-EFF-DATE       PIC X(06).
032700         10  UPDT-MONTH          OCCURS 12.
032800             15  FILLER          PIC X(05).
032900             15  UP-BASE-DATE    PIC X(06).
033000             15  FILLER          PIC X(01).
033100             15  UPDATE-FACTOR   PIC 9(01)V9(05).
033200
033300 01  UPDT-ENTRIES2              PIC 9(02) VALUE 4.
033400 01  UPDT-TABLE2.
033500     02  UPDT-WORK2.
033600*UPDT 880401 UPDATING FACTORS EFFECTIVE DATE
033700*     LURBAN=1.0150 OURBAN=1.0100 RURAL=1.0300
033800     05  FILLER PIC X(06) VALUE '880401'.
033900     05  FILLER PIC X(27) VALUE '830131 122989 122383 124806'.
034000     05  FILLER PIC X(27) VALUE '830228 123113 122507 124933'.
034100     05  FILLER PIC X(27) VALUE '830331 123236 122629 125057'.
034200     05  FILLER PIC X(27) VALUE '830430 123362 122754 125185'.
034300     05  FILLER PIC X(27) VALUE '830531 123486 122878 125311'.
034400     05  FILLER PIC X(27) VALUE '830630 123612 123003 125439'.
034500     05  FILLER PIC X(27) VALUE '830731 123737 123127 125565'.
034600     05  FILLER PIC X(27) VALUE '830831 123861 123251 125692'.
034700     05  FILLER PIC X(27) VALUE '820930 123711 123102 125539'.
034800     05  FILLER PIC X(27) VALUE '821031 123429 122821 125253'.
034900     05  FILLER PIC X(27) VALUE '821130 123145 122538 124965'.
035000     05  FILLER PIC X(27) VALUE '821231 122863 122257 124678'.
035100*UPDT 881001 UPDATING FACTORS EFFECTIVE DATE
035200*     LURBAN=1.0340 OURBAN=1.0290 RURAL=1.0390
035300     05  FILLER PIC X(06) VALUE '881001'.
035400     05  FILLER PIC X(27) VALUE '830131 127171 125932 129673'.
035500     05  FILLER PIC X(27) VALUE '830228 127299 126060 129805'.
035600     05  FILLER PIC X(27) VALUE '830331 127426 126185 129934'.
035700     05  FILLER PIC X(27) VALUE '830430 127556 126314 130067'.
035800     05  FILLER PIC X(27) VALUE '830531 127685 126441 130198'.
035900     05  FILLER PIC X(27) VALUE '830630 127815 126570 130331'.
036000     05  FILLER PIC X(27) VALUE '830731 127944 126698 130462'.
036100     05  FILLER PIC X(27) VALUE '830831 128072 126825 130594'.
036200     05  FILLER PIC X(27) VALUE '820930 127917 126672 130435'.
036300     05  FILLER PIC X(27) VALUE '821031 127626 126383 130138'.
036400     05  FILLER PIC X(27) VALUE '821130 127332 126092 129839'.
036500     05  FILLER PIC X(27) VALUE '821231 127040 125802 129540'.
036600*UPDT 891001 UPDATING FACTORS EFFECTIVE DATE
036700*     LURBAN=1.0550 OURBAN=1.0550 RURAL=1.0550 (OCT - DEC)
036800     05  FILLER PIC X(06) VALUE '891001'.
036900     05  FILLER PIC X(27) VALUE '830131 134165 132858 136805'.
037000     05  FILLER PIC X(27) VALUE '830228 134300 132993 136944'.
037100     05  FILLER PIC X(27) VALUE '830331 134434 133125 137080'.
037200     05  FILLER PIC X(27) VALUE '830430 134572 133261 137221'.
037300     05  FILLER PIC X(27) VALUE '830531 134708 133395 137359'.
037400     05  FILLER PIC X(27) VALUE '830630 134845 133531 137499'.
037500     05  FILLER PIC X(27) VALUE '830731 134981 133666 137637'.
037600     05  FILLER PIC X(27) VALUE '830831 135116 133800 137777'.
037700     05  FILLER PIC X(27) VALUE '820930 134952 133639 137609'.
037800     05  FILLER PIC X(27) VALUE '821031 134645 133334 137296'.
037900     05  FILLER PIC X(27) VALUE '821130 134335 133027 136980'.
038000     05  FILLER PIC X(27) VALUE '821231 134027 132721 136665'.
038100*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE
038200*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)
038300     05  FILLER PIC X(06) VALUE '900101'.
038400     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.
038500     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.
038600     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.
038700     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.
038800     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.
038900     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.
039000     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.
039100     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.
039200     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.
039300     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.
039400     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.
039500     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.
039600     02  UPDATE-TABLE2 REDEFINES UPDT-WORK2.
039700     05  UPDT-PERIOD2             OCCURS 4.
039800         10  UPDT-EFF-DATE2       PIC X(06).
039900         10  UPDT-MONTH2          OCCURS 12.
040000             15  UP-BASE-DATE2    PIC X(06).
040100             15  UP-L-O-R2        OCCURS 3.
040200                 20  FILLER           PIC X(01).
040300                 20  UPDATE-FACTOR2   PIC 9(01)V9(05).
040400
040500 01  DRG-TABLE.
040600     05  D-TAB.
040700         10  FILLER                  PIC X(06) VALUE
040800        '871001'.
040900         10  FILLER                  PIC X(44) VALUE
041000        '03443414232038160126310291831273102590412530'.
041100         10  FILLER                  PIC X(44) VALUE
041200        '01568506721004393020070252691122900736703419'.
041300         10  FILLER                  PIC X(44) VALUE
041400        '01263907125012123076260077290522300945906925'.
041500         10  FILLER                  PIC X(44) VALUE
041600        '00932407225012429075250062930421701038406625'.
041700         10  FILLER                  PIC X(44) VALUE
041800        '00635804720009557063240061580452201622007726'.
041900         10  FILLER                  PIC X(44) VALUE
042000        '01361307125007055046180095050452200922805223'.
042100         10  FILLER                  PIC X(44) VALUE
042200        '00538603615005635025130147530432201169405624'.
042300         10  FILLER                  PIC X(44) VALUE
042400        '00585603420003539020080065500422200400502813'.
042500         10  FILLER                  PIC X(44) VALUE
042600        '00245701605012038060240060350402100682003110'.
042700         10  FILLER                  PIC X(44) VALUE
042800        '00710403014003779022090051670180500467502007'.
042900         10  FILLER                  PIC X(44) VALUE
043000        '00365701604006600025090037270371400635205620'.
043100         10  FILLER                  PIC X(44) VALUE
043200        '00559503314006195038220036110261300401802913'.
043300         10  FILLER                  PIC X(44) VALUE
043400        '02892311930006681028090054240230800703302711'.
043500         10  FILLER                  PIC X(44) VALUE
043600        '00615902310006889032110045980180600447101807'.
043700         10  FILLER                  PIC X(44) VALUE
043800        '00790703220003097015030038450170500261601503'.
043900         10  FILLER                  PIC X(44) VALUE
044000        '00540102111003089013030115380462301054804723'.
044100         10  FILLER                  PIC X(44) VALUE
044200        '00460003512004272032120099640441900721705117'.
044300         10  FILLER                  PIC X(44) VALUE
044400        '00536604114005345032130060260391400489503115'.
044500         10  FILLER                  PIC X(44) VALUE
044600        '00740403722003427021090302581233002088508827'.
044700         10  FILLER                  PIC X(44) VALUE
044800        '01097004422014817090270207770972801334107726'.
044900         10  FILLER                  PIC X(44) VALUE
045000        '01103207025011899065240096980652500537204317'.
045100         10  FILLER                  PIC X(44) VALUE
045200        '01145106825007720049230156910612401126306324'.
045300         10  FILLER                  PIC X(44) VALUE
045400        '01286207325008961061190094480492301282106825'.
045500         10  FILLER                  PIC X(44) VALUE
045600        '00826405123013954074250075710522100980406020'.
045700         10  FILLER                  PIC X(44) VALUE
045800        '00715104915005744030110078030421900523802911'.
045900         10  FILLER                  PIC X(44) VALUE
046000        '00958505423006625040191192252584407342417435'.
046100         10  FILLER                  PIC X(44) VALUE
046200        '05781113231055415142320428581112905370311029'.
046300         10  FILLER                  PIC X(44) VALUE
046400        '03914207425036718127310226390932701891105924'.
046500         10  FILLER                  PIC X(44) VALUE
046600        '02459014733017040103280405161293102769406625'.
046700         10  FILLER                  PIC X(44) VALUE
046800        '01226104522017563030140086920432202477611129'.
046900         10  FILLER                  PIC X(44) VALUE
047000        '01716209427012002073250139790292101180604522'.
047100         10  FILLER                  PIC X(44) VALUE
047200        '00688402510030575172350102220622400851308022'.
047300         10  FILLER                  PIC X(44) VALUE
047400        '01571503021008776056240058620402200797604719'.
047500         10  FILLER                  PIC X(44) VALUE
047600        '00599703714006088044170092210522300610303815'.
047700         10  FILLER                  PIC X(44) VALUE
047800        '00631503321008535048200059120361400668904114'.
047900         10  FILLER                  PIC X(44) VALUE
048000        '00680104417005244034130055000301101144905824'.
048100         10  FILLER                  PIC X(44) VALUE
048200        '00668903817034379156340213441202703237614533'.
048300         10  FILLER                  PIC X(44) VALUE
048400        '01834110724026797127310148850892401598808426'.
048500         10  FILLER                  PIC X(44) VALUE
048600        '01056606723037961134310181950892700838206021'.
048700         10  FILLER                  PIC X(44) VALUE
048800        '00932405323005449033130114540602300681004014'.
048900         10  FILLER                  PIC X(44) VALUE
049000        '00754104016005004028090077170391102401411029'.
049100         10  FILLER                  PIC X(44) VALUE
049200        '01467508118014954074230086510481201406704823'.
049300         10  FILLER                  PIC X(44) VALUE
049400        '00668902612027316115290140180672501186106925'.
049500         10  FILLER                  PIC X(44) VALUE
049600        '00704904422009878056220066000441500996406124'.
049700         10  FILLER                  PIC X(44) VALUE
049800        '00783405518005838043140104160712500915005824'.
049900         10  FILLER                  PIC X(44) VALUE
050000        '00541504116007224049190052520371400422302413'.
050100         10  FILLER                  PIC X(44) VALUE
050200        '00753004322004112029110045400220800914404923'.
050300         10  FILLER                  PIC X(44) VALUE
050400        '00496603015008147039150468811673503862514432'.
050500         10  FILLER                  PIC X(44) VALUE
050600        '03025214532018505100280238541243001689810022'.
050700         10  FILLER                  PIC X(44) VALUE
050800        '01876809827011152070150226931233002473109427'.
050900         10  FILLER                  PIC X(44) VALUE
051000        '02393308326012075072250104220642401026906124'.
051100         10  FILLER                  PIC X(44) VALUE
051200        '01213206725006806042220092430562300581603815'.
051300         10  FILLER                  PIC X(44) VALUE
051400        '02414512328021776135320161041112701376406217'.
051500         10  FILLER                  PIC X(44) VALUE
051600        '01846010529021385128310137680902601597308426'.
051700         10  FILLER                  PIC X(44) VALUE
051800        '02815512931016224090270101860592000924205323'.
051900         10  FILLER                  PIC X(44) VALUE
052000        '01452306324007995033180112020522200658803112'.
052100         10  FILLER                  PIC X(44) VALUE
052200        '00677503214013570068250068780341600820103214'.
052300         10  FILLER                  PIC X(44) VALUE
052400        '00520202108008868046230083460352100860303121'.
052500         10  FILLER                  PIC X(44) VALUE
052600        '01726709027009057049230120600822600903607225'.
052700         10  FILLER                  PIC X(44) VALUE
052800        '00595904823016579107290095500752601093207325'.
052900         10  FILLER                  PIC X(44) VALUE
053000        '00664405422014100089270066940532300730505724'.
053100         10  FILLER                  PIC X(44) VALUE
053200        '00534504419005769046180054070391800609704519'.
053300         10  FILLER                  PIC X(44) VALUE
053400        '00683004422006721045220041480251100349601807'.
053500         10  FILLER                  PIC X(44) VALUE
053600        '00790905924004557038180046380291500658504121'.
053700         10  FILLER                  PIC X(44) VALUE
053800        '01044806618008462053130100460522300601003011'.
053900         10  FILLER                  PIC X(44) VALUE
054000        '00620402709004312020060259671533301617910829'.
054100         10  FILLER                  PIC X(44) VALUE
054200        '01390906825006865034190062480341500593402412'.
054300         10  FILLER                  PIC X(44) VALUE
054400        '01517707626006834034180120170872701037507425'.
054500         10  FILLER                  PIC X(44) VALUE
054600        '00724706024010494064240063950382200524502916'.
054700         10  FILLER                  PIC X(44) VALUE
054800        '00969507225007063058190073670461600619704522'.
054900         10  FILLER                  PIC X(44) VALUE
055000        '00430603416003424022090076820552400479503718'.
055100         10  FILLER                  PIC X(44) VALUE
055200        '02991917536027063120300222741383202001808226'.
055300         10  FILLER                  PIC X(44) VALUE
055400        '01147005420008428040130049910230802602712030'.
055500         10  FILLER                  PIC X(44) VALUE
055600        '01169806224007493061210072280451900925906024'.
055700         10  FILLER                  PIC X(44) VALUE
055800        '00579104517007065032200082710472301086206925'.
055900         10  FILLER                  PIC X(44) VALUE
056000        '00675804722038463165350277471283102365110328'.
056100         10  FILLER                  PIC X(44) VALUE
056200        '01366506224014376082260091210561701535407325'.
056300         10  FILLER                  PIC X(44) VALUE
056400        '00862004322009026046220056810291100824604421'.
056500         10  FILLER                  PIC X(44) VALUE
056600        '00528602812004323023110236350822601284006224'.
056700         10  FILLER                  PIC X(44) VALUE
056800        '00354201807010441060240057770321901023006825'.
056900         10  FILLER                  PIC X(44) VALUE
057000        '00731605518006829043140070200361600513902409'.
057100         10  FILLER                  PIC X(44) VALUE
057200        '00678904520004553032130055110332100626603918'.
057300         10  FILLER                  PIC X(44) VALUE
057400        '00443102612002788016050090500532300591303618'.
057500         10  FILLER                  PIC X(44) VALUE
057600        '00688703419019237116280140800941901077406619'.
057700         10  FILLER                  PIC X(44) VALUE
057800        '00750505011007865035220059300281300433502407'.
057900         10  FILLER                  PIC X(44) VALUE
058000        '01029404315004494021080037880170401130205724'.
058100         10  FILLER                  PIC X(44) VALUE
058200        '00828404321009360057240050910271400658803820'.
058300         10  FILLER                  PIC X(44) VALUE
058400        '00405902309006734048160033330160500488602914'.
058500         10  FILLER                  PIC X(44) VALUE
058600        '02299712831015482091230099290671300798305714'.
058700         10  FILLER                  PIC X(44) VALUE
058800        '02159111429012941081200090250631200695703619'.
058900         10  FILLER                  PIC X(44) VALUE
059000        '00644202713004095017050065970351600426202208'.
059100         10  FILLER                  PIC X(44) VALUE
059200        '01906009628010916061240054810321800830805722'.
059300         10  FILLER                  PIC X(44) VALUE
059400        '00492003317010303065190071640500900492703412'.
059500         10  FILLER                  PIC X(44) VALUE
059600        '00321202406005641031070068170441500352002511'.
059700         10  FILLER                  PIC X(44) VALUE
059800        '00988202921007787042090028430210900312401908'.
059900         10  FILLER                  PIC X(44) VALUE
060000        '00369401605001309012020039640331700351202613'.
060100         10  FILLER                  PIC X(44) VALUE
060200        '01223203722036480179360182671333101157108627'.
060300         10  FILLER                  PIC X(44) VALUE
060400        '01412707425009416042200022180310703525212831'.
060500         10  FILLER                  PIC X(44) VALUE
060600        '01520609127012250048230072640442200344101707'.
060700         10  FILLER                  PIC X(44) VALUE
060800        '01014505523012115064240068300392102690011229'.
060900         10  FILLER                  PIC X(44) VALUE
061000        '02087109928009252046230152220792600808504823'.
061100         10  FILLER                  PIC X(44) VALUE
061200        '01040704923027146125300144990742500895504222'.
061300         10  FILLER                  PIC X(44) VALUE
061400        '01080207125004742024100049190291300395402008'.
061500         10  FILLER                  PIC X(44) VALUE
061600        '01238507125008128051230350671453201589407425'.
061700         10  FILLER                  PIC X(44) VALUE
061800        '00934605021009743067250097780592400694904717'.
061900         10  FILLER                  PIC X(44) VALUE
062000        '00625504416006274034180153330802602217612230'.
062100         10  FILLER                  PIC X(44) VALUE
062200        '00600404321006580060240063150562400730506124'.
062300         10  FILLER                  PIC X(44) VALUE
062400        '00886807125009329088270071340582400709704322'.
062500         10  FILLER                  PIC X(44) VALUE
062600        '00423203220008149059240059030502300978809127'.
062700         10  FILLER                  PIC X(44) VALUE
062800        '01330613732000000000000175230722502249809628'.
062900         10  FILLER                  PIC X(44) VALUE
063000        '00718502414019218059240121690432200820705323'.
063100         10  FILLER                  PIC X(44) VALUE
063200        '00518303717004796024100047030271200347002909'.
063300         10  FILLER                  PIC X(44) VALUE
063400        '00792204522004917030140059070341400897604623'.
063500         10  FILLER                  PIC X(44) VALUE
063600        '00513703317009067045220046920291401981104623'.
063700         10  FILLER                  PIC X(44) VALUE
063800        '02531704122037113161340179641002801049506424'.
063900         10  FILLER                  PIC X(44) VALUE
064000        '00719802417017517137320076330532300474003415'.
064100         10  FILLER                  PIC X(44) VALUE
064200        '00317201806005383028200047230292102467909928'.
064300         10  FILLER                  PIC X(44) VALUE
064400        '00000000000000000000000408961813610729617135'.
064500         10  FILLER                  PIC X(44) VALUE
064600        '02710708326118772333510317570882700000000000'.
064700         10  FILLER                  PIC X(44) VALUE
064800        '00000000000000000000000000000000000000000000'.
064900     05  DRGX-TAB REDEFINES D-TAB.
065000     10  DRGX-PERIOD                OCCURS 1
065100                                    INDEXED BY DX1.
065200         15  DRGX-EFF-DATE          PIC X(06).
065300         15  DRG-DATA               OCCURS 480
065400                                    INDEXED BY DX2.
065500             20  DRG-WT             PIC 9(02)V9(04).
065600             20  DRG-ALOS           PIC 9(02)V9(01).
065700             20  DRG-DAYS-CUTOFF    PIC 9(02).
065800
065900
066000 LINKAGE SECTION.
066100
066200***************************************************************
066300*                 * * * * * * * * *                           *
066400*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
066500*    IN HOW TO PAY THE BILL.                                  *
066600*         REVIEW-CODE:                                        *
066700*            00 = PAY-WITH-OUTLIER.                           *
066800*                 WILL CALCULATE THE STANDARD PAYMENT.        *
066900*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
067000*                 OUTLIERS. PPS-RTC CODES 01 AND 02 NOW SENT  *
067100*                 TO THE PRO FOR POST PAYMENT REVIEW.       . *
067200*            01 = PAY-DAYS-OUTLIER.                           *
067300*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
067400*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
067500*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
067600*                 OUTLIER CUTOFF FOR THE DRG.                 *
067700*            02 = PAY-COST-OUTLIER.                           *
067800*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
067900*                 ALSO CALCULATE THE COST OUTLIER PORTION OF  *
068000*                 THE PAYMENT IF THE ADJUSTED CHARGES ON THE  *
068100*                 BILL EXCEED THE COST THRESHOLD.             *
068200*                 IF  LENGTH OF STAY EXCEED OUTLIER CUTOFF, NO*
068300*                 PAYMENT WILL BE MADE AND A RETURN-CODE OF   *
068400*                 60 WILL BE RETURNED.                        *
068500*            03 = PAY-PERDIEM-DAYS.                           *
068600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
068700*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
068800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
068900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
069000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
069100*                 STANDARD PAYMENT IS CALCULATED.             *
069200*                 TRANSFERS AFTER 093084 POTENTIALLY          *
069300*                 ELIGABLE FOR COST OUTLIER PAYMENT.          *
069400*            04 = PAY-AVG-STAY-ONLY.                          *
069500*                 WILL CALCULATE THE STANDARD PAYMENT.        *
069600*                 WILL NOT TEST FOR DAYS OR COST OUTLIERS.    *
069700*            05 = PAY-XFER-WITH-COST                          *
069800*                 PAY TRANSFER WITH COST OUTLIER APPROVED.    *
069900*            06 = PAY-XFER-NO-COST                            *
070000*                 PAY TRANSFER WITH COST OUTLIER DENIED.      *
070100*            07 = PAY-WITHOUT-COST                            *
070200*                 PAY WITHOUT COST OUTLIER.                   *
070300*                                                             *
070400***************************************************************
070500 01  BILL-DATA.
070600         10  B-PROVIDER-NO          PIC X(06).
070700         10  B-REVIEW-CODE          PIC 9(02).
070800             88  VALID-REVIEW-CODE  VALUE 00 THRU 07.
070900             88  PAY-WITH-OUTLIER   VALUE 00 07.
071000             88  PAY-DAYS-OUTLIER   VALUE 01.
071100             88  PAY-COST-OUTLIER   VALUE 02.
071200             88  PAY-PERDIEM-DAYS   VALUE 03.
071300             88  PAY-AVG-STAY-ONLY  VALUE 04.
071400             88  PAY-XFER-WITH-COST VALUE 05.
071500             88  PAY-XFER-NO-COST   VALUE 06.
071600             88  PAY-WITHOUT-COST   VALUE 07.
071700         10  B-DRG                  PIC 9(03).
071800         10  B-LOS                  PIC 9(03).
071900         10  B-COVERED-DAYS         PIC 9(03).
072000         10  B-LTR-DAYS             PIC 9(02).
072100         10  B-DISCHARGE-DATE.
072200             15  B-DISCHG-MM        PIC 9(02).
072300             15  B-DISCHG-DD        PIC 9(02).
072400             15  B-DISCHG-YY        PIC 9(02).
072500         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
072600***************************************************************
072700*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
072800*    AND PASSED BACK TO THE CALLING PROGRAM                   *
072900*            RETURN CODE VALUES (PPS-RTC)                     *
073000*                                                             *
073100*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
073200*              00 = PAID NORMAL DRG PAYMENT                   *
073300*                                                             *
073400*              01 = PAID AS A DAY-OUTLIER. SEND TO PRO FOR    *
073500*                   POST PAYMENT REVIEW.                      *
073600*              02 = PAID AS A COST-OUTLIER. SEND TO PRO FOR   *
073700*                   POST PAYMENT REVIEW.                      *
073800*              03 = PAID ON PERDIEM BASIS (XFER OR REVIEW 03) *
073900*                   NOT POTENTIALLY ELIGEABLE FOR COST OUTLIER*
074000*              04 = PAID NORMAL DRG PAYMENT ONLY. DAY AND     *
074100*                   COST OUTLIER CRITERIA IGNORED.            *
074200*              05 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
074300*                   OUTLIER APPROVED.                         *
074400*              06 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
074500*                   OUTLIER DENIED.                           *
074600*                                                             *
074700*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
074800*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
074900*              52 = INVALID MSA # IN PROVIDER FILE            *
075000*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
075100*              54 = DRG NOT 001-468 OR 471-490                *
075200*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
075300*              56 = INVALID LENGTH OF STAY                    *
075400*              57 = REVIEW CODE INVALID (NOT 00 - 07)         *
075500*              58 = TOTAL CHARGES NOT NUMERIC                 *
075600*              59 = POSSIBLE DAY OUTLIER CANDIDATE            *
075700*              60 = REVIEW CODE 02 (POSSIBLE COST OUTLIER)    *
075800*                   AND POSSIBLE DAY OUTLIER CANDIDATE. NOT   *
075900*                   ELIGABLE FOR COST OUTLIER.                *
076000*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
076100*              62 = INVALID NUMBER OF COVERED DAYS            *
076200*              63 = POSSIBLE COST OUTLIER CANDIDATE.          *
076300*              64 = DISPROPORTIONATE SHARE PERCENTAGE AND     *
076400*                   BED-SIZE CONFLICT ON PROVIDER SPECIFIC FILE
076500*              98 = CANNOT PROCESS BILL OLDER THEN 871001     *
076600***************************************************************
076700 01  PPS-DATA.
076800         10  PPS-RTC                PIC 9(02).
076900         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
077000         10  PPS-OUTLIER-DAYS       PIC 9(03).
077100         10  PPS-AVG-LOS            PIC 9(02)V9(01).
077200         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
077300         10  PPS-INDTEACH-ADJ       PIC 9(06)V9(02).
077400         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
077500         10  PPS-HSP-PART           PIC 9(06)V9(02).
077600         10  PPS-FSP-PART           PIC 9(06)V9(02).
077700         10  PPS-OUTLIER-PART       PIC 9(07)V9(02).
077800         10  PPS-REG-DAYS-USED      PIC 9(03).
077900         10  PPS-LTR-DAYS-USED      PIC 9(02).
078000         10  PPS-DSH-ADJ            PIC 9(06)V9(02).
078100         10  PPS-CALC-VERS          PIC X(05).
078200
078300******************************************************************
078400*            THESE ARE THE VERSIONS OF THE PPCAL
078500*           PROGRAMS THAT WILL BE PASSED BACK----
078600*          ASSOCIATED WITH THE BILL BEING PROCESSED
078700******************************************************************
078800 01  PRICER-OPT-VERS-SW.
078900     02  PRICER-OPTION-SW          PIC X(01).
079000         88  ALL-TABLES-PASSED          VALUE 'A'.
079100         88  PROV-RECORD-PASSED         VALUE 'P'.
079200         88  ADDITIONAL-VARIABLES       VALUE 'M'.
079300     02  PPS-VERSIONS.
079400         10  PPDRV-VERSION        PIC X(05).
079500
079600******************************************************************
079700*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
079800*          ASSOCIATED WITH THE BILL BEING PROCESSED
079900******************************************************************
080000 01  PPS-ADDITIONAL-VARIABLES.
080100     05  PPS-HSP-PCT                PIC 9(01)V9(02).
080200     05  PPS-FSP-PCT                PIC 9(01)V9(02).
080300     05  PPS-NAT-PCT                PIC 9(01)V9(02).
080400     05  PPS-REG-PCT                PIC 9(01)V9(02).
080500     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
080600     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
080700     05  PPS-DRG-WT                 PIC 9(02)V9(04).
080800     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
080900     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
081000     05  PPS-REG-LABOR              PIC 9(05)V9(02).
081100     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
081200     05  PPS-COLA                   PIC 9(01)V9(03).
081300     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
081400     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
081500     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
081600     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
081700
081800******************************************************************
081900*               THIS IS THE PROVIDER RECORD
082000*          ASSOCIATED WITH THE BILL BEING PROCESSED
082100******************************************************************
082200 01  PROV-HOLD.
082300     02  PROV-REC-HOLD.
082400         05  P-PROVIDER-NO.
082500             10  P-STATE                PIC 9(02).
082600             10  FILLER                 PIC X(04).
082700         05  P-EFF-DATE.
082800             10  P-EFF-YY               PIC 9(02).
082900             10  P-EFF-MM               PIC 9(02).
083000             10  P-EFF-DD               PIC 9(02).
083100         05  P-WAIVER-CODE              PIC X(01).
083200             88  WAIVER-STATE           VALUE 'Y'.
083300         05  P-PROVIDER-TYPE            PIC X(02).
083400             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.
083500             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.
083600             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
083700             88  REDESIGNATED-RURAL-YR1 VALUE '09'.
083800             88  REDESIGNATED-RURAL-YR2 VALUE '10'.
083900             88  SOLE-COM-REF-CENT      VALUE '11'.
084000             88  MDH-REBASED-FY90       VALUE '14' '15'.
084100             88  MDH-RRC-REBASED-FY90   VALUE '15'.
084200             88  SCH-REBASED-FY90       VALUE '16' '17'.
084300             88  SCH-RRC-REBASED-FY90   VALUE '17'.
084400         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
084500             88  NEW-ENGLAND            VALUE  1.
084600             88  MIDDLE-ATLANTIC        VALUE  2.
084700             88  SOUTH-ATLANTIC         VALUE  3.
084800             88  EAST-NORTH-CENTRAL     VALUE  4.
084900             88  EAST-SOUTH-CENTRAL     VALUE  5.
085000             88  WEST-NORTH-CENTRAL     VALUE  6.
085100             88  WEST-SOUTH-CENTRAL     VALUE  7.
085200             88  MOUNTAIN               VALUE  8.
085300             88  PACIFIC                VALUE  9.
085400         05  P-PPS-BLEND-YEAR           PIC 9(01).
085500             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
085600         05  P-MSA-X.
085700             10  P-RURAL                PIC X(04).
085800                 88  RURAL              VALUE  '9999'.
085900         05  P-MSA-9 REDEFINES P-MSA-X  PIC 9(04).
086000         05  P-FISCAL-YEAR-END.
086100             10  P-MM                   PIC 9(02).
086200             10  P-DD                   PIC 9(02).
086300             10  P-YY                   PIC 9(02).
086400         05  P-VARIABLES.
086500             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
086600             10  P-COLA                 PIC S9(01)V9(03).
086700             10  P-INTERN-RATIO         PIC S9(01)V9(04).
086800             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
086900             10  P-BED-SIZE             PIC  9(05).
087000             10  P-DSH-PERCENT          PIC V9(04).
087100             10  P-CCR                  PIC  9(01)V9(03).
087200             10  P-CMI                  PIC  9(01)V9(04).
087300             10  FILLER                 PIC  9(01).
087400             10  P-REPORT-DATE          PIC  9(06).
087500             10  FILLER                 PIC  9(01).
087600             10  P-INTER-NO             PIC  9(05).
087700     02  FILLER                         PIC X(80).
087800
087900******************************************************************
088000*                   THIS IS THE WAGE-INDEX
088100*          ASSOCIATED WITH THE BILL BEING PROCESSED
088200******************************************************************
088300 01  WAGE-INDEX-RECORD.
088400     05  W-MSA               PIC X(4).
088500     05  W-SIZE              PIC X(01).
088600         88  LARGE-URBAN       VALUE 'L'.
088700         88  OTHER-URBAN       VALUE 'O'.
088800         88  ALL-RURAL         VALUE 'R'.
088900     05  W-EFF-DATE          PIC X(6).
089000     05  FILLER              PIC X.
089100     05  W-INDEX-RECORD      PIC S9(02)V9(04).
089200
089300 PROCEDURE DIVISION  USING BILL-DATA
089400                           PPS-DATA
089500                           PRICER-OPT-VERS-SW
089600                           PPS-ADDITIONAL-VARIABLES
089700                           PROV-HOLD
089800                           WAGE-INDEX-RECORD.
089900
090000***************************************************************
090100*    PROCESSING:                                              *
090200*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
090300*        B. INITIALIZE PPCAL  WORK VARIABLES.                 *
090400*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
090500*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
090600*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
090700*           GOBACK.                                           *
090800*        D. ASSEMBLE PRICING COMPONENTS.                      *
090900*        E. CALCULATE THE BLENDED PRICE.                      *
091000***************************************************************
091100
091200     PERFORM 0200-MAINLINE-CONTROL.
091300
091400     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
091500     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
091600
091700     GOBACK.
091800
091900 0200-MAINLINE-CONTROL.
092000     MOVE ALL '0' TO PPS-DATA.
092100     MOVE ALL '0' TO HOLD-PPS-COMPONENTS.
092200     MOVE ALL '0' TO HOLD-ADDITIONAL-VARIABLES.
092300     PERFORM 1000-EDIT-THE-BILL-INFO.
092400     IF  PPS-RTC = 00
092500         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
092600         PERFORM 3000-CALC-BLENDED-PAYMENT.
092700
092800 1000-EDIT-THE-BILL-INFO.
092900***************************************************************
093000*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
093100*    AND DO NOT ATTEMPT TO PRICE.                             *
093200***************************************************************
093300     MOVE B-DISCHG-YY TO H-BILL-YY.
093400     MOVE B-DISCHG-MM TO H-BILL-MM.
093500     MOVE B-DISCHG-DD TO H-BILL-DD.
093600     IF  PPS-RTC = 00
093700         IF  WAIVER-STATE
093800             MOVE 53 TO PPS-RTC.
093900     IF  PPS-RTC = 00
094000         IF  B-DRG < 001 OR > 490 OR = 469 OR = 470
094100             MOVE 54 TO PPS-RTC.
094200     IF  PPS-RTC = 00
094300         MOVE P-EFF-DATE  TO HOLD-PROV-DATE
094400         MOVE P-FISCAL-YEAR-END TO HOLD-PROV-FYE-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 2000-ASSEMBLE-PPS-VARIABLES.
098500***************************************************************
098600*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
098700*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
098800*    OF THAT VARIABLE.                                        *
098900***************************************************************
099000***  GET THE PROVIDER SPECIFIC VARIABLES.
099100
099200     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
099300     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
099400
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 2400-GET-DRG-WEIGHT VARYING DX1
100300             FROM 1 BY 1 UNTIL DX1 > 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
101800     MOVE 10 TO R4.
101900
102000     IF  P-STATE = 40
102100         MOVE 11 TO R2
102200         MOVE 12 TO R4.
102300
102400     IF  RURAL
102500         MOVE 2 TO R3
102600     ELSE
102700         MOVE 1 TO R3.
102800
102900     IF  REFERRAL-CENTER
103000         MOVE 1 TO R3.
103100
103200     IF HOLD-BILL-DATE > '880331'
103300        PERFORM 2300-GET-LABOR-NLABOR-RATES2 VARYING R1
103400             FROM 1 BY 1 UNTIL R1 > 2
103500     ELSE
103600        PERFORM 2200-GET-LABOR-NLABOR-RATES VARYING R1
103700             FROM 1 BY 1 UNTIL R1 > 2.
103800
103900***************************************************************
104000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
104100
104200     IF  H-FYE-MMDD > '0929'
104300         MOVE 83 TO H-FYE-YY
104400     ELSE
104500         MOVE 84 TO H-FYE-YY.
104600
104700     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30
104800         MOVE 31 TO H-FYE-DD
104900     ELSE
105000     IF  H-FYE-MM = 02 AND H-FYE-DD > 27
105100         MOVE 31 TO H-FYE-DD.
105200
105300     COMPUTE MO-DIFF =
105400         ((H-BILL-YY - 83) * 12 + H-BILL-MM) -
105500         ((H-FYE-YY  - 83) * 12 + H-FYE-MM).
105600
105700     IF  H-BILL-DD > H-FYE-DD
105800         ADD 1 TO MO-DIFF.
105900
106000     IF  MO-DIFF < 13 MOVE 1 TO HSP-FY
106100     ELSE
106200     IF  MO-DIFF < 32 MOVE 2 TO HSP-FY
106300     ELSE
106400     IF  MO-DIFF < 37 MOVE 3 TO HSP-FY
106500     ELSE
106600     IF  MO-DIFF < 49 MOVE 4 TO HSP-FY.
106700
106800     IF  MO-DIFF > 48 AND < 61
106900         MOVE 4 TO HSP-FY
107000         IF  HOLD-BILL-DATE > '871120'
107100             PERFORM 2100-CHECK-HSP-FY5.
107200
107300     IF  MO-DIFF > 60 MOVE 7 TO HSP-FY.
107400
107500     IF  MO-DIFF > 72
107600         MOVE 8 TO HSP-FY.
107700
107800     IF  P-PPS-BLEND-YEAR NUMERIC AND VALID-PPS-BLEND-YEAR
107900         MOVE P-PPS-BLEND-YEAR TO HSP-FY.
108000
108100     IF  HSP-FY < 5
108200         MOVE HSP (HSP-FY) TO H-HSP-PCT
108300         MOVE FSP (HSP-FY) TO H-FSP-PCT
108400     ELSE
108500         MOVE 0.00  TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.
108600
108700     IF  P-STATE = 38
108800         IF HSP-FY = 3
108900            MOVE 0.25  TO H-HSP-PCT MOVE 0.75 TO H-FSP-PCT
109000         ELSE
109100         IF HSP-FY > 3
109200            MOVE 0.00  TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.
109300
109400***************************************************************
109500***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
109600
109700     IF  HOLD-BILL-DATE > '860930' AND < '871121'
109800         MOVE 0.50 TO H-NAT-PCT MOVE 0.50 TO H-REG-PCT
109900     ELSE
110000     IF  HOLD-BILL-DATE > '871120'
110100         MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.
110200
110300     IF  P-STATE = 38
110400             MOVE 1.00 TO H-NAT-PCT MOVE 0.00 TO H-REG-PCT.
110500
110600***************************************************************
110700*    REGIONAL FLOOR
110800
110900     IF  HOLD-BILL-DATE > '880331'
111000         IF  (H-REG-LABOR + H-REG-NLABOR) >
111100             (H-NAT-LABOR + H-NAT-NLABOR)
111200             MOVE 0.85 TO H-NAT-PCT MOVE 0.15 TO H-REG-PCT.
111300
111400     IF  P-STATE = 40
111500         MOVE 0.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT
111600         MOVE 0.25 TO H-NAT-PCT MOVE 0.75 TO H-REG-PCT.
111700
111800     IF  SOLE-COMMUNITY-PROV
111900         MOVE 0.75 TO H-HSP-PCT MOVE 0.25 TO H-FSP-PCT
112000         MOVE 0.00 TO H-NAT-PCT MOVE 1.00 TO H-REG-PCT.
112100
112200     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
112300         MOVE 1.00 TO H-HSP-PCT MOVE 1.00 TO H-FSP-PCT.
112400
112500***************************************************************
112600***  GET THE STANDARD UPDATING FACTOR
112700
112800     MOVE HSP-FY TO U1.
112900     ADD 1 TO U1.
113000     MOVE P-MM TO U2.
113100
113200     IF  H-FYE-MM = 01 AND H-FYE-DD < 16
113300         MOVE 12 TO U2
113400     ELSE
113500     IF  H-FYE-MM = 02 AND H-FYE-DD < 15
113600         MOVE 01 TO U2
113700     ELSE
113800     IF  H-FYE-MM > 02 AND H-FYE-DD < 16
113900         COMPUTE U2 = U2 - 1.
114000
114100     MOVE R3 TO U3.
114200
114300     IF  REFERRAL-CENTER
114400         MOVE 3 TO U3.
114500
114600     IF  U1 > 6
114700         SUBTRACT 6 FROM U1
114800         MOVE UPDATE-FACTOR2 (U1 U2 U3) TO H-UPDATE-FACTOR
114900     ELSE
115000         MOVE UPDATE-FACTOR  (U1 U2)    TO H-UPDATE-FACTOR.
115100
115200***************************************************************
115300***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE
115400
115500     IF  PRUP-UPDT-FACTOR NUMERIC
115600         IF  PRUP-UPDT-FACTOR > 0
115700             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.
115800
115900 2100-CHECK-HSP-FY5.
116000     COMPUTE HOLD-BILL-DAYS =
116100         H-BILL-YY * 365 + T-DAYS (H-BILL-MM) + H-BILL-DD.
116200
116300     IF  (H-BILL-YY = 84 OR 88 OR 92) AND H-BILL-MM > 2
116400         ADD 1 TO HOLD-BILL-DAYS.
116500
116600     IF  H-FYE-MMDD > '0929'
116700         MOVE 87 TO H-FYE-YY
116800     ELSE
116900         MOVE 88 TO H-FYE-YY.
117000
117100     MOVE P-DD TO H-FYE-DD.
117200
117300     COMPUTE HOLD-PROV-DAYS =
117400         H-FYE-YY * 365 + T-DAYS (H-FYE-MM) + H-FYE-DD.
117500
117600     IF  (H-FYE-YY = 84 OR 88 OR 92) AND H-FYE-MM > 2
117700         ADD 1 TO HOLD-PROV-DAYS.
117800
117900     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 51)
118000         MOVE 5 TO HSP-FY.
118100
118200     IF  HOLD-BILL-DAYS > (HOLD-PROV-DAYS + 183)
118300         MOVE 6 TO HSP-FY.
118400
118500 2200-GET-LABOR-NLABOR-RATES.
118600     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
118700         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
118800         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
118900         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
119000         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR
119100         IF REDESIGNATED-RURAL-YR1 OR REDESIGNATED-RURAL-YR2
119200            PERFORM 2250-BLEND-RURAL-RATES.
119300
119400 2250-BLEND-RURAL-RATES.
119500      IF  REDESIGNATED-RURAL-YR1
119600          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3
119700      ELSE
119800          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
119900
120000      COMPUTE H-REG-LABOR  ROUNDED =
120100          (REG-LABOR  (R1 R2 1) - REG-LABOR  (R1 R2 2))
120200            * BLEND-RURAL-PCT   + REG-LABOR  (R1 R2 2).
120300
120400      COMPUTE H-REG-NLABOR ROUNDED =
120500          (REG-NLABOR (R1 R2 1) - REG-NLABOR (R1 R2 2))
120600            * BLEND-RURAL-PCT   + REG-NLABOR (R1 R2 2).
120700
120800      COMPUTE H-NAT-LABOR  ROUNDED =
120900          (REG-LABOR  (R1 R4 1) - REG-LABOR  (R1 R4 2))
121000            * BLEND-RURAL-PCT   + REG-LABOR  (R1 R4 2).
121100
121200      COMPUTE H-NAT-NLABOR ROUNDED =
121300          (REG-NLABOR (R1 R4 1) - REG-NLABOR (R1 R4 2))
121400            * BLEND-RURAL-PCT   + REG-NLABOR (R1 R4 2).
121500
121600 2300-GET-LABOR-NLABOR-RATES2.
121700     IF  LARGE-URBAN
121800         MOVE 1 TO R3
121900     ELSE
122000     IF  OTHER-URBAN OR REFERRAL-CENTER
122100         MOVE 2 TO R3
122200     ELSE
122300         MOVE 3 TO R3.
122400
122500     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE2 (R1)
122600         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR
122700         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NLABOR
122800         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR
122900         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NLABOR
123000         IF REDESIGNATED-RURAL-YR1 OR REDESIGNATED-RURAL-YR2
123100            PERFORM 2350-BLEND-RURAL-RATES2.
123200
123300 2350-BLEND-RURAL-RATES2.
123400      IF  REDESIGNATED-RURAL-YR1
123500          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3
123600      ELSE
123700          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
123800
123900      COMPUTE H-REG-LABOR  ROUNDED =
124000          (REG-LABOR2  (R1 R2 2) - REG-LABOR2  (R1 R2 3))
124100            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R2 3).
124200
124300      COMPUTE H-REG-NLABOR ROUNDED =
124400          (REG-NLABOR2 (R1 R2 2) - REG-NLABOR2 (R1 R2 3))
124500            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R2 3).
124600
124700      COMPUTE H-NAT-LABOR  ROUNDED =
124800          (REG-LABOR2  (R1 R4 2) - REG-LABOR2  (R1 R4 3))
124900            * BLEND-RURAL-PCT   +  REG-LABOR2  (R1 R4 3).
125000
125100      COMPUTE H-NAT-NLABOR ROUNDED =
125200          (REG-NLABOR2 (R1 R4 2) - REG-NLABOR2 (R1 R4 3))
125300            * BLEND-RURAL-PCT   +  REG-NLABOR2 (R1 R4 3).
125400
125500 2400-GET-DRG-WEIGHT.
125600     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX1)
125700         SET DX2 TO B-DRG
125800         MOVE DRG-WT (DX1 DX2)          TO H-DRG-WT
125900         MOVE DRG-ALOS (DX1 DX2)        TO H-ALOS
126000         MOVE DRG-DAYS-CUTOFF (DX1 DX2) TO H-DAYS-CUTOFF.
126100
126200
126300 3000-CALC-BLENDED-PAYMENT.
126400***************************************************************
126500*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
126600*        CALCULATE COVERED DAYS UTILIZATION.                  *
126700*        CALCULATE THE FEDERAL PORTION.                       *
126800*        CALCULATE THE HOSPITAL PORTION.                      *
126900*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
127000*        CALCULATE THE COST-OUTLIER PORTION.                  *
127100*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
127200*        CALCULATE THE INDIRECT TEACHING ADJUSTMENT.          *
127300***************************************************************
127400     PERFORM 3100-CALC-STAY-UTILIZATION.
127500     PERFORM 3300-CALC-FSP-AMT.
127600     PERFORM 3400-CALC-HSP-AMT.
127700     MOVE 00            TO  PPS-RTC.
127800     MOVE H-WAGE-INDX   TO  PPS-WAGE-INDX.
127900     MOVE H-ALOS        TO  PPS-AVG-LOS.
128000     MOVE H-DAYS-CUTOFF TO  PPS-DAYS-CUTOFF.
128100
128200     PERFORM 3600-CALC-OUTLIER.
128300
128400     IF  PAY-AVG-STAY-ONLY
128500         MOVE 0  TO H-OUTLIER-PART
128600         MOVE 04 TO PPS-RTC.
128700
128800     IF  PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST
128900         IF  B-LOS < H-ALOS
129000             IF  NOT (B-DRG = 385 OR 456)
129100                 PERFORM 3500-CALC-PERDIEM-AMT
129200                 MOVE 03 TO PPS-RTC.
129300
129400     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)
129500         IF  H-OUTCST-PART > 0
129600             MOVE H-OUTCST-PART TO H-OUTLIER-PART
129700             MOVE 05 TO PPS-RTC
129800         ELSE
129900         IF  PPS-RTC NOT = 03
130000             MOVE 00 TO PPS-RTC
130100             MOVE 0  TO H-OUTLIER-PART.
130200
130300     IF  PAY-DAYS-OUTLIER
130400         IF  PPS-RTC NOT = 01
130500             MOVE 0  TO H-OUTLIER-PART
130600             MOVE 00 TO PPS-RTC.
130700
130800     IF  PAY-COST-OUTLIER
130900         IF  PPS-RTC = 01
131000             MOVE 0  TO H-OUTLIER-PART
131100             MOVE 60 TO PPS-RTC.
131200
131300     IF  PAY-XFER-NO-COST
131400         MOVE 0  TO H-OUTLIER-PART
131500         MOVE 00 TO PPS-RTC
131600         IF B-LOS < H-ALOS
131700         IF  NOT (B-DRG = 385 OR 456)
131800             PERFORM 3500-CALC-PERDIEM-AMT
131900             MOVE 06 TO PPS-RTC.
132000
132100     IF  PPS-RTC < 50
132200         PERFORM 3800-CALC-BLEND-AMT
132300     ELSE
132400         MOVE 0 TO PPS-HSP-PART
132500                   PPS-FSP-PART
132600                   PPS-OUTLIER-PART
132700                   PPS-OUTLIER-DAYS
132800                   PPS-REG-DAYS-USED
132900                   PPS-LTR-DAYS-USED
133000                   PPS-TOTAL-PAYMENT
133100                   PPS-DSH-ADJ
133200                   PPS-INDTEACH-ADJ.
133300
133400 3100-CALC-STAY-UTILIZATION.
133500     IF  H-REG-DAYS > 0
133600         IF  H-REG-DAYS < H-DAYS-CUTOFF
133700             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
133800             MOVE 0          TO H-REG-DAYS
133900         ELSE
134000             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
134100             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
134200     ELSE
134300     IF  H-LTR-DAYS < H-DAYS-CUTOFF
134400         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
134500         MOVE 0          TO H-LTR-DAYS
134600     ELSE
134700         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
134800         SUBTRACT H-DAYS-CUTOFF  FROM H-LTR-DAYS.
134900
135000     IF  B-LOS > H-DAYS-CUTOFF
135100         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
135200
135300 3200-CALC-OUTLIER-UTILIZATION.
135400     COMPUTE PPS-OUTLIER-DAYS =
135500         B-LOS - H-DAYS-CUTOFF.
135600
135700     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
135800         COMPUTE PPS-OUTLIER-DAYS =
135900             H-REG-DAYS + H-LTR-DAYS
136000         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
136100         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
136200     ELSE
136300     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
136400         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
136500         COMPUTE PPS-LTR-DAYS-USED =
136600             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS - H-REG-DAYS)
136700     ELSE
136800         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
136900
137000     IF  B-REVIEW-CODE = 03 OR 04
137100         IF  PPS-REG-DAYS-USED > 0
137200             MOVE 0 TO PPS-LTR-DAYS-USED.
137300
137400 3300-CALC-FSP-AMT.
137500     COMPUTE H-FSP-PART ROUNDED =
137600         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDX +
137700         H-NAT-NLABOR * H-COLA) * H-DRG-WT)
137800                           +
137900         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDX +
138000         H-REG-NLABOR * H-COLA) * H-DRG-WT).
138100
138200 3400-CALC-HSP-AMT.
138300     COMPUTE H-HSP-PART ROUNDED =
138400         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.
138500
138600 3500-CALC-PERDIEM-AMT.
138700     MOVE B-LOS TO H-COV-DAYS.
138800
138900     IF  H-COV-DAYS = 0
139000         MOVE 1 TO H-COV-DAYS.
139100
139200     COMPUTE H-HSP-PART ROUNDED =
139300        H-HSP-PART / H-ALOS * H-COV-DAYS
139400        ON SIZE ERROR MOVE 0 TO H-HSP-PART.
139500
139600     COMPUTE H-FSP-PART ROUNDED =
139700        H-FSP-PART / H-ALOS * H-COV-DAYS
139800        ON SIZE ERROR MOVE 0 TO H-FSP-PART.
139900
140000 3600-CALC-OUTLIER.
140100     MOVE 0.60 TO H-DAYOUT-PCT H-CSTOUT-PCT.
140200
140300     IF  HOLD-BILL-DATE > '880331'
140400         IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
140500             MOVE 0.90 TO H-DAYOUT-PCT H-CSTOUT-PCT.
140600
140700     MOVE 0.7439   TO H-LABOR-PCT.
140800     MOVE 0.2561   TO H-NLABOR-PCT.
140900     MOVE 0.660    TO H-CSTCHG-RATIO.
141000     MOVE 2.000    TO H-CST-MULTIPLE.
141100     MOVE 14000.00 TO H-CST-THRESH.
141200
141300***********************************************************
141400***  DAY OUTLIER CALCULATION
141500
141600     IF  PPS-OUTLIER-DAYS > 0
141700     COMPUTE H-OUTDAY-PART  =
141800         H-DAYOUT-PCT *  H-FSP-PART / H-ALOS * PPS-OUTLIER-DAYS
141900         ON SIZE ERROR MOVE 0 TO H-OUTDAY-PART.
142000
142100***********************************************************
142200***  COST OUTLIER CALCULATION
142300
142400     COMPUTE H-DOLLAR-THRESHOLD ROUNDED =
142500         (H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDX) +
142600         (H-CST-THRESH * H-NLABOR-PCT * H-COLA).
142700
142800     COMPUTE H-COST-OUTLIER ROUNDED =
142900         H-CST-MULTIPLE * H-FSP-PART.
143000
143100     IF  H-DOLLAR-THRESHOLD > H-COST-OUTLIER
143200         MOVE H-DOLLAR-THRESHOLD TO H-COST-OUTLIER.
143300
143400     PERFORM 3700-CALC-IND-TEACHING.
143500     MOVE 0 TO H-DSH-PERCENT.
143600
143700     IF  P-DSH-PERCENT NUMERIC
143800         MOVE P-DSH-PERCENT TO H-DSH-PERCENT.
143900
144000     COMPUTE H-BILL-COSTS ROUNDED =
144100         B-CHARGES-CLAIMED * H-CSTCHG-RATIO /
144200         (1 + H-IND-TEACHING + H-DSH-PERCENT)
144300         ON SIZE ERROR MOVE 0 TO H-BILL-COSTS.
144400
144500     IF  H-BILL-COSTS > H-COST-OUTLIER
144600         COMPUTE H-OUTCST-PART =
144700         H-CSTOUT-PCT * (H-BILL-COSTS - H-COST-OUTLIER).
144800
144900     IF  PAY-WITHOUT-COST
145000         MOVE 0 TO H-OUTCST-PART.
145100
145200***********************************************************
145300***  DAY OUTLIER PRECEDENCE
145400
145500     IF  HOLD-BILL-DATE < '881101'
145600         IF  H-OUTDAY-PART > 0 OR H-OUTCST-PART > 0
145700             IF  H-OUTDAY-PART > 0
145800                 MOVE H-OUTDAY-PART TO H-OUTLIER-PART
145900                 MOVE 01 TO PPS-RTC
146000             ELSE
146100                 MOVE H-OUTCST-PART TO H-OUTLIER-PART
146200                 MOVE 02 TO PPS-RTC.
146300
146400
146500 3700-CALC-IND-TEACHING.
146600
146700         COMPUTE H-IND-TEACHING =
146800             2.0 * ((1 + H-INTERN-RATIO) ** .405  - 1).
146900
147000 3800-CALC-BLEND-AMT.
147100     IF  H-CMI-ADJ-CPD = 0
147200         MOVE 0.00 TO H-HSP-PCT
147300         MOVE 1.00 TO H-FSP-PCT.
147400
147500     COMPUTE PPS-HSP-PART ROUNDED =
147600         H-HSP-PCT * H-HSP-PART.
147700
147800     COMPUTE PPS-FSP-PART ROUNDED =
147900         H-FSP-PCT * H-FSP-PART.
148000
148100     COMPUTE PPS-OUTLIER-PART ROUNDED =
148200             H-FSP-PCT * H-OUTLIER-PART.
148300
148400     MOVE ZERO TO PPS-DSH-ADJ.
148500
148600     IF  P-DSH-PERCENT NUMERIC
148700             COMPUTE PPS-DSH-ADJ ROUNDED =
148800             (PPS-FSP-PART + PPS-OUTLIER-PART) * P-DSH-PERCENT.
148900
149000     PERFORM 3700-CALC-IND-TEACHING.
149100
149200     COMPUTE PPS-INDTEACH-ADJ ROUNDED =
149300         (PPS-FSP-PART + PPS-OUTLIER-PART) * H-IND-TEACHING.
149400
149500     COMPUTE PPS-TOTAL-PAYMENT =
149600             PPS-HSP-PART     + PPS-FSP-PART +
149700             PPS-OUTLIER-PART + PPS-DSH-ADJ.
149800
149900******        L A S T   S O U R C E   S T A T E M E N T   *****
