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