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