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