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