000100 IDENTIFICATION DIVISION.
000200 PROGRAM-ID.           PPCAL04D.
000300*AUTHOR.            DDS TEAM.
000400*REMARKS.                CMS.
000500 DATE-COMPILED.
000600 ENVIRONMENT DIVISION.
000700 CONFIGURATION SECTION.
000800 SOURCE-COMPUTER.            IBM-370.
000900 OBJECT-COMPUTER.            IBM-370.
001000 INPUT-OUTPUT  SECTION.
001100 FILE-CONTROL.
001200
001300 DATA DIVISION.
001400 FILE SECTION.
001500
001600 WORKING-STORAGE SECTION.
001700 01  W-STORAGE-REF                  PIC X(46)  VALUE
001800     'PPCAL04D      - W O R K I N G   S T O R A G E'.
001900 01  CAL-VERSION                    PIC X(05)  VALUE 'C04.D'.
002000***************************************************************
002100***************************************************************
002200****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002300****ATTENTION******ATTENTION********ATTENTION*******ATTENTION**
002400***************************************************************
002500*    IF YOU ARE A HMO, YOU WANT TO PAY CLAIMS AS A HMO        *
002600*     - CHANGE THE > 01 HMO-FLAG < TO THE VALUE OF 'Y' *
002700*     - CHANGE ALL PPCAL___ PROGRAMS BACK TO PPCAL983 *
002800*        BEFORE YOU COMPILE AND LINK THEM *
002900*     - THIS WILL ALLOW YOU TO PAY ALL YOUR CLAIMS WITH *
003000*        AN HMO ADJUSTMENT *
003100***************************************************************
003200***************************************************************
003300 01  HMO-FLAG                       PIC X      VALUE 'N'.
003400***************************************************************
003500***************************************************************
003600 01  HMO-TAG                        PIC X      VALUE SPACE.
003700 01  TEMP-RELIEF-FLAG               PIC X      VALUE 'N'.
003800 01  NON-TEMP-RELIEF-PAYMENT        PIC 9(07)V9(02) VALUE ZEROES.
003900 01  WK-H-OPER-DOLLAR-THRESHOLD     PIC 9(07)V9(09) VALUE ZEROES.
004000 01  R1                             PIC S9(04) COMP SYNC.
004100 01  R2                             PIC S9(04) COMP SYNC.
004200 01  R3                             PIC S9(04) COMP SYNC.
004300 01  R4                             PIC S9(04) COMP SYNC.
004400
004500 01  H-OPER-DSH-SCH               PIC 9(01)V9(04).
004600 01  H-OPER-DSH-RRC               PIC 9(01)V9(04).
004700
004800***************************************************************
004900***************************************************************
005000*    LAYUP TABLE AREA FOR FY2004 RATES UP TO NOV 1, 2003      *
005100***************************************************************
005200 01  RATE-TABLE.
005300     02  RATE-WORK.
005400*RATE 20031001 REGION  LABOR AND NON-LABOR RATES
005500*                  R3=1     /     R3=2
005600*               LARGE URBAN / OTHER URBAN
005700*               LABOR / NON / LABOR / NON
005800*                     /LABOR/       /LABOR
005900*             --------------------------------------------
006000         05  FILLER PIC X(08) VALUE '20031001'.
006100         05  NAT    PIC X(30) VALUE
006200            ' 0313639 127485 0308673 125467'.
006300         05  PR     PIC X(30) VALUE
006400            ' 0150957 060764 0148568 059802'.
006500         05  NATPR  PIC X(30) VALUE
006600            ' 0311002 126414 0311002 126414'.
006700***************************************************************
006800     02  RATE-TAB REDEFINES RATE-WORK.
006900         05  RATE-PERIOD            OCCURS 1.
007000             10  RATE-EFF-DATE      PIC X(08).
007100             10  REG-NAT            OCCURS 3.
007200                 15  R-LARGE-OTHER  OCCURS 2.
007300                     20  FILLER     PIC X(01).
007400                     20  REG-LABOR  PIC 9(05)V9(02).
007500                     20  FILLER     PIC X(01).
007600                     20  REG-NLABOR PIC 9(04)V9(02).
007700
007800
007900***************************************************************
008000***************************************************************
008100*    LAYUP TABLE2 AREA FOR FY2004 RATES                       *
008200*         NOV 1,2003 THROUGH MARCH 31,2004                    *
008300***************************************************************
008400***************************************************************
008500 01  RATE-TABLE2.
008600     02  RATE-WORK2.
008700*RATE 20031101 REGION  LABOR AND NON-LABOR RATES
008800*                  R3=1     /     R3=2
008900*               LARGE URBAN / OTHER URBAN
009000*               LABOR / NON / LABOR / NON
009100*                     /LABOR/       /LABOR
009200*             --------------------------------------------
009300         05  FILLER PIC X(08) VALUE '20031101'.
009400         05  NAT2    PIC X(30) VALUE
009500            ' 0313639 127485 0314632 127889'.
009600         05  PR2     PIC X(30) VALUE
009700            ' 0150957 060764 0148568 059802'.
009800         05  NATPR2  PIC X(30) VALUE
009900            ' 0314166 127699 0314166 127699'.
010000***************************************************************
010100     02  RATE-TAB2 REDEFINES RATE-WORK2.
010200         05  RATE-PERIOD2            OCCURS 1.
010300             10  RATE-EFF-DATE2      PIC X(08).
010400             10  REG-NAT2            OCCURS 3.
010500                 15  R-LARGE-OTHER2  OCCURS 2.
010600                     20  FILLER      PIC X(01).
010700                     20  REG-LABOR2  PIC 9(05)V9(02).
010800                     20  FILLER      PIC X(01).
010900                     20  REG-NLABOR2 PIC 9(04)V9(02).
011000
011100***************************************************************
011200*    LAYUP TABLE3 AREA FOR FY2004 RATES                       *
011300*         APR 1,2004 THROUGH SEPTEMBER 30,2004                *
011400***************************************************************
011500***************************************************************
011600 01  RATE-TABLE3.
011700     02  RATE-WORK3.
011800*RATE 20040401 REGION  LABOR AND NON-LABOR RATES
011900*                  R3=1     /     R3=2
012000*               LARGE URBAN / OTHER URBAN
012100*               LABOR / NON / LABOR / NON
012200*                     /LABOR/       /LABOR
012300*             --------------------------------------------
012400         05  FILLER PIC X(08) VALUE '20040401'.
012500         05  NAT3    PIC X(30) VALUE
012600            ' 0313549 127449 0313549 127449'.
012700         05  PR3     PIC X(30) VALUE
012800            ' 0150758 060683 0153938 061964'.
012900         05  NATPR3  PIC X(30) VALUE
013000            ' 0313549 127449 0313549 127449'.
013100***************************************************************
013200     02  RATE-TAB3 REDEFINES RATE-WORK3.
013300         05  RATE-PERIOD3            OCCURS 1.
013400             10  RATE-EFF-DATE3      PIC X(08).
013500             10  REG-NAT3            OCCURS 3.
013600                 15  R-LARGE-OTHER3  OCCURS 2.
013700                     20  FILLER      PIC X(01).
013800                     20  REG-LABOR3  PIC 9(05)V9(02).
013900                     20  FILLER      PIC X(01).
014000                     20  REG-NLABOR3 PIC 9(04)V9(02).
014100
014200
014300***************************************************************
014400*    LAYUP TABLE AREA FOR FY2004 DRGS                         *
014500***************************************************************
014600 01  DRG-TABLE.
014700     05  D-TAB.
014800       10  FILLER                  PIC X(08) VALUE
014900      '20031001'.
015000       10  FILLER                  PIC X(56) VALUE
015100     '03618608000109020850041000530197531270012700000000000000'.
015200       10  FILLER                  PIC X(56) VALUE
015300     '00000000000000008092022000310265190660009801545301900028'.
015400       10  FILLER                  PIC X(56) VALUE
015500     '01421404700069012448048000650085710300004100925904500059'.
015600       10  FILLER                  PIC X(56) VALUE
015700     '00817604000050012682047000610096770390004901261804800064'.
015800       10  FILLER                  PIC X(56) VALUE
015900     '00699102500032010026042000550070410280003502739408000105'.
016000       10  FILLER                  PIC X(56) VALUE
016100     '01513805000066010737039000510082390320004301012103700050'.
016200       10  FILLER                  PIC X(56) VALUE
016300     '00610902500032013730022000410133700320005201338604400061'.
016400       10  FILLER                  PIC X(56) VALUE
016500     '00708702700035003341020000200091170310004100568402000025'.
016600       10  FILLER                  PIC X(56) VALUE
016700     '00209801600016009931037000500063550250003100629801200015'.
016800       10  FILLER                  PIC X(56) VALUE
016900     '01057502500038004669019000280062850150002100893702700038'.
017000       10  FILLER                  PIC X(56) VALUE
017100     '00340101600016007064019000270053820240003400659704000050'.
017200       10  FILLER                  PIC X(56) VALUE
017300     '00725002500031007936034000450053170240003100299602900029'.
017400       10  FILLER                  PIC X(56) VALUE
017500     '01727703200045008317015000190084100190002800801801400018'.
017600       10  FILLER                  PIC X(56) VALUE
017700     '01252002200036004856032000320092470200003000923301900029'.
017800       10  FILLER                  PIC X(56) VALUE
017900     '01102902400037002757015000150095570190002700209901500015'.
018000       10  FILLER                  PIC X(56) VALUE
018100     '01233403100052002973013000130137590300004401308904300065'.
018200       10  FILLER                  PIC X(56) VALUE
018300     '00574802300028005811024000310077800290003700653103100039'.
018400       10  FILLER                  PIC X(56) VALUE
018500     '00498702500030003188020000240070650250003400695402600034'.
018600       10  FILLER                  PIC X(56) VALUE
018700     '00818403300045003380021000210304370770010002818408400111'.
018800       10  FILLER                  PIC X(56) VALUE
018900     '01237803500048012731056000660159740670008500840004300054'.
019000       10  FILLER                  PIC X(56) VALUE
019100     '01530006100061013724051000690096200430005400537102600033'.
019200       10  FILLER                  PIC X(56) VALUE
019300     '01192704800063006864028000360134300480006400903104100051'.
019400       10  FILLER                  PIC X(56) VALUE
019500     '01046304900059006147034000400074080310005101202405000063'.
019600       10  FILLER                  PIC X(56) VALUE
019700     '00717603300040011340047000630061660300003800746403700046'.
019800       10  FILLER                  PIC X(56) VALUE
019900     '00550502900035009662037000370070320240003200522201800021'.
020000       10  FILLER                  PIC X(56) VALUE
020100     '00865403300044005437021000261860812610042407938912200144'.
020200       10  FILLER                  PIC X(56) VALUE
020300     '05715608200099072936096001140537510920010405365607300098'.
020400       10  FILLER                  PIC X(56) VALUE
020500     '03940106700077040492062000890247970320004100000000000000'.
020600       10  FILLER                  PIC X(56) VALUE
020700     '03010610400133016436063000870354650500007402359003100044'.
020800       10  FILLER                  PIC X(56) VALUE
020900     '01395102600043016089020000290137390320005302316405600090'.
021000       10  FILLER                  PIC X(56) VALUE
021100     '01616905300066010297029000370156450290004801436703300044'.
021200       10  FILLER                  PIC X(56) VALUE
021300     '01094702200028025418092001180102650420005300728504600055'.
021400       10  FILLER                  PIC X(56) VALUE
021500     '01022901700026009505045000570056760330004100642202300029'.
021600       10  FILLER                  PIC X(56) VALUE
021700     '00555901800023005954025000320092820340004500574002200027'.
021800       10  FILLER                  PIC X(56) VALUE
021900     '00824303300033008355031000400051600200002500530502000025'.
022000       10  FILLER                  PIC X(56) VALUE
022100     '00747302800036005761021000260054800170002101226003900056'.
022200       10  FILLER                  PIC X(56) VALUE
022300     '00578702000026027376088001020153750560006203402510100123'.
022400       10  FILLER                  PIC X(56) VALUE
022500     '01459005800063028711092001130130610440005601913406900084'.
022600       10  FILLER                  PIC X(56) VALUE
022700     '01131004700053040212099001330130430300004100848906000060'.
022800       10  FILLER                  PIC X(56) VALUE
022900     '01315204000058006517020000260137440380005100821902200027'.
023000       10  FILLER                  PIC X(56) VALUE
023100     '01167603000043006446016000190069650210002102330607000084'.
023200       10  FILLER                  PIC X(56) VALUE
023300     '01230203900045014317036000470088890200002401315803300049'.
023400       10  FILLER                  PIC X(56) VALUE
023500     '00752501800024028245075001090119120330004301367005200070'.
023600       10  FILLER                  PIC X(56) VALUE
023700     '00752802800038010025039000480055870250002901099804100052'.
023800       10  FILLER                  PIC X(56) VALUE
023900     '00925903700046006940026000310108850460006000964204200055'.
024000       10  FILLER                  PIC X(56) VALUE
024100     '00537602800034008223034000440057590230002900481302400033'.
024200       10  FILLER                  PIC X(56) VALUE
024300     '00868503300047003236029000290077780300004001108804100056'.
024400       10  FILLER                  PIC X(56) VALUE
024500     '00598702400031008104037000520427870980013801802504700062'.
024600       10  FILLER                  PIC X(56) VALUE
024700     '03421110400128016030057000670306130870010601611704800056'.
024800       10  FILLER                  PIC X(56) VALUE
024900     '02554707500092011831038000440239530700009803041506700105'.
025000       10  FILLER                  PIC X(56) VALUE
025100     '03684110200142013120048000640134820500006701167504400058'.
025200       10  FILLER                  PIC X(56) VALUE
025300     '01209504600062007071029000380115390400005300660102300029'.
025400       10  FILLER                  PIC X(56) VALUE
025500     '02032704400049018477061000700125440450004901415203200064'.
025600       10  FILLER                  PIC X(56) VALUE
025700     '01890406700092000000000000000000000000000002110705000080'.
025800       10  FILLER                  PIC X(56) VALUE
025900     '03002009000134015750043000550102580270003200588105300053'.
026000       10  FILLER                  PIC X(56) VALUE
026100     '00000000000000000000000000000105730220003000789801600019'.
026200       10  FILLER                  PIC X(56) VALUE
026300     '01170403600053015529045000660081900210002601163902700042'.
026400       10  FILLER                  PIC X(56) VALUE
026500     '00706401800023013147036000560000000000000000967401800027'.
026600       10  FILLER                  PIC X(56) VALUE
026700     '02002405000074011977022000310075800380004900735803900048'.
026800       10  FILLER                  PIC X(56) VALUE
026900     '00598302900037013564065000870106140510006401315304900067'.
027000       10  FILLER                  PIC X(56) VALUE
027100     '00635803000038011695053000690075250370004700715503700047'.
027200       10  FILLER                  PIC X(56) VALUE
027300     '00478602600033006063030000380057240260003300858503800049'.
027400       10  FILLER                  PIC X(56) VALUE
027500     '00674402500036007091032000410045780230002800255301800018'.
027600       10  FILLER                  PIC X(56) VALUE
027700     '00758103700047004464026000320029740290002900819003800051'.
027800       10  FILLER                  PIC X(56) VALUE
027900     '00891302100026007018016000180094200180002700685401200014'.
028000       10  FILLER                  PIC X(56) VALUE
028100     '00894401600021009533029000430205560830011501060505000066'.
028200       10  FILLER                  PIC X(56) VALUE
028300     '01598404200066008791023000320095740290004501151302400038'.
028400       10  FILLER                  PIC X(56) VALUE
028500     '01774706000085008129025000360102800560007201018504600060'.
028600       10  FILLER                  PIC X(56) VALUE
028700     '00619203000039011574047000650057290240003400647103500045'.
028800       10  FILLER                  PIC X(56) VALUE
028900     '00880504700058005432035000420077790400005300710903200041'.
029000       10  FILLER                  PIC X(56) VALUE
029100     '00486602300029002586022000220073220350004700421502300029'.
029200       10  FILLER                  PIC X(56) VALUE
029300     '02082507900106020342044000590188990770010302149803900050'.
029400       10  FILLER                  PIC X(56) VALUE
029500     '00944101800027008938017000220064680140001602733607300106'.
029600       10  FILLER                  PIC X(56) VALUE
029700     '01389603200047007800035000460079750300004000863904000051'.
029800       10  FILLER                  PIC X(56) VALUE
029900     '00508502700033004537024000310094660380005501100104700062'.
030000       10  FILLER                  PIC X(56) VALUE
030100     '00615802800036032343072000850236590640008002385606200089'.
030200       10  FILLER                  PIC X(56) VALUE
030300     '01185402800036012257035000540061450170002101599304000062'.
030400       10  FILLER                  PIC X(56) VALUE
030500     '00899101700021011502029000440062580150001801084103000045'.
030600       10  FILLER                  PIC X(56) VALUE
030700     '00681401700022004984023000230207960370007001298704900066'.
030800       10  FILLER                  PIC X(56) VALUE
030900     '00850302400036011871044000610067710220002900885304300054'.
031000       10  FILLER                  PIC X(56) VALUE
031100     '00568503100037004625028000330080880240003200479701600019'.
031200       10  FILLER                  PIC X(56) VALUE
031300     '00655302900038004206021000260037270310003100761302700038'.
031400       10  FILLER                  PIC X(56) VALUE
031500     '00529601700021003210016000160106180420005600598202400032'.
031600       10  FILLER                  PIC X(56) VALUE
031700     '00948303700057014810039000460108350280003000859502600034'.
031800       10  FILLER                  PIC X(56) VALUE
031900     '00586901800020012316035000550113450290004800285302400024'.
032000       10  FILLER                  PIC X(56) VALUE
032100     '01273901900032007800024000320015510170001701330601600025'.
032200       10  FILLER                  PIC X(56) VALUE
032300     '01167103000049010213045000590054170220003000747203300044'.
032400       10  FILLER                  PIC X(56) VALUE
032500     '00460802000025007370036000450023790130001300709702900040'.
032600       10  FILLER                  PIC X(56) VALUE
032700     '01839004900065014808047000570089120300003200755601800021'.
032800       10  FILLER                  PIC X(56) VALUE
032900     '02273706700084011807034000420080990230002600866102200028'.
033000       10  FILLER                  PIC X(56) VALUE
033100     '01079302200032003041014000140093740260003600909802900041'.
033200       10  FILLER                  PIC X(56) VALUE
033300     '02128405300082012826048000680055880230003101165705100067'.
033400       10  FILLER                  PIC X(56) VALUE
033500     '00606502400033010119042000570063170320003500552002700035'.
033600       10  FILLER                  PIC X(56) VALUE
033700     '00385602000023007402025000300058060440004400569302500034'.
033800       10  FILLER                  PIC X(56) VALUE
033900     '01032103100041007950020000260036260200003000432301600020'.
034000       10  FILLER                  PIC X(56) VALUE
034100     '00525701500019002190013000170051230270003800348501900026'.
034200       10  FILLER                  PIC X(56) VALUE
034300     '01385501800018045687179001790312031330013301882708600086'.
034400       10  FILLER                  PIC X(56) VALUE
034500     '03205204700047011344034000340015360310003103316407100097'.
034600       10  FILLER                  PIC X(56) VALUE
034700     '01357109100091019338047000760083070320004400698602900042'.
034800       10  FILLER                  PIC X(56) VALUE
034900     '01264803700052012360045000590066510270003500000000000000'.
035000       10  FILLER                  PIC X(56) VALUE
035100     '02894608100116011430027000400181970580008200865803000041'.
035200       10  FILLER                  PIC X(56) VALUE
035300     '01924104900049027055069000970124100320004102198404800082'.
035400       10  FILLER                  PIC X(56) VALUE
035500     '01243904600061010833032000410039480470004700567902500036'.
035600       10  FILLER                  PIC X(56) VALUE
035700     '01322405200071007370032000420362761040014401591805600075'.
035800       10  FILLER                  PIC X(56) VALUE
035900     '00961204400057010672048000630084760360004600610702800034'.
036000       10  FILLER                  PIC X(56) VALUE
036100     '00746403100041007248025000370181550590008402407408000131'.
036200       10  FILLER                  PIC X(56) VALUE
036300     '00678102800038005087032000450050120310004400729104500071'.
036400       10  FILLER                  PIC X(56) VALUE
036500     '00829104500061006801056000790066200440006900651302900040'.
036600       10  FILLER                  PIC X(56) VALUE
036700     '00290402200031000000000000000000000000000000000000000000'.
036800       10  FILLER                  PIC X(56) VALUE
036900     '00000000000000000000000000000175470520008201887805800091'.
037000       10  FILLER                  PIC X(56) VALUE
037100     '00966202100031024200056000860097870250003400747503200042'.
037200       10  FILLER                  PIC X(56) VALUE
037300     '00501502300029002983024000240052380190002500098102900029'.
037400       10  FILLER                  PIC X(56) VALUE
037500     '00835202600037004246016000200026480210002101045503500049'.
037600       10  FILLER                  PIC X(56) VALUE
037700     '00511302100028008153030000420047730180002400000000000000'.
037800       10  FILLER                  PIC X(56) VALUE
037900     '00000000000000000000000000000000000000000000000000000000'.
038000       10  FILLER                  PIC X(56) VALUE
038100     '01169202200036009747090001100068560310004100498202400030'.
038200       10  FILLER                  PIC X(56) VALUE
038300     '00888102000039008088022000390052740190003703845409400131'.
038400       10  FILLER                  PIC X(56) VALUE
038500     '00000000000000000000000000000305760470005400000000000000'.
038600       10  FILLER                  PIC X(56) VALUE
038700     '03488507400127000000000000000360000800011302247708000111'.
038800       10  FILLER                  PIC X(56) VALUE
038900     '01887305400083023743049000730143000240003209782314000211'.
039000       10  FILLER                  PIC X(56) VALUE
039100     '06107419200218034803096001251677623420041605417909700145'.
039200       10  FILLER                  PIC X(56) VALUE
039300     '03212107900100048793087001290200570530007304811811700170'.
039400       10  FILLER                  PIC X(56) VALUE
039500     '01860306000086010512039000550171390280003403837109300149'.
039600       10  FILLER                  PIC X(56) VALUE
039700     '01830204400060010034020000250855511340016205683906800089'.
039800       10  FILLER                  PIC X(56) VALUE
039900     '03405605200063025319036000400142440330004500936902000024'.
040000       10  FILLER                  PIC X(56) VALUE
040100     '02639308300107014192051000620122330300003911621520300280'.
040200       10  FILLER                  PIC X(56) VALUE
040300     '02000602300056041070121001690181540650009201377505600080'.
040400       10  FILLER                  PIC X(56) VALUE
040500     '00642603100044011812046000680067530320004705340511100132'.
040600       10  FILLER                  PIC X(56) VALUE
040700     '06159408700100000000000000000533660300005202691103800048'.
040800       10  FILLER                  PIC X(56) VALUE
040900     '02159801800025017494023000340242660320005101578001700021'.
041000       10  FILLER                  PIC X(56) VALUE
041100     '00711504300058005226077000970039560330004100732002700034'.
041200       10  FILLER                  PIC X(56) VALUE
041300     '14189610200196029891036000450244830180002507220514200175'.
041400       10  FILLER                  PIC X(56) VALUE
041500     '02252905300082012017028000360305520680009901448202900040'.
041600       10  FILLER                  PIC X(56) VALUE
041700     '01667802700041010748016000200815600810011006277503900058'.
041800       10  FILLER                  PIC X(56) VALUE
041900     '01818504700070009919021000290338460740011201289102900040'.
042000     05  DRGX-TAB REDEFINES D-TAB.
042100         10  DRGX-PERIOD               OCCURS 1
042200                                        INDEXED BY DX5.
042300             15  DRGX-EFF-DATE         PIC X(08).
042400             15  DRG-DATA              OCCURS 540
042500                                        INDEXED BY DX6.
042600                 20  DRG-WT            PIC 9(02)V9(04).
042700                 20  DRG-ALOS          PIC 9(02)V9(01).
042800                 20  DRG-DAYS-TRIM     PIC 9(02).
042900                 20  DRG-ARITH-ALOS    PIC 9(02)V9(01).
043000
043100 01  HOLD-AREA.
043200     02  HOLD-PPS-COMPONENTS.
043300         05  H-OPER-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
043400         05  H-CAPI-SHARE-DOLL-THRESHOLD  PIC 9(07)V9(09).
043500
043600         05  H-OPER-HSP-PART              PIC 9(06)V9(09).
043700         05  H-CAPI-HSP-PART              PIC 9(06)V9(09).
043800
043900         05  H-OPER-FSP-PART              PIC 9(06)V9(09).
044000         05  H-CAPI-FSP-PART              PIC 9(06)V9(09).
044100         05  H-CAPI2-B-FSP-PART           PIC 9(06)V9(09).
044200
044300         05  H-OPER-OUTLIER-PART          PIC 9(07)V9(09).
044400         05  H-CAPI-OUTLIER-PART          PIC 9(07)V9(09).
044500         05  H-CAPI2-B-OUTLIER-PART       PIC 9(07)V9(09).
044600
044700         05  H-OPER-OUTDAY-PART           PIC 9(07)V9(09).
044800         05  H-CAPI-OUTDAY-PART           PIC 9(07)V9(09).
044900
045000         05  H-OPER-OUTCST-PART           PIC 9(07)V9(09).
045100         05  H-CAPI-OUTCST-PART           PIC 9(07)V9(09).
045200
045300         05  H-OPER-CSTCHG-RATIO          PIC 9(01)V9(03).
045400         05  H-CAPI-CSTCHG-RATIO          PIC 9(01)V9(03).
045500
045600
045700         05  H-OPER-IME-TEACH             PIC 9(06)V9(09).
045800         05  H-CAPI-PAYCDE-PCT1           PIC 9(01)V9(02).
045900         05  H-CAPI-PAYCDE-PCT2           PIC 9(01)V9(02).
046000         05  H-CAPI-COST-OUTLIER          PIC 9(07)V9(09).
046100         05  H-CAPI-BILL-COSTS            PIC 9(07)V9(09).
046200         05  H-CAPI-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
046300         05  H-CAPI-COLA                  PIC 9(01)V9(03).
046400         05  H-CAPI-SCH                   PIC 9(05)V9(02).
046500         05  H-CAPI-BUD-NEUTRALITY        PIC 9(01)V9(04).
046600         05  H-CAPI-OLD-HARMLESS          PIC 9(09)V9(02).
046700         05  H-CAPI-FED-RATE              PIC 9(05)V9(04).
046800         05  H-CAPI-FULL-PROS             PIC 9(05)V9(04).
046900         05  H-CAPI-LARG-URBAN            PIC 9(01)V9(02).
047000         05  H-CAPI-GAF                   PIC 9(05)V9(04).
047100         05  H-PR-CAPI-GAF                PIC 9(05)V9(04).
047200         05  H-BLEND-GAF                  PIC 9(05)V9(04).
047300         05  H-WAGE-INDEX                 PIC 9(02)V9(04).
047400         05  H-COV-DAYS                   PIC 9(3).
047500         05  H-PERDIEM-DAYS               PIC 9(3).
047600         05  H-REG-DAYS                   PIC 9(3).
047700         05  H-LTR-DAYS                   PIC 9(3).
047800         05  H-DSCHG-FRCTN                PIC 9(1)V9999.
047900         05  H-DRG-WT-FRCTN               PIC 9(2)V9999.
048000         05  H-ALOS                       PIC 9(02)V9(01).
048100         05  H-DAYS-CUTOFF                PIC 9(02)V9(01).
048200         05  H-DAYOUT-PCT                 PIC 9(01)V9(02).
048300         05  H-CSTOUT-PCT                 PIC 9(01)V9(02).
048400         05  H-CST-THRESH                 PIC 9(05)V9(02).
048500         05  H-PRE-CAPI-THRESH            PIC 9(05)V9(02).
048600         05  H-BUDG-NUTR01                PIC 9(01)V9(06).
048700         05  H-BUDG-NUTR02                PIC 9(01)V9(06).
048800         05  H-BUDG-NUTR03                PIC 9(01)V9(06).
048900         05  H-BUDG-NUTR04                PIC 9(01)V9(06).
049000         05  H-UPDATE-01                  PIC 9(01)V9(04).
049100         05  H-UPDATE-02                  PIC 9(01)V9(04).
049200         05  H-UPDATE-03                  PIC 9(01)V9(04).
049300         05  H-UPDATE-04                  PIC 9(01)V9(04).
049400         05  H-ACCUM-TO-HSP               PIC 9(01)V9(04).
049500         05  H-HSP-UPDATE94               PIC 9(01)V9(04).
049600         05  H-HSP-UPDATE95               PIC 9(01)V9(04).
049700         05  H-HSP-UPDATE96               PIC 9(01)V9(04).
049800         05  H-HSP-UPDATE97               PIC 9(01)V9(04).
049900         05  H-HSP-UPDATE98               PIC 9(01)V9(04).
050000         05  H-HSP-UPDATE99               PIC 9(01)V9(04).
050100         05  H-HSP-UPDATE00               PIC 9(01)V9(04).
050200         05  H-HSP-UPDATE01               PIC 9(01)V9(04).
050300         05  H-PUERTO-RICO-RATE           PIC 9(04)V9(02).
050400         05  H-FEDERAL-RATE               PIC 9(04)V9(02).
050500         05  H-LABOR-PCT                  PIC 9(01)V9(04).
050600         05  H-NONLABOR-PCT               PIC 9(01)V9(04).
050700         05  H-PR-LABOR-PCT               PIC 9(01)V9(04).
050800         05  H-PR-NONLABOR-PCT            PIC 9(01)V9(04).
050900         05  H-HSP-RATE                   PIC 9(06)V9(09).
051000         05  H-FSP-RATE                   PIC 9(06)V9(09).
051100         05  H-OUTLIER-OFFSET-NAT         PIC 9(01)V9(06).
051200         05  H-OUTLIER-OFFSET-PR          PIC 9(01)V9(06).
051300         05  H-WK-OPER-DSH                PIC 9(01)V9(04).
051400         05  H-WK-CAPI-IME-TEACH          PIC 9(06)V9(09).
051500         05  H-OPER-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
051600         05  H-CAPI-PR-DOLLAR-THRESHOLD   PIC 9(07)V9(09).
051700         05  H-DSH-REDUCT-FACTOR          PIC 9(01)V9(04).
051800         05  H-WK-PASS-AMT-PLUS-MISC      PIC 9(06)V99.
051900         05  H-BASE-DRG-PAYMENT           PIC S9(07)V99.
052000         05  H-NEW-TECH-ADDON-XIGRIS      PIC S9(07)V99.
052100         05  H-NEW-TECH-ADDON-INFUSE      PIC S9(07)V99.
052200         05  H-LESSER-XIGRIS-1            PIC S9(07)V99.
052300         05  H-LESSER-XIGRIS-2            PIC S9(07)V99.
052400         05  H-LESSER-INFUSE-1            PIC S9(07)V99.
052500         05  H-LESSER-INFUSE-2            PIC S9(07)V99.
052600         05  H-CSTMED-XIGRIS              PIC S9(07)V99.
052700         05  H-CSTMED-INFUSE              PIC S9(07)V99.
052800
052900
053000     02  HOLD-ADDITIONAL-VARIABLES.
053100         05  H-OPER-HSP-PCT               PIC 9(01)V9(02).
053200         05  H-OPER-FSP-PCT               PIC 9(01)V9(02).
053300         05  H-NAT-PCT                    PIC 9(01)V9(02).
053400         05  H-REG-PCT                    PIC 9(01)V9(02).
053500         05  H-FAC-SPEC-RATE              PIC 9(05)V9(02).
053600         05  H-UPDATE-FACTOR              PIC 9(01)V9(05).
053700         05  H-DRG-WT                     PIC 9(02)V9(04).
053800         05  H-TOT-REG-AL                 PIC 9(05)V9(02).
053900         05  H-TOT-NAT-AL                 PIC 9(05)V9(02).
054000         05  H-NAT-LABOR                  PIC 9(05)V9(02).
054100         05  H-NAT-NONLABOR               PIC 9(05)V9(02).
054200         05  H-REG-LABOR                  PIC 9(05)V9(02).
054300         05  H-REG-NONLABOR               PIC 9(05)V9(02).
054400         05  H-OPER-COLA                  PIC 9(01)V9(03).
054500         05  H-INTERN-RATIO               PIC 9(01)V9(04).
054600         05  H-OPER-COST-OUTLIER          PIC 9(07)V9(09).
054700         05  H-OPER-BILL-COSTS            PIC 9(07)V9(09).
054800         05  H-OPER-DOLLAR-THRESHOLD      PIC 9(07)V9(09).
054900
055000     02  HOLD-CAPITAL-VARIABLES.
055100         05  H-CAPI-TOTAL-PAY             PIC 9(07)V9(02).
055200         05  H-CAPI-HSP                   PIC 9(07)V9(02).
055300         05  H-CAPI-FSP                   PIC 9(07)V9(02).
055400         05  H-CAPI-OUTLIER               PIC 9(07)V9(02).
055500         05  H-CAPI-OLD-HARM              PIC 9(07)V9(02).
055600         05  H-CAPI-DSH-ADJ               PIC 9(07)V9(02).
055700         05  H-CAPI-IME-ADJ               PIC 9(07)V9(02).
055800         05  H-CAPI-EXCEPTIONS            PIC 9(07)V9(02).
055900
056000     02  HOLD-CAPITAL2-VARIABLES.
056100         05  H-CAPI2-PAY-CODE             PIC X(1).
056200         05  H-CAPI2-B-FSP                PIC 9(07)V9(02).
056300         05  H-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
056400
056500     02  HOLD-OTHER-VARIABLES.
056600         05  H-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
056700         05  H-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
056800         05  H-LOW-VOL-PAYMENT              PIC 9(07)V9(02).
056900         05  H-HVBP-HRR-DATA.
057000             10  H-VAL-BASED-PURCH-PARTIPNT PIC X.
057100             10  H-VAL-BASED-PURCH-ADJUST     PIC 9V9(11).
057200             10  H-HOSP-READMISS-REDUCTN      PIC X.
057300             10  H-HOSP-HRR-ADJUSTMT          PIC 9V9(4).
057400         05  H-OPERATNG-DATA.
057500             10  H-MODEL1-BUNDLE-DISPRCNT    PIC V999.
057600             10  H-OPER-BASE-DRG-PAY         PIC 9(08)V99.
057700             10  H-OPER-HSP-AMT              PIC 9(08)V99.
057800
057900     02  HOLD-PC-OTH-VARIABLES.
058000         05  H-OPER-DSH                   PIC 9(01)V9(04).
058100         05  H-CAPI-DSH                   PIC 9(01)V9(04).
058200         05  H-CAPI-HSP-PCT               PIC 9(01)V9(02).
058300         05  H-CAPI-FSP-PCT               PIC 9(01)V9(04).
058400         05  H-ARITH-ALOS                 PIC 9(02)V9(01).
058500         05  H-PR-WAGE-INDEX              PIC 9(02)V9(04).
058600         05  H-TRANSFER-ADJ               PIC 9(01)V9(05).
058700         05  H-PC-HMO-FLAG                PIC X(01).
058800         05  H-PC-COT-FLAG                PIC X(01).
058900         05  H-FILLER                     PIC X(0998).
059000
059100 LINKAGE SECTION.
059200***************************************************************
059300*                 * * * * * * * * *                           *
059400*    REVIEW CODES ARE USED TO DIRECT THE PPCAL  SUBROUTINE    *
059500*    IN HOW TO PAY THE BILL.                                  *
059600*                         *****                               *
059700*    COMMENTS  ** CLAIMS RECEIVED WITH CONDITION CODE 66      *
059800*                 SHOULD BE PROCESSED UNDER REVIEW CODE 06,   *
059900*                 07 OR 11 AS APPROPRIATE TO EXCLUDE ANY      *
060000*                 OUTLIER COMPUTATION.                        *
060100*                         *****                               *
060200*         REVIEW-CODE:                                        *
060300*            00 = PAY-WITH-OUTLIER.                           *
060400*                 WILL CALCULATE THE STANDARD PAYMENT.        *
060500*                 WILL ALSO ATTEMPT TO PAY ONLY COST          *
060600*                 OUTLIERS, DAY OUTLIERS EXPIRED 10/01/97     *
060700*            03 = PAY-PERDIEM-DAYS.                           *
060800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
060900*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
061000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
061100*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
061200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
061300*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
061400*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
061500*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
061600*                 BILL EXCEED THE COST THRESHOLD.             *
061700*            06 = PAY-XFER-NO-COST                            *
061800*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
061900*                 THE STANDARD PAYMENT IF THE COVERED DAYS    *
062000*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
062100*                 FOR THE DRG.  IF COVERED DAYS EQUAL OR      *
062200*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
062300*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
062400*                 CALCULATE ANY COST OUTLIER PORTION          *
062500*                 OF THE PAYMENT.                             *
062600*            07 = PAY-WITHOUT-COST.                           *
062700*                 WILL CALCULATE THE STANDARD PAYMENT         *
062800*                 WITHOUT COST PORTION.                       *
062900*            09 = PAY-XFER-SPEC-DRG - POST-ACUTE TRANSFERS    *
063000*                 FOR DRG'S 209,210,211,014,113,236,          *
063100*                           012,024,025,088,089,090,          *
063200*                           121,122,127,130,131,239,          *
063300*                           277,278,294,296,297,320,          *
063400*                           321,395,468,429,483               *
063500*                               POST-ACUTE TRANSFERS          *
063600*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
063700*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
063800*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
063900*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
064000*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
064100*                 STANDARD PAYMENT IS CALCULATED. WILL ALSO   *
064200*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
064300*                 PAYMENT IF THE ADJUSTED CHARGES ON THE      *
064400*                 BILL EXCEED THE COST THRESHOLD.             *
064500*            11 = PAY-XFER-SPEC-DRG-NO-COST                   *
064600*                 POST-ACUTE TRANSFERS                        *
064700*                 FOR DRG'S 209,210,211,014,113,236,          *
064800*                           012,024,025,088,089,090,          *
064900*                           121,122,127,130,131,239,          *
065000*                           277,278,294,296,297,320,          *
065100*                           321,395,468,429,483               *
065200*                               POST-ACUTE TRANSFERS          *
065300*                 WILL CALCULATE A PERDIEM PAYMENT BASED ON   *
065400*                 THE STANDARD DRG PAYMENT IF THE COVERED DAYS*
065500*                 ARE LESS THAN THE AVERAGE LENGTH OF STAY    *
065600*                 FOR THE DRG. IF COVERED DAYS EQUAL OR       *
065700*                 EXCEED THE AVERAGE LENGTH OF STAY, THE      *
065800*                 STANDARD PAYMENT IS CALCULATED. WILL NOT    *
065900*                 CALCULATE THE COST OUTLIER PORTION OF THE   *
066000*                 PAYMENT.                                    *
066100***************************************************************
066200
066300**************************************************************
066400*      MILLINNIUM COMPATIBLE                                 *
066500*      THIS IS THE BILL-RECORD THAT WILL BE PASSED BACK FROM *
066600*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
066700*      IN THE NEW FORMAT                                     *
066800**************************************************************
066900 01  BILL-NEW-DATA.
067000         10  B-NPI10.
067100             15  B-NPI8             PIC X(08).
067200             15  B-NPI-FILLER       PIC X(02).
067300         10  B-PROVIDER-NO          PIC X(06).
067400             88  SE-AL-PROV           VALUE
067500            '010001' '010005' '010006' '010007' '010008'
067600            '010009' '010010' '010011' '010012' '010015'
067700            '010016' '010018' '010019' '010021' '010022'
067800            '010023' '010024' '010025' '010027' '010029'
067900            '010032' '010033' '010034' '010035' '010038'
068000            '010039' '010040' '010043' '010044' '010045'
068100            '010046' '010049' '010050' '010051' '010053'
068200            '010054' '010055' '010056' '010058' '010059'
068300            '010061' '010062' '010064' '010065' '010066'
068400            '010068' '010072' '010073' '010078' '010079'
068500            '010083' '010084' '010085' '010087' '010089'
068600            '010090' '010091' '010092' '010095' '010098'
068700            '010099' '010100' '010101' '010103' '010104'
068800            '010108' '010109' '010110' '010112' '010113'
068900            '010114' '010115' '010118' '010119' '010120'
069000            '010125' '010126' '010128' '010129' '010130'
069100            '010131' '010137' '010138' '010139' '010143'
069200            '010144' '010145' '010146' '010148' '010149'
069300            '010150' '010152' '010157' '010158' '190013'
069400            '190040' '190045' '190050' '190053' '190060'
069500            '190064' '190086' '190102' '190111' '190113'
069600            '190125' '190242' '250040' '250048' '250050'
069700            '250078' '250082' '250104'.
069800         10  B-REVIEW-CODE          PIC 9(02).
069900             88  VALID-REVIEW-CODE    VALUE 00 03 06 07 09 11.
070000             88  PAY-WITH-OUTLIER     VALUE 00 07.
070100             88  PAY-PERDIEM-DAYS     VALUE 03.
070200             88  PAY-XFER-NO-COST     VALUE 06.
070300             88  PAY-WITHOUT-COST     VALUE 07.
070400             88  PAY-XFER-SPEC-DRG    VALUE 09 11.
070500             88  PAY-XFER-SPEC-DRG-NO-COST VALUE 11.
070600         10  B-DRG                  PIC 9(03).
070700         10  B-LOS                  PIC 9(03).
070800         10  B-COVERED-DAYS         PIC 9(03).
070900         10  B-LTR-DAYS             PIC 9(02).
071000         10  B-DISCHARGE-DATE.
071100             15  B-DISCHG-CC        PIC 9(02).
071200             15  B-DISCHG-YY        PIC 9(02).
071300             15  B-DISCHG-MM        PIC 9(02).
071400             15  B-DISCHG-DD        PIC 9(02).
071500         10  B-CHARGES-CLAIMED      PIC 9(07)V9(02).
071600         10  B-PRIN-PROC-CODE       PIC X(07).
071700         10  B-OTHER-PROC-CODE1     PIC X(07).
071800         10  B-OTHER-PROC-CODE2     PIC X(07).
071900         10  B-OTHER-PROC-CODE3     PIC X(07).
072000         10  B-OTHER-PROC-CODE4     PIC X(07).
072100         10  B-OTHER-PROC-CODE5     PIC X(07).
072200         10  B-OTHER-PROC-CODE6     PIC X(07).
072300         10  B-OTHER-PROC-CODE7     PIC X(07).
072400         10  B-OTHER-PROC-CODE8     PIC X(07).
072500         10  B-OTHER-PROC-CODE9     PIC X(07).
072600         10  B-OTHER-PROC-CODE10    PIC X(07).
072700         10  B-OTHER-PROC-CODE11    PIC X(07).
072800         10  B-OTHER-PROC-CODE12    PIC X(07).
072900         10  B-OTHER-PROC-CODE13    PIC X(07).
073000         10  B-OTHER-PROC-CODE14    PIC X(07).
073100         10  B-OTHER-PROC-CODE15    PIC X(07).
073200         10  B-OTHER-PROC-CODE16    PIC X(07).
073300         10  B-OTHER-PROC-CODE17    PIC X(07).
073400         10  B-OTHER-PROC-CODE18    PIC X(07).
073500         10  B-OTHER-PROC-CODE19    PIC X(07).
073600         10  B-OTHER-PROC-CODE20    PIC X(07).
073700         10  B-OTHER-PROC-CODE21    PIC X(07).
073800         10  B-OTHER-PROC-CODE22    PIC X(07).
073900         10  B-OTHER-PROC-CODE23    PIC X(07).
074000         10  B-OTHER-PROC-CODE24    PIC X(07).
074100         10  B-OTHER-DIAG-CODE1     PIC X(07).
074200         10  B-OTHER-DIAG-CODE2     PIC X(07).
074300         10  B-OTHER-DIAG-CODE3     PIC X(07).
074400         10  B-OTHER-DIAG-CODE4     PIC X(07).
074500         10  B-OTHER-DIAG-CODE5     PIC X(07).
074600         10  B-OTHER-DIAG-CODE6     PIC X(07).
074700         10  B-OTHER-DIAG-CODE7     PIC X(07).
074800         10  B-OTHER-DIAG-CODE8     PIC X(07).
074900         10  B-OTHER-DIAG-CODE9     PIC X(07).
075000         10  B-OTHER-DIAG-CODE10    PIC X(07).
075100         10  B-OTHER-DIAG-CODE11    PIC X(07).
075200         10  B-OTHER-DIAG-CODE12    PIC X(07).
075300         10  B-OTHER-DIAG-CODE13    PIC X(07).
075400         10  B-OTHER-DIAG-CODE14    PIC X(07).
075500         10  B-OTHER-DIAG-CODE15    PIC X(07).
075600         10  B-OTHER-DIAG-CODE16    PIC X(07).
075700         10  B-OTHER-DIAG-CODE17    PIC X(07).
075800         10  B-OTHER-DIAG-CODE18    PIC X(07).
075900         10  B-OTHER-DIAG-CODE19    PIC X(07).
076000         10  B-OTHER-DIAG-CODE20    PIC X(07).
076100         10  B-OTHER-DIAG-CODE21    PIC X(07).
076200         10  B-OTHER-DIAG-CODE22    PIC X(07).
076300         10  B-OTHER-DIAG-CODE23    PIC X(07).
076400         10  B-OTHER-DIAG-CODE24    PIC X(07).
076500         10  B-OTHER-DIAG-CODE25    PIC X(07).
076600         10  BILL-DEMO-DATA.
076700             15  BILL-DEMO-CODE1        PIC X(02).
076800             15  BILL-DEMO-CODE2        PIC X(02).
076900             15  BILL-DEMO-CODE3        PIC X(02).
077000             15  BILL-DEMO-CODE4        PIC X(02).
077100         10  BILL-NDC-DATA.
077200             15  BILL-NDC-NUMBER        PIC X(11).
077300         10  FILLER                     PIC X(73).
077400
077500
077600
077700***************************************************************
077800*    THIS DATA IS CALCULATED BY THIS PPCAL  SUBROUTINE        *
077900*    AND PASSED BACK TO THE CALLING PROGRAM                   *
078000*            RETURN CODE VALUES (PPS-RTC)                     *
078100*                                                             *
078200*            PPS-RTC 00-49 = HOW THE BILL WAS PAID            *
078300*              00 = PAID NORMAL DRG PAYMENT                   *
078400*                                                             *
078500*              01 = PAID AS A DAY-OUTLIER.                    *
078600*                   NOTE:                                     *
078700*                     DAY-OUTLIER NO LONGER BEING PAID        *
078800*                         AS OF 10/01/97                      *
078900*                                                             *
079000*              02 = PAID AS A COST-OUTLIER.                   *
079100*                                                             *
079200*              03 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079300*                   AND INCLUDING THE FULL DRG.               *
079400*              05 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079500*                   AND INCLUDING THE FULL DRG WHICH ALSO     *
079600*                   QUALIFIED FOR A COST OUTLIER PAYMENT.     *
079700*              06 = TRANSFER PAID ON A PERDIEM BASIS UP TO    *
079800*                   AND INCLUDING THE FULL DRG. PROVIDER      *
079900*                   REFUSED COST OUTLIER.                     *
080000*              10 = DRG IS 209, 210 OR 211 AND                *
080100*                   POST-ACUTE TRANSFER                       *
080200*              12 = POST-CAUTE TRANSFER WITH SPECIFIC DRGS    *
080300*                       THE FOLLOWING DRG'S                   *
080400*                 FOR DRG'S             014,113,236,          *
080500*                           012,024,025,088,089,090,          *
080600*                           121,122,127,130,131,239,          *
080700*                           277,278,294,296,297,320,          *
080800*                           321,395,468,429,483               *
080900*              14 = PAID NORMAL DRG PAYMENT WITH              *
081000*                    PERDIEM DAYS = OR > GM  ALOS             *
081100*              16 = PAID AS A COST-OUTLIER WITH               *
081200*                    PERDIEM DAYS = OR > GM  ALOS             *
081300*                                                             *
081400*            PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *
081500*              51 = NO PROVIDER SPECIFIC INFO FOUND           *
081600*              52 = INVALID MSA # IN PROVIDER FILE            *
081700*                   OR INVALID WAGE INDEX                     *
081800*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *
081900*              54 = DRG < 001 OR > 540,                       *
082000*                                       OR = 004 OR = 005     *
082100*                                       OR = 112              *
082200*                                       OR = 214 OR = 215     *
082300*                                       OR = 221 OR = 222     *
082400*                                       OR = 231 OR = 400     *
082500*                                       OR = 434 OR = 435     *
082600*                                       OR = 436 OR = 437     *
082700*                                       OR = 438 OR = 456     *
082800*                                       OR = 457 OR = 458     *
082900*                                       OR = 459 OR = 460     *
083000*                                       OR = 469 OR = 470     *
083100*                                       OR = 472 OR = 474     *
083200*                                       OR = 514              *
083300*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *
083400*                                      OR                     *
083500*                   DISCHARGE DATE < MSA EFF START DATE       *
083600*                   FOR PPS                                   *
083700*                                      OR                     *
083800*                   PROVIDER HAS BEEN TERMINATED ON OR BEFORE *
083900*                   DISCHARGE DATE                            *
084000*              56 = INVALID LENGTH OF STAY                    *
084100*              57 = REVIEW CODE INVALID (NOT 00 03 06 07 09   *
084200*                                        NOT 11)              *
084300*              58 = TOTAL CHARGES NOT NUMERIC                 *
084400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *
084500*                   OR BILL-LTR-DAYS > 60                     *
084600*              62 = INVALID NUMBER OF COVERED DAYS            *
084700*              65 = PAY-CODE NOT = A,B OR C ON PROVIDER       *
084800*                   SPECIFIC FILE FOR CAPITAL                 *
084900*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *
085000*                   OR COST OUTLIER THRESHOLD CALUCULATION    *
085100*              98 = CANNOT PROCESS BILL OLDER THAN 5 YEARS    *
085200***************************************************************
085300 01  PPS-DATA.
085400         10  PPS-RTC                PIC 9(02).
085500         10  PPS-WAGE-INDX          PIC 9(02)V9(04).
085600         10  PPS-OUTLIER-DAYS       PIC 9(03).
085700         10  PPS-AVG-LOS            PIC 9(02)V9(01).
085800         10  PPS-DAYS-CUTOFF        PIC 9(02)V9(01).
085900         10  PPS-OPER-IME-ADJ       PIC 9(06)V9(02).
086000         10  PPS-TOTAL-PAYMENT      PIC 9(07)V9(02).
086100         10  PPS-OPER-HSP-PART      PIC 9(06)V9(02).
086200         10  PPS-OPER-FSP-PART      PIC 9(06)V9(02).
086300         10  PPS-OPER-OUTLIER-PART  PIC 9(07)V9(02).
086400         10  PPS-REG-DAYS-USED      PIC 9(03).
086500         10  PPS-LTR-DAYS-USED      PIC 9(02).
086600         10  PPS-OPER-DSH-ADJ       PIC 9(06)V9(02).
086700         10  PPS-CALC-VERS          PIC X(05).
086800
086900******************************************************************
087000*            THESE ARE THE VERSIONS OF THE PPCAL
087100*           PROGRAMS THAT WILL BE PASSED BACK----
087200*          ASSOCIATED WITH THE BILL BEING PROCESSED
087300******************************************************************
087400 01  PRICER-OPT-VERS-SW.
087500     02  PRICER-OPTION-SW          PIC X(01).
087600         88  ALL-TABLES-PASSED          VALUE 'A'.
087700         88  PROV-RECORD-PASSED         VALUE 'P'.
087800         88  ADDITIONAL-VARIABLES       VALUE 'M'.
087900         88  PC-PRICER                  VALUE 'C'.
088000     02  PPS-VERSIONS.
088100         10  PPDRV-VERSION         PIC X(05).
088200
088300******************************************************************
088400*        THIS IS THE VARIABLES THAT WILL BE PASSED BACK
088500*          ASSOCIATED WITH THE BILL BEING PROCESSED
088600******************************************************************
088700 01  PPS-ADDITIONAL-VARIABLES.
088800     05  PPS-HSP-PCT                PIC 9(01)V9(02).
088900     05  PPS-FSP-PCT                PIC 9(01)V9(02).
089000     05  PPS-NAT-PCT                PIC 9(01)V9(02).
089100     05  PPS-REG-PCT                PIC 9(01)V9(02).
089200     05  PPS-FAC-SPEC-RATE          PIC 9(05)V9(02).
089300     05  PPS-UPDATE-FACTOR          PIC 9(01)V9(05).
089400     05  PPS-DRG-WT                 PIC 9(02)V9(04).
089500     05  PPS-NAT-LABOR              PIC 9(05)V9(02).
089600     05  PPS-NAT-NLABOR             PIC 9(05)V9(02).
089700     05  PPS-REG-LABOR              PIC 9(05)V9(02).
089800     05  PPS-REG-NLABOR             PIC 9(05)V9(02).
089900     05  PPS-OPER-COLA              PIC 9(01)V9(03).
090000     05  PPS-INTERN-RATIO           PIC 9(01)V9(04).
090100     05  PPS-COST-OUTLIER           PIC 9(07)V9(09).
090200     05  PPS-BILL-COSTS             PIC 9(07)V9(09).
090300     05  PPS-DOLLAR-THRESHOLD       PIC 9(07)V9(09).
090400     05  PPS-DSCHG-FRCTN            PIC 9(1)V9999.
090500     05  PPS-DRG-WT-FRCTN           PIC 9(2)V9999.
090600     05  PPS-CAPITAL-VARIABLES.
090700         10  PPS-CAPI-TOTAL-PAY           PIC 9(07)V9(02).
090800         10  PPS-CAPI-HSP                 PIC 9(07)V9(02).
090900         10  PPS-CAPI-FSP                 PIC 9(07)V9(02).
091000         10  PPS-CAPI-OUTLIER             PIC 9(07)V9(02).
091100         10  PPS-CAPI-OLD-HARM            PIC 9(07)V9(02).
091200         10  PPS-CAPI-DSH-ADJ             PIC 9(07)V9(02).
091300         10  PPS-CAPI-IME-ADJ             PIC 9(07)V9(02).
091400         10  PPS-CAPI-EXCEPTIONS          PIC 9(07)V9(02).
091500     05  PPS-CAPITAL2-VARIABLES.
091600         10  PPS-CAPI2-PAY-CODE             PIC X(1).
091700         10  PPS-CAPI2-B-FSP                PIC 9(07)V9(02).
091800         10  PPS-CAPI2-B-OUTLIER            PIC 9(07)V9(02).
091900
092000     05  PPS-OTHER-VARIABLES.
092100         10  PPS-NON-TEMP-RELIEF-PAYMENT    PIC 9(07)V9(02).
092200         10  PPS-NEW-TECH-PAY-ADD-ON        PIC 9(07)V9(02).
092300         10  PPS-LOW-VOL-PAYMENT            PIC 9(07)V9(02).
092400         10  PPS-HVBP-HRR-DATA.
092500             15  PPS-VAL-BASED-PURCH-PARTIPNT PIC X.
092600             15  PPS-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
092700             15  PPS-HOSP-READMISS-REDUCTN    PIC X.
092800             15  PPS-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
092900         10  PPS-OPERATNG-DATA.
093000             15  PPS-MODEL1-BUNDLE-DISPRCNT  PIC V999.
093100             15  PPS-OPER-BASE-DRG-PAY       PIC 9(08)V99.
093200             15  PPS-OPER-HSP-AMT            PIC 9(08)V99.
093300
093400     05  PPS-PC-OTH-VARIABLES.
093500         10  PPS-OPER-DSH                   PIC 9(01)V9(04).
093600         10  PPS-CAPI-DSH                   PIC 9(01)V9(04).
093700         10  PPS-CAPI-HSP-PCT               PIC 9(01)V9(02).
093800         10  PPS-CAPI-FSP-PCT               PIC 9(01)V9(04).
093900         10  PPS-ARITH-ALOS                 PIC 9(02)V9(01).
094000         10  PPS-PR-WAGE-INDEX              PIC 9(02)V9(04).
094100         10  PPS-TRANSFER-ADJ               PIC 9(01)V9(05).
094200         10  PPS-PC-HMO-FLAG                PIC X(01).
094300         10  PPS-PC-COT-FLAG                PIC X(01).
094400         10  PPS-FILLER                     PIC X(0998).
094500
094600**************************************************************
094700*      MILLINNIUM COMPATIBLE                                 *
094800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BACK FROM *
094900*      THE PPCAL001 PROGRAM AND AFTER FOR PROCESSING         *
095000*      IN THE NEW FORMAT                                     *
095100**************************************************************
095200 01  PROV-NEW-HOLD.
095300     02  PROV-NEWREC-HOLD1.
095400         05  P-NEW-NPI10.
095500             10  P-NEW-NPI8             PIC X(08).
095600             10  P-NEW-NPI-FILLER       PIC X(02).
095700         05  P-NEW-PROVIDER-NO.
095800             10  P-NEW-STATE            PIC 9(02).
095900             10  FILLER                 PIC X(04).
096000         05  P-NEW-DATE-DATA.
096100             10  P-NEW-EFF-DATE.
096200                 15  P-NEW-EFF-DT-CC    PIC 9(02).
096300                 15  P-NEW-EFF-DT-YY    PIC 9(02).
096400                 15  P-NEW-EFF-DT-MM    PIC 9(02).
096500                 15  P-NEW-EFF-DT-DD    PIC 9(02).
096600             10  P-NEW-FY-BEGIN-DATE.
096700                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).
096800                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).
096900                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).
097000                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).
097100             10  P-NEW-REPORT-DATE.
097200                 15  P-NEW-REPORT-DT-CC PIC 9(02).
097300                 15  P-NEW-REPORT-DT-YY PIC 9(02).
097400                 15  P-NEW-REPORT-DT-MM PIC 9(02).
097500                 15  P-NEW-REPORT-DT-DD PIC 9(02).
097600             10  P-NEW-TERMINATION-DATE.
097700                 15  P-NEW-TERM-DT-CC   PIC 9(02).
097800                 15  P-NEW-TERM-DT-YY   PIC 9(02).
097900                 15  P-NEW-TERM-DT-MM   PIC 9(02).
098000                 15  P-NEW-TERM-DT-DD   PIC 9(02).
098100         05  P-NEW-WAIVER-CODE          PIC X(01).
098200             88  P-NEW-WAIVER-STATE       VALUE 'Y'.
098300         05  P-NEW-INTER-NO             PIC 9(05).
098400         05  P-NEW-PROVIDER-TYPE        PIC X(02).
098500             88  P-N-SOLE-COMMUNITY-PROV    VALUE '01' '11'.
098600             88  P-N-REFERRAL-CENTER        VALUE '07' '11'
098700                                                  '15' '17'
098800                                                  '22'.
098900             88  P-N-INDIAN-HEALTH-SERVICE  VALUE '08'.
099000             88  P-N-REDESIGNATED-RURAL-YR1 VALUE '09'.
099100             88  P-N-REDESIGNATED-RURAL-YR2 VALUE '10'.
099200             88  P-N-SOLE-COM-REF-CENT      VALUE '11'.
099300             88  P-N-MDH-REBASED-FY90       VALUE '14' '15'.
099400             88  P-N-MDH-RRC-REBASED-FY90   VALUE '15'.
099500             88  P-N-SCH-REBASED-FY90       VALUE '16' '17'.
099600             88  P-N-SCH-RRC-REBASED-FY90   VALUE '17'.
099700             88  P-N-MEDICAL-ASSIST-FACIL   VALUE '18'.
099800             88  P-N-EACH                   VALUE '21' '22'.
099900             88  P-N-EACH-REFERRAL-CENTER   VALUE '22'.
100000             88  P-N-NHCMQ-II-SNF           VALUE '32'.
100100             88  P-N-NHCMQ-III-SNF          VALUE '33'.
100200         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
100300             88  P-N-NEW-ENGLAND            VALUE  1.
100400             88  P-N-MIDDLE-ATLANTIC        VALUE  2.
100500             88  P-N-SOUTH-ATLANTIC         VALUE  3.
100600             88  P-N-EAST-NORTH-CENTRAL     VALUE  4.
100700             88  P-N-EAST-SOUTH-CENTRAL     VALUE  5.
100800             88  P-N-WEST-NORTH-CENTRAL     VALUE  6.
100900             88  P-N-WEST-SOUTH-CENTRAL     VALUE  7.
101000             88  P-N-MOUNTAIN               VALUE  8.
101100             88  P-N-PACIFIC                VALUE  9.
101200         05  P-NEW-CURRENT-DIV   REDEFINES
101300                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).
101400             88  P-N-VALID-CENSUS-DIV    VALUE 1 THRU 9.
101500         05  P-NEW-MSA-DATA.
101600             10  P-NEW-CHG-CODE-INDEX       PIC X.
101700             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT.
101800             10  P-NEW-GEO-LOC-MSA9   REDEFINES
101900                             P-NEW-GEO-LOC-MSAX  PIC 9(04).
102000             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT.
102100             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT.
102200             10  P-NEW-STAND-AMT-LOC-MSA9
102300       REDEFINES P-NEW-STAND-AMT-LOC-MSA.
102400                 15  P-NEW-RURAL-1ST.
102500                     20  P-NEW-STAND-RURAL  PIC XX.
102600                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.
102700                 15  P-NEW-RURAL-2ND        PIC XX.
102800         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.
102900                 88  P-NEW-SCH-YRBLANK    VALUE   '  '.
103000                 88  P-NEW-SCH-YR82       VALUE   '82'.
103100                 88  P-NEW-SCH-YR87       VALUE   '87'.
103200         05  P-NEW-LUGAR                    PIC X.
103300         05  P-NEW-TEMP-RELIEF-IND          PIC X.
103400         05  P-NEW-FED-PPS-BLEND-IND        PIC X.
103500         05  FILLER                         PIC X(05).
103600     02  PROV-NEWREC-HOLD2.
103700         05  P-NEW-VARIABLES.
103800             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).
103900             10  P-NEW-COLA              PIC  9(01)V9(03).
104000             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).
104100             10  P-NEW-BED-SIZE          PIC  9(05).
104200             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).
104300             10  P-NEW-CMI               PIC  9(01)V9(04).
104400             10  P-NEW-SSI-RATIO         PIC  V9(04).
104500             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).
104600             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).
104700             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).
104800             10  P-NEW-DSH-PERCENT       PIC  V9(04).
104900             10  P-NEW-FYE-DATE          PIC  X(08).
105000         05  FILLER                      PIC  X(23).
105100     02  PROV-NEWREC-HOLD3.
105200         05  P-NEW-PASS-AMT-DATA.
105300             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.
105400             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.
105500             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.
105600             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.
105700         05  P-NEW-CAPI-DATA.
105800             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.
105900             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.
106000             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.
106100             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.
106200             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.
106300             15  P-NEW-CAPI-NEW-HOSP       PIC X.
106400             15  P-NEW-CAPI-IME            PIC 9V9999.
106500             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.
106600         05  P-HVBP-HRR-DATA.
106700             15  P-VAL-BASED-PURCH-PARTIPNT PIC X.
106800             15  P-VAL-BASED-PURCH-ADJUST   PIC 9V9(11).
106900             15  P-HOSP-READMISSION-REDUCTN PIC X.
107000             15  P-HOSP-HRR-ADJUSTMT        PIC 9V9(4).
107100         05  P-MODEL1-BUNDLE-DATA.
107200             15  P-MODEL1-BUNDLE-DISPRCNT   PIC V999.
107300             15  P-HAC-REDUC-IND            PIC X.
107400             15  P-UNCOMP-CARE-AMOUNT       PIC 9(07)V99.
107500             15  P-EHR-REDUC-IND            PIC X.
107600         05  FILLER                         PIC X(09).
107700
107800************************************************************
107900******************************************************************
108000*      MILLINNIUM COMPATIBLE
108100*                   THIS IS THE WAGE-INDEX
108200*          ASSOCIATED WITH THE BILL BEING PROCESSED
108300******************************************************************
108400 01  WAGE-NEW-INDEX-RECORD.
108500     05  W-MSA                         PIC X(4).
108600     05  W-SIZE                        PIC X.
108700         88  LARGE-URBAN       VALUE 'L'.
108800         88  OTHER-URBAN       VALUE 'O'.
108900         88  ALL-RURAL         VALUE 'R'.
109000     05  W-EFF-DATE                    PIC X(8).
109100     05  FILLER                        PIC X.
109200     05  W-INDEX-RECORD                PIC S9(02)V9(04).
109300     05  W-PR-INDEX-RECORD             PIC S9(02)V9(04).
109400
109500
109600 PROCEDURE DIVISION  USING BILL-NEW-DATA
109700                           PPS-DATA
109800                           PRICER-OPT-VERS-SW
109900                           PPS-ADDITIONAL-VARIABLES
110000                           PROV-NEW-HOLD
110100                           WAGE-NEW-INDEX-RECORD.
110200
110300***************************************************************
110400*    PROCESSING:                                              *
110500*        A. WILL PROCESS CASES BASED ON DISCHARGE DATE
110600*        B. INITIALIZE PPCAL  HOLD VARIABLES.                 *
110700*        C. EDIT THE DATA PASSED FROM THE BILL BEFORE         *
110800*           ATTEMPTING TO CALCULATE PPS. IF THIS BILL         *
110900*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *
111000*           GOBACK.                                           *
111100*        D. ASSEMBLE PRICING COMPONENTS.                      *
111200*        E. CALCULATE THE PRICE.                              *
111300***************************************************************
111400
111500     MOVE ZEROES TO NON-TEMP-RELIEF-PAYMENT.
111600     MOVE 'N' TO TEMP-RELIEF-FLAG.
111700
111800     PERFORM 0200-MAINLINE-CONTROL.
111900
112000     MOVE HOLD-ADDITIONAL-VARIABLES TO  PPS-ADDITIONAL-VARIABLES.
112100     MOVE H-DSCHG-FRCTN             TO  PPS-DSCHG-FRCTN.
112200     MOVE H-DRG-WT-FRCTN            TO  PPS-DRG-WT-FRCTN.
112300     MOVE HOLD-CAPITAL-VARIABLES    TO  PPS-CAPITAL-VARIABLES.
112400     MOVE HOLD-CAPITAL2-VARIABLES   TO  PPS-CAPITAL2-VARIABLES.
112500     MOVE CAL-VERSION               TO  PPS-CALC-VERS.
112600     MOVE HOLD-OTHER-VARIABLES      TO  PPS-OTHER-VARIABLES.
112700     MOVE HOLD-PC-OTH-VARIABLES     TO  PPS-PC-OTH-VARIABLES.
112800
112900     GOBACK.
113000
113100 0200-MAINLINE-CONTROL.
113200
113300     MOVE 'N' TO HMO-TAG.
113400
113500     IF PPS-PC-HMO-FLAG = 'Y' OR
113600               HMO-FLAG = 'Y'
113700        MOVE 'Y' TO HMO-TAG.
113800
113900     IF P-NEW-STATE NOT = 40
114000        MOVE ZEROES TO W-PR-INDEX-RECORD.
114100
114200     MOVE ALL '0' TO PPS-DATA
114300                     H-OPER-DSH-SCH
114400                     H-OPER-DSH-RRC
114500                     HOLD-PPS-COMPONENTS
114600                     HOLD-PPS-COMPONENTS
114700                     HOLD-ADDITIONAL-VARIABLES
114800                     HOLD-CAPITAL-VARIABLES
114900                     HOLD-CAPITAL2-VARIABLES
115000                     HOLD-OTHER-VARIABLES
115100                     HOLD-PC-OTH-VARIABLES.
115200
115300     IF P-NEW-CAPI-HOSP-SPEC-RATE NOT NUMERIC
115400        MOVE 0 TO P-NEW-CAPI-HOSP-SPEC-RATE.
115500
115600     IF P-NEW-CAPI-OLD-HARM-RATE  NOT NUMERIC
115700        MOVE 0 TO P-NEW-CAPI-OLD-HARM-RATE.
115800
115900     IF P-NEW-CAPI-NEW-HARM-RATIO NOT NUMERIC
116000        MOVE 0 TO P-NEW-CAPI-NEW-HARM-RATIO.
116100
116200     IF P-NEW-CAPI-CSTCHG-RATIO NOT NUMERIC
116300        MOVE 0 TO P-NEW-CAPI-CSTCHG-RATIO.
116400
116500     PERFORM 1000-EDIT-THE-BILL-INFO.
116600
116700     IF  PPS-RTC = 00
116800         PERFORM 2000-ASSEMBLE-PPS-VARIABLES
116900         PERFORM 3000-CALC-PAYMENT THRU 3000-EXIT.
117000
117100     IF PPS-RTC = 00
117200        IF H-PERDIEM-DAYS = H-ALOS OR
117300           H-PERDIEM-DAYS > H-ALOS
117400           MOVE 14 TO PPS-RTC.
117500
117600     IF PPS-RTC = 02
117700        IF H-PERDIEM-DAYS = H-ALOS OR
117800           H-PERDIEM-DAYS > H-ALOS
117900           MOVE 16 TO PPS-RTC.
118000
118100 1000-EDIT-THE-BILL-INFO.
118200***************************************************************
118300*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *
118400*    AND DO NOT ATTEMPT TO PRICE.                             *
118500***************************************************************
118600
118700     MOVE 1.00 TO H-CAPI-PAYCDE-PCT1.
118800     MOVE 0.00 TO H-CAPI-PAYCDE-PCT2.
118900
119000     IF  PPS-RTC = 00
119100         IF  P-NEW-WAIVER-STATE
119200             MOVE 53 TO PPS-RTC.
119300
119400     IF  PPS-RTC = 00
119500         IF  B-DRG < 001 OR > 540
119600                                  OR = 004 OR = 005
119700                                  OR = 112
119800                                  OR = 214 OR = 215
119900                                  OR = 221 OR = 222
120000                                  OR = 231 OR = 400
120100                                  OR = 434 OR = 435
120200                                  OR = 436 OR = 437
120300                                  OR = 438 OR = 456
120400                                  OR = 457 OR = 458
120500                                  OR = 459 OR = 460
120600                                  OR = 469 OR = 470
120700                                  OR = 472 OR = 474
120800                                  OR = 514
120900             MOVE 54 TO PPS-RTC.
121000
121100     IF  PPS-RTC = 00
121200            IF  ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR
121300                 (B-DISCHARGE-DATE < W-EFF-DATE))
121400                MOVE 55 TO PPS-RTC.
121500
121600     IF  PPS-RTC = 00
121700         IF P-NEW-TERMINATION-DATE > 00000000
121800            IF  ((B-DISCHARGE-DATE = P-NEW-TERMINATION-DATE) OR
121900                 (B-DISCHARGE-DATE > P-NEW-TERMINATION-DATE))
122000                  MOVE 55 TO PPS-RTC.
122100
122200     IF  PPS-RTC = 00
122300         IF  B-LOS NOT NUMERIC
122400             MOVE 56 TO PPS-RTC
122500         ELSE
122600         IF  B-LOS = 0
122700             IF B-REVIEW-CODE NOT = 00 AND
122800                              NOT = 03 AND
122900                              NOT = 06 AND
123000                              NOT = 07 AND
123100                              NOT = 09 AND
123200                              NOT = 11
123300             MOVE 56 TO PPS-RTC.
123400
123500     IF  PPS-RTC = 00
123600         IF  B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60
123700             MOVE 61 TO PPS-RTC
123800         ELSE
123900             MOVE B-LTR-DAYS TO H-LTR-DAYS.
124000
124100     IF  PPS-RTC = 00
124200         IF  B-COVERED-DAYS NOT NUMERIC
124300             MOVE 62 TO PPS-RTC
124400         ELSE
124500         IF  B-COVERED-DAYS = 0 AND B-LOS > 0
124600             MOVE 62 TO PPS-RTC
124700         ELSE
124800             MOVE B-COVERED-DAYS TO H-COV-DAYS.
124900
125000     IF  PPS-RTC = 00
125100         IF  H-LTR-DAYS  > H-COV-DAYS
125200             MOVE 62 TO PPS-RTC
125300         ELSE
125400             COMPUTE H-REG-DAYS = H-COV-DAYS - H-LTR-DAYS.
125500
125600     IF  PPS-RTC = 00
125700         IF  NOT VALID-REVIEW-CODE
125800             MOVE 57 TO PPS-RTC.
125900
126000     IF  PPS-RTC = 00
126100         IF  B-CHARGES-CLAIMED NOT NUMERIC
126200             MOVE 58 TO PPS-RTC.
126300
126400     IF PPS-RTC = 00
126500           IF P-NEW-CAPI-NEW-HOSP NOT = 'Y'
126600                 IF P-NEW-CAPI-PPS-PAY-CODE NOT = 'A' AND
126700                                            NOT = 'B' AND
126800                                            NOT = 'C'
126900                 MOVE 65 TO PPS-RTC.
127000
127100 2000-ASSEMBLE-PPS-VARIABLES.
127200***************************************************************
127300*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *
127400*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *
127500*    OF THAT VARIABLE.                                        *
127600***************************************************************
127700***  GET THE PROVIDER SPECIFIC VARIABLES.
127800***  GET THE PROVIDER SPECIFIC VARIABLES.
127900
128000     MOVE P-NEW-FAC-SPEC-RATE TO H-FAC-SPEC-RATE.
128100     MOVE P-NEW-INTERN-RATIO TO H-INTERN-RATIO.
128200
128300     IF  (P-NEW-STATE = 02 OR 12)
128400         MOVE P-NEW-COLA TO H-OPER-COLA
128500     ELSE
128600         MOVE 1.000  TO H-OPER-COLA.
128700
128800***************************************************************
128900***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
129000***  GET THE DRG RELATIVE WEIGHTS, ALOS, DAYS CUTOFF
129100
129200     PERFORM 2600-GET-DRG-WEIGHT
129300             VARYING DX5 FROM 1 BY 1 UNTIL DX5 > 1.
129400
129500***************************************************************
129600***  GET THE WAGE-INDEX
129700***  GET THE WAGE-INDEX
129800
129900     MOVE W-INDEX-RECORD TO H-WAGE-INDEX.
130000     MOVE W-PR-INDEX-RECORD TO H-PR-WAGE-INDEX.
130100
130200***************************************************************
130300***  GET THE LABOR, NON-LABOR STANDARD RATES
130400
130500     IF  P-NEW-STATE = 40
130600         MOVE 2 TO R2
130700         MOVE 3 TO R4
130800     ELSE
130900         MOVE 1 TO R2
131000         MOVE 1 TO R4.
131100
131200     IF  LARGE-URBAN
131300         MOVE 1 TO R3
131400     ELSE
131500         MOVE 2 TO R3.
131600
131700     IF B-DISCHARGE-DATE < 20031101
131800        PERFORM 2300-GET-LABOR-NLABOR-RATES
131900             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
132000
132100     IF (B-DISCHARGE-DATE > 20031031 AND
132200         B-DISCHARGE-DATE < 20040401)
132300        PERFORM 2350-GET-LABOR-NLABOR-RATES2
132400             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
132500
132600     IF B-DISCHARGE-DATE > 20040331
132700        PERFORM 2360-GET-LABOR-NLABOR-RATES3
132800             VARYING R1 FROM 1 BY 1 UNTIL R1 > 1.
132900
133000      IF SE-AL-PROV
133100      COMPUTE H-TOT-REG-AL ROUNDED = H-REG-LABOR + H-REG-NONLABOR
133200      COMPUTE H-TOT-NAT-AL ROUNDED = H-NAT-LABOR + H-NAT-NONLABOR
133300      COMPUTE H-REG-LABOR ROUNDED  = H-TOT-REG-AL * 0.7079
133400      COMPUTE H-NAT-LABOR ROUNDED  = H-TOT-NAT-AL * 0.7079
133500      COMPUTE H-REG-NONLABOR ROUNDED = H-TOT-REG-AL * 0.2921
133600      COMPUTE H-NAT-NONLABOR ROUNDED = H-TOT-NAT-AL * 0.2921.
133700
133800***************************************************************
133900***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
134000***  GET THE HSP & FSP BLEND PERCENTS FOR THIS BILL
134100
134200     MOVE 0.00  TO H-OPER-HSP-PCT.
134300     MOVE 1.00  TO H-OPER-FSP-PCT.
134400
134500***************************************************************
134600***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
134700***  GET THE NATIONAL & REGIONAL BLEND PERCENTS FOR THIS BILL
134800
134900      MOVE 1.00 TO H-NAT-PCT.
135000      MOVE 0.00 TO H-REG-PCT.
135100
135200     IF  P-NEW-STATE = 40
135300         MOVE 0.50 TO H-NAT-PCT
135400         MOVE 0.50 TO H-REG-PCT
135500         IF B-DISCHARGE-DATE > 20040331
135600            MOVE 0.63 TO H-NAT-PCT
135700            MOVE 0.37 TO H-REG-PCT.
135800
135900     IF  P-N-SCH-REBASED-FY90 OR
136000         P-N-EACH OR
136100         P-N-MDH-REBASED-FY90
136200         MOVE 1.00 TO H-OPER-HSP-PCT.
136300
136400 2300-GET-LABOR-NLABOR-RATES.
136500
136600     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE (R1)
136700         MOVE REG-LABOR  (R1 R2 R3) TO H-REG-LABOR
136800         MOVE REG-NLABOR (R1 R2 R3) TO H-REG-NONLABOR
136900         MOVE REG-LABOR  (R1 R4 R3) TO H-NAT-LABOR
137000         MOVE REG-NLABOR (R1 R4 R3) TO H-NAT-NONLABOR.
137100
137200
137300 2350-GET-LABOR-NLABOR-RATES2.
137400
137500     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE2 (R1)
137600         MOVE REG-LABOR2  (R1 R2 R3) TO H-REG-LABOR
137700         MOVE REG-NLABOR2 (R1 R2 R3) TO H-REG-NONLABOR
137800         MOVE REG-LABOR2  (R1 R4 R3) TO H-NAT-LABOR
137900         MOVE REG-NLABOR2 (R1 R4 R3) TO H-NAT-NONLABOR.
138000
138100 2360-GET-LABOR-NLABOR-RATES3.
138200
138300     IF  B-DISCHARGE-DATE NOT < RATE-EFF-DATE3 (R1)
138400         MOVE REG-LABOR3  (R1 R2 R3) TO H-REG-LABOR
138500         MOVE REG-NLABOR3 (R1 R2 R3) TO H-REG-NONLABOR
138600         MOVE REG-LABOR3  (R1 R4 R3) TO H-NAT-LABOR
138700         MOVE REG-NLABOR3 (R1 R4 R3) TO H-NAT-NONLABOR.
138800
138900 2600-GET-DRG-WEIGHT.
139000
139100     IF  B-DISCHARGE-DATE NOT < DRGX-EFF-DATE (DX5)
139200         SET DX6 TO B-DRG
139300         MOVE DRG-WT (DX5 DX6)         TO H-DRG-WT
139400         MOVE DRG-ALOS (DX5 DX6)       TO H-ALOS
139500*****    MOVE DRG-DAYS-TRIM (DX5 DX6)  TO H-DAYS-CUTOFF
139600         MOVE ZEROES                   TO H-DAYS-CUTOFF
139700         MOVE DRG-ARITH-ALOS (DX5 DX6) TO H-ARITH-ALOS.
139800
139900 3000-CALC-PAYMENT.
140000***************************************************************
140100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *
140200*        CALCULATE THE STAY UTILIZATION.                      *
140300*        CALCULATE THE FEDERAL PORTION.                       *
140400*        CALCULATE THE HOSPITAL PORTION.                      *
140500*        CALCULATE THE COST-OUTLIER PORTION.                  *
140600*        CALCULATE THE TOTAL PAYMENT OPERATING AND CAPITAL    *
140700*        CALCULATE THE DSH ADJUSTMENT.                        *
140800*        CALCULATE THE IME TEACHING.                          *
140900***************************************************************
141000
141100     PERFORM 3100-CALC-STAY-UTILIZATION.
141200     PERFORM 3300-CALC-OPER-FSP-AMT.
141300
141400     IF B-DISCHARGE-DATE > 20040331
141500        PERFORM 3900A-CALC-OPER-DSH THRU 3900A-EXIT
141600     ELSE
141700        PERFORM 3900-CALC-OPER-DSH THRU 3900-EXIT.
141800
141900***********************************************************
142000***  OPERATING IME CALCULATION
142100***  OPERATING IME CALCULATION
142200
142300     IF B-DISCHARGE-DATE > 20040331
142400         COMPUTE H-OPER-IME-TEACH ROUNDED =
142500            1.47 * ((1 + H-INTERN-RATIO) ** .405  - 1)
142600     ELSE
142700         COMPUTE H-OPER-IME-TEACH ROUNDED =
142800            1.35 * ((1 + H-INTERN-RATIO) ** .405  - 1).
142900
143000***********************************************************
143100
143200     IF P-N-SCH-REBASED-FY90 OR
143300        P-N-EACH OR
143400        P-N-MDH-REBASED-FY90
143500         PERFORM 3450-CALC-ADDITIONAL-HSP.
143600
143700     MOVE 00                 TO  PPS-RTC.
143800     MOVE H-WAGE-INDEX       TO  PPS-WAGE-INDX.
143900     MOVE H-ALOS             TO  PPS-AVG-LOS.
144000     MOVE H-DAYS-CUTOFF      TO  PPS-DAYS-CUTOFF.
144100
144200     MOVE B-LOS TO H-PERDIEM-DAYS.
144300     IF H-PERDIEM-DAYS < 1
144400         MOVE 1 TO H-PERDIEM-DAYS.
144500     ADD 1 TO H-PERDIEM-DAYS.
144600
144700     MOVE 1 TO H-DSCHG-FRCTN.
144800
144900     COMPUTE H-DRG-WT-FRCTN ROUNDED = H-DSCHG-FRCTN * H-DRG-WT.
145000
145100     IF  (PAY-PERDIEM-DAYS OR
145200          PAY-XFER-NO-COST) OR
145300       (PAY-XFER-SPEC-DRG AND (B-DRG = 014 OR 113 OR 236 OR
145400                                       012 OR 024 OR 025 OR
145500                                       088 OR 089 OR 090 OR
145600                                       121 OR 122 OR 127 OR
145700                                       130 OR 131 OR 239 OR
145800                                       277 OR 278 OR 294 OR
145900                                       296 OR 297 OR 320 OR
146000                                       321 OR 395 OR 468 OR
146100                                       429 OR 483))
146200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
146300         COMPUTE H-DSCHG-FRCTN  ROUNDED = H-PERDIEM-DAYS / H-ALOS
146400         IF H-DSCHG-FRCTN > 1
146500              MOVE 1 TO H-DSCHG-FRCTN
146600              MOVE 1 TO H-TRANSFER-ADJ
146700         ELSE
146800              COMPUTE H-DRG-WT-FRCTN ROUNDED =
146900                  (H-PERDIEM-DAYS / H-ALOS) * H-DRG-WT.
147000
147100     IF (PAY-XFER-SPEC-DRG AND (B-DRG = 209 OR 210 OR 211))
147200         COMPUTE H-TRANSFER-ADJ ROUNDED = H-PERDIEM-DAYS / H-ALOS
147300         COMPUTE H-DSCHG-FRCTN  ROUNDED =
147400                        .5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)
147500         IF H-DSCHG-FRCTN > 1
147600              MOVE 1 TO H-DSCHG-FRCTN
147700              MOVE 1 TO H-TRANSFER-ADJ
147800         ELSE
147900              COMPUTE H-DRG-WT-FRCTN ROUNDED =
148000            (.5 + ((.5 * H-PERDIEM-DAYS) / H-ALOS)) * H-DRG-WT.
148100
148200
148300***********************************************************
148400***  CAPITAL DSH CALCULATION
148500***  CAPITAL DSH CALCULATION
148600
148700     MOVE 0 TO H-CAPI-DSH.
148800
148900     IF P-NEW-BED-SIZE NOT NUMERIC
149000         MOVE 0 TO P-NEW-BED-SIZE.
149100
149200     IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
149300         COMPUTE H-CAPI-DSH ROUNDED = 2.7183 **
149400                  (.2025 * (P-NEW-SSI-RATIO
149500                          + P-NEW-MEDICAID-RATIO)) - 1.
149600
149700***********************************************************
149800***  CAPITAL IME TEACH CALCULATION
149900***  CAPITAL IME TEACH CALCULATION
150000
150100     MOVE 0 TO H-WK-CAPI-IME-TEACH.
150200
150300     IF P-NEW-CAPI-IME NUMERIC
150400        IF P-NEW-CAPI-IME > 1.5000
150500           MOVE 1.5000 TO P-NEW-CAPI-IME.
150600
150700     IF P-NEW-CAPI-IME NUMERIC
150800        COMPUTE H-WK-CAPI-IME-TEACH ROUNDED =
150900          (2.7183 ** (.2822 * P-NEW-CAPI-IME)) - 1.
151000
151100***********************************************************
151200******************************************************************
151300***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
151400***  NO LONGER PAYING DAY-OUTLIERS     AS OF 10/01/97
151500***  ZEROED OUT THE H-DAYOUT-PCT FIELD AS OF 10/01/97
151600
151700     MOVE 0.00 TO H-DAYOUT-PCT.
151800******************************************************************
151900
152000     MOVE 0.80 TO H-CSTOUT-PCT.
152100
152200******************************************************************
152300*****THESE ARE BURNS DRG'S
152400     IF  B-DRG = 504 OR 505 OR 506 OR 507 OR 508 OR
152500                 509 OR 510 OR 511
152600             MOVE 0.90 TO H-CSTOUT-PCT.
152700
152800***     NATIONAL PERCENTAGE
152900     MOVE 0.7110   TO H-LABOR-PCT.
153000     MOVE 0.2890   TO H-NONLABOR-PCT.
153100
153200***     PUERTO RICO PERCENTAGE
153300     MOVE 0.7130   TO H-PR-LABOR-PCT.
153400     MOVE 0.2870   TO H-PR-NONLABOR-PCT.
153500
153600     IF  P-NEW-OPER-CSTCHG-RATIO NUMERIC
153700             MOVE P-NEW-OPER-CSTCHG-RATIO TO H-OPER-CSTCHG-RATIO
153800     ELSE
153900             MOVE 0.000 TO H-OPER-CSTCHG-RATIO.
154000
154100     IF P-NEW-CAPI-CSTCHG-RATIO NUMERIC
154200             MOVE P-NEW-CAPI-CSTCHG-RATIO TO H-CAPI-CSTCHG-RATIO
154300     ELSE
154400             MOVE 0.000 TO H-CAPI-CSTCHG-RATIO.
154500
154600     IF SE-AL-PROV
154700     MOVE 0.7079   TO H-LABOR-PCT
154800     MOVE 0.2921   TO H-NONLABOR-PCT.
154900***********************************************************
155000***********************************************************
155100***  CAPITAL PAYMENT METHOD B
155200***  CAPITAL PAYMENT METHOD B
155300
155400     IF W-SIZE = 'L'
155500        MOVE 1.03 TO H-CAPI-LARG-URBAN
155600     ELSE
155700        MOVE 1.00 TO H-CAPI-LARG-URBAN.
155800
155900     COMPUTE H-CAPI-GAF    ROUNDED = (H-WAGE-INDEX ** .6848).
156000     COMPUTE H-PR-CAPI-GAF ROUNDED = (H-PR-WAGE-INDEX ** .6848).
156100
156200     IF B-DISCHARGE-DATE > 20040331
156300        COMPUTE H-FEDERAL-RATE ROUNDED =
156400                                 (0413.48 * H-CAPI-GAF)
156500        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
156600                                 (0202.96 * H-PR-CAPI-GAF)
156700     ELSE
156800        COMPUTE H-FEDERAL-RATE ROUNDED =
156900                                 (0414.18 * H-CAPI-GAF)
157000        COMPUTE H-PUERTO-RICO-RATE ROUNDED =
157100                                 (0203.17 * H-PR-CAPI-GAF).
157200
157300     COMPUTE H-CAPI-COLA ROUNDED =
157400                     (.3152 * (H-OPER-COLA - 1) + 1).
157500
157600     MOVE H-FEDERAL-RATE TO H-CAPI-FED-RATE.
157700
157800     IF P-NEW-STATE = 40
157900        COMPUTE  H-CAPI-FED-RATE ROUNDED =
158000                 (H-NAT-PCT * H-FEDERAL-RATE) +
158100                 (H-REG-PCT * H-PUERTO-RICO-RATE)
158200        IF B-DISCHARGE-DATE > 20040331
158300            COMPUTE  H-CAPI-FED-RATE ROUNDED =
158400                    (.625 * H-FEDERAL-RATE) +
158500                    (.375 * H-PUERTO-RICO-RATE).
158600***********************************************************
158700***  NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001
158800***  CAPITAL HSP CALCULATION
158900***  CAPITAL HSP CALCULATION
159000*
159100*    IF B-DISCHARGE-DATE > 20010331
159200*        MOVE 1.0149 TO H-HSP-UPDATE01
159300*    ELSE
159400*        MOVE 1.0147 TO H-HSP-UPDATE01.
159500*
159600*    COMPUTE H-ACCUM-TO-HSP ROUNDED = H-HSP-UPDATE01.
159700*
159800*    COMPUTE H-CAPI-HSP-PART ROUNDED = (H-DRG-WT *
159900*                  P-NEW-CAPI-HOSP-SPEC-RATE * H-ACCUM-TO-HSP).
160000***********************************************************
160100
160200***********************************************************
160300***  CAPITAL FSP CALCULATION
160400***  CAPITAL FSP CALCULATION
160500
160600     COMPUTE H-CAPI-FSP-PART ROUNDED =
160700                               H-DRG-WT * H-CAPI-FED-RATE *
160800                               H-CAPI-COLA *
160900                               H-CAPI-LARG-URBAN.
161000
161100***********************************************************
161200***  CAPITAL PAYMENT METHOD A
161300***  CAPITAL PAYMENT METHOD A
161400
161500     IF P-N-SCH-REBASED-FY90 OR P-N-EACH
161600        MOVE 1.00 TO H-CAPI-SCH
161700     ELSE
161800        MOVE 0.85 TO H-CAPI-SCH.
161900
162000***********************************************************
162100***********  CAPITAL OLD-HARMLESS CALCULATION ***********
162200***********  CAPITAL OLD-HARMLESS CALCULATION ***********
162300
162400     COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
162500                    (P-NEW-CAPI-OLD-HARM-RATE *
162600                    H-CAPI-SCH).
162700
162800***********************************************************
162900        IF PAY-PERDIEM-DAYS
163000            IF  H-PERDIEM-DAYS < H-ALOS
163100                IF  NOT (B-DRG = 385)
163200                    PERFORM 3500-CALC-PERDIEM-AMT
163300                    MOVE 03 TO PPS-RTC.
163400
163500        IF PAY-XFER-SPEC-DRG
163600            IF  H-PERDIEM-DAYS < H-ALOS
163700                IF  NOT (B-DRG = 385)
163800                    PERFORM 3550-CALC-PERDIEM-AMT.
163900
164000        IF  PAY-XFER-NO-COST
164100            MOVE 00 TO PPS-RTC
164200            IF H-PERDIEM-DAYS < H-ALOS
164300               IF  NOT (B-DRG = 385)
164400                   PERFORM 3500-CALC-PERDIEM-AMT
164500                   MOVE 06 TO PPS-RTC.
164600
164700     PERFORM 4000-CALC-TECH-ADDON THRU 4000-EXIT.
164800
164900     PERFORM 3600-CALC-OUTLIER THRU 3600-EXIT.
165000
165100     IF PPS-RTC = 67  GO TO 3000-CONTINUE.
165200
165300        IF PAY-XFER-SPEC-DRG
165400            IF  H-PERDIEM-DAYS < H-ALOS
165500                IF  NOT (B-DRG = 385)
165600                    PERFORM 3560-CHECK-RTN-CODE THRU 3560-EXIT.
165700
165800
165900        IF  PAY-PERDIEM-DAYS
166000            IF  H-OPER-OUTCST-PART > 0
166100                MOVE H-OPER-OUTCST-PART TO
166200                     H-OPER-OUTLIER-PART
166300                MOVE 05 TO PPS-RTC
166400            ELSE
166500            IF  PPS-RTC NOT = 03
166600                MOVE 00 TO PPS-RTC
166700                MOVE 0  TO H-OPER-OUTLIER-PART.
166800
166900        IF  PAY-PERDIEM-DAYS
167000            IF  H-CAPI-OUTCST-PART > 0
167100                MOVE H-CAPI-OUTCST-PART TO
167200                     H-CAPI-OUTLIER-PART
167300                MOVE 05 TO PPS-RTC
167400            ELSE
167500            IF  PPS-RTC NOT = 03
167600                MOVE 0  TO H-CAPI-OUTLIER-PART.
167700
167800
167900 3000-CONTINUE.
168000
168100***********************************************************
168200***  DETERMINES THE FEDERAL AMOUNT THAT WOULD BE PAID IF
168300***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
168400
168500     COMPUTE H-CAPI2-B-FSP-PART ROUNDED = H-CAPI-FSP-PART.
168600
168700***********************************************************
168800
168900     IF  PPS-RTC = 67
169000         MOVE H-OPER-DOLLAR-THRESHOLD TO
169100              WK-H-OPER-DOLLAR-THRESHOLD.
169200
169300     IF  PPS-RTC < 50
169400         PERFORM 3800-CALC-TOT-AMT
169500     ELSE
169600         MOVE ALL '0' TO PPS-OPER-HSP-PART
169700                         PPS-OPER-FSP-PART
169800                         PPS-OPER-OUTLIER-PART
169900                         PPS-OUTLIER-DAYS
170000                         PPS-REG-DAYS-USED
170100                         PPS-LTR-DAYS-USED
170200                         PPS-TOTAL-PAYMENT
170300                         PPS-OPER-DSH-ADJ
170400                         PPS-OPER-IME-ADJ
170500                         H-DSCHG-FRCTN
170600                         H-DRG-WT-FRCTN
170700                         HOLD-ADDITIONAL-VARIABLES
170800                         HOLD-CAPITAL-VARIABLES
170900                         HOLD-CAPITAL2-VARIABLES
171000                         HOLD-OTHER-VARIABLES
171100                         HOLD-PC-OTH-VARIABLES.
171200
171300     IF  PPS-RTC = 67
171400         MOVE WK-H-OPER-DOLLAR-THRESHOLD TO
171500                 H-OPER-DOLLAR-THRESHOLD.
171600
171700 3000-EXIT.  EXIT.
171800
171900 3100-CALC-STAY-UTILIZATION.
172000
172100     MOVE 0 TO PPS-REG-DAYS-USED.
172200     MOVE 0 TO PPS-LTR-DAYS-USED.
172300
172400     IF H-REG-DAYS > 0
172500        IF H-REG-DAYS > B-LOS
172600           MOVE B-LOS TO PPS-REG-DAYS-USED
172700        ELSE
172800           MOVE H-REG-DAYS TO PPS-REG-DAYS-USED
172900     ELSE
173000        IF H-LTR-DAYS > B-LOS
173100           MOVE B-LOS TO PPS-LTR-DAYS-USED
173200        ELSE
173300           MOVE H-LTR-DAYS TO PPS-LTR-DAYS-USED.
173400
173500
173600
173700 3300-CALC-OPER-FSP-AMT.
173800***********************************************************
173900***  OPERATING FSP CALCULATION
174000***  OPERATING FSP CALCULATION
174100
174200     COMPUTE H-OPER-FSP-PART ROUNDED =
174300           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
174400            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
174500                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
174600
174700****CHECK FOR PUERTO RICO
174800     IF (P-NEW-STATE = 40 AND
174900          B-DISCHARGE-DATE < 20040401)
175000       COMPUTE H-OPER-FSP-PART ROUNDED =
175100           (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
175200            H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
175300                           +
175400           (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
175500            H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
175600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
175700
175800     IF (P-NEW-STATE = 40 AND
175900          B-DISCHARGE-DATE > 20040331)
176000           COMPUTE H-OPER-FSP-PART ROUNDED =
176100              (.625 * (H-NAT-LABOR * H-WAGE-INDEX +
176200               H-NAT-NONLABOR * H-OPER-COLA) * H-DRG-WT)
176300                              +
176400              (.375 * (H-REG-LABOR * H-PR-WAGE-INDEX +
176500               H-REG-NONLABOR * H-OPER-COLA) * H-DRG-WT)
176600                   ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
176700
176800 3450-CALC-ADDITIONAL-HSP.
176900***********************************************************
177000*    OBRA 89 CALCULATE ADDITIONAL HSP PAYMENT FOR
177100*    SOLE COMMUNITY
177200*    AND ESSENTIAL ACCESS COMMUNITY HOSPITALS (EACH)
177300*    NOW REIMBURSED WITH 100% NATIONAL FEDERAL RATES
177400***********************************************************
177500**** CHANGE ESTIMATED OUTLIER FACTORS WHEN FED RATES CHANGE
177600****    USE ACTUAL FEDERAL REGISTER NUMBER
177700
177800***************************************************************
177900***         GET THE UPDATING FACTOR
178000***         GET THE UPDATING FACTOR
178100
178200     MOVE 0.997174 TO H-BUDG-NUTR01.
178300     MOVE 0.995821 TO H-BUDG-NUTR02.
178400     MOVE 0.993111 TO H-BUDG-NUTR03.
178500
178600     IF B-DISCHARGE-DATE > 20040331
178700        MOVE 1.002628 TO H-BUDG-NUTR04
178800     ELSE
178900        MOVE 1.002588 TO H-BUDG-NUTR04.
179000
179100     MOVE 1.0340 TO H-UPDATE-01.
179200     MOVE 1.0275 TO H-UPDATE-02.
179300     MOVE 1.0295 TO H-UPDATE-03.
179400     MOVE 1.0340 TO H-UPDATE-04.
179500
179600     COMPUTE H-UPDATE-FACTOR ROUNDED =
179700                       (H-UPDATE-01 * H-UPDATE-02 *
179800                        H-UPDATE-03 * H-UPDATE-04 *
179900                        H-BUDG-NUTR01 * H-BUDG-NUTR02 *
180000                        H-BUDG-NUTR03 * H-BUDG-NUTR04).
180100
180200     COMPUTE H-HSP-RATE ROUNDED =
180300         H-FAC-SPEC-RATE * H-UPDATE-FACTOR.
180400***************************************************************
180500
180600***************************************************************
180700***     OUTLIER OFFSETS
180800***     OPERATING NATIONAL
180900***     OPERATING PUERTO RICO BLEND
181000
181100      IF B-DISCHARGE-DATE > 20040331
181200         MOVE 0.948997 TO H-OUTLIER-OFFSET-NAT
181300         MOVE 0.958823 TO H-OUTLIER-OFFSET-PR
181400      ELSE
181500         MOVE 0.949460 TO H-OUTLIER-OFFSET-NAT
181600         MOVE 0.963073 TO H-OUTLIER-OFFSET-PR.
181700
181800***************************************************************
181900     COMPUTE H-FSP-RATE ROUNDED =
182000         (H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
182100         H-NAT-NONLABOR * H-OPER-COLA))
182200                           *
182300     ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-NAT)
182400                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
182500
182600     IF (P-NEW-STATE = 40 AND
182700           B-DISCHARGE-DATE < 20040401)
182800       COMPUTE H-FSP-RATE ROUNDED =
182900         ((H-NAT-PCT * (H-NAT-LABOR * H-WAGE-INDEX +
183000         H-NAT-NONLABOR * H-OPER-COLA))
183100                           +
183200          (H-REG-PCT * (H-REG-LABOR * H-PR-WAGE-INDEX +
183300         H-REG-NONLABOR * H-OPER-COLA)))
183400                           *
183500      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
183600                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
183700
183800     IF (P-NEW-STATE = 40 AND
183900           B-DISCHARGE-DATE > 20040331)
184000           COMPUTE H-FSP-RATE ROUNDED =
184100             ((.625 * (H-NAT-LABOR * H-WAGE-INDEX +
184200                H-NAT-NONLABOR * H-OPER-COLA))
184300                           +
184400             (.375 * (H-REG-LABOR * H-PR-WAGE-INDEX +
184500                H-REG-NONLABOR * H-OPER-COLA)))
184600                           *
184700      ((1 + H-OPER-IME-TEACH + H-OPER-DSH) / H-OUTLIER-OFFSET-PR)
184800                   ON SIZE ERROR MOVE 0 TO H-FSP-RATE.
184900
185000     IF  H-HSP-RATE > H-FSP-RATE
185100           COMPUTE H-OPER-HSP-PART ROUNDED =
185200             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT
185300                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART
185400     ELSE
185500         MOVE 0 TO H-OPER-HSP-PART.
185600
185700***************************************************************
185800***         GET THE MDH REBASE
185900***     HAS BEEN REVIVED FOR 10/01/97
186000
186100     IF  H-HSP-RATE > H-FSP-RATE
186200         IF P-NEW-PROVIDER-TYPE = '14' OR '15'
186300           COMPUTE H-OPER-HSP-PART ROUNDED =
186400             (H-HSP-RATE - H-FSP-RATE) * H-DRG-WT * .5
186500                   ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
186600
186700 3500-CALC-PERDIEM-AMT.
186800***********************************************************
186900***  REVIEW CODE = 03 OR 06
187000***  OPERATING PERDIEM-AMT CALCULATION
187100***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
187200
187300**    REMOVED AS OF APR 1 2004
187400***     COMPUTE H-OPER-HSP-PART ROUNDED =
187500***     H-OPER-HSP-PART * H-TRANSFER-ADJ
187600***     ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
187700***********************************************************
187800
187900        COMPUTE H-OPER-FSP-PART ROUNDED =
188000        H-OPER-FSP-PART * H-TRANSFER-ADJ
188100        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
188200
188300***********************************************************
188400***********************************************************
188500***  REVIEW CODE = 03 OR 06
188600***  CAPITAL   PERDIEM-AMT CALCULATION
188700***  CAPITAL   HSP AND FSP CALCULATION FOR TRANSFERS
188800
188900***********************************************************
189000**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
189100*       COMPUTE H-CAPI-HSP-PART ROUNDED =
189200*       H-CAPI-HSP-PART * H-TRANSFER-ADJ
189300*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
189400***********************************************************
189500
189600        COMPUTE H-CAPI-FSP-PART ROUNDED =
189700        H-CAPI-FSP-PART * H-TRANSFER-ADJ
189800        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
189900
190000***********************************************************
190100***  REVIEW CODE = 03 OR 06
190200***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
190300***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
190400
190500        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
190600        H-CAPI-OLD-HARMLESS * H-TRANSFER-ADJ
190700        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
190800
190900 3550-CALC-PERDIEM-AMT.
191000***********************************************************
191100***  REVIEW CODE = 09  OR 11 TRANSFER WITH SPECIAL DRG
191200***  OPERATING PERDIEM-AMT CALCULATION
191300***  OPERATING HSP AND FSP CALCULATION FOR TRANSFERS
191400**    REMOVED AS OF APR 1 2004
191500*    IF (B-DRG = 209 OR 210 OR 211)
191600*       MOVE 10 TO PPS-RTC
191700*       COMPUTE H-OPER-HSP-PART ROUNDED =
191800*       H-OPER-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
191900*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
192000
192100*    IF (B-DRG = 014 OR 113 OR 236 OR
192200*                012 OR 024 OR 025 OR
192300*                088 OR 089 OR 090 OR
192400*                121 OR 122 OR 127 OR
192500*                130 OR 131 OR 239 OR
192600*                277 OR 278 OR 294 OR
192700*                296 OR 297 OR 320 OR
192800*                321 OR 395 OR 468 OR
192900*                429 OR 483)
193000*       MOVE 12 TO PPS-RTC
193100*       COMPUTE H-OPER-HSP-PART ROUNDED =
193200*       H-OPER-HSP-PART *  H-TRANSFER-ADJ
193300*       ON SIZE ERROR MOVE 0 TO H-OPER-HSP-PART.
193400***********************************************************
193500
193600     IF (B-DRG = 209 OR 210 OR 211)
193700        MOVE 10 TO PPS-RTC
193800        COMPUTE H-OPER-FSP-PART ROUNDED =
193900        H-OPER-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
194000        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
194100
194200     IF (B-DRG = 014 OR 113 OR 236 OR
194300                 012 OR 024 OR 025 OR
194400                 088 OR 089 OR 090 OR
194500                 121 OR 122 OR 127 OR
194600                 130 OR 131 OR 239 OR
194700                 277 OR 278 OR 294 OR
194800                 296 OR 297 OR 320 OR
194900                 321 OR 395 OR 468 OR
195000                 429 OR 483)
195100        MOVE 12 TO PPS-RTC
195200        COMPUTE H-OPER-FSP-PART ROUNDED =
195300        H-OPER-FSP-PART *  H-TRANSFER-ADJ
195400        ON SIZE ERROR MOVE 0 TO H-OPER-FSP-PART.
195500
195600***********************************************************
195700***  CAPITAL PERDIEM-AMT CALCULATION
195800***  CAPITAL HSP AND FSP CALCULATION FOR TRANSFERS
195900
196000***********************************************************
196100**NO LONGER PAID CAPITAL HSP AS OF OCT. 1, 2001    **************
196200*    IF (B-DRG = 209 OR 210 OR 211)
196300*       MOVE 10 TO PPS-RTC
196400*       COMPUTE H-CAPI-HSP-PART ROUNDED =
196500*       H-CAPI-HSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
196600*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
196700*
196800*    IF (B-DRG = 014 OR 113 OR 236 OR 263 OR
196900*                264 OR 429 OR 483)
197000*       MOVE 12 TO PPS-RTC
197100*       COMPUTE H-CAPI-HSP-PART ROUNDED =
197200*       H-CAPI-HSP-PART *  H-TRANSFER-ADJ
197300*       ON SIZE ERROR MOVE 0 TO H-CAPI-HSP-PART.
197400***********************************************************
197500
197600     IF (B-DRG = 209 OR 210 OR 211)
197700        MOVE 10 TO PPS-RTC
197800        COMPUTE H-CAPI-FSP-PART ROUNDED =
197900        H-CAPI-FSP-PART * (.5 * (1 + H-TRANSFER-ADJ))
198000        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
198100
198200     IF (B-DRG = 014 OR 113 OR 236 OR
198300                 012 OR 024 OR 025 OR
198400                 088 OR 089 OR 090 OR
198500                 121 OR 122 OR 127 OR
198600                 130 OR 131 OR 239 OR
198700                 277 OR 278 OR 294 OR
198800                 296 OR 297 OR 320 OR
198900                 321 OR 395 OR 468 OR
199000                 429 OR 483)
199100        MOVE 12 TO PPS-RTC
199200        COMPUTE H-CAPI-FSP-PART ROUNDED =
199300        H-CAPI-FSP-PART *  H-TRANSFER-ADJ
199400        ON SIZE ERROR MOVE 0 TO H-CAPI-FSP-PART.
199500
199600***********************************************************
199700***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
199800***  CAPITAL PERDIEM-AMT, OLD-HARMLESS CALCULATION
199900
200000     IF (B-DRG = 209 OR 210 OR 211)
200100        MOVE 10 TO PPS-RTC
200200        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
200300        H-CAPI-OLD-HARMLESS * (.5 * (1 + H-TRANSFER-ADJ))
200400        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
200500
200600     IF (B-DRG = 014 OR 113 OR 236 OR
200700                 012 OR 024 OR 025 OR
200800                 088 OR 089 OR 090 OR
200900                 121 OR 122 OR 127 OR
201000                 130 OR 131 OR 239 OR
201100                 277 OR 278 OR 294 OR
201200                 296 OR 297 OR 320 OR
201300                 321 OR 395 OR 468 OR
201400                 429 OR 483)
201500        MOVE 12 TO PPS-RTC
201600        COMPUTE H-CAPI-OLD-HARMLESS ROUNDED =
201700        H-CAPI-OLD-HARMLESS *  H-TRANSFER-ADJ
201800        ON SIZE ERROR MOVE 0 TO H-CAPI-OLD-HARMLESS.
201900
202000 3560-CHECK-RTN-CODE.
202100
202200     IF (B-DRG = 209 OR 210 OR 211)
202300        MOVE 10 TO PPS-RTC.
202400     IF (B-DRG = 014 OR 113 OR 236 OR
202500                 012 OR 024 OR 025 OR
202600                 088 OR 089 OR 090 OR
202700                 121 OR 122 OR 127 OR
202800                 130 OR 131 OR 239 OR
202900                 277 OR 278 OR 294 OR
203000                 296 OR 297 OR 320 OR
203100                 321 OR 395 OR 468 OR
203200                 429 OR 483)
203300        MOVE 12 TO PPS-RTC.
203400
203500 3560-EXIT.    EXIT.
203600
203700 3600-CALC-OUTLIER.
203800***********************************************************
203900***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
204000***  COST OUTLIER OPERATING AND CAPITAL CALCULATION
204100
204200     IF H-CAPI-CSTCHG-RATIO > 0 OR
204300       H-OPER-CSTCHG-RATIO > 0
204400        COMPUTE H-OPER-SHARE-DOLL-THRESHOLD ROUNDED =
204500                H-OPER-CSTCHG-RATIO /
204600               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
204700        COMPUTE H-CAPI-SHARE-DOLL-THRESHOLD ROUNDED =
204800                H-CAPI-CSTCHG-RATIO /
204900               (H-OPER-CSTCHG-RATIO + H-CAPI-CSTCHG-RATIO)
205000     ELSE
205100         MOVE 0 TO H-OPER-SHARE-DOLL-THRESHOLD
205200                   H-CAPI-SHARE-DOLL-THRESHOLD.
205300
205400***********************************************************
205500***********************************************************
205600***********************************************************
205700***********************************************************
205800***********************************************************
205900***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
206000***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
206100***  OUTLIER THRESHOLD AND PRE-CAPITAL THRESHOLD AMOUNTS
206200
206300***NO LONGER PAID PRE-CAPITAL AS OCT 1, 2001***************
206400***     MOVE 16036.00 TO H-PRE-CAPI-THRESH.
206500***********************************************************
206600***********************************************************
206700***********************************************************
206800***********************************************************
206900
207000
207100
207200***********************************************************
207300***  OUTLIER THRESHOLD AMOUNTS
207400***  OUTLIER THRESHOLD AMOUNTS
207500
207600     IF B-DISCHARGE-DATE > 20040331
207700        MOVE 30150.00 TO H-CST-THRESH
207800     ELSE
207900        MOVE 31000.00 TO H-CST-THRESH.
208000
208100     IF (B-REVIEW-CODE = '03') AND
208200         H-PERDIEM-DAYS < H-ALOS
208300        COMPUTE H-CST-THRESH ROUNDED =
208400                      (H-CST-THRESH * H-TRANSFER-ADJ)
208500                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
208600
208700     IF ((B-REVIEW-CODE = '09') AND
208800         (H-PERDIEM-DAYS < H-ALOS))
208900         IF (B-DRG = 014 OR 113 OR 236 OR
209000                     012 OR 024 OR 025 OR
209100                     088 OR 089 OR 090 OR
209200                     121 OR 122 OR 127 OR
209300                     130 OR 131 OR 239 OR
209400                     277 OR 278 OR 294 OR
209500                     296 OR 297 OR 320 OR
209600                     321 OR 395 OR 468 OR
209700                     429 OR 483)
209800            COMPUTE H-CST-THRESH ROUNDED =
209900                      (H-CST-THRESH * H-TRANSFER-ADJ)
210000                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
210100
210200     IF ((B-REVIEW-CODE = '09') AND
210300         (H-PERDIEM-DAYS < H-ALOS))
210400         IF (B-DRG = 209 OR 210 OR 211)
210500           COMPUTE H-CST-THRESH ROUNDED =
210600          (H-CST-THRESH * (.5 * (1 + H-TRANSFER-ADJ)))
210700                ON SIZE ERROR MOVE 0 TO H-CST-THRESH.
210800
210900     COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
211000        ((H-CST-THRESH * H-LABOR-PCT * H-WAGE-INDEX) +
211100         (H-CST-THRESH * H-NONLABOR-PCT * H-OPER-COLA)) *
211200          H-OPER-SHARE-DOLL-THRESHOLD.
211300
211400     IF (P-NEW-STATE = 40 AND
211500           B-DISCHARGE-DATE < 20040401)
211600        COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
211700           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
211800            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
211900             H-OPER-SHARE-DOLL-THRESHOLD
212000        COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
212100               (H-OPER-DOLLAR-THRESHOLD +
212200                H-OPER-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
212300
212400     IF (P-NEW-STATE = 40 AND
212500           B-DISCHARGE-DATE > 20040331)
212600          COMPUTE H-OPER-PR-DOLLAR-THRESHOLD ROUNDED =
212700           ((H-CST-THRESH * H-PR-LABOR-PCT * H-PR-WAGE-INDEX) +
212800            (H-CST-THRESH * H-PR-NONLABOR-PCT * H-OPER-COLA)) *
212900             H-OPER-SHARE-DOLL-THRESHOLD
213000          COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
213100               (H-OPER-DOLLAR-THRESHOLD * .625) +
213200               (H-OPER-PR-DOLLAR-THRESHOLD * .375).
213300***********************************************************
213400
213500     COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
213600          H-CST-THRESH * H-CAPI-GAF * H-CAPI-LARG-URBAN *
213700          H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA.
213800
213900
214000     IF (P-NEW-STATE = 40 AND
214100           B-DISCHARGE-DATE < 20040401)
214200        COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
214300           H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
214400           H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
214500        COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
214600               (H-CAPI-DOLLAR-THRESHOLD +
214700                H-CAPI-PR-DOLLAR-THRESHOLD) * H-NAT-PCT.
214800
214900     IF (P-NEW-STATE = 40 AND
215000           B-DISCHARGE-DATE > 20040331)
215100          COMPUTE H-CAPI-PR-DOLLAR-THRESHOLD ROUNDED =
215200             H-CST-THRESH * H-PR-CAPI-GAF * H-CAPI-LARG-URBAN *
215300             H-CAPI-SHARE-DOLL-THRESHOLD * H-CAPI-COLA
215400          COMPUTE H-CAPI-DOLLAR-THRESHOLD ROUNDED =
215500                 (H-CAPI-DOLLAR-THRESHOLD * .625) +
215600                 (H-CAPI-PR-DOLLAR-THRESHOLD * .375).
215700
215800     COMPUTE H-OPER-COST-OUTLIER ROUNDED =
215900      (H-OPER-FSP-PART * (1 + H-OPER-IME-TEACH + H-OPER-DSH))
216000                       +
216100             H-OPER-DOLLAR-THRESHOLD
216200                       +
216300                 H-NEW-TECH-PAY-ADD-ON.
216400
216500     COMPUTE H-CAPI-COST-OUTLIER ROUNDED =
216600      (H-CAPI-FSP-PART * (1 + H-WK-CAPI-IME-TEACH + H-CAPI-DSH))
216700                       +
216800             H-CAPI-DOLLAR-THRESHOLD.
216900
217000     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
217100         MOVE 0 TO H-CAPI-COST-OUTLIER.
217200
217300
217400***********************************************************
217500***  OPERATING COST CALCULATION
217600***  OPERATING COST CALCULATION
217700
217800     COMPUTE H-OPER-BILL-COSTS ROUNDED =
217900         B-CHARGES-CLAIMED * H-OPER-CSTCHG-RATIO
218000         ON SIZE ERROR MOVE 0 TO H-OPER-BILL-COSTS.
218100
218200
218300     IF  H-OPER-BILL-COSTS > H-OPER-COST-OUTLIER
218400         COMPUTE H-OPER-OUTCST-PART ROUNDED =
218500         H-CSTOUT-PCT * (H-OPER-BILL-COSTS -
218600                         H-OPER-COST-OUTLIER).
218700
218800     IF PAY-WITHOUT-COST OR
218900        PAY-XFER-NO-COST OR
219000        PAY-XFER-SPEC-DRG-NO-COST
219100         MOVE 0 TO H-OPER-OUTCST-PART.
219200
219300***********************************************************
219400***  CAPITAL COST CALCULATION
219500***  CAPITAL COST CALCULATION
219600
219700     COMPUTE H-CAPI-BILL-COSTS ROUNDED =
219800             B-CHARGES-CLAIMED * H-CAPI-CSTCHG-RATIO
219900         ON SIZE ERROR MOVE 0 TO H-CAPI-BILL-COSTS.
220000
220100     IF  H-CAPI-BILL-COSTS > H-CAPI-COST-OUTLIER
220200         COMPUTE H-CAPI-OUTCST-PART ROUNDED =
220300         H-CSTOUT-PCT * (H-CAPI-BILL-COSTS -
220400                         H-CAPI-COST-OUTLIER).
220500
220600     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
220700       COMPUTE H-CAPI-OUTCST-PART ROUNDED =
220800              (H-CAPI-OUTCST-PART * P-NEW-CAPI-NEW-HARM-RATIO).
220900
221000     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
221100        COMPUTE H-CAPI-OUTCST-PART ROUNDED =
221200               (H-CAPI-OUTCST-PART * H-CAPI-PAYCDE-PCT1).
221300
221400     IF (H-CAPI-BILL-COSTS   + H-OPER-BILL-COSTS) <
221500        (H-CAPI-COST-OUTLIER + H-OPER-COST-OUTLIER)
221600        MOVE 0 TO H-CAPI-OUTCST-PART
221700                  H-OPER-OUTCST-PART.
221800
221900     IF PAY-WITHOUT-COST OR
222000        PAY-XFER-NO-COST OR
222100        PAY-XFER-SPEC-DRG-NO-COST
222200         MOVE 0 TO H-CAPI-OUTCST-PART.
222300
222400***********************************************************
222500***  DETERMINES THE BILL TO BE COST  OUTLIER
222600
222700     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
222800         MOVE 0 TO H-CAPI-OUTDAY-PART
222900                   H-CAPI-OUTCST-PART.
223000
223100     IF (H-OPER-OUTCST-PART + H-CAPI-OUTCST-PART) > 0
223200                 MOVE H-OPER-OUTCST-PART TO
223300                      H-OPER-OUTLIER-PART
223400                 MOVE H-CAPI-OUTCST-PART TO
223500                      H-CAPI-OUTLIER-PART
223600                 MOVE 02 TO PPS-RTC.
223700
223800
223900***********************************************************
224000***  DETERMINES IF COST OUTLIER
224100***  RECOMPUTES DOLLAR THRESHOLD TO BE SENT BACK WITH
224200***         RETURN CODE OF 02
224300
224400     MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
224500
224600     IF PPS-RTC = 02
224700             COMPUTE H-OPER-DOLLAR-THRESHOLD ROUNDED =
224800                     (H-CAPI-COST-OUTLIER  +
224900                      H-OPER-COST-OUTLIER)
225000                             /
225100                    (H-CAPI-CSTCHG-RATIO  +
225200                     H-OPER-CSTCHG-RATIO)
225300             ON SIZE ERROR MOVE 0 TO H-OPER-DOLLAR-THRESHOLD.
225400
225500***********************************************************
225600***  DETERMINES IF COST OUTLIER WITH LOS IS > COVERED  DAYS
225700***         RETURN CODE OF 67
225800
225900     IF PPS-RTC = 02
226000         IF ((H-REG-DAYS + H-LTR-DAYS) < B-LOS) OR
226100            PPS-PC-COT-FLAG = 'Y'
226200             MOVE 67 TO PPS-RTC.
226300***********************************************************
226400
226500***********************************************************
226600***  DETERMINES THE OUTLIER AMOUNT THAT WOULD BE PAID IF
226700***  THE PROVIDER WAS TYPE B-HOLD-HARMLESS 100% FED RATE
226800
226900     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
227000        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
227100                H-CAPI-OUTLIER-PART / P-NEW-CAPI-NEW-HARM-RATIO
227200         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
227300
227400     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
227500        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
227600                H-CAPI-OUTLIER-PART.
227700
227800     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
227900        COMPUTE H-CAPI2-B-OUTLIER-PART ROUNDED =
228000                H-CAPI-OUTLIER-PART / H-CAPI-PAYCDE-PCT1
228100         ON SIZE ERROR MOVE 0 TO H-CAPI2-B-OUTLIER-PART.
228200
228300 3600-EXIT.   EXIT.
228400***********************************************************
228500***********************************************************
228600
228700***********************************************************
228800 3800-CALC-TOT-AMT.
228900***********************************************************
229000***  CALCULATE TOTALS FOR CAPITAL
229100***  CALCULATE TOTALS FOR CAPITAL
229200
229300     MOVE P-NEW-CAPI-PPS-PAY-CODE  TO H-CAPI2-PAY-CODE.
229400
229500     IF P-NEW-CAPI-PPS-PAY-CODE = 'A'
229600        MOVE P-NEW-CAPI-NEW-HARM-RATIO TO H-CAPI-FSP-PCT
229700        MOVE 0.00 TO H-CAPI-HSP-PCT.
229800
229900     IF P-NEW-CAPI-PPS-PAY-CODE = 'B'
230000        MOVE 0    TO H-CAPI-OLD-HARMLESS
230100        MOVE 1.00 TO H-CAPI-FSP-PCT
230200        MOVE 0.00 TO H-CAPI-HSP-PCT.
230300
230400     IF P-NEW-CAPI-PPS-PAY-CODE = 'C'
230500        MOVE 0    TO H-CAPI-OLD-HARMLESS
230600        MOVE H-CAPI-PAYCDE-PCT1 TO H-CAPI-FSP-PCT
230700        MOVE H-CAPI-PAYCDE-PCT2 TO H-CAPI-HSP-PCT.
230800
230900     COMPUTE H-CAPI-HSP ROUNDED =
231000         H-CAPI-HSP-PCT * H-CAPI-HSP-PART.
231100
231200     COMPUTE H-CAPI-FSP ROUNDED =
231300         H-CAPI-FSP-PCT * H-CAPI-FSP-PART.
231400
231500     MOVE P-NEW-CAPI-EXCEPTIONS TO H-CAPI-EXCEPTIONS.
231600
231700     MOVE H-CAPI-OLD-HARMLESS TO H-CAPI-OLD-HARM.
231800
231900     COMPUTE H-CAPI-DSH-ADJ ROUNDED =
232000             H-CAPI-FSP
232100              * H-CAPI-DSH.
232200
232300     COMPUTE H-CAPI-IME-ADJ ROUNDED =
232400          H-CAPI-FSP *
232500                 H-WK-CAPI-IME-TEACH.
232600
232700     COMPUTE H-CAPI-OUTLIER ROUNDED =
232800             1.00 * H-CAPI-OUTLIER-PART.
232900
233000     COMPUTE H-CAPI2-B-FSP ROUNDED =
233100             1.00 * H-CAPI2-B-FSP-PART.
233200
233300     COMPUTE H-CAPI2-B-OUTLIER ROUNDED =
233400             1.00 * H-CAPI2-B-OUTLIER-PART.
233500***********************************************************
233600***  IF CAPITAL IS NOT IN EFFECT FOR GIVEN PROVIDER
233700***        THIS ZEROES OUT ALL CAPITAL DATA
233800
233900     IF (P-NEW-CAPI-NEW-HOSP = 'Y')
234000        MOVE ALL '0' TO HOLD-CAPITAL-VARIABLES.
234100***********************************************************
234200
234300***********************************************************
234400***  CALCULATE FINAL TOTALS FOR OPERATING
234500***  CALCULATE FINAL TOTALS FOR OPERATING
234600
234700     IF (H-CAPI-OUTLIER > 0 AND
234800         PPS-OPER-OUTLIER-PART = 0)
234900            COMPUTE PPS-OPER-OUTLIER-PART =
235000                    PPS-OPER-OUTLIER-PART + .01.
235100
235200     COMPUTE PPS-OPER-FSP-PART ROUNDED =
235300             H-OPER-FSP-PCT * H-OPER-FSP-PART.
235400
235500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
235600             H-OPER-HSP-PCT * H-OPER-HSP-PART.
235700
235800     MOVE ZERO TO PPS-OPER-DSH-ADJ.
235900
236000     IF  H-OPER-DSH NUMERIC
236100         COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
236200              PPS-OPER-FSP-PART * H-OPER-DSH.
236300
236400     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
236500             PPS-OPER-FSP-PART * H-OPER-IME-TEACH.
236600
236700     COMPUTE PPS-OPER-OUTLIER-PART ROUNDED =
236800             H-OPER-FSP-PCT * H-OPER-OUTLIER-PART.
236900
237000     IF HMO-TAG  = 'Y'
237100        PERFORM 3850-HMO-IME-ADJ.
237200
237300***********************************************************
237400***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
237500***  CALCULATE FINAL TOTALS FOR CAPITAL AND OPERATING
237600
237700     COMPUTE H-CAPI-TOTAL-PAY ROUNDED =
237800             H-CAPI-HSP + H-CAPI-FSP + H-CAPI-EXCEPTIONS +
237900             H-CAPI-OUTLIER + H-CAPI-DSH-ADJ +
238000             H-CAPI-IME-ADJ + H-CAPI-OLD-HARM.
238100
238200     MOVE H-NEW-TECH-PAY-ADD-ON TO PPS-NEW-TECH-PAY-ADD-ON.
238300
238400     COMPUTE PPS-TOTAL-PAYMENT ROUNDED =
238500             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
238600             PPS-OPER-OUTLIER-PART + PPS-OPER-DSH-ADJ +
238700                     PPS-OPER-IME-ADJ
238800                           +
238900                 PPS-NEW-TECH-PAY-ADD-ON
239000                           +
239100                 H-WK-PASS-AMT-PLUS-MISC
239200                           +
239300                   H-CAPI-TOTAL-PAY.
239400
239500 3850-HMO-IME-ADJ.
239600***********************************************************
239700***  HMO CALC FOR PASS-THRU ADDON
239800***  HMO CALC FOR PASS-THRU ADDON
239900
240000***  HMO DIR-MED-ED  ---- NO LONGER PAID AS OF 10/01/2002
240100
240200     COMPUTE H-WK-PASS-AMT-PLUS-MISC ROUNDED =
240300          (P-NEW-PASS-AMT-PLUS-MISC -
240400           P-NEW-PASS-AMT-DIR-MED-ED) * B-LOS.
240500
240600***********************************************************
240700***  HMO IME ADJUSTMENT --- NO LONGER PAID AS OF 10/01/2002
240800
240900     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
241000                   PPS-OPER-IME-ADJ * .0.
241100
241200***********************************************************
241300
241400 3900-CALC-OPER-DSH.
241500
241600***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
241700***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2001
241800
241900      MOVE 0.0000 TO H-OPER-DSH.
242000
242100      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
242200                                     + P-NEW-MEDICAID-RATIO).
242300
242400***********************************************************
242500*****    0-99 BEDS
242600      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
242700                               AND H-WK-OPER-DSH > .1499
242800                               AND H-WK-OPER-DSH < .1923
242900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
243000                                      * .65 + .025.
243100
243200      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
243300                               AND H-WK-OPER-DSH > .1922
243400             MOVE .0525 TO H-OPER-DSH.
243500
243600***********************************************************
243700*****   100 + BEDS
243800
243900      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
244000                               AND H-WK-OPER-DSH > .1499
244100                               AND H-WK-OPER-DSH < .2021
244200        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
244300                                      * .65 + .025.
244400
244500      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
244600                               AND H-WK-OPER-DSH > .202
244700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
244800                                      * .825 + .0588.
244900
245000***********************************************************
245100*****   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
245200
245300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
245400                               AND H-WK-OPER-DSH > .1499
245500                               AND H-WK-OPER-DSH < .1923
245600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
245700                                 * .65 + .025.
245800
245900      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
246000                               AND H-WK-OPER-DSH > .1922
246100        MOVE .0525 TO H-OPER-DSH.
246200
246300***********************************************************
246400*****   OTHER RURAL HOSPITALS 500 BEDS +
246500
246600      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
246700                               AND H-WK-OPER-DSH > .1499
246800                               AND H-WK-OPER-DSH < .2021
246900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
247000                                 * .65 + .025.
247100
247200      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
247300                               AND H-WK-OPER-DSH > .202
247400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
247500                                 * .825 + .0588.
247600
247700***********************************************************
247800*****   RURAL HOSPITALS SCH
247900
248000      IF W-SIZE = 'R'
248100         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
248200                               AND H-WK-OPER-DSH > .1499
248300                               AND H-WK-OPER-DSH < .1923
248400         COMPUTE H-OPER-DSH-SCH ROUNDED = (H-WK-OPER-DSH - .15)
248500                                 * .65 + .025
248600         MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
248700      IF W-SIZE = 'R'
248800         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
248900                               AND H-WK-OPER-DSH > .1922
249000                               AND H-WK-OPER-DSH < .3000
249100         MOVE .0525 TO H-OPER-DSH-SCH
249200                       H-OPER-DSH.
249300      IF W-SIZE = 'R'
249400         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
249500                               AND H-WK-OPER-DSH > .2999
249600         MOVE .10 TO H-OPER-DSH-SCH
249700                     H-OPER-DSH.
249800***********************************************************
249900*****   RURAL HOSPITALS RRC
250000
250100      IF W-SIZE = 'R'
250200         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
250300                               AND H-WK-OPER-DSH > .1499
250400                               AND H-WK-OPER-DSH < .1923
250500         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .15)
250600                                 * .65 + .025.
250700      IF W-SIZE = 'R'
250800         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
250900                               AND H-WK-OPER-DSH > .1922
251000                               AND H-WK-OPER-DSH < .3000
251100         MOVE .0525 TO H-OPER-DSH-RRC.
251200
251300      IF W-SIZE = 'R'
251400         IF (P-NEW-PROVIDER-TYPE = '07' OR '17' OR '22')
251500                               AND H-WK-OPER-DSH > .2999
251600         COMPUTE H-OPER-DSH-RRC ROUNDED = (H-WK-OPER-DSH - .30)
251700                                 * .60 + .0525.
251800
251900***********************************************************
252000*****   RURAL HOSPITALS BOTH SCH AND RRC
252100
252200      IF W-SIZE = 'R'
252300         IF (P-NEW-PROVIDER-TYPE = '17' OR '22')
252400                MOVE H-OPER-DSH-RRC TO H-OPER-DSH
252500             IF H-OPER-DSH-SCH > H-OPER-DSH-RRC
252600                MOVE H-OPER-DSH-SCH TO H-OPER-DSH.
252700
252800***********************************************************
252900*** RRC ONLY
253000      IF W-SIZE = 'R'
253100         IF (P-NEW-PROVIDER-TYPE = '07')
253200                MOVE H-OPER-DSH-RRC TO H-OPER-DSH.
253300
253400***********************************************************
253500
253600      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
253700
253800 3900-EXIT.   EXIT.
253900
254000 3900A-CALC-OPER-DSH.
254100
254200***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
254300***  OPERATING DSH CALCULATION EFFECTIVE APRIL 1, 2004
254400
254500      MOVE 0.0000 TO H-OPER-DSH.
254600
254700      COMPUTE H-WK-OPER-DSH ROUNDED  = (P-NEW-SSI-RATIO
254800                                     + P-NEW-MEDICAID-RATIO).
254900
255000***********************************************************
255100**1**    0-99 BEDS
255200***   NOT TO EXCEED 12%
255300
255400      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
255500                               AND H-WK-OPER-DSH > .1499
255600                               AND H-WK-OPER-DSH < .2020
255700        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
255800                                      * .65 + .025
255900        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
256000
256100      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE < 100
256200                               AND H-WK-OPER-DSH > .2019
256300        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
256400                                      * .825 + .0588
256500        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
256600
256700***********************************************************
256800**2**   100 + BEDS
256900***  NO CAP >> CAN EXCEED 12%
257000
257100      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
257200                               AND H-WK-OPER-DSH > .1499
257300                               AND H-WK-OPER-DSH < .2020
257400        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
257500                                      * .65 + .025.
257600
257700      IF (W-SIZE = 'O' OR 'L') AND P-NEW-BED-SIZE > 99
257800                               AND H-WK-OPER-DSH > .2019
257900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
258000                                      * .825 + .0588.
258100
258200***********************************************************
258300**3**   OTHER RURAL HOSPITALS LESS THEN 500 BEDS
258400***   NOT TO EXCEED 12%
258500
258600      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
258700                               AND H-WK-OPER-DSH > .1499
258800                               AND H-WK-OPER-DSH < .2020
258900        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
259000                                 * .65 + .025
259100        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
259200
259300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE < 500
259400                               AND H-WK-OPER-DSH > .2019
259500        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
259600                                 * .825 + .0588
259700        IF H-OPER-DSH > .1200  MOVE .1200 TO H-OPER-DSH.
259800
259900***********************************************************
260000**4**   OTHER RURAL HOSPITALS 500 BEDS +
260100***  NO CAP >> CAN EXCEED 12%
260200
260300      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
260400                               AND H-WK-OPER-DSH > .1499
260500                               AND H-WK-OPER-DSH < .2020
260600        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
260700                                 * .65 + .025.
260800
260900      IF W-SIZE = 'R'          AND P-NEW-BED-SIZE > 499
261000                               AND H-WK-OPER-DSH > .2019
261100        COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
261200                                 * .825 + .0588.
261300
261400***********************************************************
261500**7**   RURAL HOSPITALS SCH
261600***   NOT TO EXCEED 12%
261700
261800      IF W-SIZE = 'R'
261900         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
262000                               AND H-WK-OPER-DSH > .1499
262100                               AND H-WK-OPER-DSH < .2020
262200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
262300                                 * .65 + .025
262400         IF H-OPER-DSH > .1200
262500                          MOVE .1200 TO H-OPER-DSH.
262600
262700      IF W-SIZE = 'R'
262800         IF (P-NEW-PROVIDER-TYPE = '16' OR '17' OR '21' OR '22')
262900                               AND H-WK-OPER-DSH > .2019
263000         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
263100                                 * .825 + .0588
263200         IF H-OPER-DSH > .1200
263300                          MOVE .1200 TO H-OPER-DSH.
263400***********************************************************
263500**6**   RURAL HOSPITALS RRC    RULE 5 AND 6 SAME
263600***   RRC OVERRIDES SCH CAP
263700***   REMOVED CHECK FOR RURAL ON RRC'S CR3784H1
263800***      MADE THIS CHG ON 03/06/2006
263900***   NO CAP >>  CAN EXCEED 12%
264000
264100***   IF W-SIZE = 'R'
264200         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
264300                                   '17' OR '22')
264400                               AND H-WK-OPER-DSH > .1499
264500                               AND H-WK-OPER-DSH < .2020
264600         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .15)
264700                                 * .65 + .025.
264800***   IF W-SIZE = 'R'
264900         IF (P-NEW-PROVIDER-TYPE = '07' OR '15' OR
265000                                   '17' OR '22')
265100                               AND H-WK-OPER-DSH > .2019
265200         COMPUTE H-OPER-DSH ROUNDED = (H-WK-OPER-DSH - .202)
265300                                 * .825 + .0588.
265400
265500***********************************************************
265600***********************************************************
265700
265800      COMPUTE H-OPER-DSH ROUNDED = H-OPER-DSH * 1.0000.
265900
266000 3900A-EXIT.   EXIT.
266100
266200***********************************************************
266300***********************************************************
266400***********************************************************
266500***********************************************************
266600
266700 4000-CALC-TECH-ADDON.
266800
266900***********************************************************
267000***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
267100***  CALCULATE TOTALS FOR OPERATING  ADD ON FOR TECH
267200***      CALCULATED FOR ADD ON DONE BEFORE OUTLER
267300***      CALCULATED FOR ADD ON DONE BEFORE SPECIAL DRGS
267400
267500     COMPUTE PPS-OPER-HSP-PART ROUNDED =
267600         H-OPER-HSP-PCT * H-OPER-HSP-PART.
267700
267800     COMPUTE PPS-OPER-FSP-PART ROUNDED =
267900         H-OPER-FSP-PCT * H-OPER-FSP-PART.
268000
268100     MOVE ZERO TO PPS-OPER-DSH-ADJ.
268200
268300     IF  H-OPER-DSH NUMERIC
268400             COMPUTE PPS-OPER-DSH-ADJ ROUNDED =
268500              PPS-OPER-FSP-PART
268600              * H-OPER-DSH.
268700
268800     COMPUTE PPS-OPER-IME-ADJ ROUNDED =
268900             PPS-OPER-FSP-PART *
269000             H-OPER-IME-TEACH.
269100
269200     COMPUTE H-BASE-DRG-PAYMENT ROUNDED =
269300             PPS-OPER-HSP-PART + PPS-OPER-FSP-PART +
269400             PPS-OPER-DSH-ADJ + PPS-OPER-IME-ADJ.
269500
269600***********************************************************
269700***       XIGRIS CASES
269800***********************************************************
269900     IF '0011   ' =  B-PRIN-PROC-CODE   OR
270000                     B-OTHER-PROC-CODE1 OR
270100                     B-OTHER-PROC-CODE2 OR
270200                     B-OTHER-PROC-CODE3 OR
270300                     B-OTHER-PROC-CODE4 OR
270400                     B-OTHER-PROC-CODE5
270500           NEXT SENTENCE
270600     ELSE
270700           MOVE ZEROES TO H-NEW-TECH-ADDON-XIGRIS
270800           GO TO 4000-CHECK-INFUSE-CASES.
270900
271000     MOVE  6800.00 TO H-CSTMED-XIGRIS.
271100
271200     COMPUTE H-LESSER-XIGRIS-1 ROUNDED =
271300             .5 * H-CSTMED-XIGRIS.
271400
271500     COMPUTE H-LESSER-XIGRIS-2 ROUNDED =
271600           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
271700                     H-BASE-DRG-PAYMENT) * .5.
271800
271900     IF H-LESSER-XIGRIS-2 > 0
272000        IF H-LESSER-XIGRIS-1 < H-LESSER-XIGRIS-2
272100           MOVE H-LESSER-XIGRIS-1 TO H-NEW-TECH-ADDON-XIGRIS
272200        ELSE
272300           MOVE H-LESSER-XIGRIS-2 TO H-NEW-TECH-ADDON-XIGRIS
272400     ELSE
272500        MOVE ZEROES          TO H-NEW-TECH-ADDON-XIGRIS.
272600
272700 4000-CHECK-INFUSE-CASES.
272800***********************************************************
272900***       INFUSE CASES
273000***********************************************************
273100     IF B-DRG = 497 OR 498
273200        NEXT SENTENCE
273300     ELSE
273400        MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
273500        GO TO 4000-ADD-TECH-CASES.
273600
273700     IF '8451   ' =  B-PRIN-PROC-CODE   OR
273800                     B-OTHER-PROC-CODE1 OR
273900                     B-OTHER-PROC-CODE2 OR
274000                     B-OTHER-PROC-CODE3 OR
274100                     B-OTHER-PROC-CODE4 OR
274200                     B-OTHER-PROC-CODE5
274300           NEXT SENTENCE
274400     ELSE
274500           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
274600           GO TO 4000-ADD-TECH-CASES.
274700
274800     IF '8452   ' =  B-PRIN-PROC-CODE   OR
274900                     B-OTHER-PROC-CODE1 OR
275000                     B-OTHER-PROC-CODE2 OR
275100                     B-OTHER-PROC-CODE3 OR
275200                     B-OTHER-PROC-CODE4 OR
275300                     B-OTHER-PROC-CODE5
275400           NEXT SENTENCE
275500     ELSE
275600           MOVE ZEROES TO H-NEW-TECH-ADDON-INFUSE
275700           GO TO 4000-ADD-TECH-CASES.
275800
275900     MOVE 8900.00 TO H-CSTMED-INFUSE.
276000
276100     COMPUTE H-LESSER-INFUSE-1 ROUNDED =
276200             .5 * H-CSTMED-INFUSE.
276300
276400     COMPUTE H-LESSER-INFUSE-2 ROUNDED =
276500           ((B-CHARGES-CLAIMED * P-NEW-OPER-CSTCHG-RATIO) -
276600                     H-BASE-DRG-PAYMENT) * .5.
276700
276800     IF H-LESSER-INFUSE-2 > 0
276900        IF H-LESSER-INFUSE-1 < H-LESSER-INFUSE-2
277000           MOVE H-LESSER-INFUSE-1 TO H-NEW-TECH-ADDON-INFUSE
277100        ELSE
277200           MOVE H-LESSER-INFUSE-2 TO H-NEW-TECH-ADDON-INFUSE
277300     ELSE
277400        MOVE ZEROES          TO H-NEW-TECH-ADDON-INFUSE.
277500
277600 4000-ADD-TECH-CASES.
277700
277800     COMPUTE H-NEW-TECH-PAY-ADD-ON ROUNDED =
277900             H-NEW-TECH-ADDON-XIGRIS + H-NEW-TECH-ADDON-INFUSE.
278000
278100 4000-EXIT.    EXIT.
278200
278300******        L A S T   S O U R C E   S T A T E M E N T   *****
