000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL926.
000300*AUTHOR.              DDS TEAM.
000400*REMARKS.         MODIFIED BY DDS TEAM.
000500*                        HCFA.
000600*            CAPITAL ADDED FOR OCTOBER 01,1991.
000700 DATE-COMPILED.
000800 ENVIRONMENT DIVISION.
000900 CONFIGURATION SECTION.
001000 SOURCE-COMPUTER.            IBM-370.
001100 OBJECT-COMPUTER.            IBM-370.
001200 INPUT-OUTPUT  SECTION.
001300 FILE-CONTROL.
001400
001500 DATA DIVISION.
001600 FILE SECTION.
001700
001800 WORKING-STORAGE SECTION.
001900 77  PAN-VALET PICTURE X(24) VALUE '001PPCAL926  09/22/93'.
002000 01  W-STORAGE-REF                  PIC X(46)  VALUE
002100     'PPCAL926 - WORKING   STORAGE'.
002200 01  CAL-VERSION                    PIC X(05)  VALUE 'C92.6'.
002300 01  R1                             PIC S9(04) COMP SYNC.
002400 01  R2                             PIC S9(04) COMP SYNC.
002500 01  R3                             PIC S9(04) COMP SYNC.
002600 01  R4                             PIC S9(04) COMP SYNC.
002700 01  U1                             PIC S9(04) COMP SYNC.
002800 01  U2                             PIC S9(04) COMP SYNC.
002900 01  U3                             PIC S9(04) COMP SYNC.
003000 01  BLEND-RURAL-PCT                PIC V9(09) COMP SYNC.
003100 01  MO-DIFF                        PIC  9(03).
003200
003300***************************************************************
003400*    LAYUP TABLE AREA                                         *
003500***************************************************************
003600 01  RATE-TABLE.
003700     02  RATE-WORK.
003800*RATE 910101 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
003900         05  FILLER PIC X(06) VALUE '910101'.
004000         05  NE01   PIC X(45) VALUE
004100            ' 0260503 106716 0256378 105026 0269937 093096'.
004200         05  MA02   PIC X(45) VALUE
004300            ' 0234038 101101 0230333 099500 0258518 088007'.
004400         05  SA03   PIC X(45) VALUE
004500            ' 0249828 093305 0245872 091828 0247132 076314'.
004600         05  ENS04  PIC X(45) VALUE
004700            ' 0263508 110396 0259336 108648 0250254 084817'.
004800         05  ESC05  PIC X(45) VALUE
004900            ' 0239766 084486 0235969 083149 0244934 071164'.
005000         05  WNC06  PIC X(45) VALUE
005100            ' 0249899 100589 0245943 098996 0238058 076028'.
005200         05  WSC07  PIC X(45) VALUE
005300            ' 0248461 092673 0244527 091207 0228307 069919'.
005400         05  MNT08  PIC X(45) VALUE
005500            ' 0239676 099266 0235882 097694 0230879 080417'.
005600         05  PAC09  PIC X(45) VALUE
005700            ' 0233139 113390 0229448 111595 0224550 090593'.
005800         05  NTL10  PIC X(45) VALUE
005900            ' 0248060 102198 0244133 100580 0243474 078443'.
006000         05  PR11   PIC X(45) VALUE
006100            ' 0223104 046400 0219571 045665 0165958 035777'.
006200         05  NPR12  PIC X(45) VALUE
006300            ' 0245471 095600 0245471 095600 0245471 095600'.
006400*RATE 911001 REGION-NATION/LURBAN-OURBAN-RURAL/LABOR-NLABOR
006500         05  FILLER PIC X(06) VALUE '911001'.
006600         05  FILLER PIC X(45) VALUE
006700            ' 0265355 108704 0261153 106982 0280971 096901'.
006800         05  FILLER PIC X(45) VALUE
006900            ' 0238396 102984 0234623 101354 0269086 091604'.
007000         05  FILLER PIC X(45) VALUE
007100            ' 0254481 095043 0250452 093539 0257234 079433'.
007200         05  FILLER PIC X(45) VALUE
007300            ' 0268415 112451 0264165 110671 0260484 088284'.
007400         05  FILLER PIC X(45) VALUE
007500            ' 0244231 086059 0240364 084698 0254945 074073'.
007600         05  FILLER PIC X(45) VALUE
007700            ' 0254553 102463 0250523 100840 0247788 079136'.
007800         05  FILLER PIC X(45) VALUE
007900            ' 0253088 094399 0249081 092905 0237639 072778'.
008000         05  FILLER PIC X(45) VALUE
008100            ' 0244140 101114 0240275 099513 0240317 083703'.
008200         05  FILLER PIC X(45) VALUE
008300            ' 0237481 115502 0233721 113673 0233728 094297'.
008400         05  FILLER PIC X(45) VALUE
008500            ' 0252680 104101 0248680 102454 0253426 081650'.
008600         05  FILLER PIC X(45) VALUE
008700            ' 0227259 047264 0223661 046516 0172742 037239'.
008800         05  FILLER PIC X(45) VALUE
008900            ' 0251414 097822 0251414 097822 0251414 097822'.
009000     02  RATE-TAB REDEFINES RATE-WORK.
009100         05  RATE-PERIOD            OCCURS 2.
009200             10  RATE-EFF-DATE      PIC X(06).
009300             10  REG-NAT            OCCURS 12.
009400                 15  R-URBAN-RURAL  OCCURS 3.
009500                     20  FILLER     PIC X(01).
009600                     20  REG-LABOR  PIC 9(05)V9(02).
009700                     20  FILLER     PIC X(01).
009800                     20  REG-NLABOR PIC 9(04)V9(02).
009900
010000 01  UPDT-TABLE.
010100     02  UPDT-WORK.
010200*UPDT 900101 UPDATING FACTORS EFFECTIVE DATE
010300*     LURBAN=1.0562 OURBAN=1.0497 RURAL=1.0972 (JAN - SEP)
010400     05  FILLER PIC X(06) VALUE '900101'.
010500     05  FILLER PIC X(27) VALUE '830131 134318 132191 142277'.
010600     05  FILLER PIC X(27) VALUE '830228 134453 132325 142422'.
010700     05  FILLER PIC X(27) VALUE '830331 134587 132456 142564'.
010800     05  FILLER PIC X(27) VALUE '830430 134725 132592 142710'.
010900     05  FILLER PIC X(27) VALUE '830531 134861 132725 142853'.
011000     05  FILLER PIC X(27) VALUE '830630 134998 132861 142999'.
011100     05  FILLER PIC X(27) VALUE '830731 135134 132995 143143'.
011200     05  FILLER PIC X(27) VALUE '830831 135270 133128 143288'.
011300     05  FILLER PIC X(27) VALUE '820930 135106 132968 143113'.
011400     05  FILLER PIC X(27) VALUE '821031 134799 132664 142787'.
011500     05  FILLER PIC X(27) VALUE '821130 134488 132359 142459'.
011600     05  FILLER PIC X(27) VALUE '821231 134180 132054 142131'.
011700     02  UPDATE-TABLE REDEFINES UPDT-WORK.
011800     05  UPDT-PERIOD             OCCURS 1.
011900         10  UPDT-EFF-DATE       PIC X(06).
012000         10  UPDT-MONTH          OCCURS 12.
012100             15  UP-BASE-DATE    PIC X(06).
012200             15  UP-L-O-R        OCCURS 3.
012300                 20  FILLER           PIC X(01).
012400                 20  UPDATE-FACTOR   PIC 9(01)V9(05).
012500
012600 01  DRG-TABLE.
012700     05  D-TAB.
012800         10  FILLER                  PIC X(06) VALUE
012900        '911001'.
013000         10  DRG-001-004             PIC X(44) VALUE
013100        '03363712244033233113430288301274502457709942'.
013200         10  DRG-005-008             PIC X(44) VALUE
013300        '01524105535004868019170271851164400773003035'.
013400         10  DRG-009-012             PIC X(44) VALUE
013500        '01293307139012834077400075450443600937206939'.
013600         10  FILLER                  PIC X(44) VALUE
013700        '00852406739012173072390065240413301082406639'.
013800         10  FILLER                  PIC X(44) VALUE
013900        '00633104436008971059380057350393601934808540'.
014000         10  FILLER                  PIC X(44) VALUE
014100        '01468507539007190044350087150443600979205337'.
014200         10  FILLER                  PIC X(44) VALUE
014300        '00525203528008281034310135660433601237105938'.
014400         10  FILLER                  PIC X(44) VALUE
014500        '00552503235003496020170071390433600414502625'.
014600         10  FILLER                  PIC X(44) VALUE
014700        '00242701609011524059380056480373600643402112'.
014800         10  FILLER                  PIC X(44) VALUE
014900        '00795102935003532021160047320150800510102023'.
015000         10  FILLER                  PIC X(44) VALUE
015100        '00361301607006162021150035790362500611905536'.
015200         10  FILLER                  PIC X(44) VALUE
015300        '00593803530006709041360039230273100396902930'.
015400         10  FILLER                  PIC X(44) VALUE
015500        '02279007039006625022140058710201800745102422'.
015600         10  FILLER                  PIC X(44) VALUE
015700        '00659001920006806032220051340161400544401815'.
015800         10  FILLER                  PIC X(44) VALUE
015900        '00850103435003060015040040710151000258401504'.
016000         10  FILLER                  PIC X(44) VALUE
016100        '00806502535003052013050105950383601119005237'.
016200         10  FILLER                  PIC X(44) VALUE
016300        '00472703323004606033240087080423200727705033'.
016400         10  FILLER                  PIC X(44) VALUE
016500        '00515603923005295032320081970483700574103435'.
016600         10  FILLER                  PIC X(44) VALUE
016700        '00750004136003386021200300631154402380410643'.
016800         10  FILLER                  PIC X(44) VALUE
016900        '01028904536014273087410178130924101006606739'.
017000         10  FILLER                  PIC X(44) VALUE
017100        '01089906138012453067390096060623800492003732'.
017200         10  FILLER                  PIC X(44) VALUE
017300        '01164306839006834043360138510603800994205938'.
017400         10  FILLER                  PIC X(44) VALUE
017500        '01165807139007282054300078460423601199706939'.
017600         10  FILLER                  PIC X(44) VALUE
017700        '00802805237012472071390061080443500945705935'.
017800         10  FILLER                  PIC X(44) VALUE
017900        '00645004626008262055370079620413600498302618'.
018000         10  FILLER                  PIC X(44) VALUE
018100        '00923205137005272033301403232525708257518150'.
018200         10  FILLER                  PIC X(44) VALUE
018300        '06158112745054470136460496161134305960012745'.
018400         10  FILLER                  PIC X(44) VALUE
018500        '00000000000042703103420239800754002016304837'.
018600         10  FILLER                  PIC X(44) VALUE
018700        '02692514346015499090410367951194402497305738'.
018800         10  FILLER                  PIC X(44) VALUE
018900        '01274303736016957028350093790353602073607439'.
019000         10  FILLER                  PIC X(44) VALUE
019100        '01621008240011667060380139200303501197304236'.
019200         10  FILLER                  PIC X(44) VALUE
019300        '00738702222028874163480100700603800790607433'.
019400         10  FILLER                  PIC X(44) VALUE
019500        '01255102434009118061380058820453700731204036'.
019600         10  FILLER                  PIC X(44) VALUE
019700        '00534203026005663039300087700493700543403227'.
019800         10  FILLER                  PIC X(44) VALUE
019900        '00623903335008211045360051490312300622603725'.
020000         10  FILLER                  PIC X(44) VALUE
020100        '00695004335005006031220051180271801088805237'.
020200         10  FILLER                  PIC X(44) VALUE
020300        '00645403434025777124440163010903403180413546'.
020400         10  FILLER                  PIC X(44) VALUE
020500        '01544308929025069114430120420673901725508741'.
020600         10  FILLER                  PIC X(44) VALUE
020700        '01053406728041746143460154720774000828106038'.
020800         10  FILLER                  PIC X(44) VALUE
020900        '00937204637004909025180107010493700615602920'.
021000         10  FILLER                  PIC X(44) VALUE
021100        '00738203234004476018110066120403302173309842'.
021200         10  FILLER                  PIC X(44) VALUE
021300        '01256206925012931061350075970401501060103836'.
021400         10  FILLER                  PIC X(44) VALUE
021500        '00540602017027582111430113030533701254907039'.
021600         10  FILLER                  PIC X(44) VALUE
021700        '00621803636009735055370057230382301023505938'.
021800         10  FILLER                  PIC X(44) VALUE
021900        '00784005132005656038220111410713900921605838'.
022000         10  FILLER                  PIC X(44) VALUE
022100        '00498803826007599049370051980352500512502718'.
022200         10  FILLER                  PIC X(44) VALUE
022300        '00776604336004062029230050940232600984605237'.
022400         10  FILLER                  PIC X(44) VALUE
022500        '00469702830007555042360444121554801737908541'.
022600         10  FILLER                  PIC X(44) VALUE
022700        '03027514046016189088410220991064301354707628'.
022800         10  FILLER                  PIC X(44) VALUE
022900        '01687207840009076045250240491194402796009441'.
023000         10  FILLER                  PIC X(44) VALUE
023100        '02303408841012231072390117840683901087006138'.
023200         10  FILLER                  PIC X(44) VALUE
023300        '01240206739006029037360097320553700553203326'.
023400         10  FILLER                  PIC X(44) VALUE
023500        '02379510136019386114430137470903600913904036'.
023600         10  FILLER                  PIC X(44) VALUE
023700        '01747109441018748089410111560583302032110142'.
023800         10  FILLER                  PIC X(44) VALUE
023900        '03164114146014112072390089770462900913005337'.
024000         10  FILLER                  PIC X(44) VALUE
024100        '01835007740009721039360080440332500630602515'.
024200         10  FILLER                  PIC X(44) VALUE
024300        '00782503335013613061380067910292500801502628'.
024400         10  FILLER                  PIC X(44) VALUE
024500        '00540301916009278041360108170403601244804036'.
024600         10  FILLER                  PIC X(44) VALUE
024700        '01987309041010365046370109740743900842806639'.
024800         10  FILLER                  PIC X(44) VALUE
024900        '00558304436015884106430102690754001148607139'.
025000         10  FILLER                  PIC X(44) VALUE
025100        '00570404536012558082400066720503700766505437'.
025200         10  FILLER                  PIC X(44) VALUE
025300        '00543404036005872044360054450363600667304637'.
025400         10  FILLER                  PIC X(44) VALUE
025500        '00715604336007021045370042910252400345401815'.
025600         10  FILLER                  PIC X(44) VALUE
025700        '00788505838004238035350045820293500640903836'.
025800         10  FILLER                  PIC X(44) VALUE
025900        '00902404624007057036150090730403600572002414'.
026000         10  FILLER                  PIC X(44) VALUE
026100        '00674902215004944019180268661524701298208641'.
026200         10  FILLER                  PIC X(44) VALUE
026300        '01386006138006814030350059220273500719402534'.
026400         10  FILLER                  PIC X(44) VALUE
026500        '01660008140006551029350124800884101078907439'.
026600         10  FILLER                  PIC X(44) VALUE
026700        '00657505437011312066390058700333500573103736'.
026800         10  FILLER                  PIC X(44) VALUE
026900        '00919807039006129053300072780422400663904637'.
027000         10  FILLER                  PIC X(44) VALUE
027100        '00416703130003383022190073500523700441003634'.
027200         10  FILLER                  PIC X(44) VALUE
027300        '02721015147024320095410225331344501881006939'.
027400         10  FILLER                  PIC X(44) VALUE
027500        '01007904036007491028170044160170802838712144'.
027600         10  FILLER                  PIC X(44) VALUE
027700        '01152805537007516058380074000443600937806038'.
027800         10  FILLER                  PIC X(44) VALUE
027900        '00530304031005396027300085980483701119106939'.
028000         10  FILLER                  PIC X(44) VALUE
028100        '00592304136038891139460266451154302398610142'.
028200         10  FILLER                  PIC X(44) VALUE
028300        '01182105337012922069390071000402301434106438'.
028400         10  FILLER                  PIC X(44) VALUE
028500        '00737503231008792039360051820231600817403836'.
028600         10  FILLER                  PIC X(44) VALUE
028700        '00460702117004271023260210270703901281406338'.
028800         10  FILLER                  PIC X(44) VALUE
028900        '00482502533010908060380054550263201000206739'.
029000         10  FILLER                  PIC X(44) VALUE
029100        '00634604928006334046350074220303200389802114'.
029200         10  FILLER                  PIC X(44) VALUE
029300        '00667304336004219029250054440313200614303636'.
029400         10  FILLER                  PIC X(44) VALUE
029500        '00397802018002754016090095660533700534003035'.
029600         10  FILLER                  PIC X(44) VALUE
029700        '00909404837017509089320135740742100900505026'.
029800         10  FILLER                  PIC X(44) VALUE
029900        '00616303713007776029350063820253500428302413'.
030000         10  FILLER                  PIC X(44) VALUE
030100        '00961503325005955025350037420170601049204436'.
030200         10  FILLER                  PIC X(44) VALUE
030300        '00726303335009609058380050160273500670903936'.
030400         10  FILLER                  PIC X(44) VALUE
030500        '00404902320006731049280032930130500583803335'.
030600         10  FILLER                  PIC X(44) VALUE
030700        '02059010142013909072330085620501300707604117'.
030800         10  FILLER                  PIC X(44) VALUE
030900        '02216710242011104060230078230461200775704130'.
031000         10  FILLER                  PIC X(44) VALUE
031100        '00851203335004921014050064400312800529502528'.
031200         10  FILLER                  PIC X(44) VALUE
031300        '01687807439011681066390049530293500923306038'.
031400         10  FILLER                  PIC X(44) VALUE
031500        '00527403235010237058370064560411100523503330'.
031600         10  FILLER                  PIC X(44) VALUE
031700        '00316902108005045025090067350442900376402523'.
031800         10  FILLER                  PIC X(44) VALUE
031900        '01027803135007532039140028920211600272001409'.
032000         10  FILLER                  PIC X(44) VALUE
032100        '00382701611001251012050039340333100302702221'.
032200         10  FILLER                  PIC X(44) VALUE
032300        '01208401834036039179500180461334501143108641'.
032400         10  FILLER                  PIC X(44) VALUE
032500        '01384606138008422041360021910311103291211644'.
032600         10  FILLER                  PIC X(44) VALUE
032700        '01502209141015719057380076790463700524602434'.
032800         10  FILLER                  PIC X(44) VALUE
032900        '01212805537012080066390066610403602598509541'.
033000         10  FILLER                  PIC X(44) VALUE
033100        '02251010342008701036360161250814000728203936'.
033200         10  FILLER                  PIC X(44) VALUE
033300        '01028104937026566109430115190533701104604336'.
033400         10  FILLER                  PIC X(44) VALUE
033500        '01009406438005540028190045690263300421602121'.
033600         10  FILLER                  PIC X(44) VALUE
033700        '01329907540007231043360360421494701530807540'.
033800         10  FILLER                  PIC X(44) VALUE
033900        '01031505137009585065390095480583800648404530'.
034000         10  FILLER                  PIC X(44) VALUE
034100        '00666704432005916040330162400824002369512645'.
034200         10  FILLER                  PIC X(44) VALUE
034300        '00711304737006241055370060280523700783106639'.
034400         10  FILLER                  PIC X(44) VALUE
034500        '00934207640009074088410073550613800696004336'.
034600         10  FILLER                  PIC X(44) VALUE
034700        '00375403135007689056380051410473701078216448'.
034800         10  FILLER                  PIC X(44) VALUE
034900        '01177515147000000000000152670653801849208440'.
035000         10  FILLER                  PIC X(44) VALUE
035100        '00687202427019377062380075950273200756605237'.
035200         10  FILLER                  PIC X(44) VALUE
035300        '00491103630004738024220047760262400342802917'.
035400         10  FILLER                  PIC X(44) VALUE
035500        '00786704236004428025250051260211700818404236'.
035600         10  FILLER                  PIC X(44) VALUE
035700        '00417702825009096044360041870252502019805638'.
035800         10  FILLER                  PIC X(44) VALUE
035900        '01673103035039835163480196371054301043506438'.
036000         10  FILLER                  PIC X(44) VALUE
036100        '00826802534018346142460072970503700449503128'.
036200         10  FILLER                  PIC X(44) VALUE
036300        '00370601919005693026350043030253503423813345'.
036400         10  FILLER                  PIC X(44) VALUE
036500        '00000000000000000000000396231334513956322855'.
036600         10  FILLER                  PIC X(44) VALUE
036700        '03338109842000000000000360940984202217514346'.
036800         10  FILLER                  PIC X(44) VALUE
036900        '01433806138022177072390132590443622821336669'.
037000         10  FILLER                  PIC X(44) VALUE
037100        '15289037870031795135451415063997206259914546'.
037200         10  FILLER                  PIC X(44) VALUE
037300        '03063213746052491111430182180764004310617049'.
037400         10  FILLER                  PIC X(44) VALUE
037500        '01979009642011904054370156330583302573708340'.
037600     05  DRGX-TAB REDEFINES D-TAB.
037700         10  DRGX-PERIOD               OCCURS 1
037800                                        INDEXED BY DX5.
037900             15  DRGX-EFF-DATE         PIC X(06).
038000             15  DRG-DATA              OCCURS 492
038100                                        INDEXED BY DX6.
038200                 20  DRG-WT            PIC 9(02)V9(04).
038300                 20  DRG-ALOS          PIC 9(02)V9(01).
038400                 20  DRG-DAYS-TRIM     PIC 9(02).
038500
038600 01  HOLD-AREA.
038700     02  HOLD-DATES.
038800         05  HOLD-BILL-DATE.
038900             10  H-BILL-YY                PIC 9(02).
039000             10  H-BILL-MM                PIC 9(02).
039100             10  H-BILL-DD                PIC 9(02).
039200
039300         05  HOLD-FY-BEGIN-DATE.
039400             10  H-FY-BEGIN-YY            PIC 9(02).
039500             10  H-FY-BEGIN-MM            PIC 9(02).
039600             10  H-FY-BEGIN-DD            PIC 9(02).
039700
039800         05  HOLD-PROV-FYE-DATE.
039900             10  H-FYE-YY                 PIC 9(02).
040000             10  H-FYE-MMDD.
040100                 15  H-FYE-MM             PIC 9(02).
040200                 15  H-FYE-DD             PIC 9(02).
040300
040400     02  HOLD-PPS-COMPONENTS.
040500         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
040600         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
040700
040800         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
040900         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
041000
041100         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
041200         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
041300
041400         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
041500         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
041600
041700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
041800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
041900
042000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
042100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
042200
042300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
042400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
042500
042600         05  H-OPER-DSH                   PIC 9(01)V9(04).
042700         05  H-CAPI-DSH                   PIC 9(01)V9(04).
042800
042900         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
043000         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
043100         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
043200         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
043300         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
043400         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
043500         05  H-CAPI-COLA                  PIC 9(01)V9(03).
043600         05  H-CAPI-SCH                   PIC 9(05)V9(02).
043700         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
043800         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
043900         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
044000         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
044100         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
044200         05  H-CAPI-GAF                   PIC 9(05)V9(04).
044300         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
044400         05  H-COV-DAYS                   PIC 9(3).
044500         05  H-REG-DAYS                   PIC 9(3).
044600         05  H-LTR-DAYS                   PIC 9(3).
044700         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
044800         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
044900         05  H-ALOS                       PIC 9(02)V9(01).
045000         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
045100         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
045200         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
045300         05  H-CST-MULTIPLE               PIC 9(01)V9(03).
045400         05  H-CST-THRESH                 PIC 9(05)V9(02).
045500         05  H-LABOR-PCT                  PIC 9(01)V9(04).
045600         05  H-NLABOR-PCT                 PIC 9(01)V9(04).
045700         05  H-HSP-RATE                   PIC 9(06)V9(09).
045800         05  H-FSP-RATE                   PIC 9(06)V9(09).
045900         05  H-OUTLIER-FACT               PIC 9(01)V9(06).
046000         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
046100         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
046200
046300
046400     02  HOLD-ADDITIONAL-VARIABLES.
046500         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
046600         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
046700         05  H-NAT-PCT                    PIC 9(01)V9(02).
046800         05  H-REG-PCT                    PIC 9(01)V9(02).
046900         05  H-CMI-ADJ-CPD                PIC 9(05)V9(02).
047000         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
047100         05  H-DRG-WT                     PIC 9(02)V9(04).
047200         05  H-NAT-LABOR                  PIC 9(05)V9(02).
047300         05  H-NAT-NLABOR                 PIC 9(05)V9(02).
047400         05  H-REG-LABOR                  PIC 9(05)V9(02).
047500         05  H-REG-NLABOR                 PIC 9(05)V9(02).
047600         05  H-OPER-COLA                  PIC 9(01)V9(03).
047700         05  H-INTERN-RATIO               PIC 9(01)V9(04).
047800         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
047900         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
048000         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
048100
048200     02  HOLD-CAPITAL-VARIABLES.
048300         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
048400         05  H-CAPI-HSP                   PIC 9(07)V9(02).
048500         05  H-CAPI-FSP                   PIC 9(07)V9(02).
048600         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
048700         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
048800         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
048900         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
049000         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
049100
049200 LINKAGE SECTION.
049300***************************************************************
049400*                 * * * * * * * * *                           *
049500*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
049600*    IN HOW TO PAY THE BILL.                                  *
049700*         REVIEW-CODE:                                        *
049800*            00 = PAY-WITH-OUTLIER.                           *
049900*                 WILL CALCULATE THE STANDARD PAYMENT.        *
050000*                 WILL ALSO ATTEMPT TO PAY DAY AND COST       *
050100*                 OUTLIERS. PPS-RTC CODES 01 AND 02 NOW SENT  *
050200*                 TO THE PRO FOR POST PAYMENT REVIEW.       . *
050300*            01 = PAY-DAYS-OUTLIER.                           *
050400*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
050500*                 ALSO CALCULATE THE DAY OUTLIER PORTION OF   *
050600*                 THE PAYMENT IF THE COVERED DAYS EXCEED THE  *
050700*                 OUTLIER CUTOFF FOR THE DRG.                 *
050800*            02 = PAY-COST-OUTLIER.                           *
050900*                 WILL CALCULATE THE STANDARD PAYMENT. WILL   *
051000*                 ALSO CALCULATE THE COST OUTLIER PORTION OF  *
051100*                 THE PAYMENT IF THE ADJUSTED CHARGES ON THE  *
051200*                 BILL EXCEED THE COST THRESHOLD.             *
051300*                 IF  LENGTH OF STAY EXCEED OUTLIER CUTOFF, NO*
051400*                 PAYMENT WILL BE MADE AND A RETURN-CODE OF   *
051500*                 60 WILL BE RETURNED.                        *
051600*            03 = PAY-PERDIEM-DAYS.                           *
051700*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
051800*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
051900*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
052000*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
052100*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
052200*                 STANDARD PAYMENT IS CALCULATED.             *
052300*                 TRANSFERS AFTER 093084 POTENTIALLY          *
052400*                 ELIGABLE FOR COST OUTLIER PAYMENT.          *
052500*            04 = PAY-AVG-STAY-ONLY.                          *
052600*                 WILL CALCULATE THE STANDARD PAYMENT.        *
052700*                 WILL NOT TEST FOR DAYS OR COST OUTLIERS.    *
052800*            05 = PAY-XFER-WITH-COST                          *
052900*                 PAY TRANSFER WITH COST OUTLIER APPROVED.    *
053000*            06 = PAY-XFER-NO-COST                            *
053100*                 PAY TRANSFER WITH COST OUTLIER DENIED.      *
053200*            07 = PAY-WITHOUT-COST                            *
053300*                 PAY WITHOUT COST OUTLIER.                   *
053400*                                                             *
053500***************************************************************
053600 01  BILL-DATA.
053700         10  B-PROVIDER-NO          PIC X(06).
053800         10  B-REVIEW-CODE          PIC 9(02).
053900             88  VALID-REVIEW-CODE  VALUE 00 THRU 07.
054000             88  PAY-WITH-OUTLIER   VALUE 00 07.
054100             88  PAY-DAYS-OUTLIER   VALUE 01.
054200             88  PAY-COST-OUTLIER   VALUE 02.
054300             88  PAY-PERDIEM-DAYS   VALUE 03.
054400             88  PAY-AVG-STAY-ONLY  VALUE 04.
054500             88  PAY-XFER-WITH-COST VALUE 05.
054600             88  PAY-XFER-NO-COST   VALUE 06.
054700             88  PAY-WITHOUT-COST   VALUE 07.
054800         10  B-DRG                  PIC 9(03).
054900         10  B-LOS                  PIC 9(03).
055000         10  B-COVERED-DAYS         PIC 9(03).
055100         10  B-LTR-DAYS             PIC 9(02).
055200         10  B-DISCHARGE-DATE.
055300             15  B-DISCHG-MM        PIC 9(02).
055400             15  B-DISCHG-DD        PIC 9(02).
055500             15  B-DISCHG-YY        PIC 9(02).
055600         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
055700
055800***************************************************************
055900*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
056000*    AND PASSED BACK TO THE CALLING PROGRAM                   *
056100*            RETURN CODE VALUES (PPS-RTC)                     *
056200*                                                             *
056300*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
056400*              00 = PAID NORMAL DRG PAYMENT                   *
056500*                                                             *
056600*              01 = PAID AS A DAY-OUTLIER. SEND TO PRO FOR    *
056700*                   POST PAYMENT REVIEW.                      *
056800*              02 = PAID AS A COST-OUTLIER. SEND TO PRO FOR   *
056900*                   POST PAYMENT REVIEW.                      *
057000*              03 = PAID ON PERDIEM BASIS (XFER OR REVIEW 03) *
057100*                   NOT POTENTIALLY ELIGEABLE FOR COST OUTLIER*
057200*              04 = PAID NORMAL DRG PAYMENT ONLY. DAY AND     *
057300*                   COST OUTLIER CRITERIA IGNORED.            *
057400*              05 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
057500*                   OUTLIER APPROVED.                         *
057600*              06 = PAID TRANSFER ON PERDIEM BASIS WITH COST  *
057700*                   OUTLIER DENIED.                           *
057800*                                                             *
057900*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
058000*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
058100*              52 = INVALID MSA # IN PROVIDER FILE            *
058200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
058300*              54 = DRG < 001 OR > 492, OR = 109 OR = 438     *
058400*                                       OR = 469 OR = 470     *
058500*                                       OR = 474              *
058600*              55 = DISCHARGE DATE < PROVIDER PPS START DATE  *
058700*              56 = INVALID LENGTH OF STAY                    *
058800*              57 = REVIEW CODE INVALID (NOT 00 - 07)         *
058900*              58 = TOTAL CHARGES NOT NUMERIC                 *
059000*              59 = POSSIBLE DAY OUTLIER CANDIDATE            *
059100*              60 = REVIEW CODE 02 (POSSIBLE COST OUTLIER)    *
059200*                   AND POSSIBLE DAY OUTLIER CANDIDATE. NOT   *
059300*                   ELIGABLE FOR COST OUTLIER.                *
059400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
059500*              62 = INVALID NUMBER OF COVERED DAYS            *
059600*              63 = POSSIBLE COST OUTLIER CANDIDATE.          *
059700*              64 = DISPROPORTIONATE SHARE PERCENTAGE AND     *
059800*                   BED-SIZE CONFLICT ON PROVIDER SPECIFIC FILE
059900*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
060000*                   SPECIFIC FILE FOR CAPITAL                 *
060100*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
060200***************************************************************
060300 01  PPS-DATA.
060400         10  PPS-RTC                PIC 9(02).
060500         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
060600         10  PPS-OUTLIER-DAYS       PIC 9(03).
060700         10  PPS-AVG-LOS            PIC 9(02)V9(01).
060800         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
060900         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
061000         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
061100         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
061200         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
061300         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
061400         10  PPS-REG-DAYS-USED      PIC 9(03).
061500         10  PPS-LTR-DAYS-USED      PIC 9(02).
061600         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
061700         10  PPS-CALC-VERS          PIC X(05).
061800
061900******************************************************************
062000*            THESE ARE THE VERSIONS OF THE PPCAL
062100*           PROGRAMS THAT WILL BE PASSED BACK----
062200*          ASSOCIATED WITH THE BILL BEING PROCESSED
062300******************************************************************
062400 01  PRICER-OPT-VERS-SW.
062500     02  PRICER-OPTION-SW          PIC X(01).
062600         88  ALL-TABLES-PASSED          VALUE 'A'.
062700         88  PROV-RECORD-PASSED         VALUE 'P'.
062800         88  ADDITIONAL-VARIABLES       VALUE 'M'.
062900     02  PPS-VERSIONS.
063000         10  PPDRV-VERSION         PIC X(05).
063100
063200******************************************************************
063300*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
063400*          ASSOCIATED WITH THE BILL BEING PROCESSED
063500******************************************************************
063600 01  PPS-ADDITIONAL-VARIABLES.
063700     05  PPS-HSP-PCT                PIC 9(01)V9(02).
063800     05  PPS-FSP-PCT                PIC 9(01)V9(02).
063900     05  PPS-NAT-PCT                PIC 9(01)V9(02).
064000     05  PPS-REG-PCT                PIC 9(01)V9(02).
064100     05  PPS-CMI-ADJ-CPD            PIC 9(05)V9(02).
064200     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
064300     05  PPS-DRG-WT                 PIC 9(02)V9(04).
064400     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
064500     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
064600     05  PPS-REG-LABOR              PIC 9(05)V9(02).
064700     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
064800     05  PPS-OPER-COLA              PIC 9(01)V9(03).
064900     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
065000     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
065100     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
065200     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
065300     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
065400     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
065500     05  PPS-CAPITAL-VARIABLES.
065600         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
065700         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
065800         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
065900         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
066000         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
066100         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
066200         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
066300         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
066400
066500******************************************************************
066600*               THIS IS THE PROVIDER RECORD
066700*          ASSOCIATED WITH THE BILL BEING PROCESSED
066800******************************************************************
066900 01  PROV-HOLD.
067000     02  PROV-REC-HOLD.
067100         05  P-PROVIDER-NO.
067200             10  P-STATE                PIC 9(02).
067300             10  FILLER                 PIC X(04).
067400         05  P-EFF-DATE.
067500             10  P-EFF-YY               PIC 9(02).
067600             10  P-EFF-MM               PIC 9(02).
067700             10  P-EFF-DD               PIC 9(02).
067800         05  P-WAIVER-CODE              PIC X(01).
067900             88  WAIVER-STATE           VALUE 'Y'.
068000         05  P-PROVIDER-TYPE            PIC X(02).
068100             88  SOLE-COMMUNITY-PROV    VALUE '01' '11'.
068200             88  REFERRAL-CENTER        VALUE '07' '11' '15' '17'.
068300             88  INDIAN-HEALTH-SERVICE  VALUE '08'.
068400             88  REDESIGNATED-RURAL-YR1 VALUE '09'.
068500             88  REDESIGNATED-RURAL-YR2 VALUE '10'.
068600             88  SOLE-COM-REF-CENT      VALUE '11'.
068700             88  MDH-REBASED-FY90       VALUE '14' '15'.
068800             88  MDH-RRC-REBASED-FY90   VALUE '15'.
068900             88  SCH-REBASED-FY90       VALUE '16' '17'.
069000             88  SCH-RRC-REBASED-FY90   VALUE '17'.
069100             88  MEDICAL-ASSIST-FACIL   VALUE '18'.
069200         05  P-CURRENT-CENSUS-DIV       PIC 9(01).
069300             88  NEW-ENGLAND            VALUE  1.
069400             88  MIDDLE-ATLANTIC        VALUE  2.
069500             88  SOUTH-ATLANTIC         VALUE  3.
069600             88  EAST-NORTH-CENTRAL     VALUE  4.
069700             88  EAST-SOUTH-CENTRAL     VALUE  5.
069800             88  WEST-NORTH-CENTRAL     VALUE  6.
069900             88  WEST-SOUTH-CENTRAL     VALUE  7.
070000             88  MOUNTAIN               VALUE  8.
070100             88  PACIFIC                VALUE  9.
070200         05  P-CENSUS-DIV  REDEFINES
070300                    P-CURRENT-CENSUS-DIV       PIC 9(01).
070400             88  VALID-CENSUS-DIV   VALUE 1 THRU 9.
070500         05  P-PPS-BLEND-YEAR           PIC 9(01).
070600             88  VALID-PPS-BLEND-YEAR   VALUE 1 THRU 8.
070700         05  P-MSA-X.
070800             10  P-MSA-9                PIC X(04).
070900         05  P-FISCAL-YEAR-END.
071000             10  P-MM                   PIC 9(02).
071100             10  P-DD                   PIC 9(02).
071200             10  P-YY                   PIC 9(02).
071300         05  P-VARIABLES.
071400             10  P-CMI-ADJ-CPD          PIC S9(05)V9(02).
071500             10  P-COLA                 PIC S9(01)V9(03).
071600             10  P-INTERN-RATIO         PIC S9(01)V9(04).
071700             10  PRUP-UPDT-FACTOR       PIC S9(01)V9(05).
071800             10  P-BED-SIZE             PIC  9(05).
071900             10  P-DSH-PERCENT          PIC V9(04).
072000             10  P-OPER-CSTCHG-RATIO    PIC  9(01)V9(03).
072100             10  P-CMI                  PIC  9(01)V9(04).
072200             10  FILLER                 PIC  9(01).
072300             10  P-REPORT-DATE          PIC  9(06).
072400             10  FILLER                 PIC  9(01).
072500             10  P-INTER-NO             PIC  9(05).
072600     02  PROV-REC-HOLD2.
072700         05  P-FY-BEGIN-DATE.
072800             10  P-FY-BEGIN-MM          PIC 9(2).
072900             10  P-FY-BEGIN-DD          PIC 9(2).
073000             10  P-FY-BEGIN-YY          PIC 9(2).
073100         05  P-PASS-AMT-CAPITAL         PIC 9(4)V99.
073200         05  P-PASS-AMT-DIR-MED-ED      PIC 9(4)V99.
073300         05  P-PASS-AMT-ORGAN-ACQ       PIC 9(4)V99.
073400         05  P-PASS-AMT-INCL-MISC       PIC 9(4)V99.
073500         05  P-SSI-RATIO                PIC V9(4).
073600         05  P-MEDICAID-RATIO           PIC V9(4).
073700         05  P-TERMINATION-DATE         PIC X(6).
073800         05  P-WAGE-INDEX-LOC-MSA       PIC X(4).
073900         05  P-CHG-CODE-INDEX           PIC X.
074000         05  P-STAND-AMT-LOC-MSA.
074100             10  P-RURAL-1ST            PIC XX.
074200                 88  P-RURAL-CHECK        VALUE '  '.
074300             10  P-RURAL-2ND            PIC XX.
074400         05  P-CAPI-SOL-HOSP-RATE       PIC XX.
074500         05  FILLER                     PIC X.
074600         05  FILLER                     PIC X(06).
074700         05  FILLER                     PIC X(18).
074800     02  PROV-REC-HOLD3.
074900         05  P-CAPI-PPS-PAY-CODE        PIC X.
075000         05  P-CAPI-HOSP-SPEC-RATE      PIC 9(4)V99.
075100         05  P-CAPI-OLD-HARM-RATE       PIC 9(4)V99.
075200         05  P-CAPI-NEW-HARM-RATIO      PIC 9(1)V9999.
075300         05  P-CAPI-CSTCHG-RATIO        PIC 9V999.
075400         05  P-CAPI-NEW-HOSP            PIC X.
075500         05  P-CAPI-IME                 PIC 9V9999.
075600         05  P-CAPI-EXCEPTIONS          PIC 9(4)V99.
075700         05  FILLER                     PIC X(46).
075800
075900******************************************************************
076000*                   THIS IS THE WAGE-INDEX
076100*          ASSOCIATED WITH THE BILL BEING PROCESSED
076200******************************************************************
076300 01  WAGE-INDEX-RECORD.
076400     05  W-MSA                         PIC X(4).
076500     05  W-SIZE                        PIC X.
076600         88  LARGE-URBAN       VALUE 'L'.
076700         88  OTHER-URBAN       VALUE 'O'.
076800         88  ALL-RURAL         VALUE 'R'.
076900     05  W-EFF-DATE                    PIC X(6).
077000     05  FILLER                        PIC X.
077100     05  W-INDEX-RECORD                PIC S9(02)V9(04).
077200
077300
077400 PROCEDURE DIVISION  USING BILL-DATA
077500                           PPS-DATA
077600                           PRICER-OPT-VERS-SW
077700                           PPS-ADDITIONAL-VARIABLES
077800                           PROV-HOLD
077900                           WAGE-INDEX-RECORD.
078000
078100***************************************************************
078200*    PROCESSING:                                              *
078300*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
078400*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
078500*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
078600*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
078700*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
078800*           GOBACK.                                           *
078900*        D. ASSEMBLE PRICING COMPONENTS.                      *
079000*        E. CALCULATE THE BLENDED PRICE.                      *
079100***************************************************************
079200
079300     PERFORM 0200-MAINLINE-CONTROL.
079400
079500     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
079600     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
079700     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
079800     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
079900     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
080000
080100
080200     GOBACK.
080300
080400 0200-MAINLINE-CONTROL.
080500     MOVE ALL '0' TO PPS-DATA
080600                     HOLD-PPS-COMPONENTS
080700                     HOLD-ADDITIONAL-VARIABLES
080800                     HOLD-CAPITAL-VARIABLES.
080900
081000     IF P-CAPI-HOSP-SPEC-RATE NOT NUMERIC
081100        MOVE 0 TO P-CAPI-HOSP-SPEC-RATE.
081200
081300     IF P-CAPI-OLD-HARM-RATE  NOT NUMERIC
081400        MOVE 0 TO P-CAPI-OLD-HARM-RATE.
081500
081600     IF P-CAPI-NEW-HARM-RATIO NOT NUMERIC
081700        MOVE 0 TO P-CAPI-NEW-HARM-RATIO.
081800
081900     IF P-CAPI-CSTCHG-RATIO NOT NUMERIC
082000        MOVE 0 TO P-CAPI-CSTCHG-RATIO.
082100
082200******************************************************************
082300     PERFORM 1000-EDIT-THE-BILL-INFO.
082400
082500     IF  PPS-RTC = 00
082600         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
082700         PERFORM 3000-CALC-BLENDED-PAYMENT.
082800
082900 1000-EDIT-THE-BILL-INFO.
083000***************************************************************
083100*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
083200*    AND DO NOT ATTEMPT TO PRICE.                             *
083300***************************************************************
083400
083500     MOVE P-YY TO H-FYE-YY.
083600     MOVE P-MM TO H-FYE-MM.
083700     MOVE P-DD TO H-FYE-DD.
083800
083900     IF  H-FYE-MMDD > '0929'
084000         MOVE 83 TO H-FYE-YY
084100     ELSE
084200         MOVE 84 TO H-FYE-YY.
084300
084400     IF  (H-FYE-MM = 04 OR 06 OR 09 OR 11) AND H-FYE-DD = 30
084500         MOVE 31 TO H-FYE-DD
084600     ELSE
084700         IF  H-FYE-MM = 02 AND H-FYE-DD > 27
084800             MOVE 31 TO H-FYE-DD.
084900
085000     MOVE B-DISCHG-YY TO H-BILL-YY.
085100     MOVE B-DISCHG-MM TO H-BILL-MM.
085200     MOVE B-DISCHG-DD TO H-BILL-DD.
085300
085400     MOVE P-FY-BEGIN-YY TO H-FY-BEGIN-YY.
085500     MOVE P-FY-BEGIN-MM TO H-FY-BEGIN-MM.
085600     MOVE P-FY-BEGIN-DD TO H-FY-BEGIN-DD.
085700
085800     IF HOLD-FY-BEGIN-DATE < 921001
085900        IF P-FY-BEGIN-MM = 10 OR = 11 OR = 12
086000           MOVE 91 TO H-FY-BEGIN-YY
086100        ELSE
086200           MOVE 92 TO H-FY-BEGIN-YY.
086300
086400     IF  PPS-RTC = 00
086500         IF  WAIVER-STATE
086600             MOVE 53 TO PPS-RTC.
086700
086800     IF  PPS-RTC = 00
086900         IF  B-DRG < 001 OR > 492 OR = 109 OR = 438
087000                                  OR = 469 OR = 470
087100                                  OR = 474
087200             MOVE 54 TO PPS-RTC.
087300
087400     IF  PPS-RTC = 00
087500         IF  HOLD-BILL-DATE < P-EFF-DATE
087600             MOVE 55 TO PPS-RTC.
087700     IF  PPS-RTC = 00
087800         IF  B-REVIEW-CODE NOT NUMERIC
087900             MOVE 57 TO PPS-RTC.
088000
088100     IF  PPS-RTC = 00
088200         IF  B-LOS NOT NUMERIC
088300             MOVE 56 TO PPS-RTC
088400         ELSE
088500         IF  B-LOS = 0 AND B-REVIEW-CODE NOT = 03
088600             MOVE 56 TO PPS-RTC.
088700
088800     IF  PPS-RTC = 00
088900         IF  B-LTR-DAYS NOT NUMERIC
089000             MOVE 61 TO PPS-RTC
089100         ELSE
089200             MOVE B-LTR-DAYS TO H-LTR-DAYS.
089300
089400     IF  PPS-RTC = 00
089500         IF  B-COVERED-DAYS NOT NUMERIC
089600             MOVE 62 TO PPS-RTC
089700         ELSE
089800         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
089900             MOVE 62 TO PPS-RTC
090000         ELSE
090100             MOVE B-COVERED-DAYS TO H-COV-DAYS.
090200
090300     IF  PPS-RTC = 00
090400         IF  H-LTR-DAYS  > H-COV-DAYS
090500             MOVE 62 TO PPS-RTC
090600         ELSE
090700             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
090800
090900     IF  PPS-RTC = 00
091000         IF  NOT VALID-REVIEW-CODE
091100             MOVE 57 TO PPS-RTC.
091200
091300     IF  PPS-RTC = 00
091400         IF  B-CHARGES-CLAIMED NOT NUMERIC
091500             MOVE 58 TO PPS-RTC.
091600
091700     IF PPS-RTC = 00
091800        IF NOT INDIAN-HEALTH-SERVICE
091900           IF P-CAPI-NEW-HOSP NOT = 'Y'
092000              IF (HOLD-FY-BEGIN-DATE < HOLD-BILL-DATE) OR
092100                 (HOLD-FY-BEGIN-DATE = HOLD-BILL-DATE)
092200                 IF P-CAPI-PPS-PAY-CODE NOT = 'A' AND
092300                                        NOT = 'B' AND
092400                                        NOT = 'C'
092500                 MOVE 65 TO PPS-RTC.
092600
092700 2000-ASSEMBLE-PPS-VARIABLES.
092800***************************************************************
092900*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
093000*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
093100*    OF THAT VARIABLE.                                        *
093200***************************************************************
093300***  GET THE PROVIDER SPECIFIC VARIABLES.
093400
093500     MOVE P-CMI-ADJ-CPD  TO H-CMI-ADJ-CPD.
093600     MOVE P-INTERN-RATIO TO H-INTERN-RATIO.
093700
093800     IF  NOT (P-STATE = 02 OR 12)
093900         MOVE 1 TO H-OPER-COLA
094000     ELSE
094100         MOVE P-COLA TO H-OPER-COLA.
094200
094300***************************************************************
094400***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
094500
094600     PERFORM 2600-GET-DRG-WEIGHT
094700             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
094800
094900***************************************************************
095000***  GET THE WAGE-INDEX
095100
095200     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
095300
095400***************************************************************
095500***  GET THE LABOR, NON-LABOR STANDARD RATES
095600
095700     IF  VALID-CENSUS-DIV
095800         MOVE P-CURRENT-CENSUS-DIV TO R2
095900     ELSE
096000         MOVE 10 TO R2.
096100
096200     MOVE 10 TO R4.
096300
096400     IF  P-STATE = 40
096500         MOVE 11 TO R2
096600         MOVE 12 TO R4.
096700
096800     IF  LARGE-URBAN
096900         MOVE 1 TO R3
097000     ELSE
097100     IF  OTHER-URBAN OR REFERRAL-CENTER
097200         MOVE 2 TO R3
097300     ELSE
097400         MOVE 3 TO R3.
097500
097600     PERFORM 2300-GET-LABOR-NLABOR-RATES
097700             VARYING R1 FROM 1 BY 1 UNTIL R1 > 2.
097800
097900***************************************************************
098000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
098100
098200     MOVE 0.00  TO H-OPER-HSP-PCT.
098300     MOVE 1.00  TO H-OPER-FSP-PCT.
098400
098500***************************************************************
098600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
098700
098800      MOVE 1.00 TO H-NAT-PCT.
098900      MOVE 0.00 TO H-REG-PCT.
099000
099100***************************************************************
099200*    REGIONAL FLOOR
099300
099400     IF  (H-REG-LABOR + H-REG-NLABOR) >
099500         (H-NAT-LABOR + H-NAT-NLABOR)
099600           MOVE 0.85 TO H-NAT-PCT
099700           MOVE 0.15 TO H-REG-PCT.
099800
099900     IF  P-STATE = 40
100000         MOVE 0.00 TO H-OPER-HSP-PCT
100100         MOVE 1.00 TO H-OPER-FSP-PCT
100200         MOVE 0.25 TO H-NAT-PCT
100300         MOVE 0.75 TO H-REG-PCT.
100400
100500     IF  SOLE-COMMUNITY-PROV
100600         MOVE 0.75 TO H-OPER-HSP-PCT
100700         MOVE 0.25 TO H-OPER-FSP-PCT
100800         MOVE 0.00 TO H-NAT-PCT
100900         MOVE 1.00 TO H-REG-PCT.
101000
101100     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
101200         MOVE 1.00 TO H-OPER-HSP-PCT
101300                      H-OPER-FSP-PCT.
101400
101500***************************************************************
101600***  GET THE STANDARD UPDATING FACTOR
101700
101800     MOVE 1 TO  U1.
101900
102000     MOVE P-MM TO U2.
102100
102200     IF  H-FYE-MM = 01 AND H-FYE-DD < 16
102300         MOVE 12 TO U2
102400     ELSE
102500     IF  H-FYE-MM = 02 AND H-FYE-DD < 15
102600         MOVE 01 TO U2
102700     ELSE
102800     IF  H-FYE-MM > 02 AND H-FYE-DD < 16
102900         COMPUTE U2 = U2 - 1.
103000
103100     MOVE R3 TO U3.
103200
103300     IF  REFERRAL-CENTER
103400         MOVE 3 TO U3.
103500
103600     MOVE UPDATE-FACTOR (U1 U2 U3) TO H-UPDATE-FACTOR.
103700
103800***************************************************************
103900***  GET THE SPECIAL UPDATING FACTOR IF APPLICABLE
104000
104100     IF  PRUP-UPDT-FACTOR NUMERIC
104200         IF  PRUP-UPDT-FACTOR > 0
104300             MOVE PRUP-UPDT-FACTOR TO H-UPDATE-FACTOR.
104400
104500 2300-GET-LABOR-NLABOR-RATES.
104600
104700     IF  HOLD-BILL-DATE NOT < RATE-EFF-DATE (R1)
104800         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
104900         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NLABOR
105000         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
105100         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NLABOR
105200         IF REDESIGNATED-RURAL-YR1 OR
105300                   REDESIGNATED-RURAL-YR2
105400            PERFORM 2350-BLEND-RURAL-RATES.
105500
105600 2350-BLEND-RURAL-RATES.
105700      IF  REDESIGNATED-RURAL-YR1
105800          COMPUTE BLEND-RURAL-PCT ROUNDED = 2 / 3
105900      ELSE
106000          COMPUTE BLEND-RURAL-PCT ROUNDED = 1 / 3.
106100
106200      COMPUTE H-REG-LABOR  ROUNDED =
106300          (REG-LABOR  (R1 R2 2) - REG-LABOR  (R1 R2 3))
106400            * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R2 3).
106500
106600      COMPUTE H-REG-NLABOR ROUNDED =
106700          (REG-NLABOR (R1 R2 2) - REG-NLABOR (R1 R2 3))
106800            * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R2 3).
106900
107000      COMPUTE H-NAT-LABOR  ROUNDED =
107100          (REG-LABOR  (R1 R4 2) - REG-LABOR  (R1 R4 3))
107200            * BLEND-RURAL-PCT   +  REG-LABOR  (R1 R4 3).
107300
107400      COMPUTE H-NAT-NLABOR ROUNDED =
107500          (REG-NLABOR (R1 R4 2) - REG-NLABOR (R1 R4 3))
107600            * BLEND-RURAL-PCT   +  REG-NLABOR (R1 R4 3).
107700
107800 2600-GET-DRG-WEIGHT.
107900     IF  HOLD-BILL-DATE NOT < DRGX-EFF-DATE (DX5)
108000         SET DX6 TO B-DRG
108100         MOVE DRG-WT (DX5 DX6)        TO H-DRG-WT
108200         MOVE DRG-ALOS (DX5 DX6)      TO H-ALOS
108300         MOVE DRG-DAYS-TRIM (DX5 DX6) TO H-DAYS-CUTOFF.
108400
108500 3000-CALC-BLENDED-PAYMENT.
108600***************************************************************
108700*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
108800*        CALCULATE COVERED DAYS UTILIZATION.                  *
108900*        CALCULATE THE FEDERAL PORTION.                       *
109000*        CALCULATE THE HOSPITAL PORTION.                      *
109100*        CALCULATE THE DAYS-OUTLIER PORTION.                  *
109200*        CALCULATE THE COST-OUTLIER PORTION.                  *
109300*        CALCULATE THE TOTAL PAYMENT (BLENDED)                *
109400*        CALCULATE THE DSH ADJUSTMENT.                        *
109500***************************************************************
109600     PERFORM 3100-CALC-STAY-UTILIZATION.
109700     PERFORM 3300-CALC-OPER-FSP-AMT.
109800     PERFORM 3400-CALC-OPER-HSP-AMT.
109900     PERFORM 3900-CALC-OPER-DSH.
110000***********************************************************
110100***  OPERATING IME CALCULATION
110200
110300         COMPUTE H-OPER-IME-TEACH =
110400            1.89 * ((1 + H-INTERN-RATIO) ** .405  - 1).
110500
110600***********************************************************
110700
110800     IF  SCH-REBASED-FY90 OR MDH-REBASED-FY90
110900         PERFORM 3450-CALC-ADDITIONAL-HSP.
111000
111100     MOVE 00                 TO  PPS-RTC.
111200     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
111300     MOVE H-ALOS             TO  PPS-AVG-LOS.
111400     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
111500
111600     PERFORM 3600-CALC-OUTLIER.
111700
111800     IF  PAY-AVG-STAY-ONLY
111900         MOVE 0  TO H-OPER-OUTLIER-PART
112000         MOVE 04 TO PPS-RTC.
112100
112200     IF (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)
112300         IF  B-LOS < H-ALOS
112400             IF  NOT (B-DRG = 385 OR 456)
112500                 PERFORM 3500-CALC-PERDIEM-AMT
112600                 MOVE 03 TO PPS-RTC.
112700
112800     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)
112900         IF  H-OPER-OUTCST-PART > 0
113000             MOVE H-OPER-OUTCST-PART TO
113100                  H-OPER-OUTLIER-PART
113200             MOVE 05 TO PPS-RTC
113300         ELSE
113400         IF  PPS-RTC NOT = 03
113500             MOVE 00 TO PPS-RTC
113600             MOVE 0  TO H-OPER-OUTLIER-PART.
113700
113800     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST)
113900         IF  H-CAPI-OUTCST-PART > 0
114000             MOVE H-CAPI-OUTCST-PART TO
114100                  H-CAPI-OUTLIER-PART
114200             MOVE 05 TO PPS-RTC
114300         ELSE
114400         IF  PPS-RTC NOT = 03
114500             MOVE 0  TO H-CAPI-OUTLIER-PART.
114600
114700     IF  PAY-DAYS-OUTLIER
114800         IF  PPS-RTC NOT = 01
114900             MOVE 0  TO H-OPER-OUTLIER-PART
115000                        H-CAPI-OUTLIER-PART
115100             MOVE 00 TO PPS-RTC.
115200
115300     IF  PAY-COST-OUTLIER
115400         IF  PPS-RTC = 01
115500             MOVE 0  TO H-OPER-OUTLIER-PART
115600                        H-CAPI-OUTLIER-PART
115700             MOVE 60 TO PPS-RTC.
115800
115900     IF  PAY-XFER-NO-COST
116000         MOVE 0  TO H-OPER-OUTLIER-PART
116100                    H-CAPI-OUTLIER-PART
116200         MOVE 00 TO PPS-RTC
116300         IF B-LOS < H-ALOS
116400         IF  NOT (B-DRG = 385 OR 456)
116500             PERFORM 3500-CALC-PERDIEM-AMT
116600             MOVE 06 TO PPS-RTC.
116700
116800     MOVE 1 TO H-DSCHG-FRCTN.
116900
117000     IF  (PAY-PERDIEM-DAYS OR PAY-XFER-WITH-COST OR
117100          PAY-XFER-NO-COST)
117200          COMPUTE H-DSCHG-FRCTN = H-COV-DAYS / H-ALOS
117300          IF H-DSCHG-FRCTN > 1
117400             MOVE 1 TO H-DSCHG-FRCTN.
117500
117600     COMPUTE H-DRG-WT-FRCTN = H-DSCHG-FRCTN * H-DRG-WT.
117700
117800     IF  PPS-RTC < 50
117900         PERFORM 3800-CALC-TOT-AMT
118000     ELSE
118100         MOVE 0 TO PPS-OPER-HSP-PART
118200                   PPS-OPER-FSP-PART
118300                   PPS-OPER-OUTLIER-PART
118400                   PPS-OUTLIER-DAYS
118500                   PPS-REG-DAYS-USED
118600                   PPS-LTR-DAYS-USED
118700                   PPS-TOTAL-PAYMENT
118800                   H-DSCHG-FRCTN
118900                   H-DRG-WT-FRCTN
119000                   PPS-OPER-DSH-ADJ
119100                   PPS-OPER-IME-ADJ
119200                   HOLD-CAPITAL-VARIABLES.
119300
119400 3100-CALC-STAY-UTILIZATION.
119500     IF  H-REG-DAYS > 0
119600         IF  H-REG-DAYS < H-DAYS-CUTOFF
119700             MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
119800             MOVE 0          TO H-REG-DAYS
119900         ELSE
120000             MOVE H-DAYS-CUTOFF TO PPS-REG-DAYS-USED
120100             SUBTRACT H-DAYS-CUTOFF FROM H-REG-DAYS
120200     ELSE
120300     IF  H-LTR-DAYS < H-DAYS-CUTOFF
120400         MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED
120500         MOVE 0          TO H-LTR-DAYS
120600     ELSE
120700         MOVE H-DAYS-CUTOFF TO PPS-LTR-DAYS-USED
120800         SUBTRACT H-DAYS-CUTOFF FROM H-LTR-DAYS.
120900
121000     IF  B-LOS > H-DAYS-CUTOFF
121100         PERFORM 3200-CALC-OUTLIER-UTILIZATION.
121200
121300 3200-CALC-OUTLIER-UTILIZATION.
121400     COMPUTE PPS-OUTLIER-DAYS =
121500         B-LOS - H-DAYS-CUTOFF.
121600
121700     IF  (H-REG-DAYS + H-LTR-DAYS) < PPS-OUTLIER-DAYS
121800         COMPUTE PPS-OUTLIER-DAYS =
121900             H-REG-DAYS + H-LTR-DAYS
122000         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
122100         ADD H-LTR-DAYS TO PPS-LTR-DAYS-USED
122200     ELSE
122300     IF  H-REG-DAYS < PPS-OUTLIER-DAYS
122400         ADD H-REG-DAYS TO PPS-REG-DAYS-USED
122500         COMPUTE PPS-LTR-DAYS-USED =
122600             PPS-LTR-DAYS-USED + (PPS-OUTLIER-DAYS -
122700                                  H-REG-DAYS)
122800     ELSE
122900         ADD PPS-OUTLIER-DAYS TO PPS-REG-DAYS-USED.
123000
123100     IF  B-REVIEW-CODE = 03 OR 04
123200         IF  PPS-REG-DAYS-USED > 0
123300             MOVE 0 TO PPS-LTR-DAYS-USED.
123400
123500 3300-CALC-OPER-FSP-AMT.
123600***********************************************************
123700***  OPERATING FSP CALCULATION
123800
123900     COMPUTE H-OPER-FSP-PART ROUNDED =
124000         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
124100         H-NAT-NLABOR * H-OPER-COLA) * H-DRG-WT)
124200                           +
124300         (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
124400         H-REG-NLABOR * H-OPER-COLA) * H-DRG-WT).
124500
124600 3400-CALC-OPER-HSP-AMT.
124700***********************************************************
124800***  OPERATING HSP CALCULATION
124900
125000     COMPUTE H-OPER-HSP-PART ROUNDED =
125100         H-CMI-ADJ-CPD * H-UPDATE-FACTOR * H-DRG-WT.
125200
125300 3450-CALC-ADDITIONAL-HSP.
125400***********************************************************
125500*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
125600*    SOLE COMMUNITY AND MEDICARE DEPENDENT HOSPITALS
125700*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
125800***********************************************************
125900**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
126000
126100         IF  P-RURAL-CHECK AND NOT REFERRAL-CENTER
126200             MOVE 1.021240 TO H-OUTLIER-FACT
126300         ELSE
126400             MOVE 1.059269 TO H-OUTLIER-FACT.
126500
126600***********************************************************
126700**** CHANGE HSP UPDATE FACTORS WHEN HOSPITAL PERIOD CHANGES
126800**** FORCE FYE SO THAT NEW CALC STARTS ON OR AFTER 04/01/90
126900
127000     MOVE 1.00000 TO H-UPDATE-FACTOR.
127100
127200***********************************************************
127300**** INCREASE THIS ADD BY 1 EVERY HCFAS NEW FISCAL YEAR
127400     ADD 8 TO H-FYE-YY.
127500
127600     IF  HOLD-BILL-DATE > HOLD-PROV-FYE-DATE
127700         COMPUTE H-UPDATE-FACTOR ROUNDED =
127800            (1.044 * .999757 * 1.052).
127900
128000     IF  (HOLD-BILL-DATE < HOLD-PROV-FYE-DATE) OR
128100         (HOLD-BILL-DATE = HOLD-PROV-FYE-DATE)
128200          COMPUTE H-UPDATE-FACTOR ROUNDED =
128300            (1.052 * .998526).
128400
128500     COMPUTE H-HSP-RATE ROUNDED =
128600         H-CMI-ADJ-CPD * H-UPDATE-FACTOR.
128700
128800     COMPUTE H-FSP-RATE ROUNDED =
128900         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
129000         H-NAT-NLABOR * H-OPER-COLA))
129100                           +
129200          (H-REG-PCT * (H-REG-LABOR * H-WAGE-INDEX +
129300         H-REG-NLABOR * H-OPER-COLA)))
129400                           *
129500         H-OUTLIER-FACT * (1 + H-OPER-IME-TEACH +
129600                         H-OPER-DSH).
129700     IF  H-HSP-RATE > H-FSP-RATE
129800         COMPUTE H-OPER-HSP-PART =
129900             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
130000     ELSE
130100         MOVE 0 TO H-OPER-HSP-PART.
130200
130300 3500-CALC-PERDIEM-AMT.
130400     MOVE B-LOS TO H-COV-DAYS.
130500     IF  H-COV-DAYS = 0
130600         MOVE 1 TO H-COV-DAYS.
130700***********************************************************
130800***  OPERATING PERDIEM-AMT CALCULATION
130900
131000     COMPUTE H-OPER-HSP-PART ROUNDED =
131100        H-OPER-HSP-PART / H-ALOS * H-COV-DAYS
131200        ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
131300
131400     COMPUTE H-OPER-FSP-PART ROUNDED =
131500        H-OPER-FSP-PART / H-ALOS * H-COV-DAYS
131600        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
131700
131800***********************************************************
131900***  CAPITAL PERDIEM-AMT CALCULATION
132000
132100     COMPUTE H-CAPI-HSP-PART ROUNDED =
132200        H-CAPI-HSP-PART / H-ALOS * H-COV-DAYS
132300        ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
132400
132500     COMPUTE H-CAPI-FSP-PART ROUNDED =
132600        H-CAPI-FSP-PART / H-ALOS * H-COV-DAYS
132700        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
132800
132900***********************************************************
133000***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
133100
133200     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
133300        H-CAPI-OLD-HARMLESS / H-ALOS * H-COV-DAYS
133400        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
133500
133600 3600-CALC-OUTLIER.
133700     MOVE 0.60 TO H-DAYOUT-PCT.
133800     MOVE 0.75 TO H-CSTOUT-PCT.
133900
134000     IF  B-DRG = 456 OR 457 OR 458 OR 459 OR 460 OR 472
134100             MOVE 0.60 TO H-DAYOUT-PCT
134200             MOVE 0.90 TO H-CSTOUT-PCT.
134300
134400     MOVE 0.7140   TO H-LABOR-PCT.
134500     MOVE 0.2860   TO H-NLABOR-PCT.
134600
134700     IF  P-OPER-CSTCHG-RATIO NUMERIC
134800             MOVE P-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
134900     ELSE
135000             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
135100
135200     IF P-CAPI-CSTCHG-RATIO NUMERIC
135300             MOVE P-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
135400     ELSE
135500             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
135600
135700     MOVE 2.000    TO H-CST-MULTIPLE.
135800     MOVE 44000.00 TO H-CST-THRESH.
135900
136000***********************************************************
136100***  OPERATING DAY OUTLIER CALCULATION
136200
136300     IF  PPS-OUTLIER-DAYS > 0
136400        COMPUTE H-OPER-OUTDAY-PART =
136500            H-DAYOUT-PCT *  H-OPER-FSP-PART / H-ALOS
136600                                       * PPS-OUTLIER-DAYS
136700            ON SIZE ERROR MOVE 0 TO H-OPER-OUTDAY-PART.
136800
136900***********************************************************
137000***********************************************************
137100***  CAPITAL PAYMENT METHOD B
137200
137300     IF W-SIZE = 'L'
137400        MOVE 1.03 TO H-CAPI-LARG-URBAN
137500     ELSE
137600        MOVE 1.00 TO H-CAPI-LARG-URBAN.
137700
137800     COMPUTE H-CAPI-GAF = (H-WAGE-INDEX ** .6848).
137900
138000     COMPUTE H-CAPI-COLA =
138100                     (.3152 * (H-OPER-COLA - 1) + 1).
138200
138300     IF P-STATE = 40
138400        COMPUTE  H-CAPI-FED-RATE = (.75 * 319.68) +
138500                                   (.25 * 415.59)
138600     ELSE
138700        MOVE 415.59 TO H-CAPI-FED-RATE.
138800
138900***********************************************************
139000***  CAPITAL HSP CALCULATION
139100
139200     COMPUTE H-CAPI-HSP-PART = (H-DRG-WT *
139300                                P-CAPI-HOSP-SPEC-RATE).
139400***********************************************************
139500***  CAPITAL FSP CALCULATION
139600
139700     COMPUTE H-CAPI-FSP-PART = H-DRG-WT * H-CAPI-FED-RATE *
139800                               H-CAPI-COLA * H-CAPI-GAF *
139900                               H-CAPI-LARG-URBAN.
140000***********************************************************
140100***********************************************************
140200***  CAPITAL PAYMENT METHOD A
140300
140400     IF SOLE-COMMUNITY-PROV OR SCH-REBASED-FY90
140500        MOVE 1.00 TO H-CAPI-SCH
140600     ELSE
140700        MOVE 0.85 TO H-CAPI-SCH.
140800
140900***********  CAPITAL OLD-HARMLESS CALCULATION ***********
141000
141100     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
141200                    (P-CAPI-OLD-HARM-RATE *
141300                    H-CAPI-SCH).
141400
141500***********************************************************
141600***********************************************************
141700***  CAPITAL DAY OUTLIER CALCULATION
141800
141900     IF  PPS-OUTLIER-DAYS > 0
142000         COMPUTE H-CAPI-OUTDAY-PART =
142100            H-DAYOUT-PCT * H-CAPI-FSP-PART / H-ALOS
142200                                       * PPS-OUTLIER-DAYS
142300            ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
142400
142500     IF  H-CAPI-OUTDAY-PART  > 0
142600         IF P-CAPI-PPS-PAY-CODE = 'A'
142700             COMPUTE H-CAPI-OUTDAY-PART =
142800                 H-CAPI-OUTDAY-PART * P-CAPI-NEW-HARM-RATIO
142900             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
143000
143100     IF  H-CAPI-OUTDAY-PART  > 0
143200         IF P-CAPI-PPS-PAY-CODE = 'C'
143300             COMPUTE H-CAPI-OUTDAY-PART =
143400                    (H-CAPI-OUTDAY-PART * .10)
143500             ON SIZE ERROR MOVE 0 TO H-CAPI-OUTDAY-PART.
143600
143700***********************************************************
143800***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
143900
144000     IF H-CAPI-CSTCHG-RATIO > 0 OR
144100       H-OPER-CSTCHG-RATIO > 0
144200        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD =
144300                H-OPER-CSTCHG-RATIO /
144400               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
144500        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD =
144600                H-CAPI-CSTCHG-RATIO /
144700               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
144800     ELSE
144900         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
145000                   H-CAPI-SHARE-DOLL-THRESHOLD.
145100
145200     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
145300        ((H-CST-THRESH * H-LABOR-PCT  * H-WAGE-INDEX) +
145400         (H-CST-THRESH * H-NLABOR-PCT * H-OPER-COLA)) *
145500          H-OPER-SHARE-DOLL-THRESHOLD.
145600
145700***********************************************************
145800***  DIFFERENT THRESHOLD   PRE-CAPITAL
145900
146000     IF (HOLD-BILL-DATE < HOLD-FY-BEGIN-DATE) OR
146100        (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
146200        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
146300                (40100 * H-LABOR-PCT * H-WAGE-INDEX) +
146400                (40100 * H-NLABOR-PCT * H-OPER-COLA).
146500***********************************************************
146600
146700     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
146800          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
146900          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
147000
147100     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
147200         H-CST-MULTIPLE * H-OPER-FSP-PART.
147300
147400     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
147500         H-CST-MULTIPLE * H-CAPI-FSP-PART.
147600
147700     IF (HOLD-BILL-DATE < HOLD-FY-BEGIN-DATE) OR
147800        (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
147900         MOVE 0 TO H-CAPI-DOLLAR-THRESHOLD
148000                   H-CAPI-COST-OUTLIER.
148100
148200     IF (H-OPER-DOLLAR-THRESHOLD + H-CAPI-DOLLAR-THRESHOLD)
148300        > (H-OPER-COST-OUTLIER + H-CAPI-COST-OUTLIER)
148400      MOVE H-OPER-DOLLAR-THRESHOLD TO H-OPER-COST-OUTLIER
148500      MOVE H-CAPI-DOLLAR-THRESHOLD TO H-CAPI-COST-OUTLIER.
148600
148700***********************************************************
148800***  CAPITAL DSH CALCULATION
148900     MOVE 0 TO H-CAPI-DSH.
149000
149100     IF P-BED-SIZE NOT NUMERIC
149200         MOVE 0 TO P-BED-SIZE.
149300
149400     IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
149500         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
149600                  (.2025 * (P-SSI-RATIO
149700                          + P-MEDICAID-RATIO)) - 1.
149800
149900***********************************************************
150000***  OPERATING COST CALCULATION
150100
150200     COMPUTE H-OPER-BILL-COSTS ROUNDED =
150300         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO /
150400         (1 + H-OPER-IME-TEACH + H-OPER-DSH)
150500         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
150600
150700     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
150800         COMPUTE H-OPER-OUTCST-PART =
150900         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
151000                         H-OPER-COST-OUTLIER).
151100
151200     IF  PAY-WITHOUT-COST
151300         MOVE 0 TO H-OPER-OUTCST-PART.
151400
151500***********************************************************
151600***  CAPITAL IME TEACH CALCULATION
151700
151800     MOVE 0 TO H-WK-CAPI-IME-TEACH.
151900
152000     IF P-CAPI-IME NUMERIC
152100        COMPUTE H-WK-CAPI-IME-TEACH =
152200          (2.7183 ** (.2822 * P-CAPI-IME)) - 1.
152300
152400***********************************************************
152500***  CAPITAL COST CALCULATION
152600
152700     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
152800             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO /
152900            (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH)
153000         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
153100
153200     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
153300         COMPUTE H-CAPI-OUTCST-PART =
153400         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
153500                         H-CAPI-COST-OUTLIER).
153600
153700     IF P-CAPI-PPS-PAY-CODE = 'A'
153800       COMPUTE H-CAPI-OUTCST-PART =
153900              (H-CAPI-OUTCST-PART * P-CAPI-NEW-HARM-RATIO).
154000
154100     IF P-CAPI-PPS-PAY-CODE = 'C'
154200        COMPUTE H-CAPI-OUTCST-PART =
154300               (H-CAPI-OUTCST-PART * .10).
154400
154500     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
154600        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
154700        MOVE 0 TO H-CAPI-OUTCST-PART
154800                  H-OPER-OUTCST-PART.
154900
155000     IF  PAY-WITHOUT-COST
155100         MOVE 0 TO H-CAPI-OUTCST-PART.
155200
155300***********************************************************
155400***  GREATER OF DAY OR COST OPERATING AND CAPITAL
155500
155600     IF (HOLD-BILL-DATE < HOLD-FY-BEGIN-DATE) OR
155700        (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
155800         MOVE 0 TO H-CAPI-OUTDAY-PART
155900                   H-CAPI-OUTCST-PART.
156000
156100      IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) > 0 OR
156200         (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
156300         IF (H-OPER-OUTDAY-PART + H-CAPI-OUTDAY-PART) >
156400            (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART)
156500                 MOVE H-OPER-OUTDAY-PART TO
156600                      H-OPER-OUTLIER-PART
156700                 MOVE H-CAPI-OUTDAY-PART TO
156800                      H-CAPI-OUTLIER-PART
156900                 MOVE 01 TO PPS-RTC
157000             ELSE
157100                 MOVE H-OPER-OUTCST-PART TO
157200                      H-OPER-OUTLIER-PART
157300                 MOVE H-CAPI-OUTCST-PART TO
157400                      H-CAPI-OUTLIER-PART
157500                 MOVE 02 TO PPS-RTC.
157600
157700 3800-CALC-TOT-AMT.
157800     IF  H-CMI-ADJ-CPD = 0
157900         MOVE 0.00 TO H-OPER-HSP-PCT
158000         MOVE 1.00 TO H-OPER-FSP-PCT.
158100
158200***********************************************************
158300***  CALCULATE FINAL TOTALS FOR OPERATING
158400
158500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
158600         H-OPER-HSP-PCT * H-OPER-HSP-PART.
158700
158800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
158900         H-OPER-FSP-PCT * H-OPER-FSP-PART.
159000
159100     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
159200             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
159300
159400     MOVE ZERO TO PPS-OPER-DSH-ADJ.
159500
159600     IF  H-OPER-DSH NUMERIC
159700             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
159800             (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART)
159900              * H-OPER-DSH.
160000
160100     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
160200         (PPS-OPER-FSP-PART + PPS-OPER-OUTLIER-PART) *
160300                 H-OPER-IME-TEACH.
160400
160500***********************************************************
160600***  CALCULATE FINAL TOTALS FOR CAPITAL
160700
160800     IF P-CAPI-PPS-PAY-CODE = 'A'
160900        MOVE P-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
161000        MOVE 0.00 TO H-CAPI-HSP-PCT.
161100
161200     IF P-CAPI-PPS-PAY-CODE = 'B'
161300        MOVE 0    TO H-CAPI-OLD-HARMLESS
161400        MOVE 1.00 TO H-CAPI-FSP-PCT
161500        MOVE 0.00 TO H-CAPI-HSP-PCT.
161600
161700     IF P-CAPI-PPS-PAY-CODE = 'C'
161800        MOVE 0    TO H-CAPI-OLD-HARMLESS
161900        MOVE 0.10 TO H-CAPI-FSP-PCT
162000        MOVE 0.90 TO H-CAPI-HSP-PCT.
162100
162200     COMPUTE H-CAPI-HSP ROUNDED =
162300         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
162400
162500     COMPUTE H-CAPI-FSP ROUNDED =
162600         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
162700
162800     MOVE P-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
162900
163000     COMPUTE H-CAPI-OUTLIER ROUNDED =
163100             1.00 * H-CAPI-OUTLIER-PART.
163200
163300     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
163400
163500     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
163600             (H-CAPI-FSP + H-CAPI-OUTLIER-PART)
163700              * H-CAPI-DSH.
163800
163900     COMPUTE H-CAPI-IME-ADJ ROUNDED =
164000         (H-CAPI-FSP + H-CAPI-OUTLIER-PART) *
164100                 H-WK-CAPI-IME-TEACH.
164200
164300***********************************************************
164400***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
164500***        THIS ZEROES OUT ALL CAPITAL DATA
164600
164700     IF (HOLD-BILL-DATE < HOLD-FY-BEGIN-DATE) OR
164800        (P-CAPI-NEW-HOSP = 'Y') OR INDIAN-HEALTH-SERVICE
164900        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
165000
165100     COMPUTE H-CAPI-TOTAL-PAY =
165200             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
165300             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
165400             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
165500
165600***********************************************************
165700***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
165800
165900     COMPUTE PPS-TOTAL-PAYMENT =
166000             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
166100             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
166200             PPS-OPER-IME-ADJ
166300                           +
166400                  H-CAPI-TOTAL-PAY.
166500
166600 3900-CALC-OPER-DSH.
166700***********************************************************
166800***  OPERATING DSH CALCULATION
166900
167000      MOVE .00 TO H-OPER-DSH.
167100
167200      COMPUTE H-WK-OPER-DSH = (P-SSI-RATIO
167300                                     + P-MEDICAID-RATIO).
167400
167500      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE < 100
167600                               AND H-WK-OPER-DSH > .3999
167700        MOVE .05 TO H-OPER-DSH.
167800
167900      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
168000                               AND H-WK-OPER-DSH > .1499
168100                               AND H-WK-OPER-DSH < .2021
168200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
168300                                      * .6 + .025.
168400
168500      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
168600                               AND H-WK-OPER-DSH > .1499
168700                               AND H-WK-OPER-DSH < .2021
168800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
168900                                 * .6 + .025.
169000
169100      IF (W-SIZE = 'O' OR 'L') AND P-BED-SIZE > 99
169200                               AND H-WK-OPER-DSH > .202
169300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
169400                                 * .7 + .0562.
169500
169600      IF W-SIZE = 'R'          AND P-BED-SIZE > 499
169700                               AND H-WK-OPER-DSH > .202
169800        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
169900                                 * .7 + .0562.
170000
170100      IF W-SIZE = 'R'          AND P-BED-SIZE < 101
170200                               AND H-WK-OPER-DSH > .4499
170300        MOVE .04 TO H-OPER-DSH.
170400
170500      IF W-SIZE = 'R'          AND P-BED-SIZE > 100
170600                               AND P-BED-SIZE < 500
170700                               AND H-WK-OPER-DSH > .2999
170800        MOVE .04 TO H-OPER-DSH.
170900
171000      IF W-SIZE = 'R'
171100         IF (P-PROVIDER-TYPE = '01' OR '16')
171200                               AND H-WK-OPER-DSH > .2999
171300                               AND P-BED-SIZE < 500
171400            MOVE .10 TO H-OPER-DSH.
171500
171600      IF W-SIZE = 'R'
171700         IF (P-PROVIDER-TYPE = '07')
171800                               AND H-WK-OPER-DSH > .2999
171900                               AND P-BED-SIZE > 100
172000                               AND P-BED-SIZE < 500
172100            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
172200                                 * .6 + .04.
172300
172400      IF W-SIZE = 'R'
172500         IF (P-PROVIDER-TYPE = '11' OR '17')
172600                               AND H-WK-OPER-DSH > .2999
172700                               AND P-BED-SIZE < 500
172800            COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .3)
172900                                 * .6 + .04.
173000
173100      IF W-SIZE = 'R'
173200         IF (P-PROVIDER-TYPE = '11' OR '17')
173300                               AND H-WK-OPER-DSH > .2999
173400                               AND P-BED-SIZE < 500
173500                               AND H-OPER-DSH < .10
173600            MOVE .10 TO H-OPER-DSH.
173700
173800
173900******        L A S T   S O U R C E   S T A T E M E N T   *****
