000100 IDENTIFICATION DIVISION.                                         00010000
000200 PROGRAM-ID.    IRCAL110.                                         00020025
000300*AUTHOR.        PBG/DDS.                                          00030025
000400*REMARKS.       CMS.                                              00040000
000500                                                                  00050000
000600 DATE-COMPILED.                                                   00060000
000610******************************************************************00061000
000620*  CHANGE FOR 2011 - EFFECTIVE 10/01/2010                        *00062026
000622*----------------------------------------------------------------*00062217
000623* UPDATED CMG-TABLE FOR 2011                                     *00062326
000624*                                                                *00062417
000625* UPDATED 0100-INITIAL-ROUTINE VALUES                            *00062517
000626*                                                                *00062617
000627* MOVE .75271 TO PPS-NAT-LABOR-PCT.                              *00062726
000628* MOVE .24729 TO PPS-NAT-NONLABOR-PCT.                           *00062826
000629* MOVE 11410  TO PPS-NAT-THRESHOLD-ADJ.                          *00062926
000631* MOVE 13860  TO PPS-BDGT-NEUT-CONV-AMT.                         *00063126
000633*                                                                *00063324
000651******************************************************************00065114
000652     EJECT                                                        00065214
000653 ENVIRONMENT DIVISION.                                            00065314
000654 CONFIGURATION SECTION.                                           00065414
000655 SOURCE-COMPUTER.            IBM-370.                             00065514
000660 OBJECT-COMPUTER.            IBM-370.                             00066000
000670 INPUT-OUTPUT  SECTION.                                           00067000
000680 FILE-CONTROL.                                                    00068000
000690                                                                  00069000
000700 DATA DIVISION.                                                   00070000
000800 FILE SECTION.                                                    00080000
000900                                                                  00090000
001000 WORKING-STORAGE SECTION.                                         00100000
001100 01  W-STORAGE-REF                  PIC X(46)  VALUE              00110000
001200     'IRCAL110      - W O R K I N G   S T O R A G E'.             00120025
001300 01  CAL-VERSION                    PIC X(05)  VALUE 'V11.0'.     00130025
001400                                                                  00140000
001500***************************************************************   00150000
001600*    LAYUP TABLE AREA FOR FY2011 CMGS                         *   00160027
001700*    EFFECTIVE DATE OF OCTOBER 1, 2010                        *   00170027
001800***************************************************************   00180000
022110     EJECT                                                        02211002
022120 01  CMG-TABLE.                                                   02212028
022130     05  CMG-TABLE-DATA.                                          02213028
022140         10                      PIC X(32)   VALUE                02214028
022150           '01010803507197064540609610100908'.                    02215028
022160         10                      PIC X(32)   VALUE                02216028
022170           '01020991708883079660752412121110'.                    02217028
022180         10                      PIC X(32)   VALUE                02218028
022190           '01031143910245091880867813141212'.                    02219028
022200         10                      PIC X(32)   VALUE                02220028
022300           '01041239311100099540940215151312'.                    02230028
022310         10                      PIC X(32)   VALUE                02231028
022311           '01051461313088117371108615151514'.                    02231128
022312         10                      PIC X(32)   VALUE                02231228
022313           '01061671114968134221267820191716'.                    02231328
022314         10                      PIC X(32)   VALUE                02231428
022315           '01071891716943151931435121211818'.                    02231528
022316         10                      PIC X(32)   VALUE                02231628
022317           '01082297620579184541743128242222'.                    02231728
022318         10                      PIC X(32)   VALUE                02231828
022319           '01092201719719176831670323232021'.                    02231928
022320         10                      PIC X(32)   VALUE                02232028
022321           '01102784724941223662112635292625'.                    02232128
022322         10                      PIC X(32)   VALUE                02232228
022323           '02010771206244058240522610100708'.                    02232328
022324         10                      PIC X(32)   VALUE                02232428
022325           '02021041308430078640705614131010'.                    02232528
022326         10                      PIC X(32)   VALUE                02232628
022327           '02031199709713090600813016141111'.                    02232728
022328         10                      PIC X(32)   VALUE                02232828
022329           '02041348410917101830913818161412'.                    02232928
022330         10                      PIC X(32)   VALUE                02233028
022331           '02051605212996121221087818161514'.                    02233128
022332         10                      PIC X(32)   VALUE                02233228
022333           '02062020516359152591369224201818'.                    02233328
022334         10                      PIC X(32)   VALUE                02233428
022335           '02072761922361208581871637292622'.                    02233528
022336         10                      PIC X(32)   VALUE                02233628
022337           '03011084209479085200784711131110'.                    02233728
022338         10                      PIC X(32)   VALUE                02233828
022339           '03021366511947107390989013141313'.                    02233928
022340         10                      PIC X(32)   VALUE                02234028
022341           '03031627014224127851177518171515'.                    02234128
022342         10                      PIC X(32)   VALUE                02234228
022343           '03042231219506175331614732232019'.                    02234328
022344         10                      PIC X(32)   VALUE                02234428
022345           '04010832207488074050664011111109'.                    02234528
022346         10                      PIC X(32)   VALUE                02234628
022347           '04021227211042109200979217151413'.                    02234728
022348         10                      PIC X(32)   VALUE                02234828
022349           '04032064018572183671646828222221'.                    02234928
022350         10                      PIC X(32)   VALUE                02235028
022351           '04043660132935325702920453443434'.                    02235128
022352         10                      PIC X(32)   VALUE                02235228
022353           '04052785925068247902222844232927'.                    02235328
022354         10                      PIC X(32)   VALUE                02235428
022355           '05010722406359058580523410100808'.                    02235528
022356         10                      PIC X(32)   VALUE                02235628
022357           '05021004408843081460727815111110'.                    02235728
022358         10                      PIC X(32)   VALUE                02235828
022359           '05031320311624107070956618151312'.                    02235928
022360         10                      PIC X(32)   VALUE                02236028
022361           '05041569413816127271137121181614'.                    02236128
022362         10                      PIC X(32)   VALUE                02236228
022363           '05051804915889146371307723191817'.                    02236328
022364         10                      PIC X(32)   VALUE                02236428
022365           '05062570022625208421862136282423'.                    02236528
022366         10                      PIC X(32)   VALUE                02236628
022367           '06011020408350074000661110120909'.                    02236728
022368         10                      PIC X(32)   VALUE                02236828
022369           '06021347511027097730873114131211'.                    02236928
022370         10                      PIC X(32)   VALUE                02237028
022371           '06031707313971123821106217171414'.                    02237128
022372         10                      PIC X(32)   VALUE                02237228
022373           '06042279218652165301476725211918'.                    02237328
022374         10                      PIC X(32)   VALUE                02237428
022375           '07010888007865075640671211111009'.                    02237528
022376         10                      PIC X(32)   VALUE                02237628
022377           '07021161710290098960878114131312'.                    02237728
022378         10                      PIC X(32)   VALUE                02237828
022379           '07031405512449119721062415161514'.                    02237928
022380         10                      PIC X(32)   VALUE                02238028
022381           '07041791715870152621354319191817'.                    02238128
022382         10                      PIC X(32)   VALUE                02238228
022383           '08010563505635052620477908080707'.                    02238328
022384         10                      PIC X(32)   VALUE                02238428
022385           '08020765807658071510649510100909'.                    02238528
022386         10                      PIC X(32)   VALUE                02238628
022387           '08031047210472097790888113141212'.                    02238728
022388         10                      PIC X(32)   VALUE                02238828
022389           '08040937309373087530795011121110'.                    02238928
022390         10                      PIC X(32)   VALUE                02239028
022391           '08051179111791110111000014161313'.                    02239128
022392         10                      PIC X(32)   VALUE                02239228
022393           '08061445414454134971225915181615'.                    02239328
022394         10                      PIC X(32)   VALUE                02239428
022395           '09010853007310068140607410100909'.                    02239528
022396         10                      PIC X(32)   VALUE                02239628
022397           '09021140909776091130812412121211'.                    02239728
022398         10                      PIC X(32)   VALUE                02239828
022399           '09031477712663118041052218161514'.                    02239928
022400         10                      PIC X(32)   VALUE                02240028
022401           '09041925716502153831371224211817'.                    02240128
022402         10                      PIC X(32)   VALUE                02240228
022403           '10010915309055081890724612121010'.                    02240328
022404         10                      PIC X(32)   VALUE                02240428
022405           '10021193111803106750944515151312'.                    02240528
022406         10                      PIC X(32)   VALUE                02240628
022407           '10031770117512158371401319201817'.                    02240728
022408         10                      PIC X(32)   VALUE                02240828
022409           '11011162911629102140886812141311'.                    02240928
022410         10                      PIC X(32)   VALUE                02241028
022411           '11021622916229142531237520201516'.                    02241128
022412         10                      PIC X(32)   VALUE                02241228
022413           '12010982609395084130772414111110'.                    02241328
022414         10                      PIC X(32)   VALUE                02241428
022415           '12021219311659104400958513131312'.                    02241528
022416         10                      PIC X(32)   VALUE                02241628
022417           '12031514414480129661190420181615'.                    02241728
022418         10                      PIC X(32)   VALUE                02241828
022419           '13010872908729086210782712121110'.                    02241928
022420         10                      PIC X(32)   VALUE                02242028
022421           '13021171411714115691050415151413'.                    02242128
022422         10                      PIC X(32)   VALUE                02242228
022423           '13031534915349151581376218201817'.                    02242328
022424         10                      PIC X(32)   VALUE                02242428
022425           '14010791907281064810581309080908'.                    02242528
022426         10                      PIC X(32)   VALUE                02242628
022427           '14021092310044089400801812131111'.                    02242728
022428         10                      PIC X(32)   VALUE                02242828
022429           '14031328412215108730975215151312'.                    02242928
022430         10                      PIC X(32)   VALUE                02243028
022431           '14041729015898141521269221191715'.                    02243128
022432         10                      PIC X(32)   VALUE                02243228
022433           '15010952208452071970693511110909'.                    02243328
022434         10                      PIC X(32)   VALUE                02243428
022435           '15021269711271095970924714141111'.                    02243528
022436         10                      PIC X(32)   VALUE                02243628
022437           '15031560413851117931136416161313'.                    02243728
022438         10                      PIC X(32)   VALUE                02243828
022439           '15041992317685150581451022201716'.                    02243928
022440         10                      PIC X(32)   VALUE                02244028
022441           '16010834108341080800725608121010'.                    02244128
022442         10                      PIC X(32)   VALUE                02244228
022443           '16021121511215108650975610161413'.                    02244328
022444         10                      PIC X(32)   VALUE                02244428
022445           '16031440914409139591253511201716'.                    02244528
022446         10                      PIC X(32)   VALUE                02244628
022447           '17011034209632083810736812121110'.                    02244728
022448         10                      PIC X(32)   VALUE                02244828
022449           '17021344712523108960958015161413'.                    02244928
022450         10                      PIC X(32)   VALUE                02245028
022451           '17031591414820128951133717191615'.                    02245128
022452         10                      PIC X(32)   VALUE                02245228
022453           '17042081419383168651482725242018'.                    02245328
022454         10                      PIC X(32)   VALUE                02245428
022455           '18011134809797087240732116121210'.                    02245528
022456         10                      PIC X(32)   VALUE                02245628
022457           '18021818315698139801173121171615'.                    02245728
022458         10                      PIC X(32)   VALUE                02245828
022459           '18033186127506244952055540362825'.                    02245928
022460         10                      PIC X(32)   VALUE                02246028
022461           '19011115411154095120853713141112'.                    02246128
022462         10                      PIC X(32)   VALUE                02246228
022463           '19022134121341181971633223232220'.                    02246328
022464         10                      PIC X(32)   VALUE                02246428
022465           '19033259532595277942494626283231'.                    02246528
022466         10                      PIC X(32)   VALUE                02246628
022467           '20010840907437067000601411100908'.                    02246728
022468         10                      PIC X(32)   VALUE                02246828
022469           '20021132910019090250810212121111'.                    02246928
022470         10                      PIC X(32)   VALUE                02247028
022471           '20031443712768115021032516151413'.                    02247128
022472         10                      PIC X(32)   VALUE                02247228
022473           '20041927417045153551378424201817'.                    02247328
022474         10                      PIC X(32)   VALUE                02247428
022475           '21012836321611216111752925192416'.                    02247528
022476         10                      PIC X(32)   VALUE                02247628
022477           '50010000000000000000145000000003'.                    02247728
022478         10                      PIC X(32)   VALUE                02247828
022479           '51010000000000000000535600000007'.                    02247928
022480         10                      PIC X(32)   VALUE                02248028
022481           '51020000000000000001581600000020'.                    02248128
022482         10                      PIC X(32)   VALUE                02248228
022483           '51030000000000000000731200000009'.                    02248328
022484         10                      PIC X(32)   VALUE                02248428
022485           '51040000000000000001875900000023'.                    02248528
022486         10                      PIC X(32)   VALUE                02248628
022487           '99990000000000000000000000000000'.                    02248728
022488     05  W-CMG-TABLE REDEFINES CMG-TABLE-DATA.                    02248828
022489         10  CMG-DATA            OCCURS 93 TIMES                  02248928
022490                                 ASCENDING KEY IS CMG-NUM         02249028
022491                                 INDEXED BY DX6.                  02249128
022492             15  CMG-NUM         PIC X(4).                        02249228
022493             15  CMG-NUM-REDEF REDEFINES CMG-NUM.                 02249328
022494                 20  CMG-RIC     PIC XX.                          02249428
022495                 20  FILLER      PIC XX.                          02249528
022496             15  B-REL-WGT       PIC 9(1)V9(4).                   02249628
022497             15  C-REL-WGT       PIC 9(1)V9(4).                   02249728
022498             15  D-REL-WGT       PIC 9(1)V9(4).                   02249828
022499             15  A-REL-WGT       PIC 9(1)V9(4).                   02249928
022500             15  B-LOS-TABLE     PIC 9(2).                        02250028
022501             15  C-LOS-TABLE     PIC 9(2).                        02250128
022502             15  D-LOS-TABLE     PIC 9(2).                        02250228
022503             15  A-LOS-TABLE     PIC 9(2).                        02250328
022504     EJECT                                                        02250409
022505 01  HOLD-PPS-COMPONENTS.                                         02250500
022506     05  H-LOS                        PIC 9(05).                  02250600
022507     05  H-WK-DSH                     PIC 9(01)V9(04).            02250700
022510     05  H-TEACH-PCT                  PIC 9(01)V9(04).            02251000
022600     05  H-LABOR-PORTION              PIC 9(07)V9(06).            02260000
022700     05  H-NONLABOR-PORTION           PIC 9(07)V9(06).            02270000
022800     05  H-OUTLIER-LABOR-PORTION      PIC 9(07)V9(06).            02280000
022900     05  H-OUTLIER-NONLABOR-PORTION   PIC 9(07)V9(06).            02290000
023000     05  H-FP-OUTLIER-THRESHOLD       PIC 9(07)V9(06).            02300000
023100     05  H-OUTLIER-THRESHOLD          PIC 9(07)V9(06).            02310000
023200     05  H-CHG-OUTLIER-THRESHOLD      PIC 9(07)V9(04).            02320000
023300     05  H-FY-BEGIN-DATE              PIC 9(08).                  02330000
023400     05  H-DISCHARGE-DATE             PIC 9(08).                  02340000
023500                                                                  02350000
023600 LINKAGE SECTION.                                                 02360000
023700**************************************************************    02370000
023800*      THIS IS THE BILL-RECORD THAT WILL BE PASSED FROM      *    02380000
023900*      THE IRCAL___ PROGRAM                                  *    02390000
024000**************************************************************    02400000
024100 01  BILL-NEW-DATA.                                               02410000
024200         10  B-NPI10.                                             02420000
024300             15  B-NPI8             PIC X(08).                    02430000
024400             15  B-NPI-FILLER       PIC X(02).                    02440000
024500         10  B-PROVIDER-NO          PIC X(06).                    02450000
024600         10  B-PATIENT-STATUS       PIC X(02).                    02460000
024700         10  B-CMG-CODE             PIC X(05).                    02470000
024800         10  B-LOS                  PIC 9(03).                    02480000
024900         10  B-COV-DAYS             PIC 9(03).                    02490000
025000         10  B-LTR-DAYS             PIC 9(02).                    02500000
025100         10  B-SPEC-PAY-IND         PIC X(01).                    02510000
025200         10  B-DISCHARGE-DATE.                                    02520000
025300             15  B-DISCHG-CC        PIC 9(02).                    02530000
025400             15  B-DISCHG-YY        PIC 9(02).                    02540000
025500             15  B-DISCHG-MM        PIC 9(02).                    02550000
025600             15  B-DISCHG-DD        PIC 9(02).                    02560000
025700         10  B-COV-CHARGES          PIC 9(07)V9(02).              02570000
025800         10  FILLER                 PIC X(11).                    02580000
025900                                                                  02590000
026000***************************************************************   02600000
026100*    THIS DATA IS CALCULATED BY THIS IRCAL SUBROUTINE         *   02610000
026200*    AND PASSED BACK TO THE CALLING PROGRAM                   *   02620000
026300*            RETURN CODE VALUES (PPS-RTC)                     *   02630000
026400*                                                             *   02640000
026500*     ****   PPS-RTC 00-49 = HOW THE BILL WAS PAID            *   02650000
026600*              00 = PAID NORMAL CMG PAYMENT WITHOUT OUTLIER   *   02660000
026700*                                                             *   02670000
026800*              01 = PAID NORMAL CMG PAYMENT WITH OUTLIER      *   02680000
026900*                                                             *   02690000
027000*              02 = TRANSFER PAID ON A PERDIEM BASIS WITHOUT  *   02700000
027100*                   OUTLIER                                   *   02710000
027200*              03 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02720000
027300*                   OUTLIER                                   *   02730000
027400*              04 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02740000
027500*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02750000
027600*                   WITHOUT OUTLIER                           *   02760000
027700*              05 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02770000
027800*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02780000
027900*                   WITH OUTLIER                              *   02790000
028000*              06 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02800000
028100*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02810000
028200*                   RATE -- WITHOUT OUTLIER                   *   02820000
028300*              07 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   02830000
028400*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   02840000
028500*                   RATE -- WITH OUTLIER                      *   02850000
028600*       **** NEW RT CODES FOR PAYMENT WITH PENALTIES          *   02860000
028700*              10 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02870000
028800*                   WITHOUT OUTLIER                           *   02880000
028900*              11 = PAID NORMAL CMG PAYMENT WITH PENALTY      *   02890000
029000*                   WITH OUTLIER                              *   02900000
029100*              12 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02910000
029200*                   PENALTY WITHOUT OUTLIER                   *   02920000
029300*              13 = TRANSFER PAID ON A PERDIEM BASIS WITH     *   02930000
029400*                   PENALTY WITH OUTLIER                      *   02940000
029500*              14 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02950000
029600*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02960000
029700*                   WITH PENALTY WITHOUT OUTLIER              *   02970000
029800*              15 = BLENDED CMG PAYMENT -- 2/3 FEDERAL PPS    *   02980000
029900*                   RATE + 1/3 PROVIDER SPECIFIC RATE --      *   02990000
030000*                   WITH PENALTY WITH OUTLIER                 *   03000000
030100*              16 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03010000
030200*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03020000
030300*                   RATE -- WITH PENALTY WITHOUT OUTLIER      *   03030000
030400*              17 = BLENDED TRANSFER PAYMENT -- 2/3 FEDERAL   *   03040000
030500*                   PPS TRANSFER RATE + 1/3 PROVIDER SPECIFIC *   03050000
030600*                   RATE -- WITH PENALTY WITH OUTLIER         *   03060000
030700*                                                             *   03070000
030800*      ****  PPS-RTC 50-99 = WHY THE BILL WAS NOT PAID        *   03080000
030900*              50 = PROVIDER SPECIFIC RATE NOT NUMERIC        *   03090000
031000*              51 = PROVIDER RECORD TERMINATED                *   03100000
031100*              52 = INVALID WAGE INDEX                        *   03110000
031200*              53 = WAIVER STATE - NOT CALCULATED BY PPS      *   03120000
031300*              54 = CMG ON CLAIM NOT FOUND IN TABLE           *   03130000
031400*              55 = DISCHARGE DATE < PROVIDER EFF START DATE  *   03140000
031500*                                      OR                     *   03150000
031600*                   DISCHARGE DATE < MSA EFF START DATE       *   03160000
031700*                   FOR PPS                                   *   03170000
031800*              56 = INVALID LENGTH OF STAY                    *   03180000
031900*              57 = PROVIDER SPECIFIC RATE ZERO WHEN BLENDED  *   03190000
032000*                   PAYMENT REQUESTED                         *   03200000
032100*              58 = TOTAL COVERED CHARGES NOT NUMERIC         *   03210000
032200*              59 = PROVIDER SPECIFIC RECORD NOT FOUND        *   03220000
032300*              60 = MSA WAGE INDEX RECORD NOT FOUND           *   03230000
032400*              61 = LIFETIME RESERVE DAYS NOT NUMERIC         *   03240000
032500*                   OR BILL-LTR-DAYS > 60                     *   03250000
032600*              62 = INVALID NUMBER OF COVERED DAYS            *   03260000
032700*              65 = OPERATING COST-TO-CHARGE RATIO NOT NUMERIC*   03270000
032800*              67 = COST OUTLIER WITH LOS > COVERED DAYS      *   03280000
032900*                   OR COST OUTLIER THRESHOLD CALCULATION     *   03290000
033000*              72 = INVALID BLEND INDICATOR (NOT 3 OR 4)      *   03300000
033100*              73 = DISCHARGED BEFORE PROVIDER FY BEGIN       *   03310000
033200*              74 = PROVIDER FY BEGIN DATE NOT IN 2002        *   03320000
033300***************************************************************   03330000
033400 01  PPS-DATA-ALL.                                                03340000
033500     05  PPS-RTC                      PIC 9(02).                  03350000
033600     05  PPS-DATA.                                                03360000
033700         10  PPS-MSA                  PIC X(04).                  03370000
033800         10  PPS-WAGE-INDEX           PIC 9(02)V9(04).            03380000
033900         10  PPS-AVG-LOS              PIC 9(02).                  03390000
034000         10  PPS-RELATIVE-WGT         PIC 9(01)V9(04).            03400000
034100         10  PPS-TOTAL-PAY-AMT        PIC 9(07)V9(02).            03410000
034200         10  PPS-FED-PAY-AMT          PIC 9(07)V9(02).            03420000
034300         10  PPS-FAC-SPEC-PAY-AMT     PIC 9(07)V9(02).            03430000
034400         10  PPS-OUTLIER-PAY-AMT      PIC 9(07)V9(02).            03440000
034500         10  PPS-LIP-PAY-AMT          PIC 9(07)V9(02).            03450000
034600         10  PPS-LIP-PCT              PIC 9(01)V9(04).            03460000
034700         10  PPS-LOS                  PIC 9(03).                  03470000
034800         10  PPS-REG-DAYS-USED        PIC 9(03).                  03480000
034900         10  PPS-LTR-DAYS-USED        PIC 9(03).                  03490000
035000         10  PPS-TRANSFER-PCT         PIC 9(01)V9(04).            03500000
035100         10  PPS-FAC-SPEC-RT-PREBLEND PIC 9(05)V9(02).            03510000
035200         10  PPS-STANDARD-PAY-AMT     PIC 9(07)V9(02).            03520000
035300         10  PPS-FAC-COSTS            PIC 9(07)V9(02).            03530000
035400         10  PPS-OUTLIER-THRESHOLD    PIC 9(07)V9(02).            03540000
035500         10  PPS-CHG-OUTLIER-THRESHOLD PIC 9(07)V9(02).           03550000
035600         10  PPS-TOTAL-PENALTY-AMT    PIC 9(07)V9(02).            03560000
035700         10  PPS-FED-PENALTY-AMT      PIC 9(07)V9(02).            03570000
035800         10  PPS-LIP-PENALTY-AMT      PIC 9(07)V9(02).            03580000
035900         10  PPS-OUT-PENALTY-AMT      PIC 9(07)V9(02).            03590000
036000         10  PPS-SUBM-CMG-CODE        PIC X(05).                  03600000
036100         10  PPS-CMG-CODE-REDEF REDEFINES PPS-SUBM-CMG-CODE.      03610000
036200            15  PPS-CMG-ALPHA         PIC X(01).                  03620000
036300            15  PPS-CMG-NUMERIC.                                  03630000
036400               20  PPS-CMG-RIC        PIC X(02).                  03640000
036500               20  FILLER             PIC X(02).                  03650000
036600         10  PPS-PRICED-CMG-CODE      PIC X(05).                  03660000
036700         10  PPS-CALC-VERS-CD         PIC X(05).                  03670000
036800         10  PPS-CBSA                 PIC X(05).                  03680000
036900         10  FILLER                   PIC X(08).                  03690000
037000     05  PPS-OTHER-DATA.                                          03700000
037100         10  PPS-NAT-LABOR-PCT        PIC 9(01)V9(05).            03710000
037200         10  PPS-NAT-NONLABOR-PCT     PIC 9(01)V9(05).            03720000
037300         10  PPS-NAT-THRESHOLD-ADJ    PIC 9(05)V9(02).            03730000
037400         10  PPS-BDGT-NEUT-CONV-AMT   PIC 9(05)V9(02).            03740000
037500         10  PPS-FED-RATE-PCT         PIC 9(01)V9(04).            03750000
037600         10  PPS-FAC-RATE-PCT         PIC 9(01)V9(04).            03760000
037700         10  PPS-RURAL-ADJUSTMENT     PIC 9(01)V9(04).            03770000
037800         10  PPS-TEACH-PAY-AMT        PIC 9(07)V9(02).            03780000
037900         10  PPS-TEACH-PENALTY-AMT    PIC 9(07)V9(02).            03790000
038000         10  FILLER                   PIC X(02).                  03800000
038100     05  PPS-PC-DATA.                                             03810000
038200         10  PPS-COT-IND              PIC X(01).                  03820000
038300         10  FILLER                   PIC X(20).                  03830000
038400                                                                  03840000
038500******************************************************************03850000
038600*            THESE ARE THE VERSIONS OF THE IRDRV___               03860000
038700*           PROGRAMS THAT WILL BE PASSED BACK----                 03870000
038800*          ASSOCIATED WITH THE BILL BEING PROCESSED               03880000
038900******************************************************************03890000
039000 01  PRICER-OPT-VERS-SW.                                          03900000
039100     05  PRICER-OPTION-SW          PIC X(01).                     03910000
039200         88  ALL-TABLES-PASSED          VALUE 'A'.                03920000
039300         88  PROV-RECORD-PASSED         VALUE 'P'.                03930000
039400     05  PPS-VERSIONS.                                            03940000
039500         10  PPDRV-VERSION         PIC X(05).                     03950000
039600                                                                  03960000
039700**************************************************************    03970000
039800*      THIS IS THE PROV-RECORD THAT WILL BE PASSED BY        *    03980000
039900*      THE IRCAL___ PROGRAM                                  *    03990000
040000**************************************************************    04000000
040100 01  PROV-NEW-HOLD.                                               04010000
040200     02  PROV-NEWREC-HOLD1.                                       04020000
040300         05  P-NEW-NPI10.                                         04030000
040400             10  P-NEW-NPI8             PIC X(08).                04040000
040500             10  P-NEW-NPI-FILLER       PIC X(02).                04050000
040600         05  P-NEW-PROVIDER-NO.                                   04060000
040700             10  P-NEW-STATE            PIC 9(02).                04070000
040800             10  FILLER                 PIC X(04).                04080000
040900         05  P-NEW-DATE-DATA.                                     04090000
041000             10  P-NEW-EFF-DATE.                                  04100000
041100                 15  P-NEW-EFF-DT-CC    PIC 9(02).                04110000
041200                 15  P-NEW-EFF-DT-YY    PIC 9(02).                04120000
041300                 15  P-NEW-EFF-DT-MM    PIC 9(02).                04130000
041400                 15  P-NEW-EFF-DT-DD    PIC 9(02).                04140000
041500             10  P-NEW-FY-BEGIN-DATE.                             04150000
041600                 15  P-NEW-FY-BEG-DT-CC PIC 9(02).                04160000
041700                 15  P-NEW-FY-BEG-DT-YY PIC 9(02).                04170000
041800                 15  P-NEW-FY-BEG-DT-MM PIC 9(02).                04180000
041900                 15  P-NEW-FY-BEG-DT-DD PIC 9(02).                04190000
042000             10  P-NEW-REPORT-DATE.                               04200000
042100                 15  P-NEW-REPORT-DT-CC PIC 9(02).                04210000
042200                 15  P-NEW-REPORT-DT-YY PIC 9(02).                04220000
042300                 15  P-NEW-REPORT-DT-MM PIC 9(02).                04230000
042400                 15  P-NEW-REPORT-DT-DD PIC 9(02).                04240000
042500             10  P-NEW-TERMINATION-DATE.                          04250000
042600                 15  P-NEW-TERM-DT-CC   PIC 9(02).                04260000
042700                 15  P-NEW-TERM-DT-YY   PIC 9(02).                04270000
042800                 15  P-NEW-TERM-DT-MM   PIC 9(02).                04280000
042900                 15  P-NEW-TERM-DT-DD   PIC 9(02).                04290000
043000         05  P-NEW-WAIVER-CODE          PIC X(01).                04300000
043100             88  P-NEW-WAIVER-STATE       VALUE 'Y'.              04310000
043200         05  P-NEW-INTER-NO             PIC 9(05).                04320000
043300         05  P-NEW-PROVIDER-TYPE        PIC X(02).                04330000
043400         05  P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).                04340000
043500         05  P-NEW-CURRENT-DIV   REDEFINES                        04350000
043600                    P-NEW-CURRENT-CENSUS-DIV   PIC 9(01).         04360000
043700         05  P-NEW-MSA-DATA.                                      04370000
043800             10  P-NEW-CHG-CODE-INDEX       PIC X.                04380000
043900             10  P-NEW-GEO-LOC-MSAX         PIC X(04) JUST RIGHT. 04390000
044000             10  P-NEW-GEO-LOC-MSA9   REDEFINES                   04400000
044100                             P-NEW-GEO-LOC-MSAX  PIC 9(04).       04410000
044200             10  P-NEW-WAGE-INDEX-LOC-MSA   PIC X(04) JUST RIGHT. 04420000
044300             10  P-NEW-STAND-AMT-LOC-MSA    PIC X(04) JUST RIGHT. 04430000
044400             10  P-NEW-STAND-AMT-LOC-MSA9                         04440000
044500                 REDEFINES P-NEW-STAND-AMT-LOC-MSA.               04450000
044600                 15  P-NEW-RURAL-1ST.                             04460000
044700                     20  P-NEW-STAND-RURAL  PIC XX.               04470000
044800                         88  P-NEW-STD-RURAL-CHECK VALUE '  '.    04480000
044900                 15  P-NEW-RURAL-2ND        PIC XX.               04490000
045000         05  P-NEW-SOL-COM-DEP-HOSP-YR PIC XX.                    04500000
045100         05  P-NEW-LUGAR                    PIC X.                04510000
045200         05  P-NEW-TEMP-RELIEF-IND          PIC X.                04520000
045300         05  P-NEW-FED-PPS-BLEND-IND        PIC X.                04530000
045400         05  FILLER                         PIC X(05).            04540000
045500     02  PROV-NEWREC-HOLD2.                                       04550000
045600         05  P-NEW-VARIABLES.                                     04560000
045700             10  P-NEW-FAC-SPEC-RATE     PIC  9(05)V9(02).        04570000
045800             10  P-NEW-COLA              PIC  9(01)V9(03).        04580000
045900             10  P-NEW-INTERN-RATIO      PIC  9(01)V9(04).        04590000
046000             10  P-NEW-BED-SIZE          PIC  9(05).              04600000
046100             10  P-NEW-OPER-CSTCHG-RATIO PIC  9(01)V9(03).        04610000
046200             10  P-NEW-CMI               PIC  9(01)V9(04).        04620000
046300             10  P-NEW-SSI-RATIO         PIC  V9(04).             04630000
046400             10  P-NEW-MEDICAID-RATIO    PIC  V9(04).             04640000
046500             10  P-NEW-PPS-BLEND-YR-IND  PIC  9(01).              04650000
046600             10  P-NEW-PRUF-UPDTE-FACTOR PIC  9(01)V9(05).        04660000
046700             10  P-NEW-DSH-PERCENT       PIC  V9(04).             04670000
046800             10  P-NEW-FYE-DATE          PIC  X(08).              04680000
046900         05  P-NEW-CBSA-DATA.                                     04690000
047000             10  P-NEW-CBSA-SPEC-PAY-IND   PIC X.                 04700000
047100             10  P-NEW-CBSA-HOSP-QUAL-IND  PIC X.                 04710000
047200             10  P-NEW-CBSA-GEO-LOC        PIC X(05) JUST RIGHT.  04720000
047300             10  P-NEW-CBSA-RECLASS-LOC    PIC X(05) JUST RIGHT.  04730000
047400             10  P-NEW-CBSA-STAND-AMT-LOC  PIC X(05) JUST RIGHT.  04740000
047500             10  P-NEW-CBSA-STAND-AMT-LOC9                        04750000
047600                 REDEFINES P-NEW-CBSA-STAND-AMT-LOC.              04760000
047700                 15  P-NEW-CBSA-RURAL-1ST.                        04770000
047800                     20  P-NEW-CBSA-STAND-RURAL PIC 999.          04780000
047900                 15  P-NEW-CBSA-RURAL-2ND       PIC 99.           04790000
048000             10  P-NEW-CBSA-SPEC-WAGE-INDEX     PIC 9(02)V9(04).  04800000
048100     02  PROV-NEWREC-HOLD3.                                       04810000
048200         05  P-NEW-PASS-AMT-DATA.                                 04820000
048300             10  P-NEW-PASS-AMT-CAPITAL    PIC 9(04)V99.          04830000
048400             10  P-NEW-PASS-AMT-DIR-MED-ED PIC 9(04)V99.          04840000
048500             10  P-NEW-PASS-AMT-ORGAN-ACQ  PIC 9(04)V99.          04850000
048600             10  P-NEW-PASS-AMT-PLUS-MISC  PIC 9(04)V99.          04860000
048700         05  P-NEW-CAPI-DATA.                                     04870000
048800             15  P-NEW-CAPI-PPS-PAY-CODE   PIC X.                 04880000
048900             15  P-NEW-CAPI-HOSP-SPEC-RATE PIC 9(04)V99.          04890000
049000             15  P-NEW-CAPI-OLD-HARM-RATE  PIC 9(04)V99.          04900000
049100             15  P-NEW-CAPI-NEW-HARM-RATIO PIC 9(01)V9999.        04910000
049200             15  P-NEW-CAPI-CSTCHG-RATIO   PIC 9V999.             04920000
049300             15  P-NEW-CAPI-NEW-HOSP       PIC X.                 04930000
049400             15  P-NEW-CAPI-IME            PIC 9V9999.            04940000
049500             15  P-NEW-CAPI-EXCEPTIONS     PIC 9(04)V99.          04950000
049600             15  P-VAL-BASED-PURCH-SCORE   PIC 9V999.             04960000
049700         05  FILLER                        PIC X(18).             04970000
049800******************************************************************04980000
049900*                   THIS IS THE WAGE-INDEX                        04990000
050000*          ASSOCIATED WITH THE BILL BEING PROCESSED               05000000
050100*                                                                 05010000
050200******************************************************************05020000
050300 01  WAGE-NEW-INDEX-RECORD-CBSA.                                  05030000
050400     05  W-NEW-CBSA                    PIC X(5).                  05040000
050500*       88  VALID-RURAL-CBSA    VALUE                             05050000
050600*             '50001' '50007' '50016' '50020' '50031'             05060000
050700*             '50036' '50054' '50060' '50067' '50087'             05070000
050800*             '50089' '50091' '50092' '50100' '50104'             05080000
050900*             '50108' '50114' '50121' '50125' '50140'             05090000
051000*             '50145' '50152' '50164' '50170' '50192'             05100000
051100*             '50199' '50206' '50210' '50214' '50218'             05110000
051200*             '50222' '50225' '50226' '50231' '50234'             05120000
051300*             '50237' '50243' '50248' '50250' '50255'             05130000
051400*             '50256' '50257' '50260' '50261' '50262'             05140000
051500*             '50263' '50266' '50268' '50272' '50275'             05150000
051600*             '50281' '50286' '50293' '50313' '50314'             05160000
051700*             '50316' '50325' '50326' '50327' '50329'             05170000
051800*             '50336' '50344' '50352'.                            05180000
051900     05  W-NEW-EFF-DATE-C              PIC X(8).                  05190000
052000     05  W-NEW-WAGE-INDEX-C            PIC S9(02)V9(04).          05200000
052100                                                                  05210000
052200 PROCEDURE DIVISION  USING BILL-NEW-DATA                          05220000
052300                           PPS-DATA-ALL                           05230000
052400                           PRICER-OPT-VERS-SW                     05240000
052500                           PROV-NEW-HOLD                          05250000
052600                           WAGE-NEW-INDEX-RECORD-CBSA.            05260000
052700***************************************************************   05270000
052800*    PROCESSING:                                              *   05280000
052900*        A. WILL PROCESS CLAIMS BASED ON DISCHARGE DATE       *   05290000
053000*        B. INITIALIZE IRCAL HOLD VARIABLES.                  *   05300000
053100*        C. EDIT THE DATA PASSED FROM THE CLAIM BEFORE        *   05310000
053200*           ATTEMPTING TO CALCULATE PPS. IF THIS CLAIM        *   05320000
053300*           CANNOT BE PROCESSED, SET A RETURN CODE AND        *   05330000
053400*           GOBACK.                                           *   05340000
053500*        D. ASSEMBLE PRICING COMPONENTS.                      *   05350000
053600*        E. CALCULATE THE PRICE.                              *   05360000
053700*        F. CALCULATE OUTLIERS IF APPLICABLE.                 *   05370000
053800***************************************************************   05380000
053900                                                                  05390000
054000 0000-MAINLINE-CONTROL.                                           05400000
054120                                                                  05412006
054200     PERFORM 0100-INITIAL-ROUTINE                                 05420000
054300        THRU 0100-EXIT.                                           05430000
054400                                                                  05440000
054500     PERFORM 1000-EDIT-THE-BILL-INFO                              05450000
054600        THRU 1000-EXIT.                                           05460000
054700                                                                  05470000
054800     IF PPS-RTC = 00                                              05480000
054900        PERFORM 1700-EDIT-CMG-CODE                                05490000
055000           THRU 1700-EXIT.                                        05500000
055100                                                                  05510000
055200     IF PPS-RTC = 00                                              05520000
055300        PERFORM 2000-ASSEMBLE-PPS-VARIABLES                       05530000
055400           THRU 2000-EXIT.                                        05540000
055500                                                                  05550000
055600     IF PPS-RTC = 00                                              05560000
055700        PERFORM 3000-CALC-PAYMENT                                 05570000
055800           THRU 3000-EXIT                                         05580000
055900        PERFORM 3500-CONTINUE-CALC                                05590000
056000           THRU 3500-EXIT                                         05600000
056100        PERFORM 4000-CALC-OUTLIER                                 05610000
056200           THRU 4000-EXIT                                         05620000
056300        PERFORM 5000-FINAL-PAYMENTS                               05630000
056400           THRU 5000-EXIT.                                        05640000
056500                                                                  05650000
056600     PERFORM 9000-MOVE-RESULTS                                    05660000
056700        THRU 9000-EXIT.                                           05670000
056800                                                                  05680000
056900     GOBACK.                                                      05690000
057000                                                                  05700000
057100 0100-INITIAL-ROUTINE.                                            05710000
057200                                                                  05720000
057300     MOVE ZEROS TO PPS-RTC.                                       05730000
057400     INITIALIZE PPS-DATA.                                         05740000
057500     INITIALIZE PPS-OTHER-DATA.                                   05750000
057600     INITIALIZE HOLD-PPS-COMPONENTS.                              05760000
057700***************************************************************   05770000
057800*    UPDATE THE VALUES BELOW FOR EACH FY RELEASE              *   05780000
057900*     - VALUES PER POLICY                                     *   05790000
058000***************************************************************   05800000
058100                                                                  05810000
058200     MOVE .75271 TO PPS-NAT-LABOR-PCT.                            05820026
058300     MOVE .24729 TO PPS-NAT-NONLABOR-PCT.                         05830026
058531     MOVE 11410  TO PPS-NAT-THRESHOLD-ADJ.                        05853126
058540     MOVE 13860  TO PPS-BDGT-NEUT-CONV-AMT.                       05854026
058600                                                                  05860000
058700 0100-EXIT.                                                       05870000
058800      EXIT.                                                       05880000
058900                                                                  05890000
059000 1000-EDIT-THE-BILL-INFO.                                         05900000
059100***************************************************************   05910000
059200*    BILL DATA EDITS IF ANY FAIL SET PPS-RTC                  *   05920000
059300*    AND DO NOT ATTEMPT TO PRICE.                             *   05930000
059400***************************************************************   05940000
059500                                                                  05950000
059600     MOVE B-CMG-CODE TO PPS-SUBM-CMG-CODE.                        05960000
059700                                                                  05970000
059800     IF (B-LOS NUMERIC) AND (B-LOS > 0)                           05980000
059900        MOVE B-LOS TO H-LOS                                       05990000
060000     ELSE                                                         06000000
060100        IF B-LOS = 0                                              06010000
060200           MOVE 1 TO H-LOS                                        06020000
060300        ELSE                                                      06030000
060400           MOVE 56 TO PPS-RTC.                                    06040000
060500                                                                  06050000
060600     MOVE P-NEW-FY-BEGIN-DATE TO H-FY-BEGIN-DATE.                 06060000
060700     IF H-FY-BEGIN-DATE (5:2) < 11                                06070000
060800       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 10200          06080000
060900     ELSE                                                         06090000
061000       COMPUTE H-FY-BEGIN-DATE = H-FY-BEGIN-DATE + 19000.         06100000
061100     MOVE B-DISCHARGE-DATE TO H-DISCHARGE-DATE.                   06110000
061200     IF (H-DISCHARGE-DATE > H-FY-BEGIN-DATE)                      06120000
061300        OR (P-NEW-FY-BEGIN-DATE > 20020930 AND                    06130000
061400            P-NEW-FY-BEGIN-DATE < 20030101)                       06140000
061500        MOVE '4' TO P-NEW-FED-PPS-BLEND-IND.                      06150000
061600     IF P-NEW-FY-BEGIN-DATE > 20011231                            06160000
061700        IF (P-NEW-FY-BEGIN-DATE <= B-DISCHARGE-DATE)              06170000
061800           IF P-NEW-FED-PPS-BLEND-IND = '4'                       06180000
061900              MOVE 1.0000 TO PPS-FED-RATE-PCT                     06190000
062000              MOVE 0.0000 TO PPS-FAC-RATE-PCT                     06200000
062100           ELSE                                                   06210000
062200             IF P-NEW-FED-PPS-BLEND-IND = '3'                     06220000
062300                MOVE .6667 TO PPS-FED-RATE-PCT                    06230000
062400                MOVE .3333 TO PPS-FAC-RATE-PCT                    06240000
062500             ELSE                                                 06250000
062600               MOVE 72 TO PPS-RTC                                 06260000
062700        ELSE                                                      06270000
062800           MOVE 73 TO PPS-RTC                                     06280000
062900     ELSE                                                         06290000
063000        MOVE 74 TO PPS-RTC.                                       06300000
063100                                                                  06310000
063200     IF PPS-RTC = 00                                              06320000
063300       IF P-NEW-WAIVER-STATE                                      06330000
063400          MOVE 53 TO PPS-RTC.                                     06340000
063500                                                                  06350000
063600     IF PPS-RTC = 00                                              06360000
063700         IF ((B-DISCHARGE-DATE < P-NEW-EFF-DATE) OR               06370000
063800            (B-DISCHARGE-DATE < W-NEW-EFF-DATE-C))                06380000
063900            MOVE 55 TO PPS-RTC.                                   06390000
064000                                                                  06400000
064100     IF PPS-RTC = 00                                              06410000
064200         IF P-NEW-TERMINATION-DATE > 00000000                     06420000
064300            IF B-DISCHARGE-DATE >= P-NEW-TERMINATION-DATE         06430000
064400               MOVE 51 TO PPS-RTC.                                06440000
064500                                                                  06450000
064600     IF PPS-RTC = 00                                              06460000
064700         IF B-COV-CHARGES NOT NUMERIC                             06470000
064800            MOVE 58 TO PPS-RTC.                                   06480000
064900                                                                  06490000
065000     IF PPS-RTC = 00                                              06500000
065100        IF B-LTR-DAYS NOT NUMERIC OR B-LTR-DAYS > 60              06510000
065200           MOVE 61 TO PPS-RTC                                     06520000
065300        ELSE                                                      06530000
065400           MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.                  06540000
065500                                                                  06550000
065600     IF PPS-RTC = 00                                              06560000
065700        IF B-COV-DAYS NOT NUMERIC                                 06570000
065800             MOVE 62 TO PPS-RTC                                   06580000
065900        ELSE                                                      06590000
066000          IF B-COV-DAYS = 0 AND H-LOS > 0                         06600000
066100             MOVE 62 TO PPS-RTC.                                  06610000
066200                                                                  06620000
066300     IF PPS-RTC = 00                                              06630000
066400        IF B-LTR-DAYS  > B-COV-DAYS                               06640000
066500           MOVE 62 TO PPS-RTC                                     06650000
066600        ELSE                                                      06660000
066700           COMPUTE PPS-REG-DAYS-USED = B-COV-DAYS - B-LTR-DAYS.   06670000
066800                                                                  06680000
066900     IF PPS-RTC = 00                                              06690000
067000        IF PPS-REG-DAYS-USED > 0                                  06700000
067100           IF PPS-REG-DAYS-USED > H-LOS                           06710000
067200              MOVE H-LOS TO PPS-REG-DAYS-USED                     06720000
067300           ELSE                                                   06730000
067400              NEXT SENTENCE                                       06740000
067500        ELSE                                                      06750000
067600           IF B-LTR-DAYS > H-LOS                                  06760000
067700              MOVE H-LOS TO PPS-LTR-DAYS-USED                     06770000
067800           ELSE                                                   06780000
067900              MOVE B-LTR-DAYS TO PPS-LTR-DAYS-USED.               06790000
068000                                                                  06800000
068100 1000-EXIT.                                                       06810000
068200      EXIT.                                                       06820000
068300                                                                  06830000
068400***************************************************************   06840000
068500*    FINDS THE CMG CODE IN THE TABLE                          *   06850000
068600***************************************************************   06860000
068700 1700-EDIT-CMG-CODE.                                              06870000
068710* 01/2010 - ADDED 5001 PER C.R. # 6699                            06871015
069000                                                                  06900000
069100     IF PPS-CMG-NUMERIC = '9999' OR '5001'                        06910013
069200        NEXT SENTENCE                                             06920000
069300     ELSE                                                         06930000
069400        IF PPS-CMG-NUMERIC < '2103'                               06940000
069500           NEXT SENTENCE                                          06950000
069600        ELSE                                                      06960000
069700           MOVE 54 TO PPS-RTC.                                    06970012
069800                                                                  06980000
069900     IF PPS-RTC = 00                                              06990000
070000        SEARCH ALL CMG-DATA                                       07000000
070100           AT END                                                 07010000
070200             MOVE 54 TO PPS-RTC                                   07020000
070300        WHEN CMG-NUM (DX6) = PPS-CMG-NUMERIC                      07030000
070400             PERFORM 1750-FIND-VALUE                              07040000
070500                THRU 1750-EXIT                                    07050000
070600        END-SEARCH.                                               07060000
070700                                                                  07070000
070800 1700-EXIT.                                                       07080000
070900      EXIT.                                                       07090000
071000                                                                  07100000
071100***************************************************************   07110000
071200*    FINDS THE VALUE IN THE CMG CODE IN THE TABLE             *   07120000
071300***************************************************************   07130000
071400 1750-FIND-VALUE.                                                 07140000
071500                                                                  07150000
071600      IF PPS-CMG-ALPHA = 'A'                                      07160000
071700         MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                 07170000
071800         MOVE A-LOS-TABLE (DX6) TO PPS-AVG-LOS                    07180000
071900      ELSE                                                        07190000
072000         IF PPS-CMG-ALPHA = 'B'                                   07200000
072100            MOVE B-REL-WGT (DX6) TO PPS-RELATIVE-WGT              07210000
072200            MOVE B-LOS-TABLE (DX6) TO PPS-AVG-LOS                 07220000
072300         ELSE                                                     07230000
072400            IF PPS-CMG-ALPHA = 'C'                                07240000
072500               MOVE C-REL-WGT (DX6) TO PPS-RELATIVE-WGT           07250000
072600               MOVE C-LOS-TABLE (DX6) TO PPS-AVG-LOS              07260000
072700            ELSE                                                  07270000
072800               IF PPS-CMG-ALPHA = 'D'                             07280000
072900                  MOVE D-REL-WGT (DX6) TO PPS-RELATIVE-WGT        07290000
073000                  MOVE D-LOS-TABLE (DX6) TO PPS-AVG-LOS           07300000
073100               ELSE                                               07310000
073200                  MOVE 54 TO PPS-RTC.                             07320000
073300                                                                  07330000
073400 1750-EXIT.                                                       07340000
073500      EXIT.                                                       07350000
073600                                                                  07360000
073700***************************************************************   07370000
073800*    THE APPROPRIATE SET OF THESE PPS VARIABLES ARE SELECTED  *   07380000
073900*    DEPENDING ON THE BILL DISCHARGE DATE AND EFFECTIVE DATE  *   07390000
074000*    OF THAT VARIABLE.                                        *   07400000
074100***************************************************************   07410000
074200***  GET THE PROVIDER SPECIFIC VARIABLE AND WAGE INDEX            07420000
074300***************************************************************   07430000
074400 2000-ASSEMBLE-PPS-VARIABLES.                                     07440000
074500                                                                  07450000
074600     IF P-NEW-FAC-SPEC-RATE NUMERIC                               07460000
074700        MOVE P-NEW-FAC-SPEC-RATE TO PPS-FAC-SPEC-RT-PREBLEND      07470000
074800     ELSE                                                         07480000
074900        MOVE 50 TO PPS-RTC                                        07490000
075000        GO TO 2000-EXIT.                                          07500000
075100                                                                  07510000
075200     IF P-NEW-FED-PPS-BLEND-IND = '3'                             07520000
075300        IF PPS-FAC-SPEC-RT-PREBLEND = 0                           07530000
075400          MOVE 57 TO PPS-RTC                                      07540000
075500          GO TO 2000-EXIT.                                        07550000
075600                                                                  07560000
075700     IF W-NEW-WAGE-INDEX-C NUMERIC                                07570000
075800            AND W-NEW-WAGE-INDEX-C > 0                            07580000
075900        MOVE W-NEW-WAGE-INDEX-C TO PPS-WAGE-INDEX                 07590000
076000     ELSE                                                         07600000
076100        MOVE 52 TO PPS-RTC                                        07610000
076200        GO TO 2000-EXIT.                                          07620000
076300                                                                  07630000
076400     IF P-NEW-OPER-CSTCHG-RATIO NOT NUMERIC                       07640000
076500        MOVE 65 TO PPS-RTC.                                       07650000
076600                                                                  07660000
076700 2000-EXIT.                                                       07670000
076800      EXIT.                                                       07680000
076900                                                                  07690000
077000***************************************************************   07700000
077100*    IF THE BILL DATA HAS PASSED ALL EDITS (RTC=00)           *   07710000
077200*        CALCULATE THE FEDERAL PORTION.                       *   07720000
077300*        CALCULATE THE HOSPITAL PORTION.                      *   07730000
077400*        CALCULATE THE COST-OUTLIER PORTION.                  *   07740000
077500*        CALCULATE THE LIP ADJUSTMENT PERCENTAGE.             *   07750000
077600***************************************************************   07760000
077700 3000-CALC-PAYMENT.                                               07770000
077800                                                                  07780000
077900***  LIP PERCENTAGE CALCULATION *******************************   07790000
078000                                                                  07800000
078100      COMPUTE H-WK-DSH = (P-NEW-SSI-RATIO                         07810000
078200                           + P-NEW-MEDICAID-RATIO).               07820000
078300                                                                  07830000
078400      COMPUTE PPS-LIP-PCT ROUNDED =                               07840000
078500            ((1 + H-WK-DSH) ** .4613) - 1.                        07850003
078600                                                                  07860000
078700      COMPUTE H-TEACH-PCT ROUNDED =                               07870000
078800            ((1 + P-NEW-CAPI-IME) ** .6876) - 1.                  07880003
078900                                                                  07890000
079000***************************************************************   07900000
079100                                                                  07910000
079200     MOVE 1.0000 TO PPS-TRANSFER-PCT.                             07920000
079300                                                                  07930000
079400     IF B-PATIENT-STATUS =                                        07940000
079500         ('02' OR '03' OR '61' OR '62' OR '63' OR '64')           07950000
079600        IF H-LOS < PPS-AVG-LOS                                    07960000
079700           COMPUTE PPS-TRANSFER-PCT =                             07970000
079800               ((H-LOS + .5) / PPS-AVG-LOS)                       07980000
079900           MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE          07990000
080000           GO TO 3000-EXIT.                                       08000000
080100                                                                  08010000
080200     IF H-LOS > 3                                                 08020000
080300        NEXT SENTENCE                                             08030000
080400     ELSE                                                         08040000
080500        MOVE 'A5001' TO PPS-PRICED-CMG-CODE                       08050000
080600        SET DX6 TO 88                                             08060000
080700        MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT                  08070000
080800        GO TO 3000-EXIT.                                          08080000
080900                                                                  08090000
081000     IF B-PATIENT-STATUS = '20'                                   08100000
081100        NEXT SENTENCE                                             08110000
081200     ELSE                                                         08120000
081300        MOVE PPS-SUBM-CMG-CODE TO PPS-PRICED-CMG-CODE             08130000
081400        GO TO 3000-EXIT.                                          08140000
081500                                                                  08150000
081600     IF PPS-CMG-RIC = ('07' OR '08' OR '09')                      08160000
081700        IF H-LOS < 14                                             08170000
081800           MOVE 'A5101' TO PPS-PRICED-CMG-CODE                    08180000
081900           SET DX6 TO 89                                          08190000
082000           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08200000
082100        ELSE                                                      08210000
082200           MOVE 'A5102' TO PPS-PRICED-CMG-CODE                    08220000
082300           SET DX6 TO 90                                          08230000
082400           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08240000
082500     ELSE                                                         08250000
082600        IF H-LOS < 16                                             08260000
082700           MOVE 'A5103' TO PPS-PRICED-CMG-CODE                    08270000
082800           SET DX6 TO 91                                          08280000
082900           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT               08290000
083000        ELSE                                                      08300000
083100           MOVE 'A5104' TO PPS-PRICED-CMG-CODE                    08310000
083200           SET DX6 TO 92                                          08320000
083300           MOVE A-REL-WGT (DX6) TO PPS-RELATIVE-WGT.              08330000
083400                                                                  08340000
083500 3000-EXIT.                                                       08350000
083600      EXIT.                                                       08360000
083700                                                                  08370000
083800 3500-CONTINUE-CALC.                                              08380000
083900                                                                  08390000
084000     COMPUTE PPS-STANDARD-PAY-AMT =                               08400000
084100            (PPS-TRANSFER-PCT * PPS-RELATIVE-WGT                  08410000
084200                      * PPS-BDGT-NEUT-CONV-AMT).                  08420000
084300                                                                  08430000
084400***************************************************************   08440000
084500*      CHANGE RURAL ADJUSTMENT AMOUNT IF NECESSARY            *   08450000
084600*      - PER CHANGE REQUEST                                   *   08460000
084700***************************************************************   08470000
084800     IF W-NEW-CBSA (1:3) = '   '                                  08480000
084900        MOVE 1.1840 TO PPS-RURAL-ADJUSTMENT                       08490008
085000     ELSE                                                         08500000
085100        MOVE 1.0000 TO PPS-RURAL-ADJUSTMENT.                      08510000
085200                                                                  08520000
085300***************************************************************   08530000
085400*      CHANGE RURAL ADJUSTMENT BASED ON RELIEF INDICATOR      *   08540000
085500*       IF NECESSARY - PER CHANGE REQUEST                     *   08550000
085600***************************************************************   08560000
085700** REMOVED FOR 2008 RELEASE                                       08570000
085800**   IF P-NEW-TEMP-RELIEF-IND = 'Y'                               08580000
085900**      MOVE 1.0638 TO PPS-RURAL-ADJUSTMENT.                      08590000
086000                                                                  08600000
086100     COMPUTE H-LABOR-PORTION =                                    08610000
086200        (PPS-STANDARD-PAY-AMT * PPS-NAT-LABOR-PCT)                08620000
086300          * PPS-WAGE-INDEX.                                       08630000
086400                                                                  08640000
086500     COMPUTE H-NONLABOR-PORTION =                                 08650000
086600        (PPS-STANDARD-PAY-AMT * PPS-NAT-NONLABOR-PCT).            08660000
086700                                                                  08670000
086800     COMPUTE PPS-FED-PAY-AMT ROUNDED =                            08680000
086900        ((H-LABOR-PORTION + H-NONLABOR-PORTION) *                 08690000
087000         PPS-RURAL-ADJUSTMENT).                                   08700000
087100                                                                  08710000
087200     COMPUTE PPS-LIP-PAY-AMT ROUNDED =                            08720000
087300        (PPS-FED-PAY-AMT * PPS-LIP-PCT).                          08730000
087400                                                                  08740000
087500     COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                          08750000
087600        (PPS-FED-PAY-AMT * H-TEACH-PCT).                          08760000
087700                                                                  08770000
087800 3500-EXIT.                                                       08780000
087900      EXIT.                                                       08790000
088000                                                                  08800000
088100 4000-CALC-OUTLIER.                                               08810000
088200                                                                  08820000
088300     COMPUTE PPS-FAC-COSTS ROUNDED =                              08830000
088400         (B-COV-CHARGES * P-NEW-OPER-CSTCHG-RATIO).               08840000
088500                                                                  08850000
088600     COMPUTE H-OUTLIER-LABOR-PORTION =                            08860000
088700        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-LABOR-PCT)               08870000
088800              * PPS-WAGE-INDEX.                                   08880000
088900                                                                  08890000
089000     COMPUTE H-OUTLIER-NONLABOR-PORTION =                         08900000
089100        (PPS-NAT-THRESHOLD-ADJ * PPS-NAT-NONLABOR-PCT).           08910000
089200                                                                  08920000
089300     COMPUTE H-FP-OUTLIER-THRESHOLD ROUNDED =                     08930000
089400        ((H-OUTLIER-LABOR-PORTION + H-OUTLIER-NONLABOR-PORTION) * 08940000
089500         PPS-RURAL-ADJUSTMENT * (PPS-LIP-PCT + H-TEACH-PCT + 1)). 08950000
089600                                                                  08960000
089700     COMPUTE H-OUTLIER-THRESHOLD ROUNDED =                        08970000
089800        (PPS-FED-PAY-AMT + H-FP-OUTLIER-THRESHOLD +               08980000
089900         PPS-LIP-PAY-AMT + PPS-TEACH-PAY-AMT).                    08990000
090000                                                                  09000000
090100     IF PPS-FAC-COSTS > H-OUTLIER-THRESHOLD                       09010000
090200        COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                     09020000
090300           ((PPS-FAC-COSTS - H-OUTLIER-THRESHOLD) * .8).          09030000
090400                                                                  09040000
090500     COMPUTE H-CHG-OUTLIER-THRESHOLD ROUNDED =                    09050000
090600         H-OUTLIER-THRESHOLD / P-NEW-OPER-CSTCHG-RATIO.           09060000
090700                                                                  09070000
090800                                                                  09080000
090900 4000-EXIT.                                                       09090000
091000      EXIT.                                                       09100000
091100                                                                  09110000
091200 5000-FINAL-PAYMENTS.                                             09120000
091300                                                                  09130000
091400     IF B-SPEC-PAY-IND = '1' OR '3'                               09140000
091500         MOVE ZEROES TO PPS-OUTLIER-PAY-AMT.                      09150000
091600                                                                  09160000
091700     IF PPS-FED-RATE-PCT = 1.0000                                 09170000
091800         MOVE 0 TO PPS-FAC-SPEC-PAY-AMT                           09180000
091900     ELSE                                                         09190000
092000         COMPUTE PPS-FED-PAY-AMT ROUNDED =                        09200000
092100           (PPS-FED-RATE-PCT * PPS-FED-PAY-AMT)                   09210000
092200         COMPUTE PPS-FAC-SPEC-PAY-AMT ROUNDED =                   09220000
092300           (PPS-FAC-RATE-PCT * PPS-FAC-SPEC-RT-PREBLEND)          09230000
092400         COMPUTE PPS-OUTLIER-PAY-AMT ROUNDED =                    09240000
092500           (PPS-FED-RATE-PCT * PPS-OUTLIER-PAY-AMT)               09250000
092600         COMPUTE PPS-TEACH-PAY-AMT ROUNDED =                      09260000
092700           (PPS-FED-RATE-PCT * PPS-TEACH-PAY-AMT)                 09270000
092800         COMPUTE PPS-LIP-PAY-AMT ROUNDED =                        09280000
092900           (PPS-FED-RATE-PCT * PPS-LIP-PAY-AMT).                  09290000
093000                                                                  09300000
093100     IF B-SPEC-PAY-IND = '2' OR '3'                               09310000
093200        COMPUTE PPS-FED-PENALTY-AMT ROUNDED =                     09320000
093300           (PPS-FED-PAY-AMT * .25)                                09330000
093400        COMPUTE PPS-FED-PAY-AMT =                                 09340000
093500           (PPS-FED-PAY-AMT - PPS-FED-PENALTY-AMT)                09350000
093600        COMPUTE PPS-LIP-PENALTY-AMT ROUNDED =                     09360000
093700           (PPS-LIP-PAY-AMT * .25)                                09370000
093800        COMPUTE PPS-LIP-PAY-AMT =                                 09380000
093900           (PPS-LIP-PAY-AMT - PPS-LIP-PENALTY-AMT)                09390000
094000        COMPUTE PPS-OUT-PENALTY-AMT ROUNDED =                     09400000
094100           (PPS-OUTLIER-PAY-AMT * .25)                            09410000
094200        COMPUTE PPS-OUTLIER-PAY-AMT =                             09420000
094300           (PPS-OUTLIER-PAY-AMT - PPS-OUT-PENALTY-AMT)            09430000
094400        COMPUTE PPS-TEACH-PENALTY-AMT ROUNDED =                   09440000
094500           (PPS-TEACH-PAY-AMT * .25)                              09450000
094600        COMPUTE PPS-TEACH-PAY-AMT =                               09460000
094700           (PPS-TEACH-PAY-AMT - PPS-TEACH-PENALTY-AMT)            09470000
094800        COMPUTE PPS-TOTAL-PENALTY-AMT =                           09480000
094900           (PPS-FED-PENALTY-AMT + PPS-LIP-PENALTY-AMT             09490000
095000           + PPS-OUT-PENALTY-AMT + PPS-TEACH-PENALTY-AMT).        09500000
095100                                                                  09510000
095200     COMPUTE PPS-TOTAL-PAY-AMT ROUNDED =                          09520000
095300        (PPS-FED-PAY-AMT + PPS-FAC-SPEC-PAY-AMT                   09530000
095400         + PPS-OUTLIER-PAY-AMT + PPS-LIP-PAY-AMT +                09540000
095500         PPS-TEACH-PAY-AMT).                                      09550000
095600                                                                  09560000
095700     IF PPS-FED-RATE-PCT = 1.0000                                 09570000
095800        IF PPS-TRANSFER-PCT = 1.0000                              09580000
095900           IF PPS-OUTLIER-PAY-AMT > 0.0                           09590000
096000              MOVE 01 TO PPS-RTC                                  09600000
096100           ELSE                                                   09610000
096200              MOVE 00 TO PPS-RTC                                  09620000
096300        ELSE                                                      09630000
096400           IF PPS-OUTLIER-PAY-AMT > 0.0                           09640000
096500              MOVE 03 TO PPS-RTC                                  09650000
096600           ELSE                                                   09660000
096700              MOVE 02 TO PPS-RTC                                  09670000
096800     ELSE                                                         09680000
096900        IF PPS-TRANSFER-PCT = 1.0000                              09690000
097000           IF PPS-OUTLIER-PAY-AMT > 0.0                           09700000
097100              MOVE 05 TO PPS-RTC                                  09710000
097200           ELSE                                                   09720000
097300              MOVE 04 TO PPS-RTC                                  09730000
097400        ELSE                                                      09740000
097500           IF PPS-OUTLIER-PAY-AMT > 0.0                           09750000
097600              MOVE 07 TO PPS-RTC                                  09760000
097700           ELSE                                                   09770000
097800              MOVE 06 TO PPS-RTC.                                 09780000
097900                                                                  09790000
098000     IF B-SPEC-PAY-IND = '2' OR '3'                               09800000
098100        COMPUTE PPS-RTC = PPS-RTC + 10.                           09810000
098200     IF PPS-RTC = (01 OR 03 OR 05 OR 07                           09820000
098300                OR 11 OR 13 OR 15 OR 17)                          09830000
098400        IF ((PPS-REG-DAYS-USED + PPS-LTR-DAYS-USED) < H-LOS)      09840000
098500           OR PPS-COT-IND = 'Y'                                   09850000
098600            MOVE 67 TO PPS-RTC.                                   09860000
098700                                                                  09870000
098800 5000-EXIT.                                                       09880000
098900      EXIT.                                                       09890000
099000                                                                  09900000
099100 9000-MOVE-RESULTS.                                               09910000
099200                                                                  09920000
099300     IF PPS-RTC < 50                                              09930000
099400      MOVE H-LOS                   TO  PPS-LOS                    09940000
099500      MOVE H-OUTLIER-THRESHOLD     TO  PPS-OUTLIER-THRESHOLD      09950000
099600      MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD   09960000
099700      MOVE W-NEW-CBSA              TO  PPS-CBSA                   09970000
099800      MOVE 'V11.0'                 TO  PPS-CALC-VERS-CD           09980025
099900     ELSE                                                         09990000
100000       INITIALIZE PPS-DATA                                        10000000
100100       INITIALIZE PPS-OTHER-DATA                                  10010000
100200       MOVE 'V11.0'                TO  PPS-CALC-VERS-CD.          10020025
100300                                                                  10030000
100400     IF PPS-RTC = 67                                              10040000
100500       MOVE H-CHG-OUTLIER-THRESHOLD TO PPS-CHG-OUTLIER-THRESHOLD. 10050000
100600                                                                  10060000
100700 9000-EXIT.                                                       10070000
100800      EXIT.                                                       10080000
100900                                                                  10090000
101000******        L A S T   S O U R C E   S T A T E M E N T   *****   10100000
