Produced by Araxis Merge on 2/15/2018 4:25:50 PM Eastern Standard Time. See www.araxis.com for information about Merge. This report uses XHTML and CSS2, and is best viewed with a modern standards-compliant browser. For optimum results when printing this report, use landscape orientation and enable printing of background images and colours in your browser.
| # | Location | File | Last Modified |
|---|---|---|---|
| 1 | eBilling_Bld22_IB_2_608.zip | TAS eBill SDD US1108 2488 v2.00.docx | Tue Dec 19 16:26:29 2017 UTC |
| 2 | eBilling_Bld22_IB_2_608.zip | TAS eBill SDD US1108 2488 v2.00.docx | Thu Feb 15 18:15:47 2018 UTC |
| Description | Between Files 1 and 2 |
|
|---|---|---|
| Text Blocks | Lines | |
| Unchanged | 1 | 8546 |
| Changed | 0 | 0 |
| Inserted | 0 | 0 |
| Removed | 0 | 0 |
| Whitespace | |
|---|---|
| Character case | Differences in character case are significant |
| Line endings | Differences in line endings (CR and LF characters) are ignored |
| CR/LF characters | Not shown in the comparison detail |
No regular expressions were active.
| 1 | TAS eBilli ng SDD | |
| 2 | US-1108 | |
| 3 | US-2488 | |
| 4 | V2.00 | |
| 5 | System Des ign Docume nt | |
| 6 | IB*2.0*592 | |
| 7 | ||
| 8 | ||
| 9 | ||
| 10 | ||
| 11 | Department of Vetera ns Affairs | |
| 12 | August 201 7 | |
| 13 | Version 2. 00 | |
| 14 | User Story Number: U S-1108, US -2488 | |
| 15 | User Story Name: Ent er/Edit De ntal Claim s, Update Reports – Form Type J430D | |
| 16 | Product Ba cklog ID: n/a | |
| 17 | ||
| 18 | Design/Ass umptions: | |
| 19 | The design for this user story is going on the fol lowing ass umptions: | |
| 20 | The dental specific claim info rmation th at is not available via the pa tient enco unter reco rds will b e availabl e to the b illing cle rks for ma nual entry . | |
| 21 | Dental cla ims will n ot be prin table loca lly. | |
| 22 | VistA will provide t he non-X12 data elem ent VAMC S ide/Div ID to the cl earinghous e so they can create their cla ims report s that the y return t o VistA. | |
| 23 | There will be a way in VistA f or the IB software t o identify the event as a dent al event. | |
| 24 | TJPI is co vered in U S14. | |
| 25 | The IB sys tem will p rovide the ability f or users t o view/inp ut the add itional Fo rm Type J4 03D or For m Type des ignation ( I/P/D) whe n one of t he followi ng reports /options s earches or displays the form t ype: | |
| 26 | View/Print EOB | |
| 27 | EDI Claim Status Rep ort | |
| 28 | View/Resub mit Claims – Live or Test | |
| 29 | Ready for Extract St atus Repor t | |
| 30 | HCCH Payer ID Report | |
| 31 | View/Print EDI Bill Extract Da ta | |
| 32 | Provider I D Query (C PAC) | |
| 33 | Resolution Summary: | |
| 34 | To resolve this requ est, the f ollowing b ullet item s will nee d to be re solved: | |
| 35 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to provi de the abi lity to Cr eate and m aintain a new Form T ype J430D for Dental Claims. | |
| 36 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to retri eve the av ailable da ta from th e Patient’ s PCE (Pat ient Care Encounter) and make it availab le to the user to ad d to the c laim. | |
| 37 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to defau lt the CHA RGE TYPE f or Dental Claim to t hat of Pro fessional. | |
| 38 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to provi de a NEW P ROVIDER TY PE to be a dded to De ntal claim s at eithe r the line level or the claim level equa l to ASSIS TANT SURGE ON with th e qualifie r equal to DD. | |
| 39 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to provi de the fol lowing new Line Leve l Data Fie lds for De ntal Proce dures: | |
| 40 | Oral Cavit y Designat ion [Up to 5 Procedu res] | |
| 41 | Prosthesis /Crown/Inl ay Code; d efine fiel d as a SET with the following values: | |
| 42 | I = Initia l Placemen t | |
| 43 | R = Replac ement | |
| 44 | Prior Plac ement Date and Quali fier; REQU IRED when Prosthesis /Crown/Inl ay Code is equal to “R”eplacem ent. This field sho uld be def ined as a SET with t he followi ng values: | |
| 45 | 139 = Esti mated | |
| 46 | 441 = Prio r Placemen t | |
| 47 | Tooth Code [New File containin g the 32 d ifferent T eeth] | |
| 48 | Tooth Surf ace Code; define fie ld as a SE T with the following values: | |
| 49 | B = Buccal | |
| 50 | D = Distal | |
| 51 | F = Facial | |
| 52 | I = Incisa l | |
| 53 | L = Lingua l | |
| 54 | M = Mesial | |
| 55 | O = Occlus al | |
| 56 | Orthodonti c Banding Date; this is the da te the pat ient’s ort hodontic a ppliances were place d. | |
| 57 | Orthodonti c Banding Replacemen t Date | |
| 58 | Treatment Start Date | |
| 59 | Treatment Completion Date | |
| 60 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to provi de the fol lowing new Line Clai m Data Fie lds for De ntal Claim s: | |
| 61 | Tooth Numb er | |
| 62 | Tooth Stat us Code | |
| 63 | Orthodonti c Banding Date | |
| 64 | Orthodonti c Treatmen t Months C ount | |
| 65 | Orthodonti c Treatmen t Months R emaining | |
| 66 | Treatment Indicator; this is a YES or NO field | |
| 67 | Attachment Report Ty pe; define field as a SET with the follo wing value s: | |
| 68 | B4 = Refer ral Form | |
| 69 | DA = Denta l Models | |
| 70 | DG = Diagn ostic Repo rt | |
| 71 | EB = EOB ( COB o Medi care Secon dary Repor t) | |
| 72 | OZ = Suppo rt Data fo r Claim | |
| 73 | P6 = Perio dontal Cha rts | |
| 74 | RB = Radio logy Films | |
| 75 | RR = Radio logy Repor ts | |
| 76 | Transmissi on Method; the REQUI RED logic is the sam e as the c urrent Att achment Re port field s in Scree n 8. | |
| 77 | Attachment Control N umber; the REQUIRED logic is t he same as the curre nt Attachm ent Report fields in Screen 8. | |
| 78 | Claim Note ; this sho uld be an 80 charact er free te xt field. | |
| 79 | Modify the Enter/Edi t Billing Informatio n [IB EDIT BILLING I NFO] optio n to creat e a Dental 837 trans action for Dental Ev ents even though the Charge Ty pe is Prof essional. | |
| 80 | The Enter/ Edit Billi ng Informa tion [IB E DIT BILLIN G INFO] op tion shoul d prevent the Local Printing o f Dental C laims. | |
| 81 | The Enter/ Edit Billi ng Informa tion [IB E DIT BILLIN G INFO] op tion will prevent th e creation of dental claims to the insur ance compa ny, Medica re (WNR). | |
| 82 | The IB Sys tem will p rovide the ability f or users t o view/inp ut the add itional Fo rm Type J4 30D or For m Type des ignation ( I/P/D) whe n one of t he followi ng reports /options s earches or displays the form t ype: | |
| 83 | View/Print EOB | |
| 84 | EDI Claim Status Rep ort | |
| 85 | View/Resub mit Claims – Live or Test | |
| 86 | Ready for Extract St atus Repor t | |
| 87 | HCCH Payer ID Report | |
| 88 | View/Print EDI Bill Extract Da ta | |
| 89 | Provider I D Query (C PAC) | |
| 90 | ||
| 91 | The IB Sys tem will p rovide the ability f or users t o continue to use th e GEN Prin t Bill opt ion, [IB P RINT BILL] , to view, the scree ns of prev iously tra nsmitted d ental clai ms while p reventing their abil ity to pri nt those c laims. | |
| 92 | Design Con straints: | |
| 93 | This SDD i s dependen t upon the following User Stor ies: | |
| 94 | US131 (Cre ate 837D T ransaction ) | |
| 95 | US1109 (Cr eate Denta l Form/Upd ate Autobi ller) | |
| 96 | US2487 (In surance Co mpany Entr y/Edit – D ental) | |
| 97 | US2503 (Pr ovider ID Maintenanc e Dental) | |
| 98 | IOC Sites must provi de Dental Services t o their bi llable Vet erans. | |
| 99 | FSC must p rovide tes ting resou rces. | |
| 100 | HCCH must provide te sting reso urces. | |
| 101 | Detailed D esign: | |
| 102 | Create a n ew Form Ty pe “J430D” in Bill F orm Type f ile [#353] . Form ty pe must be setup as a printabl e form, ev en though it will no t be print able, but for screen entry pur poses, it needs to b e a printa ble form. National Form field needs to be set to Yes, to al low billin g screen e ntry. | |
| 103 | NUMBER: 7 N AME: J430D | |
| 104 | FORMAT T YPE: PRINT ED FORM NATIONAL F ORM: YES | |
| 105 | SHORT DE SCRIPTION: Dental Fo rm | |
| 106 | ||
| 107 | The Bill/C laims File [#399] re quires the following new field s to be de fined. | |
| 108 | ||
| 109 | DATA NAME GLOB AL DA TA | |
| 110 | ELEMENT TITLE LOCA TION TY PE | |
| 111 | ---------- ---------- ---------- ---------- ---------- ---------- ---------- ------- | |
| 112 | ||
| 113 | 399.0304,9 0.01ORAL C AVITY DESI GNATION (1 ) DEN;1 SE T | |
| 114 | ||
| 115 | '00' FOR Entire Or al Cavity; | |
| 116 | '01' FOR Maxillary Arch; | |
| 117 | '02' FOR Mandibula r Arch; | |
| 118 | '10' F OR Upper R ight Quadr ant; | |
| 119 | '20' F OR Upper L eft Quadra nt; | |
| 120 | '30' F OR Lower L eft Quadra nt; | |
| 121 | '40' F OR Lower R ight Quadr ant; | |
| 122 | LAST E DITED: MAR 02, 2017 | |
| 123 | HELP-P ROMPT: Enter a valid Cavi ty Designa tion code. The | |
| 124 | entered code must not alread y be prese nt in | |
| 125 | Oral Cav ity Design ations #2, #3, #4 or #5. | |
| 126 | DESCRI PTION: The firs t Oral Cav ity Design ation code . You | |
| 127 | can ente r up to fi ve codes. | |
| 128 | ||
| 129 | SCREEN : S DIC("S ")="I $$OR ALCAV^IBCU 7(90.01)" | |
| 130 | EXPLAN ATION: Only all ows Oral C avity Desi gnation Co des | |
| 131 | that are not alrea dy present in Oral C avity | |
| 132 | Designat ions #2, # 3, #4 or # 5. | |
| 133 | ||
| 134 | 399.0304,9 0.02ORAL C AVITY DESI GNATION (2 ) DEN;2 SE T | |
| 135 | ||
| 136 | '00' FOR Entire Or al Cavity; | |
| 137 | '01' FOR Maxill ary Arch; | |
| 138 | '02' F OR Mandibu lar Arch; | |
| 139 | '10' F OR Upper R ight Quadr ant; | |
| 140 | '20' F OR Upper L eft Quadra nt; | |
| 141 | '30' F OR Lower L eft Quadra nt; | |
| 142 | '40' F OR Lower R ight Quadr ant; | |
| 143 | LAST E DITED: MAR 02, 2017 | |
| 144 | HELP-P ROMPT: Enter a valid Oral Cavity De signation Code. | |
| 145 | The ente red code m ust not al ready be p resent | |
| 146 | in Oral Cavity Des ignations #1, #3, #4 or #5. | |
| 147 | DESCRI PTION: The seco nd Oral Ca vity Desig nation cod e. You | |
| 148 | can ente r up to fi ve codes. | |
| 149 | ||
| 150 | SCREEN : S DIC("S ")="I $$OR ALCAV^IBCU 7(90.02)" | |
| 151 | EXPLAN ATION: Only all ows Oral C avity Desi gnation Co des | |
| 152 | that are not alrea dy present in Oral C avity | |
| 153 | Designat ions #1, # 3, #4 or # 5. | |
| 154 | ||
| 155 | 399.0304,9 0.03ORAL C AVITY DESI GNATION (3 ) DEN;3 SE T | |
| 156 | ||
| 157 | '00' FOR Entire Or al Cavity; | |
| 158 | '01' FOR Maxillary Arch; | |
| 159 | '02' FOR Mandibula r Arch; | |
| 160 | '10' F OR Upper R ight Quadr ant; | |
| 161 | '20' FOR Upper Left Quadrant; | |
| 162 | '30' F OR Lower L eft Quadra nt; | |
| 163 | '40' F OR Lower R ight Quadr ant; | |
| 164 | LAST E DITED: MAR 02, 2017 | |
| 165 | HELP-P ROMPT: Enter a valid Oral Cavity De signation Code. | |
| 166 | The ente red code m ust not al ready be p resent | |
| 167 | in Oral Cavity Des ignations #1, #2, #4 or #5. | |
| 168 | DESCRI PTION: The thir d Oral Cav ity Design ation code . You | |
| 169 | can ente r up to fi ve codes. | |
| 170 | ||
| 171 | SCREEN : S DIC("S ")="I $$OR ALCAV^IBCU 7(90.03)" | |
| 172 | EXPLAN ATION: Only all ows Oral C avity Desi gnation Co des | |
| 173 | That are not alrea dy present in Oral C avity | |
| 174 | Designat ions #1, # 2, #4 or # 5. | |
| 175 | ||
| 176 | 399.0304,9 0.04ORAL C AVITY DESI GNATION (4 ) DEN;4 SE T | |
| 177 | ||
| 178 | '00' FOR Entire Or al Cavity; | |
| 179 | '01' FOR Maxillary Arch; | |
| 180 | '02' FOR Mandibula r Arch; | |
| 181 | '10' FOR U pper Right Quadrant; | |
| 182 | '20' F OR Upper L eft Quadra nt; | |
| 183 | '30' F OR Lower L eft Quadra nt; | |
| 184 | '40' F OR Lower R ight Quadr ant; | |
| 185 | LAST E DITED: MAR 02, 2017 | |
| 186 | HELP-P ROMPT: Enter a valid Oral Cavity De signation code. | |
| 187 | The ente red code m ust not al ready be p resent | |
| 188 | in Oral Cavity Des ignations #1, #2, #3 or #5. | |
| 189 | DESCRI PTION: The four th Oral Ca vity Desig nation cod e. You | |
| 190 | can ente r up to fi ve codes. | |
| 191 | ||
| 192 | SCREEN : S DIC("S ")="I $$OR ALCAV^IBCU 7(90.04)" | |
| 193 | EXPLAN ATION: Only all ows Oral C avity Desi gnation Co des | |
| 194 | that are not alrea dy present in Oral C avity | |
| 195 | Designat ions #1, # 2, #3 or # 5. | |
| 196 | ||
| 197 | 399.0304,9 0.05ORAL C AVITY DESI GNATION (5 ) DEN;5 SE T | |
| 198 | ||
| 199 | '00' FOR Entire Or al Cavity; | |
| 200 | '01' FOR Maxillary Arch; | |
| 201 | '02' FOR Mandibula r Arch; | |
| 202 | '10' F OR Upper R ight Quadr ant; | |
| 203 | '20' F OR Upper L eft Quadra nt; | |
| 204 | '30' F OR Lower L eft Quadra nt; | |
| 205 | '40' F OR Lower R ight Quadr ant; | |
| 206 | LAST E DITED: MAR 02, 2017 | |
| 207 | HELP-P ROMPT: Enter a valid Oral Cavity De signation code. | |
| 208 | The ente red code m ust not al ready be p resent | |
| 209 | in Oral Cavity Des ignations #1, #2, #3 or #4. | |
| 210 | DESCRI PTION: The fift h Oral Cav ity Design ation code . You | |
| 211 | can ente r up to fi ve codes. | |
| 212 | ||
| 213 | SCREEN : S DIC("S ")="I $$OR ALCAV^IBCU 7(90.05)" | |
| 214 | EXPLAN ATION: Only all ows Oral C avity Desi gnation Co des | |
| 215 | that are not alrea dy present in Oral C avity | |
| 216 | Designat ions #1, # 2, #3 and #4. | |
| 217 | ||
| 218 | 399.0304,9 0.06PROSTH ESIS/CROWN /INLAY COD E DEN;6 SE T | |
| 219 | ||
| 220 | 'I' FOR Initial Pl acement; | |
| 221 | 'R' FOR Replacemen t; | |
| 222 | LAST E DITED: JUN 28, 2017 | |
| 223 | HELP-P ROMPT: Select a code that indicates the place ment | |
| 224 | status o f the pros thesis, cr own or inl ay. DE SCRIPTION: This is th e placemen t status o f the | |
| 225 | prosthes is. | |
| 226 | ||
| 227 | ||
| 228 | 399.0304,9 0.07PRIOR PLACEMENT DATE QUALI FIER DEN;7 SET | |
| 229 | ||
| 230 | '139' FO R Estimate d; | |
| 231 | '441' FO R Prior Pl acement; | |
| 232 | LAST E DITED: JUN 14, 2017 | |
| 233 | HELP-P ROMPT: Select a qualifier that indi cates whet her or | |
| 234 | not the Prior Plac ement Date is known or just | |
| 235 | estimate d. | |
| 236 | DESCRI PTION: This is the date t hat indica tes whethe r the | |
| 237 | Prior Pl acement Da te is know n or is | |
| 238 | estimate d. | |
| 239 | ||
| 240 | ||
| 241 | 399.0304,9 0.08PRIOR PLACEMENT DATE DEN ;8 DATE | |
| 242 | ||
| 243 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 244 | LAST E DITED: JUN 14, 2017 | |
| 245 | HELP-P ROMPT: Enter th e date whe n the pros thesis, cr own or | |
| 246 | inlay wa s replaced . Date is REQUIRED when | |
| 247 | Prosthes is/Crown/I nlay code equals | |
| 248 | Replacem ent. | |
| 249 | DESCRI PTION: This dat e indicate s when a p rosthesis, crown | |
| 250 | or inlay was repla ced. | |
| 251 | ||
| 252 | ||
| 253 | 399.0304,9 0.09ORTHOD ONTIC BAND ING DATE D EN;9 DATE | |
| 254 | ||
| 255 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 256 | LAST E DITED: JUN 28, 2017 | |
| 257 | HELP-P ROMPT: Enter th e date the patient's orthodont ic | |
| 258 | applianc es were pl aced if di fferent fr om the | |
| 259 | claim le vel date. | |
| 260 | DESCRI PTION: This is the date t he patient 's orthodo ntic | |
| 261 | applianc es were pl aced if di fferent fr om the | |
| 262 | claim le vel date. | |
| 263 | ||
| 264 | ||
| 265 | ||
| 266 | 399.0304,9 0.1 ORTHO BANDING RE PLACEMENT DATE DEN;1 0 DATE | |
| 267 | ||
| 268 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 269 | LAST E DITED: JUN 28, 2017 | |
| 270 | HELP-P ROMPT: Enter th e date the patient's orthodont ic | |
| 271 | applianc es were re placed. | |
| 272 | DESCRI PTION: This is the date t he patient 's orthodo ntic | |
| 273 | applianc es were re placed. | |
| 274 | ||
| 275 | ||
| 276 | 399.0304,9 0.11TREATM ENT START DATE DEN ;11 DATE | |
| 277 | ||
| 278 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 279 | LAST E DITED: JUN 28, 2017 | |
| 280 | HELP-P ROMPT: Enter th e date for initial i mpression or | |
| 281 | preparat ion for a crown or d entures or | |
| 282 | initial endodontic treatment or the im plant | |
| 283 | fixture placement. | |
| 284 | DESCRI PTION: This is the date f or initial impressio n or | |
| 285 | preparat ion for a crown or d entures or | |
| 286 | initial endodontic treatment or the im plant | |
| 287 | fixture placement. | |
| 288 | ||
| 289 | ||
| 290 | 399.0304,9 0.12TREATM ENT COMPLE TION DATE DEN;12 DAT E | |
| 291 | ||
| 292 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 293 | LAST E DITED: JUN 28, 2017 | |
| 294 | HELP-P ROMPT: Enter th e date tha t a course of treatm ent was | |
| 295 | complete d. | |
| 296 | DESCRI PTION: This is the date t hat a cour se of trea tment | |
| 297 | was comp leted. | |
| 298 | ||
| 299 | ||
| 300 | 399.0304,9 1 TOOTH INFORMATIO N DEN 1;0 POINTE R | |
| 301 | Multip le #399.30 491 | |
| 302 | (Add Ne w Entry wi thout Aski ng) | |
| 303 | ||
| 304 | DESCRI PTION: This mul tiple hold s tooth in formation for the | |
| 305 | dental s ervice lin e. | |
| 306 | ||
| 307 | ||
| 308 | 399.30491, .01 TOOT H CODE 0;1 POINT ER TO X12 278 DENTAL NUMBERING | |
| 309 | SYSTEM F ILE (#356. 022) (Mult iply asked ) | |
| 310 | ||
| 311 | LAST EDITED: MAR 02, 2017 | |
| 312 | HELP -PROMPT: Enter a valid Toot h Code. | |
| 313 | DESC RIPTION: | |
| 314 | This ide ntifies th e tooth th at require s work. | |
| 315 | ||
| 316 | CROS S-REFERENC E:399.3049 1^B | |
| 317 | 1)= | |
| 318 | S ^DGCR(3 99,DA(2)," CP",DA(1), "DEN1","B" ,$E(X,1,30 ),DA)="" | |
| 319 | ||
| 320 | 2)= | |
| 321 | K ^DGCR(39 9,DA(2),"C P",DA(1)," DEN1","B", $E(X,1,30) ,DA) | |
| 322 | ||
| 323 | ||
| 324 | 399.30491, .02 TOOT H SURFACE (1) 0;2 SET | |
| 325 | ||
| 326 | 'B' FOR Buccal; | |
| 327 | 'D' FOR Distal; | |
| 328 | 'F' FOR Facial; | |
| 329 | 'I' FOR Incisal; | |
| 330 | 'L' FOR Lingual; | |
| 331 | 'M' FOR Mesial; | |
| 332 | 'O' FOR Occlusal; | |
| 333 | LAST EDITED: MAR 02, 2017 | |
| 334 | HELP -PROMPT: Enter a valid Toot h Surface code. The | |
| 335 | entered code must not alread y be prese nt in | |
| 336 | Tooth Su rfaces #2, #3, #4 or #5. | |
| 337 | DESC RIPTION: The code that best describes the area of the | |
| 338 | tooth th at was tre ated. Up to five To oth | |
| 339 | Surfaces are allow ed. | |
| 340 | ||
| 341 | SCRE EN: S DIC("S ")="I $$TO OTHS^IBCU7 (.02)" | |
| 342 | EXPL ANATION: Only all ow Tooth S urface Cod es that ar e not | |
| 343 | already present in Tooth Sur faces #2, #3, #4 | |
| 344 | or #5. | |
| 345 | ||
| 346 | 399.30491, .03 TOOT H SURFACE (2) 0;3 SET | |
| 347 | ||
| 348 | 'B' FOR Buccal; | |
| 349 | 'D' FOR Distal; | |
| 350 | 'F' FOR Facial; | |
| 351 | 'I' FOR Incisal; | |
| 352 | 'L' FOR Lingual; | |
| 353 | 'M' FOR Mesial; | |
| 354 | 'O' FOR Occlusal; | |
| 355 | LAST EDITED: MAR 02, 2017 | |
| 356 | HELP -PROMPT: Enter a valid Toot h Surface code. The | |
| 357 | Entered code must not alread y be prese nt in | |
| 358 | Tooth Su rfaces #1, #3, #4 or #5. | |
| 359 | DESC RIPTION: The code that best describes the area of the | |
| 360 | tooth th at was tre ated. Up to five To oth | |
| 361 | Surfaces are allow ed. | |
| 362 | ||
| 363 | SCRE EN: S DIC("S ")="I $$TO OTHS^IBCU7 (.03)" | |
| 364 | EXPL ANATION: Only all ow Tooth S urface Cod es that ar e not | |
| 365 | already present in Tooth Sur faces #1, #3, #4 | |
| 366 | or #5. | |
| 367 | ||
| 368 | 399.30491, .04 TOOT H SURFACE (3) 0;4 SET | |
| 369 | ||
| 370 | 'B' FOR Buccal; | |
| 371 | 'D' FOR Distal; | |
| 372 | 'F' FOR Facial; | |
| 373 | 'I' FOR Incisal; | |
| 374 | 'L' FOR Lingual; | |
| 375 | 'M' FOR Mesial; | |
| 376 | 'O' FOR Occlusal; | |
| 377 | LAST EDITED: MAR 02, 2017 | |
| 378 | HELP -PROMPT: Enter a valid Toot h Surface code. The | |
| 379 | entered code must not alread y be prese nt in | |
| 380 | Tooth Su rfaces #1, #2, #4 or #5. | |
| 381 | DESC RIPTION: The code that best describes the area of the | |
| 382 | tooth th at was tre ated. Up to five To oth | |
| 383 | Surfaces are allow ed. | |
| 384 | ||
| 385 | SCRE EN: S DIC("S ")="I $$TO OTHS^IBCU7 (.04)" | |
| 386 | EXPL ANATION: Only all ow Tooth S urface Cod es that ar e not | |
| 387 | already present in Tooth Sur faces #1, #2, #4 | |
| 388 | or #5. | |
| 389 | ||
| 390 | 399.30491, .05 TOOT H SURFACE (4) 0;5 SET | |
| 391 | ||
| 392 | 'B' FOR Buccal; | |
| 393 | 'D' FOR Distal; | |
| 394 | 'F' FOR Facial; | |
| 395 | 'I' FOR Incisal; | |
| 396 | 'L' FOR Lingual; | |
| 397 | 'M' FOR Mesial; | |
| 398 | 'O' FOR Occlusal; | |
| 399 | LAST EDITED: MAR 02, 2017 | |
| 400 | HELP -PROMPT: Enter a valid Toot h Surface code. The | |
| 401 | entered code must not alread y be prese nt in | |
| 402 | Tooth Su rfaces #1, #2, #3 or #5. | |
| 403 | DESC RIPTION: The code that best describes the area of the | |
| 404 | tooth th at was tre ated. Up to five To oth | |
| 405 | Surfaces are allow ed. | |
| 406 | ||
| 407 | SCRE EN: S DIC("S ")="I $$TO OTHS^IBCU7 (.05)" | |
| 408 | EXPL ANATION: Only all ow Tooth S urface cod es that ar e not | |
| 409 | already present in Tooth Sur faces #1, #2, #3 | |
| 410 | or #5. | |
| 411 | ||
| 412 | 399.30491, .06 TOOT H SURFACE (5) 0;6 SET | |
| 413 | ||
| 414 | 'B' FOR Buccal; | |
| 415 | 'D' FOR Distal; | |
| 416 | 'F' FOR Facial; | |
| 417 | 'I' FOR Incisal; | |
| 418 | 'L' FOR Lingual; | |
| 419 | 'M' FOR Mesial; | |
| 420 | 'O' FOR Occlusal; | |
| 421 | LAST EDITED: MAR 02, 2017 | |
| 422 | HELP -PROMPT: Enter a valid Toot h Surface code. The | |
| 423 | entered code must not alread y be prese nt in | |
| 424 | Tooth Su rfaces #1, #2, #3 or #4. | |
| 425 | DESC RIPTION: The code that best describes the area of the | |
| 426 | tooth th at was tre ated. Up to five To oth | |
| 427 | Surfaces are allow ed. | |
| 428 | ||
| 429 | SCRE EN: S DIC("S ")="I $$TO OTHS^IBCU7 (.06)" | |
| 430 | EXPL ANATION: Only all ow Tooth S urface cod es that ar e not | |
| 431 | already present in Tooth Sur faces #1, #2, #3 | |
| 432 | or #4. | |
| 433 | ||
| 434 | ||
| 435 | 399,92 BANDIN G DATE DEN ;1 DATE | |
| 436 | ||
| 437 | INPUT TRANSFORM: S %DT="E X" D ^%DT S X=Y K:Y< 1 X | |
| 438 | LAST E DITED: JUN 28, 2017 | |
| 439 | HELP-P ROMPT: Enter th e date the patient's orthodont ic | |
| 440 | applianc es were pl aced. | |
| 441 | DESCRI PTION: This is the date t he patient 's orthodo ntic | |
| 442 | applianc es were pl aced. | |
| 443 | ||
| 444 | ||
| 445 | 399,93 TREATM ENT MONTHS COUNT DEN ;2 NUMBER | |
| 446 | ||
| 447 | INPUT TRAN SFORM: | |
| 448 | K:+X'=X!( X>99999999 9999999)!( X<0)!(X?.E 1"."1N.N) X | |
| 449 | LAST E DITED: JUN 28, 2017 | |
| 450 | HELP-P ROMPT: Enter th e estimate d number o f treatmen t | |
| 451 | months i n whole nu mbers. | |
| 452 | DE SCRIPTION: This is the es timated nu mber of tr eatment | |
| 453 | months. | |
| 454 | ||
| 455 | ||
| 456 | 399,94 TREATM ENT MONTHS REMAINING DEN;3 NUM BER | |
| 457 | ||
| 458 | INPUT TRANSFORM: | |
| 459 | K:+X'=X!(X >999999999 999999)!(X <0)!(X?.E1 "."1N.N) X | |
| 460 | LAST E DITED: JUN 28, 2017 | |
| 461 | HELP-P ROMPT: Enter th e number o f months r emaining r equired | |
| 462 | for a tr ansfer pat ient, in w hole numbe rs. | |
| 463 | DESCRI PTION: This is the number of months remaining | |
| 464 | required for a tra nsfer pati ent. | |
| 465 | ||
| 466 | ||
| 467 | 399,95 TREATM ENT INDICA TOR DEN ;4 SET | |
| 468 | '0' FOR NO; | |
| 469 | '1' FOR YES; | |
| 470 | LAST E DITED: JUN 28, 2017 | |
| 471 | HELP-P ROMPT: Enter 'Y ES' if ser vices repo rted on th is | |
| 472 | claim ar e for orth odontic pu rposes. | |
| 473 | Otherwis e, enter ' NO'. REQU IRED when neither | |
| 474 | Treatmen t Months n or Treatme nt Months | |
| 475 | Remainin g are pres ent. | |
| 476 | DESCRI PTION: This fie ld indicat es that se rvices rep orted | |
| 477 | on this claim are for orthod ontic purp oses. | |
| 478 | REQUIRED when neit her Treatm ent Months nor | |
| 479 | Treatmen t Months R emaining a re present . | |
| 480 | ||
| 481 | ||
| 482 | 399,96 TOOTH STATUS DEN 1;0 SET Mu ltiple #39 9.096 | |
| 483 | ||
| 484 | DESCRIPT ION: This is a multiple f ield defin ing the te eth | |
| 485 | that the dental se rvices wer e related to. | |
| 486 | ||
| 487 | IDENTI FIED BY: STATUS C ODE(#.02) | |
| 488 | ||
| 489 | 399.096,.0 1 TOOT H NUMBER 0 ;1 NUMBER (Multiply asked) | |
| 490 | ||
| 491 | INPU T TRANSFOR M: K:+X'= X!(X>32)!( X<0)!(X?.E 1"."1N.N) X | |
| 492 | LAST EDITED: MAR 13 , 2017 | |
| 493 | HELP -PROMPT: Type a number be tween 1 an d 32, 0 de cimal | |
| 494 | digits . | |
| 495 | DESC RIPTION: This i s the toot h number t hat is eit her | |
| 496 | missin g or is to be extrac ted. | |
| 497 | ||
| 498 | CROS S-REFERENC E: 399.09 6^B | |
| 499 | 1) = S ^DGCR( 399,DA(1), "DEN1","B" ,$E(X,1,30 ),DA)="" | |
| 500 | ||
| 501 | 2)= K ^DGCR(39 9,DA(1),"D EN1","B",$ E(X,1,30), DA) | |
| 502 | ||
| 503 | 399.096,.0 2 STAT US CODE 0;2 SET | |
| 504 | 'E' FOR EX TRACTED; | |
| 505 | 'M' FOR MI SSING; | |
| 506 | LAST EDITED: JUN 28, 2017 | |
| 507 | HELP -PROMPT: Select t he code th at indicat es whether a | |
| 508 | tooth wi ll be extr acted or i s missing. | |
| 509 | DESC RIPTION: This cod e indicate s whether a tooth wi ll be | |
| 510 | extracte d or is mi ssing. | |
| 511 | ||
| 512 | ||
| 513 | 399,97 DENT AL CLAIM N OTE D EN2;1 FREE TEXT | |
| 514 | ||
| 515 | INPU T TRANSFOR M: K:$L(X )>80!($L(X )<1) X | |
| 516 | LAST EDITED: JUN 28 , 2017 | |
| 517 | HELP -PROMPT: Enter informatio n that is needed to | |
| 518 | substa ntiate the medical t reatment, 1 to 80 | |
| 519 | charac ters. | |
| 520 | DESC RIPTION: This i s an 80 ch aracter fr ee text fi eld to | |
| 521 | allow for the en try of inf ormation t hat is | |
| 522 | needed to substa ntiate med ical treat ment. | |
| 523 | ||
| 524 | ||
| 525 | Screens 5 and 10 req uire modif ications t o allow fo r the view / entry o f the nece ssary Dent al field v alues. Fi le 399, su b-file 399 .0304, sub -file 399. 0404, fiel d .01 LINE FUNCTION and File 3 99, sub-fi le 399.022 2, field . 01 FUNCTIO N are a se t of codes that will need to h ave an add itional op tion added , 6 ASSIST ANT SURGEO N. | |
| 526 | ||
| 527 | 399.0222,. 01 FUNCTIO N 0;1 SET ( Required) (Multiply asked) | |
| 528 | ||
| 529 | '1' FOR REFERRING; | |
| 530 | '2' FOR OPERATING; | |
| 531 | '3' FOR RENDERING; | |
| 532 | '4' FOR ATTENDING; | |
| 533 | '5' FOR SUPERVISIN G; | |
| 534 | '9' FOR OTHER OPER ATING; | |
| 535 | '6' FOR ASSISTANT SURGEON; | |
| 536 | LAST E DITED: MAR 07, 2017 | |
| 537 | HELP-P ROMPT: Select t he functio n performe d by a pro vider | |
| 538 | for this bill. | |
| 539 | DESCRI PTION: There ar e provider s who perf ormed spec ific | |
| 540 | function s for the services o n this bil l. | |
| 541 | These pr oviders ar e needed t o enable t he V.A. | |
| 542 | to colle ct reimbur sement whe n more tha n one | |
| 543 | provider function is involve d in the b illable | |
| 544 | episode (like an o perating p hysician o r | |
| 545 | referrin g provider ). This d ata identi fies | |
| 546 | the type of functi on that wa s performe d by a | |
| 547 | provider . There ca n only be 1 provider | |
| 548 | recorded for each function o n a claim. | |
| 549 | ||
| 550 | SCREEN : S DIC("S ")= | |
| 551 | "I $$PR VOK^IBCEU( +Y,$S($G(D 0):D0,1:$G (DA)))" | |
| 552 | EXPLAN ATION: Function must matc h bill for m type. U se '??' | |
| 553 | to see t he functio n definiti ons. | |
| 554 | EX ECUTABLE H ELP: D PR VHELP^IBCE U5 | |
| 555 | ||
| 556 | 399.0404,. 01 LINE FU NCTION 0;1 SET ( Multiply a sked) | |
| 557 | ||
| 558 | '1' FOR REFERRING; | |
| 559 | '2' FOR OPERATING; | |
| 560 | '3' FOR RENDERING; | |
| 561 | '4' FOR ATTENDING; | |
| 562 | '5' FOR SUPERVISIN G; | |
| 563 | '9' FOR OTHER OPER ATING; | |
| 564 | '6' FOR ASSISTANT SURGEON; | |
| 565 | LAST E DITED: MAR 01, 2017 | |
| 566 | HELP-P ROMPT: Select t he functio n performe d by a pro vider | |
| 567 | for this claim lin e. | |
| 568 | DESCRI PTION: There ar e provider s who perf ormed spec ific | |
| 569 | function s for the services o n this cla im | |
| 570 | line. | |
| 571 | These pr oviders ar e needed t o enable t he V.A. | |
| 572 | to colle ct reimbur sement whe n more tha n one | |
| 573 | provider function is involve d in the b illable | |
| 574 | episode (like an o perating p hysician o r | |
| 575 | referrin g provider ). This da ta identif ies the | |
| 576 | type of function t hat was pe rformed by a | |
| 577 | provider . There c an only be 1 provide r | |
| 578 | recorded for each function o n a claim line. | |
| 579 | ||
| 580 | SCREEN : S DIC("S ")="I $$LN PRVOK^IBCE U7(+Y,$G(D A(2)))" | |
| 581 | EXPLAN ATION: Function must matc h bill for m type. Us e '??' | |
| 582 | to see t he functio n definiti ons. | |
| 583 | EX ECUTABLE H ELP: D LN PRVHLP^IBC EU7 | |
| 584 | ||
| 585 | Screen 8 w ill be mod ified to d isplay a d ifferent s et of fiel ds if the Claim is a Dental Cl aim (See r ecommended changes t o the rout ine IBCSC8 ). The fo llowing da ta diction ary modifi cations ar e required to allow for the vi ew/entry o f the nece ssary Dent al field v alues: | |
| 586 | Field #399 , 285 (Att achment Re port Type) , needs to have the following SCREEN add ed to its field defi nition: | |
| 587 | ||
| 588 | 399,285 ATTACHMEN T REPORT T YPE U8;2 P OINTER TO IB ATTACHM ENT | |
| 589 | REPOR T TYPE FILE (#353.3) | |
| 590 | ||
| 591 | LAST ED ITED: AUG 16, 2 010 | |
| 592 | HELP-PR OMPT: Select an Attachmen t Report T ype. | |
| 593 | DESCRIP TION: This is a Report Ty pe to desc ribe the t ype of | |
| 594 | documenta tion that will provi de additio nal | |
| 595 | informati on for thi s claim. This appli es to | |
| 596 | the entir e claim. | |
| 597 | ||
| 598 | SCREEN: S DIC("S")=” I $$RTYPOK ^IBCEU(X,D A)" | |
| 599 | ||
| 600 | This will allow for the follow ing: | |
| 601 | For all Cl aims that are not De ntal, the Screen wil l prevent the option of P6 (Pe riodontal Charts) fr om being a selected value. | |
| 602 | For those claims tha t are Dent al, the Sc reen will only allow the selec tion of th e followin g values f rom file # 353.3 (IB ATTACHMENT REPORT TY PE): | |
| 603 | B4 = Refer ral Form | |
| 604 | DA = Denta l Models | |
| 605 | DG = Diagn ostic Repo rt | |
| 606 | EB = EOB ( COB o Medi care Secon dary Repor t) | |
| 607 | OZ = Suppo rt Data fo r Claim | |
| 608 | P6 = Perio dontal Cha rts | |
| 609 | RB = Radio logy Films | |
| 610 | RR = Radio logy Repor ts | |
| 611 | ||
| 612 | ||
| 613 | ||
| 614 | The follow ing routin es need to be modifi ed to allo w for the entry/edit of the ne w Dental f ields. | |
| 615 | ||
| 616 | Routines | |
| 617 | Activities | |
| 618 | Routine Na me | |
| 619 | IBCB | |
| 620 | Enhancemen t Category | |
| 621 | New | |
| 622 | Modify | |
| 623 | Delete | |
| 624 | No Change | |
| 625 | RTM | |
| 626 | ||
| 627 | Related Op tions | |
| 628 | None | |
| 629 | Related Ro utines | |
| 630 | Routines “ Called By” | |
| 631 | Routines “ Called” | |
| 632 | ||
| 633 | ||
| 634 | ||
| 635 | ||
| 636 | Data Dicti onary (DD) Reference s | |
| 637 | CLAIMS TRA CKING File [#356] | |
| 638 | Related Pr otocols | |
| 639 | None | |
| 640 | Related In tegration Control Re gistration s (ICRs) | |
| 641 | None | |
| 642 | Data Passi ng | |
| 643 | Input | |
| 644 | Output Re ference | |
| 645 | Both | |
| 646 | Global Re ference | |
| 647 | Local | |
| 648 | Input Attr ibute Name and Defin ition | |
| 649 | Name: | |
| 650 | Definition : | |
| 651 | Output Att ribute Nam e and Defi nition | |
| 652 | Name: | |
| 653 | Definition : | |
| 654 | Current Lo gic | |
| 655 | IBCB ;ALB/ MRL - BILL ING BEGINN ING POINT/ SELECT BIL L OR PATIE NT ;01 JUN 88 12:00 ;;2.0;INTE GRATED BIL LING;**52, 80,106,51, 137,161,19 9,348**;21 -MAR-94;Bu ild 5 ;;Pe r VHA Dire ctive 10-9 3-142, thi s routine should not be modifi ed. ; ;MAP TO DGCRB ;EN ; D HO ME^%ZIS Q: '$D(IBAC) ;*** ;I $D (XRT0) S:' $D(XRTN) X RTN="IBCB" D T1^%ZOS V ;stop rt clock ;S XRTL=$ZU(0 ),XRTN="IB CB-"_$G(IB AC) D T0^% ZOSV ;star t rt clock ; S:'$D(I BV) IBV=1 L K ^UTIL ITY($J),DF N,IBIFN,DI C,IBPOPOUT S DIC(0)= "EQMZ" R ! !,"Enter B ILL NUMBER or PATIEN T NAME: ", IBX:DTIME I IBX["^"! (IBX="") S IBAC1=0 Q K ^TMP("I BCRRX",$J) S IBAC1=1 N DPTNOFZ Y S DPTNOF ZY=1 ;Supp ress PATIE NT file fu zzy lookup s I IBX?1A 4N!(IBX?2A .AP)!(IBX? 2.A1",".AP )!(IBX?1A1 P.AP) S DI C="^DPT(", X=IBX D ^D IC G EN:Y' >0 S DFN=+ Y D HINQ S X=$S('$D( ^DGCR(399, "C",DFN)): 1,'$D(^DGC R(399,"AOP ",DFN)):2, 1:0) I $D( DFN),X,IBA C<4 W !!," No ",$S(X= 1:"",1:"OP EN "),"bil ling recor ds on file for this patient." D ASK I '$ D(IBIFN) G EN I $D(D FN) D G E N . D DATE :'$D(IBIFN ),ASK:'$D( IBIFN) . I $D(IBIFN) D ST S DI C("S")=$S( IBAC'=4&(I BAC'=4.1): "I $P(^(0) ,U,13)<3 D EN^DDIOL( $P(^(0),U) )",1:"I $P (^(""S""), U,17)="""" "_$S(IBAC= 4.1:",$P(^ (0),U,13)= 3,+$$LAST3 64^IBCEF4( +Y),""PX"" [$P($G(^IB A(364,+$$L AST364^IBC EF4(+Y),0) ),U,3)",1: "")) S DIC ="^DGCR(39 9,",X=IBX D ^DIC G:Y '>0 EN S I BIFN=+Y,DF N=$P(Y(0), "^",2) ; D HINQ,ST G EN G ENHI NQ I $S('$ D(^DPT(DFN ,.361)):1, $P(^(.361) ,"^",1)'=" V":1,1:0) W !?17,"** * ELIGIBIL ITY NOT VE RIFIED *** " D HINQ1M T ;I $D(DF N) D ^DGMT 1 K DGMTLL I $D(DFN) D DIS^DGM TU(DFN) QH INQ1 I $P( $G(^IBE(35 0.9,1,1)), "^",16) S X="DVBHQZ4 " X ^%ZOSF ("TEST") K X I $T W ! D EN^DVB HQZ4 Q ;I $P($G(^IBE (350.9,1,1 )),"^",16) F X="DVBH QZ4","DGHI NQZ4" X ^% ZOSF("TEST ") I $T S DGROUT=X K X W ! D @ ("EN^"_DGR OUT) K DGR OUT Q K Y QASK I IBA C'=1 K IBI FN Q W !!, "DO YOU WA NT TO ESTA BLISH A NE W BILLING RECORD FOR '",$P(^DP T(DFN,0)," ^",1),"'" S %=2 D YN ^DICN I '% W !!?4,"Y ES - To es tablish a new billin g record i n the bill ing file." ,!?4,"NO - To discon tinue this process i mmediately ." G ASK I %'=1 K IB IFN Q K DA ,Y,DINUM,I BIFN S (IB NEW,IBYN)= 1 D ^IBCA QDATE I $D (^DGCR(399 ,"C",DFN)) S DA="" F I=1:1 S D A=$O(^DGCR (399,"APDT ",DFN,DA)) Q:DA="" D DATE1 I IBAC=4,'$D (^UTILITY( $J,"IB")) W !,"No ", $S($D(^DGC R(399,"C", DFN)):"UNC ANCELLED " ,1:""),"bi lling reco rds on fil e for this patient." Q S CT=0, CT1=1,IBT= "" F J=1:1 S IBT=$O( ^UTILITY($ J,"IB",IBT )) Q:IBT=" " F J1=0: 0 S J1=$O( ^UTILITY($ J,"IB",IBT ,J1)) Q:J1 ="" S X=J 1 D SETCT W ! S G="" ,CT2=$S(CT <(CT1+4):C T,1:(CT1+4 )) F K=CT1 :1:CT2 I $ D(^UTILITY ($J,"UB",K )) D WRLIN E S X="" D WDATE Q:X ["^" I '$ D(IB),$D(^ UTILITY($J ,"UB",K+1) ) S CT1=K+ 1 G CT K C T,CT1,CT2, K,^UTILITY ($J,"UB") QWRLINE N IBX S IBDA TA=^UTILIT Y($J,"UB", K),IBX=$G( ^DGCR(399, +$P(IBDATA ,"^",2),0) ) W !?2,K, ?6 S Y=+IB DATA X ^DD ("DD") W Y ,?27,$P(IB X,"^",1),? 35,$S($P(I BX,U,21)=" S":"s",$P( IBX,U,21)= "T":"t",1: ""),?38,$P (IBDATA,"^ ",3),?59,$ E($P(IBDAT A,"^",4),1 ,10),?70,$ E($P(IBDAT A,"^",5),1 ,10) QDATE 1 S IBT=$O (^DGCR(399 ,"APDT",DF N,DA,0)) I $D(^DGCR( 399,+DA,0) ),$S(IBAC< 3:$P(^(0), U,13)<2,IB AC=3:$P(^( 0),U,13)<3 ,'$D(^("S" )):0,$P(^( "S"),"^",1 7)]"":0,1: 1) S ^UTIL ITY($J,"IB ",IBT,DA)= "" QWDATE Q:'CT W ! ! W:K<CT " PRESS <RET URN> TO CO NTINUE, OR ",! W "CHO OSE 1",$S( CT=1:"",1: "-"_K),": " R X:DTIM E Q:X["^"! (X="") I X ["?" W !!, "Select on e of the a bove or <R ETURN> to establish a new bill ing record ." G WDATE I $S('$D( ^UTILITY($ J,"UB",+X) ):1,+X>K:1 ,+X<1:1,'( X?.N):1,1: 0) W !!,"N OT A VALID CHOICE!!" ,*7 G WDAT E S IBIFN= $P(^UTILIT Y($J,"UB", X),"^",2), IB=1 Q ;KE YOK(IBIFN, DUZ) ; Che ck if COB bill, does user have key ; IBI FN = ien o f bill (fi le 399) ; N IBCOB,IB OK,DIR,X,Y S IBOK=1, IBCOB=$$CO BN^IBCEF(I BIFN) I IB COB>1 D . S IBCOB=$P ("^SECONDA RY^TERTIAR Y",U,IBCOB ) . S DIR( 0)="YA",DI R("A",1)=" YOU ARE AB OUT TO EDI T A "_IBCO B_" BILL", DIR("A")=" ARE YOU SU RE YOU WAN T TO CONTI NUE?: ",DI R("B")="NO " W ! D ^D IR K DIR W ! . I Y'= 1 S IBOK=0 Q IBOK ;S ET I $S(IB V:1,$P(^DG CR(399,+X, 0),"^",13) :1,1:0) S CT=CT+1 D SET2 QSET2 S IBND0=^ DGCR(399,+ X,0) N IBF TP S IBFTP =$S($$FT^I BCEF(+X)=3 :"/UB",$$F T^IBCEF(+X )=2:"/1500 ",1:"") S ^UTILITY($ J,"UB",CT) =9999999-I BT_"^"_+X_ "^"_$P($G( ^DGCR(399. 3,+$P(IBND 0,"^",7),0 )),"^",4)_ "-"_$$BCHG TYPE^IBCU( +X)_"^"_$P ($P($P($P( ^DD(399,.1 3,0),"^",3 ),$P(IBND0 ,"^",13)_" :",2),";", 1),"/",1) S ^UTILITY ($J,"UB",C T)=^UTILIT Y($J,"UB", CT)_"^"_$S ($P(IBND0, U,27)=1:"I NST"_IBFTP ,$P(IBND0, U,27)=2:"P ROF"_IBFTP ,1:"") QST ; Do not use the va riable IBH when call ing this e ntry point L ^DGCR(3 99,IBIFN): 5 I '$T W !,"No furt her proces sing of th is record permitted at this ti me.",!,"Re cord locke d by anoth er user. T ry again l ater." Q D RECALL^DI LFD(399,IB IFN_",",DU Z) D NOPTF ^IBCB2 I ' IBAC1 D NO PTF1^IBCB2 Q I IBAC' =1&(IBAC'= 4.1) G ST2 ST1 K ^UTI LITY($J) S IBPOPOUT= 0 ; Only a llow view of bill wa iting for MRA or pen ding extra ct I $P($G (^DGCR(399 ,IBIFN,0)) ,U,13)=2 D G Q . W !,"This bi ll is requ esting an MRA - can only view bill data" . S IBV=1 D VIEW^IB CB2 I IBAC =4.1 D G Q . Q:$P($ G(^DGCR(39 9,IBIFN,0) ),U,13)'=3 . N Z . S Z=$P($G(^ IBA(364,+$ $LAST364^I BCEF4(IBIF N),0)),U,3 ) . I Z'=" X"&(Z'="P" ) Q . W !, "This bill has a tra nsmit stat us of ",$$ EXPAND^IBT RE(364,.03 ,Z)," - ca n only vie w bill dat a" . S IBV =1 D VIEW^ IBCB2 D ^I BCSCU,^IBC SC1 G Q:'$ T!($G(IBPO POUT))ST2 K IBTXPRT, IBPOPOUT D ^IBCB1 ; perform IB edits/aut horize the bill I $G (IBCIREDT) G ST1 ; Re-edit the bill KILL IBCIR EDT ; cle an up QUIT ;Q ; K IB IFN,IBV,IB AC ;*** ;I $D(XRT0) S:'$D(XRTN ) XRTN="IB CB" D T1^% ZOSV ;stop rt clock Q ;EDI S I BAC=1,IBV= 0 D EN G Q :'IBAC1,ED IREV G QAU T S IBAC=3 ,IBV=0 D E N G Q:'IBA C1,AUTGEN S IBAC=4,I BV=1 D EN G Q:'IBAC1 ,GENVIEW S IBAC=4.1, IBV=1 D EN G Q:'IBAC 1,VIEW Q ; | |
| 656 | Modified L ogic (Chan ges are in bold) | |
| 657 | IBCB ;ALB/ MRL - BILL ING BEGINN ING POINT/ SELECT BIL L OR PATIE NT ;01 JUN 88 12:00 ;;2.0;INTE GRATED BIL LING;**52, 80,106,51, 137,161,19 9,348,592* *;21-MAR-9 4;Build 5 ;;Per VHA Directive 10-93-142, this rout ine should not be mo dified. ; ;MAP TO DG CRB ;EN ; D HOME^%ZI S Q:'$D(IB AC) ;*** ; I $D(XRT0) S:'$D(XRT N) XRTN="I BCB" D T1^ %ZOSV ;sto p rt clock ;S XRTL=$ ZU(0),XRTN ="IBCB-"_$ G(IBAC) D T0^%ZOSV ; start rt c lock ; S:' $D(IBV) IB V=1 L K ^ UTILITY($J ),DFN,IBIF N,DIC,IBPO POUT S DIC (0)="EQMZ" R !!,"Ent er BILL NU MBER or PA TIENT NAME : ",IBX:DT IME I IBX[ "^"!(IBX=" ") S IBAC1 =0 Q K ^TM P("IBCRRX" ,$J) S IBA C1=1 N DPT NOFZY S DP TNOFZY=1 ; Suppress P ATIENT fil e fuzzy lo okups I IB X?1A4N!(IB X?2A.AP)!( IBX?2.A1", ".AP)!(IBX ?1A1P.AP) S DIC="^DP T(",X=IBX D ^DIC G E N:Y'>0 S D FN=+Y D HI NQ S X=$S( '$D(^DGCR( 399,"C",DF N)):1,'$D( ^DGCR(399, "AOP",DFN) ):2,1:0) I $D(DFN),X ,IBAC<4 W !!,"No ",$ S(X=1:"",1 :"OPEN "), "billing r ecords on file for t his patien t." D ASK I '$D(IBIF N) G EN I $D(DFN) D G EN . D DATE:'$D(I BIFN),ASK: '$D(IBIFN) . I $D(IB IFN) D ST S DIC("S") =$S(IBAC'= 4&(IBAC'=4 .1):"I $P( ^(0),U,13) <3 D EN^DD IOL($P(^(0 ),U))",1:" I $P(^(""S ""),U,17)= """""_$S(I BAC=4.1:", $P(^(0),U, 13)=3,+$$L AST364^IBC EF4(+Y),"" PX""[$P($G (^IBA(364, +$$LAST364 ^IBCEF4(+Y ),0)),U,3) ",1:"")) S DIC="^DGC R(399,",X= IBX D ^DIC G:Y'>0 EN S IBIFN=+ Y,DFN=$P(Y (0),"^",2) ; D HINQ, ST G EN G ENHINQ I $ S('$D(^DPT (DFN,.361) ):1,$P(^(. 361),"^",1 )'="V":1,1 :0) W !?17 ,"*** ELIG IBILITY NO T VERIFIED ***" D HI NQ1MT ;I $ D(DFN) D ^ DGMT1 K DG MTLL I $D( DFN) D DIS ^DGMTU(DFN ) QHINQ1 I $P($G(^IB E(350.9,1, 1)),"^",16 ) S X="DVB HQZ4" X ^% ZOSF("TEST ") K X I $ T W ! D EN ^DVBHQZ4 Q ;I $P($G( ^IBE(350.9 ,1,1)),"^" ,16) F X=" DVBHQZ4"," DGHINQZ4" X ^%ZOSF(" TEST") I $ T S DGROUT =X K X W ! D @("EN^" _DGROUT) K DGROUT Q K Y QASK I IBAC'=1 K IBIFN Q W !!,"DO YO U WANT TO ESTABLISH A NEW BILL ING RECORD FOR '",$P (^DPT(DFN, 0),"^",1), "'" S %=2 D YN^DICN I '% W !!? 4,"YES - T o establis h a new bi lling reco rd in the billing fi le.",!?4," NO - To di scontinue this proce ss immedia tely." G A SK I %'=1 K IBIFN Q K DA,Y,DIN UM,IBIFN S (IBNEW,IB YN)=1 D ^I BCA QDATE I $D(^DGCR (399,"C",D FN)) S DA= "" F I=1:1 S DA=$O(^ DGCR(399," APDT",DFN, DA)) Q:DA= "" D DATE 1 I IBAC=4 ,'$D(^UTIL ITY($J,"IB ")) W !,"N o ",$S($D( ^DGCR(399, "C",DFN)): "UNCANCELL ED ",1:"") ,"billing records on file for this patie nt." Q S C T=0,CT1=1, IBT="" F J =1:1 S IBT =$O(^UTILI TY($J,"IB" ,IBT)) Q:I BT="" F J 1=0:0 S J1 =$O(^UTILI TY($J,"IB" ,IBT,J1)) Q:J1="" S X=J1 D SE TCT W ! S G="",CT2=$ S(CT<(CT1+ 4):CT,1:(C T1+4)) F K =CT1:1:CT2 I $D(^UTI LITY($J,"U B",K)) D W RLINE S X= "" D WDATE Q:X["^" I '$D(IB), $D(^UTILIT Y($J,"UB", K+1)) S CT 1=K+1 G CT K CT,CT1, CT2,K,^UTI LITY($J,"U B") QWRLIN E N IBX S IBDATA=^UT ILITY($J," UB",K),IBX =$G(^DGCR( 399,+$P(IB DATA,"^",2 ),0)) W !? 2,K,?6 S Y =+IBDATA X ^DD("DD") W Y,?27,$ P(IBX,"^", 1),?35,$S( $P(IBX,U,2 1)="S":"s" ,$P(IBX,U, 21)="T":"t ",1:""),?3 8,$P(IBDAT A,"^",3),? 59,$E($P(I BDATA,"^", 4),1,10),? 70,$E($P(I BDATA,"^", 5),1,10) Q DATE1 S IB T=$O(^DGCR (399,"APDT ",DFN,DA,0 )) I $D(^D GCR(399,+D A,0)),$S(I BAC<3:$P(^ (0),U,13)< 2,IBAC=3:$ P(^(0),U,1 3)<3,'$D(^ ("S")):0,$ P(^("S")," ^",17)]"": 0,1:1) S ^ UTILITY($J ,"IB",IBT, DA)="" QWD ATE Q:'CT W !! W:K< CT "PRESS <RETURN> T O CONTINUE , OR",! W "CHOOSE 1" ,$S(CT=1:" ",1:"-"_K) ,": " R X: DTIME Q:X[ "^"!(X="") I X["?" W !!,"Selec t one of t he above o r <RETURN> to establ ish a new billing re cord." G W DATE I $S( '$D(^UTILI TY($J,"UB" ,+X)):1,+X >K:1,+X<1: 1,'(X?.N): 1,1:0) W ! !,"NOT A V ALID CHOIC E!!",*7 G WDATE S IB IFN=$P(^UT ILITY($J," UB",X),"^" ,2),IB=1 Q ;KEYOK(IB IFN,DUZ) ; Check if COB bill, does user have key ; IBIFN = i en of bill (file 399 ) ; N IBCO B,IBOK,DIR ,X,Y S IBO K=1,IBCOB= $$COBN^IBC EF(IBIFN) I IBCOB>1 D . S IBCO B=$P("^SEC ONDARY^TER TIARY",U,I BCOB) . S DIR(0)="YA ",DIR("A", 1)="YOU AR E ABOUT TO EDIT A "_ IBCOB_" BI LL",DIR("A ")="ARE YO U SURE YOU WANT TO C ONTINUE?: ",DIR("B") ="NO" W ! D ^DIR K D IR W ! . I Y'=1 S IB OK=0 Q IBO K ;SET I $ S(IBV:1,$P (^DGCR(399 ,+X,0),"^" ,13):1,1:0 ) S CT=CT+ 1 D SET2 Q SET2 S IBN D0=^DGCR(3 99,+X,0) N IBFTP ; J WS;IB*2.0* 592 US1108 - Dental EDI 837D / form J430 D S IBFTP= $S($$FT^IB CEF(+X)=3: "/UB",$$FT ^IBCEF(+X) =2:"/1500" ,$$FT^IBCE F(+X)=7:"/ J430D",1:" ") S ^UTIL ITY($J,"UB ",CT)=9999 999-IBT_"^ "_+X_"^"_$ P($G(^DGCR (399.3,+$P (IBND0,"^" ,7),0)),"^ ",4)_"-"_$ $BCHGTYPE^ IBCU(+X)_" ^"_$P($P($ P($P(^DD(3 99,.13,0), "^",3),$P( IBND0,"^", 13)_":",2) ,";",1),"/ ",1) S ^UT ILITY($J," UB",CT)=^U TILITY($J, "UB",CT)_" ^"_$S($P(I BND0,U,27) =1:"INST"_ IBFTP,$P(I BND0,U,27) =2:"PROF"_ IBFTP,1:"" ) QST ; Do not use t he variabl e IBH when calling t his entry point L ^D GCR(399,IB IFN):5 I ' $T W !,"No further p rocessing of this re cord permi tted at th is time.", !,"Record locked by another us er. Try ag ain later. " Q D RECA LL^DILFD(3 99,IBIFN_" ,",DUZ) D NOPTF^IBCB 2 I 'IBAC1 D NOPTF1^ IBCB2 Q I IBAC'=1&(I BAC'=4.1) G ST2ST1 K ^UTILITY( $J) S IBPO POUT=0 ; O nly allow view of bi ll waiting for MRA o r pending extract I $P($G(^DGC R(399,IBIF N,0)),U,13 )=2 D G Q . W !,"Th is bill is requestin g an MRA - can only view bill data" . S IBV=1 D VI EW^IBCB2 I IBAC=4.1 D G Q . Q :$P($G(^DG CR(399,IBI FN,0)),U,1 3)'=3 . N Z . S Z=$P ($G(^IBA(3 64,+$$LAST 364^IBCEF4 (IBIFN),0) ),U,3) . I Z'="X"&(Z '="P") Q . W !,"This bill has a transmit status of ",$$EXPAN D^IBTRE(36 4,.03,Z)," - can onl y view bil l data" . S IBV=1 D VIEW^IBCB2 D ^IBCSCU ,^IBCSC1 G Q:'$T!($G (IBPOPOUT) )ST2 K IBT XPRT,IBPOP OUT D ^IBC B1 ; perfo rm IB edit s/authoriz e the bill I $G(IBCI REDT) G ST 1 ; Re -edit the bill KILL IBCIREDT ; clean up QUIT ;Q ; K IBIFN,I BV,IBAC ;* ** ;I $D(X RT0) S:'$D (XRTN) XRT N="IBCB" D T1^%ZOSV ;stop rt c lock Q ;ED I S IBAC=1 ,IBV=0 D E N G Q:'IBA C1,EDIREV G QAUT S I BAC=3,IBV= 0 D EN G Q :'IBAC1,AU TGEN S IBA C=4,IBV=1 D EN G Q:' IBAC1,GENV IEW S IBAC =4.1,IBV=1 D EN G Q: 'IBAC1,VIE W Q ; | |
| 658 | ||
| 659 | ||
| 660 | Routines | |
| 661 | Activities | |
| 662 | Routine Na me | |
| 663 | IBCB1 | |
| 664 | Enhancemen t Category | |
| 665 | New | |
| 666 | Modify | |
| 667 | Delete | |
| 668 | No Change | |
| 669 | RTM | |
| 670 | ||
| 671 | Related Op tions | |
| 672 | None | |
| 673 | Related Ro utines | |
| 674 | Routines “ Called By” | |
| 675 | Routines “ Called” | |
| 676 | ||
| 677 | ||
| 678 | ||
| 679 | ||
| 680 | Data Dicti onary (DD) Reference s | |
| 681 | ||
| 682 | Related Pr otocols | |
| 683 | None | |
| 684 | Related In tegration Control Re gistration s (ICRs) | |
| 685 | None | |
| 686 | Data Passi ng | |
| 687 | Input | |
| 688 | Output Re ference | |
| 689 | Both | |
| 690 | Global Re ference | |
| 691 | Local | |
| 692 | Input Attr ibute Name and Defin ition | |
| 693 | Name: | |
| 694 | Definition : | |
| 695 | Output Att ribute Nam e and Defi nition | |
| 696 | Name: | |
| 697 | Definition : | |
| 698 | Current Lo gic | |
| 699 | IBCB1 ;ALB /AAS - Pro cess bill after ente r/edited ; 2-NOV-89 ; ;2.0;INTEG RATED BILL ING;**70,1 06,51,137, 161,182,15 5,327,432* *;21-MAR-9 4;Build 19 2 ;;Per VH A Directiv e 10-93-14 2, this ro utine shou ld not be modified. ; ;MAP TO DGCRB1 ; ; IBQUIT = F lag to sto p processi ng ;IBVIEW = Flag fo r Bill has been view ed ;IBDISP = Flag fo r Bill ent ering disp lay been v iewed. ; K ^UTILITY( $J) I $D(I BAC),IBAC> 1 G @IBAC1 ;complete bill D EN D,EDITS^IB CB2 G:IBQU IT END ; I '$$IICM^I BCB2(IBIFN ) G END ; Ingenix Cl aimsManage r I '$$IIQ MED^IBCB2( IBIFN) G E ND ; DSS Q uadraMed C laims Scru bber ;3 ;a uthorize b ill/reques t MRA I '$ D(^XUSEC(" IB AUTHORI ZE",DUZ))! ('$D(IBIFN )) W !!,"Y ou do not hold the A uthorize K ey.",! G E ND I '$P($ G(^IBE(350 .9,1,1))," ^",23),DUZ =$P(^DGCR( 399,IBIFN, "S"),"^",2 ) W !!,"En tering use r can not authorize. ",! G END I $P(^DGCR (399,IBIFN ,"S"),"^", 9) W !,"Al ready Appr oved, Can' t change" G END D:'$ G(IBAC)!($ G(IBAC)>1) EDITS^IBC B2 G:IBQUI T END ; I $G(IBAC)'= 1,'$$IICM^ IBCB2(IBIF N) G END ; Ingenix C laimsManag er I $G(IB AC)'=1,'$$ IIQMED^IBC B2(IBIFN) G END ; DS S QuadraMe d Claims S crubber ;A UTH S IBMR A=$$REQMRA ^IBEFUNC(I BIFN) S IB END=0 I IB MRA["R" D AUTH^IBCB1 1 G:IBEND END ;MRA n ormally re quired, bu t MEDIGAP ins co ; d oesn't wan t/need it or MRA par ameter off ; W !!,"T HIS BILL W ILL "_$P(" NOT ^",U,$ $TXMT^IBCE F4(IBIFN)+ 1)_"BE TRA NSMITTED E LECTRONICA LLY" W !!, "WANT TO " ,$S('IBMRA :"AUTHORIZ E BILL",1: "REQUEST A N MRA")," AT THIS TI ME" S %=2 D YN^DICN G:%=-1!(%= 2) END I ' % W !?4,"Y ES - If fi nished ent ering bill informati on and to allow bill to be pri nted or tr ansmitted" ,!?4,"No - To take n o action" G AUTH S ( DIC,DIE)=3 99,IBYY=$S ('IBMRA:"@ 90",1:"@90 1"),DA=IBI FN,DR="[IB STATUS]" D ^DIE K D IC,DIE,IBY Y D:$D(IBX 3) DISAP^I BCBULL I $ S('IBMRA:' $P(^DGCR(3 99,IBIFN," S"),"^",9) ,1:'$P($G( ^DGCR(399, IBIFN,"TX" )),U,6)) G END ; ; U pdate the review sta tus for al l EOB's on file D ST AT^IBCEMU2 (IBIFN,3) ; Accepted - Complet e EOB ; D AUTOCK^IBC EU2(IBIFN) ; Checks for need t o add any codes to b ill based on informa tion alrea dy on bill , specific ally for E DI purpose s S IBTXST AT=$$TXMT^ IBCEF4(IBI FN,,1) ;De termine tr ansmit, wh ether live /test I IB TXSTAT D I IBMRA D CTCOPY^IBC CCB(IBIFN, 1) G END . W !," Addi ng " .W:+I BTXSTAT=2 "test " W "bill to B ILL TRANSM ISSION Fil e"_$S('IBM RA:"",1:" for MRA su bmission") _".",! .W: +IBTXSTAT= 1&IBMRA " Bill is no longer ed itable unl ess return ed in erro r from Med icare." .S Y=$$ADDTB ILL(IBIFN, +IBTXSTAT) .W ! W:'$ P(Y,U,3) * 7 W $S($P( Y,U,3):" B ill will b e submitte d electron ically",1: " Error lo ading into transmit file - bil l can not be transmi tted.") .; ; W !,"Pa ssing comp leted Bill to Accoun ts Receiva ble. Bill is no long er editabl e." D ARPA SS(IBIFN,1 ) G:'$G(PR CASV("OKAY ")) END W !,"Complet ed Bill Su ccessfully sent to A ccounts Re ceivable." D FIND^IB OHCK(DFN,I BIFN) ; ; Check to s ee if any unreviewed status me ssages or EOBs on fi le and ; w hat to do about them N IBTXBAR R S IBRESU B=$$RESUB^ IBCECSA4($ S($G(IBCNC OPY):$P($G (^DGCR(399 ,IBIFN,0)) ,U,15),1:I BIFN),+IBT XSTAT,"E", .IBTXBARR) I IBRESUB =2 D ; updat e review s tatuses to be 'revie w complete ' . N IBDA S IBDA=0 . F S IBD A=$O(IBTXB ARR(IBDA)) Q:'IBDA D UPDEDI^I BCEM(IBDA, $S($G(IBCN COPY):"R", 1:"E")) . Q ; K IBTX PRT ;4 ;ge nerate/pri nt bill G: '$D(IBIFN) END S:'$D (IBMRA) IB MRA=+$$NEE DMRA^IBEFU NC(IBIFN) I 'IBMRA,' $P(^DGCR(3 99,IBIFN," S"),"^",9) W !!,*7," Not Author ized, Can Not Print! " G END I IBMRA,'$P( ^DGCR(399, IBIFN,"TX" ),"^",6) W !!,*7,"No t Ready Fo r MRA Subm ission, Ca n Not Prin t!" G END S IBTXSTAT =$$TXMT^IB CEF4(IBIFN ) I IBMRA, $$NEEDMRA^ IBEFUNC(IB IFN)'["R" W !!,*7,"M RA Submiss ion not ye t confirme d by Austi n, Can Not Print!" Q :$S('IBTXS TAT:1,1:"X P"'[$P($G( ^IBA(364,+ $$LAST364^ IBCEF4(IBI FN),0)),U, 3)) I +IBT XSTAT,$D(^ IBA(364,"A BDT",IBIFN )) S IBTXO K="" D I 'IBTXOK S %=2 G GENT X . N IBX, IBTST . S IBX=+$$LAS T364^IBCEF 4(IBIFN),I BTST="" . I $$TEST^I BCEF4(IBIF N) S (IBTX OK,IBTST)= 1 . I "XP" [$P($G(^IB A(364,IBX, 0)),U,3) D :'IBTST Q .. W !!,* 7,"This Bi ll Can Not Be Printe d Until Tr ansmit Con firmed" W: IBMRA " (t o request an MRA)" D :'$D(IBVIE W) VIEW^IB CB2 . W !! ,"This Bil l Has Alre ady Been T ransmitted " W:IBMRA " (to requ est an MRA )" . S DIR ("B")="Y", DIR("A")=" WANT TO PR INT IT ANY WAY",DIR(0 )="Y" D ^D IR K DIR Q :$D(DTOUT) !$D(DUOUT) !'Y S IBT XOK=1 D DI SP^IBCB2 S :'$D(IBQUI T) IBQUIT= 0 D:'$D(IB VIEW) VIEW ^IBCB2 G:I BQUIT END S IBPNT=$P (^DGCR(399 ,IBIFN,"S" ),"^",12)G EN I $$TES T^IBCEF4(I BIFN) W !! ,"THIS BIL L IS BEING USED AS A TRANSMISS ION TEST B ILL" W !!, "WANT TO " ,$S(IBPNT] "":"RE-",1 :""),"PRIN T BILL AT THIS TIME" S %=2 D Y N^DICN I % =-1 D:+$G( IBAC)=1 EN D,CTCOPY^I BCCCB(IBIF N) G END I '% W !?4, "YES - to print the bill now", !?4,"NO - To take no action" G GENGENTX I %'=1 D:+ $G(IBAC)=1 END,CTCOP Y^IBCCCB(I BIFN) G EN D ; ; Bill has never been prin ted. First time prin t. I 'IBPN T D G END . I $D(IB TXPRT) D T XPRTS . D EN1^IBCF . I $D(IBTX PRT) D TXP RT . ;D MR A^IBCEMU1( IBIFN) ; P rinting th e MRA ;WCJ ;IB*2.0*43 2;MRA may have a dif fierent cl aim number if this i s tertiary . D MRA^I BCEMU1($$G ETMRACL^IB CAPR(IBIFN )) ;WCJ;IB *2.0*432;s ee above . I $G(IBMR ANOT) D EO BALL^IBCAP R2(IBIFN) ;WCJ;IB*2. 0*432 prin t all the EOBs (ask device onc e) . I +$G (IBAC)=1 D END,CTCOP Y^IBCCCB(I BIFN) . Q ; ; Below section is for re-pr intsRPNT G :$$NEEDMRA ^IBEFUNC(I BIFN) END R !!,"(2)n d Notice, (3)rd Noti ce, (C)opy or (O)rig inal: C// ",IBPNT:DT IME S:IBPN T="" IBPNT ="C" G:IBP NT["^" END S IBPNT=$ E(IBPNT,1) I "23oOcC "'[IBPNT W !?5,"Ente r 'O' to r eprint the original bill or",! ?5,"Enter 'C' to rep rint the b ill as a d uplicate c opy or",!? 5,"Enter ' 2' or '3' to print 2 nd or 3rd follow-up notices." S IBPNT=1 G RPNT W " (",$S("cC "[IBPNT:"C OPY","oO"[ IBPNT:"ORI GINAL",IBP NT=2:"2nd NOTICE",IB PNT=3:"3rd NOTICE",1 :""),")" I $D(IBTXPR T) D . D T XPRTS . I "oOcC"[IBP NT S IBRES UB=$$RESUB ^IBCECSA4( IBIFN,1,"P ") S IBPNT =$S("oO"[I BPNT:1,"cC "[IBPNT:0, 1:IBPNT) D EN1X^IBCF D:$D(IBTX PRT) TXPRT D MRA^IBC EMU1(IBIFN ) ; Printi ng the MRA ; ;END K IBER,IBEND D END^IBC BB1 K IBQU IT,IBVIEW, IBDISP,IBS T,IB,PRCAE RCD,PRCAER R,PRCASVC, PRCAT,DGRA 2,IBBT,IBC H,IBNDS,IB OA,IBREV,I BX,DGXRF1, PRCAORA,IB X3,DGBILLB S,DGII,DGV ISCNT,DGFI L,DGTE,IBT XOK,IBTXST AT,IBMRA,I BNOFIX K % DT,DIC,DIE ,I,J,X,Y,Y 1,Y2,IBER, IBDFN,IBDS DT,IBJ,IBN DI1,IBZZ,V A,IBMA,IBX DT,DI,PRCA PAYR,DGBS, DGCNT,DGDA ,DGPAG,DGR EVC,DGRV,D GTEXT,DGTO TPAG,IBOPV ,DGLCNT,DG TEXT1,DGRS PAC,DGSM,I BPNT,DGINP T,DGLL,IBC PTN,IBFL K IBRESUB,I BOPV1,IBOP V2,IBCHG,D GBIL1,DGU, DDH,IBA1,I BINS,IBPRO C,PRCARI K :'$D(PRCAS V("NOTICE" )) PRCASV K ^TMP("IB XDATA",$J) ,^TMP("IBX EDIT",$J) K IBCISNT, IBCISTAT,I BCIERR ; remove Cl aimsManage r variable s Q ;TX1(I BX,RESUB) ; Transmit a single bill from file 364 e ntry # IBX ; RESUB = flag (1 = resubmitt ing a bill , 0 = subm itting bil l 1st time ) ; Return s 1 if suc cessfully extracted to mailman queue for transmiss ion, ; 0 i f extract not succes sful N IBT XOK,IBVVSA VE K ^TMP( "IBRESUBMI T",$J),^TM P("IBONE", $J) S IBVV SAVE("IBX" )=IBX,^TMP ("IBONE",$ J)=+$G(RES UB),^($J,I BX)="" D O NE^IBCE837 S IBX=IBV VSAVE("IBX ") I $P($G (^IBA(364, IBX,0)),U, 3)="P" S I BTXOK=1 K ^TMP("IBON E",$J) Q $ G(IBTXOK) ;ARONLY(IB IFN) ; Pas s bill to A/R, but t hat's all D ARPASS(I BIFN,0) Q ;ARPASS(IB IFN,UPDOK) ;Pass bil l to A/R a s NEW BILL ;IBIFN = bill entry # ;UPDOK = flag 1: if error g oing to A/ R, allow i nteractive edit ; 0: send bull etin to IB EDI for e rror going to A/R Q: +$$STA^PRC AFN(+IBIFN )'=201 ;Mu st not hav e been sen t previous ly D GVAR^ IBCBB ;Can 't be an i ns co that won't rei mburse Q:$ S($P($G(^D GCR(399,IB IFN,0)),U, 11)="i":'I BNDMP,1:0) D ARRAY^I BCBB1,^PRC ASVC6 D RE L^PRCASVC: $G(PRCASV( "OKAY")) I '$G(PRCAS V("OKAY")) D . N IBQ UIT,IBQUIT 1 . S IBQU IT=0 . I $ G(UPDOK) D Q .. F D Q:IBQUI T ... D DS PARERR^IBC B2("") ... Q:IBQUIT ... I $$AS KEDIT^IBCB 2($G(IBAC) ) D VIEW1^ IBCB2 Q .. . S IBQUIT =1 . N XMS UB,XMY,XMT EXT,XMDUZ, IBT . S XM SUB="ERROR PASSING B ILL TO A/R ON CONFIR MATION",XM TEXT="IBT( ",XMY="G.I B EDI",XMD UZ=.5 . S IBT(1)="A problem ha s been det ected whil e trying t o pass bil l "_$P($G( ^DGCR(399, IBIFN,0)), U)_" to" . S IBT(2)= "Accounts Receivable when upda ting the b ill's elec tronic con firmation. " . S IBT( 3)="Please use the o ption PASS BILL TO A /R to comp lete this process." . D ^XMD Q ;ADDTBILL (IBIFN,TXS T) ; Add n ew transmi t bill rec to file 3 64 for bil l IBIFN ; TXST = tes t flag 1=l ive, 2=tes t N COB,DD ,DO,DIC,DL AYGO,X S T XST=($G(TX ST)/2\1),C OB=$$COB^I BCEF(IBIFN ) S DIC(0) ="L",DIC=" ^IBA(364," ,DLAYGO=36 4,X=IBIFN, DIC("DR")= ".03///X;. 04///NOW;. 07////"_TX ST_";.08// //"_COB D FILE^DICN Q Y ;TXPRT S ; Save o ff last pr int date t o see if b ill was re printed wi thout queu eing I '$$ NEEDMRA^IB EFUNC(IBIF N) S IBTXP RT("PRT")= $P($G(^DGC R(399,IBIF N,"S")),U, 14) Q ;TXP RT ; Set v ariable if print was tasked or bill was printed (l ast print date chang ed) I '$$N EEDMRA^IBE FUNC(IBIFN ),$S($G(ZT SK):1,1:IB TXPRT("PRT ")'=$P($G( ^DGCR(399, IBIFN,"S") ),U,14)) S IBTXPRT=1 Q ; | |
| 700 | Modified L ogic (Chan ges are in bold) | |
| 701 | IBCB1 ;ALB /AAS - Pro cess bill after ente r/edited ; 2-NOV-89 ; ;2.0;INTEG RATED BILL ING;**70,1 06,51,137, 161,182,15 5,327,432, 592**;21-M AR-94;Buil d 192 ;;Pe r VHA Dire ctive 10-9 3-142, thi s routine should not be modifi ed. ; ;MAP TO DGCRB1 ; ;IBQUIT = Flag to stop proc essing ;IB VIEW = Fla g for Bill has been viewed ;IB DISP = Fla g for Bill entering display be en viewed. ; K ^UTIL ITY($J) I $D(IBAC),I BAC>1 G @I BAC1 ;comp lete bill D END,EDIT S^IBCB2 G: IBQUIT END ; I '$$II CM^IBCB2(I BIFN) G EN D ; Ingeni x ClaimsMa nager I '$ $IIQMED^IB CB2(IBIFN) G END ; D SS QuadraM ed Claims Scrubber ; 3 ;authori ze bill/re quest MRA I '$D(^XUS EC("IB AUT HORIZE",DU Z))!('$D(I BIFN)) W ! !,"You do not hold t he Authori ze Key.",! G END I ' $P($G(^IBE (350.9,1,1 )),"^",23) ,DUZ=$P(^D GCR(399,IB IFN,"S")," ^",2) W !! ,"Entering user can not author ize.",! G END I $P(^ DGCR(399,I BIFN,"S"), "^",9) W ! ,"Already Approved, Can't chan ge" G END D:'$G(IBAC )!($G(IBAC )>1) EDITS ^IBCB2 G:I BQUIT END ; I $G(IBA C)'=1,'$$I ICM^IBCB2( IBIFN) G E ND ; Ingen ix ClaimsM anager I $ G(IBAC)'=1 ,'$$IIQMED ^IBCB2(IBI FN) G END ; DSS Quad raMed Clai ms Scrubbe r ;AUTH S IBMRA=$$RE QMRA^IBEFU NC(IBIFN) S IBEND=0 I IBMRA["R " D AUTH^I BCB11 G:IB END END ;M RA normall y required , but MEDI GAP ins co ; doesn't want/need it or MRA parameter off ; W ! !,"THIS BI LL WILL "_ $P("NOT ^" ,U,$$TXMT^ IBCEF4(IBI FN)+1)_"BE TRANSMITT ED ELECTRO NICALLY" W !!,"WANT TO ",$S('I BMRA:"AUTH ORIZE BILL ",1:"REQUE ST AN MRA" )," AT THI S TIME" S %=2 D YN^D ICN G:%=-1 !(%=2) END I '% W !? 4,"YES - I f finished entering bill infor mation and to allow bill to be printed o r transmit ted",!?4," No - To ta ke no acti on" G AUTH S (DIC,DI E)=399,IBY Y=$S('IBMR A:"@90",1: "@901"),DA =IBIFN,DR= "[IB STATU S]" D ^DIE K DIC,DIE ,IBYY D:$D (IBX3) DIS AP^IBCBULL I $S('IBM RA:'$P(^DG CR(399,IBI FN,"S"),"^ ",9),1:'$P ($G(^DGCR( 399,IBIFN, "TX")),U,6 )) G END ; ; Update the review status fo r all EOB' s on file D STAT^IBC EMU2(IBIFN ,3) ; Acce pted - Com plete EOB ; D AUTOCK ^IBCEU2(IB IFN) ; Che cks for ne ed to add any codes to bill ba sed on inf ormation a lready on bill, spec ifically f or EDI pur poses S IB TXSTAT=$$T XMT^IBCEF4 (IBIFN,,1) ;Determin e transmit , whether live/test I IBTXSTAT D I IBMR A D CTCOPY ^IBCCCB(IB IFN,1) G E ND .W !," Adding " . W:+IBTXSTA T=2 "test " W "bill to BILL TR ANSMISSION File"_$S( 'IBMRA:"", 1:" for MR A submissi on")_".",! .W:+IBTXS TAT=1&IBMR A " Bill i s no longe r editable unless re turned in error from Medicare. " .S Y=$$A DDTBILL(IB IFN,+IBTXS TAT) .W ! W:'$P(Y,U, 3) *7 W $S ($P(Y,U,3) :" Bill wi ll be subm itted elec tronically ",1:" Erro r loading into trans mit file - bill can not be tra nsmitted." ) .; ; W ! ,"Passing completed Bill to Ac counts Rec eivable. B ill is no longer edi table." D ARPASS(IBI FN,1) G:'$ G(PRCASV(" OKAY")) EN D W !,"Com pleted Bil l Successf ully sent to Account s Receivab le." D FIN D^IBOHCK(D FN,IBIFN) ; ; Check to see if any unrevi ewed statu s messages or EOBs o n file and ; what to do about them N IBT XBARR S IB RESUB=$$RE SUB^IBCECS A4($S($G(I BCNCOPY):$ P($G(^DGCR (399,IBIFN ,0)),U,15) ,1:IBIFN), +IBTXSTAT, "E",.IBTXB ARR) I IBR ESUB=2 D ; u pdate revi ew statuse s to be 'r eview comp lete' . N IBDA S IBD A=0 . F S IBDA=$O(I BTXBARR(IB DA)) Q:'IB DA D UPDE DI^IBCEM(I BDA,$S($G( IBCNCOPY): "R",1:"E") ) . Q ; K IBTXPRT ;4 ;generate /print bil l G:'$D(IB IFN) END S :'$D(IBMRA ) IBMRA=+$ $NEEDMRA^I BEFUNC(IBI FN) I 'IBM RA,'$P(^DG CR(399,IBI FN,"S"),"^ ",9) W !!, *7,"Not Au thorized, Can Not Pr int!" G EN D I IBMRA, '$P(^DGCR( 399,IBIFN, "TX"),"^", 6) W !!,*7 ,"Not Read y For MRA Submission , Can Not Print!" G END S IBTX STAT=$$TXM T^IBCEF4(I BIFN) I IB MRA,$$NEED MRA^IBEFUN C(IBIFN)'[ "R" W !!,* 7,"MRA Sub mission no t yet conf irmed by A ustin, Can Not Print !" Q:$S('I BTXSTAT:1, 1:"XP"'[$P ($G(^IBA(3 64,+$$LAST 364^IBCEF4 (IBIFN),0) ),U,3)) I +IBTXSTAT, $D(^IBA(36 4,"ABDT",I BIFN)) S I BTXOK="" D I 'IBTXO K S %=2 G GENTX . N IBX,IBTST . S IBX=+$ $LAST364^I BCEF4(IBIF N),IBTST=" " . I $$TE ST^IBCEF4( IBIFN) S ( IBTXOK,IBT ST)=1 . I "XP"[$P($G (^IBA(364, IBX,0)),U, 3) D:'IBTS T Q .. ;J WS;IB*2.0* 592 .. I $ $FT^IBCEF( IBIFN)=7 W !!,*7,"Th is Bill Ca n Not Be P rinted" .. E W !!,* 7,"This Bi ll Can Not Be Printe d Until Tr ansmit Con firmed" .. W:IBMRA " (to reque st an MRA) " D:'$D(IB VIEW) VIEW ^IBCB2 . W !!,"This Bill Has A lready Bee n Transmit ted" W:IBM RA " (to r equest an MRA)" . S DIR("B")=" Y",DIR("A" )="WANT TO PRINT IT ANYWAY",DI R(0)="Y" D ^DIR K DI R Q:$D(DTO UT)!$D(DUO UT)!'Y S IBTXOK=1 D DISP^IBCB 2 S:'$D(IB QUIT) IBQU IT=0 D:'$D (IBVIEW) V IEW^IBCB2 G:IBQUIT E ND S IBPNT =$P(^DGCR( 399,IBIFN, "S"),"^",1 2)GEN I $$ TEST^IBCEF 4(IBIFN) W !!,"THIS BILL IS BE ING USED A S A TRANSM ISSION TES T BILL" W !!,"WANT T O ",$S(IBP NT]"":"RE- ",1:""),"P RINT BILL AT THIS TI ME" S %=2 D YN^DICN I %=-1 D:+ $G(IBAC)=1 END,CTCOP Y^IBCCCB(I BIFN) G EN D I '% W ! ?4,"YES - to print t he bill no w",!?4,"NO - To take no action " G GEN ;J WS;IB*2.0* 592 I %=1, $$FT^IBCEF (IBIFN)=7 W !!,*7,"D ental Clai ms can not be printe d." G END GENTX I %' =1 D:+$G(I BAC)=1 END ,CTCOPY^IB CCCB(IBIFN ) G END ; ; Bill has never bee n printed. First tim e print. I 'IBPNT D G END . I $D(IBTXPR T) D TXPRT S . D EN1^ IBCF . I $ D(IBTXPRT) D TXPRT . ;D MRA^IB CEMU1(IBIF N) ; Print ing the MR A ;WCJ;IB* 2.0*432;MR A may have a diffier ent claim number if this is te rtiary . D MRA^IBCEM U1($$GETMR ACL^IBCAPR (IBIFN)) ; WCJ;IB*2.0 *432;see a bove . I $ G(IBMRANOT ) D EOBALL ^IBCAPR2(I BIFN) ;WCJ ;IB*2.0*43 2 print al l the EOBs (ask devi ce once) . I +$G(IBA C)=1 D END ,CTCOPY^IB CCCB(IBIFN ) . Q ; ; Below sect ion is for re-prints RPNT G:$$N EEDMRA^IBE FUNC(IBIFN ) END R !! ,"(2)nd No tice, (3)r d Notice, (C)opy or (O)riginal : C// ",IB PNT:DTIME S:IBPNT="" IBPNT="C" G:IBPNT[" ^" END S I BPNT=$E(IB PNT,1) I " 23oOcC"'[I BPNT W !?5 ,"Enter 'O ' to repri nt the ori ginal bill or",!?5," Enter 'C' to reprint the bill as a dupli cate copy or",!?5,"E nter '2' o r '3' to p rint 2nd o r 3rd foll ow-up noti ces." S IB PNT=1 G RP NT W " (", $S("cC"[IB PNT:"COPY" ,"oO"[IBPN T:"ORIGINA L",IBPNT=2 :"2nd NOTI CE",IBPNT= 3:"3rd NOT ICE",1:"") ,")" I $D( IBTXPRT) D . D TXPRT S . I "oOc C"[IBPNT S IBRESUB=$ $RESUB^IBC ECSA4(IBIF N,1,"P") S IBPNT=$S( "oO"[IBPNT :1,"cC"[IB PNT:0,1:IB PNT) D EN1 X^IBCF D:$ D(IBTXPRT) TXPRT D M RA^IBCEMU1 (IBIFN) ; Printing t he MRA ; ; END K IBER ,IBEND D E ND^IBCBB1 K IBQUIT,I BVIEW,IBDI SP,IBST,IB ,PRCAERCD, PRCAERR,PR CASVC,PRCA T,DGRA2,IB BT,IBCH,IB NDS,IBOA,I BREV,IBX,D GXRF1,PRCA ORA,IBX3,D GBILLBS,DG II,DGVISCN T,DGFIL,DG TE,IBTXOK, IBTXSTAT,I BMRA,IBNOF IX K %DT,D IC,DIE,I,J ,X,Y,Y1,Y2 ,IBER,IBDF N,IBDSDT,I BJ,IBNDI1, IBZZ,VA,IB MA,IBXDT,D I,PRCAPAYR ,DGBS,DGCN T,DGDA,DGP AG,DGREVC, DGRV,DGTEX T,DGTOTPAG ,IBOPV,DGL CNT,DGTEXT 1,DGRSPAC, DGSM,IBPNT ,DGINPT,DG LL,IBCPTN, IBFL K IBR ESUB,IBOPV 1,IBOPV2,I BCHG,DGBIL 1,DGU,DDH, IBA1,IBINS ,IBPROC,PR CARI K:'$D (PRCASV("N OTICE")) P RCASV K ^T MP("IBXDAT A",$J),^TM P("IBXEDIT ",$J) K IB CISNT,IBCI STAT,IBCIE RR ; rem ove Claims Manager va riables Q ;TX1(IBX,R ESUB) ; Tr ansmit a s ingle bill from file 364 entry # IBX ; R ESUB = fla g (1 = res ubmitting a bill, 0 = submitti ng bill 1s t time) ; Returns 1 if success fully extr acted to m ailman que ue for tra nsmission, ; 0 if ex tract not successful N IBTXOK, IBVVSAVE K ^TMP("IBR ESUBMIT",$ J),^TMP("I BONE",$J) S IBVVSAVE ("IBX")=IB X,^TMP("IB ONE",$J)=+ $G(RESUB), ^($J,IBX)= "" D ONE^I BCE837 S I BX=IBVVSAV E("IBX") I $P($G(^IB A(364,IBX, 0)),U,3)=" P" S IBTXO K=1 K ^TMP ("IBONE",$ J) Q $G(IB TXOK) ;ARO NLY(IBIFN) ; Pass bi ll to A/R, but that' s all D AR PASS(IBIFN ,0) Q ;ARP ASS(IBIFN, UPDOK) ;Pa ss bill to A/R as NE W BILL ;IB IFN = bill entry # ; UPDOK = fl ag 1: if e rror going to A/R, a llow inter active edi t ; 0: sen d bulletin to IB EDI for error going to A/R Q:+$$S TA^PRCAFN( +IBIFN)'=2 01 ;Must n ot have be en sent pr eviously D GVAR^IBCB B ;Can't b e an ins c o that won 't reimbur se Q:$S($P ($G(^DGCR( 399,IBIFN, 0)),U,11)= "i":'IBNDM P,1:0) D A RRAY^IBCBB 1,^PRCASVC 6 D REL^PR CASVC:$G(P RCASV("OKA Y")) I '$G (PRCASV("O KAY")) D . N IBQUIT, IBQUIT1 . S IBQUIT=0 . I $G(UP DOK) D Q .. F D Q :IBQUIT .. . D DSPARE RR^IBCB2(" ") ... Q:I BQUIT ... I $$ASKEDI T^IBCB2($G (IBAC)) D VIEW1^IBCB 2 Q ... S IBQUIT=1 . N XMSUB,X MY,XMTEXT, XMDUZ,IBT . S XMSUB= "ERROR PAS SING BILL TO A/R ON CONFIRMATI ON",XMTEXT ="IBT(",XM Y="G.IB ED I",XMDUZ=. 5 . S IBT( 1)="A prob lem has be en detecte d while tr ying to pa ss bill "_ $P($G(^DGC R(399,IBIF N,0)),U)_" to" . S I BT(2)="Acc ounts Rece ivable whe n updating the bill' s electron ic confirm ation." . S IBT(3)=" Please use the optio n PASS BIL L TO A/R t o complete this proc ess." . D ^XMD Q ;AD DTBILL(IBI FN,TXST) ; Add new t ransmit bi ll rec to file 364 f or bill IB IFN ; TXST = test fl ag 1=live, 2=test N COB,DD,DO, DIC,DLAYGO ,X S TXST= ($G(TXST)/ 2\1),COB=$ $COB^IBCEF (IBIFN) S DIC(0)="L" ,DIC="^IBA (364,",DLA YGO=364,X= IBIFN,DIC( "DR")=".03 ///X;.04// /NOW;.07// //"_TXST_" ;.08////"_ COB D FILE ^DICN Q Y ;TXPRTS ; Save off l ast print date to se e if bill was reprin ted withou t queueing I '$$NEED MRA^IBEFUN C(IBIFN) S IBTXPRT(" PRT")=$P($ G(^DGCR(39 9,IBIFN,"S ")),U,14) Q ;TXPRT ; Set varia ble if pri nt was tas ked or bil l was prin ted (last print date changed) I '$$NEEDM RA^IBEFUNC (IBIFN),$S ($G(ZTSK): 1,1:IBTXPR T("PRT")'= $P($G(^DGC R(399,IBIF N,"S")),U, 14)) S IBT XPRT=1 Q ; | |
| 702 | ||
| 703 | ||
| 704 | Routines | |
| 705 | Activities | |
| 706 | Routine Na me | |
| 707 | IBCB2 | |
| 708 | Enhancemen t Category | |
| 709 | New | |
| 710 | Modify | |
| 711 | Delete | |
| 712 | No Change | |
| 713 | RTM | |
| 714 | ||
| 715 | Related Op tions | |
| 716 | None | |
| 717 | Related Ro utines | |
| 718 | Routines “ Called By” | |
| 719 | Routines “ Called” | |
| 720 | ||
| 721 | ||
| 722 | ||
| 723 | ||
| 724 | Data Dicti onary (DD) Reference s | |
| 725 | CLAIMS TRA CKING File [#356] | |
| 726 | Related Pr otocols | |
| 727 | None | |
| 728 | Related In tegration Control Re gistration s (ICRs) | |
| 729 | None | |
| 730 | Data Passi ng | |
| 731 | Input | |
| 732 | Output Re ference | |
| 733 | Both | |
| 734 | Global Re ference | |
| 735 | Local | |
| 736 | Input Attr ibute Name and Defin ition | |
| 737 | Name: | |
| 738 | Definition : | |
| 739 | Output Att ribute Nam e and Defi nition | |
| 740 | Name: | |
| 741 | Definition : | |
| 742 | Current Lo gic | |
| 743 | IBCB2 ;ALB /AAS - Pro cess bill after ente r/edited ; 13-DEC-89 ;;2.0;INTE GRATED BIL LING;**52, 51,161,182 ,155,447** ;21-MAR-94 ;Build 80 ;;Per VHA Directive 10-93-142, this rout ine should not be mo dified. ; ;MAP TO DG CRB2 ; ;IB QUIT = Fla g to stop processing ;IBVIEW = Flag show ing Bill h as been vi ewed ;IBDI SP = Flag showing Bi ll enterin g display has been v iewed. ;IB NOFIX = Fl ag to indi cate do no t ask to e dit or rev iew bill s creens ;IB REEDIT = F lag to ind icate Bill has been re-edited ;VIEW ;Vie w screens; if status allows ed iting , al low editin g N Y,DIR S IBPOPOUT =0 S IBVIE W=1,IBV=$S ($D(IBV):I BV,1:1) S DIR(0)="YA ",DIR("B") ="NO",DIR( "A")="WANT TO "_$S(' IBV:"EDIT" ,1:"REVIEW ")_" SCREE NS? ",DIR( "?",1)=" Y ES - to "_ $S('IBV:"E DIT",1:"RE VIEW")_" t he screens ",DIR("?") =" NO - To take no a ction" D ^ DIR K DIR S:$D(DTOUT ) IBQUIT=1 Q:Y'=1 I $G(IBREEDI T)=1,'IBV S IBREEDIT =2 ; set f lag indica ting re-ed itVIEW1 S IBVIEW=1,I BEDIT=0 D SCREENS S: $G(IBPOPOU T) IBQUIT= 1 Q ;DISP S IB("S")= $S($D(^DGC R(399,IBIF N,"S")):^( "S"),1:"") W ! D DIS P^IBCNQ W ! S IBDISP =1 Q Q ;ED ITS ; Perf orm edits on bill pr ior to aut horization /transmiss ion N IBRE EDITED1 ; S IBQUIT=0 I '$D(IBE R)!('$D(PR CASV)) D A LLED(.IBQU IT) ; ; If the user is wanting to quit, but there are some u nresolved ; errors r eported by ClaimsMan ager, then capture t he user's Exit ; com ments. ; I $$CM^IBCI UT1(IBIFN) ,IBQUIT,$P ($G(^IBA(3 51.9,IBIFN ,0)),U,2)= 4 D COMMEN T^IBCIUT7( IBIFN,1) ; Q:IBQUIT D:'$D(IBDI SP) DISP ; ; If clai m re-edit, then call the IB ed it checks again I '$ D(IBVIEW) S IBREEDIT =1 D VIEW I $G(IBREE DIT)=2 K I BER,IBDISP ,IBVIEW G ED1 Q ;ALL ED(IBQUIT) ; Billing edit/corr ection N I BQUIT1,IBD ONE1,IBDON E,IBEDIT,I BCORR,IBER ,IBPRT,IBX ERR S (IBQ UIT,IBDONE ,IBCORR)=0 ,IBER="" ; IBDONE = 1 ==> exit , no error s ; IBQUI T = 1 ==> exit, erro rs not cor rected I $ $FT^IBCEF( IBIFN)=2,' $G(IBNOFIX ) D DISP24 (IBIFN,.IB CORR,.IBQU IT) ; F D Q:IBQUIT !IBDONE D VIEW1 I $ $FT^IBCEF( IBIFN)=2,' $G(IBNOFIX ),'IBQUIT S IBCORR=0 D DISP24( IBIFN,.IBC ORR,.IBQUI T) . I $G( IBPOPOUT) S IBQUIT=1 . Q:IBQUI T!IBCORR . I $G(IBNO FIX) D .. W !!,"... Checking c laim valid ity" . E D .. W !!, "... Execu ting natio nal IB edi ts" . D EN ^IBCBB,LOC ERR . ; . I $G(IBER) '=""!$D(IB XERR) D Q :'IBDONE . . D DSPLER R ; Displa ys warning s/errors . . K IBXERR .. Q:IBQU IT!(IBDONE ) .. I $G( IBNOFIX) S IBDONE=1 Q .. I '$$ ASKEDIT($G (IBAC)) W ! S IBQUIT =1 ; Don't want to r e-edit .. ; . I $G(I BNOFIX) S IBDONE=1 Q . S IBEDI T=0 . I $S ($P($G(^DG CR(399,IBI FN,0)),U,1 3)>2:1,$D( PRCASV):'$ D(PRCASV(" OKAY")),1: 0) D S:'I BQUIT&'IBE DIT IBDONE =1 Q .. N IBQUIT1 .. S IBQUIT1 =0 .. W !! !,"... Exe cuting A/R edits" .. I $P($G(^ DGCR(399,I BIFN,0)),U ,13)>2 D G VAR^IBCBB, ARRAY^IBCB B1 .. D AR CHK($G(IBN OFIX),0,.I BQUIT1,.IB QUIT,.IBED IT,.PRCASV ) . S IBDO NE=1 ; No errors . S :$G(IBPRT( "PRT"))'<0 IBQUIT=0 Q ;ARCHK(I BNOFIX,IBN OPRT,IBQUI T1,IBQUIT, IBEDIT,PRC ASV) ; A/R Verificat ion ; Retu rns IBEDIT , IBQUIT1, IBQUIT,PR CASV array if passed by refere nce ; IBNO FIX = 1 if no editin g needed ; IBNOPRT = 1 if no p rinting ne eded F D ^PRCASVC6 D Q:IBQUI T1!IBEDIT D GVAR^IB CBB,ARRAY^ IBCBB1 . I '$G(IBNOP RT) Q:$G(I BPRT("PRT" ))<0 . I P RCASV("OKA Y") W:'$G( IBNOPRT) ! !,"No A/R errors fou nd" S IBQU IT1=1 Q . I 'PRCASV( "OKAY") D Q .. D DS PARERR($G( IBNOPRT)) ; Display A/R errors .. Q:IBQU IT .. I $G (IBNOFIX) S IBQUIT1= 1 Q .. I ' $$ASKEDIT( $G(IBAC)) W !,"There is an unr esolved A/ R error - cannot aut horize bil l" D PAUSE ^VALM1 S ( IBQUIT,IBQ UIT1)=1 Q .. S IBEDI T=1 ; Q ;D SPLERR ; D isplay nat ional/loca l edits fa iled N Z D PRTH(.IBP RT) I IBPR T("PRT")<0 S IBQUIT= 1 Q S Z=0 F S Z=$O( ^TMP($J,"B ILL-WARN", Z)) Q:'Z W !,^(Z) W :'$O(^(Z)) ! S Y2="" I IBER'=" WARN" F I= 1:1 S X=$P (IBER,";", I) Q:X="" W:I=1 !?5 ,"**Errors **:" I $D( ^IBE(350.8 ,+$O(^IBE( 350.8,"AC" ,X,0)),0)) S Y=^(0), Y1=$P(Y,"^ ",5),Y2=Y2 _Y1 I Y1<5 W !?5,$E( $P(Y,"^",2 ),1,80) ; IBXERR = l ocal edits return er ror array ; If IBXER R returns = 1 then w e have at least one error ; = "" or 0, t hen we hav e only loc al warning s ; undefi ned = no l ocal error s or warni ngs I $D(I BXERR) D . S I="" W !!,?3,"Loc al Edits:" . S:$G(IB XERR) Y2=3 ,IBER="L" . F S I=$ O(IBXERR(I )) Q:I="" W !,?5,$E (IBXERR(I) ,1,75) I $ G(IBPRT("P RT")) D CL OSE(.IBPRT ) G:$G(IBN OFIX) Q I $G(IBER)=" WARN"!($G( IBXERR)=0) D ;Warni ngs only - make bill er stop an d look . W ! . N DIR ,X,Y . S D IR(0)="YA" ,DIR("B")= "NO",DIR(" A",1)="THI S BILL STI LL HAS ONE OR MORE W ARNINGS - PLEASE REV IEW THEM C AREFULLY", DIR("A")=" ARE YOU SU RE IT'S OK TO CONTIN UE? " . D ^DIR K DIR . I Y'=1 S Y2=3 Q . S IBER="" ,IBDONE=1 K IBXERR I $S(Y2'["3 "&'$G(IBXE RR):0,1:1) K IBXERRQ K ^TMP($J ,"BILL-WAR N") Q ;DSP ARERR(IBNO PRT) ; Dis plays A/R errors N I ,J,Y,X,ERR PRT I '$G( IBNOPRT) D PRTH(.IBP RT) I IBPR T("PRT")<0 S IBQUIT= 1 Q I $P($ G(PRCAERR) ,U,2)'="" D . N Z . S Z=+$O(^I BE(350.8," C",$P(PRCA ERR,U,2),0 )),Z=$P($G (^IBE(350. 8,+Z,0)),U ,2) . W !, ?5,"An A/R error has been repo rted - bil l cannot b e authoriz ed",!!,?5, $P(PRCAERR ,U,2)," - ",$S(Z'="" :Z,1:"??") E D . W !,?5,"An u ndetermine d A/R erro r was foun d - "_$G(P RCAERR) I $G(IBPRT(" PRT")) D C LOSE(.IBPR T) Q ;NOPT F S IBAC1= 1 I $D(^DG CR(399,IBI FN,0)),$P( ^(0),"^",8 ),'$D(^DGP T($P(^(0), "^",8),0)) S IBAC1=0 Q ;NOPTF1 W !!,*7," PTF Record for this Bill was D ELETED!",! ,"Further processing not allow ed. Cancel and re-en ter." Q ;L OCERR ; Ch eck for lo cal edits ; Execute screen pos t-processo r for bill s with loc al scrn 9 affiliatio ns N IBZ,I BXIEN,IBPR T K IBXERR S IBZ=$$L OCSCRN^IBC SC11(IBIFN ) ; IB*2.0 *447 BI I IBZ S IBXI EN=IBIFN W !!,"... E xecuting l ocal IB ed its" D FPO ST^IBCEFG7 (IBZ,0,.IB XERR) I '$ D(IBXERR) W !!,"No e rrors foun d for loca l edits" Q ;PRTH(IBP RT,IBA) ; Print a he ading for error/warn ings sent to a print er ; Retur ns IBPRT = 1 if vali d pritner selected ; IBPRT = - 1 if '^' e ntered ; I BPRT = 0 i f home dev ice N POP, %ZIS,POP S %ZIS("A") ="ERROR/WA RNING OUTP UT DEVICE: " D ^%ZIS I POP S I BPRT("PRT" )=-1 Q I I O=IO(0) S IBPRT("PRT ")=0 Q S I BPRT("PRT" )=1 U IO W !,"INCONS ISTENCIES LIST FOR B ILL #: ",$ P($G(^DGCR (399,IBIFN ,0)),U),!, $J("",29), "AT: ",$$F MTE^XLFDT( $$NOW^XLFD T,2),!,$J( "",19),"GE NERATED BY : ",$P($G( ^VA(200,DU Z,0)),U),! ! Q ;CLOSE (IBPRT) ; Close devi ce, reset printer fl ag D ^%ZIS C S IBPRT( "PRT")=0 D HOME^%ZIS Q ;ASKEDI T(IBAC) ; Ask if edi t/review o f bill is desired ; FUNCTION r eturns 0/1 for NO/YE S ; IBAC = flag for function b eing perfo rmed - to determine edit/revie w N DIR,X, Y S DIR(0) ="YA" S DI R("A",1)=" ",DIR("A" ,2)=" ",DI R("A")="Do you wish to "_$S($G (IBAC)<4:" edit",1:"r eview")_" the incons istencies now? ",DIR ("B")="NO" S DIR("?" ,1)=" ",DI R("?",2)=" ",DIR("?" ,3)=" YES - To edit inconsiste nt fields" ,DIR("?")= " NO - To discontinu e this pro cess." D ^ DIR K DIR Q (Y=1) ;S CREENS ; N IBH D ^IB CSCU,^IBCS C1 I $G(IB V) K IBPOP OUT Q ;DIS P24(IBIFN, IBCORR,IBQ UIT) ; W @ IOF D BL24 ^IBCSCH(IB IFN,0) S D IR("A",1)= " ",DIR("A ")="Are th e above ch arges corr ect for th is bill? " ,DIR("B")= "YES",DIR( 0)="YA" D ^DIR K DIR I Y'=1 D . I Y=0,$$ ASKEDIT($G (IBAC)) S IBCORR=1 Q . S IBQUI T=1 Q ;IIC M(IBIFN) ; Ingenix C laimsManag er: Claim Scrubber ; Send the bill to Cl aimsManage r, the IBC ISTAT vari able retur ned from C laimsManag er indicat es ; 3 - P assed CM w ith no err ors ; 5 - User overr iding the CM errors ; 7 - the CM interfa ce isn't w orking ; 1 1 - User o verriding the CM err ors (CM no t updated) ; ; Retu rns False (0) if the bill fail s the Clai msManager Scrubber/e rrors foun d ; Return s True (1) if the bi ll passed the Claims Manager Sc rubber/no errors fou nd or Clai msManager not On at site ; N I BOK S IBOK =1 I +$G(I BIFN),$$CM ^IBCIUT1(I BIFN) S IB CISNT=1 D ST2^IBCIST I '$F(".3 .5.7.11.", "."_IBCIST AT_".") S IBOK=0 Q I BOK ;IIQME D(IBIFN) ; DSS Quadr aMed Inter face: Quad raMed Clai m Scrubber ; Send th e bill to the Quadra Med Claim Scrubber ; Returns F alse (0) i f the bill fails the QuadraMed Scrubber/ errors fou nd ; Retur ns True (1 ) if the b ill passed the Quadr aMed Scrub ber/no err ors found or QuadraM ed not On at site ; ; QuadraMe d Scrubber EN^VEJDIB SC returns IBQMED = 1 if no er ror found, returns 0 if error found ; N IBQMED S I BQMED=1 I +$G(IBIFN) ,$$QMED^IB CU1("EN^VE JDIBSC",IB IFN) D EN^ VEJDIBSC(I BIFN) Q IB QMED | |
| 744 | Modified L ogic (Chan ges are in bold) | |
| 745 | IBCB2 ;ALB /AAS - Pro cess bill after ente r/edited ; 13-DEC-89 ;;2.0;INTE GRATED BIL LING;**52, 51,161,182 ,155,447,5 92**;21-MA R-94;Build 80 ;;Per VHA Direct ive 10-93- 142, this routine sh ould not b e modified . ; ;MAP T O DGCRB2 ; ;IBQUIT = Flag to s top proces sing ;IBVI EW = Flag showing Bi ll has bee n viewed ; IBDISP = F lag showin g Bill ent ering disp lay has be en viewed. ;IBNOFIX = Flag to indicate d o not ask to edit or review bi ll screens ;IBREEDIT = Flag to indicate Bill has b een re-edi ted ;VIEW ;View scre ens; if st atus allow s editing , allow ed iting N Y, DIR S IBPO POUT=0 S I BVIEW=1,IB V=$S($D(IB V):IBV,1:1 ) S DIR(0) ="YA",DIR( "B")="NO", DIR("A")=" WANT TO "_ $S('IBV:"E DIT",1:"RE VIEW")_" S CREENS? ", DIR("?",1) =" YES - t o "_$S('IB V:"EDIT",1 :"REVIEW") _" the scr eens",DIR( "?")=" NO - To take no action" D ^DIR K DIR S:$D(D TOUT) IBQU IT=1 Q:Y'= 1 I $G(IBR EEDIT)=1,' IBV S IBRE EDIT=2 ; s et flag in dicating r e-editVIEW 1 S IBVIEW =1,IBEDIT= 0 D SCREEN S S:$G(IBP OPOUT) IBQ UIT=1 Q ;D ISP S IB(" S")=$S($D( ^DGCR(399, IBIFN,"S") ):^("S"),1 :"") W ! D DISP^IBCN Q W ! S IB DISP=1 Q Q ;EDITS ; Perform ed its on bil l prior to authoriza tion/trans mission N IBREEDITED 1 ; S IBQU IT=0 I '$D (IBER)!('$ D(PRCASV)) D ALLED(. IBQUIT) ; ; If the u ser is wan ting to qu it, but th ere are so me unresol ved ; erro rs reporte d by Claim sManager, then captu re the use r's Exit ; comments. ; I $$CM^ IBCIUT1(IB IFN),IBQUI T,$P($G(^I BA(351.9,I BIFN,0)),U ,2)=4 D CO MMENT^IBCI UT7(IBIFN, 1) ; Q:IBQ UIT D:'$D( IBDISP) DI SP ; ; If claim re-e dit, then call the I B edit che cks again I '$D(IBVI EW) S IBRE EDIT=1 D V IEW I $G(I BREEDIT)=2 K IBER,IB DISP,IBVIE W G ED1 Q ;ALLED(IBQ UIT) ; Bil ling edit/ correction N IBQUIT1 ,IBDONE1,I BDONE,IBED IT,IBCORR, IBER,IBPRT ,IBXERR S (IBQUIT,IB DONE,IBCOR R)=0,IBER= "" ; IBDON E = 1 ==> exit, no e rrors ; I BQUIT = 1 ==> exit, errors not corrected ;JWS;IB*2 .0*592:Den tal form # 7 don't di splay Box 24 info fo r dental I $$FT^IBCE F(IBIFN)=2 ,'$G(IBNOF IX) D DISP 24(IBIFN,. IBCORR,.IB QUIT) ;JWS ;IB*2.0*59 2:Dental f orm #7 do same as CM S-1500 F D Q:IBQUI T!IBDONE D VIEW1 I $$FT^IBCEF (IBIFN)=2! ($$FT^IBCE F(IBIFN)=7 ),'$G(IBNO FIX),'IBQU IT S IBCOR R=0 D:$$FT ^IBCEF(IBI FN)'=7 DIS P24(IBIFN, .IBCORR,.I BQUIT) . I $G(IBPOPO UT) S IBQU IT=1 . Q:I BQUIT!IBCO RR . I $G( IBNOFIX) D .. W !!," ... Checki ng claim v alidity" . E D .. W !!,"... E xecuting n ational IB edits" . D EN^IBCBB ,LOCERR . ; . I $G(I BER)'=""!$ D(IBXERR) D Q:'IBDO NE .. D DS PLERR ; Di splays war nings/erro rs .. K IB XERR .. Q: IBQUIT!(IB DONE) .. I $G(IBNOFI X) S IBDON E=1 Q .. I '$$ASKEDI T($G(IBAC) ) W ! S IB QUIT=1 ; D on't want to re-edit .. ; . I $G(IBNOFIX ) S IBDONE =1 Q . S I BEDIT=0 . I $S($P($G (^DGCR(399 ,IBIFN,0)) ,U,13)>2:1 ,$D(PRCASV ):'$D(PRCA SV("OKAY") ),1:0) D S:'IBQUIT& 'IBEDIT IB DONE=1 Q . . N IBQUIT 1 .. S IBQ UIT1=0 .. W !!!,"... Executing A/R edits " .. I $P( $G(^DGCR(3 99,IBIFN,0 )),U,13)>2 D GVAR^IB CBB,ARRAY^ IBCBB1 .. D ARCHK($G (IBNOFIX), 0,.IBQUIT1 ,.IBQUIT,. IBEDIT,.PR CASV) . S IBDONE=1 ; No errors . S:$G(IB PRT("PRT") )'<0 IBQUI T=0 Q ;ARC HK(IBNOFIX ,IBNOPRT,I BQUIT1,IBQ UIT,IBEDIT ,PRCASV) ; A/R Verif ication ; Returns IB EDIT, IBQU IT1, IBQUI T,PRCASV a rray if pa ssed by re ference ; IBNOFIX = 1 if no ed iting need ed ; IBNOP RT = 1 if no printin g needed F D ^PRCAS VC6 D Q:I BQUIT1!IBE DIT D GVA R^IBCBB,AR RAY^IBCBB1 . I '$G(I BNOPRT) Q: $G(IBPRT(" PRT"))<0 . I PRCASV( "OKAY") W: '$G(IBNOPR T) !!,"No A/R errors found" S IBQUIT1=1 Q . I 'PRC ASV("OKAY" ) D Q .. D DSPARERR ($G(IBNOPR T)) ; Disp lay A/R er rors .. Q: IBQUIT .. I $G(IBNOF IX) S IBQU IT1=1 Q .. I '$$ASKE DIT($G(IBA C)) W !,"T here is an unresolve d A/R erro r - cannot authorize bill" D P AUSE^VALM1 S (IBQUIT ,IBQUIT1)= 1 Q .. S I BEDIT=1 ; Q ;DSPLERR ; Display national/ local edit s failed N Z D PRTH( .IBPRT) I IBPRT("PRT ")<0 S IBQ UIT=1 Q S Z=0 F S Z =$O(^TMP($ J,"BILL-WA RN",Z)) Q: 'Z W !,^( Z) W:'$O(^ (Z)) ! S Y 2="" I IBE R'="WARN" F I=1:1 S X=$P(IBER, ";",I) Q:X ="" W:I=1 !?5,"**Er rors**:" I $D(^IBE(3 50.8,+$O(^ IBE(350.8, "AC",X,0)) ,0)) S Y=^ (0),Y1=$P( Y,"^",5),Y 2=Y2_Y1 I Y1<5 W !?5 ,$E($P(Y," ^",2),1,80 ) ; IBXERR = local e dits retur n error ar ray ; If I BXERR retu rns = 1 th en we have at least one error ; = "" or 0, then we have only local war nings ; un defined = no local e rrors or w arnings I $D(IBXERR) D . S I=" " W !!,?3, "Local Edi ts:" . S:$ G(IBXERR) Y2=3,IBER= "L" . F S I=$O(IBXE RR(I)) Q:I ="" W !,? 5,$E(IBXER R(I),1,75) I $G(IBPR T("PRT")) D CLOSE(.I BPRT) G:$G (IBNOFIX) Q I $G(IBE R)="WARN"! ($G(IBXERR )=0) D ;W arnings on ly - make biller sto p and look . W ! . N DIR,X,Y . S DIR(0)= "YA",DIR(" B")="NO",D IR("A",1)= "THIS BILL STILL HAS ONE OR MO RE WARNING S - PLEASE REVIEW TH EM CAREFUL LY",DIR("A ")="ARE YO U SURE IT' S OK TO CO NTINUE? " . D ^DIR K DIR . I Y '=1 S Y2=3 Q . S IBE R="",IBDON E=1 K IBXE RR I $S(Y2 '["3"&'$G( IBXERR):0, 1:1) K IBX ERRQ K ^TM P($J,"BILL -WARN") Q ;DSPARERR( IBNOPRT) ; Displays A/R errors N I,J,Y,X ,ERRPRT I '$G(IBNOPR T) D PRTH( .IBPRT) I IBPRT("PRT ")<0 S IBQ UIT=1 Q I $P($G(PRCA ERR),U,2)' ="" D . N Z . S Z=+$ O(^IBE(350 .8,"C",$P( PRCAERR,U, 2),0)),Z=$ P($G(^IBE( 350.8,+Z,0 )),U,2) . W !,?5,"An A/R error has been reported - bill cann ot be auth orized",!! ,?5,$P(PRC AERR,U,2), " - ",$S(Z '="":Z,1:" ??") E D . W !,?5," An undeter mined A/R error was found - "_ $G(PRCAERR ) I $G(IBP RT("PRT")) D CLOSE(. IBPRT) Q ; NOPTF S IB AC1=1 I $D (^DGCR(399 ,IBIFN,0)) ,$P(^(0)," ^",8),'$D( ^DGPT($P(^ (0),"^",8) ,0)) S IBA C1=0 Q ;NO PTF1 W !!, *7,"PTF Re cord for t his Bill w as DELETED !",!,"Furt her proces sing not a llowed. Ca ncel and r e-enter." Q ;LOCERR ; Check fo r local ed its ; Exec ute screen post-proc essor for bills with local scr n 9 affili ations N I BZ,IBXIEN, IBPRT K IB XERR S IBZ =$$LOCSCRN ^IBCSC11(I BIFN) ; IB *2.0*447 B I I IBZ S IBXIEN=IBI FN W !!,". .. Executi ng local I B edits" D FPOST^IBC EFG7(IBZ,0 ,.IBXERR) I '$D(IBXE RR) W !!," No errors found for local edit s" Q ;PRTH (IBPRT,IBA ) ; Print a heading for error/ warnings s ent to a p rinter ; R eturns IBP RT = 1 if valid prit ner select ed ; IBPRT = -1 if ' ^' entered ; IBPRT = 0 if home device N POP,%ZIS,P OP S %ZIS( "A")="ERRO R/WARNING OUTPUT DEV ICE: " D ^ %ZIS I POP S IBPRT(" PRT")=-1 Q I IO=IO(0 ) S IBPRT( "PRT")=0 Q S IBPRT(" PRT")=1 U IO W !,"IN CONSISTENC IES LIST F OR BILL #: ",$P($G(^ DGCR(399,I BIFN,0)),U ),!,$J("", 29),"AT: " ,$$FMTE^XL FDT($$NOW^ XLFDT,2),! ,$J("",19) ,"GENERATE D BY: ",$P ($G(^VA(20 0,DUZ,0)), U),!! Q ;C LOSE(IBPRT ) ; Close device, re set printe r flag D ^ %ZISC S IB PRT("PRT") =0 D HOME^ %ZIS Q ;AS KEDIT(IBAC ) ; Ask if edit/revi ew of bill is desire d ; FUNCTI ON returns 0/1 for N O/YES ; IB AC = flag for functi on being p erformed - to determ ine edit/r eview N DI R,X,Y S DI R(0)="YA" S DIR("A", 1)=" ",DIR ("A",2)=" ",DIR("A") ="Do you w ish to "_$ S($G(IBAC) <4:"edit", 1:"review" )_" the in consistenc ies now? " ,DIR("B")= "NO" S DIR ("?",1)=" ",DIR("?", 2)=" ",DIR ("?",3)=" YES - To e dit incons istent fie lds",DIR(" ?")=" NO - To discon tinue this process." D ^DIR K DIR Q (Y=1 ) ;SCREENS ; N IBH D ^IBCSCU,^ IBCSC1 I $ G(IBV) K I BPOPOUT Q ;DISP24(IB IFN,IBCORR ,IBQUIT) ; W @IOF D BL24^IBCSC H(IBIFN,0) S DIR("A" ,1)=" ",DI R("A")="Ar e the abov e charges correct fo r this bil l? ",DIR(" B")="YES", DIR(0)="YA " D ^DIR K DIR I Y'= 1 D . I Y= 0,$$ASKEDI T($G(IBAC) ) S IBCORR =1 Q . S I BQUIT=1 Q ;IICM(IBIF N) ; Ingen ix ClaimsM anager: Cl aim Scrubb er ; Send the bill t o ClaimsMa nager, the IBCISTAT variable r eturned fr om ClaimsM anager ind icates ; 3 - Passed CM with no errors ; 5 - User o verriding the CM err ors ; 7 - the CM int erface isn 't working ; 11 - Us er overrid ing the CM errors (C M not upda ted) ; ; Returns Fa lse (0) if the bill fails the ClaimsMana ger Scrubb er/errors found ; Re turns True (1) if th e bill pas sed the Cl aimsManage r Scrubber /no errors found or ClaimsMana ger not On at site ; N IBOK S IBOK=1 I + $G(IBIFN), $$CM^IBCIU T1(IBIFN) S IBCISNT= 1 D ST2^IB CIST I '$F (".3.5.7.1 1.","."_IB CISTAT_"." ) S IBOK=0 Q IBOK ;I IQMED(IBIF N) ; DSS Q uadraMed I nterface: QuadraMed Claim Scru bber ; Sen d the bill to the Qu adraMed Cl aim Scrubb er ; Retur ns False ( 0) if the bill fails the Quadr aMed Scrub ber/errors found ; R eturns Tru e (1) if t he bill pa ssed the Q uadraMed S crubber/no errors fo und or Qua draMed not On at sit e ; ; Quad raMed Scru bber EN^VE JDIBSC ret urns IBQME D = 1 if n o error fo und, retur ns 0 if er ror found ; N IBQMED S IBQMED= 1 I +$G(IB IFN),$$QME D^IBCU1("E N^VEJDIBSC ",IBIFN) D EN^VEJDIB SC(IBIFN) Q IBQMED | |
| 746 | ||
| 747 | Routines | |
| 748 | Activities | |
| 749 | Routine Na me | |
| 750 | IBCBB | |
| 751 | Enhancemen t Category | |
| 752 | New | |
| 753 | Modify | |
| 754 | Delete | |
| 755 | No Change | |
| 756 | RTM | |
| 757 | ||
| 758 | Related Op tions | |
| 759 | None | |
| 760 | Related Ro utines | |
| 761 | Routines “ Called By” | |
| 762 | Routines “ Called” | |
| 763 | ||
| 764 | ||
| 765 | ||
| 766 | ||
| 767 | Data Dicti onary (DD) Reference s | |
| 768 | CLAIMS TRA CKING File [#356] | |
| 769 | Related Pr otocols | |
| 770 | None | |
| 771 | Related In tegration Control Re gistration s (ICRs) | |
| 772 | None | |
| 773 | Data Passi ng | |
| 774 | Input | |
| 775 | Output Re ference | |
| 776 | Both | |
| 777 | Global Re ference | |
| 778 | Local | |
| 779 | Input Attr ibute Name and Defin ition | |
| 780 | Name: | |
| 781 | Definition : | |
| 782 | Output Att ribute Nam e and Defi nition | |
| 783 | Name: | |
| 784 | Definition : | |
| 785 | Current Lo gic | |
| 786 | IBCBB ;ALB /AAS - EDI T CHECK RO UTINE TO B E INVOKED BEFORE ALL BILL APPR OVAL ACTIO NS ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 80,51,137, 288,327,36 1,371,377, 400,432,46 1,547**;21 -MAR-94;Bu ild 119 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; ;MAP TO DGCRBB ; ; IBNDn = IB ND(n) = ^i b(399,n) ; RETURNS: ; IBER=field s with err ors separa ted by sem i-colons ; PRCASV("OK AY")=1 if iber="" an d $D(prcas v("array") ) compete ;GVAR ;set up variab les for mc cr Q:'$D(I BIFN) F I= 0,"M","U", "U1","S"," MP","TX"," UF3","UF31 ","U2" S @ ("IBND"_I) =$G(^DGCR( 399,IBIFN, I)) S IBBN O=$P(IBND0 ,"^"),DFN= $P(IBND0," ^",2),IBEV DT=$P(IBND 0,"^",3) S IBLOC=$P( IBND0,"^", 4),IBCL=$P (IBND0,"^" ,5),IBTF=$ P(IBND0,"^ ",6) S IBA T=$P(IBND0 ,"^",7),IB WHO=$P(IBN D0,"^",11) ,IBST=$P(I BND0,"^",1 3),IBFT=$P (IBND0,"^" ,19) S IBF DT=$P(IBND U,"^",1),I BTDT=$P(IB NDU,"^",2) S IBTC=$P (IBNDU1,"^ ",1),IBFY= $P(IBNDU1, "^",9),IBF YC=$P(IBND U1,"^",10) S IBEU=$P (IBNDS,"^" ,2),IBRU=$ P(IBNDS,"^ ",5),IBAU= $P(IBNDS," ^",8) S IB TOB=$$TOB( IBND0),IBT OB12=$E(IB TOB,1,2) K ^TMP($J," BILL-WARN" ) Q ;EN ;E ntry to ch eck for er rors N IBQ ,IBXERR,IB XDATA,IBXS AVE,IBZPRC 92,IBQUIT, IBISEQ,IDD ATA,IBFOR, IBC I $D(I BFL) N IBF L K ^TMP($ J) W ! S I BER="" D G VAR I '$D( IBND0) S I BER=-1 Q ; ;patient in patient file I DF N="" S IBE R=IBER_"IB 057;" I DF N]"",'$D(^ DPT(DFN)) S IBER=IBE R_"IB057;" ; ;Event date in co rrect form at I IBEVD T="" S IBE R=IBER_"IB 049;" I IB EVDT]"",IB EVDT'?7N&( IBEVDT'?7N 1".".N) S IBER=IBER_ "IB049;" ; ;Rate Typ e I IBAT=" " S IBER=I BER_"IB059 ;" I IBAT] "",'$D(^DG CR(399.3,I BAT,0)) S IBER=IBER_ "IB059;" I IBAT]"",$ D(^DGCR(39 9.3,IBAT,0 )),'$P(^(0 ),"^",6) S IBER=IBER _"IB059;", IBAT="" I IBAT]"",$P ($G(^DGCR( 399.3,IBAT ,0)),"^",6 ) S IBARTP =$P($$CATN ^PRCAFN($P (^DGCR(399 .3,IBAT,0) ,"^",6))," ^",3) ;Che ck that AR category expects sa me debtor as defined in who's responsibl e. I $D(IB ARTP),IBWH O="i"&(IBA RTP'="T")! (IBWHO="p" &("PC"'[IB ARTP))!(IB WHO="o"&(I BARTP'="N" )) S IBER= IBER_"IB05 8;" ; ;Who 's Respons ible I IBW HO=""!($L( IBWHO)>1)! ("iop"'[IB WHO) S IBE R=IBER_"IB 065;" S IB MRA=$S($$M CRWNR^IBEF UNC(+$$CUR R^IBCEF2(I BIFN)):$$T XMT^IBCEF4 (IBIFN)>0, 1:0) ; MCR will not reimburse is only va lid if the re is subs equent ins urance ; t hat will r eimburse I IBWHO="i" D . I IBM RA D Q .. N Z,IBZ . . S IBZ=0 .. F Z=$$C OBN^IBCEF( IBIFN):1:3 I $D(^DGC R(399,IBIF N,"I"_(Z+1 ))),$P($G( ^DIC(36,+$ G(^DGCR(39 9,IBIFN,"I "_(Z+1))), 0)),U,2)'= "N" S IBZ= 1 Q .. I ' IBZ S IBER =IBER_"IB0 54;" D WAR N^IBCBB11( "A valid c laim for M EDICARE WN R needs su bsequent i ns. that w ill reimbu rse") .. . I $$COB^I BCEF(IBIFN )="S",$$MC RWNR^IBEFU NC(+$$CURR ^IBCEF2(IB IFN))=1,$D (^DGCR(399 ,IBIFN,"I3 ")) Q . I $S('IBNDMP :1,1:$P(IB NDMP,U,2)' =$$BPP^IBC NS2(IBIFN, 1)) S IBER =IBER_"IB0 54;" I IBW HO="o",'$P (IBNDM,"^" ,11) S IBE R=IBER_"IB 053;" ; ; Outpatient Statement dates can not span the ICD-10 activatio n date I I BCL>2,$$IC D10S^IBCU4 (IBFDT,IBT DT) S IBER =IBER_"IB3 54;" ; ; A ll bill IC D codes mu st match C ode Versio n on State ment To Da te IB356 D ICD10V^IB CBB0(IBIFN ) ; ; Bill ing Provid er check - IB*2*400 D BP^IBCBB 0(IBIFN) ; ; Pay-to Provider c heck - IB* 2*400 D PA YTO^IBCBB0 (IBIFN) ; ; All insu rance subs cribers mu st have a birth date on file ; - 11/10/0 4 - IB*2.0 *288 ; - 1 2/14/06 - IB*2.0*361 - must ha ve INSURED 'S SEX too ; IB erro r codes ; IB221 - Pr imary insu rance subs criber mis sing date of birth ; IB222 - S econdary i nsurance s ubscriber missing da te of birt h ; IB223 - Tertiary insurance subscribe r missing date of bi rth ; IB26 1 - Primar y insuranc e subscrib er is miss ing INSURE D'S SEX ; IB262 - Se condary in surance su bscriber i s missing INSURED'S SEX ; IB26 3 - Tertia ry insuran ce subscri ber is mis sing INSUR ED'S SEX ; F IBISEQ= 1:1:3 D . I '$P($G(^ DGCR(399,I BIFN,"I"_I BISEQ)),U, 1) Q ; n o insuranc e here . K ^UTILITY( "VADM",$J) ,^UTILITY( "VAPA",$J) . S IDDAT A=$$INSDEM ^IBCEF(IBI FN,IBISEQ) . K ^UTIL ITY("VADM" ,$J),^UTIL ITY("VAPA" ,$J) . ; . I '$P(IDD ATA,U,1) D ERR(221) ; birth da te missing . ; . I " ^M^F^"'[(U _$P(IDDATA ,U,2)_U) D ERR(261) ; sex miss ing . ; . ; IB*2*371 - esg - c heck for o ther missi ng insuran ce pieces . ; check insured's name, prim ary ID#, p t. relatio nship to i nsured, . ; and subs criber add ress data . N INNAM E,SUBID,PT REL,SFA,CA S,LN,FN . ; . ; IB27 3 - Primar y Insuranc e name of insured mi ssing . ; IB274 - Se condary In surance na me of insu red missin g . ; IB27 5 - Tertia ry Insuran ce name of insured m issing . S INNAME=$$ POLICY^IBC EF(IBIFN,1 7,IBISEQ) . S LN=$P( INNAME,"," ,1),FN=$P( INNAME,"," ,2) ; last name,firs t name . S LN=$$NOPU NCT^IBCEF( LN,1) . S FN=$$NOPUN CT^IBCEF(F N,1) . ; i b*2.0*547 - subscrib er only ne eds last n ame . ;I L N=""!(FN=" ") D ERR(2 73) ; name of insure d missing or invalid . I LN="" D ERR(273 ) ; name o f insured missing or invalid . S LN=$$NA ME^IBCEFG1 (INNAME) ; additiona l name che cks . S FN =$P(LN,U,2 ) . S LN=$ P(LN,U,1) . ;I LN="" !(FN="") D ERR(273) ; name of insured mi ssing or i nvalid . I LN="" D E RR(273) ; name of in sured miss ing or inv alid . ; . ; IB276 - Primary I nsurance s ubscriber ID missing . ; IB277 - Seconda ry Insuran ce subscri ber ID mis sing . ; I B278 - Ter tiary Insu rance subs criber ID missing . S SUBID=$$ NOPUNCT^IB CEF($$POLI CY^IBCEF(I BIFN,2,IBI SEQ),1) . I SUBID="" D ERR(276 ) ; subscr iber ID# m issing . ; . ; IB279 - Primary Insurance missing p t relation ship . ; I B280 - Sec ondary Ins urance mis sing pt re lationship . ; IB281 - Tertiar y Insuranc e missing pt relatio nship . S PTREL=$$PO LICY^IBCEF (IBIFN,16, IBISEQ) . I PTREL="" D ERR(279 ) ; missin g patient relationsh ip to insu red . ; . ; subscrib er address section . S SFA=$$I NSADDR^IBC EF(IBIFN,I BISEQ) ; f ull addres s all piec es . S CAS =$$NOPUNCT ^IBCEF($P( SFA,U,2,5) ,1) ; stri ng city,st ,zip,addr1 . ; . ; I B282 - Pri mary Insur ance addre ss line 1 missing . ; IB283 - Secondary Insurance address li ne 1 missi ng . ; IB2 84 - Terti ary Insura nce addres s line 1 m issing . I $$NOPUNCT ^IBCEF($P( SFA,U,5),1 )="" D ; address l ine 1 is b lank .. ; pat=subscr iber and c urrent ins urance - a ddress is required . . I +PTREL =1,IBISEQ= $$COBN^IBC EF(IBIFN) D ERR(282) Q .. ; if any part of the add ress is th ere, then all fields are requi red .. I C AS'="" D E RR(282) Q .. Q . ; . ; IB285 - Primary I nsurance c ity missin g . ; IB28 6 - Second ary Insura nce city m issing . ; IB287 - T ertiary In surance ci ty missing . I $$NOP UNCT^IBCEF ($P(SFA,U, 2),1)="" D ; city is blank . . ; pat=su bscriber a nd current insurance - address is requir ed .. I +P TREL=1,IBI SEQ=$$COBN ^IBCEF(IBI FN) D ERR( 285) Q .. ; if any p art of the address i s there, t hen all fi elds are r equired .. I CAS'="" D ERR(285 ) Q .. Q . ; . ; IB2 88 - Prima ry Insuran ce state m issing . ; IB289 - S econdary I nsurance s tate missi ng . ; IB2 90 - Terti ary Insura nce state missing . I $$NOPUNC T^IBCEF($P (SFA,U,3), 1)="" D ; state is blank .. ; pat=subs criber and current i nsurance - address i s required .. I +PTR EL=1,IBISE Q=$$COBN^I BCEF(IBIFN ) D ERR(28 8) Q .. ; if any par t of the a ddress is there, the n all fiel ds are req uired .. I CAS'="" D ERR(288) Q .. Q . ; . ; IB291 - Primary Insurance zipcode m issing . ; IB292 - S econdary I nsurance z ipcode mis sing . ; I B293 - Ter tiary Insu rance zipc ode missin g . I $$NO PUNCT^IBCE F($P(SFA,U ,4),1)="" D ; zipc ode is bla nk .. ; pa t=subscrib er and cur rent insur ance - add ress is re quired .. I +PTREL=1 ,IBISEQ=$$ COBN^IBCEF (IBIFN) D ERR(291) Q .. ; if a ny part of the addre ss is ther e, then al l fields a re require d .. I CAS '="" D ERR (291) Q .. Q . ; . Q ; ; esg - IB*2*371 - check pa tient addr ess fields K ^UTILIT Y("VAPA",$ J) ; S IBF OR=0 ; for eign addre ss flag S IBC=+$$PTA DDR^IBCEF( IBIFN,25) ; country code ien I IBC D . N CODE . S CODE=$$GET 1^DIQ(779. 004,IBC,.0 1) ; .01 c ode field file 779.0 04 . I COD E'="",CODE '="USA" S IBFOR=1 ; foreign co untry exis ts . Q ; I $$NOPUNCT ^IBCEF($$P TADDR^IBCE F(IBIFN,1) ,1)="" S I BER=IBER_" IB269;" I $$NOPUNCT^ IBCEF($$PT ADDR^IBCEF (IBIFN,4), 1)="" S IB ER=IBER_"I B270;" I $ $NOPUNCT^I BCEF($$PTA DDR^IBCEF( IBIFN,5),1 )="",'IBFO R S IBER=I BER_"IB271 ;" I $$NOP UNCT^IBCEF ($$PTADDR^ IBCEF(IBIF N,11),1)=" ",'IBFOR S IBER=IBER _"IB272;" K ^UTILITY ("VAPA",$J ) ; D PAYE RADD^IBCBB 0(IBIFN) ; check the payer add resses D ^ IBCBB1 Q ; The remai ning code below is b eing remov ed with Pa tch IB*2.0 *432. ; ; esg - 9/20 /07 - IB p atch 371 - prevent E DI transmi ssion for 3 payer ; claims for all but t he first p ayer. To b e removed when Emdeo n ; and FS C are able to deal w ith these. ; I +$G(^ DGCR(399,I BIFN,"I2") ),+$G(^DGC R(399,IBIF N,"I3")),$ $TXMT^IBCE F4(IBIFN) D . ; for MRA reques t claims, make sure the MRA se condary cl aim is for ced to pri nt . I $$R EQMRA^IBEF UNC(IBIFN) D Q .. I '$P($G(^D GCR(399,IB IFN,"TX")) ,U,9) S IB ER=IBER_"I B146;" .. Q . ; . I $$COBN^IBC EF(IBIFN)= 1 Q ; pr imary paye r sequence claims ar e OK . ; . ; But cla ims with a payer seq uence of 2 or 3 need to print locally . S IBER=IBE R_"IB147;" . Q ; Q ; EDIT(IBIFN ) ; Run ed its from w ithin the billing ed it screens N IBVIEW, IBDISP,IBN OFIX,DIR,X ,Y S (IBNO FIX,IBVIEW ,IBDISP)=1 D EDITS^I BCB2 W ! S DIR("A")= "Press RET URN to con tinue",DIR (0)="E" D ^DIR K DIR Q ;TOB(IB ND0) ; ; I BND0 = the 0-node of the bill (file 399) Q ($P(IBN D0,U,24)_$ P($G(^DGCR (399.1,+$P (IBND0,U,2 5),0)),U,2 )_$P(IBND0 ,U,26)) ;E RR(Z) ; up date IBER variable f rom the ab ove insura nce checks ; Z is th e IB error code# for the prima ry insuran ce error N IBERRNO S IBERRNO=" IB"_(Z+IBI SEQ-1) I I BER[IBERRN O Q S IBER =IBER_IBER RNO_";" Q | |
| 787 | Modified L ogic (Chan ges are in bold) | |
| 788 | IBCBB ;ALB /AAS - EDI T CHECK RO UTINE TO B E INVOKED BEFORE ALL BILL APPR OVAL ACTIO NS ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 80,51,137, 288,327,36 1,371,377, 400,432,46 1,547,592* *;21-MAR-9 4;Build 11 9 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; ;MAP TO DGCRBB ; ;IBNDn = IBND(n) = ^ib(399, n) ;RETURN S: ;IBER=f ields with errors se parated by semi-colo ns ;PRCASV ("OKAY")=1 if iber=" " and $D(p rcasv("arr ay")) comp ete ;GVAR ;set up va riables fo r mccr Q:' $D(IBIFN) F I=0,"M", "U","U1"," S","MP","T X","UF3"," UF31","U2" S @("IBND "_I)=$G(^D GCR(399,IB IFN,I)) S IBBNO=$P(I BND0,"^"), DFN=$P(IBN D0,"^",2), IBEVDT=$P( IBND0,"^", 3) S IBLOC =$P(IBND0, "^",4),IBC L=$P(IBND0 ,"^",5),IB TF=$P(IBND 0,"^",6) S IBAT=$P(I BND0,"^",7 ),IBWHO=$P (IBND0,"^" ,11),IBST= $P(IBND0," ^",13),IBF T=$P(IBND0 ,"^",19) S IBFDT=$P( IBNDU,"^", 1),IBTDT=$ P(IBNDU,"^ ",2) S IBT C=$P(IBNDU 1,"^",1),I BFY=$P(IBN DU1,"^",9) ,IBFYC=$P( IBNDU1,"^" ,10) S IBE U=$P(IBNDS ,"^",2),IB RU=$P(IBND S,"^",5),I BAU=$P(IBN DS,"^",8) S IBTOB=$$ TOB(IBND0) ,IBTOB12=$ E(IBTOB,1, 2) K ^TMP( $J,"BILL-W ARN") Q ;E N ;Entry t o check fo r errors N IBQ,IBXER R,IBXDATA, IBXSAVE,IB ZPRC92,IBQ UIT,IBISEQ ,IDDATA,IB FOR,IBC I $D(IBFL) N IBFL K ^T MP($J) W ! S IBER="" D GVAR I '$D(IBND0) S IBER=-1 Q ; ;pati ent in pat ient file I DFN="" S IBER=IBER _"IB057;" I DFN]"",' $D(^DPT(DF N)) S IBER =IBER_"IB0 57;" ; ;Ev ent date i n correct format I I BEVDT="" S IBER=IBER _"IB049;" I IBEVDT]" ",IBEVDT'? 7N&(IBEVDT '?7N1".".N ) S IBER=I BER_"IB049 ;" ; ;Rate Type I IB AT="" S IB ER=IBER_"I B059;" I I BAT]"",'$D (^DGCR(399 .3,IBAT,0) ) S IBER=I BER_"IB059 ;" I IBAT] "",$D(^DGC R(399.3,IB AT,0)),'$P (^(0),"^", 6) S IBER= IBER_"IB05 9;",IBAT=" " I IBAT]" ",$P($G(^D GCR(399.3, IBAT,0))," ^",6) S IB ARTP=$P($$ CATN^PRCAF N($P(^DGCR (399.3,IBA T,0),"^",6 )),"^",3) ;Check tha t AR categ ory expect s same deb tor as def ined in wh o's respon sible. I $ D(IBARTP), IBWHO="i"& (IBARTP'=" T")!(IBWHO ="p"&("PC" '[IBARTP)) !(IBWHO="o "&(IBARTP' ="N")) S I BER=IBER_" IB058;" ; ;Who's Res ponsible I IBWHO=""! ($L(IBWHO) >1)!("iop" '[IBWHO) S IBER=IBER _"IB065;" S IBMRA=$S ($$MCRWNR^ IBEFUNC(+$ $CURR^IBCE F2(IBIFN)) :$$TXMT^IB CEF4(IBIFN )>0,1:0) ; MCR will not reimbu rse is onl y valid if there is subsequent insurance ; that wi ll reimbur se I IBWHO ="i" D . ; JWS;IB*2.0 *592;US110 9; If Dent al and Pla n Coverage Limitatio n is NO sk ip . I $$F T^IBCEF(IB IFN)=7,'$$ PTCOV^IBCN SU3(DFN,$P ($G(^DGCR( 399,IBIFN, 0)),"^",3) ,"DENTAL") S IBER=IB ER_"IB362" . I IBMRA D Q .. ; JWS;IB*2.0 *592;Do no t allow to bill Dent al to Medi care WNR . . I $$FT^I BCEF(IBIFN )=7,'$F(IB ER,"IB359; ") S IBER= IBER_"IB35 9;" .. N Z ,IBZ .. S IBZ=0 .. F Z=$$COBN^ IBCEF(IBIF N):1:3 I $ D(^DGCR(39 9,IBIFN,"I "_(Z+1))), $P($G(^DIC (36,+$G(^D GCR(399,IB IFN,"I"_(Z +1))),0)), U,2)'="N" S IBZ=1 Q .. I 'IBZ S IBER=IBE R_"IB054;" D WARN^IB CBB11("A v alid claim for MEDIC ARE WNR ne eds subseq uent ins. that will reimburse" ) . I $$CO B^IBCEF(IB IFN)="S",$ $MCRWNR^IB EFUNC(+$$C URR^IBCEF2 (IBIFN))=1 ,$D(^DGCR( 399,IBIFN, "I3")) Q . I $S('IBN DMP:1,1:$P (IBNDMP,U, 2)'=$$BPP^ IBCNS2(IBI FN,1)) S I BER=IBER_" IB054;" I IBWHO="o", '$P(IBNDM, "^",11) S IBER=IBER_ "IB053;" ; ; Outpati ent Statem ent dates can not sp an the ICD -10 activa tion date I IBCL>2,$ $ICD10S^IB CU4(IBFDT, IBTDT) S I BER=IBER_" IB354;" ; ; All bill ICD codes must matc h Code Ver sion on St atement To Date IB35 6 D ICD10V ^IBCBB0(IB IFN) ; ; B illing Pro vider chec k - IB*2*4 00 D BP^IB CBB0(IBIFN ) ; ; Pay- to Provide r check - IB*2*400 D PAYTO^IBC BB0(IBIFN) ; ; All i nsurance s ubscribers must have a birth d ate on fil e ; - 11/1 0/04 - IB* 2.0*288 ; - 12/14/06 - IB*2.0* 361 - must have INSU RED'S SEX too ; IB e rror codes ; IB221 - Primary i nsurance s ubscriber missing da te of birt h ; IB222 - Secondar y insuranc e subscrib er missing date of b irth ; IB2 23 - Terti ary insura nce subscr iber missi ng date of birth ; I B261 - Pri mary insur ance subsc riber is m issing INS URED'S SEX ; IB262 - Secondary insurance subscribe r is missi ng INSURED 'S SEX ; I B263 - Ter tiary insu rance subs criber is missing IN SURED'S SE X ; F IBIS EQ=1:1:3 D . I '$P($ G(^DGCR(39 9,IBIFN,"I "_IBISEQ)) ,U,1) Q ; no insur ance here . K ^UTILI TY("VADM", $J),^UTILI TY("VAPA", $J) . S ID DATA=$$INS DEM^IBCEF( IBIFN,IBIS EQ) . K ^U TILITY("VA DM",$J),^U TILITY("VA PA",$J) . ; . I '$P( IDDATA,U,1 ) D ERR(22 1) ; birth date miss ing . ; . I "^M^F^"' [(U_$P(IDD ATA,U,2)_U ) D ERR(26 1) ; sex m issing . ; . ; IB*2* 371 - esg - check fo r other mi ssing insu rance piec es . ; che ck insured 's name, p rimary ID# , pt. rela tionship t o insured, . ; and s ubscriber address da ta . N IN NAME,SUBID ,PTREL,SFA ,CAS,LN,FN . ; . ; I B273 - Pri mary Insur ance name of insured missing . ; IB274 - Secondary Insurance name of i nsured mis sing . ; I B275 - Ter tiary Insu rance name of insure d missing . S INNAME =$$POLICY^ IBCEF(IBIF N,17,IBISE Q) . S LN= $P(INNAME, ",",1),FN= $P(INNAME, ",",2) ; l ast name,f irst name . S LN=$$N OPUNCT^IBC EF(LN,1) . S FN=$$NO PUNCT^IBCE F(FN,1) . ; ib*2.0*5 47 - subsc riber only needs las t name . ; I LN=""!(F N="") D ER R(273) ; n ame of ins ured missi ng or inva lid . I LN ="" D ERR( 273) ; nam e of insur ed missing or invali d . S LN=$ $NAME^IBCE FG1(INNAME ) ; additi onal name checks . S FN=$P(LN, U,2) . S L N=$P(LN,U, 1) . ;I LN =""!(FN="" ) D ERR(27 3) ; name of insured missing o r invalid . I LN="" D ERR(273) ; name of insured m issing or invalid . ; . ; IB27 6 - Primar y Insuranc e subscrib er ID miss ing . ; IB 277 - Seco ndary Insu rance subs criber ID missing . ; IB278 - Tertiary I nsurance s ubscriber ID missing . S SUBID =$$NOPUNCT ^IBCEF($$P OLICY^IBCE F(IBIFN,2, IBISEQ),1) . I SUBID ="" D ERR( 276) ; sub scriber ID # missing . ; . ; IB 279 - Prim ary Insura nce missin g pt relat ionship . ; IB280 - Secondary Insurance missing pt relations hip . ; IB 281 - Tert iary Insur ance missi ng pt rela tionship . S PTREL=$ $POLICY^IB CEF(IBIFN, 16,IBISEQ) . I PTREL ="" D ERR( 279) ; mis sing patie nt relatio nship to i nsured . ; . ; subsc riber addr ess sectio n . S SFA= $$INSADDR^ IBCEF(IBIF N,IBISEQ) ; full add ress all p ieces . S CAS=$$NOPU NCT^IBCEF( $P(SFA,U,2 ,5),1) ; s tring city ,st,zip,ad dr1 . ; . ; IB282 - Primary In surance ad dress line 1 missing . ; IB283 - Seconda ry Insuran ce address line 1 mi ssing . ; IB284 - Te rtiary Ins urance add ress line 1 missing . I $$NOPU NCT^IBCEF( $P(SFA,U,5 ),1)="" D ; addres s line 1 i s blank .. ; pat=sub scriber an d current insurance - address is require d .. I +PT REL=1,IBIS EQ=$$COBN^ IBCEF(IBIF N) D ERR(2 82) Q .. ; if any pa rt of the address is there, th en all fie lds are re quired .. I CAS'="" D ERR(282) Q .. Q . ; . ; IB28 5 - Primar y Insuranc e city mis sing . ; I B286 - Sec ondary Ins urance cit y missing . ; IB287 - Tertiary Insurance city miss ing . I $$ NOPUNCT^IB CEF($P(SFA ,U,2),1)=" " D ; ci ty is blan k .. ; pat =subscribe r and curr ent insura nce - addr ess is req uired .. I +PTREL=1, IBISEQ=$$C OBN^IBCEF( IBIFN) D E RR(285) Q .. ; if an y part of the addres s is there , then all fields ar e required .. I CAS' ="" D ERR( 285) Q .. Q . ; . ; IB288 - Pr imary Insu rance stat e missing . ; IB289 - Secondar y Insuranc e state mi ssing . ; IB290 - Te rtiary Ins urance sta te missing . I $$NOP UNCT^IBCEF ($P(SFA,U, 3),1)="" D ; state is blank .. ; pat=s ubscriber and curren t insuranc e - addres s is requi red .. I + PTREL=1,IB ISEQ=$$COB N^IBCEF(IB IFN) D ERR (288) Q .. ; if any part of th e address is there, then all f ields are required . . I CAS'=" " D ERR(28 8) Q .. Q . ; . ; IB 291 - Prim ary Insura nce zipcod e missing . ; IB292 - Secondar y Insuranc e zipcode missing . ; IB293 - Tertiary I nsurance z ipcode mis sing . I $ $NOPUNCT^I BCEF($P(SF A,U,4),1)= "" D ; z ipcode is blank .. ; pat=subsc riber and current in surance - address is required .. I +PTRE L=1,IBISEQ =$$COBN^IB CEF(IBIFN) D ERR(291 ) Q .. ; i f any part of the ad dress is t here, then all field s are requ ired .. I CAS'="" D ERR(291) Q .. Q . ; . Q ; ; es g - IB*2*3 71 - check patient a ddress fie lds K ^UTI LITY("VAPA ",$J) ; S IBFOR=0 ; foreign ad dress flag S IBC=+$$ PTADDR^IBC EF(IBIFN,2 5) ; count ry code ie n I IBC D . N CODE . S CODE=$$ GET1^DIQ(7 79.004,IBC ,.01) ; .0 1 code fie ld file 77 9.004 . I CODE'="",C ODE'="USA" S IBFOR=1 ; foreign country e xists . Q ; I $$NOPU NCT^IBCEF( $$PTADDR^I BCEF(IBIFN ,1),1)="" S IBER=IBE R_"IB269;" I $$NOPUN CT^IBCEF($ $PTADDR^IB CEF(IBIFN, 4),1)="" S IBER=IBER _"IB270;" I $$NOPUNC T^IBCEF($$ PTADDR^IBC EF(IBIFN,5 ),1)="",'I BFOR S IBE R=IBER_"IB 271;" I $$ NOPUNCT^IB CEF($$PTAD DR^IBCEF(I BIFN,11),1 )="",'IBFO R S IBER=I BER_"IB272 ;" K ^UTIL ITY("VAPA" ,$J) ; D P AYERADD^IB CBB0(IBIFN ) ; check the payer addresses D ^IBCBB1 Q ; The re maining co de below i s being re moved with Patch IB* 2.0*432. ; ; esg - 9 /20/07 - I B patch 37 1 - preven t EDI tran smission f or 3 payer ; claims for all bu t the firs t payer. T o be remov ed when Em deon ; and FSC are a ble to dea l with the se. ; I +$ G(^DGCR(39 9,IBIFN,"I 2")),+$G(^ DGCR(399,I BIFN,"I3") ),$$TXMT^I BCEF4(IBIF N) D . ; f or MRA req uest claim s, make su re the MRA secondary claim is forced to print . I $$REQMRA^I BEFUNC(IBI FN) D Q . . I '$P($G (^DGCR(399 ,IBIFN,"TX ")),U,9) S IBER=IBER _"IB146;" .. Q . ; . I $$COBN^ IBCEF(IBIF N)=1 Q ; primary p ayer seque nce claims are OK . ; . ; But claims wit h a payer sequence o f 2 or 3 n eed to pri nt locally . S IBER= IBER_"IB14 7;" . Q ; Q ;EDIT(IB IFN) ; Run edits fro m within t he billing edit scre ens N IBVI EW,IBDISP, IBNOFIX,DI R,X,Y S (I BNOFIX,IBV IEW,IBDISP )=1 D EDIT S^IBCB2 W ! S DIR("A ")="Press RETURN to continue", DIR(0)="E" D ^DIR K DIR Q ;TOB (IBND0) ; ; IBND0 = the 0-node of the bi ll (file 3 99) Q ($P( IBND0,U,24 )_$P($G(^D GCR(399.1, +$P(IBND0, U,25),0)), U,2)_$P(IB ND0,U,26)) ;ERR(Z) ; update IB ER variabl e from the above ins urance che cks ; Z is the IB er ror code# for the pr imary insu rance erro r N IBERRN O S IBERRN O="IB"_(Z+ IBISEQ-1) I IBER[IBE RRNO Q S I BER=IBER_I BERRNO_";" Q ; | |
| 789 | ||
| 790 | ||
| 791 | ||
| 792 | Routines | |
| 793 | Activities | |
| 794 | Routine Na me | |
| 795 | IBCBB1 | |
| 796 | Enhancemen t Category | |
| 797 | New | |
| 798 | Modify | |
| 799 | Delete | |
| 800 | No Change | |
| 801 | RTM | |
| 802 | ||
| 803 | Related Op tions | |
| 804 | None | |
| 805 | Related Ro utines | |
| 806 | Routines “ Called By” | |
| 807 | Routines “ Called” | |
| 808 | ||
| 809 | ||
| 810 | ||
| 811 | ||
| 812 | Data Dicti onary (DD) Reference s | |
| 813 | CLAIMS TRA CKING File [#356] | |
| 814 | Related Pr otocols | |
| 815 | None | |
| 816 | Related In tegration Control Re gistration s (ICRs) | |
| 817 | None | |
| 818 | Data Passi ng | |
| 819 | Input | |
| 820 | Output Re ference | |
| 821 | Both | |
| 822 | Global Re ference | |
| 823 | Local | |
| 824 | Input Attr ibute Name and Defin ition | |
| 825 | Name: | |
| 826 | Definition : | |
| 827 | Output Att ribute Nam e and Defi nition | |
| 828 | Name: | |
| 829 | Definition : | |
| 830 | Current Lo gic | |
| 831 | IBCBB1 ;AL B/AAS - CO NTINUATION OF EDIT C HECK ROUTI NE ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 27,52,80,9 3,106,51,1 51,148,153 ,137,232,2 80,155,320 ,343,349,3 63,371,395 ,384,432,4 47,488**;2 1-MAR-94;B uild 184 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ; ; *** Begin IB*2.0*488 VD (Issue 46 RBN) N I S I="" S X=+$G(^D GCR(399,IB IFN,"MP")) I 'X,$$MC RWNR^IBEFU NC(+$$CURR ^IBCEF2(IB IFN)) S X= +$$CURR^IB CEF2(IBIFN ) I X,+$G( ^DIC(36,X, 3)) S I=$P (^(3),U,$S ($$FT^IBCE F(IBIFN)=2 :2,1:4)) S I=$$UP^XL FSTR(I) I (I'=""&(I[ "PRNT")&($ G(IBER)'[" IB488")) D . S IBER =$G(IBER)_ "IB488;" ; ; Cause a n error if FORCED TO PRINT TO CLEARINGHO USE I $P($ G(^DGCR(39 9,IBIFN,"T X")),U,8)= 2 D . S IB ER=$G(IBER )_"IB489;" ; ; Cause a fatal e rror if th e claim ha s no proce dures & is NOT a UB- 04 Inpatie nt claim. I +$O(^DGC R(399,IBIF N,"CP",0)) =0 D .I $$ INPAT^IBCE F(IBIFN,1) ,$$INSPRF^ IBCEF(IBIF N) Q ; i npatient U B-04 check .I '$$INP AT^IBCEF(I BIFN,1),$$ INSPRF^IBC EF(IBIFN) D Q ; Outpatie nt Institu tional Cla im. ..I IB ER["IB352" Q ..S IBE R=IBER_"IB 352;" .; . ; Professi onal claim .I IBER[" IB353" Q . S IBER=IBE R_"IB353;" .Q ; *** End IB*2.0 *488 -- VD ; ;MAP TO DGCRBB1 ; % ;Bill St atus N Z,Z 0,Z1,IBFT I $S(+IBST =0:1,1:"^1 ^2^3^4^7^" '[(U_IBST_ U)) S IBER =IBER_"IB0 45;" ; ;St atement Co vers From I IBFDT="" S IBER=IB ER_"IB061; " I IBFDT] "",IBFDT'? 7N&(IBFDT' ?7N1".".N) S IBER=IB ER_"IB061; " I IBFDT> IBTDT S IB ER=IBER_"I B061;" ; f rom must b e on or be fore the t o date S IBFFY=$$FY ^IBOUTL(IB FDT) ; if inpat - fr om date mu st not be prior to a dmit date. I $$INPAT ^IBCEF(IBI FN,1),(IBF DT<($P($G( ^DGPT(+$P( IBND0,U,8) ,0)),U,2)\ 1)) S IBER =IBER_"IB0 61;" ; ;St atement Co vers To I IBTDT="" S IBER=IBER _"IB062;" I IBTDT]"" ,IBTDT'?7N &(IBTDT'?7 N1".".N) S IBER=IBER _"IB062;" I IBTDT>DT !(IBTDT<IB FDT) S IBE R=IBER_"IB 062;" ; t o date mus t not be > than today 's date S IBTFY=$$FY ^IBOUTL(IB TDT) ; ;To tal Charge s ; IB*2.0 *447/TAZ R emoved thi s error so that zero dollar re venue code s can proc ess on the 837 ;I +I BTC'>0!(+I BTC'=IBTC) S IBER=IB ER_"IB064; " ; ;Billa ble charge s for seco ndary clai m I $$MCRO NBIL^IBEFU NC(IBIFN)& (($P(IBNDU 1,U,1)-$P( IBNDU1,U,2 ))'>0) S I BER=IBER_" IB094;" ;F iscal Year 1 S IBFFY =$$FY^IBOU TL(IBFDT) ; ;Check p rovider li nk for cur rent user, enterer, reviewer a nd Authori zor I '$D( ^VA(200,DU Z,0)) S IB ER=IBER_"I B048;" I I BEU]"",'$D (^VA(200,I BEU,0)) S IBER=IBER_ "IB048;" I IBRU]"",' $D(^VA(200 ,IBRU,0)) S IBER=IBE R_"IB060;" I IBAU]"" ,'$D(^VA(2 00,IBAU,0) ) S IBER=I BER_"IB041 ;" ; I IBE R="",+$$ST A^PRCAFN(I BIFN)=104 S IBER=IBE R_"IB040;" ; If ins bill, must have vali d COB sequ ence I $P( IBND0,U,11 )="i",$S($ P(IBND0,U, 21)="":1,1 :"PST"'[$P (IBND0,U,2 1)) S IBER =IBER_"IB3 24;" ; ; C heck for v alid sec p rovider id for curre nt ins S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," PRV",Z)) Q :'Z S Z0= $G(^(Z,0)) ,Z1=+$$COB N^IBCEF(IB IFN) I $P( Z0,U,4+Z1) '="",$P(Z0 ,U,11+Z1)' ="" D . I '$$SECIDCK ^IBCEF74(I BIFN,Z1,$P (Z0,U,11+Z 1),Z) D WA RN^IBCBB11 ("Prov sec ondary id type for t he "_$P("P RIMARY^SEC ONDARY^TER TIARY",U,Z 1)_" "_$$E XTERNAL^DI LFD(399.02 22,.01,,+Z 0)_" is in valid/won' t transmit ") ; Check NPIs D NP ICHK^IBCBB 11 ; ; Che ck multipl e rx NPIs D RXNPI^IB CBB11(IBIF N) ; ; Che ck taxonom ies D TAXC HK^IBCBB11 ; ; Check for Physi cian Name K IBXDATA D F^IBCEF( "N-ATT/REN D PHYSICIA N NAME",,, IBIFN) ; I B*2.0*432 - CMS1500 no longer needs a cl aim level rendering S IBFT=$$F T^IBCEF(IB IFN) I IBF T'=2,$P($G (IBXDATA), U)="" S IB ER=IBER_"I B303;" ; N FUNCTION, IBINS ; IB *2.0*432 - CMS1500 n o longer n eeds a cla im level r endering ; S FUNCTION =$S($$FT^I BCEF(IBIFN )=3:4,1:3) S FUNCTIO N=$S(IBFT= 3:4,1:3) I IBFT'=2,I BER'["IB30 3;" D . F IBINS=1:1: 3 D .. S Z =$$GETTYP^ IBCEP2A(IB IFN,IBINS) .. I Z,$P (Z,U,2) D ; Renderi ng/attendi ng prov se condary id required ... N IBID ,IBOK,Q0 . .. D PROVI NF^IBCEF74 (IBIFN,IBI NS,.IBID,1 ,"C") ; ch eck all as though th ey were cu rrent ... S IBOK=0 . .. S Q0=0 F S Q0=$O (IBID(1,FU NCTION,Q0) ) Q:'Q0 I $P(IBID(1 ,FUNCTION, Q0),U,9)=+ Z S IBOK=1 Q ... I ' IBOK S IBE R=IBER_$S( IBINS=1:"I B236;",IBI NS=2:"IB23 7;",IBINS= 3:"IB238;" ,1:"") ; ; Patch 432 enh5:The IB system shall no l onger prev ent users from autho rizing(fat al error m essage)a c laim becau se the sys tem cannot find the providersS SNorEIN ; D PRIIDCHK ^IBCBB11 ; N IBM,IBM 1 S IBM=$G (^DGCR(399 ,IBIFN,"M" )) S IBM1= $G(^DGCR(3 99,IBIFN," M1")) I $P (IBM,U),$P ($G(^DIC(3 6,$P(IBM,U ),4)),U,6) ,$P(IBM1,U ,2)="" S I BER=IBER_" IB244;" I $P(IBM,U,2 ),$P($G(^D IC(36,$P(I BM,U,2),4) ),U,6),$P( IBM1,U,3)= "" S IBER= IBER_"IB24 5;" I $P(I BM,U,3),$P ($G(^DIC(3 6,$P(IBM,U ,3),4)),U, 6),$P(IBM1 ,U,4)="" S IBER=IBER _"IB246;" ; ; If out side facil ity, check for ID an d qualifie r in 355.9 3 ; 5/15/0 6 - esg - hard error IB243 tur ned into w arning mes sage inste ad S Z=$P( $G(^DGCR(3 99,IBIFN," U2")),U,10 ) I Z D . I $P($G(^I BA(355.93, Z,0)),U,9) =""!($P($G (^IBA(355. 93,Z,0)),U ,13)="") D .. N Z1,Z 2 .. S Z1= "Missing L ab or Faci lity Prima ry ID for non-VA fac ility, " . . S Z2=$$E XTERNAL^DI LFD(399,23 2,,Z) .. I $L(Z2)'>1 9 D WARN^I BCBB11(Z1_ Z2) Q .. D WARN^IBCB B11(Z1),WA RN^IBCBB11 (" "_Z2) . . Q . Q ; ; Must be one and on ly one div ision on b ill S IBZ= $$MULTDIV^ IBCBB11(IB IFN,IBND0) ; I IBZ S IBER=IBER _$S(IBZ=1: "IB095;",I BZ=2:"IB10 4;",1:"IB1 05;") ; Al low multi- divisional for OP in stutional claims I I BZ,$$INPAT ^IBCEF(IBI FN)!'($$IN SPRF^IBCEF (IBIFN)) S IBER=IBER _$S(IBZ=1: "IB095;",I BZ=2:"IB10 4;",1:"IB1 05;") ; St ill need e rror msg o n OP Insti tutional i f No Defau lt divisio n I IBZ=3, '$$INPAT^I BCEF(IBIFN ),$$INSPRF ^IBCEF(IBI FN) S IBER =IBER_"IB1 05;" ; Div ision addr ess must b e defined in institu tion file I $P(IBND0 ,U,22) D . N Z,Z0,Z1 . S Z0=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),0 )) . S Z1= $G(^DIC(4, +$P($G(^DG (40.8,+$P( IBND0,U,22 ),0)),U,7) ,1)) . I $ P(Z0,U,2)= "" S IBER= IBER_"IB09 7;" Q . F Z=1,3,4 I $P(Z1,U,Z) ="" S IBER =IBER_"IB0 97;" Q ; ; IB*2.0*43 2 Check am bulance ad dresses, C OB Non-cov ered amt. & Attachme nt Control I $$AMBCK ^IBCBB11(I BIFN)=1 S IBER=IBER_ "IB329;" I $$COBAMT^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB330;" I $$TMCK^IBC BB11(IBIFN )=1 S IBER =IBER_"IB3 31;" I $$A CCK^IBCBB1 1(IBIFN)=1 S IBER=IB ER_"IB332; " I $$COBM RA^IBCBB11 (IBIFN)=1 S IBER=IBE R_"IB342;" I $$COBSE C^IBCBB11( IBIFN)=1 S IBER=IBER _"IB343;" ; ;CHAMPVA Rate Type and Prima ry Insuran ce Carrier s Type of Coverage m ust match S (IBRTCHV ,IBPICHV)= 0 I $P($G( ^DGCR(399. 3,+IBAT,0) ),U,1)="CH AMPVA" S I BRTCHV=1 I $P($G(^IB E(355.2,+$ P($G(^DIC( 36,+IBNDMP ,0)),U,13) ,0)),U,1)= "CHAMPVA" S IBPICHV= 1 I (+IBRT CHV!+IBPIC HV)&('IBRT CHV!'IBPIC HV) S IBER =IBER_"IB0 85;" ; N I BZPRC,IBZP RCUB D F^I BCEF("N-AL L PROCEDUR ES","IBZPR C",,IBIFN) ; Procedu re Clinic is require d for Surg ical Proce dures Outp t Facility Charges I +$P(IBND0 ,U,27)'=2, $$BILLRATE ^IBCRU3(IB AT,IBCL,IB EVDT,"RC O UTPATIENT" ) D . N Z, Z0,Z1,ZE S (ZE,Z)=0 F S Z=$O( ^DGCR(399, IBIFN,"CP" ,Z)) Q:'Z D I +ZE S IBER=IBE R_"IB320;" Q .. S Z0 =$G(^DGCR( 399,IBIFN, "CP",Z,0)) ,Z1=+Z0 I Z0'[";ICPT (" Q .. I '((Z1'<100 00)&(Z1'>6 9999))&'(( Z1'<93501) &(Z1'>9353 3)) Q .. I '$P(Z0,U, 7) S ZE=1 ; ; Extrac t procedur es for UB- 04 D F^IBC EF("N-UB-0 4 PROCEDUR ES","IBZPR CUB",,IBIF N) ; Does this bill have ANY p rescriptio ns associa ted with i t? ; Must bill presc riptions s eparately from other charges ; ; DEM;432 - Call li ne level p rovider ed it checks. D LNPROV^ IBCBB12(IB IFN) ; DEM ;432 - If there are line provi der edits, then rout ine LNPROV ^IBCBB12(I BIFN) upda tes IBER s tring. ; D EM;432 - C all to Oth er Operati ng/Operati ng Provide r edit che cks. I $$O PPROVCK^IB CBB12(IBIF N)=1 S IBE R=IBER_"IB 337;" ; D EM;432 ; D EM;432 - L ine level Attachment Control e dits. I $$ LNTMCK^IBC BB11(IBIFN )=1 S IBER =IBER_"IB3 31;" ; DE M;432 I $$ LNACCK^IBC BB11(IBIFN )=1 S IBER =IBER_"IB3 32;" ; DE M;432 ; I $$ISRX^IBC EF1(IBIFN) D . N IBZ ,IBRXDEF . S IBRXDEF =$P($G(^IB E(350.9,1, 1)),U,30), IBZ=0 . F S IBZ=$O( IBZPRCUB(I BZ)) Q:'IB Z I IBZPR CUB(IBZ),+ $P(IBZPRCU B(IBZ),U)' =IBRXDEF S IBER=IBER _"IB102;" Q . K IBZ ; ; Check that COB s equences a re not ski pped K Z F Z=1:1:3 S :+$G(^DGCR (399,IBIFN ,"I"_Z)) Z (Z)="" F Z =0:1:2 S Z 0=$O(Z(Z)) Q:'Z0 I Z0'=(Z+1) S IBER=IBE R_"IB322;" Q K Z ; H D64676 IB* 2*371 - OK for payer sequence to be blan k when the Rate ; Ty pe is eith er Interag ency or Sh aring Agre ement I $P ($G(^DGCR( 399,IBIFN, 0)),U,21)= "",$P($G(^ DGCR(399,I BIFN,0)),U ,7)'=4,$P( $G(^DGCR(3 99,IBIFN,0 )),U,7)'=9 S IBER=IB ER_"IB323; " K IBXDAT A D F^IBCE F("N-PROCE DURE CODIN G METHD",, ,IBIFN) ; Coding met hod should agree wit h types of procedure codes S I BOK=$S('$O (IBZPRC(0) )!(IBXDATA =""):1,1:0 ) I 'IBOK S IBOK=1,I BZ=0 F S IBZ=$O(IBZ PRC(IBZ)) Q:'IBZ I IBZPRC(IBZ ),$P(IBZPR C(IBZ),U)' [$S(IBXDAT A=9:"ICD", 1:"ICP") S IBOK=0 Q I 'IBOK D WARN^IBCBB 11("Coding Method do es not agr ee with al l procedur e codes fo und on bil l") D EDIT MRA^IBCBB3 (.IBQUIT,. IBER,IBIFN ,IBFT) Q:$ G(IBQUIT) ; ;Other t hings that could be added: Rev Code - ca lculating charges ; Diagnosis Coding, if MT copay - check fo r other co -payments ; I $P(IBN DTX,U,8),$ $REQMRA^IB EFUNC(IBIF N) S IBER= IBER_"IB12 1;" ; ca n't force MRAs to pr int I $P(I BNDTX,U,8) !$P(IBNDTX ,U,9) D . Q:$P(IBNDT X,U,8)=2 ; Don't wan t to do th is for opt ion 2 any more. . D WARN^IBCBB 11($S($$RE QMRA^IBEFU NC(IBIFN)& ($P(IBNDTX ,U,9)):"MR A Secondar y ",1:"")_ "Bill has been force d to print "_$S($P(I BNDTX,U,8) =1!($P(IBN DTX,U,9)=1 ):"locally ",1:"at cl earinghous e")) N IBX Z,IBIZ F I BIZ=12,13, 14 S IBXZ= $P(IBNDM,U ,IBIZ) I + IBXZ S IBX Z=$P($G(^D PT(DFN,.31 2,IBXZ,0)) ,U,18) I + IBXZ S IBX Z=$G(^IBA( 355.3,+IBX Z,0)) I +$ P(IBXZ,U,1 2) D . D W ARN^IBCBB1 1($P($G(^D IC(36,+IBX Z,0)),U,1) _" require s Amb Care Certifica tion") ; D VALNDC^IB CBB11(IBIF N,DFN) ;va lidate NDC # ; ;Build AR array if no erro rs and MRA not neede d or alrea dy rec'd I IBER="",$ S($$NEEDMR A^IBEFUNC( IBIFN)!($$ REQMRA^IBE FUNC(IBIFN )):0,1:1) D ARRAY ; ;Check ROI N ROIERR S ROIERR=0 I $P($G(^ DGCR(399,I BIFN,"U")) ,U,5)=1,+$ P($G(^DGCR (399,IBIFN ,"U")),U,7 )=0 S ROIE RR=1 ; scr een 7 sens itive reco rd and no ROI I $$RO ICHK^IBCBB 11(IBIFN,D FN,+IBNDMP ) S ROIERR =1 ; check file for sensitive Rx and mis sing ROI I ROIERR S IBER=IBER_ "IB328;" ; ;Verify L ine Charge s Match Cl aim Total Charge. IB *2.0*447 B I I +$$GET 1^DIQ(399, IBIFN_",", 201)'=+$$I BLNTOT^IBC BB13(IBIFN ) S IBER=I BER_"IB344 ;" ; ;Test for valid EIN/SY ID Values. I B*2.0*447 BI I $$IBS YEI^IBCBB1 3(IBIFN) S IBER=IBER _"IB345;" ; ;Test fo r a missin g ICN. IB* 2.0*447 BI I $$IBMIC N^IBCBB13( IBIFN) S I BER=IBER_" IB346;" ; ;Test for a ZERO cha rge amount s. IB*2.0* 447 BI I $ $IBRCCHK^I BCBB13(IBI FN) D WARN ^IBCBB11(" Claim cont ains reven ue codes w ith no ass ociated ch arges.") ; ;Test for missing " Patient re ason for v isit". IB* 2.0*447 BI I $$FT^IB CEF(IBIFN) =3,'$$INPA T^IBCEF(IB IFN),$$IBP RV3^IBCBB1 3(IBIFN) S IBER=IBER _"IB347;" ; ;Test fo r missing Payer ID. IB*2.0*447 BI ;I $$I BMPID^IBCB B13(IBIFN) S IBER=IB ER_"IB348; " ;Changed Error to Warning. I B*2.0*447 TAZ I $$IB MPID^IBCBB 13(IBIFN) D WARN^IBC BB11("Not all payers have Paye r IDs.") ; ;Test for missing " Priority ( Type) of A dmission" for UB-04. IB*2.0*44 7 BI I $$F T^IBCEF(IB IFN)=3,$$G ET1^DIQ(39 9,IBIFN_", ",158)="" S IBER=IBE R_"IB349;" ;END ;Don 't kill IB IFN, IBER, DFN I $O( ^TMP($J,"B ILL-WARN", 0)),$G(IBE R)="" S IB ER="WARN" ;Warnings only K IBB NO,IBEVDT, IBLOC,IBCL ,IBTF,IBAT ,IBWHO,IBS T,IBFDT,IB TDT,IBTC,I BFY,IBFY1, IBAU,IBRU, IBEU,IBART P,IBFYC,IB MRA,IBTOB, IBTOB12,IB NDU2,IBNDU F3,IBNDUF3 1,IBNDTX K IBNDS,IBN D0,IBNDU,I BNDM,IBNDM P,IBNDU1,I BFFY,IBTFY ,IBFT,IBRT CHV,IBPICH V,IBXDATA, IBOK I $D( IBER),IBER ="" W !,"N o Errors f ound for N ational ed its" Q ;AR RAY ;Build PRCASV(ar ray) N IBC OBN,X K PR CASV Q:$$M CRWNR^IBEF UNC(+$$CUR R^IBCEF2(I BIFN)) S I BCOBN=$$CO BN^IBCEF(I BIFN) S X= IBIFN S PR CASV("BDT" )=DT,PRCAS V("ARREC") =IBIFN S P RCASV("APR ")=DUZ S P RCASV("PAT ")=DFN,PRC ASV("CAT") =$P(^DGCR( 399.3,IBAT ,0),"^",6) I IBWHO=" i" S PRCAS V("DEBTOR" )=+IBNDMP_ ";DIC(36," S PRCASV( "DEBTOR")= $S(IBWHO=" p":DFN_";D PT(",IBWHO ="o":$P(IB NDM,"^",11 )_";DIC(4, ",IBWHO="i ":PRCASV(" DEBTOR"),1 :"") S PRC ASV("CARE" )=$E($$TOB ^IBCEF1(IB IFN),1,2) S PRCASV(" FY")=$$FY^ IBOUTL(DT) _U_($P(IBN DU1,U)-$P( IBNDU1,U,2 )) ;S PRCA SV("FY")=$ P(IBNDU1,U ,9)_U_$S($ P(IBNDU1,U ,2)]"":($P (IBNDU1,U, 10)-$P(IBN DU1,U,2)), 1:$P(IBNDU 1,U,10))_$ S($P(IBNDU 1,U,11)]"" :U_$P(IBND U1,U,11)_U _$P(IBNDU1 ,U,12),1:" ")PLUS I I BWHO="i",$ P(IBNDM,"^ ",2),$D(^D IC(36,$P(I BNDM,"^",2 ),0)) S PR CASV("2NDI NS")=$P(IB NDM,"^",2) I IBWHO=" i",$P(IBND M,"^",3),$ D(^DIC(36, $P(IBNDM," ^",3),0)) S PRCASV(" 3RDINS")=$ P(IBNDM,"^ ",3) ; N I BX S IBX=$ P(IBND0,U, 21),IBX=$S (IBX="P":" I1",IBX="S ":"I2",IBX ="T":"I3", 1:"") Q:IB X="" N IBN DI1 Q:'$D( ^DGCR(399, IBIFN,IBX) ) S IBNDI1 =^(IBX) S: $P(IBNDI1, "^",3)]"" PRCASV("GP NO")=$P(IB NDI1,"^",3 ) S:$P(IBN DI1,"^",15 )]"" PRCAS V("GPNM")= $P(IBNDI1, "^",15) S: $P(IBNDI1, "^",17)]"" PRCASV("I NPA")=$P(I BNDI1,"^", 17) S:$P(I BNDI1,"^", 2)]"" PRCA SV("IDNO") =$P(IBNDI1 ,"^",2),PR CASV("INID ")=PRCASV( "IDNO") ; Check that this is a secondary or tertia ry bill an d insuranc e for prev ious ; COB sequence is Medicar e WNR and MRA is act ive --> se nd data el ements to AR I IBCOB N>1,$$WNRB ILL^IBEFUN C(IBIFN,IB COBN-1),$$ EDIACTV^IB CEF4(2) D MRA Q ;MRA N IBEOB S IBEOB=0 ; K PRCASV( "MEDURE"), PRCASV("ME DCA") ; Ge t EOB data F S IBEO B=$O(^IBM( 361.1,"B", IBIFN,IBEO B)) Q:'IBE OB D . D MRACALC^IB CEMU2(IBEO B,IBIFN,1, .PRCASV) Q ;MRA ; ; ; PREGNANC Y DX CODES : V22**-V2 4**, V27** -V28**, 63 0**-677** ;; FLU SHO TS PROCEDU RE CODES: 90724, G00 08, 90732, G0009 | |
| 832 | Modified L ogic (Chan ges are in bold) | |
| 833 | IBCBB1 ;AL B/AAS - CO NTINUATION OF EDIT C HECK ROUTI NE ;2-NOV- 89 ;;2.0;I NTEGRATED BILLING;** 27,52,80,9 3,106,51,1 51,148,153 ,137,232,2 80,155,320 ,343,349,3 63,371,395 ,384,432,4 47,488,554 ,577,592** ;21-MAR-94 ;Build 1 ; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; ; *** Be gin IB*2.0 *488 VD (I ssue 46 RB N) N I S I ="" S X=+$ G(^DGCR(39 9,IBIFN,"M P")) I 'X, $$MCRWNR^I BEFUNC(+$$ CURR^IBCEF 2(IBIFN)) S X=+$$CUR R^IBCEF2(I BIFN) ;JWS ;IB*2.0*59 2:US1108 - Dental fo rm check I X,+$G(^DI C(36,X,3)) S I=$P(^( 3),U,$S($$ FT^IBCEF(I BIFN)=2:2, $$FT^IBCEF (IBIFN)=7: 2,1:4)) S I=$$UP^XLF STR(I) I ( I'=""&(I[" PRNT")&($G (IBER)'["I B488")) D . S IBER= $G(IBER)_" IB488;" ; ; Cause an error if FORCED TO PRINT TO C LEARINGHOU SE I $P($G (^DGCR(399 ,IBIFN,"TX ")),U,8)=2 D . S IBE R=$G(IBER) _"IB489;" ; ; Cause a fatal er ror if the claim has no proced ures & is NOT a UB-0 4 Inpatien t claim. I +$O(^DGCR (399,IBIFN ,"CP",0))= 0 D .I $$I NPAT^IBCEF (IBIFN,1), $$INSPRF^I BCEF(IBIFN ) Q ; in patient UB -04 check .I '$$INPA T^IBCEF(IB IFN,1),$$I NSPRF^IBCE F(IBIFN) D Q ; Outpatien t Institut ional Clai m. ..I IBE R["IB352" Q ..S IBER =IBER_"IB3 52;" .; .; Professio nal claim .I IBER["I B353" Q .S IBER=IBER _"IB353;" .Q ; *** E nd IB*2.0* 488 -- VD ; ;MAP TO DGCRBB1 ;% ;Bill Sta tus N Z,Z0 ,Z1,IBFT I $S(+IBST= 0:1,1:"^1^ 2^3^4^7^"' [(U_IBST_U )) S IBER= IBER_"IB04 5;" ; ;Sta tement Cov ers From I IBFDT="" S IBER=IBE R_"IB061;" I IBFDT]" ",IBFDT'?7 N&(IBFDT'? 7N1".".N) S IBER=IBE R_"IB061;" I IBFDT>I BTDT S IBE R=IBER_"IB 061;" ; fr om must be on or bef ore the to date S I BFFY=$$FY^ IBOUTL(IBF DT) ; if i npat - fro m date mus t not be p rior to ad mit date. I $$INPAT^ IBCEF(IBIF N,1),(IBFD T<($P($G(^ DGPT(+$P(I BND0,U,8), 0)),U,2)\1 )) S IBER= IBER_"IB06 1;" ; ;Sta tement Cov ers To I I BTDT="" S IBER=IBER_ "IB062;" I IBTDT]"", IBTDT'?7N& (IBTDT'?7N 1".".N) S IBER=IBER_ "IB062;" I IBTDT>DT! (IBTDT<IBF DT) S IBER =IBER_"IB0 62;" ; to date must not be >t han today' s date S I BTFY=$$FY^ IBOUTL(IBT DT) ; ;Tot al Charges ; IB*2.0* 447/TAZ Re moved this error so that zero dollar rev enue codes can proce ss on the 837 ;I +IB TC'>0!(+IB TC'=IBTC) S IBER=IBE R_"IB064;" ; ;Billab le charges for secon dary claim I $$MCRON BIL^IBEFUN C(IBIFN)&( ($P(IBNDU1 ,U,1)-$P(I BNDU1,U,2) )'>0) S IB ER=IBER_"I B094;" ;Fi scal Year 1 S IBFFY= $$FY^IBOUT L(IBFDT) ; ;Check pr ovider lin k for curr ent user, enterer, r eviewer an d Authoriz or I '$D(^ VA(200,DUZ ,0)) S IBE R=IBER_"IB 048;" I IB EU]"",'$D( ^VA(200,IB EU,0)) S I BER=IBER_" IB048;" I IBRU]"",'$ D(^VA(200, IBRU,0)) S IBER=IBER _"IB060;" I IBAU]"", '$D(^VA(20 0,IBAU,0)) S IBER=IB ER_"IB041; " ; I IBER ="",+$$STA ^PRCAFN(IB IFN)=104 S IBER=IBER _"IB040;" ; If ins b ill, must have valid COB seque nce I $P(I BND0,U,11) ="i",$S($P (IBND0,U,2 1)="":1,1: "PST"'[$P( IBND0,U,21 )) S IBER= IBER_"IB32 4;" ; ; Ch eck for va lid sec pr ovider id for curren t ins S Z= 0 F S Z=$ O(^DGCR(39 9,IBIFN,"P RV",Z)) Q: 'Z S Z0=$ G(^(Z,0)), Z1=+$$COBN ^IBCEF(IBI FN) I $P(Z 0,U,4+Z1)' ="",$P(Z0, U,11+Z1)'= "" D . I ' $$SECIDCK^ IBCEF74(IB IFN,Z1,$P( Z0,U,11+Z1 ),Z) D WAR N^IBCBB11( "Prov seco ndary id t ype for th e "_$P("PR IMARY^SECO NDARY^TERT IARY",U,Z1 )_" "_$$EX TERNAL^DIL FD(399.022 2,.01,,+Z0 )_" is inv alid/won't transmit" ) ; Check NPIs D NPI CHK^IBCBB1 1 ; ; Chec k multiple rx NPIs D RXNPI^IBC BB11(IBIFN ) ; ; Chec k taxonomi es D TAXCH K^IBCBB11 ; ; Check for Physic ian Name K IBXDATA D F^IBCEF(" N-ATT/REND PHYSICIAN NAME",,,I BIFN) ; IB *2.0*432 - CMS1500 n o longer n eeds a cla im level r endering S IBFT=$$FT ^IBCEF(IBI FN) ;JWS;I B*2.0*592: US1108 - D ental form check I I BFT'=2,IBF T'=7,$P($G (IBXDATA), U)="" S IB ER=IBER_"I B303;" ; N FUNCTION, IBINS ; IB *2.0*432 - CMS1500 n o longer n eeds a cla im level r endering ; S FUNCTION =$S($$FT^I BCEF(IBIFN )=3:4,1:3) S FUNCTIO N=$S(IBFT= 3:4,1:3) ; JWS;IB*2.0 *592:US110 8 - Dental form chec k I IBFT'= 2,IBFT'=7, IBER'["IB3 03;" D . F IBINS=1:1 :3 D .. S Z=$$GETTYP ^IBCEP2A(I BIFN,IBINS ) .. I Z,$ P(Z,U,2) D ; Render ing/attend ing prov s econdary i d required ... N IBI D,IBOK,Q0 ... D PROV INF^IBCEF7 4(IBIFN,IB INS,.IBID, 1,"C") ; c heck all a s though t hey were c urrent ... S IBOK=0 ... S Q0=0 F S Q0=$ O(IBID(1,F UNCTION,Q0 )) Q:'Q0 I $P(IBID( 1,FUNCTION ,Q0),U,9)= +Z S IBOK= 1 Q ... I 'IBOK S IB ER=IBER_$S (IBINS=1:" IB236;",IB INS=2:"IB2 37;",IBINS =3:"IB238; ",1:"") ; ; Patch 43 2 enh5:The IB system shall no longer pre vent users from auth orizing(fa tal error message)a claim beca use the sy stem canno t find the providers SSNorEIN ; D PRIIDCH K^IBCBB11 ; N IBM,IB M1 S IBM=$ G(^DGCR(39 9,IBIFN,"M ")) S IBM1 =$G(^DGCR( 399,IBIFN, "M1")) I $ P(IBM,U),$ P($G(^DIC( 36,$P(IBM, U),4)),U,6 ),$P(IBM1, U,2)="" S IBER=IBER_ "IB244;" I $P(IBM,U, 2),$P($G(^ DIC(36,$P( IBM,U,2),4 )),U,6),$P (IBM1,U,3) ="" S IBER =IBER_"IB2 45;" I $P( IBM,U,3),$ P($G(^DIC( 36,$P(IBM, U,3),4)),U ,6),$P(IBM 1,U,4)="" S IBER=IBE R_"IB246;" ; ; If ou tside faci lity, chec k for ID a nd qualifi er in 355. 93 ; 5/15/ 06 - esg - hard erro r IB243 tu rned into warning me ssage inst ead S Z=$P ($G(^DGCR( 399,IBIFN, "U2")),U,1 0) I Z D . I $P($G(^ IBA(355.93 ,Z,0)),U,9 )=""!($P($ G(^IBA(355 .93,Z,0)), U,13)="") D .. N Z1, Z2 .. S Z1 ="Missing Lab or Fac ility Prim ary ID for non-VA fa cility, " .. S Z2=$$ EXTERNAL^D ILFD(399,2 32,,Z) .. I $L(Z2)'> 19 D WARN^ IBCBB11(Z1 _Z2) Q .. D WARN^IBC BB11(Z1),W ARN^IBCBB1 1(" "_Z2) .. Q . Q ; ; Must be one and o nly one di vision on bill S IBZ =$$MULTDIV ^IBCBB11(I BIFN,IBND0 ) ; I IBZ S IBER=IBE R_$S(IBZ=1 :"IB095;", IBZ=2:"IB1 04;",1:"IB 105;") ; A llow multi -divisiona l for OP i nstutional claims I IBZ,$$INPA T^IBCEF(IB IFN)!'($$I NSPRF^IBCE F(IBIFN)) S IBER=IBE R_$S(IBZ=1 :"IB095;", IBZ=2:"IB1 04;",1:"IB 105;") ; S till need error msg on OP Inst itutional if No Defa ult divisi on I IBZ=3 ,'$$INPAT^ IBCEF(IBIF N),$$INSPR F^IBCEF(IB IFN) S IBE R=IBER_"IB 105;" ; Di vision add ress must be defined in instit ution file I $P(IBND 0,U,22) D . N Z,Z0,Z 1 . S Z0=$ G(^DIC(4,+ $P($G(^DG( 40.8,+$P(I BND0,U,22) ,0)),U,7), 0)) . S Z1 =$G(^DIC(4 ,+$P($G(^D G(40.8,+$P (IBND0,U,2 2),0)),U,7 ),1)) . I $P(Z0,U,2) ="" S IBER =IBER_"IB0 97;" Q . F Z=1,3,4 I $P(Z1,U,Z )="" S IBE R=IBER_"IB 097;" Q ; ; IB*2.0*4 32 Check a mbulance a ddresses, COB Non-co vered amt. & Attachm ent Contro l I $$AMBC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB329;" I $$COBAMT ^IBCBB11(I BIFN)=1 S IBER=IBER_ "IB330;" I $$TMCK^IB CBB11(IBIF N)=1 S IBE R=IBER_"IB 331;" I $$ ACCK^IBCBB 11(IBIFN)= 1 S IBER=I BER_"IB332 ;" I $$COB MRA^IBCBB1 1(IBIFN)=1 S IBER=IB ER_"IB342; " I $$COBS EC^IBCBB11 (IBIFN)=1 S IBER=IBE R_"IB343;" ; ;CHAMPV A Rate Typ e and Prim ary Insura nce Carrie rs Type of Coverage must match S (IBRTCH V,IBPICHV) =0 I $P($G (^DGCR(399 .3,+IBAT,0 )),U,1)="C HAMPVA" S IBRTCHV=1 I $P($G(^I BE(355.2,+ $P($G(^DIC (36,+IBNDM P,0)),U,13 ),0)),U,1) ="CHAMPVA" S IBPICHV =1 I (+IBR TCHV!+IBPI CHV)&('IBR TCHV!'IBPI CHV) S IBE R=IBER_"IB 085;" ; ;N on-VA bill must use FEE REIMB INS rate t ype; FEE R EIMB INS r ate type c an only be used for Non-VA bil l ;IB*2.0* 554/DRF 10 /9/2015 ;N IBNVART,I BNVAST ;S (IBNVART,I BNVAST)=0 ;I $P($G(^ DGCR(399.3 ,+IBAT,0)) ,U,1)="FEE REIMB INS " S IBNVAR T=1 ;S IBN VAST=$$NON VAFLG(IBIF N) ;I IBNV ART,'IBNVA ST S IBER= IBER_"IB36 0;" ;Non-V A rate typ e used for bill that is not No n-VA ;I 'I BNVART,IBN VAST S IBE R=IBER_"IB 361;" ;Non -VA rate t ype not us ed for bil l that is Non-VA ; N IBZPRC,IB ZPRCUB D F ^IBCEF("N- ALL PROCED URES","IBZ PRC",,IBIF N) ; Proce dure Clini c is requi red for Su rgical Pro cedures Ou tpt Facili ty Charges I +$P(IBN D0,U,27)'= 2,$$BILLRA TE^IBCRU3( IBAT,IBCL, IBEVDT,"RC OUTPATIEN T") D . N Z,Z0,Z1,ZE S (ZE,Z)= 0 F S Z=$ O(^DGCR(39 9,IBIFN,"C P",Z)) Q:' Z D I +Z E S IBER=I BER_"IB320 ;" Q .. S Z0=$G(^DGC R(399,IBIF N,"CP",Z,0 )),Z1=+Z0 I Z0'[";IC PT(" Q .. I '((Z1'<1 0000)&(Z1' >69999))&' ((Z1'<9350 1)&(Z1'>93 533)) Q .. I '$P(Z0, U,7) S ZE= 1 ; ; Extr act proced ures for U B-04 D F^I BCEF("N-UB -04 PROCED URES","IBZ PRCUB",,IB IFN) ; Doe s this bil l have ANY prescript ions assoc iated with it? ; Mus t bill pre scriptions separatel y from oth er charges ; ; DEM;4 32 - Call line level provider edit check s. D LNPRO V^IBCBB12( IBIFN) ; D EM;432 - I f there ar e line pro vider edit s, then ro utine LNPR OV^IBCBB12 (IBIFN) up dates IBER string. ; DEM;432 - Call to O ther Opera ting/Opera ting Provi der edit c hecks. I $ $OPPROVCK^ IBCBB12(IB IFN)=1 S I BER=IBER_" IB337;" ; DEM;432 ; DEM;432 - Line leve l Attachme nt Control edits. I $$LNTMCK^I BCBB11(IBI FN)=1 S IB ER=IBER_"I B331;" ; DEM;432 I $$LNACCK^I BCBB11(IBI FN)=1 S IB ER=IBER_"I B332;" ; DEM;432 ; ; vd/Begin ning of IB *2*577 - V alidate Li ne Level N DC edits. I $$LNNDCC K^IBCBB11( IBIFN)=1 S IBER=IBER _"IB360;" ;IB*2*577 ; vd/End of IB*2*57 7 I $$ISRX ^IBCEF1(IB IFN) D . N IBZ,IBRXD EF . S IBR XDEF=$P($G (^IBE(350. 9,1,1)),U, 30),IBZ=0 . F S IBZ =$O(IBZPRC UB(IBZ)) Q :'IBZ I I BZPRCUB(IB Z),+$P(IBZ PRCUB(IBZ) ,U)'=IBRXD EF S IBER= IBER_"IB10 2;" Q . K IBZ ; ; Ch eck that C OB sequenc es are not skipped K Z F Z=1:1 :3 S:+$G(^ DGCR(399,I BIFN,"I"_Z )) Z(Z)="" F Z=0:1:2 S Z0=$O(Z (Z)) Q:'Z0 I Z0'=(Z +1) S IBER =IBER_"IB3 22;" Q K Z ; HD64676 IB*2*371 - OK for p ayer seque nce to be blank when the Rate ; Type is either Int eragency o r Sharing Agreement I $P($G(^D GCR(399,IB IFN,0)),U, 21)="",$P( $G(^DGCR(3 99,IBIFN,0 )),U,7)'=4 ,$P($G(^DG CR(399,IBI FN,0)),U,7 )'=9 S IBE R=IBER_"IB 323;" K IB XDATA D F^ IBCEF("N-P ROCEDURE C ODING METH D",,,IBIFN ) ; Coding method sh ould agree with type s of proce dure codes S IBOK=$S ('$O(IBZPR C(0))!(IBX DATA=""):1 ,1:0) I 'I BOK S IBOK =1,IBZ=0 F S IBZ=$O (IBZPRC(IB Z)) Q:'IBZ I IBZPRC (IBZ),$P(I BZPRC(IBZ) ,U)'[$S(IB XDATA=9:"I CD",1:"ICP ") S IBOK= 0 Q I 'IBO K D WARN^I BCBB11("Co ding Metho d does not agree wit h all proc edure code s found on bill") D EDITMRA^IB CBB3(.IBQU IT,.IBER,I BIFN,IBFT) Q:$G(IBQU IT) ; ;Oth er things that could be added: Rev Code - calculat ing charge s ; Diagno sis Coding , if MT co pay - chec k for othe r co-payme nts ; I $P (IBNDTX,U, 8),$$REQMR A^IBEFUNC( IBIFN) S I BER=IBER_" IB121;" ; can't fo rce MRAs t o print I $P(IBNDTX, U,8)!$P(IB NDTX,U,9) D . Q:$P(I BNDTX,U,8) =2 ; Don't want to d o this for option 2 any more. . D WARN^I BCBB11($S( $$REQMRA^I BEFUNC(IBI FN)&($P(IB NDTX,U,9)) :"MRA Seco ndary ",1: "")_"Bill has been f orced to p rint "_$S( $P(IBNDTX, U,8)=1!($P (IBNDTX,U, 9)=1):"loc ally",1:"a t clearing house")) N IBXZ,IBIZ F IBIZ=12 ,13,14 S I BXZ=$P(IBN DM,U,IBIZ) I +IBXZ S IBXZ=$P($ G(^DPT(DFN ,.312,IBXZ ,0)),U,18) I +IBXZ S IBXZ=$G(^ IBA(355.3, +IBXZ,0)) I +$P(IBXZ ,U,12) D . D WARN^IB CBB11($P($ G(^DIC(36, +IBXZ,0)), U,1)_" req uires Amb Care Certi fication") ; D VALND C^IBCBB11( IBIFN,DFN) ;validate NDC# ; ;B uild AR ar ray if no errors and MRA not n eeded or a lready rec 'd I IBER= "",$S($$NE EDMRA^IBEF UNC(IBIFN) !($$REQMRA ^IBEFUNC(I BIFN)):0,1 :1) D ARRA Y ; ;Check ROI N ROI ERR S ROIE RR=0 I $P( $G(^DGCR(3 99,IBIFN," U")),U,5)= 1,+$P($G(^ DGCR(399,I BIFN,"U")) ,U,7)=0 S ROIERR=1 ; screen 7 sensitive record and no ROI I $$ROICHK^I BCBB11(IBI FN,DFN,+IB NDMP) S RO IERR=1 ; c heck file for sensit ive Rx and missing R OI I ROIER R S IBER=I BER_"IB328 ;" ; ;Veri fy Line Ch arges Matc h Claim To tal Charge . IB*2.0*4 47 BI I +$ $GET1^DIQ( 399,IBIFN_ ",",201)'= +$$IBLNTOT ^IBCBB13(I BIFN) S IB ER=IBER_"I B344;" ; ; Test for v alid EIN/S Y ID Value s. IB*2.0* 447 BI I $ $IBSYEI^IB CBB13(IBIF N) S IBER= IBER_"IB34 5;" ; ;Tes t for a mi ssing ICN. IB*2.0*44 7 BI I $$I BMICN^IBCB B13(IBIFN) S IBER=IB ER_"IB346; " ; ;Test for a ZERO charge am ounts. IB* 2.0*447 BI I $$IBRCC HK^IBCBB13 (IBIFN) D WARN^IBCBB 11("Claim contains r evenue cod es with no associate d charges. ") ; ;Test for missi ng "Patien t reason f or visit". IB*2.0*44 7 BI I $$F T^IBCEF(IB IFN)=3,'$$ INPAT^IBCE F(IBIFN),$ $IBPRV3^IB CBB13(IBIF N) S IBER= IBER_"IB34 7;" ; ;Tes t for miss ing Payer ID. IB*2.0 *447 BI ;I $$IBMPID^ IBCBB13(IB IFN) S IBE R=IBER_"IB 348;" ;Cha nged Error to Warnin g. IB*2.0* 447 TAZ I $$IBMPID^I BCBB13(IBI FN) D WARN ^IBCBB11(" Not all pa yers have Payer IDs. ") ; ;Test for missi ng "Priori ty (Type) of Admissi on" for UB -04. IB*2. 0*447 BI I $$FT^IBCE F(IBIFN)=3 ,$$GET1^DI Q(399,IBIF N_",",158) ="" S IBER =IBER_"IB3 49;" ;END ;Don't kil l IBIFN, I BER, DFN I $O(^TMP($ J,"BILL-WA RN",0)),$G (IBER)="" S IBER="WA RN" ;Warni ngs only K IBBNO,IBE VDT,IBLOC, IBCL,IBTF, IBAT,IBWHO ,IBST,IBFD T,IBTDT,IB TC,IBFY,IB FY1,IBAU,I BRU,IBEU,I BARTP,IBFY C,IBMRA,IB TOB,IBTOB1 2,IBNDU2,I BNDUF3,IBN DUF31,IBND TX K IBNDS ,IBND0,IBN DU,IBNDM,I BNDMP,IBND U1,IBFFY,I BTFY,IBFT, IBRTCHV,IB PICHV,IBXD ATA,IBOK I $D(IBER), IBER="" W !,"No Erro rs found f or Nationa l edits" Q ;ARRAY ;B uild PRCAS V(array) N IBCOBN,X K PRCASV Q :$$MCRWNR^ IBEFUNC(+$ $CURR^IBCE F2(IBIFN)) S IBCOBN= $$COBN^IBC EF(IBIFN) S X=IBIFN S PRCASV(" BDT")=DT,P RCASV("ARR EC")=IBIFN S PRCASV( "APR")=DUZ S PRCASV( "PAT")=DFN ,PRCASV("C AT")=$P(^D GCR(399.3, IBAT,0),"^ ",6) I IBW HO="i" S P RCASV("DEB TOR")=+IBN DMP_";DIC( 36," S PRC ASV("DEBTO R")=$S(IBW HO="p":DFN _";DPT(",I BWHO="o":$ P(IBNDM,"^ ",11)_";DI C(4,",IBWH O="i":PRCA SV("DEBTOR "),1:"") S PRCASV("C ARE")=$E($ $TOB^IBCEF 1(IBIFN),1 ,2) S PRCA SV("FY")=$ $FY^IBOUTL (DT)_U_($P (IBNDU1,U) -$P(IBNDU1 ,U,2)) ;S PRCASV("FY ")=$P(IBND U1,U,9)_U_ $S($P(IBND U1,U,2)]"" :($P(IBNDU 1,U,10)-$P (IBNDU1,U, 2)),1:$P(I BNDU1,U,10 ))_$S($P(I BNDU1,U,11 )]"":U_$P( IBNDU1,U,1 1)_U_$P(IB NDU1,U,12) ,1:"")PLUS I IBWHO=" i",$P(IBND M,"^",2),$ D(^DIC(36, $P(IBNDM," ^",2),0)) S PRCASV(" 2NDINS")=$ P(IBNDM,"^ ",2) I IBW HO="i",$P( IBNDM,"^", 3),$D(^DIC (36,$P(IBN DM,"^",3), 0)) S PRCA SV("3RDINS ")=$P(IBND M,"^",3) ; N IBX S I BX=$P(IBND 0,U,21),IB X=$S(IBX=" P":"I1",IB X="S":"I2" ,IBX="T":" I3",1:"") Q:IBX="" N IBNDI1 Q: '$D(^DGCR( 399,IBIFN, IBX)) S IB NDI1=^(IBX ) S:$P(IBN DI1,"^",3) ]"" PRCASV ("GPNO")=$ P(IBNDI1," ^",3) S:$P (IBNDI1,"^ ",15)]"" P RCASV("GPN M")=$P(IBN DI1,"^",15 ) S:$P(IBN DI1,"^",17 )]"" PRCAS V("INPA")= $P(IBNDI1, "^",17) S: $P(IBNDI1, "^",2)]"" PRCASV("ID NO")=$P(IB NDI1,"^",2 ),PRCASV(" INID")=PRC ASV("IDNO" ) ; Check that this is a secon dary or te rtiary bil l and insu rance for previous ; COB seque nce is Med icare WNR and MRA is active -- > send dat a elements to AR I I BCOBN>1,$$ WNRBILL^IB EFUNC(IBIF N,IBCOBN-1 ),$$EDIACT V^IBCEF4(2 ) D MRA Q ;MRA N IBE OB S IBEOB =0 ; K PRC ASV("MEDUR E"),PRCASV ("MEDCA") ; Get EOB data F S IBEOB=$O(^ IBM(361.1, "B",IBIFN, IBEOB)) Q: 'IBEOB D . D MRACAL C^IBCEMU2( IBEOB,IBIF N,1,.PRCAS V) Q ;MRA ; ;; PREG NANCY DX C ODES: V22* *-V24**, V 27**-V28** , 630**-67 7** ;; FLU SHOTS PRO CEDURE COD ES: 90724, G0008, 90 732, G0009 ;NONVAFLG (IBIFN) ; Check if N on-VA bill ; Functio n returns 1 if Non-V A bill ; I B*2.0*554/ DRF 10/9/2 015 N FLAG ,PTF S FLA G=0 I $P($ G(^DGCR(39 9,IBIFN,"U 2")),U,10) ]"" S FLAG =1 ;Non-VA provider defined S PTF=$P($G( ^DGCR(399, IBIFN,0)), U,8) I PTF ,$P($G(^DG PT(PTF,0)) ,U,4)=1 S FLAG=1 ;PT F entry in dicates No n-VA Q FLA G | |
| 834 | ||
| 835 | ||
| 836 | Routines | |
| 837 | Activities | |
| 838 | Routine Na me | |
| 839 | IBCBB11 | |
| 840 | Enhancemen t Category | |
| 841 | New | |
| 842 | Modify | |
| 843 | Delete | |
| 844 | No Change | |
| 845 | RTM | |
| 846 | ||
| 847 | Related Op tions | |
| 848 | None | |
| 849 | Related Ro utines | |
| 850 | Routines “ Called By” | |
| 851 | Routines “ Called” | |
| 852 | ||
| 853 | ||
| 854 | ||
| 855 | ||
| 856 | Data Dicti onary (DD) Reference s | |
| 857 | CLAIMS TRA CKING File [#356] | |
| 858 | Related Pr otocols | |
| 859 | None | |
| 860 | Related In tegration Control Re gistration s (ICRs) | |
| 861 | None | |
| 862 | Data Passi ng | |
| 863 | Input | |
| 864 | Output Re ference | |
| 865 | Both | |
| 866 | Global Re ference | |
| 867 | Local | |
| 868 | Input Attr ibute Name and Defin ition | |
| 869 | Name: | |
| 870 | Definition : | |
| 871 | Output Att ribute Nam e and Defi nition | |
| 872 | Name: | |
| 873 | Definition : | |
| 874 | Current Lo gic | |
| 875 | IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3 :45 PM ;;2 .0;INTEGRA TED BILLIN G;**51,343 ,363,371,3 95,392,401 ,384,400,4 36,432,516 ,550,577,5 92**;21-MA R-94;Build 1 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ;WARN (IBDISP) ; Set warni ng in glob al ; DISP = warning text to di splay ; N Z S Z=+$O( ^TMP($J,"B ILL-WARN", ""),-1) I Z=0 S ^TMP ($J,"BILL- WARN",1)=$ J("",5)_"* *Warnings* *:",Z=1 S Z=Z+1,^TMP ($J,"BILL- WARN",Z)=$ J("",5)_IB DISP Q ;MU LTDIV(IBIF N,IBND0) ; Check for multiple divisions on a bill ien IBIFN ; IBND0 = 0-node of bill ; ; F unction re turns 1 if more than 1 divisio n found on bill N Z, Z0,Z1,MULT S MULT=0, Z1=$P(IBND 0,U,22) I Z1 D . S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," RC",Z)) Q: 'Z S Z0=$ P(^(Z,0),U ,7) I Z0,Z 0'=Z1 S MU LT=1 Q . S Z=0 F S Z=$O(^DGCR (399,IBIFN ,"CP",Z)) Q:'Z S Z0 =$P(^(Z,0) ,U,6) I Z0 ,Z0'=Z1 S MULT=2 Q I 'Z1 S MUL T=3 Q MULT ; ;; PREG NANCY DX C ODES: V22* *-V24**, V 27**-V28** , 630**-67 7** ;; FLU SHOTS PRO CEDURE COD ES: 90724, G0008, 90 732, G0009 ;NPICHK ; Check for required NPIs N IBN PIS,IBNONP I,IBNPIREQ ,Z,IBNFI,I BTF,IBWC,I BXSAVE,IBP RV,IBLINE ;*** pij s tart IB*20 *436 *** N IBRATYPE, IBLEGAL S (IBRATYPE, IBLEGAL)=" " S IBRATY PE=$P($G(^ DGCR(399,I BIFN,0)),U ,7) ; Lega l types fo r this use . ; 7=NO F AULT INS. ; 10=TORT FEASOR ; 1 1=WORKERS' COMP. S I BNFI=$O(^D GCR(399.3, "B","NO FA ULT INS.", 0)) S:'IBN FI IBNFI=7 S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10 S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11 ; I IB RATYPE=IBN FI!(IBRATY PE=IBTF)!( IBRATYPE=I BWC) D . ; One of th e legal ty pes - forc e local pr int . S IB LEGAL=1 ;* ** pij end *** S IBN PIREQ=$$NP IREQ^IBCEP 81(DT) ; C heck if NP I is requi red ; Chec k provider s ; IB*2.0 *432 chang ed the NPI check to the new Pr ovider Arr ay ;S IBNP IS=$$PROVN PI^IBCEF73 A(IBIFN,.I BNONPI) D ALLIDS^IBC EFP(IBIFN, .IBXSAVE,1 ) S IBPRV= "" F S IB PRV=$O(IBX SAVE("PROV INF",IBIFN ,"C",1,IBP RV)) Q:'IB PRV D . I $P($G(IBX SAVE("PROV INF",IBIFN ,"C",1,IBP RV,0)),U,4 )="" S IBN ONPI(IBPRV )="" S IBL INE="" F S IBLINE=$ O(IBXSAVE( "L-PROV",I BIFN,IBLIN E)) Q:'IBL INE D . S IBPRV="" . F S IBP RV=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE,"C", 1,IBPRV)) Q:IBPRV="" D .. I $ P($G(IBXSA VE("L-PROV ",IBIFN,IB LINE,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)="" I $D(IBNONP I) S IBPRV ="" F S I BPRV=$O(IB NONPI(IBPR V)) Q:'IBP RV D . ;J WS;IB*2.0* 592;Assist ant Surgeo n for dent al . I IBP RV=6 S IBE R=IBER_"IB 358;" Q . S IBER=IBE R_"IB"_(14 0+IBPRV)_" ;" Q ; If required, set error IB*2*516 ; Check or ganization s S IBNONP I="" S IBN PIS=$$ORGN PI^IBCEF73 A(IBIFN,.I BNONPI) I $L(IBNONPI ) F Z=1:1: $L(IBNONPI ,U) D . S IBER=IBER_ $P("IB339; ^IB340;^IB 341;",U,$P (IBNONPI,U ,Z)) ; DEM ;432 Added NPI error s. Q ;TAXC HK ; Check for requi red taxono mies N IBD T,IBLINE,I BNOTAX,IBP RV,IBTAXS, IBXSAVE,Z ; ; MRD;IB *2.0*516 - This chec k is now m oot; 'toda y' is alwa ys on or ; after May 23, 2008, so taxono my codes a re always required ; for certa in provide rs. ;S IBT AXREQ=$$TA XREQ^IBCEP 81(DT) ; C heck if ta xonomy is required ; ; Check p roviders ; IB*2.0*43 2 changed the Taxono my check t o the new Provider A rray ;S IB TAXS=$$PRO VTAX^IBCEF 73A(IBIFN, .IBNOTAX) D ALLIDS^I BCEFP(IBIF N,.IBXSAVE ,1) S IBPR V="" F S IBPRV=$O(I BXSAVE("PR OVINF",IBI FN,"C",1,I BPRV)) Q:' IBPRV D . I $G(IBXS AVE("PROVI NF",IBIFN, "C",1,IBPR V,"TAXONOM Y"))="" S IBNOTAX(IB PRV)="" . Q ; S IBLI NE="" F S IBLINE=$O (IBXSAVE(" L-PROV",IB IFN,IBLINE )) Q:'IBLI NE D . S IBPRV="" . F S IBPR V=$O(IBXSA VE("L-PROV ",IBIFN,IB LINE,"C",1 ,IBPRV)) Q :IBPRV="" D . . I $ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,"TAXON OMY"))="" S IBNOTAX( IBPRV)="" . . Q . Q ; ; IB251 = Referrin g provider taxonomy missing. ; IB253 = R endering p rovider ta xonomy mis sing. ; IB 254 = Atte nding prov ider taxon omy missin g. ; IB256 = Assista nt Surgeon taxonomy missing. ; JWS;IB*2.0 *592 ;JWS; IB*2.0*592 ;dental st art I $D(I BNOTAX) S IBPRV="" F S IBPRV= $O(IBNOTAX (IBPRV)) Q :'IBPRV D . ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer . ; I IBTAXREQ ,"134"[IBP RV S IBER= IBER_"IB"_ (250+IBPRV )_";" Q ; MRD;IB*2.0 *516 - Alw ays requir ed. . I "1 346"[IBPRV S IBER=IB ER_"IB"_(2 50+IBPRV)_ ";" Q ; I f required , set erro r and quit . D WARN( "Taxonomy for the "_ $P("referr ing^operat ing^render ing^attend ing^superv ising^assi stant surg eon^^^othe r",U,IBPRV )_$S(IBPRV =6:"",1:" provider") _" has no value") ; Else, set warning . Q ;JWS;IB* 2.0*592;en d ; ; Chec k organiza tions. The function ORGTAX wil l set IBNO TAX to be a ; list o f entities missing t axonomy co des, if an y (n, n^m, n^m^p, ; where each 1 is serv ice facili ty, 2 is n on-VA serv ice facili ty and ; 3 is billin g provider . ; S IBNO TAX="" S I BTAXS=$$OR GTAX^IBCEF 73A(IBIFN, .IBNOTAX) I $L(IBNOT AX) F Z=1: 1:$L(IBNOT AX,U) D . ; IB167 = Billing Pr ovider tax onomy miss ing. . ;I IBTAXREQ,$ P(IBNOTAX, U,Z)=3 S I BER=IBER_" IB167;" Q ; MRD;IB*2 .0*516 - A lways requ ired. . I $P(IBNOTAX ,U,Z)=3 S IBER=IBER_ "IB167;" Q . ; MRD;I B*2.0*516 - Remove w arning mes sage for m issing tax onomy code for lab o r facility . . ; D WA RN("Taxono my for the "_$P("Ser vice Facil ity^Non-VA Service F acility^Bi lling Prov ider",U,$P (IBNOTAX,U ,Z))_" has no value" ) ; Else, set warnin g . Q ; Q ;VALNDC(IB IFN,IBDFN) ; IB*2*36 3 - valida te NDC# be tween PRES CRIPTION f ile (#52) ; and IB B ILL/CLAIMS PRESCRIPT ION REFILL file (#36 2.4) ; inp ut - IBIFN = interna l entry nu mber of th e billing record in the BILL/C LAIMS file (#399) ; IBDFN = in ternal ent ry number of patient record in the PATIE NT file (# 2) N IBX,I BRXCOL ; c all progra m that det ermines if NDC diffe rences exi st D VALND C^IBEFUNC3 (IBIFN,IBD FN,.IBRXCO L) Q:'$D(I BRXCOL) ; at least o ne RX on t he IB reco rd has an NDC discre pancy S I BX=0 F S IBX=$O(IBR XCOL(IBX)) Q:'IBX D WARN("NDC # on Bill does not e qual the N DC# on Rx "_IBRXCOL( IBX)) Q ;P RIIDCHK ; Check for required P imarary ID (SSN/EIN) ; If the provider i s on the c laim, he m ust have o ne ; N IB I,IBZ I $$ TXMT^IBCEF 4(IBIFN) D . D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN) . S IBI="" F S IBI=$O(^ DGCR(399,I BIFN,"PRV" ,"B",IBI)) Q:IBI="" D .. I $P (IBZ,U,IBI )="" S IBE R=IBER_$S( IBI=1:"IB1 51;",IBI=2 :"IB152;", IBI=3!(IBI =4):"IB321 ;",IBI=5:" IB153;",IB I=9:"IB154 ;",1:"") Q ;RXNPI(IB IFN) ; che ck for mul tiple phar macy npi's on the sa me bill N IBORG,IBRX NPI,IBX,IB Y S IBORG= $$RXSITE^I BCEF73A(IB IFN,.IBORG ) S IBX=0 F S IBX=$ O(IBORG(IB X)) Q:'IBX S IBY=0 F S IBY=$ O(IBORG(IB X,IBY)) Q: 'IBY S IB RXNPI(+IBO RG(IBX,IBY ))="" S (I BX,IBY)=0 F S IBX=$ O(IBRXNPI( IBX)) Q:'I BX S IBY= IBY+1 I IB Y>1 D WARN ("Bill has prescript ions resul ting from "_IBY_" di fferent NP I location s") Q ;ROI CHK(IBIFN, IBDFN,IBIN S) ; IB*2. 0*384 - ch eck prescr iptions th at contain the ; SEN SITIVE DIA GNOSIS DRU G field #8 7 in the D RUG File # 50 set to 1 against ; the Clai ms Trackin g ROI file (#356.25) to see if an ROI is on file ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; IBDFN = IEN of t he patient ; IBINS = IEN of th e payer in surance co mpany (#36 ) ; OUTPUT - 0 = no error ; 1 = a presc ription is sensitive and there is no ROI on file ; N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ S R OIQ=0 S IB X=0 F S I BX=$O(^IBA (362.4,"C" ,IBIFN,IBX )) Q:'IBX D .S IBY0 =^IBA(362. 4,IBX,0),I BRXIEN=$P( IBY0,U,5) I 'IBRXIEN Q .S IBDT =$P(IBY0,U ,3),IBDRUG =$P(IBY0,U ,4) .D ZER O^IBRXUTL( IBDRUG) .I $$SENS^IB NCPDR(IBDR UG) D ; S ensitive D iagnosis D rug - chec k for ROI .. I $$ROI ^IBNCPDR4( IBDFN,IBDR UG,IBINS,I BDT) Q ;R OI is on f ile .. D W ARN("ROI n ot on file for presc ription "_ $$RXAPI1^I BNCPUT1(IB RXIEN,.01, "E")) .. S ROIQ=1ROI CHKQ ; K ^ TMP($J,"IB DRUG") Q R OIQ ;AMBCK (IBIFN) ; IB*2.0*432 - if ambu lance loca tion defin ed, addres s must be defined ; if there i s anything entered i n any of t he address fields (e ither p/up or drop/o ff fields) , than the re needs t o be: ; A ddress 1, State and ZIP unless the State is not a US state o r possessi on, then z ip code is not neede d (CMS1500 only) ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - 0 = no er ror ; 1 = Error ; N IBPAMB,IB DAMB,IBAMB R,IBCK S I BAMBR=0 Q: $$INSPRF^I BCEF(IBIFN )'=0 IBAMB R S IBPAMB =$G(^DGCR( 399,IBIFN, "U5")),IBD AMB=$G(^DG CR(399,IBI FN,"U6")) S IBCK(5)= $$NOPUNCT^ IBCEF($P(I BPAMB,U,2, 6),1),IBCK (6)=$$NOPU NCT^IBCEF( $P(IBDAMB, U,1,6),1) I IBCK(5)= "",IBCK(6) ="" Q IBAM BR ; at th is point w e know tha t at least one ambul ance field has data, so check to see if all have d ata I IBCK (5)'="" F I=2,4,5 I $P(IBPAMB, U,I)="" S IBAMBR=1 I IBCK(6)'= "" F I=1,2 ,4,5 I $P( IBDAMB,U,I )="" S IBA MBR=1 Q:IB AMBR=1 IBA MBR ; now check zip code. OK t o be null if state i s not a US Posession F I="IBPA MB","IBDAM B" I $P(I, U,5)'="",$ P($G(^DIC( 5,$P(I,U,5 ),0)),U,6) =1,$P(I,U, 6)="" S IB AMBR=1 Q I BAMBR ;COB AMT(IBIFN) ; IB*2.0* 432 - IF t here is a COB amt. i t must equ al the Tot al Claim C harge Amou nt ; input - IBIFN = IEN of th e Bill/Cla ims file ( #399) ; OU TPUT - 0 = no error ; 1 = Err or ; Q:IBI FN="" 0 Q: $P($G(^DGC R(399,IBIF N,"U4")),U )="" 0 Q:+ $P($G(^DGC R(399,IBIF N,"U1")),U )'=+$P($G( ^DGCR(399, IBIFN,"U4" )),U) 1 Q 0 ;COBMRA( IBIFN) ; I B*2.0*432 - If there is a 'COB total non -covered a mount' (Fi le#399, Fi eld#260), ; Primary Insurance must be M edicare th at never w ent to Med icare, and this must be a 2nda ry or tert iary claim ; input - IBIFN = I EN of the Bill/Claim s file (#3 99) ; OUTP UT - 0 = n o error ; 1 = Error ; N IBP Q :IBIFN="" 0 Q:$P($G( ^DGCR(399, IBIFN,"U4" )),U)="" 0 S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN I $$WNRBIL L^IBEFUNC( IBIFN,1),$ P($G(^DGCR (399,IBP," S")),U,7)= "",$$COBN^ IBCEF(IBIF N)>1 Q 0 Q 1 ;COBSEC (IBIFN) ; IB*2.0*432 - If ther e is NOT a 'COB tota l non-cove red amount ' (File#39 9, Field#2 60), ; an d Primary Insurance is Medicar e that nev er went to Medicare, 2ndary or tertiary claim cann ot be set to transmi t ; input - IBIFN = IEN of the Bill/Clai ms file (# 399) ; OUT PUT - 0 = no error ; 1 = Erro r ; N IBP Q:IBIFN="" 0 Q:$P($G (^DGCR(399 ,IBIFN,"U4 ")),U)'="" 0 Q:$$COB N^IBCEF(IB IFN)<2 0 S IBP=$P($G (^DGCR(399 ,IBIFN,"M1 ")),U,5) S :IBP="" IB P=IBIFN I $$WNRBILL^ IBEFUNC(IB IFN,1),$P( $G(^DGCR(3 99,IBP,"S" )),U,7)="" ,$P($G(^DG CR(399,IBI FN,"TX")), U,8)'=1 Q 1 Q 0 ;TMC K(IBIFN) ; IB*2.0*43 2 - Attach ment Contr ol Number - REQUIRED when Tran smission M ethod = BM , EL, EM, or FT ; in put - IBIF N = IEN of the Bill/ Claims fil e (#399) ; OUTPUT - 0 = no err or ; 1 = Error ; N IBAC Q:IBI FN="" 0 F I=1,3 S IB AC(I)=$P($ G(^DGCR(39 9,IBIFN,"U 8")),U,I) Q:IBAC(3)= "" 0 Q:IBA C(1)'="" 0 Q:IBAC(3) ="AA" 0 Q 1 ;ACCK(IB IFN) ; IB* 2.0*432 If any of th e loop inf o is prese nt, then R eport Type & Transmi ssion Meth od req'd ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; OUTPUT - 0 = no error ; 1 = Error ; N IBAC Q: IBIFN="" 0 F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I) ; All fields nu ll, no err or I IBAC( 1)="",IBAC (2)="",IBA C(3)="" Q 0 ; Both r equired fi elds compl ete, no er ror I IBAC (2)'="",IB AC(3)'="" Q 0 ; At t his point, one of th e 2 requir ed fields has data a nd one doe s not, so error Q 1 ;LNTMCK(IB IFN) ; DEM ;IB*2.0*43 2 - (Line Level) Att achment Co ntrol Numb er - REQUI RED when T ransmissio n Method = BM, EL, E M, or FT ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; OUTPUT - IBLNERR = 0 = no error ; I BLNERR = 1 = Error ; N IBAC,IB PROCP,I,IB LNERR S IB LNERR=0 ; DEM;432 - Initialize error fla g IBLNERR to '0' for no errors . Q:IBIFN= "" IBLNERR S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR . Q:' ($D(^DGCR( 399,IBIFN, "CP",IBPRO CP,0))#10) ; DEM;432 - Node '0 ' is proce dure node. . Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; D EM;432 - N ode '1' is line leve l Attachme nt Control fields. . F I=1,3 S IBAC(I)=$ P(^DGCR(39 9,IBIFN,"C P",IBPROCP ,1),U,I) . I IBAC(3) ="" S IBLN ERR=0 Q . I IBAC(1)' ="" S IBLN ERR=0 Q . I (IBAC(3) ="AA") S I BLNERR=0 Q . S IBLNE RR=1 . Q ; Q IBLNERR ;LNACCK(I BIFN) ; DE M;IB*2.0*4 32 (Line L evel) If a ny of the loop info is present , then Rep ort Type & Transmiss ion Method req'd ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - IBLNERR = 0 = no er ror ; IBL NERR = 1 = Error ; N IBAC,IBPR OCP,I,IBLN ERR S IBLN ERR=0 ; DE M;432 - In itialize e rror flag IBLNERR to '0' for n o errors. Q:IBIFN="" IBLNERR S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:IBLNE RR . Q:'($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,0))#10) ; DEM;432 - Node '0' is procedu re node. . Q:'($D(^D GCR(399,IB IFN,"CP",I BPROCP,1)) #10) ; DEM ;432 - Nod e '1' is l ine level Attachment Control f ields. . F I=1:1:3 S IBAC(I)=$ P(^DGCR(39 9,IBIFN,"C P",IBPROCP ,1),U,I) . ; All fie lds null, no error . I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" S IB LNERR=0 Q . ; Both r equired fi elds compl ete, no er ror . I IB AC(2)'="", IBAC(3)'=" " S IBLNER R=0 Q . ; At this po int, one o f the 2 re quired fie lds has da ta and one does not, so error . S IBLNER R=1 . Q ; Q IBLNERR ; ;vd/Begi nning of I B*2*577 - Validate L ine Level for NDCLNN DCCK(IBIFN ) ;IB*2*57 7 (Line Le vel) The U nits and U nits/Basis of Measur ement fiel ds are req uired if t he NDC fie ld is popu lated. ; I NPUT - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - IBLNERR = 0 = no er ror ; IBLN ERR = 1 = Error ; N IBAC,IBPRO CP,I,IBLNE RR S IBLNE RR=0 ; IB* 2*577 - In itialize e rror flag IBLNERR to '0' for n o errors. Q:IBIFN="" IBLNERR S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:IBLNE RR . Q:($$ GET1^DIQ(3 99.0304,IB PROCP_","_ IBIFN_",", "NDC","I") ="") ; IB* 2*577 - No NDC Code . ; If the re is an N DC Code, t hen the UN ITS and UN ITS/BASIS OF MEASURE MENT are R equired. . I $$GET1^ DIQ(399.03 04,IBPROCP _","_IBIFN _",","UNIT S/BASIS OF MEASUREME NT","I")=" " S IBLNER R=1 Q . I $$GET1^DIQ (399.0304, IBPROCP_", "_IBIFN_", ","UNITS", "I")="" S IBLNERR=1 Q ;Units (Quantity) is requir ed if ther e is an ND C Code. . Q ; Q IBLN ERR ;vd/En d of IB*2* 577 | |
| 876 | Modified L ogic (Chan ges are in bold) | |
| 877 | IBCBB11 ;A LB/AAS/OIF O-BP/PIJ - CONTINUAT ION OF EDI T CHECK RO UTINE ;12 Jun 2006 3 :45 PM ;;2 .0;INTEGRA TED BILLIN G;**51,343 ,363,371,3 95,392,401 ,384,400,4 36,432,516 ,550,577,5 92**;21-MA R-94;Build 1 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ;WARN (IBDISP) ; Set warni ng in glob al ; DISP = warning text to di splay ; N Z S Z=+$O( ^TMP($J,"B ILL-WARN", ""),-1) I Z=0 S ^TMP ($J,"BILL- WARN",1)=$ J("",5)_"* *Warnings* *:",Z=1 S Z=Z+1,^TMP ($J,"BILL- WARN",Z)=$ J("",5)_IB DISP Q ;MU LTDIV(IBIF N,IBND0) ; Check for multiple divisions on a bill ien IBIFN ; IBND0 = 0-node of bill ; ; F unction re turns 1 if more than 1 divisio n found on bill N Z, Z0,Z1,MULT S MULT=0, Z1=$P(IBND 0,U,22) I Z1 D . S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," RC",Z)) Q: 'Z S Z0=$ P(^(Z,0),U ,7) I Z0,Z 0'=Z1 S MU LT=1 Q . S Z=0 F S Z=$O(^DGCR (399,IBIFN ,"CP",Z)) Q:'Z S Z0 =$P(^(Z,0) ,U,6) I Z0 ,Z0'=Z1 S MULT=2 Q I 'Z1 S MUL T=3 Q MULT ; ;; PREG NANCY DX C ODES: V22* *-V24**, V 27**-V28** , 630**-67 7** ;; FLU SHOTS PRO CEDURE COD ES: 90724, G0008, 90 732, G0009 ;NPICHK ; Check for required NPIs N IBN PIS,IBNONP I,IBNPIREQ ,Z,IBNFI,I BTF,IBWC,I BXSAVE,IBP RV,IBLINE ;*** pij s tart IB*20 *436 *** N IBRATYPE, IBLEGAL S (IBRATYPE, IBLEGAL)=" " S IBRATY PE=$P($G(^ DGCR(399,I BIFN,0)),U ,7) ; Lega l types fo r this use . ; 7=NO F AULT INS. ; 10=TORT FEASOR ; 1 1=WORKERS' COMP. S I BNFI=$O(^D GCR(399.3, "B","NO FA ULT INS.", 0)) S:'IBN FI IBNFI=7 S IBTF=$O (^DGCR(399 .3,"B","TO RT FEASOR" ,0)) S:'IB TF IBTF=10 S IBWC=$O (^DGCR(399 .3,"B","WO RKERS' COM P.",0)) S: 'IBWC IBWC =11 ; I IB RATYPE=IBN FI!(IBRATY PE=IBTF)!( IBRATYPE=I BWC) D . ; One of th e legal ty pes - forc e local pr int . S IB LEGAL=1 ;* ** pij end *** S IBN PIREQ=$$NP IREQ^IBCEP 81(DT) ; C heck if NP I is requi red ; Chec k provider s ; IB*2.0 *432 chang ed the NPI check to the new Pr ovider Arr ay ;S IBNP IS=$$PROVN PI^IBCEF73 A(IBIFN,.I BNONPI) D ALLIDS^IBC EFP(IBIFN, .IBXSAVE,1 ) S IBPRV= "" F S IB PRV=$O(IBX SAVE("PROV INF",IBIFN ,"C",1,IBP RV)) Q:'IB PRV D . I $P($G(IBX SAVE("PROV INF",IBIFN ,"C",1,IBP RV,0)),U,4 )="" S IBN ONPI(IBPRV )="" S IBL INE="" F S IBLINE=$ O(IBXSAVE( "L-PROV",I BIFN,IBLIN E)) Q:'IBL INE D . S IBPRV="" . F S IBP RV=$O(IBXS AVE("L-PRO V",IBIFN,I BLINE,"C", 1,IBPRV)) Q:IBPRV="" D .. I $ P($G(IBXSA VE("L-PROV ",IBIFN,IB LINE,"C",1 ,IBPRV,0)) ,U,4)="" S IBNONPI(I BPRV)="" I $D(IBNONP I) S IBPRV ="" F S I BPRV=$O(IB NONPI(IBPR V)) Q:'IBP RV D . ;J WS;IB*2.0* 592;Assist ant Surgeo n for dent al . I IBP RV=6 S IBE R=IBER_"IB 358;" Q . S IBER=IBE R_"IB"_(14 0+IBPRV)_" ;" Q ; If required, set error IB*2*516 ; Check or ganization s S IBNONP I="" S IBN PIS=$$ORGN PI^IBCEF73 A(IBIFN,.I BNONPI) I $L(IBNONPI ) F Z=1:1: $L(IBNONPI ,U) D . S IBER=IBER_ $P("IB339; ^IB340;^IB 341;",U,$P (IBNONPI,U ,Z)) ; DEM ;432 Added NPI error s. Q ;TAXC HK ; Check for requi red taxono mies N IBD T,IBLINE,I BNOTAX,IBP RV,IBTAXS, IBXSAVE,Z ; ; MRD;IB *2.0*516 - This chec k is now m oot; 'toda y' is alwa ys on or ; after May 23, 2008, so taxono my codes a re always required ; for certa in provide rs. ;S IBT AXREQ=$$TA XREQ^IBCEP 81(DT) ; C heck if ta xonomy is required ; ; Check p roviders ; IB*2.0*43 2 changed the Taxono my check t o the new Provider A rray ;S IB TAXS=$$PRO VTAX^IBCEF 73A(IBIFN, .IBNOTAX) D ALLIDS^I BCEFP(IBIF N,.IBXSAVE ,1) S IBPR V="" F S IBPRV=$O(I BXSAVE("PR OVINF",IBI FN,"C",1,I BPRV)) Q:' IBPRV D . I $G(IBXS AVE("PROVI NF",IBIFN, "C",1,IBPR V,"TAXONOM Y"))="" S IBNOTAX(IB PRV)="" . Q ; S IBLI NE="" F S IBLINE=$O (IBXSAVE(" L-PROV",IB IFN,IBLINE )) Q:'IBLI NE D . S IBPRV="" . F S IBPR V=$O(IBXSA VE("L-PROV ",IBIFN,IB LINE,"C",1 ,IBPRV)) Q :IBPRV="" D . . I $ G(IBXSAVE( "L-PROV",I BIFN,IBLIN E,"C",1,IB PRV,"TAXON OMY"))="" S IBNOTAX( IBPRV)="" . . Q . Q ; ; IB251 = Referrin g provider taxonomy missing. ; IB253 = R endering p rovider ta xonomy mis sing. ; IB 254 = Atte nding prov ider taxon omy missin g. ; IB256 = Assista nt Surgeon taxonomy missing. ; JWS;IB*2.0 *592 ;JWS; IB*2.0*592 ;dental st art I $D(I BNOTAX) S IBPRV="" F S IBPRV= $O(IBNOTAX (IBPRV)) Q :'IBPRV D . ; Only Referring, Rendering and Atten ding are c urrently s ent to the payer . ; I IBTAXREQ ,"134"[IBP RV S IBER= IBER_"IB"_ (250+IBPRV )_";" Q ; MRD;IB*2.0 *516 - Alw ays requir ed. . I "1 346"[IBPRV S IBER=IB ER_"IB"_(2 50+IBPRV)_ ";" Q ; I f required , set erro r and quit . D WARN( "Taxonomy for the "_ $P("referr ing^operat ing^render ing^attend ing^superv ising^assi stant surg eon^^^othe r",U,IBPRV )_$S(IBPRV =6:"",1:" provider") _" has no value") ; Else, set warning . Q ;JWS;IB* 2.0*592;en d ; ; Chec k organiza tions. The function ORGTAX wil l set IBNO TAX to be a ; list o f entities missing t axonomy co des, if an y (n, n^m, n^m^p, ; where each 1 is serv ice facili ty, 2 is n on-VA serv ice facili ty and ; 3 is billin g provider . ; S IBNO TAX="" S I BTAXS=$$OR GTAX^IBCEF 73A(IBIFN, .IBNOTAX) I $L(IBNOT AX) F Z=1: 1:$L(IBNOT AX,U) D . ; IB167 = Billing Pr ovider tax onomy miss ing. . ;I IBTAXREQ,$ P(IBNOTAX, U,Z)=3 S I BER=IBER_" IB167;" Q ; MRD;IB*2 .0*516 - A lways requ ired. . I $P(IBNOTAX ,U,Z)=3 S IBER=IBER_ "IB167;" Q . ; MRD;I B*2.0*516 - Remove w arning mes sage for m issing tax onomy code for lab o r facility . . ; D WA RN("Taxono my for the "_$P("Ser vice Facil ity^Non-VA Service F acility^Bi lling Prov ider",U,$P (IBNOTAX,U ,Z))_" has no value" ) ; Else, set warnin g . Q ; Q ;VALNDC(IB IFN,IBDFN) ; IB*2*36 3 - valida te NDC# be tween PRES CRIPTION f ile (#52) ; and IB B ILL/CLAIMS PRESCRIPT ION REFILL file (#36 2.4) ; inp ut - IBIFN = interna l entry nu mber of th e billing record in the BILL/C LAIMS file (#399) ; IBDFN = in ternal ent ry number of patient record in the PATIE NT file (# 2) N IBX,I BRXCOL ; c all progra m that det ermines if NDC diffe rences exi st D VALND C^IBEFUNC3 (IBIFN,IBD FN,.IBRXCO L) Q:'$D(I BRXCOL) ; at least o ne RX on t he IB reco rd has an NDC discre pancy S I BX=0 F S IBX=$O(IBR XCOL(IBX)) Q:'IBX D WARN("NDC # on Bill does not e qual the N DC# on Rx "_IBRXCOL( IBX)) Q ;P RIIDCHK ; Check for required P imarary ID (SSN/EIN) ; If the provider i s on the c laim, he m ust have o ne ; N IB I,IBZ I $$ TXMT^IBCEF 4(IBIFN) D . D F^IBC EF("N-ALL ATT/REND P ROV SSN/EI ","IBZ",,I BIFN) . S IBI="" F S IBI=$O(^ DGCR(399,I BIFN,"PRV" ,"B",IBI)) Q:IBI="" D .. I $P (IBZ,U,IBI )="" S IBE R=IBER_$S( IBI=1:"IB1 51;",IBI=2 :"IB152;", IBI=3!(IBI =4):"IB321 ;",IBI=5:" IB153;",IB I=9:"IB154 ;",1:"") Q ;RXNPI(IB IFN) ; che ck for mul tiple phar macy npi's on the sa me bill N IBORG,IBRX NPI,IBX,IB Y S IBORG= $$RXSITE^I BCEF73A(IB IFN,.IBORG ) S IBX=0 F S IBX=$ O(IBORG(IB X)) Q:'IBX S IBY=0 F S IBY=$ O(IBORG(IB X,IBY)) Q: 'IBY S IB RXNPI(+IBO RG(IBX,IBY ))="" S (I BX,IBY)=0 F S IBX=$ O(IBRXNPI( IBX)) Q:'I BX S IBY= IBY+1 I IB Y>1 D WARN ("Bill has prescript ions resul ting from "_IBY_" di fferent NP I location s") Q ;ROI CHK(IBIFN, IBDFN,IBIN S) ; IB*2. 0*384 - ch eck prescr iptions th at contain the ; SEN SITIVE DIA GNOSIS DRU G field #8 7 in the D RUG File # 50 set to 1 against ; the Clai ms Trackin g ROI file (#356.25) to see if an ROI is on file ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; IBDFN = IEN of t he patient ; IBINS = IEN of th e payer in surance co mpany (#36 ) ; OUTPUT - 0 = no error ; 1 = a presc ription is sensitive and there is no ROI on file ; N IBX,IBY 0,IBRXIEN, IBDT,IBDRU G,ROIQ S R OIQ=0 S IB X=0 F S I BX=$O(^IBA (362.4,"C" ,IBIFN,IBX )) Q:'IBX D .S IBY0 =^IBA(362. 4,IBX,0),I BRXIEN=$P( IBY0,U,5) I 'IBRXIEN Q .S IBDT =$P(IBY0,U ,3),IBDRUG =$P(IBY0,U ,4) .D ZER O^IBRXUTL( IBDRUG) .I $$SENS^IB NCPDR(IBDR UG) D ; S ensitive D iagnosis D rug - chec k for ROI .. I $$ROI ^IBNCPDR4( IBDFN,IBDR UG,IBINS,I BDT) Q ;R OI is on f ile .. D W ARN("ROI n ot on file for presc ription "_ $$RXAPI1^I BNCPUT1(IB RXIEN,.01, "E")) .. S ROIQ=1ROI CHKQ ; K ^ TMP($J,"IB DRUG") Q R OIQ ;AMBCK (IBIFN) ; IB*2.0*432 - if ambu lance loca tion defin ed, addres s must be defined ; if there i s anything entered i n any of t he address fields (e ither p/up or drop/o ff fields) , than the re needs t o be: ; A ddress 1, State and ZIP unless the State is not a US state o r possessi on, then z ip code is not neede d (CMS1500 only) ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - 0 = no er ror ; 1 = Error ; N IBPAMB,IB DAMB,IBAMB R,IBCK S I BAMBR=0 Q: $$INSPRF^I BCEF(IBIFN )'=0 IBAMB R S IBPAMB =$G(^DGCR( 399,IBIFN, "U5")),IBD AMB=$G(^DG CR(399,IBI FN,"U6")) S IBCK(5)= $$NOPUNCT^ IBCEF($P(I BPAMB,U,2, 6),1),IBCK (6)=$$NOPU NCT^IBCEF( $P(IBDAMB, U,1,6),1) I IBCK(5)= "",IBCK(6) ="" Q IBAM BR ; at th is point w e know tha t at least one ambul ance field has data, so check to see if all have d ata I IBCK (5)'="" F I=2,4,5 I $P(IBPAMB, U,I)="" S IBAMBR=1 I IBCK(6)'= "" F I=1,2 ,4,5 I $P( IBDAMB,U,I )="" S IBA MBR=1 Q:IB AMBR=1 IBA MBR ; now check zip code. OK t o be null if state i s not a US Posession F I="IBPA MB","IBDAM B" I $P(I, U,5)'="",$ P($G(^DIC( 5,$P(I,U,5 ),0)),U,6) =1,$P(I,U, 6)="" S IB AMBR=1 Q I BAMBR ;COB AMT(IBIFN) ; IB*2.0* 432 - IF t here is a COB amt. i t must equ al the Tot al Claim C harge Amou nt ; input - IBIFN = IEN of th e Bill/Cla ims file ( #399) ; OU TPUT - 0 = no error ; 1 = Err or ; Q:IBI FN="" 0 Q: $P($G(^DGC R(399,IBIF N,"U4")),U )="" 0 Q:+ $P($G(^DGC R(399,IBIF N,"U1")),U )'=+$P($G( ^DGCR(399, IBIFN,"U4" )),U) 1 Q 0 ;COBMRA( IBIFN) ; I B*2.0*432 - If there is a 'COB total non -covered a mount' (Fi le#399, Fi eld#260), ; Primary Insurance must be M edicare th at never w ent to Med icare, and this must be a 2nda ry or tert iary claim ; input - IBIFN = I EN of the Bill/Claim s file (#3 99) ; OUTP UT - 0 = n o error ; 1 = Error ; N IBP Q :IBIFN="" 0 Q:$P($G( ^DGCR(399, IBIFN,"U4" )),U)="" 0 S IBP=$P( $G(^DGCR(3 99,IBIFN," M1")),U,5) S:IBP="" IBP=IBIFN I $$WNRBIL L^IBEFUNC( IBIFN,1),$ P($G(^DGCR (399,IBP," S")),U,7)= "",$$COBN^ IBCEF(IBIF N)>1 Q 0 Q 1 ;COBSEC (IBIFN) ; IB*2.0*432 - If ther e is NOT a 'COB tota l non-cove red amount ' (File#39 9, Field#2 60), ; an d Primary Insurance is Medicar e that nev er went to Medicare, 2ndary or tertiary claim cann ot be set to transmi t ; input - IBIFN = IEN of the Bill/Clai ms file (# 399) ; OUT PUT - 0 = no error ; 1 = Erro r ; N IBP Q:IBIFN="" 0 Q:$P($G (^DGCR(399 ,IBIFN,"U4 ")),U)'="" 0 Q:$$COB N^IBCEF(IB IFN)<2 0 S IBP=$P($G (^DGCR(399 ,IBIFN,"M1 ")),U,5) S :IBP="" IB P=IBIFN I $$WNRBILL^ IBEFUNC(IB IFN,1),$P( $G(^DGCR(3 99,IBP,"S" )),U,7)="" ,$P($G(^DG CR(399,IBI FN,"TX")), U,8)'=1 Q 1 Q 0 ;TMC K(IBIFN) ; IB*2.0*43 2 - Attach ment Contr ol Number - REQUIRED when Tran smission M ethod = BM , EL, EM, or FT ; in put - IBIF N = IEN of the Bill/ Claims fil e (#399) ; OUTPUT - 0 = no err or ; 1 = Error ; N IBAC Q:IBI FN="" 0 F I=1,3 S IB AC(I)=$P($ G(^DGCR(39 9,IBIFN,"U 8")),U,I) Q:IBAC(3)= "" 0 Q:IBA C(1)'="" 0 Q:IBAC(3) ="AA" 0 Q 1 ;ACCK(IB IFN) ; IB* 2.0*432 If any of th e loop inf o is prese nt, then R eport Type & Transmi ssion Meth od req'd ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; OUTPUT - 0 = no error ; 1 = Error ; N IBAC Q: IBIFN="" 0 F I=1:1:3 S IBAC(I) =$P($G(^DG CR(399,IBI FN,"U8")), U,I) ; All fields nu ll, no err or I IBAC( 1)="",IBAC (2)="",IBA C(3)="" Q 0 ; Both r equired fi elds compl ete, no er ror I IBAC (2)'="",IB AC(3)'="" Q 0 ; At t his point, one of th e 2 requir ed fields has data a nd one doe s not, so error Q 1 ;LNTMCK(IB IFN) ; DEM ;IB*2.0*43 2 - (Line Level) Att achment Co ntrol Numb er - REQUI RED when T ransmissio n Method = BM, EL, E M, or FT ; input - I BIFN = IEN of the Bi ll/Claims file (#399 ) ; OUTPUT - IBLNERR = 0 = no error ; I BLNERR = 1 = Error ; N IBAC,IB PROCP,I,IB LNERR S IB LNERR=0 ; DEM;432 - Initialize error fla g IBLNERR to '0' for no errors . Q:IBIFN= "" IBLNERR S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D Q:IBL NERR . Q:' ($D(^DGCR( 399,IBIFN, "CP",IBPRO CP,0))#10) ; DEM;432 - Node '0 ' is proce dure node. . Q:'($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP,1 ))#10) ; D EM;432 - N ode '1' is line leve l Attachme nt Control fields. . F I=1,3 S IBAC(I)=$ P(^DGCR(39 9,IBIFN,"C P",IBPROCP ,1),U,I) . I IBAC(3) ="" S IBLN ERR=0 Q . I IBAC(1)' ="" S IBLN ERR=0 Q . I (IBAC(3) ="AA") S I BLNERR=0 Q . S IBLNE RR=1 . Q ; Q IBLNERR ;LNACCK(I BIFN) ; DE M;IB*2.0*4 32 (Line L evel) If a ny of the loop info is present , then Rep ort Type & Transmiss ion Method req'd ; i nput - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - IBLNERR = 0 = no er ror ; IBL NERR = 1 = Error ; N IBAC,IBPR OCP,I,IBLN ERR S IBLN ERR=0 ; DE M;432 - In itialize e rror flag IBLNERR to '0' for n o errors. Q:IBIFN="" IBLNERR S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:IBLNE RR . Q:'($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,0))#10) ; DEM;432 - Node '0' is procedu re node. . Q:'($D(^D GCR(399,IB IFN,"CP",I BPROCP,1)) #10) ; DEM ;432 - Nod e '1' is l ine level Attachment Control f ields. . F I=1:1:3 S IBAC(I)=$ P(^DGCR(39 9,IBIFN,"C P",IBPROCP ,1),U,I) . ; All fie lds null, no error . I IBAC(1) ="",IBAC(2 )="",IBAC( 3)="" S IB LNERR=0 Q . ; Both r equired fi elds compl ete, no er ror . I IB AC(2)'="", IBAC(3)'=" " S IBLNER R=0 Q . ; At this po int, one o f the 2 re quired fie lds has da ta and one does not, so error . S IBLNER R=1 . Q ; Q IBLNERR ; ;vd/Begi nning of I B*2*577 - Validate L ine Level for NDCLNN DCCK(IBIFN ) ;IB*2*57 7 (Line Le vel) The U nits and U nits/Basis of Measur ement fiel ds are req uired if t he NDC fie ld is popu lated. ; I NPUT - IBI FN = IEN o f the Bill /Claims fi le (#399) ; OUTPUT - IBLNERR = 0 = no er ror ; IBLN ERR = 1 = Error ; N IBAC,IBPRO CP,I,IBLNE RR S IBLNE RR=0 ; IB* 2*577 - In itialize e rror flag IBLNERR to '0' for n o errors. Q:IBIFN="" IBLNERR S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:IBLNE RR . Q:($$ GET1^DIQ(3 99.0304,IB PROCP_","_ IBIFN_",", "NDC","I") ="") ; IB* 2*577 - No NDC Code . ; If the re is an N DC Code, t hen the UN ITS and UN ITS/BASIS OF MEASURE MENT are R equired. . I $$GET1^ DIQ(399.03 04,IBPROCP _","_IBIFN _",","UNIT S/BASIS OF MEASUREME NT","I")=" " S IBLNER R=1 Q . I $$GET1^DIQ (399.0304, IBPROCP_", "_IBIFN_", ","UNITS", "I")="" S IBLNERR=1 Q ;Units (Quantity) is requir ed if ther e is an ND C Code. . Q ; Q IBLN ERR ;vd/En d of IB*2* 577 | |
| 878 | ||
| 879 | ||
| 880 | Routines | |
| 881 | Activities | |
| 882 | Routine Na me | |
| 883 | IBCBB12 | |
| 884 | Enhancemen t Category | |
| 885 | New | |
| 886 | Modify | |
| 887 | Delete | |
| 888 | No Change | |
| 889 | RTM | |
| 890 | ||
| 891 | Related Op tions | |
| 892 | None | |
| 893 | Related Ro utines | |
| 894 | Routines “ Called By” | |
| 895 | Routines “ Called” | |
| 896 | ||
| 897 | ||
| 898 | ||
| 899 | ||
| 900 | Data Dicti onary (DD) Reference s | |
| 901 | CLAIMS TRA CKING File [#356] | |
| 902 | Related Pr otocols | |
| 903 | None | |
| 904 | Related In tegration Control Re gistration s (ICRs) | |
| 905 | None | |
| 906 | Data Passi ng | |
| 907 | Input | |
| 908 | Output Re ference | |
| 909 | Both | |
| 910 | Global Re ference | |
| 911 | Local | |
| 912 | Input Attr ibute Name and Defin ition | |
| 913 | Name: | |
| 914 | Definition : | |
| 915 | Output Att ribute Nam e and Defi nition | |
| 916 | Name: | |
| 917 | Definition : | |
| 918 | Current Lo gic | |
| 919 | IBCBB12 ;A LB/DEM - P ROCEDURE A ND LINE LE VEL PROVID ER EDITS ; 17-OCT-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32**;21-MA R-94;Build 192 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . Q ;LNPRO V(IBIFN) ; DEM;432 - Edits for line leve l provider s. ; ; Inp ut: ; IBIF N - Claim number IEN . ; ; Outp ut: ; OK - '1' Edits ; '0' No Edits. ; * Note: OK r eturned if called as function. ; Can be called as routine as well. ; I BER - Edit error str ing. Only updated if errors. ; ; Patch 4 32 EDITS: ; ; (1) No t all proc edures hav e a Line L evel Rende ring Provi der, ; and no Claim Level Rend ering Prov ider. ; Er ror Messag e in Billi ng for Pro f Renderin g. ; *Note : Only app lies to Re ndering Pr ovider Typ e. ; ; (2) All proce dures have a Line Le vel Render ing Provid er, ; and a Claim Le vel Render ing Provid er who is different ; from any of the Li ne Level R endering P roviders. ; Error in Billing. ; *Note: A pply to al l provider types (Re ndering, R eferring, Supervisin g, Attendi ng, Operat ing, and O ther Opera ting). ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. Q:'$G(IBIF N) OK ; N eed claim number IEN to contin ue. N IBPR VFUN,IBCLP RV,IBLNPRV ,PRVFUN S: '$G(IBFT) IBFT=$$FT^ IBCEF(IBIF N) ; Form Type for c laim. Q:(I BFT'=2)&(I BFT'=3) OK ; Must b e CMS-1500 (2) or UB -04 (3) Fo rm Type. S :IBFT=2 PR VFUN(2)="R ENDERING,R EFERRING,S UPERVISING " ; Allow able line provider f unctions f or CMS-150 0. S:IBFT= 3 PRVFUN(3 )="RENDERI NG,REFERRI NG,OPERATI NG,OTHER O PERATING" ; Allowab le line pr ovider fun ctions for UB-04. F PRVFUN("CN T")=1:1:$L (PRVFUN(IB FT),",") S IBPRVFUN= $P(PRVFUN( IBFT),",", PRVFUN("CN T")) D . I IBFT=2,IB PRVFUN="RE NDERING",' $$LNPRV2(I BPRVFUN),' $D(^DGCR(3 99,IBIFN," PRV","C",I BPRVFUN)) D Q ; Ed it Check ( 1). . . S OK=1 ; OK= 1 indicate s we have at least o ne error. . . S IBER =IBER_"IB3 33;" . . Q . ; . Q:' $$LNPRV2(I BPRVFUN,.I BLNPRV) ; Quit if no t all the procedures have a li ne level p rovider of the same provider t ype. . Q:' $D(^DGCR(3 99,IBIFN," PRV","C",I BPRVFUN)) ; No claim level pro vider for this provi der type. . ; . Q:'$ $CLPRV2(IB PRVFUN,.IB CLPRV) ; M ust have p rovider fo r provider type IBPR VFUN to co ntinue (Ed it (2)). . ; . S IBC LPRV=0 F S IBCLPRV= $O(IBCLPRV (IBPRVFUN, IBCLPRV)) Q:'IBCLPRV D ; Edi t Check (2 ). . . Q:$ D(IBLNPRV( IBPRVFUN,I BCLPRV)) ; Check aga inst line provider a rray IBLNP RV. . . S OK=1 . . S IBER=IBER _"IB334;" . . Q . Q ; Q OK ;LN PRV2(IBPRV FUN,IBLNPR V) ; Funct ion - Edit Check (2) for line level prov ider. ; Se e Edit Che ck (2) at top of rou tine for d etails. ; ; Input: ; IBPRVFUN - Provider Type (FUN CTION). Ex ample: REN DERING. ; IBLNPRV(Ar ray) - Pas sed by ref erence. In itially un defined. ; ; Output: ; OK - If Edit Chec k (2) line level pro vider cond ition has ; been met , then OK will retur n '1' for TRUE, ELSE , '0' ; fo r FALSE. ; *See Edit Check (2) at top of routine f or details . ; IBLNPR V(Array) - If Edit C heck (2) c ondition h as been me t, ; then IBLNPRV wi ll contain the provi der type, ; and prov ider varia ble pointe r as array ; subscri pts, and a rray eleme nt is SET to ; NULL. => IBLNPR V(IBPRVFUN ,IBLNPROV) ="". ; N O K,IBPROCP, IBLPIEN,IB LNPROV S I BPROCP=0 F S IBPROC P=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP)) Q:'I BPROCP D I $D(OK), 'OK Q . Q: '($D(^DGCR (399,IBIFN ,"CP",IBPR OCP,0))#10 ) . I '$D( ^DGCR(399, IBIFN,"CP" ,IBPROCP," LNPRV","C" ,IBPRVFUN) ) S OK=0 Q ; No lin e provider function for this p rocedure. . S IBLPIE N=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP,"LNPRV ","C",IBPR VFUN,0)) . I 'IBLPIE N S OK=0 Q ; No lin e provider IEN for t his line p rovider fu nction. . I '($D(^DG CR(399,IBI FN,"CP",IB PROCP,"LNP RV",IBLPIE N,0))#10) S OK=0 Q ; No zero node for l ine level provider. . S IBLNPR OV=$P(^DGC R(399,IBIF N,"CP",IBP ROCP,"LNPR V",IBLPIEN ,0),"^",2) . I 'IBLN PROV S OK= 0 Q ; No line provi der for th is line pr ovider fun ction. . S IBLNPRV(I BPRVFUN,IB LNPROV)="" . Q ; Q:$ D(OK) OK ; OK will never equa l '1' for TRUE at th is point. I '$D(OK), '$D(IBLNPR V(IBPRVFUN )) S OK=0 Q OK ; No line prov ider array for this line provi der functi on. S OK=1 ; Edit Ch eck (2) li ne provide r conditio n has been met. Q OK ;CLPRV2(I BPRVFUN,IB CLPRV) ; F unction - Edit Check (2) for c laim level provider. ; See Edi t Check (2 ) at top o f routine for detail s. ; ; Inp ut: ; IBPR VFUN - Pro vider Type (FUNCTION ). Example : RENDERIN G. ; IBCLP RV(Array) - Passed b y referenc e. Intiall y undefine d. ; ; Out put: ; OK - If Edit Check (2) claim leve l provider condition has ; bee n met, the n OK will return '1' for TRUE, ELSE, '0' ; for FAL SE. ; *See Edit Chec k (2) at t op of rout ine for de tails. ; I BCLPRV(Arr ay) - If E dit Check (2) condit ion has be en met, ; then IBCLP RV will co ntain the provider t ype, ; and provider variable p ointer as array ; su bscripts, and array element is SET to ; NULL. => I BCLPRV(IBP RVFUN,IBCL PROV)="". ; N IBCLPI EN,IBCLPRO V,OK S OK= 0 ; Initia lize OK=0 for FALSE. S IBCLPIE N=0 F S I BCLPIEN=$O (^DGCR(399 ,IBIFN,"PR V","C",IBP RVFUN,IBCL PIEN)) Q:' IBCLPIEN D Q:OK . Q:'($D(^DG CR(399,IBI FN,"PRV",I BCLPIEN,0) )#10) . S IBCLPROV=$ P(^DGCR(39 9,IBIFN,"P RV",IBCLPI EN,0),"^", 2) . Q:'IB CLPROV . S IBCLPRV(I BPRVFUN,IB CLPROV)="" ; Set ar ray for Ed it Check ( 2) to comp are claim level prov ider with line level provider. . S OK=1 ; At this point we h ave our cl aim level provider o f provider type IBPR VFUN. Set OK=1 for T RUE. . Q ; Q:'OK OK S OK=1 Q O K ;OPPROVC K(IBIFN) ; DEM;432 - Other Ope rating Pro vider edit checks. ; ; Input: ; IBIFN - Claim numb er IEN. ; ; Output: ; OK - '1' Edits ; ' 0' No Edit s. ; *Note : OK retur ned if cal led as fun ction ($$) . ; Can be called as routine a s well. ; ; Patch 43 2 line lev el Other O perating P rovider Ed it checks: ; ; (1) I f claim le vel Other Operating Provider, then ; (1. 1) claim m ust have c laim level Operating Provider. ; OR ; (1 .2) every line must have Opera ting Provi der. ; ; I f (1) Pass es, then d o edit che ck (2) bel ow. ; ; (2 ) If any c laim line has Other Operating Provider, then ; (2. 1) must ha ve Operati ng Provide r on same claim line , ; OR ; ( 2.2) must have claim level Ope rating Pro vider. ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. Q:'$G(IBIF N) OK ; N eed claim number IEN to contin ue. S:'$G( IBFT) IBFT =$$FT^IBCE F(IBIFN) ; Form Type for claim . Q:(IBFT' =2)&(IBFT' =3) OK ; Must be CM S-1500 (2) or UB-04 (3) Form T ype. ; N I BPRVFUN,IB LNFLAG,IBL NPRV,CLOK, LNOK ; ; N ote: Claim level pro vider - OT HER and OT HER OPERAT ING are th e same. ; Check if c ondition ( 1) has bee n met. F I BPRVFUN="O THER","OTH ER OPERATI NG" S CLOK =$$CLOPPRV 1(IBPRVFUN ) Q:CLOK Q :'CLOK OK ; No clai m level OT HER OPERAT ING PROVID ER, then Q UIT, no fu rther chec ks. S OK=0 ; Initial ize OK=0 f or FALSE. ; Conditi on (1) has been met, check con dition (1. 1). S CLOK =0 ; Initi alize CLOK =0 for FAL SE. I $D(^ DGCR(399,I BIFN,"PRV" ,"C","OPER ATING")) S IBPRVFUN= "OPERATING ",CLOK=$$C LOPPRV1(IB PRVFUN) ; Check cond ition (1.1 ). ; If CL OK at this point, th en skip co ndition ch eck (1.2) and contin ue to cond ition (2). S LNOK=0 ; Initiali ze LNOK=0 for FALSE. I 'CLOK S IBPRVFUN= "OPERATING ",LNOK=$$L NOPPRV1(IB PRVFUN) I 'LNOK S OK =1 Q OK ; Check con dition (1. 2). If 'LN OK, then w e have an error and QUIT. ; If LNOK, the n continue to condit ion check (2). S LNO K=0 ; Init ialize LNO K=0 for FA LSE. K IBL NPRV ; KI LL IBLNPRV array bef ore call t o $$LNOPPR V1(IBPRVFU N,1,.IBLNP RV). S IBP RVFUN="OTH ER OPERATI NG",LNOK=$ $LNOPPRV1( IBPRVFUN,1 ,.IBLNPRV) ; Conditi on check ( 2) start. I '$D(IBLN PRV("PRVFU N")) S OK= 0 Q OK ; If no data in IBLNPR V("PRVFUN" ) array, t hen skip r est of che cks, no er ror. ; If data in IB LNPRV("PRV FUN") arra y, then ch eck condit ion (2.1). S IBPRVFU N="OPERATI NG",LNOK=$ $LNOPPRV1( IBPRVFUN,1 ,.IBLNPRV) ; Conditi on check ( 2.1) start . S LNOK=0 ; Initial ize LNOK=0 for FALSE . D:$D(IBL NPRV("PRVF UN")) ; If data in I BLNPRV("PR VFUN") arr ay, then c ontinue co ndition ch eck (2.1). . N IBPRO CP . S IBP ROCP=0 F S IBPROCP= $O(IBLNPRV ("PROC",IB PROCP)) Q: 'IBPROCP D Q:'LNOK . . I $D( IBLNPRV("P ROC",IBPRO CP,"OTHER OPERATING" )),'$D(IBL NPRV("PROC ",IBPROCP, "OPERATING ")) S LNOK =0 Q . . S LNOK=1 ; At this po int, we ha ve at leas t one matc h. If ther e wasn't a match, th en LNOK=0 and we wou ld have QU IT. . . Q . Q I LNOK S OK=0 Q OK ; Cond itions (2) and (2.1) are met ( no error). SET OK=0 and QUIT. ; If 'LNOK , then con tinue to c ondition c heck (2.2) . S CLOK=0 ; Initial ize CLOK=0 for FALSE . S IBPRVF UN="OPERAT ING",CLOK= $$CLOPPRV1 (IBPRVFUN) ; Conditi on check ( 2.2). I CL OK S OK=0 Q OK ; Co nditions ( 2) and (2. 2) are met (no error ). SET OK= 0 and QUIT . ; At thi s point, w e have an error. SET OK=1, and QUIT. S O K=1 Q OK ; CLOPPRV1(I BPRVFUN) ; Claim lev el provide r/provider function check. ; ; Check if there is a claim lev el provide r with pro vider func tion IBPRV FUN. ; ; I nput: ; IB PRVFUN - P ROVIDER FU NCTION. ; ; Output: ; OK - '1' Claim lev el provide r exist fo r provider function IBPRVFUN. ; '0' No C laim level provider exist for provider f unction IB PRVFUN. ; N OK,IBCLP IEN,IBCLPR OV S OK=0 ; Initiali ze OK=0 fo r FALSE. ; I $D(^DGC R(399,IBIF N,"PRV","C ",IBPRVFUN )) D . S I BCLPIEN=0 F S IBCLP IEN=$O(^DG CR(399,IBI FN,"PRV"," C",IBPRVFU N,IBCLPIEN )) Q:'IBCL PIEN D Q :OK . . Q: '($D(^DGCR (399,IBIFN ,"PRV",IBC LPIEN,0))# 10) . . S IBCLPROV=$ P(^DGCR(39 9,IBIFN,"P RV",IBCLPI EN,0),U,2) . . Q:'IB CLPROV . . S OK=1 ; At this po int we hav e claim le vel provid er with pr ovider fun ction IBPR VFUN and c an QUIT fu nction/sub routine. . . Q . Q ; Q OK ;LNO PPRV1(IBPR VFUN,IBLNF LAG,IBLNPR V,IBPROCHK ) ; Check every clai m line for provider function I BPRVFUN. ; ; ; Input : ; IBPRVF UN - PROVI DER FUNCTI ON. ; IBLN FLAG(Optio nal) = 1 o r 0. 1 ind icates ret urn IBLNPR V array pa ssed by re ference, o therwise ' 0' for NO. ; IBLNPRV (Optional) - Array p assed by r eference = > IF SET O K=1, then ; I $G(IBL NFLAG) S I BLNPRV("PR OC",IBPROC P,IBPRVFUN )="",IBLNP RV("PRVFUN ",IBPRVFUN ,IBPROCP)= "" ; IBPRO CHK - Cond ition on P ROCEDURE ( ICD, CPT, or HCFA pr ocedure co des). ; ; Output: ; OK - '1' E very line level prov ider exist for provi der functi on IBPRVFU N. ; '0' N ot every l ine level provider e xist for p rovider fu nction IBP RVFUN. ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. ; N IBLPIE N,IBLNPROV ,IBPROCP S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:($D(^ DGCR(399,I BIFN,"CP", IBPROCP,0) )#10)&('OK ) . Q:'($D (^DGCR(399 ,IBIFN,"CP ",IBPROCP, 0))#10) ; No procedu re '0' nod e. . I $G( IBPROCHK)' ="" Q:$P(^ DGCR(399,I BIFN,"CP", IBPROCP,0) ,U,1)'[IBP ROCHK . I '$D(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,"C",IBPRV FUN)) S OK =0 Q ; No line prov ider funct ion IBPRVF UN for thi s procedur e. . S IBL PIEN=$O(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV","C",I BPRVFUN,0) ) . I 'IBL PIEN S OK= 0 Q ; No line provi der IEN fo r this lin e provider function. . I '($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP," LNPRV",IBL PIEN,0))#1 0) S OK=0 Q ; No '0 ' node for line leve l provider . . S IBLN PROV=$P(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV",IBLPI EN,0),U,2) . I 'IBLN PROV S OK= 0 Q ; No line provi der for th is line pr ovider fun ction. . ; At this p oint we ha ve line le vel provid er of type IBPRVFUN. . ; S OK= 1 for this claim lin e. OK can be changed back to ' 0', for FA LSE, if cl aim line f ails condi tion. . ; We would n ot get to this point if any li ne level p rovider wi th provide r function IBPRVFUN didn't exi st. . S OK =1 . I $G( IBLNFLAG) S IBLNPRV( "PROC",IBP ROCP,IBPRV FUN)="",IB LNPRV("PRV FUN",IBPRV FUN,IBPROC P)="" . Q ; Q OK ;UB PRVCK(IBIF N) ; DEM;4 32 - Check if claim requires o perating p rovider. ; ; Descrip tion: This function checks if claim requ ires an op erating pr ovider. ; ; Checks: ; ; (1) If claim has a claim l evel opera ting provi der, ; the n no furth er checks (OK=1=TRUE ). ; (2) I f claim do esn't have a claim l evel opera ting provi der, ; the n check: ; (2.1) Is this a UB- 04 claim? NO = QUIT (OK=1), YE S = Contin ue to next check. ; (2.2) Chec k every cl aim line t hat includ es HCPCS p rocs - ope rating pro vider. ; I f every cl aim line t hat includ es HCPCS p rocs has a n operatin g provider , ; then w e are OK a nd QUIT (O K=1). ; If any claim line that includes HCPCS proc s doesn't have an op erating ; provider, then we ha ve an ERRO R (OK=0). ; ; Input : ; IBIFN = Claim nu mber IEN. ; ; Output : ; OK = 0 = claim d oesn't hav e an opera ting provi der ; when operating provider or renderi ng provide r required . ; OK = 1 = claim h as an oper ating prov ider, or, ; claim do esn't requ ire operat ing provid er. ; N OK ; If clai m doesn't have any p rocedure c odes, then no checks required. I '$O(^DG CR(399,IBI FN,"CP",0) ) S OK=1 Q OK ; S OK =$$CLOPPRV 1("OPERATI NG") ; Do we have a claim leve l OPERATIN G PROVIDER (OK=1=TRU E)? Q:OK O K ; QUIT, we have a claim lev el OPERATI NG PROVIDE R (OK=1=TR UE). ; N I BFT S IBFT =($$FT^IBC EF(IBIFN)= 3) ; UB-04 claim (1 = TRUE, 0 = FALSE)? S OK=1 ; I nitialize OK=1. Q:'I BFT OK ; QUIT OK=1, not a UB- 04 claim. ; ; Claim level chec k did not pass, chec k claim li nes. ; No claim leve l OPERATIN G PROVIDER , so check every PRO CEDURE for OPERATING PROVIDER. S OK=$$UB PRVCK1("") ; Does ev ery proced ure have a n OPERATIN G PROVIDER (1=TRUE,0= FALSE)? ; Q OK ;UBPR VCK1(IBPRO CHK,IBONE) ; DEM;432 - Continu ation of U BPRVCK fun ction. ; ; Input: ; IBPROCHK(O ptional) - Optional condition on PROCEDU RE CODE (I CD, CPT, o r HCFA pro cedure cod es). ; IBO NE(Optiona l) - Quit if at leas t one line has an OP ERATING ; ; Output: ; OK - '1' Every pro cedure cod e that con tains IBPR OCHK (opti onal check ) has an O PERATING P ROVIDER. ; or if IBO NE, then a t least on e procedur e code tha t contains IBPROCHK (optional check) has an OPERAT ING PROVID ER. ; '0' Not every procedure code that contains I BPROCHK (o ptional ch eck) has a n OPERATIN G PROVIDER . ; or if IBONE, the n NO proce dure codes that cont ain IBPROC HK (option al check) has an OPE RATING PRO VIDER. ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. ; N IBLPIE N,IBLNPROV ,IBPROCP S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:($D(^ DGCR(399,I BIFN,"CP", IBPROCP,0) )#10)&('OK )&('$G(IBO NE)) I $G( IBONE),$G( OK) Q . Q: '($D(^DGCR (399,IBIFN ,"CP",IBPR OCP,0))#10 ) ; No pro cedure '0' node. . I $G(IBPROC HK)'="" Q: $P(^DGCR(3 99,IBIFN," CP",IBPROC P,0),U,1)' [IBPROCHK . I '$D(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV","C"," OPERATING" )) S OK=0 Q ; No li ne OPERATI NG PROVIDE R for this procedure . . S IBLP IEN=$O(^DG CR(399,IBI FN,"CP",IB PROCP,"LNP RV","C","O PERATING", 0)) . I 'I BLPIEN S O K=0 Q ; N o line pro vider IEN for this l ine provid er functio n. . I '($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,"LNPRV",I BLPIEN,0)) #10) S OK= 0 Q ; No '0' node f or line le vel provid er. . S IB LNPROV=$P( ^DGCR(399, IBIFN,"CP" ,IBPROCP," LNPRV",IBL PIEN,0),U, 2) . I 'IB LNPROV S O K=0 Q ; N o line pro vider for this line provider f unction. . ; At this point we have line level prov ider of ty pe OPERATI NG. . ; S OK=1 for t his claim line. OK c an be chan ged back t o '0', for FALSE, if claim lin e fails co ndition. . ; We woul d not get to this po int if any line leve l provider with prov ider funct ion OPERAT ING didn't exist. . S OK=1 . Q ; Q OK | |
| 920 | Modified L ogic (Chan ges are in bold) | |
| 921 | IBCBB12 ;A LB/DEM - P ROCEDURE A ND LINE LE VEL PROVID ER EDITS ; 17-OCT-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32,592**;2 1-MAR-94;B uild 192 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. Q ;L NPROV(IBIF N) ; DEM;4 32 - Edits for line level prov iders. ; ; Input: ; IBIFN - Cl aim number IEN. ; ; Output: ; OK - '1' E dits ; '0' No Edits. ; *Note: OK returne d if calle d as funct ion. ; Can be called as routin e as well. ; IBER - Edit error string. O nly update d if error s. ; ; Pat ch 432 EDI TS: ; ; (1 ) Not all procedures have a Li ne Level R endering P rovider, ; and no Cl aim Level Rendering Provider. ; Error Me ssage in B illing for Prof Rend ering. ; * Note: Only applies t o Renderin g Provider Type. ; ; (2) All p rocedures have a Lin e Level Re ndering Pr ovider, ; and a Clai m Level Re ndering Pr ovider who is differ ent ; from any of th e Line Lev el Renderi ng Provide rs. ; Erro r in Billi ng. ; *Not e: Apply t o all prov ider types (Renderin g, Referri ng, Superv ising, Att ending, Op erating, a nd Other O perating). ; N OK S OK=0 ; Ini tialize OK =0 for FAL SE. Q:'$G( IBIFN) OK ; Need cl aim number IEN to co ntinue. N IBPRVFUN,I BCLPRV,IBL NPRV,PRVFU N S:'$G(IB FT) IBFT=$ $FT^IBCEF( IBIFN) ; F orm Type f or claim. ; JWS;IB*2 .0*592 US1 108 - Dent al form ch eck I IBFT '=2,IBFT'= 3,IBFT'=7 Q OK ; Mu st be CMS- 1500 (2) o r UB-04 (3 ) or (7) D ental J430 D Form Typ e. S:IBFT= 2 PRVFUN(2 )="RENDERI NG,REFERRI NG,SUPERVI SING" ; A llowable l ine provid er functio ns for CMS -1500. S:I BFT=3 PRVF UN(3)="REN DERING,REF ERRING,OPE RATING,OTH ER OPERATI NG" ; All owable lin e provider functions for UB-04 . S:IBFT=7 PRVFUN(7) ="RENDERIN G,REFERRIN G,SUPERVIS ING,ASSIST ANT SURGEO N" ; Allo wable line provider functions for Dental form J430 D. ; JWS;I B*2.0*592 US1108 - e nd F PRVFU N("CNT")=1 :1:$L(PRVF UN(IBFT)," ,") S IBPR VFUN=$P(PR VFUN(IBFT) ,",",PRVFU N("CNT")) D . I IBFT =2,IBPRVFU N="RENDERI NG",'$$LNP RV2(IBPRVF UN),'$D(^D GCR(399,IB IFN,"PRV", "C",IBPRVF UN)) D Q ; Edit Ch eck (1). . . S OK=1 ; OK=1 indi cates we h ave at lea st one err or. .. S I BER=IBER_" IB333;" .. Q . ;JWS; IB*2.0*592 - US1108 start . I IBFT=7,IBP RVFUN="REN DERING",'$ $LNPRV2(IB PRVFUN),'$ D(^DGCR(39 9,IBIFN,"P RV","C",IB PRVFUN)) D Q:OK ;E dit check for dental .. I $D(^ DGCR(399,I BIFN,"PRV" ,"C","ASSI STANT SURG EON")) Q . . I $$LNPR V2("ASSIST ANT SURGEO N") Q .. S OK=1,IBER =IBER_"IB3 57;" .. Q . I IBFT=7 ,IBPRVFUN= "ASSISTANT SURGEON", '$$LNPRV2( IBPRVFUN), '$D(^DGCR( 399,IBIFN, "PRV","C", IBPRVFUN)) D Q:OK ;Edit chec k for dent al .. I $D (^DGCR(399 ,IBIFN,"PR V","C","RE NDERING")) Q .. I $$ LNPRV2("RE NDERING") Q .. S OK= 1,IBER=IBE R_"IB357;" .. Q . ;J WS;IB*2.0* 592 - US11 08 end . Q :'$$LNPRV2 (IBPRVFUN, .IBLNPRV) ; Quit if not all th e procedur es have a line level provider of the sam e provider type. . Q :'$D(^DGCR (399,IBIFN ,"PRV","C" ,IBPRVFUN) ) ; No cla im level p rovider fo r this pro vider type . . ; . Q: '$$CLPRV2( IBPRVFUN,. IBCLPRV) ; Must have provider for provid er type IB PRVFUN to continue ( Edit (2)). . ; . S I BCLPRV=0 F S IBCLPR V=$O(IBCLP RV(IBPRVFU N,IBCLPRV) ) Q:'IBCLP RV D ; E dit Check (2). .. Q: $D(IBLNPRV (IBPRVFUN, IBCLPRV)) ; Check ag ainst line provider array IBLN PRV. .. S OK=1 .. S IBER=IBER_ $S(IBPRVFU N="ASSISTA NT SURGEON ":"IB335;" ,1:"IB334; ") .. Q . Q ; Q OK ; LNPRV2(IBP RVFUN,IBLN PRV) ; Fun ction - Ed it Check ( 2) for lin e level pr ovider. ; See Edit C heck (2) a t top of r outine for details. ; ; Input: ; IBPRVFU N - Provid er Type (F UNCTION). Example: R ENDERING. ; IBLNPRV( Array) - P assed by r eference. Intially u ndefined. ; ; Output : ; OK - I f Edit Che ck (2) lin e level pr ovider con dition has ; been me t, then OK will retu rn '1' for TRUE, ELS E, '0' ; f or FALSE. ; *See Edi t Check (2 ) at top o f routine for detail s. ; IBLNP RV(Array) - If Edit Check (2) condition has been m et, ; then IBLNPRV w ill contai n the prov ider type, ; and pro vider vari able point er as arra y ; subscr ipts, and array elem ent is SET to ; NULL . => IBLNP RV(IBPRVFU N,IBLNPROV )="". ; N OK,IBPROCP ,IBLPIEN,I BLNPROV S IBPROCP=0 F S IBPRO CP=$O(^DGC R(399,IBIF N,"CP",IBP ROCP)) Q:' IBPROCP D I $D(OK) ,'OK Q . Q :'($D(^DGC R(399,IBIF N,"CP",IBP ROCP,0))#1 0) . I '$D (^DGCR(399 ,IBIFN,"CP ",IBPROCP, "LNPRV","C ",IBPRVFUN )) S OK=0 Q ; No li ne provide r function for this procedure. . S IBLPI EN=$O(^DGC R(399,IBIF N,"CP",IBP ROCP,"LNPR V","C",IBP RVFUN,0)) . I 'IBLPI EN S OK=0 Q ; No li ne provide r IEN for this line provider f unction. . I '($D(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV",IBLPI EN,0))#10) S OK=0 Q ; No zero node for line level provider. . S IBLNP ROV=$P(^DG CR(399,IBI FN,"CP",IB PROCP,"LNP RV",IBLPIE N,0),"^",2 ) . I 'IBL NPROV S OK =0 Q ; No line prov ider for t his line p rovider fu nction. . S IBLNPRV( IBPRVFUN,I BLNPROV)=" " . Q ; Q: $D(OK) OK ; OK will never equ al '1' for TRUE at t his point. I '$D(OK) ,'$D(IBLNP RV(IBPRVFU N)) S OK=0 Q OK ; N o line pro vider arra y for this line prov ider funct ion. S OK= 1 ; Edit C heck (2) l ine provid er conditi on has bee n met. Q O K ;CLPRV2( IBPRVFUN,I BCLPRV) ; Function - Edit Chec k (2) for claim leve l provider . ; See Ed it Check ( 2) at top of routine for detai ls. ; ; In put: ; IBP RVFUN - Pr ovider Typ e (FUNCTIO N). Exampl e: RENDERI NG. ; IBCL PRV(Array) - Passed by referen ce. Intial ly undefin ed. ; ; Ou tput: ; OK - If Edit Check (2) claim lev el provide r conditio n has ; be en met, th en OK will return '1 ' for TRUE , ELSE, '0 ' ; for FA LSE. ; *Se e Edit Che ck (2) at top of rou tine for d etails. ; IBCLPRV(Ar ray) - If Edit Check (2) condi tion has b een met, ; then IBCL PRV will c ontain the provider type, ; an d provider variable pointer as array ; s ubscripts, and array element i s SET to ; NULL. => IBCLPRV(IB PRVFUN,IBC LPROV)="". ; N IBCLP IEN,IBCLPR OV,OK S OK =0 ; Initi alize OK=0 for FALSE . S IBCLPI EN=0 F S IBCLPIEN=$ O(^DGCR(39 9,IBIFN,"P RV","C",IB PRVFUN,IBC LPIEN)) Q: 'IBCLPIEN D Q:OK . Q:'($D(^D GCR(399,IB IFN,"PRV", IBCLPIEN,0 ))#10) . S IBCLPROV= $P(^DGCR(3 99,IBIFN," PRV",IBCLP IEN,0),"^" ,2) . Q:'I BCLPROV . S IBCLPRV( IBPRVFUN,I BCLPROV)=" " ; Set a rray for E dit Check (2) to com pare claim level pro vider with line leve l provider . . S OK=1 ; At this point we have our c laim level provider of provide r type IBP RVFUN. Set OK=1 for TRUE. . Q ; Q:'OK OK S OK=1 Q OK ;OPPROV CK(IBIFN) ; DEM;432 - Other Op erating Pr ovider edi t checks. ; ; Input: ; IBIFN - Claim num ber IEN. ; ; Output: ; OK - '1 ' Edits ; '0' No Edi ts. ; *Not e: OK retu rned if ca lled as fu nction ($$ ). ; Can b e called a s routine as well. ; ; Patch 4 32 line le vel Other Operating Provider E dit checks : ; ; (1) If claim l evel Other Operating Provider, then ; (1 .1) claim must have claim leve l Operatin g Provider . ; OR ; ( 1.2) every line must have Oper ating Prov ider. ; ; If (1) Pas ses, then do edit ch eck (2) be low. ; ; ( 2) If any claim line has Other Operating Provider, then ; (2 .1) must h ave Operat ing Provid er on same claim lin e, ; OR ; (2.2) must have clai m level Op erating Pr ovider. ; N OK S OK= 0 ; Initia lize OK=0 for FALSE. Q:'$G(IBI FN) OK ; Need claim number IE N to conti nue. S:'$G (IBFT) IBF T=$$FT^IBC EF(IBIFN) ; Form Typ e for clai m. ; JWS;I B*2.0*592 US1108 - D ental form check I IBFT'=2,IB FT'=3,IBFT '=7 Q OK ; Must be CMS-1500 ( 2) or UB-0 4 (3) Form Type or ( 7) Dental J430D ; N IBPRVFUN,I BLNFLAG,IB LNPRV,CLOK ,LNOK ; ; Note: Clai m level pr ovider - O THER and O THER OPERA TING are t he same. ; Check if condition (1) has be en met. F IBPRVFUN=" OTHER","OT HER OPERAT ING" S CLO K=$$CLOPPR V1(IBPRVFU N) Q:CLOK Q:'CLOK OK ; No cla im level O THER OPERA TING PROVI DER, then QUIT, no f urther che cks. S OK= 0 ; Initia lize OK=0 for FALSE. ; Condit ion (1) ha s been met , check co ndtion (1. 1). S CLOK =0 ; Initi alize CLOK =0 for FAL SE. I $D(^ DGCR(399,I BIFN,"PRV" ,"C","OPER ATING")) S IBPRVFUN= "OPERATING ",CLOK=$$C LOPPRV1(IB PRVFUN) ; Check cond ition (1.1 ). ; If CL OK at this point, th en skip co ndition ch eck (1.2) and contin ue to cond ition (2). S LNOK=0 ; Initiali ze LNOK=0 for FALSE. I 'CLOK S IBPRVFUN= "OPERATING ",LNOK=$$L NOPPRV1(IB PRVFUN) I 'LNOK S OK =1 Q OK ; Check con dition (1. 2). If 'LN OK, then w e have an error and QUIT. ; If LNOK, the n continue to condit ion check (2). S LNO K=0 ; Init ialize LNO K=0 for FA LSE. K IBL NPRV ; KI LL IBLNPRV array bef ore call t o $$LNOPPR V1(IBPRVFU N,1,.IBLNP RV). S IBP RVFUN="OTH ER OPERATI NG",LNOK=$ $LNOPPRV1( IBPRVFUN,1 ,.IBLNPRV) ; Conditi on check ( 2) start. I '$D(IBLN PRV("PRVFU N")) S OK= 0 Q OK ; If no data in IBLNPR V("PRVFUN" ) array, t hen skip r est of che cks, no er ror. ; If data in IB LNPRV("PRV FUN") arra y, then ch eck condit ion (2.1). S IBPRVFU N="OPERATI NG",LNOK=$ $LNOPPRV1( IBPRVFUN,1 ,.IBLNPRV) ; Conditi on check ( 2.1) start . S LNOK=0 ; Initial ize LNOK=0 for FALSE . D:$D(IBL NPRV("PRVF UN")) ; If data in I BLNPRV("PR VFUN") arr ay, then c ontinue co ndition ch eck (2.1). . N IBPRO CP . S IBP ROCP=0 F S IBPROCP= $O(IBLNPRV ("PROC",IB PROCP)) Q: 'IBPROCP D Q:'LNOK . . I $D( IBLNPRV("P ROC",IBPRO CP,"OTHER OPERATING" )),'$D(IBL NPRV("PROC ",IBPROCP, "OPERATING ")) S LNOK =0 Q . . S LNOK=1 ; At this po int, we ha ve at leas t one matc h. If ther e wasn't a match, th en LNOK=0 and we wou ld have QU IT. . . Q . Q I LNOK S OK=0 Q OK ; Cond itions (2) and (2.1) are met ( no error). SET OK=0 and QUIT. ; If 'LNOK , then con tinue to c ondition c heck (2.2) . S CLOK=0 ; Initial ize CLOK=0 for FALSE . S IBPRVF UN="OPERAT ING",CLOK= $$CLOPPRV1 (IBPRVFUN) ; Conditi on check ( 2.2). I CL OK S OK=0 Q OK ; Co nditions ( 2) and (2. 2) are met (no error ). SET OK= 0 and QUIT . ; At thi s point, w e have an error. SET OK=1, and QUIT. S O K=1 Q OK ; CLOPPRV1(I BPRVFUN) ; Claim lev el provide r/provider function check. ; ; Check if there is a claim lev el provide r with pro vider func tion IBPRV FUN. ; ; I nput: ; IB PRVFUN - P ROVIDER FU NCTION. ; ; Output: ; OK - '1' Claim lev el provide r exist fo r provider function IBPRVFUN. ; '0' No C laim level provider exist for provider f unction IB PRVFUN. ; N OK,IBCLP IEN,IBCLPR OV S OK=0 ; Initiali ze OK=0 fo r FALSE. ; I $D(^DGC R(399,IBIF N,"PRV","C ",IBPRVFUN )) D . S I BCLPIEN=0 F S IBCLP IEN=$O(^DG CR(399,IBI FN,"PRV"," C",IBPRVFU N,IBCLPIEN )) Q:'IBCL PIEN D Q :OK . . Q: '($D(^DGCR (399,IBIFN ,"PRV",IBC LPIEN,0))# 10) . . S IBCLPROV=$ P(^DGCR(39 9,IBIFN,"P RV",IBCLPI EN,0),U,2) . . Q:'IB CLPROV . . S OK=1 ; At this po int we hav e claim le vel provid er with pr ovider fun ction IBPR VFUN and c an QUIT fu nction/sub routine. . . Q . Q ; Q OK ;LNO PPRV1(IBPR VFUN,IBLNF LAG,IBLNPR V,IBPROCHK ) ; Check every clai m line for provider function I BPRVFUN. ; ; ; Input : ; IBPRVF UN - PROVI DER FUNCTI ON. ; IBLN FLAG(Optio nal) = 1 o r 0. 1 ind icates ret urn IBLNPR V array pa ssed by re ference, o therwise ' 0' for NO. ; IBLNPRV (Optional) - Array p assed by r eference = > IF SET O K=1, then ; I $G(IBL NFLAG) S I BLNPRV("PR OC",IBPROC P,IBPRVFUN )="",IBLNP RV("PRVFUN ",IBPRVFUN ,IBPROCP)= "" ; IBPRO CHK - Cond ition on P ROCEDURE ( ICD, CPT, or HCFA pr ocedure co des). ; ; Output: ; OK - '1' E very line level prov ider exist for provi der functi on IBPRVFU N. ; '0' N ot every l ine level provider e xist for p rovider fu nction IBP RVFUN. ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. ; N IBLPIE N,IBLNPROV ,IBPROCP S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:($D(^ DGCR(399,I BIFN,"CP", IBPROCP,0) )#10)&('OK ) . Q:'($D (^DGCR(399 ,IBIFN,"CP ",IBPROCP, 0))#10) ; No procedu re '0' nod e. . I $G( IBPROCHK)' ="" Q:$P(^ DGCR(399,I BIFN,"CP", IBPROCP,0) ,U,1)'[IBP ROCHK . I '$D(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,"C",IBPRV FUN)) S OK =0 Q ; No line prov ider funct ion IBPRVF UN for thi s procedur e. . S IBL PIEN=$O(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV","C",I BPRVFUN,0) ) . I 'IBL PIEN S OK= 0 Q ; No line provi der IEN fo r this lin e provider function. . I '($D( ^DGCR(399, IBIFN,"CP" ,IBPROCP," LNPRV",IBL PIEN,0))#1 0) S OK=0 Q ; No '0 ' node for line leve l provider . . S IBLN PROV=$P(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV",IBLPI EN,0),U,2) . I 'IBLN PROV S OK= 0 Q ; No line provi der for th is line pr ovider fun ction. . ; At this p oint we ha ve line le vel provid er of type IBPRVFUN. . ; S OK= 1 for this claim lin e. OK can be changed back to ' 0', for FA LSE, if cl aim line f ails condi tion. . ; We would n ot get to this point if any li ne level p rovider wi th provide r function IBPRVFUN didn't exi st. . S OK =1 . I $G( IBLNFLAG) S IBLNPRV( "PROC",IBP ROCP,IBPRV FUN)="",IB LNPRV("PRV FUN",IBPRV FUN,IBPROC P)="" . Q ; Q OK ;UB PRVCK(IBIF N) ; DEM;4 32 - Check if claim requires o perating p rovider. ; ; Descrip tion: This function checks if claim requ ires an op erating pr ovider. ; ; Checks: ; ; (1) If claim has a claim l evel opera ting provi der, ; the n no furth er checks (OK=1=TRUE ). ; (2) I f claim do esn't have a claim l evel opera ting provi der, ; the n check: ; (2.1) Is this a UB- 04 claim? NO = QUIT (OK=1), YE S = Contin ue to next check. ; (2.2) Chec k every cl aim line t hat includ es HCPCS p rocs - ope rating pro vider. ; I f every cl aim line t hat includ es HCPCS p rocs has a n operatin g provider , ; then w e are OK a nd QUIT (O K=1). ; If any claim line that includes HCPCS proc s doesn't have an op erating ; provider, then we ha ve an ERRO R (OK=0). ; ; Input : ; IBIFN = Claim nu mber IEN. ; ; Output : ; OK = 0 = claim d oesn't hav e an opera ting provi der ; when operating provider or renderi ng provide r required . ; OK = 1 = claim h as an oper ating prov ider, or, ; claim do esn't requ ire operat ing provid er. ; N OK ; If clai m doesn't have any p rocedure c odes, then no checks required. I '$O(^DG CR(399,IBI FN,"CP",0) ) S OK=1 Q OK ; S OK =$$CLOPPRV 1("OPERATI NG") ; Do we have a claim leve l OPERATIN G PROVIDER (OK=1=TRU E)? Q:OK O K ; QUIT, we have a claim lev el OPERATI NG PROVIDE R (OK=1=TR UE). ; N I BFT S IBFT =($$FT^IBC EF(IBIFN)= 3) ; UB-04 claim (1 = TRUE, 0 = FALSE)? S OK=1 ; I nitialize OK=1. Q:'I BFT OK ; QUIT OK=1, not a UB- 04 claim. ; ; Claim level chec k did not pass, chec k claim li nes. ; No claim leve l OPERATIN G PROVIDER , so check every PRO CEDURE for OPERATING PROVIDER. S OK=$$UB PRVCK1("") ; Does ev ery proced ure have a n OPERATIN G PROVIDER (1=TRUE,0= FALSE)? ; Q OK ;UBPR VCK1(IBPRO CHK,IBONE) ; DEM;432 - Continu ation of U BPRVCK fun ction. ; ; Input: ; IBPROCHK(O ptional) - Optional condition on PROCEDU RE CODE (I CD, CPT, o r HCFA pro cedure cod es). ; IBO NE(Optiona l) - Quit if at leas t one line has an OP ERATING ; ; Output: ; OK - '1' Every pro cedure cod e that con tains IBPR OCHK (opti onal check ) has an O PERATING P ROVIDER. ; or if IBO NE, then a t least on e procedur e code tha t contains IBPROCHK (optional check) has an OPERAT ING PROVID ER. ; '0' Not every procedure code that contains I BPROCHK (o ptional ch eck) has a n OPERATIN G PROVIDER . ; or if IBONE, the n NO proce dure codes that cont ain IBPROC HK (option al check) has an OPE RATING PRO VIDER. ; N OK S OK=0 ; Initial ize OK=0 f or FALSE. ; N IBLPIE N,IBLNPROV ,IBPROCP S IBPROCP=0 F S IBPR OCP=$O(^DG CR(399,IBI FN,"CP",IB PROCP)) Q: 'IBPROCP D Q:($D(^ DGCR(399,I BIFN,"CP", IBPROCP,0) )#10)&('OK )&('$G(IBO NE)) I $G( IBONE),$G( OK) Q . Q: '($D(^DGCR (399,IBIFN ,"CP",IBPR OCP,0))#10 ) ; No pro cedure '0' node. . I $G(IBPROC HK)'="" Q: $P(^DGCR(3 99,IBIFN," CP",IBPROC P,0),U,1)' [IBPROCHK . I '$D(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV","C"," OPERATING" )) S OK=0 Q ; No li ne OPERATI NG PROVIDE R for this procedure . . S IBLP IEN=$O(^DG CR(399,IBI FN,"CP",IB PROCP,"LNP RV","C","O PERATING", 0)) . I 'I BLPIEN S O K=0 Q ; N o line pro vider IEN for this l ine provid er functio n. . I '($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,"LNPRV",I BLPIEN,0)) #10) S OK= 0 Q ; No '0' node f or line le vel provid er. . S IB LNPROV=$P( ^DGCR(399, IBIFN,"CP" ,IBPROCP," LNPRV",IBL PIEN,0),U, 2) . I 'IB LNPROV S O K=0 Q ; N o line pro vider for this line provider f unction. . ; At this point we have line level prov ider of ty pe OPERATI NG. . ; S OK=1 for t his claim line. OK c an be chan ged back t o '0', for FALSE, if claim lin e fails co ndition. . ; We woul d not get to this po int if any line leve l provider with prov ider funct ion OPERAT ING didn't exist. . S OK=1 . Q ; Q OK | |
| 922 | ||
| 923 | ||
| 924 | Routines | |
| 925 | Activities | |
| 926 | Routine Na me | |
| 927 | IBCBB3 | |
| 928 | Enhancemen t Category | |
| 929 | New | |
| 930 | Modify | |
| 931 | Delete | |
| 932 | No Change | |
| 933 | RTM | |
| 934 | ||
| 935 | Related Op tions | |
| 936 | None | |
| 937 | Related Ro utines | |
| 938 | Routines “ Called By” | |
| 939 | Routines “ Called” | |
| 940 | ||
| 941 | ||
| 942 | ||
| 943 | ||
| 944 | Data Dicti onary (DD) Reference s | |
| 945 | ||
| 946 | Related Pr otocols | |
| 947 | None | |
| 948 | Related In tegration Control Re gistration s (ICRs) | |
| 949 | None | |
| 950 | Data Passi ng | |
| 951 | Input | |
| 952 | Output Re ference | |
| 953 | Both | |
| 954 | Global Re ference | |
| 955 | Local | |
| 956 | Input Attr ibute Name and Defin ition | |
| 957 | Name: | |
| 958 | Definition : | |
| 959 | Output Att ribute Nam e and Defi nition | |
| 960 | Name: | |
| 961 | Definition : | |
| 962 | Current Lo gic | |
| 963 | IBCBB3 ;AL B/TMP - CO NTINUATION OF EDIT C HECKS ROUT INE (MEDIC ARE) ;06/2 3/98 ;;2.0 ;INTEGRATE D BILLING; **51,137,1 55,349,371 ,377,432** ;21-MAR-94 ;Build 192 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;E DITMRA(IBQ UIT,IBER,I BIFN,IBFT) ; ; Requi res execut ion of GVA R^IBCBB, I BIFN defin ed ; File IB ERROR ( 350.8) con tains erro r codes/te xt ; N IBM RATYP,Z,IB ZP,IBZP1,I BOK S IBQU IT=0 ;Flag to say we have too many error s - quit e dits ; S I BMRATYP=$$ MRATYPE^IB EFUNC(IBIF N,"C") ; I IBFT=3 D . D PARTA ; I IBFT=2 D PARTB^I BCBB9 ; K IBXDATA D F^IBCEF("N -ADMITTING DIAGNOSIS ",,,IBIFN) ; Req. fo r UB-04 ty pe of bill s 11x!18x I $G(IBXDA TA)="",IBF T=3 D Q:I BQUIT . N Z . I "^11 ^18^"[(U_I BTOB12_U) S IBQUIT=$ $IBER(.IBE R,231) Q . I $$INPAT ^IBCEF(IBI FN,1) S Z= "Admitting Diagnosis may be re quired by payer, ple ase verify " D WARN^I BCBB11(Z) ; D GETPRV ^IBCEU(IBI FN,"2,3,4" ,.Z) S IBO K=1,Z=0,IB ZP=U F S Z=$O(Z(Z)) Q:'Z S:$ S($P($G(Z( Z,1)),U,3) ["VA(200": 1,1:0) IBZ P=IBZP_+$P (Z(Z,1),U, 3)_U D ALL PROC^IBCVA 1(IBIFN,.I BZP1) ;pat ch 432, en h5: The IB system sh all no lon ger provid e users wi th a warni ng message when auth orizing a claim when line leve l and clai m level pr oviders ar e not the same. ;S Z =0 F S Z=$ O(IBZP1(Z) ) Q:'Z I $ P(IBZP1(Z) ,U,18),IBZ P'[(U_$P(I BZP1(Z),U, 18)_U) S I BOK=0 Q ;I 'IBOK D W ARN^IBCBB1 1("At leas t one prov ider on a procedure does not m atch your "_$S(IBFT= 2:"render" ,1:"attend ")_"ing or operating provider" ) I IBFT=2 D EN^IBCB B2 ; edit checks for UB-04 (in stitutiona l) forms I IBFT=3 D EN^IBCBB21 (.IBZPRC92 ) ; Q ;PAR TA ; MEDIC ARE specif ic edit ch ecks for P ART A clai ms (UB-04 formats) ; N IBI,IBJ ,IBX,IBCTY P,VADM,VAP A,IBSTOP,I BDXC,IBDXA RY,IBPR,IB LABS,REQMR A N IBS,IB TUNIT,IBCA GE,IBREV1, IBOCCS,IBO CSDT,IBVAL CD,IBOCCD, IBNOPR N I BCCARY1,IB PATST,IBZA DMIT,IBZDI SCH,IBXIEN ,IBXERR,IB XDATA,IBOC SP N IBCOV ,IBNCOV,IB REVC,IBREV DUP,IBBCPT ,IBREVC12, IBREVTOT,I BECAT,IBIN C ; ; Medi care is th e current payer, but no diagno sis codes I $$WNRBIL L^IBEFUNC( IBIFN) D S ET^IBCSC4D (IBIFN,.IB DX,.IBDXO) I '$P(IBD X,U,2) S I BQUIT=$$IB ER(.IBER,1 20) Q:IBQU IT ; ; Typ e of Bill must be th ree digits I IBTOB'? 3N S X=$$I BER(.IBER, 103) Q ; ; Covered D ays S IBCT YP=0 S IBC OV=$P(IBND U2,U,2),IB NCOV=$P(IB NDU2,U,3) ; ; If int erim bill, covered d ays must n ot be grea ter than 6 0 ; remove for IB*2. 0*432 ; I "23"[$E(IB TOB,3),IBC OV>60 S IB QUIT=$$IBE R(.IBER,"0 96") Q:IBQ UIT ; ; I bill type is 11x or 18x or 21x then we n eed covere d days ; r emove for IB*2.0*432 ; I "^11^ 18^21^"[(U _IBTOB12_U ) S IBCTYP =1 I IBCOV ="" S IBQU IT=$$IBER( .IBER,106) Q:IBQUIT ; S (IBI,I BJ)=0 K IB XDATA D F^ IBCEF("N-C ONDITION C ODES",,,IB IFN) ; Re- sort the c ondition c odes by co de S IBI=0 F S IBI= $O(IBXDATA (IBI)) Q:' IBI S IBC CARY1($P(I BXDATA(IBI ),U))="" ; ; for con dition cod e 40, cove red days m ust be 0 ; remove fo r IB*2.0*4 32 ; I $D( IBCCARY1(4 0)),IBCOV' =0 S IBQUI T=$$IBER(. IBER,107) Q:IBQUIT ; ; cov day s+non=to d ate -from date unles s the pati ent status = 30 (sti ll ; pt) o r outpatie nt or if t he to date and from date are s ame then a dd 1 S IBP ATST="",IB X=$P(IBNDU ,U,12),IBP ATST=$P($G (^DGCR(399 .1,+IBX,0) ),U,2) S I BINC=$S(IB PATST=30!( IBFDT=IBTD T):1,1:0) ; remove f or IB*2.0* 432 ;I $$I NPAT^IBCEF (IBIFN,1), (IBCOV+IBN COV)'=($$F MDIFF^XLFD T(IBTDT,IB FDT)+IBINC ) S IBQUIT =$$IBER(.I BER,108) Q :IBQUIT ; ; if cover ed days >1 00 and typ e of bill is 21x or 18x error ; remove f or IB*2.0* 432 ; I IB COV>100,(I BTOB12=18! (IBTOB12=2 1)) S IBQU IT=$$IBER( .IBER,109) Q:IBQUIT ; S (IBJ,I BTUNIT,IBS ,IBREVTOT( "AC"),IBRE VTOT("AI") ,IBREVTOT( "AO"),IBRE VTOT)=0 ; K IBXDATA D F^IBCEF( "N-UB-04 S ERVICE LIN E (EDI)",, ,IBIFN) ;G et rev cod es ; ; Re- sort the r evenue cod es by code ;>> IBREV 1(rev code ,x)=Rev co de^ptr cpt ^unit chg^ units^tota l^tot unc ; IBREV1(r ev code) = revenue c ode edit c ategory ; ; IBNOPR = flag that determine s if there are reven ue codes w ith ; char ges that d o not have a procedu re - no ne ed to chec k ; for bi llable MCR procedure s if at le ast one RC is billab le ; 1 = t here is at least one billable revenue co de without a ; proce dure ; S R EQMRA=$$RE QMRA^IBEFU NC(IBIFN) S (IBNOPR, IBI)=0 F S IBI=$O(I BXDATA(IBI )) Q:'IBI D . I REQ MRA D GYMO DCHK(IBXDA TA(IBI)) ; IB*2*377 GY modifie r check . S IBJ=$P(I BXDATA(IBI ),U),IBECA T="" . I ' IBNOPR D . . I $P(IBX DATA(IBI), U,2)'="" S IBPR($P(I BXDATA(IBI ),U,2))=IB I Q .. S I BNOPR=1 K IBPR . S:$ D(IBREV1(I BJ)) IBECA T=$G(IBREV 1(IBJ)) . I '$D(IBRE V1(IBJ))!( IBECAT="") D S IBRE V1(IBJ)=IB ECAT . . ; . . ; Acc omodations (AC) . . I (IBJ'<10 0&(IBJ'>21 9))!(IBJ=2 24) S IBEC AT="AC" Q . . ; . . ; Ancillar y Outpatie nt (AO) . . I '$$INP AT^IBCEF(I BIFN,1) S IBECAT="AO " Q . . ; . . ; Anci llary Inpa tient (AI) . . S IBE CAT="AI" . ; . S IBR EV1(IBJ,+$ O(IBREV1(I BJ,""),-1) +1)=IBXDAT A(IBI) . S IBREVTOT( IBECAT)=IB REVTOT(IBE CAT)+$P(IB XDATA(IBI) ,U,6) . I IBECAT="AC " S IBTUNI T=IBTUNIT+ $P(IBXDATA (IBI),U,4) ; I $$NEE DMRA^IBEFU NC(IBIFN), $O(IBPR("" ))'="" D Q:IBQUIT . ; Don't a llow a bil l containi ng only bi llable pro cedures fo r: . ; Oxy gen, labs, or influe nza shots . ; OR a b ill with p rosthetics on it . ; to be sen t to MEDIC ARE for an MRA . D N ONMCR(.IBP R,.IBLABS) ; Remove Oxygen, la bs, influe nza shots . I $G(IBL ABS) D WAR N^IBCBB11( "There are Lab proce dures on t his claim. "),WARN^IB CBB11("Ple ase verify that MEDI CARE does not reimbu rse these labs at 10 0%") Q . I $O(IBPR(" "))="" D . . S IBQUIT =$$IBER(.I BER,"098") ; ; cover ed days+no n covered = units of accom rev codes ; C heck room and board ; remove f or IB*2.0* 432 ;I IBT UNIT,IBTUN IT'=(IBCOV +IBNCOV) S IBQUIT=$$ IBER(.IBER ,114) Q:IB QUIT ; ; N on Covered Days ; re quired whe n the type of bill i s 11x,18x, 21x or cov ered days= 0 ; remove for IB*2. 0*432 ; I IBNCOV="", (IBCTYP!(I BCOV=0)) S IBQUIT=$$ IBER(.IBER ,115) Q:IB QUIT ; ; i f cc code= 40 then no n-covered days must be 1 ; rem ove for IB *2.0*432 ; I $D(IBCC ARY1(40)), IBNCOV'=1 S IBQUIT=$ $IBER(.IBE R,116) Q:I BQUIT ; ; Patient Se x ; must b e "M" or " F" D DEM^V ADPT I $P( VADM(5),U) '="M",$P(V ADM(5),U)' ="F" S IBQ UIT=$$IBER (.IBER,124 ) Q:IBQUIT ; ; esg - 10/17/07 - patch 37 1 ; For Pa rt A repla cement MRA request c laims, mak e sure ; t he Medicar e ICN/DCN number is present an d also tex t in FL-80 . I $$REQM RA^IBEFUNC (IBIFN),$F (".137.138 .117.118." ,"."_IBTOB _".") D Q :IBQUIT . N IBZ,FL80 TXT . D F^ IBCEF("N-C URR INS FO RM LOC 64" ,"IBZ",,IB IFN) ; see CI3-11 . I IBZ="" S IBQUIT=$$ IBER(.IBER ,205) Q:IB QUIT ; missing ICN/DCN . S FL80TXT= $P($G(^DGC R(399,IBIF N,"UF2")), U,3) . I F L80TXT="" S IBQUIT=$ $IBER(.IBE R,206) Q:I BQUIT ; m issing FL8 0 text . Q ; D ^IBCB B4 Q ;IBER (IBER,ERRN O) ; Sets error list ; NOTE: a dd code to check err or list > 20 ... If so, displa y message and ; quit so we don 't get too many erro rs at once to handle ; Print a ll if prin ting list ; I '$G(IB QUIT) D . I ERRNO?1N .N S:$L(ER RNO)<3 ERR NO=$E("00" ,1,3-$L(ER RNO))_ERRN O . I $L(I BER,";")>1 9,'$G(IBPR T("PRT")) S IBER=IBE R_"IB999;" ,IBQUIT=1 . I $G(IBE R)'[("IB"_ ERRNO_";") S IBER=IB ER_"IB"_ER RNO_";" Q IBQUIT ;NO NMCR(IBPR, IBLABS) ; Delete all oxygen an d lab, flu shot CPT entries fr om IBPR ; IBPR = arr ay subscri pted by CP T codes fr om bill ; IBLABS = f lag return ed =1 if l abs found on bill N Z S IBLABS =0 ; Oxyge n F Z="A04 22","A4575 ","A4616", "A4619","A 4620","A46 21","E0455 ","E1353", "E1355" K IBPR(Z) F Z=77:1:85 S Z0="E13" _Z K IBPR( Z0) ; Labs S Z="8000 0" F S Z= $O(IBPR(Z) ) Q:Z'?1"8 "4N S IBL ABS=1 ; Fl u shots F Z="90724", "G0008","9 0732","G00 09","90657 ","90658", "90659","9 0660" K IB PR(Z) Q ;M CRANUM(IBI FN) ; Dete rmine MEDI CARE A pro vider ID # from beds ection for ; bill ie n IBIFN N IBX ; PART A MRA (on ly) needed - determi ne if psyc h/non-psyc h claim N IBX,IBI S IBI=$P($G( ^DGCR(399, IBIFN,"U") ),U,11) S IBX=$S($TR ($P($G(^DG CR(399.1,+ IBI,0)),U) ,"psych"," PSYCH")'[" PSYCH":670 899,1:6744 99) Q IBX ;MCRACK(IB IFN,X,IBFL D) ; Check for MEDIC ARE A for bill IBIFN ; Called from CLAIM STATUS MR A field (# 24) xrefs in file 39 9 ; X = cu rrent valu e of field 399;24 ; IBFLD = 1 for primar y ins co, 2 for seco ndary, 3 f or tertiar y N IB S I B=0 I +X,$ $COBN^IBCE F(IBIFN)=I BFLD,$$WNR BILL^IBEFU NC(IBIFN,I BFLD),$$MR ATYPE^IBEF UNC(IBIFN, "C")="A" S IB=1 Q IB ;GYMODCHK (Z) ; GY m odifier ch eck proced ure. IB*2* 377 - 2/4/ 08 ; Z is the IBXDAT A(IBI) ser vice line EDI N MODS I IBER["I B123" Q ; error already fo und S MODS =$P(Z,U,9) ; list of modifiers separated by commas I MODS'[" GY" Q ; GY mod ifier not here on th is line it em I $P(Z, U,6) Q ; non- covered ch arges exis t on this line item S IBQUIT=$ $IBER(.IBE R,123)GYMO DX ; Q ; | |
| 964 | Modified L ogic (Chan ges are in bold) | |
| 965 | IBCBB3 ;AL B/TMP - CO NTINUATION OF EDIT C HECKS ROUT INE (MEDIC ARE) ;06/2 3/98 ;;2.0 ;INTEGRATE D BILLING; **51,137,1 55,349,371 ,377,432,5 92**;21-MA R-94;Build 192 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . ;EDITMRA (IBQUIT,IB ER,IBIFN,I BFT) ; ; R equires ex ecution of GVAR^IBCB B, IBIFN d efined ; F ile IB ERR OR (350.8) contains error code s/text ; N IBMRATYP, Z,IBZP,IBZ P1,IBOK S IBQUIT=0 ; Flag to sa y we have too many e rrors - qu it edits ; S IBMRATY P=$$MRATYP E^IBEFUNC( IBIFN,"C") ; I IBFT= 3 D . D PA RTA ;JWS;I B*2.0*592 US1108 - D ental form check I I BFT=2!(IBF T=7) D PAR TB^IBCBB9 ; K IBXDAT A D F^IBCE F("N-ADMIT TING DIAGN OSIS",,,IB IFN) ; Req . for UB-0 4 type of bills 11x! 18x I $G(I BXDATA)="" ,IBFT=3 D Q:IBQUIT . N Z . I "^11^18^"[ (U_IBTOB12 _U) S IBQU IT=$$IBER( .IBER,231) Q . I $$I NPAT^IBCEF (IBIFN,1) S Z="Admit ting Diagn osis may b e required by payer, please ve rify" D WA RN^IBCBB11 (Z) ; D GE TPRV^IBCEU (IBIFN,"2, 3,4",.Z) S IBOK=1,Z= 0,IBZP=U F S Z=$O(Z (Z)) Q:'Z S:$S($P($ G(Z(Z,1)), U,3)["VA(2 00":1,1:0) IBZP=IBZP _+$P(Z(Z,1 ),U,3)_U D ALLPROC^I BCVA1(IBIF N,.IBZP1) ;patch 432 , enh5: Th e IB syste m shall no longer pr ovide user s with a w arning mes sage when authorizin g a claim when line level and claim leve l provider s are not the same. ;S Z=0 F S Z=$O(IBZP 1(Z)) Q:'Z I $P(IBZP 1(Z),U,18) ,IBZP'[(U_ $P(IBZP1(Z ),U,18)_U) S IBOK=0 Q ;I 'IBOK D WARN^IB CBB11("At least one provider o n a proced ure does n ot match y our "_$S(I BFT=2:"ren der",1:"at tend")_"in g or opera ting provi der") ; JW S;IB*2.0*5 92 US1108 - Dental f orm check I IBFT=2! (IBFT=7) D EN^IBCBB2 ; edit ch ecks for U B-04 (inst itutional) forms I I BFT=3 D EN ^IBCBB21(. IBZPRC92) ; Q ;PARTA ; MEDICAR E specific edit chec ks for PAR T A claims (UB-04 fo rmats) ; N IBI,IBJ,I BX,IBCTYP, VADM,VAPA, IBSTOP,IBD XC,IBDXARY ,IBPR,IBLA BS,REQMRA N IBS,IBTU NIT,IBCAGE ,IBREV1,IB OCCS,IBOCS DT,IBVALCD ,IBOCCD,IB NOPR N IBC CARY1,IBPA TST,IBZADM IT,IBZDISC H,IBXIEN,I BXERR,IBXD ATA,IBOCSP N IBCOV,I BNCOV,IBRE VC,IBREVDU P,IBBCPT,I BREVC12,IB REVTOT,IBE CAT,IBINC ; ; Medica re is the current pa yer, but n o diagnosi s codes I $$WNRBILL^ IBEFUNC(IB IFN) D SET ^IBCSC4D(I BIFN,.IBDX ,.IBDXO) I '$P(IBDX, U,2) S IBQ UIT=$$IBER (.IBER,120 ) Q:IBQUIT ; ; Type of Bill mu st be thre e digits I IBTOB'?3N S X=$$IBE R(.IBER,10 3) Q ; ; C overed Day s S IBCTYP =0 S IBCOV =$P(IBNDU2 ,U,2),IBNC OV=$P(IBND U2,U,3) ; ; If inter im bill, c overed day s must not be greate r than 60 ; remove f or IB*2.0* 432 ; I "2 3"[$E(IBTO B,3),IBCOV >60 S IBQU IT=$$IBER( .IBER,"096 ") Q:IBQUI T ; ; I bi ll type is 11x or 18 x or 21x t hen we nee d covered days ; rem ove for IB *2.0*432 ; I "^11^18 ^21^"[(U_I BTOB12_U) S IBCTYP=1 I IBCOV=" " S IBQUIT =$$IBER(.I BER,106) Q :IBQUIT ; S (IBI,IBJ )=0 K IBXD ATA D F^IB CEF("N-CON DITION COD ES",,,IBIF N) ; Re-so rt the con dition cod es by code S IBI=0 F S IBI=$O (IBXDATA(I BI)) Q:'IB I S IBCCA RY1($P(IBX DATA(IBI), U))="" ; ; for condi tion code 40, covere d days mus t be 0 ; r emove for IB*2.0*432 ; I $D(IB CCARY1(40) ),IBCOV'=0 S IBQUIT= $$IBER(.IB ER,107) Q: IBQUIT ; ; cov days+ non=to dat e -from da te unless the patien t status = 30 (still ; pt) or outpatient or if the to date a nd from da te are sam e then add 1 S IBPAT ST="",IBX= $P(IBNDU,U ,12),IBPAT ST=$P($G(^ DGCR(399.1 ,+IBX,0)), U,2) S IBI NC=$S(IBPA TST=30!(IB FDT=IBTDT) :1,1:0) ; remove for IB*2.0*43 2 ;I $$INP AT^IBCEF(I BIFN,1),(I BCOV+IBNCO V)'=($$FMD IFF^XLFDT( IBTDT,IBFD T)+IBINC) S IBQUIT=$ $IBER(.IBE R,108) Q:I BQUIT ; ; if covered days >100 and type of bill is 21x or 18 x error ; remove for IB*2.0*43 2 ; I IBCO V>100,(IBT OB12=18!(I BTOB12=21) ) S IBQUIT =$$IBER(.I BER,109) Q :IBQUIT ; S (IBJ,IBT UNIT,IBS,I BREVTOT("A C"),IBREVT OT("AI"),I BREVTOT("A O"),IBREVT OT)=0 ; K IBXDATA D F^IBCEF("N -UB-04 SER VICE LINE (EDI)",,,I BIFN) ;Get rev codes ; ; Re-so rt the rev enue codes by code ; >> IBREV1( rev code,x )=Rev code ^ptr cpt^u nit chg^un its^total^ tot unc ; IBREV1(rev code) = r evenue cod e edit cat egory ; ; IBNOPR = f lag that d etermines if there a re revenue codes wit h ; charge s that do not have a procedure - no need to check ; for bill able MCR p rocedures if at leas t one RC i s billable ; 1 = the re is at l east one b illable re venue code without a ; procedu re ; S REQ MRA=$$REQM RA^IBEFUNC (IBIFN) S (IBNOPR,IB I)=0 F S IBI=$O(IBX DATA(IBI)) Q:'IBI D . I REQMR A D GYMODC HK(IBXDATA (IBI)) ; I B*2*377 GY modifier check . S IBJ=$P(IBX DATA(IBI), U),IBECAT= "" . I 'IB NOPR D .. I $P(IBXDA TA(IBI),U, 2)'="" S I BPR($P(IBX DATA(IBI), U,2))=IBI Q .. S IBN OPR=1 K IB PR . S:$D( IBREV1(IBJ )) IBECAT= $G(IBREV1( IBJ)) . I '$D(IBREV1 (IBJ))!(IB ECAT="") D S IBREV1 (IBJ)=IBEC AT . . ; . . ; Accom odations ( AC) . . I (IBJ'<100& (IBJ'>219) )!(IBJ=224 ) S IBECAT ="AC" Q . . ; . . ; Ancillary Outpatient (AO) . . I '$$INPAT ^IBCEF(IBI FN,1) S IB ECAT="AO" Q . . ; . . ; Ancill ary Inpati ent (AI) . . S IBECA T="AI" . ; . S IBREV 1(IBJ,+$O( IBREV1(IBJ ,""),-1)+1 )=IBXDATA( IBI) . S I BREVTOT(IB ECAT)=IBRE VTOT(IBECA T)+$P(IBXD ATA(IBI),U ,6) . I IB ECAT="AC" S IBTUNIT= IBTUNIT+$P (IBXDATA(I BI),U,4) ; I $$NEEDM RA^IBEFUNC (IBIFN),$O (IBPR("")) '="" D Q: IBQUIT . ; Don't all ow a bill containing only bill able proce dures for: . ; Oxyge n, labs, o r influenz a shots . ; OR a bil l with pro sthetics o n it . ; t o be sent to MEDICAR E for an M RA . D NON MCR(.IBPR, .IBLABS) ; Remove Ox ygen, labs , influenz a shots . I $G(IBLAB S) D WARN^ IBCBB11("T here are L ab procedu res on thi s claim.") ,WARN^IBCB B11("Pleas e verify t hat MEDICA RE does no t reimburs e these la bs at 100% ") Q . I $ O(IBPR("") )="" D .. S IBQUIT=$ $IBER(.IBE R,"098") ; ; covered days+non covered = units of a ccom rev c odes ; Che ck room an d board ; remove for IB*2.0*43 2 ;I IBTUN IT,IBTUNIT '=(IBCOV+I BNCOV) S I BQUIT=$$IB ER(.IBER,1 14) Q:IBQU IT ; ; Non Covered D ays ; requ ired when the type o f bill is 11x,18x,21 x or cover ed days=0 ; remove f or IB*2.0* 432 ; I IB NCOV="",(I BCTYP!(IBC OV=0)) S I BQUIT=$$IB ER(.IBER,1 15) Q:IBQU IT ; ; if cc code=40 then non- covered da ys must be 1 ; remov e for IB*2 .0*432 ; I $D(IBCCAR Y1(40)),IB NCOV'=1 S IBQUIT=$$I BER(.IBER, 116) Q:IBQ UIT ; ; Pa tient Sex ; must be "M" or "F" D DEM^VAD PT I $P(VA DM(5),U)'= "M",$P(VAD M(5),U)'=" F" S IBQUI T=$$IBER(. IBER,124) Q:IBQUIT ; ; esg - 1 0/17/07 - patch 371 ; For Part A replace ment MRA r equest cla ims, make sure ; the Medicare ICN/DCN nu mber is pr esent and also text in FL-80. I $$REQMRA ^IBEFUNC(I BIFN),$F(" .137.138.1 17.118."," ."_IBTOB_" .") D Q:I BQUIT . N IBZ,FL80TX T . D F^IB CEF("N-CUR R INS FORM LOC 64"," IBZ",,IBIF N) ; see C I3-11 . I IBZ="" S I BQUIT=$$IB ER(.IBER,2 05) Q:IBQU IT ; missing IC N/DCN . S FL80TXT=$P ($G(^DGCR( 399,IBIFN, "UF2")),U, 3) . I FL8 0TXT="" S IBQUIT=$$I BER(.IBER, 206) Q:IBQ UIT ; mis sing FL80 text . Q ; D ^IBCBB4 Q ;IBER(I BER,ERRNO) ; Sets er ror list ; NOTE: add code to c heck error list > 20 ... If so , display message an d ; quit s o we don't get too m any errors at once t o handle ; Print all if printi ng list ; I '$G(IBQU IT) D . I ERRNO?1N.N S:$L(ERRN O)<3 ERRNO =$E("00",1 ,3-$L(ERRN O))_ERRNO . I $L(IBE R,";")>19, '$G(IBPRT( "PRT")) S IBER=IBER_ "IB999;",I BQUIT=1 . I $G(IBER) '[("IB"_ER RNO_";") S IBER=IBER _"IB"_ERRN O_";" Q IB QUIT ;NONM CR(IBPR,IB LABS) ; De lete all o xygen and lab, flu s hot CPT en tries from IBPR ; IB PR = array subscript ed by CPT codes from bill ; IB LABS = fla g returned =1 if lab s found on bill N Z S IBLABS=0 ; Oxygen F Z="A0422 ","A4575", "A4616","A 4619","A46 20","A4621 ","E0455", "E1353","E 1355" K IB PR(Z) F Z= 77:1:85 S Z0="E13"_Z K IBPR(Z0 ) ; Labs S Z="80000" F S Z=$O (IBPR(Z)) Q:Z'?1"8"4 N S IBLAB S=1 ; Flu shots F Z= "90724","G 0008","907 32","G0009 ","90657", "90658","9 0659","906 60" K IBPR (Z) Q ;MCR ANUM(IBIFN ) ; Determ ine MEDICA RE A provi der ID # f rom bedsec tion for ; bill ien IBIFN N IB X ; PART A MRA (only ) needed - determine if psych/ non-psych claim N IB X,IBI S IB I=$P($G(^D GCR(399,IB IFN,"U")), U,11) S IB X=$S($TR($ P($G(^DGCR (399.1,+IB I,0)),U)," psych","PS YCH")'["PS YCH":67089 9,1:674499 ) Q IBX ;M CRACK(IBIF N,X,IBFLD) ; Check f or MEDICAR E A for bi ll IBIFN ; Called fr om CLAIM S TATUS MRA field (#24 ) xrefs in file 399 ; X = curr ent value of field 3 99;24 ; IB FLD = 1 fo r primary ins co, 2 for second ary, 3 for tertiary N IB S IB= 0 I +X,$$C OBN^IBCEF( IBIFN)=IBF LD,$$WNRBI LL^IBEFUNC (IBIFN,IBF LD),$$MRAT YPE^IBEFUN C(IBIFN,"C ")="A" S I B=1 Q IB ; GYMODCHK(Z ) ; GY mod ifier chec k procedur e. IB*2*37 7 - 2/4/08 ; Z is th e IBXDATA( IBI) servi ce line ED I N MODS I IBER["IB1 23" Q ; error al ready foun d S MODS=$ P(Z,U,9) ; list of m odifiers s eparated b y commas I MODS'["GY " Q ; GY modif ier not he re on this line item I $P(Z,U, 6) Q ; non-co vered char ges exist on this li ne item S IBQUIT=$$I BER(.IBER, 123)GYMODX ; Q ; | |
| 966 | ||
| 967 | Routines | |
| 968 | Activities | |
| 969 | Routine Na me | |
| 970 | IBCCC2 | |
| 971 | Enhancemen t Category | |
| 972 | New | |
| 973 | Modify | |
| 974 | Delete | |
| 975 | No Change | |
| 976 | RTM | |
| 977 | ||
| 978 | Related Op tions | |
| 979 | None | |
| 980 | Related Ro utines | |
| 981 | Routines “ Called By” | |
| 982 | Routines “ Called” | |
| 983 | ||
| 984 | ||
| 985 | ||
| 986 | ||
| 987 | Data Dicti onary (DD) Reference s | |
| 988 | ||
| 989 | Related Pr otocols | |
| 990 | None | |
| 991 | Related In tegration Control Re gistration s (ICRs) | |
| 992 | None | |
| 993 | Data Passi ng | |
| 994 | Input | |
| 995 | Output Re ference | |
| 996 | Both | |
| 997 | Global Re ference | |
| 998 | Local | |
| 999 | Input Attr ibute Name and Defin ition | |
| 1000 | Name: | |
| 1001 | Definition : | |
| 1002 | Output Att ribute Nam e and Defi nition | |
| 1003 | Name: | |
| 1004 | Definition : | |
| 1005 | Current Lo gic | |
| 1006 | IBCCC2 ;AL B/AAS - CA NCEL AND C LONE A BIL L - CONTIN UED ;6/6/0 3 9:56am ; ;2.0;INTEG RATED BILL ING;**80,1 06,124,138 ,51,151,13 7,161,182, 211,245,15 5,296,320, 348,349,37 1,400,433, 432,447,51 6**;21-MAR -94;Build 123 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ; ;M AP TO DGCR CC2 ; ;STE P 5 - get remainder of data to move and store in M CCR then x -ref ;STEP 6 - go to screens, come out t o IBB1 or something like that ;STEP5 S I BIFN1=$P(^ DGCR(399,I BIFN,0),"^ ",15) G EN D:$S(IBIFN 1="":1,'$D (^DGCR(399 ,IBIFN1,0) ):1,1:0) ; NOTE: any new or ch anged data nodes may also need to be upd ated in IB NCPDP5 ;mo ve pure da ta nodes ; MRD;IB*2. 0*516 - Ad ded "In7" nodes. F I ="I1","I17 ","I2","I2 7","I3","I 37","M1" I $D(^DGCR( 399,IBIFN1 ,I)) S ^DG CR(399,IBI FN,I)=^DGC R(399,IBIF N1,I) ; ;m ove top le vel data n ode. ;Do n ot move 'T X' node EX CEPT piece 8 (added with IB*2. 0*432) ;F I="U","U1" ,"U2","U3" ,"UF2","UF 3","UF31", "C","M" I $D(^DGCR(3 99,IBIFN1, I)) S IBND (I)=^(I) D @I ; add new data n odes intro duced with IB*2.0*43 2 F I="TX" ,"U","U1", "U2","U3", "U4","U5", "U6","U7", "U8","UF2" ,"UF3","UF 31","UF32" ,"C","M" I $D(^DGCR( 399,IBIFN1 ,I)) S IBN D(I)=^(I) D @I ; ;mo ve multipl e level da ta ;F I="C C","OC","O P","OT","R C","CP","C V","PRV" I $D(^DGCR( 399,IBIFN1 ,I,0)) D @ I ; add ne w data nod es introdu ced with I B*2.0*447 BI F I="CC ","OC","OP ","OT","RC ","CP","CV ","PRV","U 9" I $D(^D GCR(399,IB IFN1,I,0)) D @I ; ; IB*2.0*432 ADDED IBS ILENT flag so that t his can be processed in backgr ound D FTP RV^IBCEU5( IBIFN,$G(I BSILENT)) ; Ask chan ge prov ty pe if form type not the same D COBCHG(IB IFN,,.IBCO B) ; D ^IB CCC3 ; cop y table fi les (362.3 ) ; S I=$G (^DGCR(399 ,IBIFN1,0) ) I $P(I,U ,13)=7,$P( I,U,20)=1 D COPYB^IB CDC(IBIFN1 ,IBIFN) ; update aut o bill fil es D PRIOR (IBIFN) ; add new bi ll to prev ious bills in series , primary/ secondary ; I +$G(IB CTCOPY) N IBAUTO S I BAUTO=1 D PROC^IBCU7 A(IBIFN),B ILL^IBCRBC (IBIFN),CP TMOD26^IBC U73(IBIFN) D RECALL^ DILFD(399, IBIFN_",", DUZ) G END ;STEP6 N IBGOEND ; need to ki ll CRD fla g prior to entering billing sc reens in c ase a copy for corre sponding c laim is ne eded K IBC NCRD ; don 't call IB bill edit screens i f this is non-MRA ba ckground p rocessing I $G(IBSTS M)=1 G END I '$G(IBC E("EDI"))! $G(IBCE("E DI","NEW") ),'$G(IBCE AUTO) D IB SCEDT G EN D:$G(IBGOE ND) ; ;END K DFN,IB, IBA,IBA2,I BAD,IBADD1 ,IBBNO,IBC AN,IBCCC,I BDA,IBDPT, IBDR,IBDT, IBI,IBI1,I BIDS,IBIFN ,IBIFN1,IB ND,IBQUIT, IBU,IBUN,I BARST,IBCO B,IBCNCOPY ,IBCBCOPY, IBCNCRD,IB KEY K IBV, IBV1,IBW,I BWW,IBYN,I BZZ,PRCASV ,PRCAERCD, PRCAERR,PR CASVC,PRCA T,IBBT,IBC H,IBNDS,IB OA,IBREV,I BX,DGXRF1, VAEL,VAERR ,IBAC,IBCC C,IBDD1,IB IN,DGREV,D GREV00,DGR EVHDR,IBCH K K IBBS,I BLS,DGPCM, IBIP,IBND0 ,IBNDU,IBO ,IBPTF,IBS T,IBUC,IBD D,D,%,%DT, DIC,VA,VAD M,X,X1,X2, X3,X4,Y,I, J,K,DGRVRC AL,DDH,DGA CTDT,DGAMN T,DGBR,DGB RN,DGBSI,D GBSLOS,IBA 1,IBOD,IBI NS,IBN,IBP ROC,DGFUNC ,DGIFN Q ; ;IBSCEDT ; call the IB bill e dit screen s and vali date the d ata N IBV, IBPAR,IBAC ,IBHV,IBH, IBCIREDT ; if the us er came fr om CBW->PC and this is a non-M RA claim w /a paper E OB, set fo rce print flag IB*2. 0*432 ; al so, if the user came from CBW- >PC and th is is a no n-MRA clai m and the only EEOB we have ha s filing e rrors, set force pri nt flag I $G(IBMRANO T)=1,$$COB N^IBCEF(IB IFN)>1,$G( IBFROM)=2 D .I $G(I BDA)="" D FORCEPRT^I BCAPP($G(I BIFN)) Q . I $D(^IBM( 361.1,IBDA ,"ERR")) D FORCEPRT^ IBCAPP($G( IBIFN)) Q D RECALL^D ILFD(399,I BIFN_",",D UZ)ST1 S I BV=0 D ^IB CSCU,^IBCS C1 I $G(IB POPOUT) S IBGOEND=1 G IBSCX S IBAC=1 D ^ IBCB1 I $G (IBCIREDT) G ST1IBSC X ; Q ; ;T X F J=8 I $P(IBND("T X"),"^",J) ]"" S $P(^ DGCR(399,I BIFN,"TX") ,"^",J)=$P (IBND("TX" ),"^",J) Q U F J=3,4, 6:1:17,20 I $P(IBND( "U"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"U") ,"^",J)=$P (IBND("U") ,"^",J) QU 1 F J=1:1: 3,15 I $P( IBND("U1") ,"^",J)]"" S $P(^DGC R(399,IBIF N,"U1"),"^ ",J)=$P(IB ND("U1")," ^",J) QU2 F J=1:1:19 I $P(IBND ("U2"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U 2"),"^",J) =$P(IBND(" U2"),"^",J ) QU3 F J= 1:1:11 I $ P(IBND("U3 "),"^",J)] "" S $P(^D GCR(399,IB IFN,"U3"), "^",J)=$P( IBND("U3") ,"^",J) QU F2 F J=1,3 I $P(IBND ("UF2"),"^ ",J)]"" S $P(^DGCR(3 99,IBIFN," UF2"),"^", J)=$P(IBND ("UF2"),"^ ",J) QUF3 F J=4:1:6 I $P(IBND( "UF3"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U F3"),"^",J )=$P(IBND( "UF3"),"^" ,J) QU4 F J=1:1:14 I $P(IBND(" U4"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"U4" ),"^",J)=$ P(IBND("U4 "),"^",J) QU5 F J=1: 1:6 I $P(I BND("U5"), "^",J)]"" S $P(^DGCR (399,IBIFN ,"U5"),"^" ,J)=$P(IBN D("U5"),"^ ",J) QU6 F J=1:1:6 I $P(IBND(" U6"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"U6" ),"^",J)=$ P(IBND("U6 "),"^",J) QU7 F J=1: 1:5 I $P(I BND("U7"), "^",J)]"" S $P(^DGCR (399,IBIFN ,"U7"),"^" ,J)=$P(IBN D("U7"),"^ ",J) QU8 F J=1:1:3 I $P(IBND(" U8"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"U8" ),"^",J)=$ P(IBND("U8 "),"^",J) QUF31 F J= 3 I $P(IBN D("UF31"), "^",J)]"" S $P(^DGCR (399,IBIFN ,"UF31")," ^",J)=$P(I BND("UF31" ),"^",J) Q UF32 F J=1 :1:3 I $P( IBND("UF32 "),"^",J)] "" S $P(^D GCR(399,IB IFN,"UF32" ),"^",J)=$ P(IBND("UF 32"),"^",J ) QC F J=1 0 I $P(IBN D("C"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"C "),"^",J)= $P(IBND("C "),"^",J) I '$D(^DGC R(399,IBIF N1,"CP")) D CP1 QM F J=1:1:9,1 1:1:14 I $ P(IBND("M" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"M"),"^ ",J)=$P(IB ND("M"),"^ ",J) QCC S ^DGCR(399 ,IBIFN,I,0 )=^DGCR(39 9,IBIFN1,I ,0) S IBDD =399.04 F J=0:0 S J= $O(^DGCR(3 99,IBIFN1, I,J)) Q:'J I $D(^(J ,0)) S ^DG CR(399,IBI FN,I,J,0)= ^DGCR(399, IBIFN1,I,J ,0),X=$P(^ (0),"^")OP S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0) S IB DD=399.043 F J=0:0 S J=$O(^DGC R(399,IBIF N1,I,J)) Q :'J I $D( ^(J,0)) S ^DGCR(399, IBIFN,I,J, 0)=^DGCR(3 99,IBIFN1, I,J,0),X=$ P(^(0),"^" ) QOC S ^D GCR(399,IB IFN,I,0)=^ DGCR(399,I BIFN1,I,0) S IBDD=39 9.041 F J= 0:0 S J=$O (^DGCR(399 ,IBIFN1,I, J)) Q:'J I $D(^(J,0 )) S ^DGCR (399,IBIFN ,I,J,0)=^D GCR(399,IB IFN1,I,J,0 ),X=$P(^(0 ),"^") QOT S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0) S IB DD=399.048 F J=0:0 S J=$O(^DGC R(399,IBIF N1,I,J)) Q :'J I $D( ^(J,0)) S ^DGCR(399, IBIFN,I,J, 0)=^DGCR(3 99,IBIFN1, I,J,0),X=$ P(^(0),"^" ) QCV ; Do n't copy v alue codes from inpa tient inst to inpati ent prof b ills I $$F T^IBCEF(IB IFN1)'=2,$ $FT^IBCEF( IBIFN)=2 Q S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0) S IB DD=399.047 F J=0:0 S J=$O(^DGC R(399,IBIF N1,I,J)) Q :'J I $D( ^(J,0)) S ^DGCR(399, IBIFN,I,J, 0)=^DGCR(3 99,IBIFN1, I,J,0),X=$ P(^(0),"^" ) QRC S ^D GCR(399,IB IFN,I,0)=^ DGCR(399,I BIFN1,I,0) S IBDD=39 9.042 F J= 0:0 S J=$O (^DGCR(399 ,IBIFN1,I, J)) Q:'J I $D(^(J,0 )) S IBND( "RC")=^(0) F K=1:1:1 6 S $P(^DG CR(399,IBI FN,I,J,0), "^",K)=$P( IBND("RC") ,"^",K),X= $P(IBND("R C"),"^",K) QCP S ^DG CR(399,IBI FN,I,0)=^D GCR(399,IB IFN1,I,0) I +$G(IBNO CPT) Q S I BDD=399.03 04 F J=0:0 S J=$O(^D GCR(399,IB IFN1,I,J)) Q:'J I $ D(^(J,0)) S IBND("CP ")=^(0),IB ND("CP1")= $G(^(1)),I BND("CP-AU X")=$G(^(" AUX")) D . F K=1:1:7 ,9:1:14,16 :1:22 S $P (^DGCR(399 ,IBIFN,I,J ,0),"^",K) =$P(IBND(" CP"),"^",K ) . ; IB*2 .0*432 add new 1 nod e . ; MRD; IB*2.0*516 - Added p ieces 7 & 8 (NDC, Un its) to 1- node. . F K=1:1:8 S $P(^DGCR(3 99,IBIFN,I ,J,1),"^", K)=$P(IBND ("CP1"),"^ ",K) . ; e sg - 11/2/ 06 - IB*2* 348 - 50.0 9 field wa s added - AUX piece [9] . I IB ND("CP-AUX ")'="" F K =1:1:9 S $ P(^DGCR(39 9,IBIFN,I, J,"AUX")," ^",K)=$P(I BND("CP-AU X"),"^",K) . ; IB*2. 0*432 add new LNPRV multiple . I $D(^DGC R(399,IBIF N1,I,J,"LN PRV",0)) S ^DGCR(399 ,IBIFN,I,J ,"LNPRV",0 )=^DGCR(39 9,IBIFN1,I ,J,"LNPRV" ,0) D .. S K=0 F S K=$O(^DGCR (399,IBIFN 1,I,J,"LNP RV",K)) Q: 'K D ... S ^DGCR(39 9,IBIFN,I, J,"LNPRV", K,0)=^DGCR (399,IBIFN 1,I,J,"LNP RV",K,0) . I $D(^DGC R(399,IBIF N1,I,J,"MO D",0)) S ^ DGCR(399,I BIFN,I,J," MOD",0)=^D GCR(399,IB IFN1,I,J," MOD",0) D .. S K=0 F S K=$O(^ DGCR(399,I BIFN1,I,J, "MOD",K)) Q:'K D .. . I $G(IBN OTC),$P($$ MOD^ICPTMO D(+$P($G(^ DGCR(399,I BIFN1,I,J, "MOD",K,0) ),U,2),"I" ),U,2)="TC " Q ; Don 't copy TC modifier from inst to prof bi ll ... S ^ DGCR(399,I BIFN,I,J," MOD",K,0)= ^DGCR(399, IBIFN1,I,J ,"MOD",K,0 )CP1 S IBC OD=$P($G(^ DGCR(399,I BIFN,0))," ^",9) Q:IB COD=""!('$ D(^DGCR(39 9,IBIFN1," C"))) I IB COD=9 F DG I=4,5,6 I $P(^DGCR(3 99,IBIFN1, "C"),"^",D GI) S X=$P (^("C"),"^ ",DGI)_";I CD0(",DGPR OCDT=$P(^( "C"),"^",D GI+7) D FI LE I IBCOD =4 F DGI=1 ,2,3 I $P( ^DGCR(399, IBIFN1,"C" ),"^",DGI) S X=$P(^( "C"),"^",D GI)_";ICPT (",DGPROCD T=$P(^("C" ),"^",DGI+ 10) D FILE I IBCOD=5 F DGI=7,8 ,9 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S X=$P(^("C "),"^",DGI )_";ICPT(" ,DGPROCDT= $P(^("C"), "^",DGI+4) D FILE Q ;PRV ; Cop y provider s for clon ed claim N Z,Z0,CNT S Z=$P($G( ^DGCR(399, IBIFN,0)), U,19),Z0=$ P($G(^DGCR (399,IBIFN 1,0)),U,19 ),CNT=0 S IBDD=399.0 222 F J=0: 0 S J=$O(^ DGCR(399,I BIFN1,I,J) ) Q:'J I $D(^(J,0)) D . I $$G ETNPI^IBCE F73A($P(^D GCR(399,IB IFN1,I,J,0 ),U,2))="" Q ;Don't file prov ider if no NPI - IB* 2*516 . S CNT=CNT+1, ^DGCR(399, IBIFN,I,CN T,0)=^DGCR (399,IBIFN 1,I,J,0),X =$P(^(0)," ^") . I Z' =Z0,$S(X=3 :Z0=3,X=4: Z0=2,1:0) S $P(^DGCR (399,IBIFN ,I,CNT,0), U)=(Z0+1) I CNT S ^D GCR(399,IB IFN,I,0)=^ DGCR(399,I BIFN1,I,0) ,$P(^DGCR( 399,IBIFN, I,0),U,3)= CNT,$P(^DG CR(399,IBI FN,I,0),U, 4)=CNT Q ; U9 ; Added for new d ata elemen ts in IB*2 .0*447 BI M ^DGCR(39 9,IBIFN,I) =^DGCR(399 ,IBIFN1,I) Q ;COB S J=0 F S J =$O(IBCOB( I,J)) Q:'J S $P(^DG CR(399,IBI FN,I),U,J) =IBCOB(I,J ) Q ;FILE N DIC,DIE, DR,DA,X,Y, DLAYGO,DD, DO I '$D(^ DGCR(399,I BIFN,"CP", 0)) S DIC( "P")=$$GET SPEC^IBEFU NC(399,304 ) S DIC(0) ="L",DLAYG O=399,DA(1 )=IBIFN,DI C="^DGCR(3 99,"_DA(1) _",""CP"", " Q:X="" D FILE^DIC N K DO,DD Q:+Y<1 S D A=+Y S DIE ="^DGCR(39 9,"_DA(1)_ ",""CP""," ,DR="1///" _DGPROCDT D ^DIE K D GPROCDT Q ;INDEX ;in dex entire file (set logic) N IBMAED D S AVERC(IBIF N,.IBMAED) ; IB*2.0* 447 BI - S ave the va lue of pie ce 16 of e ach RC nod e before r e-indexing . S DIK="^ DGCR(399," ,DA=IBIFN D IX1^DIK K DA,DIK D RESTRC(IB IFN,.IBMAE D) ; IB*2. 0*447 BI - Restore t he value o f piece 16 of each R C node bef ore re-ind exing. Q ; PRIOR(IBIF N) ; set S econdary/T ertiary Bi ll #s on p rior bills , if the b ill is can celled rem ove it fro m prior bi lls N IBSE Q,IBSEQN,I BM1,I,IBIF N1 S IBSEQ =$$COB^IBC EF(IBIFN) S IBSEQN=$ S(IBSEQ="S ":6,IBSEQ= "T":7,1:"" ) Q:'IBSEQ N ; S IBM1 =$G(^DGCR( 399,IBIFN, "M1")) I + $P(^DGCR(3 99,IBIFN,0 ),U,13)=7 S IBIFN="" F I=5,6 I I<IBSEQN S IBIFN1= +$P(IBM1,U ,I) I +IBI FN1,$D(^DG CR(399,+IB IFN1,0)) S $P(^DGCR( 399,IBIFN1 ,"M1"),U,I BSEQN)=IBI FN Q ;COBC HG(IBIFN,I BINS,IBCOB ) ; Make c hanges for a new COB payer for bill ; IB IFN = ien of bill in file 399 ; IBINS = ien of bil l's curren t insuranc e (optiona l) ; IBCOB = array s ubscripted by node,p iece of CO B data fie ld change ; N I,IBFR MTYP,IBTAX LST ; Subt ract the P rior Payme nts from t he bill's Offset (th ese are re -added by triggers) F I=4,5,6 S $P(^DGCR (399,IBIFN ,"U1"),U,2 )=$P($G(^D GCR(399,IB IFN,"U1")) ,U,2)-$P($ G(^DGCR(39 9,IBIFN,"U 2")),U,I) ; I $G(IBI NS),$$MCRW NR^IBEFUNC (IBINS) D . ;MCRWNR is current insurance ... move payer only . N IBCOB N,IBX . S IBCOBN=$$C OBN^IBCEF( IBIFN) . S IBCOB(0,2 1)=$P("S^T ^",U,IBCOB N) . S IBC OB("M1",IB COBN+4)=IB IFN . S IB COB("TX",1 )="",IBCOB ("TX",2)=" " . S IBX= $$REQMRA^I BEFUNC(IBI FN) . I IB X=0 S IBCO B("TX",5)= 0 ; MRA no t needed . I IBX["R" S IBCOB(" TX",5)="A" ; MRA ski pped . I I BX=1,$$CHK ^IBCEMU1(I BIFN) S IB COB("TX",5 )="C" ; M RA on file . I $G(IB PRCOB) S I BCOB("TX", 5)="C" ; MRA b eing proc' d . D PRIO R(IBIFN) . Q ; ;rese t fields f or next Se quence Pay er F I=0," M1","U2"," TX" I $D(I BCOB(I)) D COB ; ; I B*2.0*211 ; save off Form Type S IBFRMTY P=$P($G(^D GCR(399,IB IFN,0)),U, 19) ; Save off Taxon omies for providers. S I=0 F S I=$O(^DG CR(399,IBI FN,"PRV",I )) Q:'I S IBTAXLST( I)=$P($G(^ DGCR(399,I BIFN,"PRV" ,I,0)),U,1 5) ; ; fir e xrefs se t logic D INDEX ; ; Restore Fo rm Type if changed, but don't restore Fo rm Type if ; creatin g CMS-1500 claim fro m CTCOPY1^ IBCCCB I $ G(IBCTCOPY )'=1,IBFRM TYP'=$P($G (^DGCR(399 ,IBIFN,0)) ,U,19) N D A,DIE,DR S DA=IBIFN, DIE="^DGCR (399,",DR= ".19////"_ IBFRMTYP D ^DIE ; ; Restore Cl aim MRA St atus field since tri ggers in f ields 101 & 102 ; wi ll overwri te the cor rect value when proc essing the MRA/EOB. ; If we're processin g the MRA/ EOB, then a valid MR A has been received. I $G(IBPR COB) N DA, DIE,DR S D A=IBIFN,DI E="^DGCR(3 99,",DR="2 4////C" D ^DIE ; ; O nly if clo ning, then restore T axonomies in fields 243 and 24 4 and 252. I '$G(IBI NS),'$G(IB PRCOB) D . S I=$P($G (IBND("U3" )),U,2) . I I'=$P($G (^DGCR(399 ,IBIFN,"U3 ")),U,2) D .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 3////"_$S( I'="":I,1: "@") D ^DI E . ; . S I=$P($G(IB ND("U3")), U,3) . I I '=$P($G(^D GCR(399,IB IFN,"U3")) ,U,3) D .. N DA,DIE, DR S DA=IB IFN,DIE="^ DGCR(399," ,DR="244// //"_$S(I'= "":I,1:"@" ) D ^DIE . ; . S I=$ P($G(IBND( "U3")),U,1 1) . I I'= $P($G(^DGC R(399,IBIF N,"U3")),U ,11) D .. N DA,DIE,D R S DA=IBI FN,DIE="^D GCR(399,", DR="252/// /"_$S(I'=" ":I,1:"@") D ^DIE . Q ; ; Rest ore Taxono mies in fi eld .15 in sub-file 399.0222. S IBTAXLST =0 F S IB TAXLST=$O( IBTAXLST(I BTAXLST)) Q:'IBTAXLS T D . S I =IBTAXLST( IBTAXLST) . I I=$P($ G(^DGCR(39 9,IBIFN,"P RV",IBTAXL ST,0)),U,1 5) Q ; No change . N DA,DIE,D R . S DA(1 )=IBIFN,DA =IBTAXLST . S DIE="^ DGCR(399," _DA(1)_"," "PRV"",",D R=".15//// "_$S(I'="" :I,1:"@") . D ^DIE . Q ; K IBC OB("TX") Q ;SAVERC(I BIFN,IBMAE D) ; IB*2. 0*447 BI - Save the value of p iece 16 of each RC n ode before re-indexi ng. Q:$G(I BCTCOPY)=1 Q:$G(IBCT COPY)=2 N IBCNT S IB CNT=0 Q:'$ G(IBIFN) Q :'$D(^DGCR (399,IBIFN ,"RC")) F S IBCNT=$ O(^DGCR(39 9,IBIFN,"R C",IBCNT)) Q:+IBCNT= 0 D . S IB MAED(IBCNT )=$P($G(^D GCR(399,IB IFN,"RC",I BCNT,0)),U ,16) Q ;RE STRC(IBIFN ,IBMAED) ; IB*2.0*44 7 BI - Res tore the v alue of pi ece 16 of each RC no de after r e-indexing . Q:$G(IBC TCOPY)=1 Q :$G(IBCTCO PY)=2 N IB CNT S IBCN T=0 Q:'$G( IBIFN) Q:' $D(^DGCR(3 99,IBIFN," RC")) F S IBCNT=$O( IBMAED(IBC NT)) Q:+IB CNT=0 D . S $P(^DGCR (399,IBIFN ,"RC",IBCN T,0),U,16) =IBMAED(IB CNT) Q | |
| 1007 | Modified L ogic (Chan ges are in bold) | |
| 1008 | IBCCC2 ;AL B/AAS - CA NCEL AND C LONE A BIL L - CONTIN UED ;6/6/0 3 9:56am ; ;2.0;INTEG RATED BILL ING;**80,1 06,124,138 ,51,151,13 7,161,182, 211,245,15 5,296,320, 348,349,37 1,400,433, 432,447,51 6,592**;21 -MAR-94;Bu ild 123 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; ;MAP TO DGCRCC2 ; ;STEP 5 - get remain der of dat a to move and store in MCCR th en x-ref ; STEP 6 - g o to scree ns, come o ut to IBB1 or someth ing like t hat ;STEP5 S IBIFN1= $P(^DGCR(3 99,IBIFN,0 ),"^",15) G END:$S(I BIFN1="":1 ,'$D(^DGCR (399,IBIFN 1,0)):1,1: 0) ; NOTE: any new o r changed data nodes may also need to be updated i n IBNCPDP5 ;move pur e data nod es ; MRD;I B*2.0*516 - Added "I n7" nodes. F I="I1", "I17","I2" ,"I27","I3 ","I37","M 1" I $D(^D GCR(399,IB IFN1,I)) S ^DGCR(399 ,IBIFN,I)= ^DGCR(399, IBIFN1,I) ; ;move to p level da ta node. ; Do not mov e 'TX' nod e EXCEPT p iece 8 (ad ded with I B*2.0*432) ;F I="U", "U1","U2", "U3","UF2" ,"UF3","UF 31","C","M " I $D(^DG CR(399,IBI FN1,I)) S IBND(I)=^( I) D @I ; add new da ta nodes i ntroduced with IB*2. 0*432 F I= "TX","U"," U1","U2"," U3","U4"," U5","U6"," U7","U8"," UF2","UF3" ,"UF31","U F32","C"," M" I $D(^D GCR(399,IB IFN1,I)) S IBND(I)=^ (I) D @I ; ;move mul tiple leve l data ;F I="CC","OC ","OP","OT ","RC","CP ","CV","PR V" I $D(^D GCR(399,IB IFN1,I,0)) D @I ; ad d new data nodes int roduced wi th IB*2.0* 447 BI F I ="CC","OC" ,"OP","OT" ,"RC","CP" ,"CV","PRV ","U9" I $ D(^DGCR(39 9,IBIFN1,I ,0)) D @I ; ;JWS;IB* 2.0*592;ad d new Dent al Claim f ields I $D (^DGCR(399 ,IBIFN1,"D EN")) S ^D GCR(399,IB IFN,"DEN") =^DGCR(399 ,IBIFN1,"D EN") I $D( ^DGCR(399, IBIFN1,"DE N1",0)) S ^DGCR(399, IBIFN,"DEN 1",0)=^DGC R(399,IBIF N1,"DEN1", 0) D . S K =0 F S K= $O(^DGCR(3 99,IBIFN1, "DEN1",K)) Q:'K S ^ DGCR(399,I BIFN,"DEN1 ",K,0)=^DG CR(399,IBI FN1,"DEN1" ,K,0) I $D (^DGCR(399 ,IBIFN1,"D EN2")) S ^ DGCR(399,I BIFN,"DEN2 ")=^DGCR(3 99,IBIFN1, "DEN2") ; ; IB*2.0*4 32 ADDED I BSILENT fl ag so that this can be process ed in back ground D F TPRV^IBCEU 5(IBIFN,$G (IBSILENT) ) ; Ask ch ange prov type if fo rm type no t the same D COBCHG( IBIFN,,.IB COB) ; D ^ IBCCC3 ; c opy table files (362 .3) ; S I= $G(^DGCR(3 99,IBIFN1, 0)) I $P(I ,U,13)=7,$ P(I,U,20)= 1 D COPYB^ IBCDC(IBIF N1,IBIFN) ; update a uto bill f iles D PRI OR(IBIFN) ; add new bill to pr evious bil ls in seri es, primar y/secondar y ; I +$G( IBCTCOPY) N IBAUTO S IBAUTO=1 D PROC^IBC U7A(IBIFN) ,BILL^IBCR BC(IBIFN), CPTMOD26^I BCU73(IBIF N) D RECAL L^DILFD(39 9,IBIFN_", ",DUZ) G E ND ;STEP6 N IBGOEND ; need to kill CRD f lag prior to enterin g billing screens in case a co py for cor responding claim is needed K I BCNCRD ; d on't call IB bill ed it screens if this i s non-MRA background processin g I $G(IBS TSM)=1 G E ND I '$G(I BCE("EDI") )!$G(IBCE( "EDI","NEW ")),'$G(IB CEAUTO) D IBSCEDT G END:$G(IBG OEND) ; ;E ND K DFN,I B,IBA,IBA2 ,IBAD,IBAD D1,IBBNO,I BCAN,IBCCC ,IBDA,IBDP T,IBDR,IBD T,IBI,IBI1 ,IBIDS,IBI FN,IBIFN1, IBND,IBQUI T,IBU,IBUN ,IBARST,IB COB,IBCNCO PY,IBCBCOP Y,IBCNCRD, IBKEY K IB V,IBV1,IBW ,IBWW,IBYN ,IBZZ,PRCA SV,PRCAERC D,PRCAERR, PRCASVC,PR CAT,IBBT,I BCH,IBNDS, IBOA,IBREV ,IBX,DGXRF 1,VAEL,VAE RR,IBAC,IB CCC,IBDD1, IBIN,DGREV ,DGREV00,D GREVHDR,IB CHK K IBBS ,IBLS,DGPC M,IBIP,IBN D0,IBNDU,I BO,IBPTF,I BST,IBUC,I BDD,D,%,%D T,DIC,VA,V ADM,X,X1,X 2,X3,X4,Y, I,J,K,DGRV RCAL,DDH,D GACTDT,DGA MNT,DGBR,D GBRN,DGBSI ,DGBSLOS,I BA1,IBOD,I BINS,IBN,I BPROC,DGFU NC,DGIFN Q ; ;IBSCED T ; call t he IB bill edit scre ens and va lidate the data N IB V,IBPAR,IB AC,IBHV,IB H,IBCIREDT ; if the user came from CBW-> PC and thi s is a non -MRA claim w/a paper EOB, set force prin t flag IB* 2.0*432 ; also, if t he user ca me from CB W->PC and this is a non-MRA cl aim and th e only EEO B we have has filing errors, s et force p rint flag I $G(IBMRA NOT)=1,$$C OBN^IBCEF( IBIFN)>1,$ G(IBFROM)= 2 D .I $G (IBDA)="" D FORCEPRT ^IBCAPP($G (IBIFN)) Q .I $D(^IB M(361.1,IB DA,"ERR")) D FORCEPR T^IBCAPP($ G(IBIFN)) Q D RECALL ^DILFD(399 ,IBIFN_"," ,DUZ)ST1 S IBV=0 D ^ IBCSCU,^IB CSC1 I $G( IBPOPOUT) S IBGOEND= 1 G IBSCX S IBAC=1 D ^IBCB1 I $G(IBCIRED T) G ST1IB SCX ; Q ; ;TX F J=8 I $P(IBND( "TX"),"^", J)]"" S $P (^DGCR(399 ,IBIFN,"TX "),"^",J)= $P(IBND("T X"),"^",J) QU F J=3, 4,6:1:17,2 0 I $P(IBN D("U"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U "),"^",J)= $P(IBND("U "),"^",J) QU1 F J=1: 1:3,15 I $ P(IBND("U1 "),"^",J)] "" S $P(^D GCR(399,IB IFN,"U1"), "^",J)=$P( IBND("U1") ,"^",J) QU 2 F J=1:1: 19 I $P(IB ND("U2")," ^",J)]"" S $P(^DGCR( 399,IBIFN, "U2"),"^", J)=$P(IBND ("U2"),"^" ,J) QU3 F J=1:1:11 I $P(IBND(" U3"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"U3" ),"^",J)=$ P(IBND("U3 "),"^",J) QUF2 F J=1 ,3 I $P(IB ND("UF2"), "^",J)]"" S $P(^DGCR (399,IBIFN ,"UF2"),"^ ",J)=$P(IB ND("UF2"), "^",J) QUF 3 F J=4:1: 6 I $P(IBN D("UF3")," ^",J)]"" S $P(^DGCR( 399,IBIFN, "UF3"),"^" ,J)=$P(IBN D("UF3")," ^",J) QU4 F J=1:1:14 I $P(IBND ("U4"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U 4"),"^",J) =$P(IBND(" U4"),"^",J ) QU5 F J= 1:1:6 I $P (IBND("U5" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"U5")," ^",J)=$P(I BND("U5"), "^",J) QU6 F J=1:1:6 I $P(IBND ("U6"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U 6"),"^",J) =$P(IBND(" U6"),"^",J ) QU7 F J= 1:1:5 I $P (IBND("U7" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"U7")," ^",J)=$P(I BND("U7"), "^",J) QU8 F J=1:1:3 I $P(IBND ("U8"),"^" ,J)]"" S $ P(^DGCR(39 9,IBIFN,"U 8"),"^",J) =$P(IBND(" U8"),"^",J ) QUF31 F J=3 I $P(I BND("UF31" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"UF31") ,"^",J)=$P (IBND("UF3 1"),"^",J) QUF32 F J =1:1:3 I $ P(IBND("UF 32"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"UF3 2"),"^",J) =$P(IBND(" UF32"),"^" ,J) QC F J =10 I $P(I BND("C")," ^",J)]"" S $P(^DGCR( 399,IBIFN, "C"),"^",J )=$P(IBND( "C"),"^",J ) I '$D(^D GCR(399,IB IFN1,"CP") ) D CP1 QM F J=1:1:9 ,11:1:14 I $P(IBND(" M"),"^",J) ]"" S $P(^ DGCR(399,I BIFN,"M"), "^",J)=$P( IBND("M"), "^",J) QCC S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0) S IB DD=399.04 F J=0:0 S J=$O(^DGCR (399,IBIFN 1,I,J)) Q: 'J I $D(^ (J,0)) S ^ DGCR(399,I BIFN,I,J,0 )=^DGCR(39 9,IBIFN1,I ,J,0),X=$P (^(0),"^") OP S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0) S IBDD=399.0 43 F J=0:0 S J=$O(^D GCR(399,IB IFN1,I,J)) Q:'J I $ D(^(J,0)) S ^DGCR(39 9,IBIFN,I, J,0)=^DGCR (399,IBIFN 1,I,J,0),X =$P(^(0)," ^") QOC S ^DGCR(399, IBIFN,I,0) =^DGCR(399 ,IBIFN1,I, 0) S IBDD= 399.041 F J=0:0 S J= $O(^DGCR(3 99,IBIFN1, I,J)) Q:'J I $D(^(J ,0)) S ^DG CR(399,IBI FN,I,J,0)= ^DGCR(399, IBIFN1,I,J ,0),X=$P(^ (0),"^") Q OT S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0) S IBDD=399.0 48 F J=0:0 S J=$O(^D GCR(399,IB IFN1,I,J)) Q:'J I $ D(^(J,0)) S ^DGCR(39 9,IBIFN,I, J,0)=^DGCR (399,IBIFN 1,I,J,0),X =$P(^(0)," ^") QCV ; Don't copy value cod es from in patient in st to inpa tient prof bills I $ $FT^IBCEF( IBIFN1)'=2 ,$$FT^IBCE F(IBIFN)=2 Q S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0) S IBDD=399.0 47 F J=0:0 S J=$O(^D GCR(399,IB IFN1,I,J)) Q:'J I $ D(^(J,0)) S ^DGCR(39 9,IBIFN,I, J,0)=^DGCR (399,IBIFN 1,I,J,0),X =$P(^(0)," ^") QRC S ^DGCR(399, IBIFN,I,0) =^DGCR(399 ,IBIFN1,I, 0) S IBDD= 399.042 F J=0:0 S J= $O(^DGCR(3 99,IBIFN1, I,J)) Q:'J I $D(^(J ,0)) S IBN D("RC")=^( 0) F K=1:1 :16 S $P(^ DGCR(399,I BIFN,I,J,0 ),"^",K)=$ P(IBND("RC "),"^",K), X=$P(IBND( "RC"),"^", K) QCP S ^ DGCR(399,I BIFN,I,0)= ^DGCR(399, IBIFN1,I,0 ) I +$G(IB NOCPT) Q S IBDD=399. 0304 F J=0 :0 S J=$O( ^DGCR(399, IBIFN1,I,J )) Q:'J I $D(^(J,0) ) S IBND(" CP")=^(0), IBND("CP1" )=$G(^(1)) ,IBND("CP- AUX")=$G(^ ("AUX")) D . F K=1:1 :7,9:1:14, 16:1:22 S $P(^DGCR(3 99,IBIFN,I ,J,0),"^", K)=$P(IBND ("CP"),"^" ,K) . ; IB *2.0*432 a dd new 1 n ode . ; MR D;IB*2.0*5 16 - Added pieces 7 & 8 (NDC, Units) to 1-node. . F K=1:1:8 S $P(^DGCR (399,IBIFN ,I,J,1),"^ ",K)=$P(IB ND("CP1"), "^",K) . ; esg - 11/ 2/06 - IB* 2*348 - 50 .09 field was added - AUX piec e [9] . I IBND("CP-A UX")'="" F K=1:1:9 S $P(^DGCR( 399,IBIFN, I,J,"AUX") ,"^",K)=$P (IBND("CP- AUX"),"^", K) . ; IB* 2.0*432 ad d new LNPR V multiple . I $D(^D GCR(399,IB IFN1,I,J," LNPRV",0)) S ^DGCR(3 99,IBIFN,I ,J,"LNPRV" ,0)=^DGCR( 399,IBIFN1 ,I,J,"LNPR V",0) D .. S K=0 F S K=$O(^DG CR(399,IBI FN1,I,J,"L NPRV",K)) Q:'K D .. . S ^DGCR( 399,IBIFN, I,J,"LNPRV ",K,0)=^DG CR(399,IBI FN1,I,J,"L NPRV",K,0) . I $D(^D GCR(399,IB IFN1,I,J," MOD",0)) S ^DGCR(399 ,IBIFN,I,J ,"MOD",0)= ^DGCR(399, IBIFN1,I,J ,"MOD",0) D .. S K=0 F S K=$O (^DGCR(399 ,IBIFN1,I, J,"MOD",K) ) Q:'K D ... I $G(I BNOTC),$P( $$MOD^ICPT MOD(+$P($G (^DGCR(399 ,IBIFN1,I, J,"MOD",K, 0)),U,2)," I"),U,2)=" TC" Q ; D on't copy TC modifie r from ins t to prof bill ... S ^DGCR(399 ,IBIFN,I,J ,"MOD",K,0 )=^DGCR(39 9,IBIFN1,I ,J,"MOD",K ,0) . ;JWS ;IB*2.0*59 2;add new Dental cla im form fi elds . I $ D(^DGCR(39 9,IBIFN1,I ,J,"DEN")) S ^DGCR(3 99,IBIFN,I ,J,"DEN")= ^DGCR(399, IBIFN1,I,J ,"DEN") . I $D(^DGCR (399,IBIFN 1,I,J,"DEN 1",0)) S ^ DGCR(399,I BIFN,I,J," DEN1",0)=^ DGCR(399,I BIFN1,I,J, "DEN1",0) D .. S K=0 F S K=$O (^DGCR(399 ,IBIFN1,I, J,"DEN1",K )) Q:'K D ... S ^DG CR(399,IBI FN,I,J,"DE N1",K,0)=^ DGCR(399,I BIFN1,I,J, "DEN1",K,0 )CP1 S IBC OD=$P($G(^ DGCR(399,I BIFN,0))," ^",9) Q:IB COD=""!('$ D(^DGCR(39 9,IBIFN1," C"))) I IB COD=9 F DG I=4,5,6 I $P(^DGCR(3 99,IBIFN1, "C"),"^",D GI) S X=$P (^("C"),"^ ",DGI)_";I CD0(",DGPR OCDT=$P(^( "C"),"^",D GI+7) D FI LE I IBCOD =4 F DGI=1 ,2,3 I $P( ^DGCR(399, IBIFN1,"C" ),"^",DGI) S X=$P(^( "C"),"^",D GI)_";ICPT (",DGPROCD T=$P(^("C" ),"^",DGI+ 10) D FILE I IBCOD=5 F DGI=7,8 ,9 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S X=$P(^("C "),"^",DGI )_";ICPT(" ,DGPROCDT= $P(^("C"), "^",DGI+4) D FILE Q ;PRV ; Cop y provider s for clon ed claim N Z,Z0,CNT S Z=$P($G( ^DGCR(399, IBIFN,0)), U,19),Z0=$ P($G(^DGCR (399,IBIFN 1,0)),U,19 ),CNT=0 S IBDD=399.0 222 F J=0: 0 S J=$O(^ DGCR(399,I BIFN1,I,J) ) Q:'J I $D(^(J,0)) D . I $$G ETNPI^IBCE F73A($P(^D GCR(399,IB IFN1,I,J,0 ),U,2))="" Q ;Don't file prov ider if no NPI - IB* 2*516 . S CNT=CNT+1, ^DGCR(399, IBIFN,I,CN T,0)=^DGCR (399,IBIFN 1,I,J,0),X =$P(^(0)," ^") . I Z' =Z0,$S(X=3 :Z0=3,X=4: Z0=2,1:0) S $P(^DGCR (399,IBIFN ,I,CNT,0), U)=(Z0+1) I CNT S ^D GCR(399,IB IFN,I,0)=^ DGCR(399,I BIFN1,I,0) ,$P(^DGCR( 399,IBIFN, I,0),U,3)= CNT,$P(^DG CR(399,IBI FN,I,0),U, 4)=CNT Q ; U9 ; Added for new d ata elemen ts in IB*2 .0*447 BI M ^DGCR(39 9,IBIFN,I) =^DGCR(399 ,IBIFN1,I) Q ;COB S J=0 F S J =$O(IBCOB( I,J)) Q:'J S $P(^DG CR(399,IBI FN,I),U,J) =IBCOB(I,J ) Q ;FILE N DIC,DIE, DR,DA,X,Y, DLAYGO,DD, DO I '$D(^ DGCR(399,I BIFN,"CP", 0)) S DIC( "P")=$$GET SPEC^IBEFU NC(399,304 ) S DIC(0) ="L",DLAYG O=399,DA(1 )=IBIFN,DI C="^DGCR(3 99,"_DA(1) _",""CP"", " Q:X="" D FILE^DIC N K DO,DD Q:+Y<1 S D A=+Y S DIE ="^DGCR(39 9,"_DA(1)_ ",""CP""," ,DR="1///" _DGPROCDT D ^DIE K D GPROCDT Q ;INDEX ;in dex entire file (set logic) N IBMAED D S AVERC(IBIF N,.IBMAED) ; IB*2.0* 447 BI - S ave the va lue of pie ce 16 of e ach RC nod e before r e-indexing . S DIK="^ DGCR(399," ,DA=IBIFN D IX1^DIK K DA,DIK D RESTRC(IB IFN,.IBMAE D) ; IB*2. 0*447 BI - Restore t he value o f piece 16 of each R C node bef ore re-ind exing. Q ; PRIOR(IBIF N) ; set S econdary/T ertiary Bi ll #s on p rior bills , if the b ill is can celled rem ove it fro m prior bi lls N IBSE Q,IBSEQN,I BM1,I,IBIF N1 S IBSEQ =$$COB^IBC EF(IBIFN) S IBSEQN=$ S(IBSEQ="S ":6,IBSEQ= "T":7,1:"" ) Q:'IBSEQ N ; S IBM1 =$G(^DGCR( 399,IBIFN, "M1")) I + $P(^DGCR(3 99,IBIFN,0 ),U,13)=7 S IBIFN="" F I=5,6 I I<IBSEQN S IBIFN1= +$P(IBM1,U ,I) I +IBI FN1,$D(^DG CR(399,+IB IFN1,0)) S $P(^DGCR( 399,IBIFN1 ,"M1"),U,I BSEQN)=IBI FN Q ;COBC HG(IBIFN,I BINS,IBCOB ) ; Make c hanges for a new COB payer for bill ; IB IFN = ien of bill in file 399 ; IBINS = ien of bil l's curren t insuranc e (optiona l) ; IBCOB = array s ubscripted by node,p iece of CO B data fie ld change ; N I,IBFR MTYP,IBTAX LST ; Subt ract the P rior Payme nts from t he bill's Offset (th ese are re -added by triggers) F I=4,5,6 S $P(^DGCR (399,IBIFN ,"U1"),U,2 )=$P($G(^D GCR(399,IB IFN,"U1")) ,U,2)-$P($ G(^DGCR(39 9,IBIFN,"U 2")),U,I) ; I $G(IBI NS),$$MCRW NR^IBEFUNC (IBINS) D . ;MCRWNR is current insurance ... move payer only . N IBCOB N,IBX . S IBCOBN=$$C OBN^IBCEF( IBIFN) . S IBCOB(0,2 1)=$P("S^T ^",U,IBCOB N) . S IBC OB("M1",IB COBN+4)=IB IFN . S IB COB("TX",1 )="",IBCOB ("TX",2)=" " . S IBX= $$REQMRA^I BEFUNC(IBI FN) . I IB X=0 S IBCO B("TX",5)= 0 ; MRA no t needed . I IBX["R" S IBCOB(" TX",5)="A" ; MRA ski pped . I I BX=1,$$CHK ^IBCEMU1(I BIFN) S IB COB("TX",5 )="C" ; M RA on file . I $G(IB PRCOB) S I BCOB("TX", 5)="C" ; MRA b eing proc' d . D PRIO R(IBIFN) . Q ; ;rese t fields f or next Se quence Pay er F I=0," M1","U2"," TX" I $D(I BCOB(I)) D COB ; ; I B*2.0*211 ; save off Form Type S IBFRMTY P=$P($G(^D GCR(399,IB IFN,0)),U, 19) ; Save off Taxon omies for providers. S I=0 F S I=$O(^DG CR(399,IBI FN,"PRV",I )) Q:'I S IBTAXLST( I)=$P($G(^ DGCR(399,I BIFN,"PRV" ,I,0)),U,1 5) ; ; fir e xrefs se t logic D INDEX ; ; Restore Fo rm Type if changed, but don't restore Fo rm Type if ; creatin g CMS-1500 claim fro m CTCOPY1^ IBCCCB I $ G(IBCTCOPY )'=1,IBFRM TYP'=$P($G (^DGCR(399 ,IBIFN,0)) ,U,19) N D A,DIE,DR S DA=IBIFN, DIE="^DGCR (399,",DR= ".19////"_ IBFRMTYP D ^DIE ; ; Restore Cl aim MRA St atus field since tri ggers in f ields 101 & 102 ; wi ll overwri te the cor rect value when proc essing the MRA/EOB. ; If we're processin g the MRA/ EOB, then a valid MR A has been received. I $G(IBPR COB) N DA, DIE,DR S D A=IBIFN,DI E="^DGCR(3 99,",DR="2 4////C" D ^DIE ; ; O nly if clo ning, then restore T axonomies in fields 243 and 24 4 and 252. I '$G(IBI NS),'$G(IB PRCOB) D . S I=$P($G (IBND("U3" )),U,2) . I I'=$P($G (^DGCR(399 ,IBIFN,"U3 ")),U,2) D .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 3////"_$S( I'="":I,1: "@") D ^DI E . ; . S I=$P($G(IB ND("U3")), U,3) . I I '=$P($G(^D GCR(399,IB IFN,"U3")) ,U,3) D .. N DA,DIE, DR S DA=IB IFN,DIE="^ DGCR(399," ,DR="244// //"_$S(I'= "":I,1:"@" ) D ^DIE . ; . S I=$ P($G(IBND( "U3")),U,1 1) . I I'= $P($G(^DGC R(399,IBIF N,"U3")),U ,11) D .. N DA,DIE,D R S DA=IBI FN,DIE="^D GCR(399,", DR="252/// /"_$S(I'=" ":I,1:"@") D ^DIE . Q ; ; Rest ore Taxono mies in fi eld .15 in sub-file 399.0222. S IBTAXLST =0 F S IB TAXLST=$O( IBTAXLST(I BTAXLST)) Q:'IBTAXLS T D . S I =IBTAXLST( IBTAXLST) . I I=$P($ G(^DGCR(39 9,IBIFN,"P RV",IBTAXL ST,0)),U,1 5) Q ; No change . N DA,DIE,D R . S DA(1 )=IBIFN,DA =IBTAXLST . S DIE="^ DGCR(399," _DA(1)_"," "PRV"",",D R=".15//// "_$S(I'="" :I,1:"@") . D ^DIE . Q ; K IBC OB("TX") Q ;SAVERC(I BIFN,IBMAE D) ; IB*2. 0*447 BI - Save the value of p iece 16 of each RC n ode before re-indexi ng. Q:$G(I BCTCOPY)=1 Q:$G(IBCT COPY)=2 N IBCNT S IB CNT=0 Q:'$ G(IBIFN) Q :'$D(^DGCR (399,IBIFN ,"RC")) F S IBCNT=$ O(^DGCR(39 9,IBIFN,"R C",IBCNT)) Q:+IBCNT= 0 D . S IB MAED(IBCNT )=$P($G(^D GCR(399,IB IFN,"RC",I BCNT,0)),U ,16) Q ;RE STRC(IBIFN ,IBMAED) ; IB*2.0*44 7 BI - Res tore the v alue of pi ece 16 of each RC no de after r e-indexing . Q:$G(IBC TCOPY)=1 Q :$G(IBCTCO PY)=2 N IB CNT S IBCN T=0 Q:'$G( IBIFN) Q:' $D(^DGCR(3 99,IBIFN," RC")) F S IBCNT=$O( IBMAED(IBC NT)) Q:+IB CNT=0 D . S $P(^DGCR (399,IBIFN ,"RC",IBCN T,0),U,16) =IBMAED(IB CNT) Q | |
| 1009 | ||
| 1010 | ||
| 1011 | Routines | |
| 1012 | Activities | |
| 1013 | Routine Na me | |
| 1014 | IBCECOB4 | |
| 1015 | Enhancemen t Category | |
| 1016 | New | |
| 1017 | Modify | |
| 1018 | Delete | |
| 1019 | No Change | |
| 1020 | RTM | |
| 1021 | ||
| 1022 | Related Op tions | |
| 1023 | None | |
| 1024 | Related Ro utines | |
| 1025 | Routines “ Called By” | |
| 1026 | Routines “ Called” | |
| 1027 | ||
| 1028 | ||
| 1029 | ||
| 1030 | ||
| 1031 | Data Dicti onary (DD) Reference s | |
| 1032 | ||
| 1033 | Related Pr otocols | |
| 1034 | None | |
| 1035 | Related In tegration Control Re gistration s (ICRs) | |
| 1036 | None | |
| 1037 | Data Passi ng | |
| 1038 | Input | |
| 1039 | Output Re ference | |
| 1040 | Both | |
| 1041 | Global Re ference | |
| 1042 | Local | |
| 1043 | Input Attr ibute Name and Defin ition | |
| 1044 | Name: | |
| 1045 | Definition : | |
| 1046 | Output Att ribute Nam e and Defi nition | |
| 1047 | Name: | |
| 1048 | Definition : | |
| 1049 | Current Lo gic | |
| 1050 | IBCECOB4 ; ALB/CXW - IB EM MANA GEMENT - R EVIEW STAT US SCREEN ;16-MAY-20 00 ;;2.0;I NTEGRATED BILLING;** 137,181,34 8,349**;21 -MAR-1994; Build 46 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ;EN ; -- main entry poin t for clai ms status awaiting r esolution detail S V ALMCNT=0,V ALMBG=1 D EN^VALM("I BCEM EOB R EVIEW") Q ;HDR ; -- header cod e ;IBDA - ien EOB se lection sc reen N IBS T S IBST=$ P($G(^IBM( 361.1,IBDA ,0)),U,16) S VALMHDR (2)="Revie w Status= "_$S(IBST= 1:"REVIEW IN PROCESS ",IBST=2:" ACCEPTED-I NTERIM EOB ",IBST=3:" ACCEPTED-C OMPLETE EO B",IBST=4: "REJECTED" ,IBST=9:"C LAIM CANCE LLED",1:"N OT REVIEWE D") Q ;INI T ; -- ini t variable s and list array N I ,X,Y,Z,IBZ ,IBFST,IBP AT K ^TMP( "IBCECOC", $J)SCR S V ALMCNT=0 ; IBCMT = t he data ex tracted in to ^TMP("I BCECOB1",$ J) ; IBIFN = the ien of the bi ll ; IBDA = the ien of the ent ry in 361. 1 S Z=$G(^ DPT(+$P($G (^DGCR(399 ,IBIFN,0)) ,U,2),0)) S IBPAT=$E ($P(Z,U),1 ,25)_"/"_$ E($P(Z,U,9 ),6,9) S X ="" S X=$$ SETFLD^VAL M1($$BN1^P RCAFN(IBIF N),X,"BILL ") S X=$$S ETFLD^VALM 1($$DAT1^I BOUTL($P(I BCMT,U)),X ,"SERVICE" ) S X=$$SE TFLD^VALM1 (IBPAT,X," PATNM") S X=$$SETFLD ^VALM1(" " _$P("PRI^S EC^TER",U, +$P(IBCMT, U,16)),X," SEQ") S X= $$SETFLD^V ALM1(" "_$ $TYPE^IBJT LA1($P(IBC MT,U,5))_" /"_$S(+$P( IBCMT,U,6) =2:"CMS-15 00",1:"UB- 04"),X,"BT YPE") D SE T(X) S Z=0 F S Z=$O (^IBM(361. 1,IBDA,21, Z)) Q:'Z S I=$G(^(Z ,0)) D . S X=$$SETST R^VALM1("R eview Date /Time: "_$ $EXPAND^IB TRE(361.12 1,.01,+I), "",2,40) . D SET(X) . I $P($G( ^VA(200,+$ P(I,U,2),0 )),U)'="" S X=$$SETS TR^VALM1(" Reviewed B y: "_$P($G (^VA(200,+ $P(I,U,2), 0)),U),"", 2,50) D SE T(X) . S ( IBFST,Y)=0 F S Y=$O (^IBM(361. 1,IBDA,21, Z,1,Y)) Q: 'Y D .. S X=$$SETST R^VALM1($S ('IBFST:"C omments: " ,1:"")_$G( ^IBM(361.1 ,IBDA,21,Z ,1,Y,0))," ",2,$S('IB FST:140,1: 150)) .. D SET(X) .. S IBFST=1 . D SET(" ")INITQ Q ;HELP ; -- help code S X="?" D DISP^XQOR M1 W !! Q ;EXIT ; -- exit code K ^TMP("I BCECOC",$J ) D CLEAN^ VALM10 Q ; SET(X) ; S VALMCNT=V ALMCNT+1 S ^TMP("IBC ECOC",$J,V ALMCNT,0)= X S ^TMP(" IBCECOC",$ J,"IDX",VA LMCNT,1)=" " S ^TMP(" IBCECOC",$ J,1)=VALMC NT Q ;STAT US ; Edit review sta tus ;IBDA - EOB ien N DA,DIE,D R,IBOLD,DI C,DO,DD,DL AYGO,IBFIN AL,IBO,IBN EW,IBFACT D FULL^VAL M1 S DIE=" ^IBM(361.1 ," S DA=IB DA G:'DA S TATUSQ S I BOLD=$P($G (^IBM(361. 1,DA,0)),U ,16),IBFIN AL=0,IBO=$ S(IBOLD'=" ":"/"_IBOL D,1:"@") S DR="@1;.1 6;I +X<3 S IBFINAL=0 ,Y=""@99"" ;S IBFINAL =1;.2;I X= """" W !," "For a fin al status, this fiel d is requi red"" S Y= ""@98"";S Y=""@99""; @98;.16/// "_IBO_";S Y=""@1"";@ 99" L +^IB M(361.1,IB DA):3 I '$ T D G STA TUSQ . W ! ,"Sorry, a nother use r currentl y editing this entry (#"_IBDA_ ")." D ^DI E ; I $G(I BFINAL) D ;Final st atus selec ted - let remarks be entered . N Z . S Z =IBDA . N IBDA,Q,DIE ,DR,DA,X,Y . S IBDA( 1)=Z,IBDA= "" . D ADD COM(.IBDA, .DUZ,.IBCO M) . I $P( $G(^IBM(36 1.1,IBDA(1 ),0)),U,20 )="F",'$O( ^IBM(361.1 ,IBDA(1),2 1,+IBDA,0) ) D ; Re quire rema rks for 'O THER ACTIO N' final s tatus .. W !,"Since FILED - NO ACTION fi nal status was selec ted, you m ust enter a",!," com ment expla ining the FILED - NO ACTION" D ADDCOM(.I BDA,.DUZ,. IBCOM,1) . . I IBDA D ... ; Del ete entry if just en tered with out a comm ent ... D KILLREV(.I BDA) .. I '$O(^IBM(3 61.1,IBDA( 1),21,+IBD A,0)) S DI E="^IBM(36 1.1,",DA=I BDA(1),DR= ".20///@;. 16///"_IBO D ^DIE W !,"The rev iew status was not c hanged bec ause no co mment was entered",! Q S IBNEW =$P($G(^IB M(361.1,DA ,0)),U,16) ;if time out-no cha nge in rev iew status S IBFACT= $P($G(^IBM (361.1,DA, 0)),U,20) I $G(IBFIN AL),IBFACT ="",IBNEW> 1 D G STA TUSQ . W ! ,"The revi ew status was not ch anged beca use no fin al status was select ed" . S DR =".16////" _IBOLD,DIE ="^IBM(361 .1," D ^DI E I IBNEW> 1,$P(^IBM( 361.1,DA,0 ),U,19) D . I "CR"'[ IBFACT D . . N DIR,X, Y .. S DIR ("?",1)="I F THIS BIL L HAS RECE IVED ITS F INAL ELECT RONIC MESS AGE AND NO FURTHER A CTION",DIR ("?",2)="W ILL BE TAK EN ON IT, ANSWER YES " .. S DIR ("A")="DO YOU WANT T O CLOSE TH E TRANSMIS SION RECOR D FOR THIS CLAIM?: " ,DIR("B")= "NO",DIR(0 )="YA" D ^ DIR .. I Y >0 S IBFAC T="N" . I "NCR"[IBFA CT D UPDED I^IBCEM(+$ P(^IBM(361 .1,DA,0),U ,19),IBFAC T) Q I IBO LD'=IBNEW D ;Note t he change and who ma de it . N IBIEN,IBTE XT,DA . S DA(1)=IBDA ,DIC="^IBM (361.1,"_D A(1)_",21, ",DIC(0)=" L",DLAYGO= 361.121 . S X=$$NOW^ XLFDT . S DIC("P")=$ $GETSPEC^I BEFUNC(361 .1,21) . D FILE^DICN K DIC,DD, DO,DLAYGO . Q:Y'>0 . S DA(2)=D A(1),DA(1) =+Y,IBIEN= DA(1)_","_ DA(2)_",", IBTEXT(1)= "REVIEW ST ATUS CHANG ED TO '"_$ $EXPAND^IB TRE(361.1, .16,$P(^IB M(361.1,DA (2),0),U,1 6))_"' BY: "_$$EXPAN D^IBTRE(36 1.121,.02, +$G(DUZ)) . D WP^DIE (361.121,I BIEN,1,,"I BTEXT") K ^TMP("DIER R",$J) . D HDR,INIT L -^IBM(36 1.1,DA)STA TUSQ ; D P AUSE^VALM1 S VALMBCK ="R" Q ;AD DCOM(IBDA, DUZ,IBCOM, ADD) ; Add review co mment to f ile 361.1 ; IBDA = a rray conta ining the DA referen ces for th e file add - ; pass by referen ce ; DUZ = ien of th e user ; A DD = flag when set t o 1 says t he review date exist s, ; just allow comm ent entry ; Returns IBDA = the entry # o f the comm ent ; and IBCOM arra y referenc ing any co mments add ed by the user ; N D A,DIC,DD,D O,DLAYGO,X ,Y S DR=$S ($G(DUZ):" .02////"_D UZ_";",1:" ")_"1" I ' $G(ADD) D . K DO,DD . S DIC="^ IBM(361.1, "_IBDA(1)_ ",21,",DA( 1)=IBDA(1) ,X=$$NOW^X LFDT . W ! ,"New Revi ew Date: " _$$FMTE^XL FDT(X,2) . S DIC("DR ")=DR,DLAY GO=361.121 . S DIC(0 )="L",DIC( "P")=$$GET SPEC^IBEFU NC(361.1,2 1) . D FIL E^DICN K D IC,DD,DO,D LAYGO . S IBDA=+Y I IBDA>0 D . I $G(ADD) S DIE="^I BM(361.1," _IBDA(1)_" ,21,",DA(1 )=IBDA(1), DA=IBDA D ^DIE . I ' $O(^IBM(36 1.1,IBDA(1 ),21,IBDA, 0)) D KILL REV(.IBDA) Q . S IBC OM(DUZ,IBD A)="" Q ;K ILLREV(IBD A) ; Delet es a revie w date if no comment s entered N DA,DIK S DA=IBDA,D A(1)=IBDA( 1),DIK="^I BM(361.1," _IBDA(1)_" ,21," K IB COM(DUZ,IB DA) D ^DIK Q ; | |
| 1051 | Modified L ogic (Chan ges are in bold) | |
| 1052 | IBCECOB4 ; ALB/CXW - IB EM MANA GEMENT - R EVIEW STAT US SCREEN ;16-MAY-20 00 ;;2.0;I NTEGRATED BILLING;** 137,181,34 8,349,592* *;21-MAR-1 994;Build 46 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ;EN ; -- m ain entry point for claims sta tus awaiti ng resolut ion detail S VALMCNT =0,VALMBG= 1 D EN^VAL M("IBCEM E OB REVIEW" ) Q ;HDR ; -- header code ;IBD A - ien EO B selectio n screen N IBST S IB ST=$P($G(^ IBM(361.1, IBDA,0)),U ,16) S VAL MHDR(2)="R eview Stat us= "_$S(I BST=1:"REV IEW IN PRO CESS",IBST =2:"ACCEPT ED-INTERIM EOB",IBST =3:"ACCEPT ED-COMPLET E EOB",IBS T=4:"REJEC TED",IBST= 9:"CLAIM C ANCELLED", 1:"NOT REV IEWED") Q ;INIT ; -- init vari ables and list array N I,X,Y,Z ,IBZ,IBFST ,IBPAT K ^ TMP("IBCEC OC",$J)SCR S VALMCNT =0 ; IBCMT = the dat a extracte d into ^TM P("IBCECOB 1",$J) ; I BIFN = the ien of th e bill ; I BDA = the ien of the entry in 361.1 S Z= $G(^DPT(+$ P($G(^DGCR (399,IBIFN ,0)),U,2), 0)) S IBPA T=$E($P(Z, U),1,25)_" /"_$E($P(Z ,U,9),6,9) S X="" S X=$$SETFLD ^VALM1($$B N1^PRCAFN( IBIFN),X," BILL") S X =$$SETFLD^ VALM1($$DA T1^IBOUTL( $P(IBCMT,U )),X,"SERV ICE") S X= $$SETFLD^V ALM1(IBPAT ,X,"PATNM" ) S X=$$SE TFLD^VALM1 (" "_$P("P RI^SEC^TER ",U,+$P(IB CMT,U,16)) ,X,"SEQ") ;JWS;IB*2. 0*592:Dent al form #7 J430D S X =$$SETFLD^ VALM1(" "_ $$TYPE^IBJ TLA1($P(IB CMT,U,5))_ "/"_$S(+$P (IBCMT,U,6 )=2:"CMS-1 500",$P(IB CMT,U,6)=7 :"J430D",1 :"UB-04"), X,"BTYPE") D SET(X) S Z=0 F S Z=$O(^IBM (361.1,IBD A,21,Z)) Q :'Z S I=$ G(^(Z,0)) D . S X=$$ SETSTR^VAL M1("Review Date/Time : "_$$EXPA ND^IBTRE(3 61.121,.01 ,+I),"",2, 40) . D SE T(X) . I $ P($G(^VA(2 00,+$P(I,U ,2),0)),U) '="" S X=$ $SETSTR^VA LM1("Revie wed By: "_ $P($G(^VA( 200,+$P(I, U,2),0)),U ),"",2,50) D SET(X) . S (IBFST ,Y)=0 F S Y=$O(^IBM (361.1,IBD A,21,Z,1,Y )) Q:'Y D .. S X=$$ SETSTR^VAL M1($S('IBF ST:"Commen ts: ",1:"" )_$G(^IBM( 361.1,IBDA ,21,Z,1,Y, 0)),"",2,$ S('IBFST:1 40,1:150)) .. D SET( X) .. S IB FST=1 . D SET("")INI TQ Q ;HELP ; -- help code S X= "?" D DISP ^XQORM1 W !! Q ;EXIT ; -- exit code K ^T MP("IBCECO C",$J) D C LEAN^VALM1 0 Q ;SET(X ) ; S VALM CNT=VALMCN T+1 S ^TMP ("IBCECOC" ,$J,VALMCN T,0)=X S ^ TMP("IBCEC OC",$J,"ID X",VALMCNT ,1)="" S ^ TMP("IBCEC OC",$J,1)= VALMCNT Q ;STATUS ; Edit revie w status ; IBDA - EOB ien N DA, DIE,DR,IBO LD,DIC,DO, DD,DLAYGO, IBFINAL,IB O,IBNEW,IB FACT D FUL L^VALM1 S DIE="^IBM( 361.1," S DA=IBDA G: 'DA STATUS Q S IBOLD= $P($G(^IBM (361.1,DA, 0)),U,16), IBFINAL=0, IBO=$S(IBO LD'="":"/" _IBOLD,1:" @") S DR=" @1;.16;I + X<3 S IBFI NAL=0,Y="" @99"";S IB FINAL=1;.2 ;I X="""" W !,""For a final st atus, this field is required"" S Y=""@98 "";S Y=""@ 99"";@98;. 16///"_IBO _";S Y=""@ 1"";@99" L +^IBM(361 .1,IBDA):3 I '$T D G STATUSQ . W !,"Sor ry, anothe r user cur rently edi ting this entry (#"_ IBDA_")." D ^DIE ; I $G(IBFINA L) D ;Fin al status selected - let remar ks be ente red . N Z . S Z=IBDA . N IBDA, Q,DIE,DR,D A,X,Y . S IBDA(1)=Z, IBDA="" . D ADDCOM(. IBDA,.DUZ, .IBCOM) . I $P($G(^I BM(361.1,I BDA(1),0)) ,U,20)="F" ,'$O(^IBM( 361.1,IBDA (1),21,+IB DA,0)) D ; Require remarks f or 'OTHER ACTION' fi nal status .. W !,"S ince FILED - NO ACTI ON final s tatus was selected, you must e nter a",!, " comment explaining the FILED - NO ACTI ON" D ADDC OM(.IBDA,. DUZ,.IBCOM ,1) .. I I BDA D ... ; Delete e ntry if ju st entered without a comment . .. D KILLR EV(.IBDA) .. I '$O(^ IBM(361.1, IBDA(1),21 ,+IBDA,0)) S DIE="^I BM(361.1," ,DA=IBDA(1 ),DR=".20/ //@;.16/// "_IBO D ^D IE W !,"Th e review s tatus was not change d because no comment was enter ed",! Q S IBNEW=$P($ G(^IBM(361 .1,DA,0)), U,16) ;if time out-n o change i n review s tatus S IB FACT=$P($G (^IBM(361. 1,DA,0)),U ,20) I $G( IBFINAL),I BFACT="",I BNEW>1 D G STATUSQ . W !,"The review st atus was n ot changed because n o final st atus was s elected" . S DR=".16 ////"_IBOL D,DIE="^IB M(361.1," D ^DIE I I BNEW>1,$P( ^IBM(361.1 ,DA,0),U,1 9) D . I " CR"'[IBFAC T D .. N D IR,X,Y .. S DIR("?", 1)="IF THI S BILL HAS RECEIVED ITS FINAL ELECTRONIC MESSAGE A ND NO FURT HER ACTION ",DIR("?", 2)="WILL B E TAKEN ON IT, ANSWE R YES" .. S DIR("A") ="DO YOU W ANT TO CLO SE THE TRA NSMISSION RECORD FOR THIS CLAI M?: ",DIR( "B")="NO", DIR(0)="YA " D ^DIR . . I Y>0 S IBFACT="N" . I "NCR" [IBFACT D UPDEDI^IBC EM(+$P(^IB M(361.1,DA ,0),U,19), IBFACT) Q I IBOLD'=I BNEW D ;N ote the ch ange and w ho made it . N IBIEN ,IBTEXT,DA . S DA(1) =IBDA,DIC= "^IBM(361. 1,"_DA(1)_ ",21,",DIC (0)="L",DL AYGO=361.1 21 . S X=$ $NOW^XLFDT . S DIC(" P")=$$GETS PEC^IBEFUN C(361.1,21 ) . D FILE ^DICN K DI C,DD,DO,DL AYGO . Q:Y '>0 . S DA (2)=DA(1), DA(1)=+Y,I BIEN=DA(1) _","_DA(2) _",",IBTEX T(1)="REVI EW STATUS CHANGED TO '"_$$EXPA ND^IBTRE(3 61.1,.16,$ P(^IBM(361 .1,DA(2),0 ),U,16))_" ' BY: "_$$ EXPAND^IBT RE(361.121 ,.02,+$G(D UZ)) . D W P^DIE(361. 121,IBIEN, 1,,"IBTEXT ") K ^TMP( "DIERR",$J ) . D HDR, INIT L -^I BM(361.1,D A)STATUSQ ; D PAUSE^ VALM1 S VA LMBCK="R" Q ;ADDCOM( IBDA,DUZ,I BCOM,ADD) ; Add revi ew comment to file 3 61.1 ; IBD A = array containing the DA re ferences f or the fil e add - ; pass by re ference ; DUZ = ien of the use r ; ADD = flag when set to 1 s ays the re view date exists, ; just allow comment e ntry ; Ret urns IBDA = the entr y # of the comment ; and IBCOM array ref erencing a ny comment s added by the user ; N DA,DIC ,DD,DO,DLA YGO,X,Y S DR=$S($G(D UZ):".02// //"_DUZ_"; ",1:"")_"1 " I '$G(AD D) D . K D O,DD . S D IC="^IBM(3 61.1,"_IBD A(1)_",21, ",DA(1)=IB DA(1),X=$$ NOW^XLFDT . W !,"New Review Da te: "_$$FM TE^XLFDT(X ,2) . S DI C("DR")=DR ,DLAYGO=36 1.121 . S DIC(0)="L" ,DIC("P")= $$GETSPEC^ IBEFUNC(36 1.1,21) . D FILE^DIC N K DIC,DD ,DO,DLAYGO . S IBDA= +Y I IBDA> 0 D . I $G (ADD) S DI E="^IBM(36 1.1,"_IBDA (1)_",21," ,DA(1)=IBD A(1),DA=IB DA D ^DIE . I '$O(^I BM(361.1,I BDA(1),21, IBDA,0)) D KILLREV(. IBDA) Q . S IBCOM(DU Z,IBDA)="" Q ;KILLRE V(IBDA) ; Deletes a review dat e if no co mments ent ered N DA, DIK S DA=I BDA,DA(1)= IBDA(1),DI K="^IBM(36 1.1,"_IBDA (1)_",21," K IBCOM(D UZ,IBDA) D ^DIK Q ; | |
| 1053 | ||
| 1054 | ||
| 1055 | Routines | |
| 1056 | Activities | |
| 1057 | Routine Na me | |
| 1058 | IBCECSA5 | |
| 1059 | Enhancemen t Category | |
| 1060 | New | |
| 1061 | Modify | |
| 1062 | Delete | |
| 1063 | No Change | |
| 1064 | RTM | |
| 1065 | ||
| 1066 | Related Op tions | |
| 1067 | None | |
| 1068 | Related Ro utines | |
| 1069 | Routines “ Called By” | |
| 1070 | Routines “ Called” | |
| 1071 | ||
| 1072 | ||
| 1073 | ||
| 1074 | ||
| 1075 | Data Dicti onary (DD) Reference s | |
| 1076 | ||
| 1077 | Related Pr otocols | |
| 1078 | None | |
| 1079 | Related In tegration Control Re gistration s (ICRs) | |
| 1080 | None | |
| 1081 | Data Passi ng | |
| 1082 | Input | |
| 1083 | Output Re ference | |
| 1084 | Both | |
| 1085 | Global Re ference | |
| 1086 | Local | |
| 1087 | Input Attr ibute Name and Defin ition | |
| 1088 | Name: | |
| 1089 | Definition : | |
| 1090 | Output Att ribute Nam e and Defi nition | |
| 1091 | Name: | |
| 1092 | Definition : | |
| 1093 | Current Lo gic | |
| 1094 | IBCECSA5 ; ALB/CXW - VIEW EOB S CREEN ;01- OCT-1999 ; ;2.0;INTEG RATED BILL ING;**137, 135,263,28 0,155,349, 489,488,54 7**;21-MAR -1994;Buil d 119 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ; ; referenc e to $$VFI LE^DILFD a llowed wit h IA#2055 (IB*2.0*54 7) ;EN ; - - main ent ry point f or VIEW EO B N VALMCN T,VALMBG,V ALMHDR S V ALMCNT=0,V ALMBG=1 D EN^VALM("I BCEM VIEW EOB") Q ;I NIT ; -- i nit variab les and li st array I '$G(IBIFN ) S VALMQU IT="" G IN ITQ ; b ill# is re quired D H DR^IBCEOB2 ; build t he VALMHDR array K I BCNT,IBONE ,^TMP("IBC ECSD",$J) ; kill var s and scra tch global ; ; 8/13/ 03 - If va riable IBE OBIFN is s et, then t his is the 361.1 ien ; that th e user sel ected from a list. B uild the d etail. I $ G(IBEOBIFN ) S IBCNT= IBEOBIFN,I BONE=1 D B LD^IBCECSA 6,EOBERR G INITQ ; D BLD^IBCEO B2 ; build ^TMP("IBC EOB",$J) c ontaining MRA/EOB li ster S IBO NE=0 M ^TM P("IBCECSD ",$J)=^TMP ("IBCEOB", $J) ; ; 4/ 7/03 - If only 1 EOB record fo und for th is bill, t hen set th e ; IBCNT variable, the IBONE one-time f lag, and b uild the ; detail se ctions of this list. I $G(VALM CNT)=1 S I BCNT=$P($G (^TMP("IBC ECSD",$J,1 )),U,2),IB ONE=1 I IB CNT D BLD^ IBCECSA6 D EOBERR ; IB*2.0*4 88 (vd) ;I NITQ Q ;HE LP ; -- he lp code S X="?" D DI SP^XQORM1 W !! Q ;EX IT ; -- ex it code K ^TMP("IBCE CSD",$J) D CLEAR^VAL M1,CLEAN^V ALM10 QMIN ; N IBREC 1,IBRM1,IB RM2,IBRM3, IBRM4,IBRM 5,IBRL,IBT YPE,IBT,IB TX,IBD ; f lag for in patient mr a S IBTYPE =$S($G(IBS RC):1,$$IN PAT^IBCEF( +IBREC):1, 1:0) ; S I B=$$SETSTR ^VALM1("ME DICARE INF ORMATION:" ,"",1,50) D SET(IB) I '$G(IBSR C) D . D C NTRL^VALM1 0(VALMCNT, 1,21,IORVO N,IORVOFF) . S ^TMP( "IBCECSD", $J,"X",5)= VALMCNT I $G(IBSRC), '$D(^IBM(3 61.1,IBCNT ,4)) Q I ' $G(IBSRC), '$$INPAT^I BCEF(+IBRE C) Q D SET (" INPATIE NT:") S IB REC1=$G(^I BM(361.1,I BCNT,4)),( IB,IBRL)=" " ; F IBT= 2:1 S IBTX =$P($T(MIN DAT+IBT)," ;",3) Q:IB TX="" D . S IBD=$P( IBREC1,"^" ,+IBTX) . I $L($P(IB TX,"^",4)) X $P(IBTX ,"^",4) E N IBFULL S IBFULL=1 . I $S(IB FULL:1,1:I BD) D .. I $L($P(IBT X,"^",4)) X $P(IBTX, "^",4) I Q .. X "S IBD="_$S($ L($P(IBTX, "^",3)):$P (IBTX,"^", 3),1:"$$A1 0(IBD)") . . S IB=$$S ETSTR^VALM 1($P(IBTX, "^",2)_IBD ,IB,$S('IB RL:4,1:37) ,$S('IBRL: 41,1:38)) .. S IBRL= $S(IBRL:0, 1:1) .. I 'IBRL D SE T(IB,IBRL) S IB="" ; D:IBRL'=" " SET(IB) D REMARK Q ;MINDAT ; data for MIN tag ; format: pi ece^label^ special fo rmat code^ special de cision for disp ;;1^ Cov Days/V isit Ct : ^$$RJ(+IBD )^I $G(IBS RC) ;;3^Cl aim DRG Am t : ;;2^L ifetm Psyc h Dy Ct : ^$$RJ(IBD) ;;5^Dispr op Share A mt : ^^I I BTYPE ;;4^ Cap Except ion Amt : ;;7^PPS C apital Amt : ^^I IBT YPE ;;6^MS P Pass Thr u Amt : ; ;9^PPS Cap HSP-DRG A mt: ^^I IB TYPE ;;8^P PS Cap FSP -DRG Amt: ^^I IBTYPE ;;11^Old Capital Am t : ^^I IB TYPE ;;10^ PPS Cap DS H-DRG Amt: ^^I IBTYP E ;;13^PPS Op Hos DR G Amt : ; ;12^PPS Ca pital IME Amt: ^^I I BTYPE ;;15 ^PPS Op Fe d DRG Amt : ^^I IBTY PE ;;14^Co st Report Day Ct : ^ $$RJ(IBD)^ I IBTYPE ; ;17^Indire ct Teach A mt : ^^I I BTYPE ;;16 ^PPS Cap O utlier Amt : ^^I IBTY PE ;;18^No n-Pay Prof Comp : ^$ $RJ(IBD) ; ;19^Non-Co vered Days Ct: ^$$RJ (+IBD)^I I BTYPE ;; ; REMARK ; s et up rema rks and li ne level d etails N I BREC1,IBP, IBT,IBX,RC ODE,RDESC, REXIST Q:$ G(IBREM) S IBREM=1 D SET(" ") D SET(" Cl aim Level Remark Inf ormation") D SET(" C ode Descri ption") I '$G(IBSRC) D . D CNT RL^VALM10( VALMCNT,4, 4,IOUON,IO UOFF) . D CNTRL^VALM 10(VALMCNT ,13,11,IOU ON,IOUOFF) . Q ; S I BREC1=$P($ G(^IBM(361 .1,IBCNT,3 )),U,3,7) I $P(IBREC 1,U,1)="" S IBREC1=$ P($G(^IBM( 361.1,IBCN T,5)),U,1, 5) S REXIS T=0 ; F IB P=1:1:5 D . S RCODE= $P(IBREC1, U,IBP) . S RDESC=$G( ^IBM(361.1 ,IBCNT,"RM "_IBP)) . ; IB*2.0*5 47 - get R ARC desrip tion from new AR fil e 346 when available . I '$$VF ILE^DILFD( 346),RCODE ="",RDESC= "" Q . K I BT . Q:RCO DE="" . I '$$VFILE^D ILFD(346) S REXIST=1 ,IBT(IBP)= RDESC . I $$VFILE^DI LFD(346) S REXIST=$$ CARC(RCODE ,346,60,"I BT") Q:REX IST<1 . D TXT1(.IBT, 0,60) . D SET(" "_$$ LJ^XLFSTR( RCODE,6)_" - "_$G(IBT (1))) . S IBX=1 . F S IBX=$O( IBT(IBX)) Q:'IBX D SET($J("", 12)_IBT(IB X)) . Q ; I 'REXIST D SET(" No claim lev el remarks on file") D SET(" " ) Q:$G(IBS RC) ; MRA Only ;MRAL LA S IB=$$ SETSTR^VAL M1("LINE L EVEL ADJUS TMENTS:"," ",1,50) D SET(IB) I '$G(IBSRC) D . D CNT RL^VALM10( VALMCNT,1, 23,IORVON, IORVOFF) . S ^TMP("I BCECSD",$J ,"X",7)=VA LMCNT I '$ D(^IBM(361 .1,IBCNT,1 5,0)) D SE T(" NONE") Q ; only if there is info ; ; look up all billed data N IB ZDATA,IBFO RM,IBX2,IB X3,IBREC2, IBREC3,IBT X,IBT,IBRC ,IBZ,IBTXL S IBFORM= 0 ; cms-15 00 I $$FT^ IBCEF(+IBR EC)=3 S IB FORM=1 ; U B-04 D F^I BCEF("N-"_ $S(IBFORM: "UB-04",1: "HCFA 1500 ")_" SERVI CE LINE (E DI)","IBZD ATA",,+IBR EC) ; S IB X=0 F S I BX=$O(^IBM (361.1,IBC NT,15,IBX) ) Q:IBX<1 S IBREC1=^ IBM(361.1, IBCNT,15,I BX,0) D . NEW RVL . D SET(" # SV DT REVC D PROC MOD UNITS BIL LED DEDUCT COINS ALL OW PYMT") . S RVL=+$ P(IBREC1,U ,12) ; ref erenced Vi sta line# . I 'RVL S RVL=IBX ; use the EOB line# if not th ere . S IB T=$$RJ($P( IBREC1,"^" ),3) ; lin e number . S IBT=IBT _" "_$$RJ( $$DAT1^IBO UTL($P($P( IBREC1,"^" ,16),".")) ,8) ; serv ice date . S IBT=IBT _" "_$$RJ( $$EXTERNAL ^DILFD(361 .115,.1,"" ,$P(IBREC1 ,"^",10)), 6) ; revcd . S IBT=I BT_" "_$$R J($P(IBREC 1,"^",4),5 ) ; proced ure . S IB T=IBT_" "_ $$RJ($P($G (^IBM(361. 1,IBCNT,15 ,IBX,2,1,0 )),"^"),3) _$S($D(^IB M(361.1,IB CNT,15,IBX ,2,2,0)):" +",1:" ") ; modifier s . S IBT= IBT_" "_$$ RJ($FN($P( IBREC1,"^" ,11),"",0) ,5) ; unit s . S IBT= IBT_" "_$$ RJ($FN($S( IBFORM:$P( $G(IBZDATA (RVL)),"^" ,5),1:$P($ G(IBZDATA( RVL)),"^", 8)*$P($G(I BZDATA(RVL )),"^",9)) ,"",2),8) ; billed . S IBT=IBT _" "_$$RJ( $FN($P($G( ^IBM(361.1 ,IBCNT,15, IBX,1,+$O( ^IBM(361.1 ,IBCNT,15, IBX,1,"B", "PR",0)),1 ,+$O(^IBM( 361.1,IBCN T,15,IBX,1 ,+$O(^IBM( 361.1,IBCN T,15,IBX,1 ,"B","PR", 0)),1,"B", 1,0)),0)), "^",2),"", 2),7) ; de duct . S I BT=IBT_" " _$$RJ($FN( $P($G(^IBM (361.1,IBC NT,15,IBX, 1,+$O(^IBM (361.1,IBC NT,15,IBX, 1,"B","PR" ,0)),1,+$O (^IBM(361. 1,IBCNT,15 ,IBX,1,+$O (^IBM(361. 1,IBCNT,15 ,IBX,1,"B" ,"PR",0)), 1,"B",2,0) ),0)),"^", 2),"",2),6 ) ; coins . S IBT=IB T_" "_$$RJ ($FN($P(IB REC1,"^",1 3),"",2),8 ) ; allow . S IBT=IB T_" "_$$RJ ($FN($P(IB REC1,"^",3 ),"",2),8) ; payment . D SET(I BT) . S IB X2=0 F S IBX2=$O(^I BM(361.1,I BCNT,15,IB X,1,IBX2)) Q:IBX2<1 D .. S IBR EC2=^IBM(3 61.1,IBCNT ,15,IBX,1, IBX2,0),IB X3=0 .. F S IBX3=$O (^IBM(361. 1,IBCNT,15 ,IBX,1,IBX 2,1,IBX3)) Q:IBX3<1 D ... S IB REC3=^IBM( 361.1,IBCN T,15,IBX,1 ,IBX2,1,IB X3,0) ... ; line lev el adjustm ents; don' t display kludges (e sg 10/23/0 3) ... I $ P(IBREC2,U ,1)="PR",$ P(IBREC3,U ,1)="AAA" Q ... I $P (IBREC2,U, 1)="OA",$P (IBREC3,U, 1)="AB3" Q ... I $P( IBREC2,U,1 )="LQ" Q . .. ; IB*2. 0*547 - ge t CARC des cription f rom AR fil e 345, whe n ready .. . I '$$VFI LE^DILFD(3 45) S IBTX (1)="ADJ: "_$P(IBREC 2,"^")_" " _$P(IBREC3 ,"^")_" "_ $P(IBREC3, "^",4) D T XT1(.IBTX, 0,79) S IB T=0 F S I BT=$O(IBTX (IBT)) Q:I BT<1 D SET (IBTX(IBT) ) ... I $$ VFILE^DILF D(345) S I BT=$$CARC( $P(IBREC3, "^"),345,7 9,"IBTX"), IBTX(1)="A DJ: "_$P(I BREC2,"^") _" "_$P(IB REC3,"^")_ ": "_$G(IB TX(1)) D T XT1(.IBTX, 0,79) S IB T=0 F S I BT=$O(IBTX (IBT)) Q:I BT<1 D SET (IBTX(IBT) ) ... K IB TX ... D S ET("ADJ AM T: "_$FN($ P(IBREC3," ^",2),"",2 )) . S IBR C=0 . F S IBRC=$O(^ IBM(361.1, IBCNT,15,I BX,4,IBRC) ) Q:'IBRC S IBREC2= $G(^(IBRC, 0)) I IBRE C2 K IBTX, IBZ S IBTX (1)=" -REM ARK CODE(" _+IBREC2_" ): ",IBTXL =$L(IBTX(1 )) D .. ; IB*2.0*547 - get RAR C descript ion from A R file 346 , when rea dy .. I '$ $VFILE^DIL FD(346) S IBTX(1)=IB TX(1)_$P(I BREC2,U,2) _" "_$P(IB REC2,U,3) .. I $$VFI LE^DILFD(3 46) S IBT= $$CARC($P( IBREC2,U,2 ),346,79," IBTX"),IBT X(1)=IBTX( 1)_$P(IBRE C2,U,2)_" "_$G(IBT(1 )) .. I $L (IBTX(1))> 79 D ... D TXT1(.IBT X,0,79) D SET(IBTX(1 )) M IBZ=I BTX K IBTX S IBTX(1) ="",IBT=1 F S IBT=$ O(IBZ(IBT) ) Q:'IBT S IBTX(1)= IBTX(1)_IB Z(IBT)_" " .. E D . .. S IBTXL =0 .. D TX T1(.IBTX,I BTXL,79) S IBT=0 F S IBT=$O(I BTX(IBT)) Q:IBT<1 D SET(IBTX(I BT)) . D S ET(" ") D SET(" ") Q ; ;/Begin ning IB*2. 0*488 (vd) EOBERR ; D isplay inf ormation a bout any 3 61.1 messa ge storage or filing errors N ERRTXT,DAS HES,Z S DA SHES="---- ---------- ---------- ---------- ---------- ---------- ---------- -----" I ' $O(^IBM(36 1.1,IBCNT, "ERR",0)) Q D SET("V istA could not match all of th e Line Lev el data re ceived in the EEOB") D SET("(8 35 Record 40) to the claim in VistA.") D SET(" ") S Z=0 F S Z=$O(^IBM (361.1,IBC NT,"ERR",Z )) Q:'Z D .S ERRTXT =$G(^IBM(3 61.1,IBCNT ,"ERR",Z,0 )) .I ERRT XT["##RAW DATA" S ER RTXT=DASHE S .D SET(E RRTXT) Q ; /End of IB *2.0*488 ( vd) ;TXT(I BRM,IBLN,I BXY) ;disp lay text o ver 79 cha rs ;IBRM - text, IBL N - length , IBXY - p osition S IBRM=$E(IB RM,IBLN+1, 999)REP I $E(IBRM,1, IBLN)'="" S IB=$$SET STR^VALM1( $E(IBRM,1, IBLN),"",I BXY,IBLN) D SET(IB) S IBRM=$E( IBRM,IBLN+ 1,999) G R EP Q ;SET( IB,IBSAV) ; I '$G(IB SAV) D SET ^IBCECSA6( $G(IBSRC), IB,+$G(CNT ),IBCNT) Q ;A10(X) ; Q $$A10^I BCECSA6(X) ;A7(X) ; returns a dollar amo unt right justified to 7 chara cters Q $$ RJ($FN(X," ",2),7) ;T XT1(IBT,DI WL,DIWR) ; sets up t ext for ov er 79 char s ; IBT - pass by re f, array o f text to be formatt ed back in array ; D IWL - left margin, D IWR = righ t margin N IBX,X,DIW F,IBS K ^U TILITY($J, "W") S DIW F="|I"_DIW L S IBX=0 F S IBX=$ O(IBT(IBX) ) Q:IBX<1 S X=IBT(IB X) D ^DIWP K IBT F S IBX=$O(^ UTILITY($J ,"W",DIWL, IBX)) Q:IB X<1 S IBT( IBX)=^UTIL ITY($J,"W" ,DIWL,IBX, 0) K ^UTIL ITY($J,"W" ) Q ;RJ(X, Y) ; right just, def ault is 10 Q $$RJ^XL FSTR(X,$G( Y,10)," ") ;CARC(IBC DE,IBF,IBM L,IBARY) ; new CARC/R ACR API fo r IB*2.0*5 47 ; IBCDE = reason code from EOB to loo kup in car c/rarc fil e (REQUIRE D) ; IBF = file# to do lookup (either 34 5-CARC or 346-RARC) *REQUIRED* ; IBML = max length for each line (defa ult is 79) ; IBARY = (required ) subscrip ted array to return descriptio n data in: ; array(1 )=first li ne of word -processed descripti on ; array (2)= 2nd l ine of wp descriptio n, and so on ; ; Ret urns total # of line s in descr iption ; N IBY,IBX,I BC,IBI,IBN ,IBALN,IBS TP,IBDSC S IBC=0 Q:$ G(IBARY)=" " IBC Q:$G (IBCDE)="" IBC Q:$G( IBF)="" IB C S:$G(IBM L)="" IBML =79 S IBY= $$FIND1^DI C(IBF,,"BX ",IBCDE) Q :IBY<1 IBC S IBX=$$G ET1^DIQ(IB F,IBY_",", 4,"","IBDS C") S IBI= 0 F S IBI =$O(IBDSC( IBI)) Q:'I BI D .S I BC=IBC+1,I BSTP=0,IBA LN=$L(IBDS C(IBI)) .S @IBARY@(I BI)=$E(IBD SC(IBI),1, IBML) Q:IB ML>IBALN . S IBDSC(IB I+1)=($E(I BDSC(IBI), (IBML+1),I BALN)_" "_ $G(IBDSC(I BI+1))) .; make sure we don't break word s in 2 .Q: $E(@IBARY@ (IBI),IBML )=" " .F I BN=IBML:-1 :1 Q:$G(IB STP)=1 D . .Q:$E(IBDS C(IBI),IBN )'=" " .. S @IBARY@( IBI)=$E(IB DSC(IBI),1 ,IBN),IBDS C(IBI+1)=( $E(IBDSC(I BI),(IBN+1 ),IBML)_$G (IBDSC(IBI +1))),IBST P=1 Q Q IB C ; | |
| 1095 | Modified L ogic (Chan ges are in bold) | |
| 1096 | IBCECSA5 ; ALB/CXW - VIEW EOB S CREEN ;01- OCT-1999 ; ;2.0;INTEG RATED BILL ING;**137, 135,263,28 0,155,349, 489,488,54 7,592**;21 -MAR-1994; Build 119 ;;Per VA D irective 6 402, this routine sh ould not b e modified . ; ; refe rence to $ $VFILE^DIL FD allowed with IA#2 055 (IB*2. 0*547) ;EN ; -- main entry poi nt for VIE W EOB N VA LMCNT,VALM BG,VALMHDR S VALMCNT =0,VALMBG= 1 D EN^VAL M("IBCEM V IEW EOB") Q ;INIT ; -- init va riables an d list arr ay I '$G(I BIFN) S VA LMQUIT="" G INITQ ; bill# i s required D HDR^IBC EOB2 ; bui ld the VAL MHDR array K IBCNT,I BONE,^TMP( "IBCECSD", $J) ; kill vars and scratch gl obal ; ; 8 /13/03 - I f variable IBEOBIFN is set, th en this is the 361.1 ien ; tha t the user selected from a lis t. Build t he detail. I $G(IBEO BIFN) S IB CNT=IBEOBI FN,IBONE=1 D BLD^IBC ECSA6,EOBE RR G INITQ ; D BLD^I BCEOB2 ; b uild ^TMP( "IBCEOB",$ J) contain ing MRA/EO B lister S IBONE=0 M ^TMP("IBC ECSD",$J)= ^TMP("IBCE OB",$J) ; ; 4/7/03 - If only 1 EOB recor d found fo r this bil l, then se t the ; IB CNT variab le, the IB ONE one-ti me flag, a nd build t he ; detai l sections of this l ist. I $G( VALMCNT)=1 S IBCNT=$ P($G(^TMP( "IBCECSD", $J,1)),U,2 ),IBONE=1 I IBCNT D BLD^IBCECS A6 D EOBER R ; IB*2 .0*488 (vd ) ;INITQ Q ;HELP ; - - help cod e S X="?" D DISP^XQO RM1 W !! Q ;EXIT ; - - exit cod e K ^TMP(" IBCECSD",$ J) D CLEAR ^VALM1,CLE AN^VALM10 QMIN ; N I BREC1,IBRM 1,IBRM2,IB RM3,IBRM4, IBRM5,IBRL ,IBTYPE,IB T,IBTX,IBD ; flag fo r inpatien t mra S IB TYPE=$S($G (IBSRC):1, $$INPAT^IB CEF(+IBREC ):1,1:0) ; S IB=$$SE TSTR^VALM1 ("MEDICARE INFORMATI ON:","",1, 50) D SET( IB) I '$G( IBSRC) D . D CNTRL^V ALM10(VALM CNT,1,21,I ORVON,IORV OFF) . S ^ TMP("IBCEC SD",$J,"X" ,5)=VALMCN T I $G(IBS RC),'$D(^I BM(361.1,I BCNT,4)) Q I '$G(IBS RC),'$$INP AT^IBCEF(+ IBREC) Q D SET(" INP ATIENT:") S IBREC1=$ G(^IBM(361 .1,IBCNT,4 )),(IB,IBR L)="" ; F IBT=2:1 S IBTX=$P($T (MINDAT+IB T),";",3) Q:IBTX="" D . S IBD =$P(IBREC1 ,"^",+IBTX ) . I $L($ P(IBTX,"^" ,4)) X $P( IBTX,"^",4 ) E N IBF ULL S IBFU LL=1 . I $ S(IBFULL:1 ,1:IBD) D .. I $L($P (IBTX,"^", 4)) X $P(I BTX,"^",4) I Q .. X "S IBD="_ $S($L($P(I BTX,"^",3) ):$P(IBTX, "^",3),1:" $$A10(IBD) ") .. S IB =$$SETSTR^ VALM1($P(I BTX,"^",2) _IBD,IB,$S ('IBRL:4,1 :37),$S('I BRL:41,1:3 8)) .. S I BRL=$S(IBR L:0,1:1) . . I 'IBRL D SET(IB,I BRL) S IB= "" ; D:IBR L'="" SET( IB) D REMA RK Q ;MIND AT ; data for MIN ta g ; format : piece^la bel^specia l format c ode^specia l decision for disp ;;1^Cov Da ys/Visit C t : ^$$RJ( +IBD)^I $G (IBSRC) ;; 3^Claim DR G Amt : ; ;2^Lifetm Psych Dy C t : ^$$RJ( IBD) ;;5^D isprop Sha re Amt : ^ ^I IBTYPE ;;4^Cap Ex ception Am t : ;;7^P PS Capital Amt : ^^I IBTYPE ;; 6^MSP Pass Thru Amt : ;;9^PPS Cap HSP-D RG Amt: ^^ I IBTYPE ; ;8^PPS Cap FSP-DRG A mt: ^^I IB TYPE ;;11^ Old Capita l Amt : ^^ I IBTYPE ; ;10^PPS Ca p DSH-DRG Amt: ^^I I BTYPE ;;13 ^PPS Op Ho s DRG Amt : ;;12^PP S Capital IME Amt: ^ ^I IBTYPE ;;15^PPS O p Fed DRG Amt : ^^I IBTYPE ;;1 4^Cost Rep ort Day Ct : ^$$RJ(I BD)^I IBTY PE ;;17^In direct Tea ch Amt : ^ ^I IBTYPE ;;16^PPS C ap Outlier Amt: ^^I IBTYPE ;;1 8^Non-Pay Prof Comp : ^$$RJ(IB D) ;;19^No n-Covered Days Ct: ^ $$RJ(+IBD) ^I IBTYPE ;; ;REMARK ; set up remarks an d line lev el details N IBREC1, IBP,IBT,IB X,RCODE,RD ESC,REXIST Q:$G(IBRE M) S IBREM =1 D SET(" ") D SET( " Claim Le vel Remark Informati on") D SET (" Code De scription" ) I '$G(IB SRC) D . D CNTRL^VAL M10(VALMCN T,4,4,IOUO N,IOUOFF) . D CNTRL^ VALM10(VAL MCNT,13,11 ,IOUON,IOU OFF) . Q ; S IBREC1= $P($G(^IBM (361.1,IBC NT,3)),U,3 ,7) I $P(I BREC1,U,1) ="" S IBRE C1=$P($G(^ IBM(361.1, IBCNT,5)), U,1,5) S R EXIST=0 ; F IBP=1:1: 5 D . S RC ODE=$P(IBR EC1,U,IBP) . S RDESC =$G(^IBM(3 61.1,IBCNT ,"RM"_IBP) ) . ; IB*2 .0*547 - g et RARC de sription f rom new AR file 346 when avail able . I ' $$VFILE^DI LFD(346),R CODE="",RD ESC="" Q . K IBT . Q :RCODE="" . I '$$VFI LE^DILFD(3 46) S REXI ST=1,IBT(I BP)=RDESC . I $$VFIL E^DILFD(34 6) S REXIS T=$$CARC(R CODE,346,6 0,"IBT") Q :REXIST<1 . D TXT1(. IBT,0,60) . D SET(" "_$$LJ^XLF STR(RCODE, 6)_"- "_$G (IBT(1))) . S IBX=1 . F S IBX =$O(IBT(IB X)) Q:'IBX D SET($J ("",12)_IB T(IBX)) . Q ; I 'REX IST D SET( " No claim level rem arks on fi le") D SET (" ") Q:$G (IBSRC) ; MRA Only ; MRALLA S I B=$$SETSTR ^VALM1("LI NE LEVEL A DJUSTMENTS :","",1,50 ) D SET(IB ) I '$G(IB SRC) D . D CNTRL^VAL M10(VALMCN T,1,23,IOR VON,IORVOF F) . S ^TM P("IBCECSD ",$J,"X",7 )=VALMCNT I '$D(^IBM (361.1,IBC NT,15,0)) D SET(" NO NE") Q ; only if th ere is inf o ; ; look up all bi lled data N IBZDATA, IBFORM,IBX 2,IBX3,IBR EC2,IBREC3 ,IBTX,IBT, IBRC,IBZ,I BTXL ;JWS; IB*2.0*592 :Dental fo rm #7 do s ame as CMS -1500 S IB FORM=0 ; c ms-1500 & J430D I $$ FT^IBCEF(+ IBREC)=3 S IBFORM=1 ; UB-04 ;J WS;IB*2.0* 592:Dental form #7 D F^IBCEF(" N-"_$S(IBF ORM=1:"UB- 04",$$FT^I BCEF(+IBRE C)=7:"J430 D",1:"HCFA 1500")_" SERVICE LI NE (EDI)", "IBZDATA", ,+IBREC) S IBX=0 F S IBX=$O(^ IBM(361.1, IBCNT,15,I BX)) Q:IBX <1 S IBREC 1=^IBM(361 .1,IBCNT,1 5,IBX,0) D . NEW RVL . D SET(" # SV DT R EVCD PROC MOD UNITS BILLED DED UCT COINS ALLOW PYMT ") . S RVL =+$P(IBREC 1,U,12) ; referenced Vista lin e# . I 'RV L S RVL=IB X ; use the EOB li ne# if not there . S IBT=$$RJ( $P(IBREC1, "^"),3) ; line numbe r . S IBT= IBT_" "_$$ RJ($$DAT1^ IBOUTL($P( $P(IBREC1, "^",16),". ")),8) ; s ervice dat e . S IBT= IBT_" "_$$ RJ($$EXTER NAL^DILFD( 361.115,.1 ,"",$P(IBR EC1,"^",10 )),6) ; re vcd . S IB T=IBT_" "_ $$RJ($P(IB REC1,"^",4 ),5) ; pro cedure . S IBT=IBT_" "_$$RJ($P ($G(^IBM(3 61.1,IBCNT ,15,IBX,2, 1,0)),"^") ,3)_$S($D( ^IBM(361.1 ,IBCNT,15, IBX,2,2,0) ):"+",1:" ") ; modif iers . S I BT=IBT_" " _$$RJ($FN( $P(IBREC1, "^",11),"" ,0),5) ; u nits . ;JW S;IB*2.0*5 92:Dental form #7 do same as C MS-1500 no change, j ust commen t . S IBT= IBT_" "_$$ RJ($FN($S( IBFORM:$P( $G(IBZDATA (RVL)),"^" ,5),1:$P($ G(IBZDATA( RVL)),"^", 8)*$P($G(I BZDATA(RVL )),"^",9)) ,"",2),8) ; billed . S IBT=IBT _" "_$$RJ( $FN($P($G( ^IBM(361.1 ,IBCNT,15, IBX,1,+$O( ^IBM(361.1 ,IBCNT,15, IBX,1,"B", "PR",0)),1 ,+$O(^IBM( 361.1,IBCN T,15,IBX,1 ,+$O(^IBM( 361.1,IBCN T,15,IBX,1 ,"B","PR", 0)),1,"B", 1,0)),0)), "^",2),"", 2),7) ; de duct . S I BT=IBT_" " _$$RJ($FN( $P($G(^IBM (361.1,IBC NT,15,IBX, 1,+$O(^IBM (361.1,IBC NT,15,IBX, 1,"B","PR" ,0)),1,+$O (^IBM(361. 1,IBCNT,15 ,IBX,1,+$O (^IBM(361. 1,IBCNT,15 ,IBX,1,"B" ,"PR",0)), 1,"B",2,0) ),0)),"^", 2),"",2),6 ) ; coins . S IBT=IB T_" "_$$RJ ($FN($P(IB REC1,"^",1 3),"",2),8 ) ; allow . S IBT=IB T_" "_$$RJ ($FN($P(IB REC1,"^",3 ),"",2),8) ; payment . D SET(I BT) . S IB X2=0 F S IBX2=$O(^I BM(361.1,I BCNT,15,IB X,1,IBX2)) Q:IBX2<1 D .. S IBR EC2=^IBM(3 61.1,IBCNT ,15,IBX,1, IBX2,0),IB X3=0 .. F S IBX3=$O (^IBM(361. 1,IBCNT,15 ,IBX,1,IBX 2,1,IBX3)) Q:IBX3<1 D ... S IB REC3=^IBM( 361.1,IBCN T,15,IBX,1 ,IBX2,1,IB X3,0) ... ; line lev el adjustm ents; don' t display kludges (e sg 10/23/0 3) ... I $ P(IBREC2,U ,1)="PR",$ P(IBREC3,U ,1)="AAA" Q ... I $P (IBREC2,U, 1)="OA",$P (IBREC3,U, 1)="AB3" Q ... I $P( IBREC2,U,1 )="LQ" Q . .. ; IB*2. 0*547 - ge t CARC des cription f rom AR fil e 345, whe n ready .. . I '$$VFI LE^DILFD(3 45) S IBTX (1)="ADJ: "_$P(IBREC 2,"^")_" " _$P(IBREC3 ,"^")_" "_ $P(IBREC3, "^",4) D T XT1(.IBTX, 0,79) S IB T=0 F S I BT=$O(IBTX (IBT)) Q:I BT<1 D SET (IBTX(IBT) ) ... I $$ VFILE^DILF D(345) S I BT=$$CARC( $P(IBREC3, "^"),345,7 9,"IBTX"), IBTX(1)="A DJ: "_$P(I BREC2,"^") _" "_$P(IB REC3,"^")_ ": "_$G(IB TX(1)) D T XT1(.IBTX, 0,79) S IB T=0 F S I BT=$O(IBTX (IBT)) Q:I BT<1 D SET (IBTX(IBT) ) ... K IB TX ... D S ET("ADJ AM T: "_$FN($ P(IBREC3," ^",2),"",2 )) . S IBR C=0 . F S IBRC=$O(^ IBM(361.1, IBCNT,15,I BX,4,IBRC) ) Q:'IBRC S IBREC2= $G(^(IBRC, 0)) I IBRE C2 K IBTX, IBZ S IBTX (1)=" -REM ARK CODE(" _+IBREC2_" ): ",IBTXL =$L(IBTX(1 )) D .. ; IB*2.0*547 - get RAR C descript ion from A R file 346 , when rea dy .. I '$ $VFILE^DIL FD(346) S IBTX(1)=IB TX(1)_$P(I BREC2,U,2) _" "_$P(IB REC2,U,3) .. I $$VFI LE^DILFD(3 46) S IBT= $$CARC($P( IBREC2,U,2 ),346,79," IBTX"),IBT X(1)=IBTX( 1)_$P(IBRE C2,U,2)_" "_$G(IBT(1 )) .. I $L (IBTX(1))> 79 D ... D TXT1(.IBT X,0,79) D SET(IBTX(1 )) M IBZ=I BTX K IBTX S IBTX(1) ="",IBT=1 F S IBT=$ O(IBZ(IBT) ) Q:'IBT S IBTX(1)= IBTX(1)_IB Z(IBT)_" " .. E D . .. S IBTXL =0 .. D TX T1(.IBTX,I BTXL,79) S IBT=0 F S IBT=$O(I BTX(IBT)) Q:IBT<1 D SET(IBTX(I BT)) . D S ET(" ") D SET(" ") Q ; ;/Begin ning IB*2. 0*488 (vd) EOBERR ; D isplay inf ormation a bout any 3 61.1 messa ge storage or filing errors N ERRTXT,DAS HES,Z S DA SHES="---- ---------- ---------- ---------- ---------- ---------- ---------- -----" I ' $O(^IBM(36 1.1,IBCNT, "ERR",0)) Q D SET("V istA could not match all of th e Line Lev el data re ceived in the EEOB") D SET("(8 35 Record 40) to the claim in VistA.") D SET(" ") S Z=0 F S Z=$O(^IBM (361.1,IBC NT,"ERR",Z )) Q:'Z D .S ERRTXT =$G(^IBM(3 61.1,IBCNT ,"ERR",Z,0 )) .I ERRT XT["##RAW DATA" S ER RTXT=DASHE S .D SET(E RRTXT) Q ; /End of IB *2.0*488 ( vd) ;TXT(I BRM,IBLN,I BXY) ;disp lay text o ver 79 cha rs ;IBRM - text, IBL N - length , IBXY - p osition S IBRM=$E(IB RM,IBLN+1, 999)REP I $E(IBRM,1, IBLN)'="" S IB=$$SET STR^VALM1( $E(IBRM,1, IBLN),"",I BXY,IBLN) D SET(IB) S IBRM=$E( IBRM,IBLN+ 1,999) G R EP Q ;SET( IB,IBSAV) ; I '$G(IB SAV) D SET ^IBCECSA6( $G(IBSRC), IB,+$G(CNT ),IBCNT) Q ;A10(X) ; Q $$A10^I BCECSA6(X) ;A7(X) ; returns a dollar amo unt right justified to 7 chara cters Q $$ RJ($FN(X," ",2),7) ;T XT1(IBT,DI WL,DIWR) ; sets up t ext for ov er 79 char s ; IBT - pass by re f, array o f text to be formatt ed back in array ; D IWL - left margin, D IWR = righ t margin N IBX,X,DIW F,IBS K ^U TILITY($J, "W") S DIW F="|I"_DIW L S IBX=0 F S IBX=$ O(IBT(IBX) ) Q:IBX<1 S X=IBT(IB X) D ^DIWP K IBT F S IBX=$O(^ UTILITY($J ,"W",DIWL, IBX)) Q:IB X<1 S IBT( IBX)=^UTIL ITY($J,"W" ,DIWL,IBX, 0) K ^UTIL ITY($J,"W" ) Q ;RJ(X, Y) ; right just, def ault is 10 Q $$RJ^XL FSTR(X,$G( Y,10)," ") ;CARC(IBC DE,IBF,IBM L,IBARY) ; new CARC/R ACR API fo r IB*2.0*5 47 ; IBCDE = reason code from EOB to loo kup in car c/rarc fil e (REQUIRE D) ; IBF = file# to do lookup (either 34 5-CARC or 346-RARC) *REQUIRED* ; IBML = max length for each line (defa ult is 79) ; IBARY = (required ) subscrip ted array to return descriptio n data in: ; array(1 )=first li ne of word -processed descripti on ; array (2)= 2nd l ine of wp descriptio n, and so on ; ; Ret urns total # of line s in descr iption ; N IBY,IBX,I BC,IBI,IBN ,IBALN,IBS TP,IBDSC S IBC=0 Q:$ G(IBARY)=" " IBC Q:$G (IBCDE)="" IBC Q:$G( IBF)="" IB C S:$G(IBM L)="" IBML =79 S IBY= $$FIND1^DI C(IBF,,"BX ",IBCDE) Q :IBY<1 IBC S IBX=$$G ET1^DIQ(IB F,IBY_",", 4,"","IBDS C") S IBI= 0 F S IBI =$O(IBDSC( IBI)) Q:'I BI D .S I BC=IBC+1,I BSTP=0,IBA LN=$L(IBDS C(IBI)) .S @IBARY@(I BI)=$E(IBD SC(IBI),1, IBML) Q:IB ML>IBALN . S IBDSC(IB I+1)=($E(I BDSC(IBI), (IBML+1),I BALN)_" "_ $G(IBDSC(I BI+1))) .; make sure we don't break word s in 2 .Q: $E(@IBARY@ (IBI),IBML )=" " .F I BN=IBML:-1 :1 Q:$G(IB STP)=1 D . .Q:$E(IBDS C(IBI),IBN )'=" " .. S @IBARY@( IBI)=$E(IB DSC(IBI),1 ,IBN),IBDS C(IBI+1)=( $E(IBDSC(I BI),(IBN+1 ),IBML)_$G (IBDSC(IBI +1))),IBST P=1 Q Q IB C ; | |
| 1097 | ||
| 1098 | ||
| 1099 | Routines | |
| 1100 | Activities | |
| 1101 | Routine Na me | |
| 1102 | IBCEDP | |
| 1103 | Enhancemen t Category | |
| 1104 | New | |
| 1105 | Modify | |
| 1106 | Delete | |
| 1107 | No Change | |
| 1108 | RTM | |
| 1109 | ||
| 1110 | Related Op tions | |
| 1111 | None | |
| 1112 | Related Ro utines | |
| 1113 | Routines “ Called By” | |
| 1114 | Routines “ Called” | |
| 1115 | ||
| 1116 | ||
| 1117 | ||
| 1118 | ||
| 1119 | Data Dicti onary (DD) Reference s | |
| 1120 | ||
| 1121 | Related Pr otocols | |
| 1122 | None | |
| 1123 | Related In tegration Control Re gistration s (ICRs) | |
| 1124 | None | |
| 1125 | Data Passi ng | |
| 1126 | Input | |
| 1127 | Output Re ference | |
| 1128 | Both | |
| 1129 | Global Re ference | |
| 1130 | Local | |
| 1131 | Input Attr ibute Name and Defin ition | |
| 1132 | Name: | |
| 1133 | Definition : | |
| 1134 | Output Att ribute Nam e and Defi nition | |
| 1135 | Name: | |
| 1136 | Definition : | |
| 1137 | Current Lo gic | |
| 1138 | IBCEDP ;AL B/ESG - ED I CLAIM ST ATUS REPOR T PRINT ;1 3-DEC-2007 ;;2.0;INT EGRATED BI LLING;**37 7**;21-MAR -94;Build 23 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; Q ;PRINT ; entry p oint to pr int the re port NEW C RT,IBPAGE, IBSTOP,IBC T,SV1,SV2, SV3,IEN,DA TA,NEWHDR NEW DIR,X, Y,DTOUT,DU OUT,DIROUT ,DIRUT I I OST["C-" S CRT=1 E S CRT=0 ; S IBPAGE=0 ,IBSTOP=0, IBCT=0,NEW HDR=0 ; I '$D(^TMP($ J,"IBCEDC" )) D HDR W !!?5,"No data found for this report." G PX I $G(Z TSTOP) D H DR W !!?5, "This repo rt was hal ted during compilati on by Task Manager Re quest." G PX ; D HDR ; initi al header display S SV1="" F S SV1=$O(^ TMP($J,"IB CEDC",SV1) ) Q:SV1="" !IBSTOP D SD(SV1) D Q:IBSTOP . S SV2=" " . F S S V2=$O(^TMP ($J,"IBCED C",SV1,SV2 )) Q:SV2=" "!IBSTOP D Q:IBSTO P .. S SV3 ="" .. F S SV3=$O(^ TMP($J,"IB CEDC",SV1, SV2,SV3)) Q:SV3=""!I BSTOP D Q:IBSTOP . .. S IEN=0 ... F S IEN=$O(^TM P($J,"IBCE DC",SV1,SV 2,SV3,IEN) ) Q:'IEN!I BSTOP D Q:IBSTOP . ... S DATA =$G(^TMP($ J,"IBCEDC" ,SV1,SV2,S V3,IEN)) . ... D PRT( DATA) .... Q ... Q . . Q . Q ; I IBSTOP G PRINTX D: $Y>(IOSL-4 ) HDR G:IB STOP PRINT X W !!?5," Total numb er of EDI Claims: ", IBCT D:$Y> (IOSL-4) H DR G:IBSTO P PRINTX W !!,"*** E nd of Repo rt ***" ;P X ; I CRT, '$D(ZTQUEU ED) S DIR( 0)="E" D ^ DIR K DIRP RINTX ; Q ;PRT(Z) ; print a li ne on the report ; Z - data fr om the scr atch globa l node N D IV,PAY,ADD R1 D:$Y>(I OSL-3) HDR G:IBSTOP PRTX S IBC T=IBCT+1 S DIV=$P($G (^DG(40.8, +$P(Z,U,10 ),0)),U,2) ; divisio n abbr S P AY=$P($G(^ DIC(36,+$P (Z,U,12),0 )),U,1) ; payer name S ADDR1=$ P($G(^DIC( 36,+$P(Z,U ,12),.11)) ,U,1) ; pa yer addres s line 1 ; W !,$P(Z, U,1) ; cla im# W ?9,$ S($P(Z,U,2 )=2:1500,1 :"UB04") ; form type W ?14,$S( $P(Z,U,3): "INPT",1:" OUTPT") ; inpat/outp at W ?21,$ P(Z,U,4) ; payer seq uence W ?2 5,$P(Z,U,5 ) ; EDI st atus code W ?29,$E($ P(Z,U,13), 1,9) ; IB status abb r W ?39,$E ($P(Z,U,11 ),1,2) ; a r status a bbr W ?44, $$FMTE^XLF DT($P(Z,U, 6)\1,"2Z") ; last tr ansmit dat e W ?55,$J ($P(Z,U,7) ,4) ; age in days W ?62,$P(Z,U ,8) ; batc h# W ?69,$ J($FN($P(Z ,U,9),"",2 ),9) ; bal ance due W ?81,DIV ; di vision W ? 89,$E(PAY, 1,23) ; pa yer name W ?114,$E(A DDR1,1,18) ; payer a ddress lin e 1 ; S NE WHDR=0 ; t oggle new header fla gPRTX ; Q ;HDR ; rep ort header ; ; if sc reen outpu t and page # already exists, do a page br eak at the bottom of the scree n I IBPAGE ,CRT D I IBSTOP G H DRX . S DI R(0)="E" D ^DIR K DI R . I 'Y S IBSTOP=1 . Q ; ; if screen ou tput OR pa ge# alread y exists, do a form feed I IBP AGE!CRT W @IOF I 'IB PAGE,'CRT W $C(13) ; first pri nter page - left mar gin set ; S IBPAGE=I BPAGE+1 ; W "EDI Cla im Status Report",?9 6,$$FMTE^X LFDT($$NOW ^XLFDT)," Page: ",IB PAGE W !," ** A claim may appea r multiple times if transmitte d more tha n once. ** " W !?3,"S orted by " ,$$SD^IBCE DS1($G(IBS ORT1)) I $ G(IBSORT2) '="" W ", then by ", $$SD^IBCED S1(IBSORT2 ) I $G(IBS ORT3)'="" W ", then by ",$$SD^ IBCEDS1(IB SORT3) ; ; display c olumn head ers W !?25 ,"*-- Stat uses --*" W !,"Claim ",?9,"Form ",?14,"Typ e",?20,"Se q",?25,"ED I",?31,"IB ",?39,"AR" ,?44,"Tran s Dt",?56, "Age",?62, "Batch#",? 71,"Bal Du e" W ?81," Div",?89," Payer" ; N Z S Z="", $P(Z,"-",1 33)="" W ! ,Z ; S NEW HDR=1 ; fl ag indicat ing a new page heade r was just printed ; ; check f or a TaskM anager sto p request I $D(ZTQUE UED),$$S^% ZTLOAD() D G HDRX . S (ZTSTOP ,IBSTOP)=1 . W !!!?5 ,"*** Repo rt Halted by TaskMan ager Reque st ***" . Q ;HDRX ; Q ;SD(SV) ; primary sort value display b reak. This procedure is to dis play a bre ak wheneve r the prim ary sort v alue chang es ; SV - subscript value of t he primary sort I IB SORT1=4!(I BSORT1=6) G SDX ; d on't displ ay a break for curre nt balance or for cl aim# prima ry sorts ; D:$Y>(IOS L-4) HDR G :IBSTOP SD X I 'NEWHD R W ! ; an extra lin e break if a page he ader was n ot just pr inted I $E (SV)="-",$ D(IBSORTOR (IBSORT1)) S SV=$E(S V,2,999) ; remove le ading "-" on descend ing numeri cal sorts ; I IBSORT 1=1 S SV=$ $FMTE^XLFD T(SV,"5Z") ; last tr ansmitted date/time I IBSORT1= 2 D ; payer n ame and ad dress . N INS,ADDR . S INS=+$P (SV,U,2) ; ins co ie n 2nd piec e of subsc ript . S A DDR=$$INSA DD^IBCNSC0 2(INS) ; a ddress fie lds . S SV =$P(SV,U,1 )_" "_$P(A DDR,U,2)_" "_$P(ADDR ,U,6)_" "_ $P(ADDR,U, 5) . Q I I BSORT1=3 S SV=SV_" - "_$$EXTER NAL^DILFD( 364,.03,,S V) ; edi c laim statu s and desc ription I IBSORT1=5 D ; di vision . N DZ,DIVNM . S DZ=+$O (^DG(40.8, "C",SV,"") ) ; divisi on ien . S DIVNM=$P( $G(^DG(40. 8,DZ,0)),U ,1) ; divi sion name . S SV=SV_ " - "_DIVN M . Q I IB SORT1=7 D ; AR s tatus . N AZ,ANM . S AZ=+$O(^P RCA(430.3, "C",SV,"") ) ; AR sta tus ien . S ANM=$P($ G(^PRCA(43 0.3,AZ,0)) ,U,1) ; AR status de scription . S SV=SV_ " - "_ANM . Q I IBSO RT1=8 S SV =SV_" Days " ; S SV=$ $SD^IBCEDS 1(IBSORT1) _": "_SV W !,SVSDX ; Q ; | |
| 1139 | Modified L ogic (Chan ges are in bold) | |
| 1140 | IBCEDP ;AL B/ESG - ED I CLAIM ST ATUS REPOR T PRINT ;1 3-DEC-2007 ;;2.0;INT EGRATED BI LLING;**37 7,592**;21 -MAR-94;Bu ild 23 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ; Q ;P RINT ; ent ry point t o print th e report N EW CRT,IBP AGE,IBSTOP ,IBCT,SV1, SV2,SV3,IE N,DATA,NEW HDR NEW DI R,X,Y,DTOU T,DUOUT,DI ROUT,DIRUT I IOST["C -" S CRT=1 E S CRT= 0 ; S IBPA GE=0,IBSTO P=0,IBCT=0 ,NEWHDR=0 ; I '$D(^T MP($J,"IBC EDC")) D H DR W !!?5, "No data f ound for t his report ." G PX I $G(ZTSTOP) D HDR W ! !?5,"This report was halted du ring compi lation by TaskManage r Request. " G PX ; D HDR ; i nitial hea der displa y S SV1="" F S SV1= $O(^TMP($J ,"IBCEDC", SV1)) Q:SV 1=""!IBSTO P D SD(SV 1) D Q:IB STOP . S S V2="" . F S SV2=$O( ^TMP($J,"I BCEDC",SV1 ,SV2)) Q:S V2=""!IBST OP D Q:I BSTOP .. S SV3="" .. F S SV3= $O(^TMP($J ,"IBCEDC", SV1,SV2,SV 3)) Q:SV3= ""!IBSTOP D Q:IBST OP ... S I EN=0 ... F S IEN=$O (^TMP($J," IBCEDC",SV 1,SV2,SV3, IEN)) Q:'I EN!IBSTOP D Q:IBST OP .... S DATA=$G(^T MP($J,"IBC EDC",SV1,S V2,SV3,IEN )) .... D PRT(DATA) .... Q ... Q .. Q . Q ; I IBST OP G PRINT X D:$Y>(IO SL-4) HDR G:IBSTOP P RINTX W !! ?5,"Total number of EDI Claims : ",IBCT D :$Y>(IOSL- 4) HDR G:I BSTOP PRIN TX W !!,"* ** End of Report *** " ;PX ; I CRT,'$D(ZT QUEUED) S DIR(0)="E" D ^DIR K DIRPRINTX ; Q ;PRT(Z ) ; print a line on the report ; Z - dat a from the scratch g lobal node N DIV,PAY ,ADDR1,TAB ;JRA IB* 2.0*592 Ad ded TAB D: $Y>(IOSL-3 ) HDR G:IB STOP PRTX S IBCT=IBC T+1 S DIV= $P($G(^DG( 40.8,+$P(Z ,U,10),0)) ,U,2) ; di vision abb r S PAY=$P ($G(^DIC(3 6,+$P(Z,U, 12),0)),U, 1) ; payer name S AD DR1=$P($G( ^DIC(36,+$ P(Z,U,12), .11)),U,1) ; payer a ddress lin e 1 ; W !, $P(Z,U,1) ; claim# ; JRA IB*2*5 92 Add Con dition for Dental Fo rm Type 7 ;W ?9,$S($ P(Z,U,2)=2 :1500,1:"U B04") ; fo rm type ;J RA IB*2.0* 592 ';' ;J RA IB*2.0* 592 Dental Form Type is 5 char s vs. 4, s o set TAB accordingl y S TAB=$S ($P(Z,U,2) =7:8,1:9) ; Set tab per form t ype ;JRA I B*2.0*592 W ?TAB,$S( $P(Z,U,2)= 2:"1500",$ P(Z,U,2)=7 :"J430D",1 :"UB04") ; form type ;JRA IB*2 .0*592 W ? 14,$S($P(Z ,U,3):"INP T",1:"OUTP T") ; inpa t/outpat W ?21,$P(Z, U,4) ; pay er sequenc e W ?25,$P (Z,U,5) ; EDI status code W ?2 9,$E($P(Z, U,13),1,9) ; IB stat us abbr W ?39,$E($P( Z,U,11),1, 2) ; ar st atus abbr W ?44,$$FM TE^XLFDT($ P(Z,U,6)\1 ,"2Z") ; l ast transm it date W ?55,$J($P( Z,U,7),4) ; age in d ays W ?62, $P(Z,U,8) ; batch# W ?69,$J($F N($P(Z,U,9 ),"",2),9) ; balance due W ?81 ,DIV ; divisi on W ?89,$ E(PAY,1,23 ) ; payer name W ?11 4,$E(ADDR1 ,1,18) ; p ayer addre ss line 1 ; S NEWHDR =0 ; toggl e new head er flagPRT X ; Q ;HDR ; report header ; ; if screen output an d page# al ready exis ts, do a p age break at the bot tom of the screen I IBPAGE,CRT D I IBST OP G HDRX . S DIR(0) ="E" D ^DI R K DIR . I 'Y S IBS TOP=1 . Q ; ; if scr een output OR page# already ex ists, do a form feed I IBPAGE! CRT W @IOF I 'IBPAGE ,'CRT W $C (13) ; fir st printer page - le ft margin set ; S IB PAGE=IBPAG E+1 ; W "E DI Claim S tatus Repo rt",?96,$$ FMTE^XLFDT ($$NOW^XLF DT)," Page : ",IBPAGE W !,"** A claim may appear mu ltiple tim es if tran smitted mo re than on ce. **" W !?3,"Sorte d by ",$$S D^IBCEDS1( $G(IBSORT1 )) I $G(IB SORT2)'="" W ", then by ",$$SD ^IBCEDS1(I BSORT2) I $G(IBSORT3 )'="" W ", then by " ,$$SD^IBCE DS1(IBSORT 3) ; ; dis play colum n headers W !?25,"*- - Statuses --*" W !, "Claim",?9 ,"Form",?1 4,"Type",? 20,"Seq",? 25,"EDI",? 31,"IB",?3 9,"AR",?44 ,"Trans Dt ",?56,"Age ",?62,"Bat ch#",?71," Bal Due" W ?81,"Div" ,?89,"Paye r" ; N Z S Z="",$P(Z ,"-",133)= "" W !,Z ; S NEWHDR= 1 ; flag i ndicating a new page header wa s just pri nted ; ; c heck for a TaskManag er stop re quest I $D (ZTQUEUED) ,$$S^%ZTLO AD() D G HDRX . S ( ZTSTOP,IBS TOP)=1 . W !!!?5,"** * Report H alted by T askManager Request * **" . Q ;H DRX ; Q ;S D(SV) ; pr imary sort value dis play break . This pro cedure is to display a break w henever th e primary sort value changes ; SV - subs cript valu e of the p rimary sor t I IBSORT 1=4!(IBSOR T1=6) G SD X ; don't display a break for current b alance or for claim# primary s orts ; D:$ Y>(IOSL-4) HDR G:IBS TOP SDX I 'NEWHDR W ! ; an ext ra line br eak if a p age header was not j ust printe d I $E(SV) ="-",$D(IB SORTOR(IBS ORT1)) S S V=$E(SV,2, 999) ; rem ove leadin g "-" on d escending numerical sorts ; I IBSORT1=1 S SV=$$FMT E^XLFDT(SV ,"5Z") ; l ast transm itted date /time I IB SORT1=2 D ; p ayer name and addres s . N INS, ADDR . S I NS=+$P(SV, U,2) ; ins co ien 2n d piece of subscript . S ADDR= $$INSADD^I BCNSC02(IN S) ; addre ss fields . S SV=$P( SV,U,1)_" "_$P(ADDR, U,2)_" "_$ P(ADDR,U,6 )_" "_$P(A DDR,U,5) . Q I IBSOR T1=3 S SV= SV_" - "_$ $EXTERNAL^ DILFD(364, .03,,SV) ; edi claim status an d descript ion I IBSO RT1=5 D ; divisi on . N DZ, DIVNM . S DZ=+$O(^DG (40.8,"C", SV,"")) ; division i en . S DIV NM=$P($G(^ DG(40.8,DZ ,0)),U,1) ; division name . S SV=SV_" - "_DIVNM . Q I IBSORT 1=7 D ; AR statu s . N AZ,A NM . S AZ= +$O(^PRCA( 430.3,"C", SV,"")) ; AR status ien . S AN M=$P($G(^P RCA(430.3, AZ,0)),U,1 ) ; AR sta tus descri ption . S SV=SV_" - "_ANM . Q I IBSORT1= 8 S SV=SV_ " Days" ; S SV=$$SD^ IBCEDS1(IB SORT1)_": "_SV W !,S VSDX ; Q ; | |
| 1141 | ||
| 1142 | ||
| 1143 | Routines | |
| 1144 | Activities | |
| 1145 | Routine Na me | |
| 1146 | IBCEF3 | |
| 1147 | Enhancemen t Category | |
| 1148 | New | |
| 1149 | Modify | |
| 1150 | Delete | |
| 1151 | No Change | |
| 1152 | RTM | |
| 1153 | ||
| 1154 | Related Op tions | |
| 1155 | None | |
| 1156 | Related Ro utines | |
| 1157 | Routines “ Called By” | |
| 1158 | Routines “ Called” | |
| 1159 | ||
| 1160 | ||
| 1161 | ||
| 1162 | ||
| 1163 | Data Dicti onary (DD) Reference s | |
| 1164 | ||
| 1165 | Related Pr otocols | |
| 1166 | None | |
| 1167 | Related In tegration Control Re gistration s (ICRs) | |
| 1168 | None | |
| 1169 | Data Passi ng | |
| 1170 | Input | |
| 1171 | Output Re ference | |
| 1172 | Both | |
| 1173 | Global Re ference | |
| 1174 | Local | |
| 1175 | Input Attr ibute Name and Defin ition | |
| 1176 | Name: | |
| 1177 | Definition : | |
| 1178 | Output Att ribute Nam e and Defi nition | |
| 1179 | Name: | |
| 1180 | Definition : | |
| 1181 | Current Lo gic | |
| 1182 | IBCEF3 ;AL B/TMP - FO RMATTER SP ECIFIC BIL L FLD FUNC TIONS ;17- JUNE-96 ;; 2.0;INTEGR ATED BILLI NG;**52,84 ,121,51,15 2,210,155, 348,349,38 9,488,516* *;21-MAR-9 4;Build 12 3 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ;MPG(P G,FLDS,FOR M) ; Set s tatic flds on pages after page 1 ; for e ither 1500 or UB ; P G = page # ; FORM= 1 for UB, o therwise f or 1500 ; FLDS: arra y passed b y referenc e and cont aining lin es OR ; li ne/column from pg 1 to repeat on subsequ ent pages ; Format: FLDS(LINE, COL) or FL DS(LINE) f or whole l ine ; CMS- 1500: LINE S 1-5,7-43 ,57 from c ol 1 to 50 , 58-63 ; UB: see CK PGUB for l ines and c olumns ; N Z,Z0,Z1,L PG S FORM= $S($G(FORM )=1:3,1:2) I FORM=2 D ; print page # on each pg, totals on last page of 1500 . S LPG=+$O( ^TMP("IBXD ATA",$J,IB XREC,""),- 1) . S Z=" [Page "_PG _" of "_LP G_"]" . S Z=$$FO^IBC NEUT1(Z,17 ,"R") . D SETGBL^IBC EFG(PG,6,6 1,Z,.IBXSI ZE) . I PG =2 S Z=$P( Z,"[",1)_" [Page 1 of "_LPG_"]" D SETGBL^ IBCEFG(1,6 ,61,Z,.IBX SIZE) . I LPG=PG D . . ; .. ; e sg - IB*2* 348 - upda te dollar format for last page of 1500 . . ; .. D S ETGBL^IBCE FG(PG,57,5 1,$$DOL^IB CEF77($G(I BXSAVE("TO T")),9),.I BXSIZE) .. D SETGBL^ IBCEFG(PG, 57,62,$$DO L^IBCEF77( $G(IBXSAVE ("PAID")), 8),.IBXSIZ E) .. ;IB* 2.0*516/DR F - Blank Box 30 on last page of multi-p age claims .. ;D SET GBL^IBCEFG (PG,57,71, $$DOL^IBCE F77($G(IBX SAVE("BDUE ")),8),.IB XSIZE) .. K IBXSAVE( "PTOT"),IB XSAVE("TOT "),IBXSAVE ("BDUE"),I BXSAVE("PA ID") ; S Z =0 F S Z= $O(FLDS(Z) ) Q:'Z D . I $O(FLD S(Z,""))=" " D Q ;r epeats lin e .. S Z0= 0 F S Z0= $O(^TMP("I BXDATA",$J ,IBXREC,1, Z,Z0)) Q:' Z0 S Z1=$ G(^(Z0)) I Z1'="" D SETGBL^IBC EFG(PG,Z,Z 0,Z1,.IBXS IZE) . S Z 0=0 F S Z 0=$O(FLDS( Z,Z0)) Q:' Z0 S Z1=$ G(^TMP("IB XDATA",$J, IBXREC,1,Z ,Z0)) I Z1 '="" D SET GBL^IBCEFG (PG,Z,Z0,Z 1,.IBXSIZE ) . I FORM =2,LPG'=PG D .. D SE TGBL^IBCEF G(PG,57,51 ,"",.IBXSI ZE) .. D S ETGBL^IBCE FG(PG,57,7 1,"",.IBXS IZE) Q ;NO NSERV(Z,Z0 ) ; Set va riable if non-servic e/non-text data is p resent for box ; 24 of CMS-150 0 ; Z = se quence of IBXSAVE be ing proces sed ; Z0 = sequnce w ithin IBXD ATA to ind icate actu al line # I $P(IBXSA VE("BOX24" ,Z),U)="" S IBXSAVE( "NON-SERV" ,Z0)="" Q ;PG(VAL,LN CT) ;Set n ext pg for CMS-1500 lines ;VAL = value o f fld ;LNC T = line # from IBXS AVE("BOX24 ") array N IBP,IBL S IBP=LNCT\ 12+(LNCT#1 2>0),IBL=L NCT-(12*(I BP-1))-1 I IBL'<0 S VAL=$$FORM AT(VAL,$G( IBXLOOP("I BX0")),$G( IBXDA)) D SETGBL^IBC EFG(IBP,IB XLN+IBL,IB XCOL,VAL,. IBXSIZE) K IBXDATA(L NCT) Q ;MP GUB(PG,OFF SET,VAL,IB LN,IBCOL,N OFORM) ; S et up page s > 1 for UB overflo ws ; PG = Page # to set (REQUI RED) ; OFF SET = offs et from fi rst line t his should be extrac ted into ; 0 = first line (REQ UIRED) ; V AL = value to set (R EQUIRED) ; IBLN = li ne to set data at (i f null, us es IBXLN) ; IBCOL = column to set data a t (if null , uses IBX COL) ; NOF ORM = don' t format, just outpu t data as passed ; A ssumes for matter IBX LN,IBXCOL variables exist ; I $G(IBLN)=" " S IBLN=I BXLN I $G( IBCOL)="" S IBCOL=IB XCOL S:'$G (NOFORM) V AL=$$FORMA T(VAL,$G(I BXLOOP("IB X0")),$G(I BXDA)) D S ETGBL^IBCE FG(PG,IBLN +OFFSET,IB COL,VAL,.I BXSIZE) Q ;CKREV(CT, VAL) ; Che ck too man y rev code lines to fit on pag e ; This p rocedure i s only cal led when C T>22 (i.e. 23 or mor e) ; D MPG UB((CT-1)\ 22+1,CT-1# 22,VAL) ; 22 codes o n a single page Q ;C KPGUB ; Ch eck to see if multip le UB page s are need ed then po pulate ; s tatic flds from page 1, add pa ge numbers ; N FLDS, LPG,IBPG,I BP,Z,Z0,TO T1,TOT2 ; S LPG=$O(^ TMP("IBXDA TA",$J,IBX REC,""),-1 ),IBP=0 S Z="" F S Z=$O(^TMP( "IBXDATA", $J,IBXREC, LPG,Z),-1) Q:'Z S Z 0=0 F S Z 0=$O(^TMP( "IBXDATA", $J,IBXREC, LPG,Z,Z0)) Q:'Z0 I $G(^(Z0))' ="" S IBP= 1 Q I 'IBP K ^TMP("I BXDATA",$J ,IBXREC,LP G) S LPG=$ O(^TMP("IB XDATA",$J, IBXREC,"") ,-1) Q:LPG =1 ; ; Sta tic flds F Z=2:1:7 S FLDS(Z)=" " ; FL- 1 thru FL- 9 F Z=1,10 ,13,19,22, 25,28,31 S FLDS(9,Z) ="" ; F L-10 thru FL-17 F Z= 13:1:17 S FLDS(Z,1)= "" ; pay er address in FL-38 S FLDS(41, 46)="" ; creatio n date F Z =42,43,44, 45,47,48,4 9,51,52,53 S FLDS(Z) ="" ; FL -50 thru F L-65 F Z=5 7,59,61,63 S (FLDS(Z ,59),FLDS( Z,72),FLDS (Z,74))="" ; FL-76 -79 ID's F Z=58,60,6 2,64 S (FL DS(Z,53),F LDS(Z,71)) ="" ; F L-76-79 Na mes ; F IB PG=1:1:LPG D . ; Add pg # to l ast line o f rev code s if multi ple pages . N IB,IBP . S IB=$G (^TMP("IBX DATA",$J,I BXREC,IBPG ,41,6)) . D MPGUB(IB PG,0,IBPG, 41,10,1) . D MPGUB(I BPG,0,LPG, 41,16,1) . D:IBPG>1 MPG(IBPG,. FLDS,1) . Q ; print totals on line 41 of the last page S (TO T1,TOT2)=0 F Z=1:1 Q :'$D(^TMP( $J,"IBC-RC ",Z)) S Z0 =^(Z) I +Z 0=1 S TOT1 =TOT1+$P(Z 0,U,7),TOT 2=TOT2+$P( Z0,U,8) ; Make sure totals are only 9 di gits => ba a IB*2.0*4 88 S TOT1= $$DOL^IBCE F77(TOT1,9 ) S TOT1=$ E(TOT1,1,9 ) S TOT2=$ $DOL^IBCEF 77(TOT2,9) S TOT2=$E (TOT2,1,9) D MPGUB(I BPG,0,"000 1",41,1,1) D MPGUB(I BPG,0,TOT1 ,41,61,1) D MPGUB(IB PG,0,TOT2, 41,71,1) ; End change s => baa I B*2.0*488 Q ;HCPC(R) ;FORMAT H CPC fld FO R UB (retu rns format ted value) ; R = fla g for type of fld (1 /2/3) bein g printed in rev cod e block Q R ;No lon ger used a s of patch IB*2.0*51 ;PROS(IBI FN) ; Extr act billab le prosthe tics for 8 37 N IBARR AY,Z,Z0,CT ,PROS D SE T^IBCSC5B( IBIFN,.IBA RRAY) I '$ P(IBARRAY, U,2) S CT= "" G PROSQ S Z="",CT =0 F S Z= $O(IBARRAY (Z)) Q:Z=" " S Z0="" F S Z0=$ O(IBARRAY( Z,Z0)) Q:Z 0="" S CT =CT+1 D .S PROS=$$PI NB^IBCSC5B (+IBARRAY( Z,Z0)) ; P 389 remove d p2 - ite m ptr file 661 .;dat e^^short d escr^entry # in file 362.5 .S IBXDATA(CT )=Z_U_U_PR OS_U_+IBAR RAY(Z,Z0)P ROSQ Q CT ;B24(IBXSV ,IBIFN,IBN OSHOW) ; C ode to exe cute to se t up IBXSV ("BOX24") for ; prin t or IBXSA VE("OUTPT" ) for tran smit - cal led by out put format ter ; IBNO SHOW = 1 i f not to s how error/ warning te xt lines ; Pass IBXS V by refer ence N IBS UB S IBSUB =$S('$G(^T MP("IBTX", $J,IBIFN)) :"BOX24",1 :"OUTPT") K IBXSV(IB SUB) I '$D (IBIFN) S IBIFN=$G(I BXIEN) I I BIFN D F^I BCEF("N-HC FA 1500 SE RVICE"_$S( IBSUB["24" :"S (PRINT ",1:" LINE (EDI")_") ",,,IBIFN) I $S(IBSU B'["24":1, 1:'$G(IBNO SHOW)) D . M IBXSV(I BSUB)=IBXD ATA E D . N Z,CT . S (Z,CT)=0 F S Z=$O (IBXDATA(Z )) Q:'Z I '$D(IBXDA TA(Z,"ARX" )) S CT=CT +1 M IBXSV (IBSUB,CT) =IBXDATA(Z ) Q ; ; es g - 11/14/ 03 - Moved the below functions due to sp ace constr aints ;ALL TYP(IBIFN) Q $$ALLTY P^IBCEF31( IBIFN)INST YP(IBIFN,S EQ) Q $$IN STYP^IBCEF 31(IBIFN,$ G(SEQ))POL TYP(IBIFN, IBSEQ) Q $ $POLTYP^IB CEF31(IBIF N,$G(IBSEQ ))ALLPTYP( IBIFN) Q $ $ALLPTYP^I BCEF31(IBI FN) ;FILL( Z) ; Q ; ; ***** ; The follow ing code p erforms th e multi-pa ge set up for ; prin ting overf low data o n the UB ; ***** ;XP ROC(DATA,C T) ; Outpu t any UB p rocedures after 6 on new page( s) ; DATA = output d ata from I BXSAVE("PR OC",CT) ; CT = array sequence # of the p rocedure b eing outpu t ; Only u sed for lo cal prints N OFFSET, PG,COL,PRC ODE,Q S Q= (CT-1)\3#2 ,OFFSET=$S ('Q:0,1:2) S PG=(CT- 1)\6+1,COL =1+(CT-1#3 *15) D MPG UB(PG,OFFS ET,$P(DATA ,U,1),58,C OL) D MPGU B(PG,OFFSE T,$P(DATA, U,2),58,CO L+9) Q ;XD IAG(DATA,C T) ; Outpu t any UB o ther diagn oses after 8 on new page(s) ; DATA = out put data f rom IBXSAV E("DX",CT) ; CT = ar ray sequen ce # of th e diagnosi s being ou tput ; Onl y used for local pri nts N COL, PG S PG=(C T-1)\8+1,C OL=8+(CT-1 #9*7) S DA TA=$P($$IC D9^IBACSV( +DATA),U,1 ) D MPGUB( PG,0,DATA, 56,COL) Q ;XVAL(DATA ,CT) ; Out put any UB value cod es after 1 2 on new p age(s) ; D ATA = outp ut data fr om IBXSAVE ("VC",CT) ; CT = arr ay sequenc e # of the value cod e being ou tput ; N C OL,PG,OFFS ET S PG=(C T-1)\12+1, COL=44+(CT -1#3*13),O FFSET=(CT- (12*(PG-1) )-1)\3 D M PGUB(PG,OF FSET,$P(DA TA,U,1),14 ,COL) D MP GUB(PG,OFF SET,$P(DAT A,U,2),14, COL+3) Q ; XCC(DATA,C T) ; Outpu t any UB c ondition c odes after 11 on new page(s) ; 11 condit ion codes per page, starting c olumns 34 thru 64 ; DATA = out put data f rom IBXSAV E("CC",CT) ; CT = ar ray sequen ce # of th e conditio n code bei ng output ; N COL,PG S PG=(CT- 1)\11+1,CO L=34+(CT-1 #11*3) D M PGUB(PG,0, DATA,9,COL ) Q ;XOCC( DATA,CT,FL ) ; Output any UB oc currence c odes after 8 (2 per form ; loc ators 31-3 4) on new page(s) ; DATA = dat a from IBX SAVE("OCC" ,z) to be output ; C T = array sequence # of occurr ence code being outp ut ; FL = # of form locator be ing popula ted with t he occ cod e ; N COL, PG,OFFSET S PG=(CT-1 )\2+1,COL= 1+((FL-31) *10),OFFSE T=$S(CT#2: 0,1:1) D M PGUB(PG,OF FSET,$P(DA TA,U,1),11 ,COL) D MP GUB(PG,OFF SET,$P(DAT A,U,2),11, COL+4) Q ; XOCCS(DATA ,CT,FL) ; Output any UB occurr ence span codes afte r 4 on new page(s) ; DATA = da ta from IB XSAVE("OCC S",z) to b e output ; CT = arra y sequence # of occu rrence spa n code bei ng output ; FL = # o f form loc ator being populated (either F L 35 or 36 ) ; N COL, PG,OFFSET S PG=(CT-1 )\2+1,OFFS ET=$S(CT#2 :0,1:1) S COL=41+((F L-35)*17) D MPGUB(PG ,OFFSET,$P (DATA,U,1) ,11,COL) D MPGUB(PG, OFFSET,$P( DATA,U,2), 11,COL+4) D MPGUB(PG ,OFFSET,$P (DATA,U,3) ,11,COL+11 ) Q ;FORMA T(VAL,IBX0 ,IBXDA) ; I IBX0'="" ,IBXDA S V AL=$$FORMA T^IBCEFG(V AL,$P($G(^ IBA(364.6, +IBXDA,0)) ,U,9),$P(I BX0,U,7),I BX0) Q VAL ;OUTPDT(I BIFN,IBXSA VE,IBXDATA ) ; Return s outpatie nt service to date ; formatted CCYYMMDD for UB 837 ; IBIFN = ien of bi ll (file 3 99) ; IBXS AVE = pass by refere nce for IB XSAVE("INP T") and IB XSAVE("DAT E") ; IBXD ATA = arra y with for matted dat e or each line item - CCYYMMDD N Z S Z=0 F S Z=$O (IBXSAVE(" INPT",Z)) Q:'Z S IB XDATA(Z)=$ S($P(IBXSA VE("INPT", Z),U,10):$ $DT^IBCEFG 1($P(IBXSA VE("INPT", Z),U,10),, "D8"),1:IB XSAVE("DAT E")) K IBX SAVE("DATE ") Q ; | |
| 1183 | Modified L ogic (Chan ges are in bold) | |
| 1184 | IBCEF3 ;AL B/TMP - FO RMATTER SP ECIFIC BIL L FLD FUNC TIONS ;17- JUNE-96 ;; 2.0;INTEGR ATED BILLI NG;**52,84 ,121,51,15 2,210,155, 348,349,38 9,488,516, 592**;21-M AR-94;Buil d 123 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ;M PG(PG,FLDS ,FORM) ; S et static flds on pa ges after page 1 ; f or either 1500 or UB ; PG = pa ge # ; FOR M= 1 for U B, otherwi se for 150 0 ; FLDS: array pass ed by refe rence and containing lines OR ; line/col umn from p g 1 to rep eat on sub sequent pa ges ; Form at: FLDS(L INE,COL) o r FLDS(LIN E) for who le line ; CMS-1500: LINES 1-5, 7-43,57 fr om col 1 t o 50, 58-6 3 ; UB: se e CKPGUB f or lines a nd columns ; N Z,Z0, Z1,LPG S F ORM=$S($G( FORM)=1:3, 1:2) ;JRA IB*2.0*592 Treat Den tal Form 7 (J430D) s ame as the 1500 ;I F ORM=2 D ; print page # on each pg, total s on last page of 15 00 ;JRA IB *2.0*592 ' ;' I FORM= 2!(FORM=7) D ; prin t page # o n each pg, totals on last page of 1500 ( or J430D) ;JRA IB*2. 0*592 . S LPG=+$O(^T MP("IBXDAT A",$J,IBXR EC,""),-1) . S Z="[P age "_PG_" of "_LPG_ "]" . S Z= $$FO^IBCNE UT1(Z,17," R") . D SE TGBL^IBCEF G(PG,6,61, Z,.IBXSIZE ) . I PG=2 S Z=$P(Z, "[",1)_"[P age 1 of " _LPG_"]" D SETGBL^IB CEFG(1,6,6 1,Z,.IBXSI ZE) . I LP G=PG D .. ; .. ; esg - IB*2*34 8 - update dollar fo rmat for l ast page o f 1500 .. ; .. D SET GBL^IBCEFG (PG,57,51, $$DOL^IBCE F77($G(IBX SAVE("TOT" )),9),.IBX SIZE) .. D SETGBL^IB CEFG(PG,57 ,62,$$DOL^ IBCEF77($G (IBXSAVE(" PAID")),8) ,.IBXSIZE) .. ;IB*2. 0*516/DRF - Blank Bo x 30 on la st page of multi-pag e claims . . ;D SETGB L^IBCEFG(P G,57,71,$$ DOL^IBCEF7 7($G(IBXSA VE("BDUE") ),8),.IBXS IZE) .. K IBXSAVE("P TOT"),IBXS AVE("TOT") ,IBXSAVE(" BDUE"),IBX SAVE("PAID ") ; S Z=0 F S Z=$O (FLDS(Z)) Q:'Z D . I $O(FLDS( Z,""))="" D Q ;rep eats line .. S Z0=0 F S Z0=$O (^TMP("IBX DATA",$J,I BXREC,1,Z, Z0)) Q:'Z0 S Z1=$G( ^(Z0)) I Z 1'="" D SE TGBL^IBCEF G(PG,Z,Z0, Z1,.IBXSIZ E) . S Z0= 0 F S Z0= $O(FLDS(Z, Z0)) Q:'Z0 S Z1=$G( ^TMP("IBXD ATA",$J,IB XREC,1,Z,Z 0)) I Z1'= "" D SETGB L^IBCEFG(P G,Z,Z0,Z1, .IBXSIZE) . I FORM=2 ,LPG'=PG D .. D SETG BL^IBCEFG( PG,57,51," ",.IBXSIZE ) .. D SET GBL^IBCEFG (PG,57,71, "",.IBXSIZ E) Q ;NONS ERV(Z,Z0) ; Set vari able if no n-service/ non-text d ata is pre sent for b ox ; 24 of CMS-1500 ; Z = sequ ence of IB XSAVE bein g processe d ; Z0 = s equnce wit hin IBXDAT A to indic ate actual line # I $P(IBXSAVE ("BOX24",Z ),U)="" S IBXSAVE("N ON-SERV",Z 0)="" Q ;P G(VAL,LNCT ) ;Set nex t pg for C MS-1500 li nes ;VAL = value of fld ;LNCT = line # f rom IBXSAV E("BOX24") array N I BP,IBL S I BP=LNCT\12 +(LNCT#12> 0),IBL=LNC T-(12*(IBP -1))-1 I I BL'<0 S VA L=$$FORMAT (VAL,$G(IB XLOOP("IBX 0")),$G(IB XDA)) D SE TGBL^IBCEF G(IBP,IBXL N+IBL,IBXC OL,VAL,.IB XSIZE) K I BXDATA(LNC T) Q ;MPGU B(PG,OFFSE T,VAL,IBLN ,IBCOL,NOF ORM) ; Set up pages > 1 for UB overflows ; PG = Pa ge # to se t (REQUIRE D) ; OFFSE T = offset from firs t line thi s should b e extracte d into ; 0 = first l ine (REQUI RED) ; VAL = value t o set (REQ UIRED) ; I BLN = line to set da ta at (if null, uses IBXLN) ; IBCOL = co lumn to se t data at (if null, uses IBXCO L) ; NOFOR M = don't format, ju st output data as pa ssed ; Ass umes forma tter IBXLN ,IBXCOL va riables ex ist ; I $G (IBLN)="" S IBLN=IBX LN I $G(IB COL)="" S IBCOL=IBXC OL S:'$G(N OFORM) VAL =$$FORMAT( VAL,$G(IBX LOOP("IBX0 ")),$G(IBX DA)) D SET GBL^IBCEFG (PG,IBLN+O FFSET,IBCO L,VAL,.IBX SIZE) Q ;C KREV(CT,VA L) ; Check too many rev code l ines to fi t on page ; This pro cedure is only calle d when CT> 22 (i.e. 2 3 or more) ; D MPGUB ((CT-1)\22 +1,CT-1#22 ,VAL) ; 22 codes on a single p age Q ;CKP GUB ; Chec k to see i f multiple UB pages are needed then popu late ; sta tic flds f rom page 1 , add page numbers ; N FLDS,LP G,IBPG,IBP ,Z,Z0,TOT1 ,TOT2 ; S LPG=$O(^TM P("IBXDATA ",$J,IBXRE C,""),-1), IBP=0 S Z= "" F S Z= $O(^TMP("I BXDATA",$J ,IBXREC,LP G,Z),-1) Q :'Z S Z0= 0 F S Z0= $O(^TMP("I BXDATA",$J ,IBXREC,LP G,Z,Z0)) Q :'Z0 I $G (^(Z0))'=" " S IBP=1 Q I 'IBP K ^TMP("IBX DATA",$J,I BXREC,LPG) S LPG=$O( ^TMP("IBXD ATA",$J,IB XREC,""),- 1) Q:LPG=1 ; ; Stati c flds F Z =2:1:7 S F LDS(Z)="" ; FL-1 thru FL-9 F Z=1,10,1 3,19,22,25 ,28,31 S F LDS(9,Z)=" " ; FL- 10 thru FL -17 F Z=13 :1:17 S FL DS(Z,1)="" ; payer address i n FL-38 S FLDS(41,46 )="" ; creation date F Z=4 2,43,44,45 ,47,48,49, 51,52,53 S FLDS(Z)=" " ; FL-5 0 thru FL- 65 F Z=57, 59,61,63 S (FLDS(Z,5 9),FLDS(Z, 72),FLDS(Z ,74))="" ; FL-76-7 9 ID's F Z =58,60,62, 64 S (FLDS (Z,53),FLD S(Z,71))=" " ; FL- 76-79 Name s ; F IBPG =1:1:LPG D . ; Add p g # to las t line of rev codes if multipl e pages . N IB,IBP . S IB=$G(^ TMP("IBXDA TA",$J,IBX REC,IBPG,4 1,6)) . D MPGUB(IBPG ,0,IBPG,41 ,10,1) . D MPGUB(IBP G,0,LPG,41 ,16,1) . D :IBPG>1 MP G(IBPG,.FL DS,1) . Q ; print to tals on li ne 41 of t he last pa ge S (TOT1 ,TOT2)=0 F Z=1:1 Q:' $D(^TMP($J ,"IBC-RC", Z)) S Z0=^ (Z) I +Z0= 1 S TOT1=T OT1+$P(Z0, U,7),TOT2= TOT2+$P(Z0 ,U,8) ; Ma ke sure to tals are o nly 9 digi ts => baa IB*2.0*488 S TOT1=$$ DOL^IBCEF7 7(TOT1,9) S TOT1=$E( TOT1,1,9) S TOT2=$$D OL^IBCEF77 (TOT2,9) S TOT2=$E(T OT2,1,9) D MPGUB(IBP G,0,"0001" ,41,1,1) D MPGUB(IBP G,0,TOT1,4 1,61,1) D MPGUB(IBPG ,0,TOT2,41 ,71,1) ;En d changes => baa IB* 2.0*488 Q ;HCPC(R) ; FORMAT HCP C fld FOR UB (return s formatte d value) ; R = flag for type o f fld (1/2 /3) being printed in rev code block Q R ;No longe r used as of patch I B*2.0*51 ; PROS(IBIFN ) ; Extrac t billable prostheti cs for 837 N IBARRAY ,Z,Z0,CT,P ROS D SET^ IBCSC5B(IB IFN,.IBARR AY) I '$P( IBARRAY,U, 2) S CT="" G PROSQ S Z="",CT=0 F S Z=$O (IBARRAY(Z )) Q:Z="" S Z0="" F S Z0=$O( IBARRAY(Z, Z0)) Q:Z0= "" S CT=C T+1 D .S P ROS=$$PINB ^IBCSC5B(+ IBARRAY(Z, Z0)) ; P38 9 removed p2 - item ptr file 6 61 .;date^ ^short des cr^entry # in file 3 62.5 .S IB XDATA(CT)= Z_U_U_PROS _U_+IBARRA Y(Z,Z0)PRO SQ Q CT ;B 24(IBXSV,I BIFN,IBNOS HOW) ; Cod e to execu te to set up IBXSV(" BOX24") fo r ; print or IBXSAVE ("OUTPT") for transm it - calle d by outpu t formatte r ; IBNOSH OW = 1 if not to sho w error/wa rning text lines ; P ass IBXSV by referen ce N IBSUB S IBSUB=$ S('$G(^TMP ("IBTX",$J ,IBIFN)):" BOX24",1:" OUTPT") K IBXSV(IBSU B) I '$D(I BIFN) S IB IFN=$G(IBX IEN) I IBI FN D F^IBC EF("N-HCFA 1500 SERV ICE"_$S(IB SUB["24":" S (PRINT", 1:" LINE ( EDI")_")", ,,IBIFN) I $S(IBSUB' ["24":1,1: '$G(IBNOSH OW)) D . M IBXSV(IBS UB)=IBXDAT A E D . N Z,CT . S (Z,CT)=0 F S Z=$O(I BXDATA(Z)) Q:'Z I ' $D(IBXDATA (Z,"ARX")) S CT=CT+1 M IBXSV(I BSUB,CT)=I BXDATA(Z) Q ; ; esg - 11/14/03 - Moved t he below f unctions d ue to spac e constrai nts ;ALLTY P(IBIFN) Q $$ALLTYP^ IBCEF31(IB IFN)INSTYP (IBIFN,SEQ ) Q $$INST YP^IBCEF31 (IBIFN,$G( SEQ))POLTY P(IBIFN,IB SEQ) Q $$P OLTYP^IBCE F31(IBIFN, $G(IBSEQ)) ALLPTYP(IB IFN) Q $$A LLPTYP^IBC EF31(IBIFN ) ;FILL(Z) ; Q ; ; * **** ; Th e followin g code per forms the multi-page set up fo r ; printi ng overflo w data on the UB ; * **** ;XPRO C(DATA,CT) ; Output any UB pro cedures af ter 6 on n ew page(s) ; DATA = output dat a from IBX SAVE("PROC ",CT) ; CT = array s equence # of the pro cedure bei ng output ; Only use d for loca l prints N OFFSET,PG ,COL,PRCOD E,Q S Q=(C T-1)\3#2,O FFSET=$S(' Q:0,1:2) S PG=(CT-1) \6+1,COL=1 +(CT-1#3*1 5) D MPGUB (PG,OFFSET ,$P(DATA,U ,1),58,COL ) D MPGUB( PG,OFFSET, $P(DATA,U, 2),58,COL+ 9) Q ;XDIA G(DATA,CT) ; Output any UB oth er diagnos es after 8 on new pa ge(s) ; DA TA = outpu t data fro m IBXSAVE( "DX",CT) ; CT = arra y sequence # of the diagnosis being outp ut ; Only used for l ocal print s N COL,PG S PG=(CT- 1)\8+1,COL =8+(CT-1#9 *7) S DATA =$P($$ICD9 ^IBACSV(+D ATA),U,1) D MPGUB(PG ,0,DATA,56 ,COL) Q ;X VAL(DATA,C T) ; Outpu t any UB v alue codes after 12 on new pag e(s) ; DAT A = output data from IBXSAVE(" VC",CT) ; CT = array sequence # of the v alue code being outp ut ; N COL ,PG,OFFSET S PG=(CT- 1)\12+1,CO L=44+(CT-1 #3*13),OFF SET=(CT-(1 2*(PG-1))- 1)\3 D MPG UB(PG,OFFS ET,$P(DATA ,U,1),14,C OL) D MPGU B(PG,OFFSE T,$P(DATA, U,2),14,CO L+3) Q ;XC C(DATA,CT) ; Output any UB con dition cod es after 1 1 on new p age(s) ; 1 1 conditio n codes pe r page, st arting col umns 34 th ru 64 ; DA TA = outpu t data fro m IBXSAVE( "CC",CT) ; CT = arra y sequence # of the condition code being output ; N COL,PG S PG=(CT-1) \11+1,COL= 34+(CT-1#1 1*3) D MPG UB(PG,0,DA TA,9,COL) Q ;XOCC(DA TA,CT,FL) ; Output a ny UB occu rrence cod es after 8 (2 per fo rm ; locat ors 31-34) on new pa ge(s) ; DA TA = data from IBXSA VE("OCC",z ) to be ou tput ; CT = array se quence # o f occurren ce code be ing output ; FL = # of form lo cator bein g populate d with the occ code ; N COL,PG ,OFFSET S PG=(CT-1)\ 2+1,COL=1+ ((FL-31)*1 0),OFFSET= $S(CT#2:0, 1:1) D MPG UB(PG,OFFS ET,$P(DATA ,U,1),11,C OL) D MPGU B(PG,OFFSE T,$P(DATA, U,2),11,CO L+4) Q ;XO CCS(DATA,C T,FL) ; Ou tput any U B occurren ce span co des after 4 on new p age(s) ; D ATA = data from IBXS AVE("OCCS" ,z) to be output ; C T = array sequence # of occurr ence span code being output ; FL = # of form locat or being p opulated ( either FL 35 or 36) ; N COL,PG ,OFFSET S PG=(CT-1)\ 2+1,OFFSET =$S(CT#2:0 ,1:1) S CO L=41+((FL- 35)*17) D MPGUB(PG,O FFSET,$P(D ATA,U,1),1 1,COL) D M PGUB(PG,OF FSET,$P(DA TA,U,2),11 ,COL+4) D MPGUB(PG,O FFSET,$P(D ATA,U,3),1 1,COL+11) Q ;FORMAT( VAL,IBX0,I BXDA) ; I IBX0'="",I BXDA S VAL =$$FORMAT^ IBCEFG(VAL ,$P($G(^IB A(364.6,+I BXDA,0)),U ,9),$P(IBX 0,U,7),IBX 0) Q VAL ; OUTPDT(IBI FN,IBXSAVE ,IBXDATA) ; Returns outpatient service t o date ; f ormatted C CYYMMDD fo r UB 837 ; IBIFN = i en of bill (file 399 ) ; IBXSAV E = pass b y referenc e for IBXS AVE("INPT" ) and IBXS AVE("DATE" ) ; IBXDAT A = array with forma tted date or each li ne item - CCYYMMDD N Z S Z=0 F S Z=$O(I BXSAVE("IN PT",Z)) Q: 'Z S IBXD ATA(Z)=$S( $P(IBXSAVE ("INPT",Z) ,U,10):$$D T^IBCEFG1( $P(IBXSAVE ("INPT",Z) ,U,10),,"D 8"),1:IBXS AVE("DATE" )) K IBXSA VE("DATE") Q ; | |
| 1185 | ||
| 1186 | Routines | |
| 1187 | Activities | |
| 1188 | Routine Na me | |
| 1189 | IBCEF31 | |
| 1190 | Enhancemen t Category | |
| 1191 | New | |
| 1192 | Modify | |
| 1193 | Delete | |
| 1194 | No Change | |
| 1195 | RTM | |
| 1196 | ||
| 1197 | Related Op tions | |
| 1198 | None | |
| 1199 | Related Ro utines | |
| 1200 | Routines “ Called By” | |
| 1201 | Routines “ Called” | |
| 1202 | ||
| 1203 | ||
| 1204 | ||
| 1205 | ||
| 1206 | Data Dicti onary (DD) Reference s | |
| 1207 | ||
| 1208 | Related Pr otocols | |
| 1209 | None | |
| 1210 | Related In tegration Control Re gistration s (ICRs) | |
| 1211 | None | |
| 1212 | Data Passi ng | |
| 1213 | Input | |
| 1214 | Output Re ference | |
| 1215 | Both | |
| 1216 | Global Re ference | |
| 1217 | Local | |
| 1218 | Input Attr ibute Name and Defin ition | |
| 1219 | Name: | |
| 1220 | Definition : | |
| 1221 | Output Att ribute Nam e and Defi nition | |
| 1222 | Name: | |
| 1223 | Definition : | |
| 1224 | Current Lo gic | |
| 1225 | IBCEF31 ;A LB/ESG - F ORMATTER S PECIFIC BI LL FLD FUN CTIONS - C ONT ;14-NO V-03 ;;2.0 ;INTEGRATE D BILLING; **155,296, 349,400,43 2,488,516* *;21-MAR-9 4;Build 12 3 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; Q ;A LLTYP(IBIF N) ; retur ns codes t o translat e to ALL i ns types o n a bill ; IBIFN = i en of bill N IBX,Z F Z=1:1:3 S $P(IBX,U, Z)=$$INSTY P(IBIFN,Z) ; IBX = p rimary cod e^secondar y code^ter tiary code Q IBX ;IN STYP(IBIFN ,SEQ) ; Re turns insu rance type code for an ins on a bill ; I BIFN = ien of bill ; SEQ = seq uence (1,2 ,3) of ins urance wan ted - prim , second, tert ; Def ault is cu rrent insu rance co ; N IBA,Z ; I '$G(SEQ ) S SEQ=$$ COBN^IBCEF (IBIFN) S Z=+$G(^DGC R(399,IBIF N,"I"_SEQ) ) ;Codes 1 :HMO;2:COM MERCIAL;3: MEDICARE;4 :MEDICAID; 5:GROUP PO LICY;9:OTH ER I Z D . S IBA=$P( $G(^DIC(36 ,Z,3)),U,9 ) . I $$MC RWNR^IBEFU NC(Z) S IB A=3 ; forc e Medicare (WNR) def inition to be correc t . I IBA= "" S IBA=5 ;Default is group p olicy - 5 if blank ; Q $G(IBA) ;POLTYP(I BIFN,IBSEQ ) ; Return s ins elec tronic pol icy type c ode for on e ; ins po licy on a bill ; IBI FN = ien o f bill ; I BSEQ = seq uence (1,2 ,3) of ins policy wa nted - pri m, second, tert ; De fault is c urrent ins urance co ; N IBPLAN ,IBPLTYP ; I '$G(IBS EQ) S IBSE Q=+$$COBN^ IBCEF(IBIF N) S IBPLA N=$G(^IBA( 355.3,+$P( $G(^DGCR(3 99,IBIFN," I"_IBSEQ)) ,U,18),0)) S IBPLTYP =$P(IBPLAN ,U,15) ; ; esg - 06/ 30/05 - IB *2.0*296 - Force Med icare (WNR ) to be co rrect I $$ WNRBILL^IB EFUNC(IBIF N,IBSEQ),$ $FT^IBCEF( IBIFN)=2 S IBPLTYP=" MB" ; CM S-1500 --- -> Medicar e Part B I $$WNRBILL ^IBEFUNC(I BIFN,IBSEQ ),$$FT^IBC EF(IBIFN)= 3 S IBPLTY P="MA" ; UB-04 --- ----> Medi care Part A ; I IBPL TYP="" S I BPLTYP="CI " ;Default is commer cial - 'CI ' I IBPLTY P="MX" D . I $P(IBPL AN,U,14)'= "","AB"[$P (IBPLAN,U, 14) S IBPL TYP="M"_$P (IBPLAN,U, 14) Q . S IBPLTYP="C I" Q $G(IB PLTYP) ;AL LPTYP(IBIF N) ; retur ns insuran ce policy type codes for ALL i ns on a bi ll ; IBIFN = ien of bill N IBX ,Z S IBX=" " F Z=1:1: 3 I $D(^DG CR(399,IBI FN,"I"_Z)) S $P(IBX, U,Z)=$$POL TYP(IBIFN, Z) ; IBX = primary c ode^second ary code^t ertiary co de Q IBX ; PGDX(DXCNT ,IBX0,IBXD A,IBXLN,IB XCOL,IBXSI ZE,IBXSAVE ) ; Subrou tine - Che cks for Di agnosis Co des (Dx) b eyond ; t he first f our, that relate to the curren t Dx posit ion passed in DXCNT. ; This su broutine s tores the Diagnosis Codes in o utput glob al using d isplay par ameters (I BXLN,IBXCO L) ; THE P AGE IS ALW AYS 1 NOW SO WE DON' T NEED 4 L INES BELOW BAA *488* ; If DXCN T is 1, ch eck for Dx 's 5,9,... etc & disp lay on pag es 2,3,... etc ; If D XCNT is 2, check for Dx's 6,10 ,...etc & display on pages 2,3 ,...etc ; If DXCNT i s 3, check for Dx's 7,11,...et c & displa y on pages 2,3,...et c ; If DXC NT is 4, c heck for D x's 8,12,. ..etc & di splay on p ages 2,3,. ..etc ; ; Input: DXC NT= positi on of curr ent Dx (fr om 1 to 4) ; IBX0= z ero-level of file 36 4.7 of cur rent Dx ; IBXDA= ien # of file 364.6 of c urrent Dx ; IBXLN IB XCOL= line # & Column # of curre nt Dx ; IB XSIZE= siz e counter ; IBXSAVE( "DX")= loc al array w ith all Dx 's on curr ent bill ; ; For pat ch *488* ; S DXNM = 12 This i s the numb er of diag nosis on a 1500 form ; S IBPG =1 This is the page number. Al l 12 print on page 1 N IBPG,VA L S IBPG=1 I '$D(IBX SAVE("DX", DXCNT)) Q S VAL=$P($ $ICD9^IBAC SV(+IBXSAV E("DX",DXC NT)),U) ; resolve Dx pointer S VAL=$$FOR MAT^IBCEF3 (VAL,$G(IB X0),$G(IBX DA)) ;form at Dx valu e D SETGBL ^IBCEFG(IB PG,IBXLN,I BXCOL,VAL, .IBXSIZE) ;store in output glo bal Q ;PG DX ;DXSV(I B,IBXSAVE) ; output formatter subroutine ; save of f DX codes in IBXSAV E("DX") N Z,IBCT S ( Z,IBCT)=0 F S Z=$O( IB(Z)) Q:' Z I $G(IB (Z)) S IBC T=IBCT+1 M IBXSAVE(" DX",IBCT)= IB(Z) Q ;A UTRF(IBXIE N,IBL,Z) ; returns a uth # and referral# if room fo r both, se parated by a space - IB*2.0*43 2 ; IBXIEN = claim ie n ; IBL = field leng th-1 to al low for 1 blank spac e between numbers (2 8 for CMS 1500, 30 f or UB-04) ; Z = 1 fo r PRIMARY, 2 for SEC ONDARY, 3 for TERTIA RY ; N IB XDATA,IBZ Q:$G(IBXIE N)="" "" ; if CMS 15 00, find c urrent cod es I $G(Z) ="",$G(IBL )=28 S Z=$ $COBN^IBCE F(IBXIEN) Q:$G(Z)="" "" ; if l ength not defined, d efault to shortest S :IBL="" IB L=28 D F^I BCEF("N-"_ $P("PRIMAR Y^SECONDAR Y^TERTIARY ",U,Z)_" A UTH CODE", ,,IBXIEN) D F^IBCEF( "N-"_$P("P RIMARY^SEC ONDARY^TER TIARY",U,Z )_" REFERR AL NUMBER" ,"IBZ",,IB XIEN) ; if length of auth and referral c ombined is too long, only retu rn auth co de Q $S(IB Z="":IBXDA TA,IBXDATA ="":IBZ,$L (IBXDATA)+ $L(IBZ)>IB L:IBXDATA, 1:IBXDATA_ " "_IBZ) ; GRPNAME(IB IEN,IBXDAT A) ; Popul ate IBXDAT A with the Group Nam e(s). ; MR D;IB*2.0*5 16 - Creat ed this pr ocedure as extract c ode for ; ^IBA(364.5 ,199), N-A LL INSURAN CE GROUP N AME. N A,Z F Z=1:1:3 I $D(^DGC R(399,IBIE N,"I"_Z)) D . S IBXD ATA(Z)=$$P OLICY^IBCE F(IBIEN,15 ,Z) I IBXD ATA(Z)'="" Q . S A=$ $POLICY^IB CEF(IBIEN, 1,Z) ; Pul l piece 1, Ins. Type . . I A'=" " S IBXDAT A(Z)=$P($G (^DIC(36,+ A,0)),U) . Q Q ;GRPN UM(IBXIEN, IBXDATA) ; Populate IBXDATA wi th the Gro up Number( s). ; MRD; IB*2.0*516 - Created this proc edure as e xtract cod e for ; ^I BA(364.5,2 00), N-ALL INSURANCE GROUP NUM BER. N Z F Z=1:1:3 I $D(^DGCR( 399,IBXIEN ,"I"_Z)) S IBXDATA(Z )=$$POLICY ^IBCEF(IBX IEN,3,Z) Q ; | |
| 1226 | Modified L ogic (Chan ges are in bold) | |
| 1227 | IBCEF31 ;A LB/ESG - F ORMATTER S PECIFIC BI LL FLD FUN CTIONS - C ONT ;14-NO V-03 ;;2.0 ;INTEGRATE D BILLING; **155,296, 349,400,43 2,488,516, 592**;21-M AR-94;Buil d 123 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ; Q ;ALLTYP( IBIFN) ; r eturns cod es to tran slate to A LL ins typ es on a bi ll ; IBIFN = ien of bill N IBX ,Z F Z=1:1 :3 S $P(IB X,U,Z)=$$I NSTYP(IBIF N,Z) ; IBX = primary code^seco ndary code ^tertiary code Q IBX ;INSTYP(I BIFN,SEQ) ; Returns insurance type code for an ins on a bill ; IBIFN = ien of bi ll ; SEQ = sequence (1,2,3) of insurance wanted - prim, seco nd, tert ; Default i s current insurance co ; N IBA ,Z ; I '$G (SEQ) S SE Q=$$COBN^I BCEF(IBIFN ) S Z=+$G( ^DGCR(399, IBIFN,"I"_ SEQ)) ;Cod es 1:HMO;2 :COMMERCIA L;3:MEDICA RE;4:MEDIC AID;5:GROU P POLICY;9 :OTHER I Z D . S IBA =$P($G(^DI C(36,Z,3)) ,U,9) . I $$MCRWNR^I BEFUNC(Z) S IBA=3 ; force Medi care (WNR) definitio n to be co rrect . I IBA="" S I BA=5 ;Defa ult is gro up policy - 5 if bla nk ; Q $G( IBA) ;POLT YP(IBIFN,I BSEQ) ; Re turns ins electronic policy ty pe code fo r one ; in s policy o n a bill ; IBIFN = i en of bill ; IBSEQ = sequence (1,2,3) of ins polic y wanted - prim, sec ond, tert ; Default is current insurance co ; N IB PLAN,IBPLT YP ; I '$G (IBSEQ) S IBSEQ=+$$C OBN^IBCEF( IBIFN) S I BPLAN=$G(^ IBA(355.3, +$P($G(^DG CR(399,IBI FN,"I"_IBS EQ)),U,18) ,0)) S IBP LTYP=$P(IB PLAN,U,15) ; ; esg - 06/30/05 - IB*2.0*2 96 - Force Medicare (WNR) to b e correct ;JRA IB*2. 0*592 Trea t Dental F orm 7 (J43 0D) the sa me as CMS- 1500 ;I $$ WNRBILL^IB EFUNC(IBIF N,IBSEQ),$ $FT^IBCEF( IBIFN)=2 S IBPLTYP=" MB" ; CMS- 1500 ----> Medicare Part B ;JR A IB*2.0*5 92 ';' ;I $$WNRBILL^ IBEFUNC(IB IFN,IBSEQ) ,$$FT^IBCE F(IBIFN)=3 S IBPLTYP ="MA" ; UB -04 ------ -> Medicar e Part A N FT S FT=$ $FT^IBCEF( IBIFN) ;JR A IB*2.0*5 92 I $$WNR BILL^IBEFU NC(IBIFN,I BSEQ),(FT= 2!(FT=7)) S IBPLTYP= "MB" ; C MS-1500 -- --> Medica re Part B ;JRA IB*2. 0*592 same for J430D I $$WNRBI LL^IBEFUNC (IBIFN,IBS EQ),FT=3 S IBPLTYP=" MA" ; UB -04 ------ -> Medicar e Part A ; JRA IB*2.0 *592 Use ' FT' vs fun ction call ; I IBPLT YP="" S IB PLTYP="CI" ;Default is commerc ial - 'CI' I IBPLTYP ="MX" D . I $P(IBPLA N,U,14)'=" ","AB"[$P( IBPLAN,U,1 4) S IBPLT YP="M"_$P( IBPLAN,U,1 4) Q . S I BPLTYP="CI " Q $G(IBP LTYP) ;ALL PTYP(IBIFN ) ; return s insuranc e policy t ype codes for ALL in s on a bil l ; IBIFN = ien of b ill N IBX, Z S IBX="" F Z=1:1:3 I $D(^DGC R(399,IBIF N,"I"_Z)) S $P(IBX,U ,Z)=$$POLT YP(IBIFN,Z ) ; IBX = primary co de^seconda ry code^te rtiary cod e Q IBX ;P GDX(DXCNT, IBX0,IBXDA ,IBXLN,IBX COL,IBXSIZ E,IBXSAVE) ; Subrout ine - Chec ks for Dia gnosis Cod es (Dx) be yond ; th e first fo ur, that r elate to t he current Dx positi on passed in DXCNT. ; This sub routine st ores the D iagnosis C odes in ou tput globa l using di splay para meters (IB XLN,IBXCOL ) ; THE PA GE IS ALWA YS 1 NOW S O WE DON'T NEED 4 LI NES BELOW BAA *488* ; If DXCNT is 1, che ck for Dx' s 5,9,...e tc & displ ay on page s 2,3,...e tc ; If DX CNT is 2, check for Dx's 6,10, ...etc & d isplay on pages 2,3, ...etc ; I f DXCNT is 3, check for Dx's 7 ,11,...etc & display on pages 2,3,...etc ; If DXCN T is 4, ch eck for Dx 's 8,12,.. .etc & dis play on pa ges 2,3,.. .etc ; ; I nput: DXCN T= positio n of curre nt Dx (fro m 1 to 4) ; IBX0= ze ro-level o f file 364 .7 of curr ent Dx ; I BXDA= ien# of file 3 64.6 of cu rrent Dx ; IBXLN IBX COL= line# & Column# of curren t Dx ; IBX SIZE= size counter ; IBXSAVE(" DX")= loca l array wi th all Dx' s on curre nt bill ; ; For patc h *488* ; S DXNM = 12 This is the numbe r of diagn osis on a 1500 form ; S IBPG= 1 This is the page n umber. All 12 print on page 1 N IBPG,VAL S IBPG=1 I '$D(IBXS AVE("DX",D XCNT)) Q S VAL=$P($$ ICD9^IBACS V(+IBXSAVE ("DX",DXCN T)),U) ; r esolve Dx pointer S VAL=$$FORM AT^IBCEF3( VAL,$G(IBX 0),$G(IBXD A)) ;forma t Dx value D SETGBL^ IBCEFG(IBP G,IBXLN,IB XCOL,VAL,. IBXSIZE) ; store in o utput glob al Q ;PGD X ;DXSV(IB ,IBXSAVE) ; output f ormatter s ubroutine ; save off DX codes in IBXSAVE ("DX") N Z ,IBCT S (Z ,IBCT)=0 F S Z=$O(I B(Z)) Q:'Z I $G(IB( Z)) S IBCT =IBCT+1 M IBXSAVE("D X",IBCT)=I B(Z) Q ;AU TRF(IBXIEN ,IBL,Z) ; returns au th # and r eferral# i f room for both, sep arated by a space - IB*2.0*432 ; IBXIEN= claim ien ; IBL = f ield lengt h-1 to all ow for 1 b lank space between n umbers (28 for CMS 1 500, 30 fo r UB-04) ; Z = 1 for PRIMARY, 2 for SECO NDARY, 3 f or TERTIAR Y ; N IBX DATA,IBZ Q :$G(IBXIEN )="" "" ; if CMS 150 0, find cu rrent code s I $G(Z)= "",$G(IBL) =28 S Z=$$ COBN^IBCEF (IBXIEN) Q :$G(Z)="" "" ; if le ngth not d efined, de fault to s hortest S: IBL="" IBL =28 D F^IB CEF("N-"_$ P("PRIMARY ^SECONDARY ^TERTIARY" ,U,Z)_" AU TH CODE",, ,IBXIEN) D F^IBCEF(" N-"_$P("PR IMARY^SECO NDARY^TERT IARY",U,Z) _" REFERRA L NUMBER", "IBZ",,IBX IEN) ; if length of auth and r eferral co mbined is too long, only retur n auth cod e Q $S(IBZ ="":IBXDAT A,IBXDATA= "":IBZ,$L( IBXDATA)+$ L(IBZ)>IBL :IBXDATA,1 :IBXDATA_" "_IBZ) ;G RPNAME(IBI EN,IBXDATA ) ; Popula te IBXDATA with the Group Name (s). ; MRD ;IB*2.0*51 6 - Create d this pro cedure as extract co de for ; ^ IBA(364.5, 199), N-AL L INSURANC E GROUP NA ME. N A,Z F Z=1:1:3 I $D(^DGCR (399,IBIEN ,"I"_Z)) D . S IBXDA TA(Z)=$$PO LICY^IBCEF (IBIEN,15, Z) I IBXDA TA(Z)'="" Q . S A=$$ POLICY^IBC EF(IBIEN,1 ,Z) ; Pull piece 1, Ins. Type. . I A'="" S IBXDATA (Z)=$P($G( ^DIC(36,+A ,0)),U) . Q Q ;GRPNU M(IBXIEN,I BXDATA) ; Populate I BXDATA wit h the Grou p Number(s ). ; MRD;I B*2.0*516 - Created this proce dure as ex tract code for ; ^IB A(364.5,20 0), N-ALL INSURANCE GROUP NUMB ER. N Z F Z=1:1:3 I $D(^DGCR(3 99,IBXIEN, "I"_Z)) S IBXDATA(Z) =$$POLICY^ IBCEF(IBXI EN,3,Z) Q ; | |
| 1228 | ||
| 1229 | Routines | |
| 1230 | Activities | |
| 1231 | Routine Na me | |
| 1232 | IBCEF4 | |
| 1233 | Enhancemen t Category | |
| 1234 | New | |
| 1235 | Modify | |
| 1236 | Delete | |
| 1237 | No Change | |
| 1238 | RTM | |
| 1239 | ||
| 1240 | Related Op tions | |
| 1241 | None | |
| 1242 | Related Ro utines | |
| 1243 | Routines “ Called By” | |
| 1244 | Routines “ Called” | |
| 1245 | ||
| 1246 | ||
| 1247 | ||
| 1248 | ||
| 1249 | Data Dicti onary (DD) Reference s | |
| 1250 | ||
| 1251 | Related Pr otocols | |
| 1252 | None | |
| 1253 | Related In tegration Control Re gistration s (ICRs) | |
| 1254 | None | |
| 1255 | Data Passi ng | |
| 1256 | Input | |
| 1257 | Output Re ference | |
| 1258 | Both | |
| 1259 | Global Re ference | |
| 1260 | Local | |
| 1261 | Input Attr ibute Name and Defin ition | |
| 1262 | Name: | |
| 1263 | Definition : | |
| 1264 | Output Att ribute Nam e and Defi nition | |
| 1265 | Name: | |
| 1266 | Definition : | |
| 1267 | Current Lo gic | |
| 1268 | IBCEF4 ;AL B/TMP - MR A/EDI ACTI VATED UTIL ITIES ;06- FEB-96 ;;2 .0;INTEGRA TED BILLIN G;**51,137 ,232,155,2 96,327,349 **;21-MAR- 94;Build 4 6 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; EDIACTV(IB EDIMRA) ; Returns 0 if EDI or MRA is not active, ; otherwis e, returns 1 ; IBEDI MRA : 1= c hecking if EDI is ac tive, 2= c hecking if MRA is ac tive N IBE DI S IBEDI =$P($G(^IB E(350.9,1, 8)),U,10) Q $S('IBED I:0,IBEDI= 3:1,1:IBED I=IBEDIMRA ) ;RATEOK( IBIFN) ; R eturns 1 i f rate typ e of bill IBIFN is t ransmittab le Q +$P($ G(^DGCR(39 9.3,+$P($G (^DGCR(399 ,IBIFN,0)) ,U,7),0)), U,10) ;INS OK(INS) ; Determine EDI activa tion statu s of insur ance co Q +$G(^DIC(3 6,INS,3)) ;1 = TEST, 2 = LIVE, 0 = NOT A CTIVE FOR EDI ;BSTAT X(IBIFN) ; Returns i nternal va lue of bil l's latest transmiss ion status N IBDA Q $P($G(^IBA (364,+$$LA ST364(IBIF N),0)),U,3 ) ;LAST364 (IBIFN) ; Determine ien of lat est transm it bill re cord for a bill Q +$ O(^IBA(364 ,"ABDT",IB IFN,+$O(^I BA(364,"AB DT",IBIFN, ""),-1),"" ),-1) ;TXM T(IBIFN,IB WHY,IBNEW) ; Determi ne if bill # IBIFN i s 'transmi ttable' ; IBNEW = fl ag is 1 if new entry - don't c heck for e ntry in fi le 364 ; F unction re turns: ; 0 if not tr ansmittabl e ; if tra nsmittable , the enti re node 3 of the ins urance com pany ; and , if passe d by refer ence IBWHY = reason not transm ittable ; 1 if local print ; 2 if EDI/MR A not acti ve ; 3 if rate type not transm ittable ; 4 if no tr ansmit for insurance co ; 5 if failed tx mn rules ; and IBWHY (0) = ien of rule fa iled ; 6 i f Rx with missing/in valid NDC format ; N IB,IB0,IB OK,IBCOB,I BMCR,X1 S IBOK=1,IB= IBIFN,IBWH Y="" ; S I BCOB=$$COB N^IBCEF(IB ),IB(.07)= +$G(^DGCR( 399,IB,"I" _IBCOB)) S IBMCR=$$M CRWNR^IBEF UNC(IB(.07 )) ; Does bill have force loca l print fl ag set? I 'IBMCR D G:IBWHY TX MTQ ; MCR WNR not c urr ins . I $S($$MRA SEC(IBIFN) :$P($G(^DG CR(399,IBI FN,"TX")), U,9)=1,1:$ P($G(^DGCR (399,IBIFN ,"TX")),U, 8)=1) S IB OK=0,IBWHY =1 I '$G(I BNEW),'$O( ^IBA(364," B",IBIFN,0 )),$P($G(^ DGCR(399,I BIFN,0)),U ,13)>2,'$$ RETN^PRCAF N(IBIFN) S IBOK=0 G TXMTQ ; No t recogniz ed as tran smittable when it wa s authoriz ed I $O(^I BA(364,"B" ,IBIFN,0)) ,$$INSOK(I B(.07)),$$ BSTATX(IBI FN)'="X" G TXMTQ ;Al ready dete rmined to be transmi ttable - e ntry exist s for bill in transm it bill fi le S IB(.0 3)=$S('IBM CR:1,1:2) ; EDI(1) o r MRA(2) S IB(.04)=$ S('$$INPAT ^IBCEF(IB, 1):1,1:2) ;Outpt(1) or Inpt(2) S IB(.05) =$S($$FT^I BCEF(IB)=3 :1,1:2) ;I nst(1) or Prof(2) ; Execute un modifiable , general edits S X1 =$$EDIACTV (IB(.03)) I 'X1 S IB WHY=2 I 'I BWHY S X1= $$RATEOK(I BIFN) S:'X 1 IBWHY=3 I 'IBWHY S X1=$$INSO K(+IB(.07) ) S:'X1 IB WHY=4 I 'I BWHY,$$ISR X^IBCEF1(I BIFN) D ; S:'X1 IBWH Y=6 . ; Ch eck for Rx s and NDC # format v alid (5-4- 2) . ;IF T HIS IS A U B FORM DO NOT SEND E LECTRONIC . I $$FT^I BCEF(IBIFN )=3 S IBWH Y=1 . ; . Q ;;CHECK REMOVAL S O NON NDC FORMAT NUM BERS WILL GO . N Z,Z 0,Z00 . S Z="" F S Z=$O(^IBA( 362.4,"AIF N"_IBIFN,Z )) Q:Z=""! 'X1 D Q: 'X1 .. S Z 0=0 F S Z 0=$O(^IBA( 362.4,"AIF N"_IBIFN,Z ,Z0)) Q:'Z 0 D Q:'X 1 ... S Z0 0=$G(^IBA( 362.4,Z0,0 )) ... Q:$ S($P(Z00,U ,8)="":1,1 :$L($P(Z00 ,U,8))=11) ... I $P( Z00,U,9)'= 4 S X1=0 ; Only cont inue if ge neral edit s are pass ed I $$COB ^IBCEF(IB) ="S" D . S COBINS=$P ($G(^DGCR( 399,IB,"M" )),U,IBCOB +1) . I 'C OBINS Q . I IBMCR S IBWHY=1,$P (^DGCR(399 ,IBIFN,"TX "),U,8)=1 I IBWHY S IBOK=0 G T XMTQ S IBO K=$$EDIT(I BIFN,.IB,. IBWHY) G:' IBOK TXMTQ ;TXMTQ ; I IBOK S I BOK=$G(^DI C(36,+IB(. 07),3)) Q IBOK ;MRAS EC(IBIFN) ; Returns 1 if curre nt bill is secondary to MCR WN R N IBSEQ, IB,Z S IB= 0 ; Chk if MCR WNR i s prev ins urer with MRA on fil e S IBSEQ= $$COBN^IBC EF(IBIFN)- 1 S Z=$$MC RONBIL^IBE FUNC(IBIFN ,IBSEQ) I +Z=1,$P(Z, U,2)=1,$$C HK^IBCEMU1 (IBIFN) S IB=1 Q IB ;EDIT(IBIF N,IB,IBWHY ) ; Find, execute ed its applyi ng to bill to see if transmitt able ; IBI FN = ien o f bill in file 399 ; IB = arra y containi ng necessa ry data fo r xref sea rch from b ill ; subs cripted by field # i n file 364 .4 ; ; Mat rix entrie s: ; IB(.0 3): 1=EDI specific, 2=MRA spec ific ; IB( .04): 1=Ou tpatient o r 2=inpati ent only ( currently defaults t o 3) ; IB( .05): 1=On ly institu tional or 2=only pro fessional ; X: Anyth ing valid ; ; MRA-ED I IN-OUT I NST-PROF ; Level --- ---- ----- - -------- - ; 1 X X X ; 2 X X IB(.05) ; 3 X IB(.04 ) X ; 4 X IB(.04) IB (.05) ; 5 IB(.03) X X ; 6 IB(. 03) X IB(. 05) ; 7 I B(.03) IB( .04) X ; 8 IB(.03) I B(.04) IB( .05) ; N I B0,IB1,IB2 ,IB3,IB4,I BDA,IBFT,I BPASS,IBSE Q,IBT,IBNO CK I '$G(I B(.03)) S IBPASS=0 G EDITQ S I BFT=$$FT^I BCEF(IBIFN ) ; S IBPA SS=1 F IBS EQ=1:1:8 D Q:'IBPAS S ; Loop thru level s in matri x . F IB1= 1:1:3 Q:'I BPASS F I B2=1:1:3 Q :'IBPASS F IB3=1:1: 3 Q:'IBPAS S D .. S IB4=0 F S IB4=$O(^I BE(364.4," AD",IB1,IB 2,IB3,IB4) ) Q:'IB4 I $O(^(IB4 ,0)) D Q: 'IBPASS .. . S IBDA=0 ... F S IBDA=$O(^ IBE(364.4, "AD",IB1,I B2,IB3,IB4 ,IBDA)) Q: 'IBDA S I B0=$G(^IBE (364.4,IBD A,0)) I IB 0'="",'$D( IBNOCK(IBD A)) D Q:' IBPASS ... . I $P(IB0 ,U,2)>DT S IBNOCK(IB DA)="" Q ; Not acti vated yet .... I $P( IB0,U,6),$ P(IB0,U,6) '>DT S IB NOCK(IBDA) ="" Q ; I nactive .. .. I $P(IB 0,U,11),IB 3'=3,$S(IB FT=3:IB3'= 1,IBFT=2:I B3'=2,1:0) S IBNOCK( IBDA)="" Q ; Form t ype not in cluded - n ot used fo r form typ e rule (0) .... I IB 4=1,'$D(^I BE(364.4,I BDA,3,"B", +IB(.07))) S IBNOCK( IBDA)="" Q ; Ins no t included for rule .... I IB4 =2,$D(^IBE (364.4,IBD A,2,"B",+I B(.07))) S IBNOCK(IB DA)="" Q ; Ins is e xcluded fr om rule .. .. S IBT=$ G(^IBE(364 .4,IBDA,1) ) .... ; C ode can as sume IBIFN , IBDA and IB(.03 th ru .05 and .07) exis t .... I I BT'="" X I BT I '$T S IBPASS=0, IBWHY(0)=I BDA,IBWHY= 5EDITQ Q I BPASS ;STA TUS(IBIFN) ; Functio n returns whether or not bill currently has a stat us ; messa ge or EOB message no t yet full y reviewed - ; (only for trans mittable b ills) ; IB IFN = ien of bill in file 399 ; Returns: ; 0 = Non e found ; If found, returns a pieced str ing as fol lows: ; ; [1] ien of transmit bill entry (file 364 ) associat ed with an ; entry i n file 361 with an u nreviewed status mes sage ; [2] ien of tr ansmit bil l entry (f ile 364) a ssociated with an ; entry in f ile 361.1 with an un reviewed E OB ; N IB, Z,Z0 S IB= "" S Z="" F S Z=$O( ^IBM(361," B",IBIFN,Z ),-1) Q:'Z I $P($G( ^IBM(361,Z ,0)),U,9)< 2,$P(^(0), U,11) S $P (IB,U)=$P( ^(0),U,11) Q ; S Z=" " F S Z=$ O(^IBM(361 .1,"B",IBI FN,Z),-1) Q:'Z I $P ($G(^IBM(3 61.1,Z,0)) ,U,16)<2,$ P(^(0),U,1 9) S $P(IB ,U,2)=$P(^ (0),U,19) Q ; Q IB ; TEST(IBIFN ) ; Return s 1 if bil l IBIFN is a transmi ssion test bill, 0 i f not Q +$ S($G(^TMP( "IBEDI_TES T_BATCH",$ J)):1,1:+$ P($G(^IBA( 364,+$$LAS T364(IBIFN ),0)),U,7) ) ; | |
| 1269 | Modified L ogic (Chan ges are in bold) | |
| 1270 | IBCEF4 ;AL B/TMP - MR A/EDI ACTI VATED UTIL ITIES ;06- FEB-96 ;;2 .0;INTEGRA TED BILLIN G;**51,137 ,232,155,2 96,327,349 ,592**;21- MAR-94;Bui ld 46 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ;EDIACT V(IBEDIMRA ) ; Return s 0 if EDI or MRA is not activ e, ; othe rwise, ret urns 1 ; I BEDIMRA : 1= checkin g if EDI i s active, 2= checkin g if MRA i s active N IBEDI S I BEDI=$P($G (^IBE(350. 9,1,8)),U, 10) Q $S(' IBEDI:0,IB EDI=3:1,1: IBEDI=IBED IMRA) ;RAT EOK(IBIFN) ; Returns 1 if rate type of b ill IBIFN is transmi ttable Q + $P($G(^DGC R(399.3,+$ P($G(^DGCR (399,IBIFN ,0)),U,7), 0)),U,10) ;INSOK(INS ) ; Determ ine EDI ac tivation s tatus of i nsurance c o Q +$G(^D IC(36,INS, 3)) ;1 = T EST, 2 = L IVE, 0 = N OT ACTIVE FOR EDI ;B STATX(IBIF N) ; Retur ns interna l value of bill's la test trans mission st atus N IBD A Q $P($G( ^IBA(364,+ $$LAST364( IBIFN),0)) ,U,3) ;LAS T364(IBIFN ) ; Determ ine ien of latest tr ansmit bil l record f or a bill Q +$O(^IBA (364,"ABDT ",IBIFN,+$ O(^IBA(364 ,"ABDT",IB IFN,""),-1 ),""),-1) ;TXMT(IBIF N,IBWHY,IB NEW) ; Det ermine if bill # IBI FN is 'tra nsmittable ' ; IBNEW = flag is 1 if new e ntry - don 't check f or entry i n file 364 ; Functio n returns: ; 0 if no t transmit table ; if transmitt able, the entire nod e 3 of the insurance company ; and, if p assed by r eference I BWHY = rea son not tr ansmittabl e ; 1 if l ocal print ; 2 if ED I/MRA not active ; 3 if rate t ype not tr ansmittabl e ; 4 if n o transmit for insur ance co ; 5 if faile d txmn rul es ; and I BWHY(0) = ien of rul e failed ; 6 if Rx w ith missin g/invalid NDC format ; N IB,IB 0,IBOK,IBC OB,IBMCR,X 1 S IBOK=1 ,IB=IBIFN, IBWHY="" ; S IBCOB=$ $COBN^IBCE F(IB),IB(. 07)=+$G(^D GCR(399,IB ,"I"_IBCOB )) S IBMCR =$$MCRWNR^ IBEFUNC(IB (.07)) ; D oes bill h ave force local prin t flag set ? I 'IBMCR D G:IBWH Y TXMTQ ; MCR WNR n ot curr in s . I $S($ $MRASEC(IB IFN):$P($G (^DGCR(399 ,IBIFN,"TX ")),U,9)=1 ,1:$P($G(^ DGCR(399,I BIFN,"TX") ),U,8)=1) S IBOK=0,I BWHY=1 I ' $G(IBNEW), '$O(^IBA(3 64,"B",IBI FN,0)),$P( $G(^DGCR(3 99,IBIFN,0 )),U,13)>2 ,'$$RETN^P RCAFN(IBIF N) S IBOK= 0 G TXMTQ ; Not reco gnized as transmitta ble when i t was auth orized I $ O(^IBA(364 ,"B",IBIFN ,0)),$$INS OK(IB(.07) ),$$BSTATX (IBIFN)'=" X" G TXMTQ ;Already determined to be tra nsmittable - entry e xists for bill in tr ansmit bil l file S I B(.03)=$S( 'IBMCR:1,1 :2) ; EDI( 1) or MRA( 2) S IB(.0 4)=$S('$$I NPAT^IBCEF (IB,1):1,1 :2) ;Outpt (1) or Inp t(2) S IB( .05)=$S($$ FT^IBCEF(I B)=3:1,1:2 ) ;Inst(1) or Prof(2 ) ; Execut e unmodifi able, gene ral edits S X1=$$EDI ACTV(IB(.0 3)) I 'X1 S IBWHY=2 I 'IBWHY S X1=$$RATE OK(IBIFN) S:'X1 IBWH Y=3 I 'IBW HY S X1=$$ INSOK(+IB( .07)) S:'X 1 IBWHY=4 I 'IBWHY,$ $ISRX^IBCE F1(IBIFN) D ;S:'X1 IBWHY=6 . ; Check fo r Rxs and NDC # form at valid ( 5-4-2) . ; IF THIS IS A UB FORM DO NOT SE ND ELECTRO NIC . I $$ FT^IBCEF(I BIFN)=3 S IBWHY=1 . ; . Q ;;C HECK REMOV AL SO NON NDC FORMAT NUMBERS W ILL GO . N Z,Z0,Z00 . S Z="" F S Z=$O(^ IBA(362.4, "AIFN"_IBI FN,Z)) Q:Z =""!'X1 D Q:'X1 .. S Z0=0 F S Z0=$O(^ IBA(362.4, "AIFN"_IBI FN,Z,Z0)) Q:'Z0 D Q:'X1 ... S Z00=$G(^ IBA(362.4, Z0,0)) ... Q:$S($P(Z 00,U,8)="" :1,1:$L($P (Z00,U,8)) =11) ... I $P(Z00,U, 9)'=4 S X1 =0 ; Only continue i f general edits are passed I $ $COB^IBCEF (IB)="S" D . S COBIN S=$P($G(^D GCR(399,IB ,"M")),U,I BCOB+1) . I 'COBINS Q . I IBMC R S IBWHY= 1,$P(^DGCR (399,IBIFN ,"TX"),U,8 )=1 I IBWH Y S IBOK=0 G TXMTQ S IBOK=$$ED IT(IBIFN,. IB,.IBWHY) G:'IBOK T XMTQ ;TXMT Q ; I IBOK S IBOK=$G (^DIC(36,+ IB(.07),3) ) Q IBOK ; MRASEC(IBI FN) ; Retu rns 1 if c urrent bil l is secon dary to MC R WNR N IB SEQ,IB,Z S IB=0 ; Ch k if MCR W NR is prev insurer w ith MRA on file S IB SEQ=$$COBN ^IBCEF(IBI FN)-1 S Z= $$MCRONBIL ^IBEFUNC(I BIFN,IBSEQ ) I +Z=1,$ P(Z,U,2)=1 ,$$CHK^IBC EMU1(IBIFN ) S IB=1 Q IB ;EDIT( IBIFN,IB,I BWHY) ; Fi nd, execut e edits ap plying to bill to se e if trans mittable ; IBIFN = i en of bill in file 3 99 ; IB = array cont aining nec essary dat a for xref search fr om bill ; subscripte d by field # in file 364.4 ; ; Matrix en tries: ; I B(.03): 1= EDI specif ic, 2=MRA specific ; IB(.04): 1=Outpatie nt or 2=in patient on ly (curren tly defaul ts to 3) ; IB(.05): 1=Only ins titutional or 2=only professio nal ; X: A nything va lid ; ; MR A-EDI IN-O UT INST-PR OF ; Level ------- - ----- ---- ----- ; 1 X X X ; 2 X X IB(.05 ) ; 3 X IB (.04) X ; 4 X IB(.04 ) IB(.05) ; 5 IB(.03 ) X X ; 6 IB(.03) X IB(.05) ; 7 IB(.03) IB(.04) X ; 8 IB(.0 3) IB(.04) IB(.05) ; N IB0,IB1 ,IB2,IB3,I B4,IBDA,IB FT,IBPASS, IBSEQ,IBT, IBNOCK I ' $G(IB(.03) ) S IBPASS =0 G EDITQ S IBFT=$$ FT^IBCEF(I BIFN) ; S IBPASS=1 F IBSEQ=1:1 :8 D Q:'I BPASS ; L oop thru l evels in m atrix . F IB1=1:1:3 Q:'IBPASS F IB2=1:1 :3 Q:'IBPA SS F IB3= 1:1:3 Q:'I BPASS D . . S IB4=0 F S IB4=$ O(^IBE(364 .4,"AD",IB 1,IB2,IB3, IB4)) Q:'I B4 I $O(^ (IB4,0)) D Q:'IBPAS S ... S IB DA=0 ... F S IBDA= $O(^IBE(36 4.4,"AD",I B1,IB2,IB3 ,IB4,IBDA) ) Q:'IBDA S IB0=$G( ^IBE(364.4 ,IBDA,0)) I IB0'="", '$D(IBNOCK (IBDA)) D Q:'IBPASS .... I $P (IB0,U,2)> DT S IBNOC K(IBDA)="" Q ; Not activated yet .... I $P(IB0,U, 6),$P(IB0, U,6)'>DT S IBNOCK(I BDA)="" Q ; Inactiv e .... ;JW S;IB*2.0*5 92;dental form #7, s ame as CMS -1500 .... I $P(IB0, U,11),IB3' =3,$S(IBFT =3:IB3'=1, IBFT=2:IB3 '=2,IBFT=7 :IB3'=2,1: 0) S IBNOC K(IBDA)="" Q ; Form type not included - not used for form t ype rule ( 0) .... I IB4=1,'$D( ^IBE(364.4 ,IBDA,3,"B ",+IB(.07) )) S IBNOC K(IBDA)="" Q ; Ins not includ ed for rul e .... I I B4=2,$D(^I BE(364.4,I BDA,2,"B", +IB(.07))) S IBNOCK( IBDA)="" Q ; Ins is excluded from rule .... S IBT =$G(^IBE(3 64.4,IBDA, 1)) .... ; Code can assume IBI FN, IBDA a nd IB(.03 thru .05 a nd .07) ex ist .... I IBT'="" X IBT I '$T S IBPASS= 0,IBWHY(0) =IBDA,IBWH Y=5EDITQ Q IBPASS ;S TATUS(IBIF N) ; Funct ion return s whether or not bil l currentl y has a st atus ; mes sage or EO B message not yet fu lly review ed - ; (on ly for tra nsmittable bills) ; IBIFN = ie n of bill in file 39 9 ; Return s: ; 0 = N one found ; If found , returns a pieced s tring as f ollows: ; ; [1] ien of transmi t bill ent ry (file 3 64) associ ated with an ; entry in file 3 61 with an unreviewe d status m essage ; [ 2] ien of transmit b ill entry (file 364) associate d with an ; entry in file 361. 1 with an unreviewed EOB ; N I B,Z,Z0 S I B="" S Z=" " F S Z=$ O(^IBM(361 ,"B",IBIFN ,Z),-1) Q: 'Z I $P($ G(^IBM(361 ,Z,0)),U,9 )<2,$P(^(0 ),U,11) S $P(IB,U)=$ P(^(0),U,1 1) Q ; S Z ="" F S Z =$O(^IBM(3 61.1,"B",I BIFN,Z),-1 ) Q:'Z I $P($G(^IBM (361.1,Z,0 )),U,16)<2 ,$P(^(0),U ,19) S $P( IB,U,2)=$P (^(0),U,19 ) Q ; Q IB ;TEST(IBI FN) ; Retu rns 1 if b ill IBIFN is a trans mission te st bill, 0 if not Q +$S($G(^TM P("IBEDI_T EST_BATCH" ,$J)):1,1: +$P($G(^IB A(364,+$$L AST364(IBI FN),0)),U, 7)) ; | |
| 1271 | ||
| 1272 | Routines | |
| 1273 | Activities | |
| 1274 | Routine Na me | |
| 1275 | IBCEF7 | |
| 1276 | Enhancemen t Category | |
| 1277 | New | |
| 1278 | Modify | |
| 1279 | Delete | |
| 1280 | No Change | |
| 1281 | RTM | |
| 1282 | ||
| 1283 | Related Op tions | |
| 1284 | None | |
| 1285 | Related Ro utines | |
| 1286 | Routines “ Called By” | |
| 1287 | Routines “ Called” | |
| 1288 | ||
| 1289 | ||
| 1290 | ||
| 1291 | ||
| 1292 | Data Dicti onary (DD) Reference s | |
| 1293 | ||
| 1294 | Related Pr otocols | |
| 1295 | None | |
| 1296 | Related In tegration Control Re gistration s (ICRs) | |
| 1297 | None | |
| 1298 | Data Passi ng | |
| 1299 | Input | |
| 1300 | Output Re ference | |
| 1301 | Both | |
| 1302 | Global Re ference | |
| 1303 | Local | |
| 1304 | Input Attr ibute Name and Defin ition | |
| 1305 | Name: | |
| 1306 | Definition : | |
| 1307 | Output Att ribute Nam e and Defi nition | |
| 1308 | Name: | |
| 1309 | Definition : | |
| 1310 | Current Lo gic | |
| 1311 | IBCEF7 ;WO IFO/SS - F ORMATTER A ND EXTRACT OR SPECIFI C BILL FUN CTIONS ;8/ 6/03 10:56 am ;;2.0;I NTEGRATED BILLING;** 232,349,43 2**;21-MAR -94;Build 192 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ;ALLPROV ;called fr om #364.5 entry "N-A LL CUR/OTH PROVIDER INFO" ;*34 2/TAZ - Ad ded call t o LPRV^IBC EF80 for l ine level providers; restructu red due to line leng th I +$G(I BXSAVE("PR OVINF",IBX IEN))=0 D . N IBZ . D PROVIDER (IBXIEN,"C ",.IBZ),PR OVIDER(IBX IEN,"O",.I BZ) S IBXS AVE("PROVI NF",IBXIEN )=IBXIEN M IBXSAVE(" PROVINF",I BXIEN)=IBZ Q ;for PR V1 ;Input: ; IB399 i en of #399 PRV1(IB399 ) ; N IBN, IBZ,IBZ1,I BZN,IBZD,I BRES,IBIND ,IBDEF,IBD EFTYP,IBQ, IBFRMTYP,I BZNAME S I BFRMTYP=+$ $FT^IBCEF( IB399) S I BN=0,IBIND =0,IBRES=" ",IBQ=0 S IBDEF=$P($ G(^DGCR(39 9,IB399,"M 1")),U,$$C OBN^IBCEF( IB399)+1), IBDEFTYP=" " I IBDEF' ="" S IBDE FTYP=$$SOP ^IBCEP2B(I B399,"") I IBDEFTYP' ="",$$CHCK PRV1^IBCEF 73($S(IBFR MTYP=2:2,I BFRMTYP=3: 1,1:0),IBD EFTYP)=0 S (IBDEF,IB DEFTYP)="" I IBDEF'= "",IBDEFTY P'="" S IB IND=IBIND+ 2,$P(IBRES ,U,IBIND)= (IBDEFTYP_ U_IBDEF) F S IBN=$O (^IBE(355. 97,IBN)) Q :+IBN=0!(I BQ=1) D . S IBZ=$G(^ IBE(355.97 ,IBN,0)),I BZ1=$G(^(1 )) . Q:$P( IBZ,"^",4) =""!$P(IBZ 1,U,9) ;if no FACILI TY'S DEFAU LT ID # . Q:$P(IBZ1, "^",4)!(IB DEFTYP=$P( IBZ,U,3)) . S IBZN=$ P(IBZ,"^", 3),IBZNAME =$P(IBZ,"^ ",1) . I I BFRMTYP=2 Q:IBZN="1A "!(IBZNAME ="MEDICARE PART A") ;1500 . I IBFRMTYP=3 Q:IBZN="1 B"!(IBZNAM E="MEDICAR E PART B") ;UB . Q:$ $CHCKPRV1^ IBCEF73($S (IBFRMTYP= 2:2,IBFRMT YP=3:1,1:0 ),IBZN)=0 . I $P(IBZ ,"^",2)=0! ($P(IBZ,"^ ",2)=2) D . . S IBIN D=IBIND+2 . . I IBIN D>14 S IBQ =1 Q . . S $P(IBRES, "^",IBIND) =IBZN_"^"_ $P(IBZ,"^" ,4) ;Remov e any dupl icate entr ies N I,Q, QUAL,QUALC ,IBRESTMP, SEQ F I=2: 2:($L(IBRE S,"^")-1) D . S QUAL =$P(IBRES, "^",I) . I $G(IBREST MP(QUAL))= "" S IBRES TMP(QUAL)= $P(IBRES," ^",(I+1)) S Q=2 S I= "",QUAL="" K IBRES S IBRES="" S SEQ=0 F S QUAL=$O (IBRESTMP( QUAL)) Q:Q UAL="" D . S SEQ=SE Q+2 . S $P (IBRES,"^" ,SEQ)=QUAL ,$P(IBRES, "^",(SEQ+1 ))=IBRESTM P(QUAL) Q IBRES ; ; creates ar ray of SUB SCR IDs fo r all "oth er insuran ces" ;Inpu t : ; IBXI EN - ien i n #399 ;Ou tput: ; IB ZOUT(Z) - array with ien of #3 6 OTHSBID( IBXIEN,IBZ OUT) ; N Z ,Z0,Z1,IBZ ,C D F^IBC EF("N-ALL INSURANCE CO 837 ID" ,"IBZ") F Z=1,2,3 S IBZ(Z)=$$P OLICY^IBCE F(IBXIEN,2 ,$E("PST", Z)) K IBXD ATA S C=$$ OTHINS1^IB CEF2(IBXIE N) F Z=1,2 I $G(IBZ( Z))'="",$E (C,Z) D . S IBZOUT(Z )=IBZ(+$E( C,Z)) Q ;I nput : ; I BXIEN - ie n in #399 ; IBP - # piece in a ddress str ing : STR LINE1|STR LINE2|CITY |STATE|ZIP ;Output: ; IBARR - output arr ay m by re ferenceELM ADD2(IBXIE N,IBP,IBAR R) ; N IBZ ZZ,A,CHECK ,IB1 I '$D (IBXSAVE(" OTH_INSURE D_ADDR")) D OTHADD2( IBXIEN,.IB ZZZ) M IBX SAVE("OTH_ INSURED_AD DR")=IBZZZ S IB1=0 F S IB1=$O (IBXSAVE(" OTH_INSURE D_ADDR",IB 1)) Q:'IB1 D . ;IF ANY PORTIO N OF ADDRE SS IS NULL SET CHECK VALUE, ER ASE ENTRY . S CHECK= 0 . F A=1, 3,4,5 I $P (IBXSAVE(" OTH_INSURE D_ADDR",IB 1),"|",A)= "" S CHECK =1 K IBXSA VE("OTH_IN SURED_ADDR ",IB1) Q . I 'CHECK D . . I IB P=0 S IBAR R(IB1)=$G( IBXSAVE("O TH_INSURED _ADDR",IB1 )) Q . . S IBARR(IB1 )=$P($G(IB XSAVE("OTH _INSURED_A DDR",IB1)) ,"|",IBP) Q ;creates an array with addre ss info fo r all othe r insured persons ;I nput : ; I BXIEN - ie n in #399 ;Output: ; IBZOUT(Z) - array w ith STR LI NE1|STR LI NE2|CITY|S TATE|ZIP O THADD2(IBX IEN,IBZOUT ) ; N C,Z, Z0,Z1,IBZ, IBZIP,IB1, IBDFN1 S I BZOUT="" D OTHP36^IB CEF72(IBXI EN,.IBZ) ; array with iens of f ile #36 K IBXDATA S C=$$OTHINS 1^IBCEF2(I BXIEN) F Z =1,2 I $G( IBZ(Z))'=" ",$E(C,Z) D . S IBIN S=+IBZ(+$E (C,Z)) . S IBDFN1=$P ($G(^DGCR( 399,IBXIEN ,0)),"^",2 ) . S IBZO UT(Z)=$$FR 2PAT(IBDFN 1,IBINS) Q ;Input: ; IBDFN-pat ient ien ; IBINS - i nput array with insu rance poin ters to 36 ;Output ; STR LINE 1|STR LINE 2|CITY|STA TE|ZIPFR2P AT(IBDFN,I BINS) ;inf ormation a bout "othe r insured" address N Z3,Z4,Z5, IBZIP S Z3 =$O(^DPT(I BDFN,.312, "B",$G(IBI NS),0)) Q: +Z3=0 "||| |" S Z4=$G (^DPT(IBDF N,.312,Z3, 3)) S IBZI P=$P($G(^D IC(5,+$P(Z 4,"^",9),0 )),"^",2) S Z5=$P(Z4 ,"^",6,8)_ "^"_IBZIP_ "^"_$P(Z4, "^",10) Q $TR(Z5,"^" ,"|") ; ;I nput : ; I BXIEN - ie n in #399 ; IBP - # piece in a ddress str ing : STR LINE1|STR LINE2|CITY |STATE|ZIP ; if IBP= 0 then ret urns whole string ;O utput: ; I BARR - out put array m by refer enceELMADD R(IBXIEN,I BP,IBARR) ; N IB1,A, CHECK D:'$ D(IBXSAVE( "OTH_PROV_ ADDR")) OT HADDR(IBXI EN) S IB1= 0 F S IB1 =$O(IBXSAV E("OTH_PRO V_ADDR",IB 1)) Q:'IB1 D . S CH ECK=0 . ;E XCLUDE ADD LINE 2 SE COND PC SI NCE IT'S O K FOR THAT TO BE EMP TY . F A=1 ,3,4,5 I $ P(IBXSAVE( "OTH_PROV_ ADDR",IB1) ,"|",A)="" D Q . . ;IF ANY PO RTION OF A DDRESS IS NULL SET C HECK VALUE , ERASE EN TRY . . S CHECK=1 K IBXSAVE("O TH_PROV_AD DR",IB1) . I 'CHECK D . . I IB P=0 S IBAR R(IB1)=$G( IBXSAVE("O TH_PROV_AD DR",IB1)) Q . . S IB ARR(IB1)=$ P($G(IBXSA VE("OTH_PR OV_ADDR",I B1)),"|",I BP) Q ; ;c reates an array with address i nfo for al l insuranc es ;Input : ; IBXIEN - ien in #399 ;Outp ut: ; IBXS AVE("OTH_P ROV_ADDR", Z) OTHADDR (IBXIEN) ; N C,Z,Z0, Z1,IBZ,IBZ IP,IB1,IBI NS D F^IBC EF("N-OTH INSURANCE CO IEN 36" ) ;array w ith iens o f file #36 M IBZ=IBX DATA K IBX DATA S C=$ $OTHINS1^I BCEF2(IBXI EN) F Z=1, 2 I $G(IBZ (Z))'="",$ E(C,Z) D . S IBINS=+ IBZ(+$E(C, Z)) . S IB ZIP=$P($G( ^DIC(5,+$P ($G(^DIC(3 6,IBINS,.1 1)),"^",5) ,0)),"^",2 ) . S IB1= $P($G(^DIC (36,IBINS, .11)),"^", 1,2)_"^"_$ P($G(^DIC( 36,IBINS,. 11)),"^",4 )_"^"_IBZI P_"^"_$P($ G(^DIC(36, IBINS,.11) ),"^",6) . S IBXSAVE ("OTH_PROV _ADDR",Z)= $TR(IB1,"^ ","|") Q ; ;Retrieve s pointer to get inf o about th e service provider ; IBIEN399 - ien in #3 99 ;IBFUNC -function (3-RENDER ING,etc) ; Output: VA RIABLE POI NTER (PTR; file_root) PROVPTR(IB IEN399,IBF UNC) ; ;*4 32/TAZ - N o longer u sed for IB XSAVE arra y setup N IBN S IBN= $O(^DGCR(3 99,IBIEN39 9,"PRV","B ",IBFUNC,0 )) I +IBN= 0 Q 0 Q $P ($G(^DGCR( 399,IBIEN3 99,"PRV",+ IBN,0)),"^ ",2) ; ;Re trieves SS N from #20 0 ;IBPTR- VARIABLE P OINTER to #200PROVSS N(IBIEN399 ) ; N IBRE TVAL S IBR ETVAL="" N IBPTR,IBF T F IBFT=1 :1:9 D . S IBPTR=$$P ROVPTR(IBI EN399,IBFT ) . S $P(I BRETVAL,"^ ",IBFT)=$$ GETSSN^IBC EF72(IBPTR ) Q IBRETV AL ; ;Inpu t: ; IBPTR - ptr to ^ VA(200 or ^IBA(355.9 3 ;Output: ; SSN or nullGETNME L(IBFULL,I BEL) ;Get name eleme nt D NAMEC OMP^XLFNAM E(.IBFULL) Q $G(IBFU LL(IBEL)) ;- ;PROVID ER ;Input: ; IB399 - ien of #3 99 ; IBPRO V: ; "C"- to get inf o for CURR ENT provid er ; "O"- to get inf o for all others (in this case the array will cont ain info f ot two pro viders ; I BRES - arr ay for res ults (by r eference) ; ;Output: ; IBRES - array to get back i nfo (by re ference) ; IBRES(IBP ROV,PRNUM, PRTYPE,SEQ #)=PROV^IN SUR^IDTYPE ^ID^FORMTY P^CARETYP ; where: ; IBPROV - see input parameter ; PRNUM: 1 =primary i nsurance p rovider, 2 = secondar y, 3 -tret iary ; PRT YPE: Provi der type(F UNCTION) ; SEQ# : s equence nu mber (1st is used fo r ID1, 2nd - for ID2 , etc) ; P ROV : prov ider/VARIA BLEPTR ; I NSUR: Insu rance PTR #36 or NON E ; IDTYPE : ID type ; ID: ID ; FORMTYP: Form type 1=UB,2=15 00 ; CARET YP: Care t ype 0=both inp/outp, 1=inpatien t, 2=outpa tientPROVI DER(IB399, IBPROV,IBR ES) ; N IB CURR,IBZ,I BRESARR S IBRESARR=" " S IBCURR =$$COB^IBC EF(IB399) ;current b ill payer sequence Q :IBPROV="A " ;PATIEN T's bill I IBPROV="C " D . D:$$ ISINSUR^IB CEF71(IBCU RR,IB399) PROVINF(IB 399,$S(IBC URR="T":3, IBCURR="S" :2,IBCURR= "P":1,1:1) ,.IBRESARR ,1,IBPROV) I IBPROV= "O" D . I IBCURR="P" D:$$ISINS UR^IBCEF71 ("S",IB399 ) PROVINF( IB399,2,.I BRESARR,1, IBPROV) D: $$ISINSUR^ IBCEF71("T ",IB399) P ROVINF(IB3 99,3,.IBRE SARR,2,IBP ROV) . I I BCURR="S" D:$$ISINSU R^IBCEF71( "P",IB399) PROVINF(I B399,1,.IB RESARR,1,I BPROV) D:$ $ISINSUR^I BCEF71("T" ,IB399) PR OVINF(IB39 9,3,.IBRES ARR,2,IBPR OV) . I IB CURR="T" D :$$ISINSUR ^IBCEF71(" P",IB399) PROVINF(IB 399,1,.IBR ESARR,1,IB PROV) D:$$ ISINSUR^IB CEF71("S", IB399) PRO VINF(IB399 ,2,.IBRESA RR,2,IBPRO V) M IBRES (IBPROV)=I BRESARR Q ;PROVINF(I B399,IBPRN UM,IBRES,I BSORT,IBIN STP) ; D P ROVINF^IBC EF74(IB399 ,IBPRNUM,. IBRES,IBSO RT,IBINSTP ) Q ;PSPRV (IBIFN) ; Returns in formation for bill i en IBIFN f or purchas ed svc ; Returns 4 digit data in follow ing format : ; 1st di git: 0 if not outsid e facility ; 1 if ou tside faci lity ; 2nd digit: 0 if not non -VA provid er for ren dering/att ending ; 1 if non-VA provider for render ing/attend ing ; 3rd digit: 0 i f not purc hased svc ; 1 if pur chased svc ; 4th dig it: 0 if 1 500 bill ; 1 if UB b ill N IBSV C,Z,Z0,IBU 2 S IBSVC= "000"_+$$I NSFT^IBCEU 5(IBIFN),I BU2=$G(^DG CR(399,IBI FN,"U2")) I $P(IBU2, U,10) S $E (IBSVC,1)= 1 ; NON-VA FACILITY S Z=($$FT^ IBCEF(IBIF N)=3)+3,Z0 =+$O(^DGCR (399,IBIFN ,"PRV","B" ,Z,0)) I $ P($G(^DGCR (399,IBIFN ,"PRV",Z0, 0)),U,2)[" IBA(355.93 " S $E(IBS VC,2)=1 I $P(IBU2,U, 11)>0,$P(I BU2,U,11)' >2 S $E(IB SVC,3)=1PS PRVQ Q IBS VC ;CHKADD ;CHECK AL L ADDRESS ELEMENTS P RESENT IF NOT KILL A LL ADDRESS ELEMENTS ;EXPECT IB XSAVE("CAD R") AS SOU RCE ARRAY N Z,CHECK S Z="",CHE CK=0 F Z=1 ,4,5,6 D . I $P($G(I BXSAVE("CA DR")),"^", Z)="" S CH ECK=1 I CH ECK=1 S IB XSAVE("CAD R")="" Q ; | |
| 1312 | Modified L ogic (Chan ges are in bold) | |
| 1313 | IBCEF7 ;WO IFO/SS - F ORMATTER A ND EXTRACT OR SPECIFI C BILL FUN CTIONS ;8/ 6/03 10:56 am ;;2.0;I NTEGRATED BILLING;** 232,349,43 2,592**;21 -MAR-94;Bu ild 192 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ;ALLP ROV ;calle d from #36 4.5 entry "N-ALL CUR /OTH PROVI DER INFO" ;*342/TAZ - Added ca ll to LPRV ^IBCEF80 f or line le vel provid ers; restr uctured du e to line length I + $G(IBXSAVE ("PROVINF" ,IBXIEN))= 0 D . N IB Z . D PROV IDER(IBXIE N,"C",.IBZ ),PROVIDER (IBXIEN,"O ",.IBZ) S IBXSAVE("P ROVINF",IB XIEN)=IBXI EN M IBXSA VE("PROVIN F",IBXIEN) =IBZ Q ;fo r PRV1 ;In put: ; IB3 99 ien of #399PRV1(I B399) ; N IBN,IBZ,IB Z1,IBZN,IB ZD,IBRES,I BIND,IBDEF ,IBDEFTYP, IBQ,IBFRMT YP,IBZNAME S IBFRMTY P=+$$FT^IB CEF(IB399) S IBN=0,I BIND=0,IBR ES="",IBQ= 0 S IBDEF= $P($G(^DGC R(399,IB39 9,"M1")),U ,$$COBN^IB CEF(IB399) +1),IBDEFT YP="" I IB DEF'="" S IBDEFTYP=$ $SOP^IBCEP 2B(IB399," ") ;JRA IB *2.0*592 T reat new D ental form 7 (J430D) same as C MS-1500 ;I IBDEFTYP' ="",$$CHCK PRV1^IBCEF 73($S(IBFR MTYP=2:2,I BFRMTYP=3: 1,1:0),IBD EFTYP)=0 S (IBDEF,IB DEFTYP)="" ;JRA IB*2 .0*592 ';' I IBDEFTY P'="",$$CH CKPRV1^IBC EF73($S((I BFRMTYP=2! (IBFRMTYP= 7)):2,IBFR MTYP=3:1,1 :0),IBDEFT YP)=0 S (I BDEF,IBDEF TYP)="" ; JRA IB*2.0 *592 I IBD EF'="",IBD EFTYP'="" S IBIND=IB IND+2,$P(I BRES,U,IBI ND)=(IBDEF TYP_U_IBDE F) F S IB N=$O(^IBE( 355.97,IBN )) Q:+IBN= 0!(IBQ=1) D . S IBZ= $G(^IBE(35 5.97,IBN,0 )),IBZ1=$G (^(1)) . Q :$P(IBZ,"^ ",4)=""!$P (IBZ1,U,9) ;if no FA CILITY'S D EFAULT ID # . Q:$P(I BZ1,"^",4) !(IBDEFTYP =$P(IBZ,U, 3)) . S IB ZN=$P(IBZ, "^",3),IBZ NAME=$P(IB Z,"^",1) . ;I IBFRMT YP=2 Q:IBZ N="1A"!(IB ZNAME="MED ICARE PART A") ;1500 ;JRA IB*2 .0*592 ';' . I IBFRM TYP=2!(IBF RMTYP=7) Q :IBZN="1A" !(IBZNAME= "MEDICARE PART A") ; 1500 or J4 30D ;JRA I B*2.0*592 . I IBFRMT YP=3 Q:IBZ N="1B"!(IB ZNAME="MED ICARE PART B") ;UB . ;Q:$$CHCK PRV1^IBCEF 73($S(IBFR MTYP=2:2,I BFRMTYP=3: 1,1:0),IBZ N)=0 ;JRA IB*2.0*592 ';' . Q:$ $CHCKPRV1^ IBCEF73($S ((IBFRMTYP =2!(IBFRMT YP=7)):2,I BFRMTYP=3: 1,1:0),IBZ N)=0 ;JRA IB*2.0*592 . I $P(IB Z,"^",2)=0 !($P(IBZ," ^",2)=2) D . . S IBI ND=IBIND+2 . . I IBI ND>14 S IB Q=1 Q . . S $P(IBRES ,"^",IBIND )=IBZN_"^" _$P(IBZ,"^ ",4) ;Remo ve any dup licate ent ries N I,Q ,QUAL,QUAL C,IBRESTMP ,SEQ F I=2 :2:($L(IBR ES,"^")-1) D . S QUA L=$P(IBRES ,"^",I) . I $G(IBRES TMP(QUAL)) ="" S IBRE STMP(QUAL) =$P(IBRES, "^",(I+1)) S Q=2 S I ="",QUAL=" " K IBRES S IBRES="" S SEQ=0 F S QUAL=$ O(IBRESTMP (QUAL)) Q: QUAL="" D . S SEQ=S EQ+2 . S $ P(IBRES,"^ ",SEQ)=QUA L,$P(IBRES ,"^",(SEQ+ 1))=IBREST MP(QUAL) Q IBRES ; ; creates a rray of SU BSCR IDs f or all "ot her insura nces" ;Inp ut : ; IBX IEN - ien in #399 ;O utput: ; I BZOUT(Z) - array wit h ien of # 36 OTHSBID (IBXIEN,IB ZOUT) ; N Z,Z0,Z1,IB Z,C D F^IB CEF("N-ALL INSURANCE CO 837 ID ","IBZ") F Z=1,2,3 S IBZ(Z)=$$ POLICY^IBC EF(IBXIEN, 2,$E("PST" ,Z)) K IBX DATA S C=$ $OTHINS1^I BCEF2(IBXI EN) F Z=1, 2 I $G(IBZ (Z))'="",$ E(C,Z) D . S IBZOUT( Z)=IBZ(+$E (C,Z)) Q ; Input : ; IBXIEN - i en in #399 ; IBP - # piece in address st ring : STR LINE1|STR LINE2|CIT Y|STATE|ZI P ;Output: ; IBARR - output ar ray m by r eferenceEL MADD2(IBXI EN,IBP,IBA RR) ; N IB ZZZ,A,CHEC K,IB1 I '$ D(IBXSAVE( "OTH_INSUR ED_ADDR")) D OTHADD2 (IBXIEN,.I BZZZ) M IB XSAVE("OTH _INSURED_A DDR")=IBZZ Z S IB1=0 F S IB1=$ O(IBXSAVE( "OTH_INSUR ED_ADDR",I B1)) Q:'IB 1 D . ;IF ANY PORTI ON OF ADDR ESS IS NUL L SET CHEC K VALUE, E RASE ENTRY . S CHECK =0 . F A=1 ,3,4,5 I $ P(IBXSAVE( "OTH_INSUR ED_ADDR",I B1),"|",A) ="" S CHEC K=1 K IBXS AVE("OTH_I NSURED_ADD R",IB1) Q . I 'CHECK D . . I I BP=0 S IBA RR(IB1)=$G (IBXSAVE(" OTH_INSURE D_ADDR",IB 1)) Q . . S IBARR(IB 1)=$P($G(I BXSAVE("OT H_INSURED_ ADDR",IB1) ),"|",IBP) Q ;create s an array with addr ess info f or all oth er insured persons ; Input : ; IBXIEN - i en in #399 ;Output: ; IBZOUT(Z ) - array with STR L INE1|STR L INE2|CITY| STATE|ZIP OTHADD2(IB XIEN,IBZOU T) ; N C,Z ,Z0,Z1,IBZ ,IBZIP,IB1 ,IBDFN1 S IBZOUT="" D OTHP36^I BCEF72(IBX IEN,.IBZ) ;array wit h iens of file #36 K IBXDATA S C=$$OTHIN S1^IBCEF2( IBXIEN) F Z=1,2 I $G (IBZ(Z))'= "",$E(C,Z) D . S IBI NS=+IBZ(+$ E(C,Z)) . S IBDFN1=$ P($G(^DGCR (399,IBXIE N,0)),"^", 2) . S IBZ OUT(Z)=$$F R2PAT(IBDF N1,IBINS) Q ;Input: ; IBDFN-pa tient ien ; IBINS - input arra y with ins urance poi nters to 3 6 ;Output ; STR LIN E1|STR LIN E2|CITY|ST ATE|ZIPFR2 PAT(IBDFN, IBINS) ;in formation about "oth er insured " address N Z3,Z4,Z5 ,IBZIP S Z 3=$O(^DPT( IBDFN,.312 ,"B",$G(IB INS),0)) Q :+Z3=0 "|| ||" S Z4=$ G(^DPT(IBD FN,.312,Z3 ,3)) S IBZ IP=$P($G(^ DIC(5,+$P( Z4,"^",9), 0)),"^",2) S Z5=$P(Z 4,"^",6,8) _"^"_IBZIP _"^"_$P(Z4 ,"^",10) Q $TR(Z5,"^ ","|") ; ; Input : ; IBXIEN - i en in #399 ; IBP - # piece in address st ring : STR LINE1|STR LINE2|CIT Y|STATE|ZI P ; if IBP =0 then re turns whol e string ; Output: ; IBARR - ou tput array m by refe renceELMAD DR(IBXIEN, IBP,IBARR) ; N IB1,A ,CHECK D:' $D(IBXSAVE ("OTH_PROV _ADDR")) O THADDR(IBX IEN) S IB1 =0 F S IB 1=$O(IBXSA VE("OTH_PR OV_ADDR",I B1)) Q:'IB 1 D . S C HECK=0 . ; EXCLUDE AD D LINE 2 S ECOND PC S INCE IT'S OK FOR THA T TO BE EM PTY . F A= 1,3,4,5 I $P(IBXSAVE ("OTH_PROV _ADDR",IB1 ),"|",A)=" " D Q . . ;IF ANY P ORTION OF ADDRESS IS NULL SET CHECK VALU E, ERASE E NTRY . . S CHECK=1 K IBXSAVE(" OTH_PROV_A DDR",IB1) . I 'CHECK D . . I I BP=0 S IBA RR(IB1)=$G (IBXSAVE(" OTH_PROV_A DDR",IB1)) Q . . S I BARR(IB1)= $P($G(IBXS AVE("OTH_P ROV_ADDR", IB1)),"|", IBP) Q ; ; creates an array wit h address info for a ll insuran ces ;Input : ; IBXIE N - ien in #399 ;Out put: ; IBX SAVE("OTH_ PROV_ADDR" ,Z) OTHADD R(IBXIEN) ; N C,Z,Z0 ,Z1,IBZ,IB ZIP,IB1,IB INS D F^IB CEF("N-OTH INSURANCE CO IEN 36 ") ;array with iens of file #3 6 M IBZ=IB XDATA K IB XDATA S C= $$OTHINS1^ IBCEF2(IBX IEN) F Z=1 ,2 I $G(IB Z(Z))'="", $E(C,Z) D . S IBINS= +IBZ(+$E(C ,Z)) . S I BZIP=$P($G (^DIC(5,+$ P($G(^DIC( 36,IBINS,. 11)),"^",5 ),0)),"^", 2) . S IB1 =$P($G(^DI C(36,IBINS ,.11)),"^" ,1,2)_"^"_ $P($G(^DIC (36,IBINS, .11)),"^", 4)_"^"_IBZ IP_"^"_$P( $G(^DIC(36 ,IBINS,.11 )),"^",6) . S IBXSAV E("OTH_PRO V_ADDR",Z) =$TR(IB1," ^","|") Q ; ;Retriev es pointer to get in fo about t he service provider ;IBIEN399 - ien in # 399 ;IBFUN C -functio n (3-RENDE RING,etc) ;Output: V ARIABLE PO INTER (PTR ;file_root )PROVPTR(I BIEN399,IB FUNC) ; ;* 432/TAZ - No longer used for I BXSAVE arr ay setup N IBN S IBN =$O(^DGCR( 399,IBIEN3 99,"PRV"," B",IBFUNC, 0)) I +IBN =0 Q 0 Q $ P($G(^DGCR (399,IBIEN 399,"PRV", +IBN,0))," ^",2) ; ;R etrieves S SN from #2 00 ;IBPTR- VARIABLE POINTER to #200PROVS SN(IBIEN39 9) ; N IBR ETVAL S IB RETVAL="" N IBPTR,IB FT F IBFT= 1:1:9 D . S IBPTR=$$ PROVPTR(IB IEN399,IBF T) . S $P( IBRETVAL," ^",IBFT)=$ $GETSSN^IB CEF72(IBPT R) Q IBRET VAL ; ;Inp ut: ; IBPT R- ptr to ^VA(200 or ^IBA(355. 93 ;Output : ; SSN or nullGETNM EL(IBFULL, IBEL) ;Get name elem ent D NAME COMP^XLFNA ME(.IBFULL ) Q $G(IBF ULL(IBEL)) ;- ;PROVI DER ;Input : ; IB399 - ien of # 399 ; IBPR OV: ; "C"- to get in fo for CUR RENT provi der ; "O"- to get in fo for all others (i n this cas e the arra y will con tain info fot two pr oviders ; IBRES - ar ray for re sults (by reference) ; ;Output : ; IBRES - array to get back info (by r eference) ; IBRES(IB PROV,PRNUM ,PRTYPE,SE Q#)=PROV^I NSUR^IDTYP E^ID^FORMT YP^CARETYP ; where: ; IBPROV - see input parameter ; PRNUM: 1=primary insurance provider, 2= seconda ry, 3 -tre tiary ; PR TYPE: Prov ider type( FUNCTION) ; SEQ# : sequence n umber (1st is used f or ID1, 2n d - for ID 2, etc) ; PROV : pro vider/VARI ABLEPTR ; INSUR: Ins urance PTR #36 or NO NE ; IDTYP E: ID type ; ID: ID ; FORMTYP : Form typ e 1=UB,2=1 500 ; CARE TYP: Care type 0=bot h inp/outp ,1=inpatie nt, 2=outp atientPROV IDER(IB399 ,IBPROV,IB RES) ; N I BCURR,IBZ, IBRESARR S IBRESARR= "" S IBCUR R=$$COB^IB CEF(IB399) ;current bill payer sequence Q:IBPROV=" A" ;PATIE NT's bill I IBPROV=" C" D . D:$ $ISINSUR^I BCEF71(IBC URR,IB399) PROVINF(I B399,$S(IB CURR="T":3 ,IBCURR="S ":2,IBCURR ="P":1,1:1 ),.IBRESAR R,1,IBPROV ) I IBPROV ="O" D . I IBCURR="P " D:$$ISIN SUR^IBCEF7 1("S",IB39 9) PROVINF (IB399,2,. IBRESARR,1 ,IBPROV) D :$$ISINSUR ^IBCEF71(" T",IB399) PROVINF(IB 399,3,.IBR ESARR,2,IB PROV) . I IBCURR="S" D:$$ISINS UR^IBCEF71 ("P",IB399 ) PROVINF( IB399,1,.I BRESARR,1, IBPROV) D: $$ISINSUR^ IBCEF71("T ",IB399) P ROVINF(IB3 99,3,.IBRE SARR,2,IBP ROV) . I I BCURR="T" D:$$ISINSU R^IBCEF71( "P",IB399) PROVINF(I B399,1,.IB RESARR,1,I BPROV) D:$ $ISINSUR^I BCEF71("S" ,IB399) PR OVINF(IB39 9,2,.IBRES ARR,2,IBPR OV) M IBRE S(IBPROV)= IBRESARR Q ;PROVINF( IB399,IBPR NUM,IBRES, IBSORT,IBI NSTP) ; D PROVINF^IB CEF74(IB39 9,IBPRNUM, .IBRES,IBS ORT,IBINST P) Q ;PSPR V(IBIFN) ; Returns i nformation for bill ien IBIFN for purcha sed svc ; Returns 4 digit dat a in follo wing forma t: ; 1st d igit: 0 if not outsi de facilit y ; 1 if o utside fac ility ; 2n d digit: 0 if not no n-VA provi der for re ndering/at tending ; 1 if non-V A provider for rende ring/atten ding ; 3rd digit: 0 if not pur chased svc ; 1 if pu rchased sv c ; 4th di git: 0 if 1500 bill ; 1 if UB bill N IBS VC,Z,Z0,IB U2 S IBSVC ="000"_+$$ INSFT^IBCE U5(IBIFN), IBU2=$G(^D GCR(399,IB IFN,"U2")) I $P(IBU2 ,U,10) S $ E(IBSVC,1) =1 ; NON-V A FACILITY S Z=($$FT ^IBCEF(IBI FN)=3)+3,Z 0=+$O(^DGC R(399,IBIF N,"PRV","B ",Z,0)) I $P($G(^DGC R(399,IBIF N,"PRV",Z0 ,0)),U,2)[ "IBA(355.9 3" S $E(IB SVC,2)=1 I $P(IBU2,U ,11)>0,$P( IBU2,U,11) '>2 S $E(I BSVC,3)=1P SPRVQ Q IB SVC ;CHKAD D ;CHECK A LL ADDRESS ELEMENTS PRESENT IF NOT KILL ALL ADDRES S ELEMENTS ;EXPECT I BXSAVE("CA DR") AS SO URCE ARRAY N Z,CHECK S Z="",CH ECK=0 F Z= 1,4,5,6 D . I $P($G( IBXSAVE("C ADR")),"^" ,Z)="" S C HECK=1 I C HECK=1 S I BXSAVE("CA DR")="" Q ; | |
| 1314 | ||
| 1315 | Routines | |
| 1316 | Activities | |
| 1317 | Routine Na me | |
| 1318 | IBCEF71 | |
| 1319 | Enhancemen t Category | |
| 1320 | New | |
| 1321 | Modify | |
| 1322 | Delete | |
| 1323 | No Change | |
| 1324 | RTM | |
| 1325 | ||
| 1326 | Related Op tions | |
| 1327 | None | |
| 1328 | Related Ro utines | |
| 1329 | Routines “ Called By” | |
| 1330 | Routines “ Called” | |
| 1331 | ||
| 1332 | ||
| 1333 | ||
| 1334 | ||
| 1335 | Data Dicti onary (DD) Reference s | |
| 1336 | ||
| 1337 | Related Pr otocols | |
| 1338 | None | |
| 1339 | Related In tegration Control Re gistration s (ICRs) | |
| 1340 | None | |
| 1341 | Data Passi ng | |
| 1342 | Input | |
| 1343 | Output Re ference | |
| 1344 | Both | |
| 1345 | Global Re ference | |
| 1346 | Local | |
| 1347 | Input Attr ibute Name and Defin ition | |
| 1348 | Name: | |
| 1349 | Definition : | |
| 1350 | Output Att ribute Nam e and Defi nition | |
| 1351 | Name: | |
| 1352 | Definition : | |
| 1353 | Current Lo gic | |
| 1354 | IBCEF71 ;W OIFO/SS - FORMATTER AND EXTRAC TOR SPECIF IC BILL FU NCTIONS ;3 1-JUL-03 ; ;2.0;INTEG RATED BILL ING;**232, 155,288,32 0,349,432* *;21-MAR-9 4;Build 19 2 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; ;-------- - ;OTHPAYC - from FO RMAT code for OP1,OP 2 ... ;Inp ut: ;IBXIE N - ien #3 99 ;IBSAVE - "in" ar ray (i.e. IBXSAVE) ; IBDATA - " out" array (i.e. IBX DATA) ;IBF UNC - FUNC TION from #399 (1-re fering,2-o perating,e tc) ;IBVAL - output value ;Out put: ; IBD ATA with f ormatted o utputOTHPA YC(IBXIEN, IBSAVE,IBD ATA,IBFUNC ,IBVAL) ; N IB1,IB2, IBINS,IBFL S IBFL=$S (IBFUNC=3! (IBFUNC=4) :1,1:0) F IB1=1,2 D . I $$ISIN SUR($G(IBS AVE("PROVI NF",IBXIEN ,"O",IB1)) ,IBXIEN) D Q ;don' t create a nything if no such i nsurance . . ;*432/TA Z Attendin g/Renderin g is no lo nger eithe r/or so th ere can be both .. ; I IBFL S I BFUNC=$S($ O(IBSAVE(" PROVINF",I BXIEN,"O", IB1,3,0)): 3,1:4) .. S:$O(IBSAV E("PROVINF ",IBXIEN," O",IB1,IBF UNC,0)) IB DATA(IB1)= IBVAL Q ;- --- ;OTHPA YV - calle d from FOR MAT code f or OP1,OP2 ... ;Inpu t: ;IBXIEN - ien #39 9 ;IBSAVE - "in" arr ay (i.e. I BXSAVE) ;I BDATA - "o ut" array (i.e. IBXD ATA) ;IBFU NC - FUNCT ION from # 399 (1-ref ering, 2-o perating, etc) ;IBSE QN - seq # of ID/QUA L ;IBFLDTY P ; "I" - ID "Q" - I D QUAL ;Ou tput: ; IB DATA with formatted outputOTHP AYV(IBXIEN ,IBSAVE,IB DATA,IBFUN C,IBFLDTYP ,IBSEQN) ; N IB1,IB2 ,IBPIECE,I BINS,IBFL S IBFL=$S( IBFUNC=3!( IBFUNC=4): 1,1:0) S I BPIECE=$S( IBFLDTYP=" I":4,IBFLD TYP="Q":3, 1:3) F IB1 =1,2 D . I $$ISINSUR ($G(IBSAVE ("PROVINF" ,IBXIEN,"O ",IB1)),IB XIEN) D Q ;don't c reate anyt hing if th ere is no such insur ance .. ;* 432/TAZ At tending/Re ndering is no longer either/or so there can be bot h .. ;I IB FL S IBFUN C=$S($O(IB SAVE("PROV INF",IBXIE N,"O",IB1, 3,0)):3,1: 4),IBFL=0 .. S IBDAT A(IB1)=$P( $G(IBSAVE( "PROVINF", IBXIEN,"O" ,IB1,IBFUN C,IBSEQN)) ,U,IBPIECE ) Q ; ;chk for ins ; Input: ; I BINS = "P" ,"S","T" ; IBXIEN - ien file # 399 ;Outpu t: ; retur ns 1-exist s , 0-does n'tISINSUR (IBINS,IBX IEN) ; N I BINSNOD S IBINSNOD=$ S(IBINS="P ":"I1",IBI NS="S":"I2 ",IBINS="T ":"I3",1:" ") I IBINS NOD="" Q 0 Q $D(^DGC R(399,IBXI EN,IBINSNO D)) ; ;--- PRACT---- ;Get list of all 355 .9 or 355. 93 records for prov ;Input: ; IB399INS - ins co fo r bill to match PRAC TIONER fro m 355.9 ;I B399FRM - form type (0=unknwn/ both,1=UB, 2=1500) to ; match PRACTIONER from 355. 9 ;IB399CA R - BILL C ARE (0=unk nwn or bot h inp/outp ,1=inpatie nt, ; 2=ou tpatient/3 =Rx) to ma tch PROV f rom 355.9 ; OR - DIV ISION PTR to file 40 .8 for ent ries in fi le 355.92 ;IBPROV - VARIABLE P TR VA prov ;IBARR - array by r eference f or result ;IBPROVTP- function (2-operati ng, 3-REND ERING,etc 0-facility ) ;IBINSTP - "C" -cu rrent ins , "O"-othe r ;IBFILE - 355.92 f or facilit y ids or 3 55.9 (defa ult) for p rovider id s ;IBINS - 1 if to i nclude ids for the i ns co for all provs ;Ouput: ;I BARR - arr ay by ref for result ; prov va r ptr^ins ptr^X12 id cd^ID^for m typ^care typ or di vision ptr ^st ptr^id rec ptr^i d type ptr PRACT(IB39 9INS,IB399 FRM,IB399C AR,IBPROV, IBARR,IBPR OVTP,IBINS TP,IBFILE, IBINS) ; N IB1,IB2,I BDAT,IBF,I BFX,IB3559 ,IBINSCO,I BFRMTYP,IB IDTYP,IBID ,IBIDT,IBD IV,IBQ,IBS 1,IBS2,IBA RRX,Z,Z1,Z 2,IBCARE I $G(IBFILE )="" S IBF ILE=355.9 S IBINS=$G (IBINS) S (IBARR,IB3 559,IB1)=0 F IBF="", 1 Q:IBF=1& $S(IBFILE' =355.9:1,1 :'IBINS) S IBFX=IBFI LE_IBF F I B2=1:1 S I B3559=$O(^ IBA(IBFX," B",$S(IBFI LE=355.9&( IBF=""):IB PROV,1:IB3 99INS),IB3 559)) Q:IB 3559="" D . S IBINS CO=$P($G(^ IBA(IBFX,I B3559,0)), "^",$S(IBF ILE=355.9& (IBF=""):2 ,1:1)) ;in s co. ptr . I IBINSC O'="" I IB INSCO'=IB3 99INS Q ; exclude if different ins . S:I BINSCO="" IBINSCO="N ONE" ;NONE will be i ncluded in the array . S IBFRM TYP=+$P($G (^IBA(IBFX ,IB3559,0) ),"^",4) ; form type (0=both,1= UB,2=1500) . I '(IBF RMTYP=0!(I B399FRM=0) ) Q:IBFRMT YP'=IB399F RM ;exclu de if not "both" and different . S IBCAR E=+$P($G(^ IBA(IBFX,I B3559,0)), "^",5) ;0= both(inp a nd outp),1 =inp,2=out p,3=prescr -- OR -- division p tr . I $S( IBFILE=355 .92:0,1:IB CARE=3) I IB399CAR'= 3 Q ; Id is only fo r Rx . I $ S(IBFILE=3 55.92:0,1: IBCARE=1!( IBCARE=2)) I IB399CA R=1!(IB399 CAR=2) Q:I BCARE'=IB3 99CAR ;bo th is OK . I IBFILE= 355.92,IBC ARE Q:IB39 9CAR'=IBCA RE ; Divi sion doesn 't match . S IBIDTYP =+$P($G(^I BA(IBFX,IB 3559,0))," ^",6) ;pro v ID type . I IBFILE =355.9,IBI DTYP=$$TAX ID^IBCEP8( ),$S(IBPRO V["VA(200" :1,1:$P($G (^IBA(355. 93,+IBPROV ,0)),U,2)= 2) Q ; Do n't extrac t tax id # id for in div prov . S IBIDT=I BIDTYP . S IBIDTYP=$ P($G(^IBE( 355.97,IBI DTYP,0))," ^",3) . Q: $P($G(^IBE (355.97,+I BIDT,1)),U ,9) . Q:IB FILE=355.9 &(IBIDTYP= "X4") ;exc lude CLIA # . S IBID =$P($G(^IB A(IBFX,IB3 559,0)),"^ ",7) ;prov ID value . I $G(IBP ROVTP)'="" ,$G(IBINST P)'="",IBP ROVTP'=0 I '$$CHCKSE C^IBCEF73( IB399FRM,I BPROVTP,IB INSTP,IBID TYP) Q ; No qualifi er chk for fac . I I BID'="" S IBDAT=IBPR OV_"^"_IBI NSCO_"^"_I BIDTYP_"^" _IBID_"^"_ IBFRMTYP_" ^"_IBCARE_ "^"_"^"_IB 3559_U_IBI DT,IBS2=$S (IBFX'=355 .91:"",1:" INS DEF^") _IB3559 . I IBFILE'= 355.92,IBI D'="",IB39 9CAR=3 S I BQ=0 D Q: IBQ .. I $ G(IBARRX(I BIDT))!(IB CARE=1) S IBQ=1 Q .. I IBCARE= 3&(IB399CA R=3) S IBA RRX(IBIDT) =1 Q ; Rx match .. I IBCARE=0 !(IBCARE=2 ) S IBARRX (IBIDT,IBI NSCO,IBS2) =IBDAT,IBQ =1 Q . I I BID'="" S IBARR(IBIN SCO,IBS2)= IBDAT ; I IB399CAR=3 S Z=0 F S Z=$O(IBA RRX(Z)) Q: 'Z I '$G( IBARRX(Z)) D . S Z1= "" F S Z1 =$O(IBARRX (Z,Z1)) Q: Z1="" S Z 2="" F S Z2=$O(IBAR RX(Z,Z1,Z2 )) Q:Z2="" S IBARR( Z1,Z2)=IBA RRX(Z,Z1,Z 2) ; I IBP ROV["VA(20 0," D ; G et lic #s from file 2 for VA p roviders . N Z,IBLIC . S IBLIC =+IBPROV,I BLIC=$$GET LIC^IBCEP5 D(.IBLIC) . S IBIDTY P=$P($G(^I BE(355.97, +$$STLIC^I BCEP8(),0) ),U,3) . S Z=0 F S Z=$O(IBLIC (Z)) Q:'Z S:$$CHCKS EC^IBCEF73 (IB399FRM, IBPROVTP,I BINSTP,IBI DTYP) IBAR R("NONE"," LIC"_Z_"^" _IBPROV)=I BPROV_U_"N ONE"_U_IBI DTYP_U_IBL IC(Z)_U_"0 "_U_"0"_U_ Z_U_U_+$$S TLIC^IBCEP 8() I IBPR OV["IBA(35 5.93" D . Q:$P($G(^I BA(355.93, +IBPROV,0) ),U,12)="" . S IBIDT YP=$P($G(^ IBE(355.97 ,+$$STLIC^ IBCEP8(),0 )),U,3) . I $$CHCKSE C^IBCEF73( IB399FRM,I BPROVTP,IB INSTP,IBID TYP) D . . S IBARR(" NONE","LIC "_$P($G(^D IC(5,+$P(^ IBA(355.93 ,+IBPROV,0 ),U,7),0)) ,U,2)_"^"_ IBPROV)=IB PROV_U_"NO NE"_U_IBID TYP_U_$P(^ IBA(355.93 ,+IBPROV,0 ),U,12)_U_ "0"_U_"0"_ U_$P(^IBA( 355.93,+IB PROV,0),U, 7)_U_U_+IB PROV Q ;AL LPRFAC(IBX IEN,IBXSAV E) ; Retur n all non- VA/outside facility prov ids ; and all V A alternat e prov ids ; IBXIEN = ien file 399 ; IBX SAVE = sub scripted a rray retur ned N IBPR OV,IBFRMTY P,IBCARE,I BRETARR,IB RET1,IBCOB N,Z,Z0,Z1, ZZ K IBXSA VE("PROVIN F_FAC",IBX IEN) ; Alw ays rebuil d this S I BCOBN=+$$C OBN^IBCEF( IBXIEN) S IBFRMTYP=$ $FT^IBCEF( IBXIEN),IB FRMTYP=$S( IBFRMTYP=2 :2,IBFRMTY P=3:1,1:0) S IBPROV= $P($G(^DGC R(399,IBXI EN,"U2")), U,10) ; IB patch 320 - Build I BPROV vari able bette r when a n on-VA faci lity exist s I IBPROV S IBPROV= IBPROV_";I BA(355.93, " I 'IBPRO V S IBCARE =$P($G(^DG CR(399,IBX IEN,0)),U, 22) I IBPR OV D . S I BCARE=$S($ $ISRX^IBCE F1(IBXIEN) :3,1:0) ;i f Rx refil l bill . S :IBCARE=0 IBCARE=$$I NPAT^IBCEF (IBXIEN,1) S:'IBCARE IBCARE=2 ;1-inp, 2- out F Z=1: 1:3 K IBRE TARR I $G( ^DGCR(399, IBXIEN,"I" _Z)) D . D PRACT(+^D GCR(399,IB XIEN,"I"_Z ),IBFRMTYP ,IBCARE,IB PROV,.IBRE TARR,0,$S( Z=IBCOBN:" C",1:"O"), $S('IBPROV :355.92,1: 355.9)) . K IBRET1 . S Z0="" F S Z0=$O( IBRETARR(Z 0)) Q:Z0=" " S Z1="" F S Z1=$ O(IBRETARR (Z0,Z1)) Q :Z1="" D .. ; Sort by div/id type .. S IBRET1($S( IBPROV:0,1 :+$P(IBRET ARR(Z0,Z1) ,U,6)),+$P (IBRETARR( Z0,Z1),U,9 ))=IBRETAR R(Z0,Z1) . . Q . ; . S Z0=$O(IB RET1(""),- 1) Q:Z0="" D .. ; I B patch 32 0 - loop t hru all ID 's .. S Z1 ="" F S Z 1=$O(IBRET 1(Z0,Z1)) Q:Z1="" D ... I Z=I BCOBN S IB XSAVE("PRO VINF_FAC", IBXIEN,"C" ,1,0,$O(IB XSAVE("PRO VINF_FAC", IBXIEN,"C" ,1,0," "), -1)+1)=IBR ET1(Z0,Z1) Q ... S Z Z=$S(Z=1:1 ,Z=2:(IBCO BN=3)+1,1: 2) ... S I BXSAVE("PR OVINF_FAC" ,IBXIEN,"O ",ZZ,0,$O( IBXSAVE("P ROVINF_FAC ",IBXIEN," O",ZZ,0," "),-1)+1)= IBRET1(Z0, Z1),IBXSAV E("PROVINF _FAC",IBXI EN,"O",ZZ) =$E("PST", Z) ... Q . . Q . Q ; S IBXSAVE( "PROVINF_F AC",IBXIEN )=IBXIEN,I BXSAVE("PR OVINF_FAC" ,IBXIEN,"C ",1)=$E("P ST",IBCOBN ) Q ;OTHID (IBXSAVE,I BXDATA,IBX IEN,PRIDSE Q,PRTYP,IB Q,IBFAC) ; From data in IBXSAV E, ; deter mine id or qualifier to output in the 83 7 records OP* ; Retu rns IBXDAT A array IB XDATA(n)=d ata ; IBXI EN = ien o f the bill -file 399 ; PRIDSEQ = sequence of the pa yer id nee ded ; PRTY P = provid er type to check for data ; IB Q = 1 if q ualifier n eeded, 0/n ull if id needed ; I BFAC = 1 i f facility id, 0 for individua l provider id ; N Z ,Z0,Z1 S Z 0="PROVINF "_$S('$G(I BFAC):"",1 :"_FAC"),Z 1=$S($G(IB Q):3,1:4) S Z=0 F S Z=$O(IBXS AVE("OSQ", Z)) Q:'Z D . I $P($ G(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),+$G (PRIDSEQ)) ),U,4)'="" S IBXDATA (IBXSAVE(" OSQ",Z))=$ P(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),+$G (PRIDSEQ)) ,U,Z1) Q ; SETSEQ(IBX IEN,IBXSAV E,IBXDATA, PRTYP,IBFA C,IBOP) ; Sets up IB XSAVE("OSQ ") ; array for other id seq in 837 recor ds OP* ; R eturns IBX DATA(n)=co b seq indi cator for ids ; IBXI EN = ien o f bill-399 ; PRTYP = the provi der type t o check fo r data for indiv pro vider ; IB FAC = 1 if facility id, 0 for individual provider id ; IBOP = segement # in OP b eing outpu t N C,Z,Z0 ,Z1,OK S C =0,Z0="PRO VINF"_$S(' $G(IBFAC): "",1:"_FAC ") S:$G(IB FAC) PRTYP =0 S Z=0 F S Z=$O(I BXSAVE(Z0, IBXIEN,"O" ,Z)) Q:'Z S OK=0 D . N Z1 F Z 1=1:1 Q:'$ D(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),Z1) ) I $P(IBX SAVE(Z0,IB XIEN,"O",Z ,+$G(PRTYP ),Z1),U,4) '="""" S O K=1 Q . I OK S C=C+1 ,IBXSAVE(" OSQ",Z)=C S Z=0 F S Z=$O(IBXS AVE("OSQ", Z)) Q:'Z S IBXDATA( IBXSAVE("O SQ",Z))=$G (IBXSAVE(Z 0,IBXIEN," O",Z)) D:I BXSAVE("OS Q",Z)>1 ID ^IBCEF2(IB XSAVE("OSQ ",Z),"OP"_ $G(IBOP)_" ") Q ;PSP RV(IBIFN) ; Q $$PSPR V^IBCEF7(I BIFN) ; Mo ved ; | |
| 1355 | Modified L ogic (Chan ges are in bold) | |
| 1356 | IBCEF71 ;W OIFO/SS - FORMATTER AND EXTRAC TOR SPECIF IC BILL FU NCTIONS ;3 1-JUL-03 ; ;2.0;INTEG RATED BILL ING;**232, 155,288,32 0,349,432, 592**;21-M AR-94;Buil d 192 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ; ;---- ----- ;OTH PAYC - fro m FORMAT c ode for OP 1,OP2 ... ;Input: ;I BXIEN - ie n #399 ;IB SAVE - "in " array (i .e. IBXSAV E) ;IBDATA - "out" a rray (i.e. IBXDATA) ;IBFUNC - FUNCTION f rom #399 ( 1-refering ,2-operati ng,etc) ;I BVAL - out put value ;Output: ; IBDATA wi th formatt ed outputO THPAYC(IBX IEN,IBSAVE ,IBDATA,IB FUNC,IBVAL ) ; N IB1, IB2,IBINS, IBFL S IBF L=$S(IBFUN C=3!(IBFUN C=4):1,1:0 ) F IB1=1, 2 D . I $$ ISINSUR($G (IBSAVE("P ROVINF",IB XIEN,"O",I B1)),IBXIE N) D Q ; don't crea te anythin g if no su ch insuran ce .. ;*43 2/TAZ Atte nding/Rend ering is n o longer e ither/or s o there ca n be both .. ;I IBFL S IBFUNC= $S($O(IBSA VE("PROVIN F",IBXIEN, "O",IB1,3, 0)):3,1:4) .. S:$O(I BSAVE("PRO VINF",IBXI EN,"O",IB1 ,IBFUNC,0) ) IBDATA(I B1)=IBVAL Q ;---- ;O THPAYV - c alled from FORMAT co de for OP1 ,OP2 ... ; Input: ;IB XIEN - ien #399 ;IBS AVE - "in" array (i. e. IBXSAVE ) ;IBDATA - "out" ar ray (i.e. IBXDATA) ; IBFUNC - F UNCTION fr om #399 (1 -refering, 2-operati ng, etc) ; IBSEQN - s eq # of ID /QUAL ;IBF LDTYP ; "I " - ID "Q" - ID QUAL ;Output: ; IBDATA w ith format ted output OTHPAYV(IB XIEN,IBSAV E,IBDATA,I BFUNC,IBFL DTYP,IBSEQ N) ; N IB1 ,IB2,IBPIE CE,IBINS,I BFL S IBFL =$S(IBFUNC =3!(IBFUNC =4):1,1:0) S IBPIECE =$S(IBFLDT YP="I":4,I BFLDTYP="Q ":3,1:3) F IB1=1,2 D . I $$ISI NSUR($G(IB SAVE("PROV INF",IBXIE N,"O",IB1) ),IBXIEN) D Q ;don 't create anything i f there is no such i nsurance . . ;*432/TA Z Attendin g/Renderin g is no lo nger eithe r/or so th ere can be both .. ; I IBFL S I BFUNC=$S($ O(IBSAVE(" PROVINF",I BXIEN,"O", IB1,3,0)): 3,1:4),IBF L=0 .. S I BDATA(IB1) =$P($G(IBS AVE("PROVI NF",IBXIEN ,"O",IB1,I BFUNC,IBSE QN)),U,IBP IECE) Q ; ;chk for i ns ;Input: ; IBINS = "P","S"," T" ; IBXIE N - ien fi le #399 ;O utput: ; r eturns 1-e xists , 0- doesn'tISI NSUR(IBINS ,IBXIEN) ; N IBINSNO D S IBINSN OD=$S(IBIN S="P":"I1" ,IBINS="S" :"I2",IBIN S="T":"I3" ,1:"") I I BINSNOD="" Q 0 Q $D( ^DGCR(399, IBXIEN,IBI NSNOD)) ; ;---PRACT- --- ;Get l ist of all 355.9 or 355.93 rec ords for p rov ;Input : ;IB399I NS - ins c o for bill to match PRACTIONER from 355. 9 ;IB399FR M - form t ype (0=unk nwn/both,1 =UB,2=1500 ) to ; ma tch PRACTI ONER from 355.9 ;IB3 99CAR - BI LL CARE (0 =unknwn or both inp/ outp,1=inp atient, ; 2=outpatie nt/3=Rx) t o match PR OV from 35 5.9 ; OR - DIVISION PTR to fil e 40.8 for entries i n file 355 .92 ;IBPRO V - VARIAB LE PTR VA prov ;IBAR R - array by referen ce for res ult ;IBPRO VTP- funct ion (2-ope rating, 3- RENDERING, etc 0-faci lity) ;IBI NSTP - "C" -current ins , "O"- other ;IBF ILE - 355. 92 for fac ility ids or 355.9 ( default) f or provide r ids ;IBI NS - 1 if to include ids for t he ins co for all pr ovs ;Ouput : ;IBARR - array by ref for re sult ; pro v var ptr^ ins ptr^X1 2 id cd^ID ^form typ^ care typ o r division ptr^st pt r^id rec p tr^id type ptrPRACT( IB399INS,I B399FRM,IB 399CAR,IBP ROV,IBARR, IBPROVTP,I BINSTP,IBF ILE,IBINS) ; N IB1,I B2,IBDAT,I BF,IBFX,IB 3559,IBINS CO,IBFRMTY P,IBIDTYP, IBID,IBIDT ,IBDIV,IBQ ,IBS1,IBS2 ,IBARRX,Z, Z1,Z2,IBCA RE I $G(IB FILE)="" S IBFILE=35 5.9 S IBIN S=$G(IBINS ) S (IBARR ,IB3559,IB 1)=0 F IBF ="",1 Q:IB F=1&$S(IBF ILE'=355.9 :1,1:'IBIN S) S IBFX= IBFILE_IBF F IB2=1:1 S IB3559= $O(^IBA(IB FX,"B",$S( IBFILE=355 .9&(IBF="" ):IBPROV,1 :IB399INS) ,IB3559)) Q:IB3559=" " D . S I BINSCO=$P( $G(^IBA(IB FX,IB3559, 0)),"^",$S (IBFILE=35 5.9&(IBF=" "):2,1:1)) ;ins co. ptr . I IB INSCO'="" I IBINSCO' =IB399INS Q ;exclud e if diffe rent ins . S:IBINSCO ="" IBINSC O="NONE" ; NONE will be include d in the a rray . S I BFRMTYP=+$ P($G(^IBA( IBFX,IB355 9,0)),"^", 4) ;form t ype (0=bot h,1=UB,2=1 500 or 4=J 430D) ;JWS ;JRA IB*2. 0*592 adde d J430D to comment . I '(IBFRM TYP=0!(IB3 99FRM=0)) Q:IBFRMTYP '=IB399FRM ;exclude if not "b oth" and d ifferent . S IBCARE= +$P($G(^IB A(IBFX,IB3 559,0)),"^ ",5) ;0=bo th(inp and outp),1=i np,2=outp, 3=prescr - - OR -- di vision ptr . I $S(IB FILE=355.9 2:0,1:IBCA RE=3) I IB 399CAR'=3 Q ; Id is only for Rx . ;JWS; IB*2.0*592 ;Dental fo rm = 4 in set of cod es value . I $S(IBFI LE=355.92: 0,1:IBCARE =1!(IBCARE =2)!(IBCAR E=4)) I IB 399CAR=1!( IB399CAR=2 ) Q:IBCARE '=IB399CAR ;both is OK . I IB FILE=355.9 2,IBCARE Q :IB399CAR' =IBCARE ; Division doesn't ma tch . S IB IDTYP=+$P( $G(^IBA(IB FX,IB3559, 0)),"^",6) ;prov ID type . I I BFILE=355. 9,IBIDTYP= $$TAXID^IB CEP8(),$S( IBPROV["VA (200":1,1: $P($G(^IBA (355.93,+I BPROV,0)), U,2)=2) Q ; Don't e xtract tax id # id f or indiv p rov . S IB IDT=IBIDTY P . S IBID TYP=$P($G( ^IBE(355.9 7,IBIDTYP, 0)),"^",3) . Q:$P($G (^IBE(355. 97,+IBIDT, 1)),U,9) . Q:IBFILE= 355.9&(IBI DTYP="X4") ;exclude CLIA # . S IBID=$P($ G(^IBA(IBF X,IB3559,0 )),"^",7) ;prov ID v alue . I $ G(IBPROVTP )'="",$G(I BINSTP)'=" ",IBPROVTP '=0 I '$$C HCKSEC^IBC EF73(IB399 FRM,IBPROV TP,IBINSTP ,IBIDTYP) Q ; No qu alifier ch k for fac . I IBID'= "" S IBDAT =IBPROV_"^ "_IBINSCO_ "^"_IBIDTY P_"^"_IBID _"^"_IBFRM TYP_"^"_IB CARE_"^"_" ^"_IB3559_ U_IBIDT,IB S2=$S(IBFX '=355.91:" ",1:"INS D EF^")_IB35 59 . I IBF ILE'=355.9 2,IBID'="" ,IB399CAR= 3 S IBQ=0 D Q:IBQ . . I $G(IBA RRX(IBIDT) )!(IBCARE= 1) S IBQ=1 Q .. I IB CARE=3&(IB 399CAR=3) S IBARRX(I BIDT)=1 Q ; Rx matc h .. ;JWS; IB*2.0*592 ;Dental fo rm .. I IB CARE=0!(IB CARE=2)!(I BCARE=4) S IBARRX(IB IDT,IBINSC O,IBS2)=IB DAT,IBQ=1 Q . I IBID '="" S IBA RR(IBINSCO ,IBS2)=IBD AT ; I IB3 99CAR=3 S Z=0 F S Z =$O(IBARRX (Z)) Q:'Z I '$G(IBA RRX(Z)) D . S Z1="" F S Z1=$O (IBARRX(Z, Z1)) Q:Z1= "" S Z2=" " F S Z2= $O(IBARRX( Z,Z1,Z2)) Q:Z2="" S IBARR(Z1, Z2)=IBARRX (Z,Z1,Z2) ; I IBPROV ["VA(200," D ; Get lic #s fro m file 2 f or VA prov iders . N Z,IBLIC . S IBLIC=+I BPROV,IBLI C=$$GETLIC ^IBCEP5D(. IBLIC) . S IBIDTYP=$ P($G(^IBE( 355.97,+$$ STLIC^IBCE P8(),0)),U ,3) . S Z= 0 F S Z=$ O(IBLIC(Z) ) Q:'Z S: $$CHCKSEC^ IBCEF73(IB 399FRM,IBP ROVTP,IBIN STP,IBIDTY P) IBARR(" NONE","LIC "_Z_"^"_IB PROV)=IBPR OV_U_"NONE "_U_IBIDTY P_U_IBLIC( Z)_U_"0"_U _"0"_U_Z_U _U_+$$STLI C^IBCEP8() I IBPROV[ "IBA(355.9 3" D . Q:$ P($G(^IBA( 355.93,+IB PROV,0)),U ,12)="" . S IBIDTYP= $P($G(^IBE (355.97,+$ $STLIC^IBC EP8(),0)), U,3) . I $ $CHCKSEC^I BCEF73(IB3 99FRM,IBPR OVTP,IBINS TP,IBIDTYP ) D . . S IBARR("NON E","LIC"_$ P($G(^DIC( 5,+$P(^IBA (355.93,+I BPROV,0),U ,7),0)),U, 2)_"^"_IBP ROV)=IBPRO V_U_"NONE" _U_IBIDTYP _U_$P(^IBA (355.93,+I BPROV,0),U ,12)_U_"0" _U_"0"_U_$ P(^IBA(355 .93,+IBPRO V,0),U,7)_ U_U_+IBPRO V Q ;ALLPR FAC(IBXIEN ,IBXSAVE) ; Return a ll non-VA/ outside fa cility pro v ids ; an d all VA a lternate p rov ids ; IBXIEN = i en file 39 9 ; IBXSAV E = subscr ipted arra y returned N IBPROV, IBFRMTYP,I BCARE,IBRE TARR,IBRET 1,IBCOBN,Z ,Z0,Z1,ZZ K IBXSAVE( "PROVINF_F AC",IBXIEN ) ; Always rebuild t his S IBCO BN=+$$COBN ^IBCEF(IBX IEN) ;S IB FRMTYP=$$F T^IBCEF(IB XIEN),IBFR MTYP=$S(IB FRMTYP=2:2 ,IBFRMTYP= 3:1,1:0) ; JRA IB*2.0 *592 ';' S IBFRMTYP= $$FT^IBCEF (IBXIEN),I BFRMTYP=$S (IBFRMTYP= 2:2,IBFRMT YP=7:4,IBF RMTYP=3:1, 1:0) ;JRA IB*2.0*592 S IBPROV= $P($G(^DGC R(399,IBXI EN,"U2")), U,10) ; IB patch 320 - Build I BPROV vari able bette r when a n on-VA faci lity exist s I IBPROV S IBPROV= IBPROV_";I BA(355.93, " I 'IBPRO V S IBCARE =$P($G(^DG CR(399,IBX IEN,0)),U, 22) I IBPR OV D . S I BCARE=$S($ $ISRX^IBCE F1(IBXIEN) :3,1:0) ;i f Rx refil l bill . S :IBCARE=0 IBCARE=$$I NPAT^IBCEF (IBXIEN,1) S:'IBCARE IBCARE=2 ;1-inp, 2- out F Z=1: 1:3 K IBRE TARR I $G( ^DGCR(399, IBXIEN,"I" _Z)) D . D PRACT(+^D GCR(399,IB XIEN,"I"_Z ),IBFRMTYP ,IBCARE,IB PROV,.IBRE TARR,0,$S( Z=IBCOBN:" C",1:"O"), $S('IBPROV :355.92,1: 355.9)) . K IBRET1 . S Z0="" F S Z0=$O( IBRETARR(Z 0)) Q:Z0=" " S Z1="" F S Z1=$ O(IBRETARR (Z0,Z1)) Q :Z1="" D .. ; Sort by div/id type .. S IBRET1($S( IBPROV:0,1 :+$P(IBRET ARR(Z0,Z1) ,U,6)),+$P (IBRETARR( Z0,Z1),U,9 ))=IBRETAR R(Z0,Z1) . . Q . ; . S Z0=$O(IB RET1(""),- 1) Q:Z0="" D .. ; I B patch 32 0 - loop t hru all ID 's .. S Z1 ="" F S Z 1=$O(IBRET 1(Z0,Z1)) Q:Z1="" D ... I Z=I BCOBN S IB XSAVE("PRO VINF_FAC", IBXIEN,"C" ,1,0,$O(IB XSAVE("PRO VINF_FAC", IBXIEN,"C" ,1,0," "), -1)+1)=IBR ET1(Z0,Z1) Q ... S Z Z=$S(Z=1:1 ,Z=2:(IBCO BN=3)+1,1: 2) ... S I BXSAVE("PR OVINF_FAC" ,IBXIEN,"O ",ZZ,0,$O( IBXSAVE("P ROVINF_FAC ",IBXIEN," O",ZZ,0," "),-1)+1)= IBRET1(Z0, Z1),IBXSAV E("PROVINF _FAC",IBXI EN,"O",ZZ) =$E("PST", Z) ... Q . . Q . Q ; S IBXSAVE( "PROVINF_F AC",IBXIEN )=IBXIEN,I BXSAVE("PR OVINF_FAC" ,IBXIEN,"C ",1)=$E("P ST",IBCOBN ) Q ;OTHID (IBXSAVE,I BXDATA,IBX IEN,PRIDSE Q,PRTYP,IB Q,IBFAC) ; From data in IBXSAV E, ; deter mine id or qualifier to output in the 83 7 records OP* ; Retu rns IBXDAT A array IB XDATA(n)=d ata ; IBXI EN = ien o f the bill -file 399 ; PRIDSEQ = sequence of the pa yer id nee ded ; PRTY P = provid er type to check for data ; IB Q = 1 if q ualifier n eeded, 0/n ull if id needed ; I BFAC = 1 i f facility id, 0 for individua l provider id ; N Z ,Z0,Z1 S Z 0="PROVINF "_$S('$G(I BFAC):"",1 :"_FAC"),Z 1=$S($G(IB Q):3,1:4) S Z=0 F S Z=$O(IBXS AVE("OSQ", Z)) Q:'Z D . I $P($ G(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),+$G (PRIDSEQ)) ),U,4)'="" S IBXDATA (IBXSAVE(" OSQ",Z))=$ P(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),+$G (PRIDSEQ)) ,U,Z1) Q ; SETSEQ(IBX IEN,IBXSAV E,IBXDATA, PRTYP,IBFA C,IBOP) ; Sets up IB XSAVE("OSQ ") ; array for other id seq in 837 recor ds OP* ; R eturns IBX DATA(n)=co b seq indi cator for ids ; IBXI EN = ien o f bill-399 ; PRTYP = the provi der type t o check fo r data for indiv pro vider ; IB FAC = 1 if facility id, 0 for individual provider id ; IBOP = segement # in OP b eing outpu t N C,Z,Z0 ,Z1,OK S C =0,Z0="PRO VINF"_$S(' $G(IBFAC): "",1:"_FAC ") S:$G(IB FAC) PRTYP =0 S Z=0 F S Z=$O(I BXSAVE(Z0, IBXIEN,"O" ,Z)) Q:'Z S OK=0 D . N Z1 F Z 1=1:1 Q:'$ D(IBXSAVE( Z0,IBXIEN, "O",Z,+$G( PRTYP),Z1) ) I $P(IBX SAVE(Z0,IB XIEN,"O",Z ,+$G(PRTYP ),Z1),U,4) '="""" S O K=1 Q . I OK S C=C+1 ,IBXSAVE(" OSQ",Z)=C S Z=0 F S Z=$O(IBXS AVE("OSQ", Z)) Q:'Z S IBXDATA( IBXSAVE("O SQ",Z))=$G (IBXSAVE(Z 0,IBXIEN," O",Z)) D:I BXSAVE("OS Q",Z)>1 ID ^IBCEF2(IB XSAVE("OSQ ",Z),"OP"_ $G(IBOP)_" ") Q ;PSP RV(IBIFN) ; Q $$PSPR V^IBCEF7(I BIFN) ; Mo ved ; | |
| 1357 | ||
| 1358 | Routines | |
| 1359 | Activities | |
| 1360 | Routine Na me | |
| 1361 | IBCEF73 | |
| 1362 | Enhancemen t Category | |
| 1363 | New | |
| 1364 | Modify | |
| 1365 | Delete | |
| 1366 | No Change | |
| 1367 | RTM | |
| 1368 | ||
| 1369 | Related Op tions | |
| 1370 | None | |
| 1371 | Related Ro utines | |
| 1372 | Routines “ Called By” | |
| 1373 | Routines “ Called” | |
| 1374 | ||
| 1375 | ||
| 1376 | ||
| 1377 | ||
| 1378 | Data Dicti onary (DD) Reference s | |
| 1379 | ||
| 1380 | Related Pr otocols | |
| 1381 | None | |
| 1382 | Related In tegration Control Re gistration s (ICRs) | |
| 1383 | None | |
| 1384 | Data Passi ng | |
| 1385 | Input | |
| 1386 | Output Re ference | |
| 1387 | Both | |
| 1388 | Global Re ference | |
| 1389 | Local | |
| 1390 | Input Attr ibute Name and Defin ition | |
| 1391 | Name: | |
| 1392 | Definition : | |
| 1393 | Output Att ribute Nam e and Defi nition | |
| 1394 | Name: | |
| 1395 | Definition : | |
| 1396 | Current Lo gic | |
| 1397 | IBCEF73 ;W OIFO/SS - FORMATTER AND EXTRAC TOR SPECIF IC BILL FU NCTIONS ;8 /6/03 10:5 6am ;;2.0; INTEGRATED BILLING;* *232,320,3 58,349,377 **;21-MAR- 94;Build 2 3 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; ;check qu alifier ;I BFRM 0-bot h, 1=UB,2= 1500 ;IBPR OV - funct ion in #39 9 (1-refer ring, 2-op erating,et c) ;IBTYPE - "C"-cur rent insur ance, "O"- other insu rance ;IBV AL - value to checkC HCKSEC(IBF RM,IBPROV, IBTYPE,IBV AL) ; I IB FRM=0 Q:$$ CHSEC(1,IB PROV,IBTYP E,IBVAL) 1 Q $$CHSEC (2,IBPROV, IBTYPE,IBV AL) Q $$CH SEC(IBFRM, IBPROV,IBT YPE,IBVAL) ;CHSEC(IB FRM,IBPROV ,IBTYPE,IB VAL) ; N I BSTR S IBS TR="" ;ref erring I I BPROV=1 S IBSTR=$S(I BTYPE="C": $$OPR5(IBF RM),IBTYPE ="O":$$OP4 (IBFRM),1: "") ;opera ting I IBP ROV=2 S IB STR=$S(IBT YPE="C":$$ OPR3(IBFRM ),IBTYPE=" O":$$OP2(I BFRM),1:"" ) ;renderi ng I IBPRO V=3 S IBST R=$S(IBTYP E="C":$$OP R2(IBFRM), IBTYPE="O" :$$OP1(IBF RM),1:"") ;attending I IBPROV= 4 S IBSTR= $S(IBTYPE= "C":$$OPR2 (IBFRM),IB TYPE="O":$ $OP1(IBFRM ),1:"") ;s upervising I IBPROV= 5 S IBSTR= $S(IBTYPE= "C":$$OPR8 (IBFRM),IB TYPE="O":$ $OP8(IBFRM ),1:"") ;o ther I IBP ROV=9 S IB STR=$S(IBT YPE="C":$$ OPR4(IBFRM ),IBTYPE=" O":$$OP9(I BFRM),1:"" ) Q:IBPROV =0!(IBSTR= "") 1 ;if "" or faci lity id al ways retur n 1 Q IBST R[("^"_IBV AL_"^") ; ;Filter in valid qual ifier entr ies for re cords SUB1 ,SUB2,OP6, OP7,OP3 ; Rebuild th e IBXSAVE( "PROVINF" or IBXSAVE ("PROVINF_ FAC" array with ; on ly ids tha t have val id qualifi ers ;IBFRM 0-both, 1 =UB,2=1500 ;IBREC re cord ID wh ose ids ar e being fi ltered (SU B1,SUB2,et c) ;IBFAC - 1 if fac ility chec k, 0 if at tending/re ndering ch eck ;IBTYP E - "C"-cu rrent insu rance, "O" -other ins urance ;IB XSAVE - th e array of provider ids extrac ted, retur ned filter ed - ; pas sed by ref erenceCHCK SUB(IBFRM, IBREC,IBFA C,IBTYPE,I BXSAVE) ; N Z,Z0,Z1, Z2,CT,IBSA VE S Z="PR OVINF"_$P( "^_FAC",U, $G(IBFAC)+ 1) I '$G(I BXSAVE(Z,I BXIEN)) D . D F^IBCE F("N-ALL " _$S($G(IBF AC):"OUTSI DE FAC PRO VIDER INF" ,1:"CUR/OT H PROVIDER INFO")) M IBSAVE(Z, IBXIEN,IBT YPE)=IBXSA VE(Z,IBXIE N,IBTYPE) K IBXSAVE( Z,IBXIEN,I BTYPE) S Z 0=0 F S Z 0=$O(IBSAV E(Z,IBXIEN ,IBTYPE,Z0 )) Q:'Z0 S Z1="" F S Z1=$O(I BSAVE(Z,IB XIEN,IBTYP E,Z0,Z1)) Q:Z1="" S (Z2,CT)=0 F S Z2=$ O(IBSAVE(Z ,IBXIEN,IB TYPE,Z0,Z1 ,Z2)) Q:'Z 2 D . N I BVAL . S I BVAL=$P(IB SAVE(Z,IBX IEN,IBTYPE ,Z0,Z1,Z2) ,U,3) . I IBFRM=0 D Q .. I $S ($$CHSUB(1 ,IBREC,IBV AL):1,1:$$ CHSUB(2,IB PROV,IBTYP E,IBVAL)) D ... S CT =CT+1,IBXS AVE(Z,IBXI EN,IBTYPE, Z0,Z1,CT)= IBSAVE(Z,I BXIEN,IBTY PE,Z0,Z1,Z 2) ... I $ G(IBXSAVE( Z,IBXIEN,I BTYPE,Z0)) ="",$G(IBS AVE(Z,IBXI EN,IBTYPE, Z0))'="" S IBXSAVE(Z ,IBXIEN,IB TYPE,Z0)=I BSAVE(Z,IB XIEN,IBTYP E,Z0) . I $$CHSUB(IB FRM,IBREC, IBVAL) D . . S CT=CT+ 1,IBXSAVE( Z,IBXIEN,I BTYPE,Z0,Z 1,CT)=IBSA VE(Z,IBXIE N,IBTYPE,Z 0,Z1,Z2) . . I $G(IBX SAVE(Z,IBX IEN,IBTYPE ,Z0))="",$ G(IBSAVE(Z ,IBXIEN,IB TYPE,Z0))' ="" S IBXS AVE(Z,IBXI EN,IBTYPE, Z0)=IBSAVE (Z,IBXIEN, IBTYPE,Z0) Q ; ; Che ck if vali d qualifie r ;IBFRM 0 -both, 1=U B,2=1500 ; IBREC reco rd ID whos e ids are being filt ered (SUB1 ,SUB2,etc) ;IBVAL - value to c heckCHSUB( IBFRM,IBRE C,IBVAL) ; N IBSTR I IBREC="SU B1" S IBST R=$$SUB1(I BFRM) I IB REC="SUB2" S IBSTR=$ $SUB2(IBFR M) I IBREC ="OP7" S I BSTR=$$OP7 (IBFRM) I IBREC="OP3 " S IBSTR= $$OP3(IBFR M) I IBREC ="OP6" S I BSTR=$$OP6 (IBFRM) Q: $G(IBSTR)= "" 1 ;if " " always r eturn 1 Q IBSTR[("^" _IBVAL_"^" ) ; ;IBFRM 0-both, 1 =UB,2=1500 OPR2(IBFRM ) ; Q:IBFR M=1 "^0B^1 A^1B^1C^1D ^1G^1H^EI^ G2^LU^N5^S Y^X5^" Q:I BFRM=2 "^0 B^1B^1C^1D ^1G^1H^EI^ G2^LU^N5^S Y^X5^" Q " " ; ;IBFRM 0-both, 1 =UB,2=1500 OP1(IBFRM) ; Q:IBFRM =1 "^1A^1B ^1C^1D^1G^ 1H^EI^G2^L U^N5^" Q:I BFRM=2 "^1 B^1C^1D^EI ^G2^LU^N5^ " Q "" ; ; IBFRM 0-bo th, 1=UB,2 =1500OPR3( IBFRM) ; Q :IBFRM=1 " ^0B^1A^1B^ 1C^1D^1G^1 H^EI^G2^LU ^N5^SY^X5^ " Q "" ; ; IBFRM 0-bo th, 1=UB,2 =1500OP2(I BFRM) ; Q: IBFRM=1 "^ 1A^1B^1C^1 D^1G^1H^EI ^G2^LU^N5^ " Q "" ; ; IBFRM 0-bo th, 1=UB,2 =1500SUB1( IBFRM) ; Q :IBFRM=1 " ^0B^1A^1B^ 1C^1D^1G^1 H^EI^G2^LU ^N5^SY^X5^ " Q:IBFRM= 2 "^0B^1A^ 1B^1C^1D^1 G^1H^EI^G2 ^LU^N5^U3^ SY^X5^" Q "" ; ;IBFR M 0-both, 1=UB,2=150 0OPR4(IBFR M) ; Q:IBF RM=1 "^0B^ 1A^1B^1C^1 D^1G^1H^EI ^G2^LU^N5^ SY^X5^" Q "" ; ;IBFR M 0-both, 1=UB,2=150 0OP9(IBFRM ) ; Q:IBFR M=1 "^1A^1 B^1C^1D^1G ^1H^EI^G2^ LU^N5^" Q "" ; ;IBFR M 0-both, 1=UB,2=150 0SUB2(IBFR M) ; Q:IBF RM=1 "^0B^ 1A^1B^1C^1 G^1H^1J^EI ^FH^G2^G5^ LU^N5^X5^T J^B3^BQ^SY ^U3^" Q:IB FRM=2 "^0B ^X4^1A^1B^ 1C^1G^1H^G 2^LU^X5^TJ ^B3^BQ^SY^ U3^" Q "" ; ;IBFRM 0 -both, 1=U B,2=1500OP 3(IBFRM) ; Q:IBFRM=1 "^1B^1C^E I^G2^LU^N5 ^" Q "" ; ;IBFRM 0-b oth, 1=UB, 2=1500OPR5 (IBFRM) ; Q:IBFRM=2 "^0B^1B^1C ^1D^1G^1H^ EI^G2^LU^N 5^SY^X5^" Q "" ; ;IB FRM 0-both , 1=UB,2=1 500OPR8(IB FRM) ; Q:I BFRM=2 "^0 B^1B^1C^1D ^1G^1H^EI^ G2^LU^N5^S Y^X5^" Q " " ; ;IBFRM 0-both, 1 =UB,2=1500 OP4(IBFRM) ; Q:IBFRM =2 "^1B^1C ^1D^EI^G2^ LU^N5^" Q "" ; ;IBFR M 0-both, 1=UB,2=150 0OP8(IBFRM ) ; Q:IBFR M=2 "^1B^1 C^1D^EI^G2 ^N5^" Q "" ; ;IBFRM 0-both, 1= UB,2=1500O P6(IBFRM) ; Q:IBFRM= 2 "^1A^1B^ 1C^G2^LU^N 5^" Q "" ; ;IBFRM 0- both, 1=UB ,2=1500OP7 (IBFRM) ; Q:IBFRM=2 "^1A^1B^1C ^G2^LU^N5^ " Q "" ; ; check qual ifier for PRV1 ;IBFR M 0-both, 1=UB,2=150 0 ;IBVAL - value to checkCHCKP RV1(IBFRM, IBVAL) ; I IBFRM=0 Q :$$CHPRV1( 1,IBVAL) 1 Q $$CHPRV 1(2,IBVAL) Q $$CHPRV 1(IBFRM,IB VAL) ;IBFR M 0-both, 1=UB,2=150 0CHPRV1(IB FRM,IBVAL) ; N IBSTR S IBSTR=" " S IBSTR= $$PRV1(IBF RM) Q:IBST R="" 1 Q I BSTR[("^"_ IBVAL_"^") ;PRV1(IBF RM) ; Q:IB FRM=1 "^1A ^1C^1D^1G^ 1H^1J^B3^B Q^EI^FH^G2 ^G5^LU^SY^ X5^" Q:IBF RM=2 "^1B^ 1C^1D^1G^1 H^1J^B3^BQ ^EI^FH^G2^ G5^LU^U3^S Y^X5^" Q " " ;PTSELF ;This tag is for the CI2 segme nt. If the IBXSAVE(" IADR") is empty ;che ck to see if the rel ationship to pt is 1 8 (self) i f so pull info ;from PT1 calls ;See if r elationshi p to insur ed is 18 i f not or i f "" quit N IBZ D F^ IBCEF("N-A LL INSURED PT RELATI ON","IBZ", ,IBXIEN) S IBZ=$G(IB Z(+$$COBN^ IBCEF(IBXI EN))) S IB Z=$$PRELCN V^IBCNSP1( IBZ,1) I I BZ'="18" S IBXDATA=" " Q N IBZ D F^IBCEF( "N-PATIENT STREET AD DRESS 1-3" ,"IBZ",,IB XIEN) S IB XDATA="18" Q ;NOPUNC T(X,SPACE, EXC) ; Str ip punctua tion from data in X ; SPACE = flag if 1 strip SPAC ES ; EXC = list of p unct not t o strip ; N PUNCT,Z S PUNCT=". ,-+(){}[]\ /><:;?|=_* &%$#@!~`^' """ I $G(S PACE) S PU NCT=PUNCT_ " " I $G(E XC)'="" S PUNCT=$TR( PUNCT,EXC) N L S L=" " F S L=$ O(X(L)) Q: L="" D . S X(L)=$TR (X(L),PUNC T) I $G(X) '="" D . S X=$TR(X,P UNCT) Q ;P ROVID(IBXI EN) ;This modified v ersion of prov id ca ll is to a cquire the SSN ;firs t, if the ssn is not available then we n eed to get the tax i d. ;we als o need to provide th e modifier for which value it is Q:+$G(I BXIEN)=0 " " S IBXSAV E("ID")="" S IBXSAVE ="" S IBXS AVE=$$PROV SSN^IBCEF7 (IBXIEN) N I F I=1:1 :9 D . I $ P(IBXSAVE, "^",I)]"" S $P(IBXSA VE("ID"),U ,I)="34" ; If no ibxd ata go loo k in 355.9 7 for 24 N IBRETVAL S IBRETVA L="" N IBP TR,IBFT F IBFT=1:1:9 D . Q:$P( IBXSAVE,U, IBFT)]"" . S IBPTR=$ $PROVPTR^I BCEF7(IBXI EN,IBFT) . S $P(IBRE TVAL,"^",I BFT)=$$TAX 3559(IBPTR ) . I $P(I BRETVAL,U, IBFT)]"" D . . S $P( IBXSAVE,U, IBFT)=$P(I BRETVAL,U, IBFT) . . S $P(IBXSA VE("ID"),U ,IBFT)="24 " Q IBXSAV E ;TAX3559 (IBPROV) ; I $P(IBPR OV,";",2)' ["IBA(355. 9" Q "" N IB2,IB3559 ,IBIDTYP,I BID,IBQFL S (IB3559, IBQFL)=0 S IBID="" Q :+$G(IBPRO V)=0 "" F IB2=1:1 S IB3559=$O( ^IBA(355.9 ,"B",IBPRO V,IB3559)) Q:IB3559= ""!IBQFL D . S IBID TYP=+$P($G (^IBA(355. 9,IB3559,0 )),"^",6) ;provider ID type, p tr to #355 .97 . S IB IDTYP=$P($ G(^IBE(355 .97,IBIDTY P,0)),"^", 3) . S:IBI DTYP="EI" IBID=$P($G (^IBA(355. 9,IB3559,0 )),"^",7), IBQFL=1 ; if nothing found yet , look in file 355.9 3 for Faci lity Defau lt ID I IB ID="",IBPR OV["IBA(35 5.93" D .N IB0,IBFID ,IBQ .S IB 0=$G(^IBA( 355.93,+IB PROV,0)) Q :IB0=""!($ P(IB0,U,2) '=1) ; not a facilit y - bail o ut .S IBFI D=$P(IB0,U ,9) Q:IBFI D="" ; no default i d on file - bail out .S IBQ=$P (IB0,U,13) I +IBQ>0, $P($G(^IBE (355.97,IB Q,0)),U,3) =24 S IBID =IBFID .Q Q $$NOPUNC T^IBCEF(IB ID) ; ;IBF ULL-full n ame ;IBEL - Name ele ment : "FA MILY","GIV EN","MIDDL E","SUFFIX " ;SSN200( IBPTR) ; I $P(IBPTR, ";",2)'="V A(200," Q "" Q $$NOP UNCT^IBCEF ($$GET1^DI Q(200,+$P( IBPTR,";") _",",9)) ; ;Input: ; IBIEN399 - ien in # 399 ;Outpu t: ; retur ns a strin g with "^" delimiter s that con tains SSNs (if any) ; in the p osition th at equal t o FUNCTION number ; i.e. if RE NDERING fu nction # i s 3 then S SN will be ; in $P(r eturn valu e,"^",3), etc. ;SSN3 559(IBPROV ) ; N IB2, IB3559,IBI DTYP,IBID, IBQFL S (I B3559,IBQF L)=0 S IBI D="" Q:+$G (IBPROV)=0 "" F IB2= 1:1 S IB35 59=$O(^IBA (355.9,"B" ,IBPROV,IB 3559)) Q:I B3559=""!I BQFL D . S IBIDTYP= +$P($G(^IB A(355.9,IB 3559,0))," ^",6) . S IBIDTYP=$P ($G(^IBE(3 55.97,IBID TYP,0)),"^ ",3) . S:I BIDTYP="SY " IBID=$P( $G(^IBA(35 5.9,IB3559 ,0)),"^",7 ),IBQFL=1 Q $$NOPUNC T^IBCEF(IB ID) ; ;IBI DTYP-provi der ID typ e, ptr to #355.97 ;I BFULL-full name ;IBE L - Name e lement : " FAMILY","G IVEN","MID DLE","SUFF IX" ;PRV1F MT(P) ;FOR MAT CODE F OR PRV1 SE GMENT THAT WON'T FIT ON LINE K IBXDATA S :'$D(IBXSA VE("BIL-PR OV-SEC")) IBXSAVE("B IL-PROV-SE C")=$$PRV1 ^IBCEF7(IB XIEN) S IB XDATA=$P($ G(IBXSAVE( "BIL-PROV- SEC")),"^" ,P) I $G(I BXDATA)'=" " S IBXDAT A=$$NOPUNC T^IBCEF(IB XDATA,1) Q ; | |
| 1398 | Modified L ogic (Chan ges are in bold) | |
| 1399 | IBCEF73 ;W OIFO/SS - FORMATTER AND EXTRAC TOR SPECIF IC BILL FU NCTIONS ;8 /6/03 10:5 6am ;;2.0; INTEGRATED BILLING;* *232,320,3 58,349,377 ,592**;21- MAR-94;Bui ld 23 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ; ;chec k qualifie r ;IBFRM 0 -both, 1=U B,2=1500, 4=J430D ;I BPROV - fu nction in #399 (1-re ferring, 2 -operating ,etc) ;IBT YPE - "C"- current in surance, " O"-other i nsurance ; IBVAL - va lue to che ckCHCKSEC( IBFRM,IBPR OV,IBTYPE, IBVAL) ; ; JWS;IB*2.0 *592; J430 D form 4 I IBFRM=0 Q :$$CHSEC(1 ,IBPROV,IB TYPE,IBVAL ) 1 Q:$$CH SEC(4,IBPR OV,IBTYPE, IBVAL) Q $ $CHSEC(2,I BPROV,IBTY PE,IBVAL) Q $$CHSEC( IBFRM,IBPR OV,IBTYPE, IBVAL) ;CH SEC(IBFRM, IBPROV,IBT YPE,IBVAL) ; N IBSTR S IBSTR=" " ;referri ng I IBPRO V=1 S IBST R=$S(IBTYP E="C":$$OP R5(IBFRM), IBTYPE="O" :$$OP4(IBF RM),1:"") ;operating I IBPROV= 2 S IBSTR= $S(IBTYPE= "C":$$OPR3 (IBFRM),IB TYPE="O":$ $OP2(IBFRM ),1:"") ;r endering I IBPROV=3 S IBSTR=$S (IBTYPE="C ":$$OPR2(I BFRM),IBTY PE="O":$$O P1(IBFRM), 1:"") ;att ending I I BPROV=4 S IBSTR=$S(I BTYPE="C": $$OPR2(IBF RM),IBTYPE ="O":$$OP1 (IBFRM),1: "") ;super vising I I BPROV=5 S IBSTR=$S(I BTYPE="C": $$OPR8(IBF RM),IBTYPE ="O":$$OP8 (IBFRM),1: "") ;JWS;I B*2.0*592; assistant surgeon De ntal I IBP ROV=6 S IB STR=$S(IBT YPE="C":$$ OPRB(IBFRM ),IBTYPE=" O":$$OPRB( IBFRM),1:" ") ;other I IBPROV=9 S IBSTR=$ S(IBTYPE=" C":$$OPR4( IBFRM),IBT YPE="O":$$ OP9(IBFRM) ,1:"") Q:I BPROV=0!(I BSTR="") 1 ;if "" or facility id always return 1 Q IBSTR[("^ "_IBVAL_"^ ") ; ;Filt er invalid qualifier entries f or records SUB1,SUB2 ,OP6,OP7,O P3 ; Rebui ld the IBX SAVE("PROV INF" or IB XSAVE("PRO VINF_FAC" array with ; only id s that hav e valid qu alifiers ; IBFRM 0-bo th, 1=UB,2 =1500, 4=J 430D ;IBRE C record I D whose id s are bein g filtered (SUB1,SUB 2,etc) ;IB FAC - 1 if facility check, 0 i f attendin g/renderin g check ;I BTYPE - "C "-current insurance, "O"-other insurance ;IBXSAVE - the arra y of provi der ids ex tracted, r eturned fi ltered - ; passed by reference CHCKSUB(IB FRM,IBREC, IBFAC,IBTY PE,IBXSAVE ) ; N Z,Z0 ,Z1,Z2,CT, IBSAVE S Z ="PROVINF" _$P("^_FAC ",U,$G(IBF AC)+1) I ' $G(IBXSAVE (Z,IBXIEN) ) D . D F^ IBCEF("N-A LL "_$S($G (IBFAC):"O UTSIDE FAC PROVIDER INF",1:"CU R/OTH PROV IDER INFO" )) M IBSAV E(Z,IBXIEN ,IBTYPE)=I BXSAVE(Z,I BXIEN,IBTY PE) K IBXS AVE(Z,IBXI EN,IBTYPE) S Z0=0 F S Z0=$O(I BSAVE(Z,IB XIEN,IBTYP E,Z0)) Q:' Z0 S Z1=" " F S Z1= $O(IBSAVE( Z,IBXIEN,I BTYPE,Z0,Z 1)) Q:Z1=" " S (Z2,C T)=0 F S Z2=$O(IBSA VE(Z,IBXIE N,IBTYPE,Z 0,Z1,Z2)) Q:'Z2 D . N IBVAL . S IBVAL=$ P(IBSAVE(Z ,IBXIEN,IB TYPE,Z0,Z1 ,Z2),U,3) . I IBFRM= 0 D Q .. I $S($$CHS UB(1,IBREC ,IBVAL):1, 1:$$CHSUB( 2,IBPROV,I BTYPE,IBVA L)) D ... S CT=CT+1, IBXSAVE(Z, IBXIEN,IBT YPE,Z0,Z1, CT)=IBSAVE (Z,IBXIEN, IBTYPE,Z0, Z1,Z2) ... I $G(IBXS AVE(Z,IBXI EN,IBTYPE, Z0))="",$G (IBSAVE(Z, IBXIEN,IBT YPE,Z0))'= "" S IBXSA VE(Z,IBXIE N,IBTYPE,Z 0)=IBSAVE( Z,IBXIEN,I BTYPE,Z0) . I $$CHSU B(IBFRM,IB REC,IBVAL) D .. S CT =CT+1,IBXS AVE(Z,IBXI EN,IBTYPE, Z0,Z1,CT)= IBSAVE(Z,I BXIEN,IBTY PE,Z0,Z1,Z 2) .. I $G (IBXSAVE(Z ,IBXIEN,IB TYPE,Z0))= "",$G(IBSA VE(Z,IBXIE N,IBTYPE,Z 0))'="" S IBXSAVE(Z, IBXIEN,IBT YPE,Z0)=IB SAVE(Z,IBX IEN,IBTYPE ,Z0) Q ; ; Check if valid qual ifier ;IBF RM 0-both, 1=UB,2=15 00, 4=J430 D ;IBREC r ecord ID w hose ids a re being f iltered (S UB1,SUB2,e tc) ;IBVAL - value t o checkCHS UB(IBFRM,I BREC,IBVAL ) ; N IBST R I IBREC= "SUB1" S I BSTR=$$SUB 1(IBFRM) I IBREC="SU B2" S IBST R=$$SUB2(I BFRM) I IB REC="OP7" S IBSTR=$$ OP7(IBFRM) I IBREC=" OP3" S IBS TR=$$OP3(I BFRM) I IB REC="OP6" S IBSTR=$$ OP6(IBFRM) Q:$G(IBST R)="" 1 ;i f "" alway s return 1 Q IBSTR[( "^"_IBVAL_ "^") ; ;IB FRM 0-both , 1=UB,2=1 500, 4=J43 0DOPR2(IBF RM) ; Q:IB FRM=1 "^0B ^1A^1B^1C^ 1D^1G^1H^E I^G2^LU^N5 ^SY^X5^" ; JRA IB*2.0 *592 Modif y for Dent al form 7 ;Q:IBFRM=2 "^0B^1B^1 C^1D^1G^1H ^EI^G2^LU^ N5^SY^X5^" ;JRA IB*2 .0*592 ';' Q:(IBFRM= 2!(IBFRM=4 )) "^0B^1B ^1C^1D^1G^ 1H^EI^G2^L U^N5^SY^X5 ^" ;JWS;J RA IB*2.0* 592 Q "" ; ;IBFRM 0- both, 1=UB ,2=1500, 4 =J430DOP1( IBFRM) ; Q :IBFRM=1 " ^1A^1B^1C^ 1D^1G^1H^E I^G2^LU^N5 ^" ;JRA IB *2.0*592 M odify for Dental for m 7 ;Q:IBF RM=2 "^1B^ 1C^1D^EI^G 2^LU^N5^" ;JRA IB*2. 0*592 ';' Q:(IBFRM=2 !(IBFRM=4) ) "^1B^1C^ 1D^EI^G2^L U^N5^" ;J WS;JRA IB* 2.0*592 Q "" ; ;IBFR M 0-both, 1=UB,2=150 0, 4=J430D OPR3(IBFRM ) ; Q:IBFR M=1 "^0B^1 A^1B^1C^1D ^1G^1H^EI^ G2^LU^N5^S Y^X5^" Q " " ; ;IBFRM 0-both, 1 =UB,2=1500 , 4=J430DO P2(IBFRM) ; Q:IBFRM= 1 "^1A^1B^ 1C^1D^1G^1 H^EI^G2^LU ^N5^" Q "" ; ;IBFRM 0-both, 1= UB,2=1500, 4=J430DSU B1(IBFRM) ; Q:IBFRM= 1 "^0B^1A^ 1B^1C^1D^1 G^1H^EI^G2 ^LU^N5^SY^ X5^" ;JRA IB*2.0*592 Modify fo r Dental f orm 7 ;Q:I BFRM=2 "^0 B^1A^1B^1C ^1D^1G^1H^ EI^G2^LU^N 5^U3^SY^X5 ^" ;JRA IB *2.0*592 ' ;' Q:(IBFR M=2!(IBFRM =4)) "^0B^ 1A^1B^1C^1 D^1G^1H^EI ^G2^LU^N5^ U3^SY^X5^" ;JWS;JRA IB*2.0*59 2 Q "" ; ; IBFRM 0-bo th, 1=UB,2 =1500, 4=J 430DOPR4(I BFRM) ; Q: IBFRM=1 "^ 0B^1A^1B^1 C^1D^1G^1H ^EI^G2^LU^ N5^SY^X5^" Q "" ; ;I BFRM 0-bot h, 1=UB,2= 1500, 4=J4 30DOP9(IBF RM) ; Q:IB FRM=1 "^1A ^1B^1C^1D^ 1G^1H^EI^G 2^LU^N5^" Q "" ; ;IB FRM 0-both , 1=UB,2=1 500, 4=J43 0DSUB2(IBF RM) ; Q:IB FRM=1 "^0B ^1A^1B^1C^ 1G^1H^1J^E I^FH^G2^G5 ^LU^N5^X5^ TJ^B3^BQ^S Y^U3^" ;JR A IB*2.0*5 92 Modify for Dental form 7 ;Q :IBFRM=2 " ^0B^X4^1A^ 1B^1C^1G^1 H^G2^LU^X5 ^TJ^B3^BQ^ SY^U3^" ;J RA IB*2.0* 592 ';' Q: (IBFRM=2!( IBFRM=4)) "^0B^X4^1A ^1B^1C^1G^ 1H^G2^LU^X 5^TJ^B3^BQ ^SY^U3^" ;JWS;JRA I B*2.0*592 Q "" ; ;IB FRM 0-both , 1=UB,2=1 500, 4=J43 0DOP3(IBFR M) ; Q:IBF RM=1 "^1B^ 1C^EI^G2^L U^N5^" Q " " ; ;IBFRM 0-both, 1 =UB,2=1500 , 4=J430DO PR5(IBFRM) ; ;JRA IB *2.0*592 M odify for Dental for m 7 ;Q:IBF RM=2 "^0B^ 1B^1C^1D^1 G^1H^EI^G2 ^LU^N5^SY^ X5^" ;JRA IB*2.0*592 ';' Q:(IB FRM=2!(IBF RM=4)) "^0 B^1B^1C^1D ^1G^1H^EI^ G2^LU^N5^S Y^X5^" ;J WS;JRA IB* 2.0*592 Q "" ; ;IBFR M 0-both, 1=UB,2=150 0, 4=J430D OPR8(IBFRM ) ; ;JRA I B*2.0*592 Modify for Dental fo rm 7 ;Q:IB FRM=2 "^0B ^1B^1C^1D^ 1G^1H^EI^G 2^LU^N5^SY ^X5^" ;JRA IB*2.0*59 2 ';' Q:(I BFRM=2!(IB FRM=4)) "^ 0B^1B^1C^1 D^1G^1H^EI ^G2^LU^N5^ SY^X5^" ; JWS;JRA IB *2.0*592 Q "" ; ;IBF RM 0-both, 1=UB,2=15 00, 4=J430 DOP4(IBFRM ) ; ;JRA I B*2.0*592 Modify for Dental fo rm 7 ;Q:IB FRM=2 "^1B ^1C^1D^EI^ G2^LU^N5^" ;JRA IB*2 .0*592 ';' Q:(IBFRM= 2!(IBFRM=4 )) "^1B^1C ^1D^EI^G2^ LU^N5^" ; JWS;JRA IB *2.0*592 Q "" ; ;IBF RM 0-both, 1=UB,2=15 00, 4=J430 DOP8(IBFRM ) ; ;JRA I B*2.0*592 Modify for Dental fo rm 7 ;Q:IB FRM=2 "^1B ^1C^1D^EI^ G2^N5^" ;J RA IB*2.0* 592 ';' Q: (IBFRM=2!( IBFRM=4)) "^1B^1C^1D ^EI^G2^N5^ " ;JWS;JR A IB*2.0*5 92 Q "" ; ;IBFRM 0-b oth, 1=UB, 2=1500, 4= J430DOP6(I BFRM) ; ;J RA IB*2.0* 592 Modify for Denta l form 7 ; Q:IBFRM=2 "^1A^1B^1C ^G2^LU^N5^ " ;JRA IB* 2.0*592 '; ' Q:(IBFRM =2!(IBFRM= 4)) "^1A^1 B^1C^G2^LU ^N5^" ;JW S;JRA IB*2 .0*592 Q " " ; ;IBFRM 0-both, 1 =UB,2=1500 , 4=J430DO P7(IBFRM) ; ;JRA IB* 2.0*592 Mo dify for D ental form 7 ;Q:IBFR M=2 "^1A^1 B^1C^G2^LU ^N5^" ;JRA IB*2.0*59 2 ';' Q:(I BFRM=2!(IB FRM=4)) "^ 1A^1B^1C^G 2^LU^N5^" ;JWS;JRA IB*2.0*592 Q "" ; ;I BFRM 0-bot h, 1=UB,2= 1500, 4=J4 30DOPRB(IB FRM) ; Q:I BFRM=4 "^0 B^1G^G2^LU ^" Q "" ; ;check qua lifier for PRV1 ;IBF RM 0-both, 1=UB,2=15 00, 4=J430 D ;IBVAL - value to checkCHCKP RV1(IBFRM, IBVAL) ; I IBFRM=0 Q :$$CHPRV1( 1,IBVAL) 1 Q $$CHPRV 1(2,IBVAL) Q $$CHPRV 1(IBFRM,IB VAL) ;IBFR M 0-both, 1=UB,2=150 0, 4=J430D CHPRV1(IBF RM,IBVAL) ; N IBSTR S IBSTR="" S IBSTR=$ $PRV1(IBFR M) Q:IBSTR ="" 1 Q IB STR[("^"_I BVAL_"^") ;PRV1(IBFR M) ; Q:IBF RM=1 "^1A^ 1C^1D^1G^1 H^1J^B3^BQ ^EI^FH^G2^ G5^LU^SY^X 5^" ;JRA I B*2.0*592 Modify for Dental fo rm 7 ;Q:IB FRM=2 "^1B ^1C^1D^1G^ 1H^1J^B3^B Q^EI^FH^G2 ^G5^LU^U3^ SY^X5^" ;J RA IB*2.0* 592 ';' Q: (IBFRM=2!( IBFRM=4)) "^1B^1C^1D ^1G^1H^1J^ B3^BQ^EI^F H^G2^G5^LU ^U3^SY^X5^ " ;JWS;JR A IB*2.0*5 92 Q "" ;P TSELF ;Thi s tag is f or the CI2 segment. If the IBX SAVE("IADR ") is empt y ;check t o see if t he relatio nship to p t is 18 (s elf) if so pull info ;from PT1 calls ;Se e if relat ionship to insured i s 18 if no t or if "" quit N IB Z D F^IBCE F("N-ALL I NSURED PT RELATION", "IBZ",,IBX IEN) S IBZ =$G(IBZ(+$ $COBN^IBCE F(IBXIEN)) ) S IBZ=$$ PRELCNV^IB CNSP1(IBZ, 1) I IBZ'= "18" S IBX DATA="" Q N IBZ D F^ IBCEF("N-P ATIENT STR EET ADDRES S 1-3","IB Z",,IBXIEN ) S IBXDAT A="18" Q ; NOPUNCT(X, SPACE,EXC) ; Strip p unctuation from data in X ; SP ACE = flag if 1 stri p SPACES ; EXC = lis t of punct not to st rip ; N PU NCT,Z S PU NCT=".,-+( ){}[]\/><: ;?|=_*&%$# @!~`^'""" I $G(SPACE ) S PUNCT= PUNCT_" " I $G(EXC)' ="" S PUNC T=$TR(PUNC T,EXC) N L S L="" F S L=$O(X( L)) Q:L="" D . S X( L)=$TR(X(L ),PUNCT) I $G(X)'="" D . S X=$ TR(X,PUNCT ) Q ;PROVI D(IBXIEN) ;This modi fied versi on of prov id call i s to acqui re the SSN ;first, i f the ssn is not ava ilable the n we need to get the tax id. ; we also ne ed to prov ide the mo difier for which val ue it is Q :+$G(IBXIE N)=0 "" S IBXSAVE("I D")="" S I BXSAVE="" S IBXSAVE= $$PROVSSN^ IBCEF7(IBX IEN) N I F I=1:1:9 D . I $P(IB XSAVE,"^", I)]"" S $P (IBXSAVE(" ID"),U,I)= "34" ;If n o ibxdata go look in 355.97 fo r 24 N IB RETVAL S I BRETVAL="" N IBPTR,I BFT F IBFT =1:1:9 D . Q:$P(IBXS AVE,U,IBFT )]"" . S I BPTR=$$PRO VPTR^IBCEF 7(IBXIEN,I BFT) . S $ P(IBRETVAL ,"^",IBFT) =$$TAX3559 (IBPTR) . I $P(IBRET VAL,U,IBFT )]"" D . . S $P(IBXS AVE,U,IBFT )=$P(IBRET VAL,U,IBFT ) . . S $P (IBXSAVE(" ID"),U,IBF T)="24" Q IBXSAVE ;T AX3559(IBP ROV) ; I $ P(IBPROV," ;",2)'["IB A(355.9" Q "" N IB2, IB3559,IBI DTYP,IBID, IBQFL S (I B3559,IBQF L)=0 S IBI D="" Q:+$G (IBPROV)=0 "" F IB2= 1:1 S IB35 59=$O(^IBA (355.9,"B" ,IBPROV,IB 3559)) Q:I B3559=""!I BQFL D . S IBIDTYP= +$P($G(^IB A(355.9,IB 3559,0))," ^",6) ;pro vider ID t ype, ptr t o #355.97 . S IBIDTY P=$P($G(^I BE(355.97, IBIDTYP,0) ),"^",3) . S:IBIDTYP ="EI" IBID =$P($G(^IB A(355.9,IB 3559,0))," ^",7),IBQF L=1 ; if n othing fou nd yet, lo ok in file 355.93 fo r Facility Default I D I IBID=" ",IBPROV[" IBA(355.93 " D .N IB0 ,IBFID,IBQ .S IB0=$G (^IBA(355. 93,+IBPROV ,0)) Q:IB0 =""!($P(IB 0,U,2)'=1) ; not a f acility - bail out . S IBFID=$P (IB0,U,9) Q:IBFID="" ; no def ault id on file - ba il out .S IBQ=$P(IB0 ,U,13) I + IBQ>0,$P($ G(^IBE(355 .97,IBQ,0) ),U,3)=24 S IBID=IBF ID .Q Q $$ NOPUNCT^IB CEF(IBID) ; ;IBFULL- full name ;IBEL - Na me element : "FAMILY ","GIVEN", "MIDDLE"," SUFFIX" ;S SN200(IBPT R) ; I $P( IBPTR,";", 2)'="VA(20 0," Q "" Q $$NOPUNCT ^IBCEF($$G ET1^DIQ(20 0,+$P(IBPT R,";")_"," ,9)) ; ;In put: ; IBI EN399 - ie n in #399 ;Output: ; returns a string wi th "^" del imiters th at contain s SSNs (if any) ; in the posit ion that e qual to FU NCTION num ber ; i.e. if RENDER ING functi on # is 3 then SSN w ill be ; i n $P(retur n value,"^ ",3), etc. ;SSN3559( IBPROV) ; N IB2,IB35 59,IBIDTYP ,IBID,IBQF L S (IB355 9,IBQFL)=0 S IBID="" Q:+$G(IBP ROV)=0 "" F IB2=1:1 S IB3559=$ O(^IBA(355 .9,"B",IBP ROV,IB3559 )) Q:IB355 9=""!IBQFL D . S IB IDTYP=+$P( $G(^IBA(35 5.9,IB3559 ,0)),"^",6 ) . S IBID TYP=$P($G( ^IBE(355.9 7,IBIDTYP, 0)),"^",3) . S:IBIDT YP="SY" IB ID=$P($G(^ IBA(355.9, IB3559,0)) ,"^",7),IB QFL=1 Q $$ NOPUNCT^IB CEF(IBID) ; ;IBIDTYP -provider ID type, p tr to #355 .97 ;IBFUL L-full nam e ;IBEL - Name eleme nt : "FAMI LY","GIVEN ","MIDDLE" ,"SUFFIX" ;PRV1FMT(P ) ;FORMAT CODE FOR P RV1 SEGMEN T THAT WON 'T FIT ON LINE K IBX DATA S:'$D (IBXSAVE(" BIL-PROV-S EC")) IBXS AVE("BIL-P ROV-SEC")= $$PRV1^IBC EF7(IBXIEN ) S IBXDAT A=$P($G(IB XSAVE("BIL -PROV-SEC" )),"^",P) I $G(IBXDA TA)'="" S IBXDATA=$$ NOPUNCT^IB CEF(IBXDAT A,1) Q ; | |
| 1400 | ||
| 1401 | Routines | |
| 1402 | Activities | |
| 1403 | Routine Na me | |
| 1404 | IBCEF74 | |
| 1405 | Enhancemen t Category | |
| 1406 | New | |
| 1407 | Modify | |
| 1408 | Delete | |
| 1409 | No Change | |
| 1410 | RTM | |
| 1411 | ||
| 1412 | Related Op tions | |
| 1413 | None | |
| 1414 | Related Ro utines | |
| 1415 | Routines “ Called By” | |
| 1416 | Routines “ Called” | |
| 1417 | ||
| 1418 | ||
| 1419 | ||
| 1420 | ||
| 1421 | Data Dicti onary (DD) Reference s | |
| 1422 | ||
| 1423 | Related Pr otocols | |
| 1424 | None | |
| 1425 | Related In tegration Control Re gistration s (ICRs) | |
| 1426 | None | |
| 1427 | Data Passi ng | |
| 1428 | Input | |
| 1429 | Output Re ference | |
| 1430 | Both | |
| 1431 | Global Re ference | |
| 1432 | Local | |
| 1433 | Input Attr ibute Name and Defin ition | |
| 1434 | Name: | |
| 1435 | Definition : | |
| 1436 | Output Att ribute Nam e and Defi nition | |
| 1437 | Name: | |
| 1438 | Definition : | |
| 1439 | Current Lo gic | |
| 1440 | IBCEF74 ;W OIFO/SS - FORMATTER/ EXTRACT BI LL FUNCTIO NS ;31-JUL -03 ;;2.0; INTEGRATED BILLING;* *232,280,1 55,290,291 ,320,358,3 43,374,432 **;21-MAR- 94;Build 1 92 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ;SORT(IBPR NUM,IBPRTY P,IB399,IB SRC,IBDST, IBN,IBEXC, IBSEQ,IBLI MIT) ; D S ORT^IBCEF7 7($G(IBPRN UM),$G(IBP RTYP),$G(I B399),.IBS RC,.IBDST, $G(IBN),$G (IBEXC),$G (IBSEQ),$G (IBLIMIT)) Q ; ;-- P ROVINF -- ;Create ar ray with p rov info ; Input: ; I B399 - ien #399 ; IB PRNUM - 1= prim ins, 2= sec, 3 -tert ; IB RES - for results ; IBSORT - t o sort OTH ER INSURAN CE data ; if PROVIN F is calle d for "C" mode of PR OVIDER sub routine th en ; IBSO RT can be any (say 1 ) ; if PRO VINF is ca lled for " O" mode th en can be more than set of dat a ; - need to sort a rray to us e it (like IBXDATA(1 ) and IBXD ATA(2)) ; for mode " O" it shou ld be 1 or 2 (see PR OVIDER sec tion) ;IBI NSTP - "C" -current ins, "O"-o ther ;Outp ut: ; IBRE S(PRNUM,PR TYPE,SEQ#) =PROV^INSU R^IDTYPE^I D^FORMTYP^ CARETYP ; where:(see PROVIDER) PROVINF(IB 399,IBPRNU M,IBRES,IB SORT,IBINS TP) ; I $G (IB399)="" Q I +$G(I BSORT)=0 S IBSORT=$G (IBPRNUM) N IBPRTYP, IBINSCO,IB PROV,IBFRM TYP,IBCARE ,IB35591,I BN,IBCURR, IBEXC,IBLI MIT S IBN= 0 S IBINSC O=+$P($G(^ DGCR(399,I B399,"M")) ,"^",IBPRN UM) S IBFR MTYP=$$FT^ IBCEF(IB39 9),IBFRMTY P=$S(IBFRM TYP=2:2,IB FRMTYP=3:1 ,1:0) S IB CARE=$S($$ ISRX^IBCEF 1(IB399):3 ,1:0) ;if an Rx refi ll bill S: IBCARE=0 I BCARE=$$IN PAT^IBCEF( IB399,1) S :'IBCARE I BCARE=2 ;1 -inp,2-out S IBLIMIT =$S($G(IBI NSTP)="C": 5,1:3) ; L imits on s econdary I Ds F IBPRT YP=1:1:9 D . N Z,IB3 55OV . S I BPROV=$$PR OVPTR^IBCE F7(IB399,I BPRTYP) . Q:+IBPROV= 0 . ;don't create an ything if form type not CMS-15 00 or UB . Q:IBFRMTY P=0 . N IB RETARR S I BRETARR=0 . D PRACT^ IBCEF71(IB INSCO,IBFR MTYP,IBCAR E,IBPROV,. IBRETARR,I BPRTYP,$G( IBINSTP)) . S IB355O V="",IBEXC ="" . S Z= $O(^DGCR(3 99,IB399," PRV","B",I BPRTYP,0)) . I Z S Z =$G(^DGCR( 399,IB399, "PRV",Z,0) ) D .. I $ P(Z,U,IBPR NUM+4)'="" ,$P(Z,U,IB PRNUM+11)' ="" S IB35 5OV=$P(Z,U ,IBPRNUM+4 )_U_$P(Z,U ,IBPRNUM+1 1) . S IBC URR=$$COB^ IBCEF(IB39 9) . S IBN =0,IB35591 =$$CH35591 ^IBCEF72(I BINSCO,IBF RMTYP,IBCA RE) . I $G (IBINSTP)= "C",$G(IBP RNUM)=1,"3 4"[$G(IBPR TYP),"P"[$ G(IBCURR), $G(IBFRMTY P)=2,$$MCR ONBIL^IBEF UNC(IB399) S IB355OV =$$MCR24K^ IBCEU3(IB3 99)_"^12" . I $G(IBI NSTP)="O", "34"[$G(IB PRTYP),"ST "[$G(IBCUR R),$G(IBFR MTYP)=2,$$ MCRONBIL^I BEFUNC(IB3 99) S IB35 5OV=$$MCR2 4K^IBCEU3( IB399)_"^1 2" ;Calcul ate MEDICA RE (WNR) s pecific pr ovider qua lifier and ID for CM S-1500 sec ondary cla ims . I $P (IB355OV,U ,2) D .. I $$CHCKSEC ^IBCEF73(I BFRMTYP,IB PRTYP,$G(I BINSTP),$P ($G(^IBE(3 55.97,+$P( IB355OV,U, 2),0)),U,3 )) D ... S IBEXC=$P( IB355OV,U, 2),IBN=IBN +1,IBRES(I BSORT,IBPR TYP,IBN)=" OVERRIDE^" _IBINSCO_U _$P($G(^IB E(355.97,+ IBEXC,0)), U,3)_U_$P( IB355OV,U) _"^^^^^"_+ IBEXC . I IB35591'=" ",IBEXC'=$ P(IB35591, U,3) S:$$C HCKSEC^IBC EF73(IBFRM TYP,IBPRTY P,$G(IBINS TP),$P(IB3 5591,"^")) IBN=IBN+1 ,IBRES(IBS ORT,IBPRTY P,IBN)="DE FAULT^"_IB INSCO_"^"_ IB35591_"^ ^",$P(IBRE S(IBSORT,I BPRTYP,IBN ),U,9)=$P( IB35591,U, 3) . D SOR T(IBSORT,I BPRTYP,IB3 99,.IBRETA RR,.IBRES, IBN,IBEXC, IBPRNUM,IB LIMIT) . S IBRES(IBS ORT,IBPRTY P)=IBPROV S IBRES(IB SORT)=$S(I BPRNUM=3:" T",IBPRNUM =2:"S",1:" P") Q ;SEC IDCK(IBIFN ,IBSEQ,IBT YP,IBIFN1) ; Functio n returns 1 if ID ty pe ptr in ; IBTYP is valid X12 code for the claim/ prov funct ion (IBPRO VF) ; as a sec id ; IBSEQ = CO B seq bein g checked ; IBIFN1 = entry # i n PRV mult iple being checked ; Called fr om input t ransform o f fields . 12-.14, su bfile 399. 0222 I $G( IBIFN)="" Q N IBOK,I BFRM,IBCOB N,IBX12,IB PROVF S IB PROVF=+$G( ^DGCR(399, IBIFN,"PRV ",IBIFN1,0 )) S IBFRM =$$FT^IBCE F(IBIFN),I BFRM=$S(IB FRM=3:1,1: 2) ; Form type S IBC OBN=$$COBN ^IBCEF(IBI FN) S:'IBC OBN IBCOBN =1 ; Curre nt COB seq S IBX12=$ P($G(^IBE( 355.97,+IB TYP,0)),U, 3) ; X12 c ode for pr ov id typ Q $$CHSEC^ IBCEF73(IB FRM,IBPROV F,$S(IBSEQ =IBCOBN:"C ",1:"O"),I BX12) ;DEF ID(IBIFN,I BPRV) ; ; IBIFN = ie n of bill ; IBPRV = ien of ent ry subfile 399.0222 ; Function returns d efault ids : prim id def^sec id def^tert id def ; S SN cannot be the def ault ID I $G(IBIFN)= "" Q "" N Z,Z1,ID,IB Z,IBINS,IB INS4,IBUB S IBZ="" S IBUB=($$F T^IBCEF(IB IFN)=3) D F^IBCEF("N -ALL ATT/R END PROV S SN/EI","IB Z","",IBIF N) S Z=$G( ^DGCR(399, IBIFN,"PRV ",IBPRV,0) ),ID=$P(Z, U,5,7) F Z 1=1:1:3 I $P(ID,U,Z1 )="" D . Q :'$G(^DGCR (399,IBIFN ,"I"_Z1)) S IBINS=+^ ("I"_Z1) . S $P(ID,U ,Z1)=$$GET ID^IBCEP2( IBIFN,2,$P (Z,U,2),Z1 ) . ; Set default if null . I $P(ID,U,Z1 )="" S $P( ID,U,Z1)=" VAD000" Q ID ;DISPID (IBXIEN) ; Display l ist of all prov and fac ids th at will ; extract fo r this bil l if trans mitted ele ctronicall y I $G(IBX IEN)="" Q N IBID,IBI D1,IBZ,IBC T,IBFRM,IB COBN,IBQUI T,IBTYP,DI R,IBIFN,X, Y,Z,Z0,Z1, CO,IBN,IBC ODE S IBIF N=IBXIEN S IBFRM=$$F T^IBCEF(IB IFN),IBCOB N=$$COBN^I BCEF(IBIFN ) W @IOF W !,"If thi s bill is transmitte d electron ically, th e followin g IDs will be sent:" ; Returns all prov sec ids to be transm itted in i ndicated s egments S Z=+$G(^DGC R(399,IBIF N,"I1")) I Z W !," P rimary Ins Co: ",$$E XTERNAL^DI LFD(399,10 1,"",Z) I IBCOBN=1 W ?54,"<<<C urrent Ins " S Z=+$G( ^DGCR(399, IBIFN,"I2" )) I Z W ! ,"Secondar y Ins Co: ",$$EXTERN AL^DILFD(3 99,101,"", Z) I IBCOB N=2 W ?54, "<<<Curren t Ins" S Z =+$G(^DGCR (399,IBIFN ,"I3")) I Z W !," Te rtiary Ins Co: ",$$E XTERNAL^DI LFD(399,10 1,"",Z) I IBCOBN=3 W ?54,"<<<C urrent Ins " W !!,"Pr ovider IDs : (VistA R ecords OP1 ,OP2,OP4,O P8,OP9,OPR 2,OPR3,OPR 4,OPR5,OPR 8):" ;F Z= 1:1:3 I $G (^DGCR(399 ,IBIFN,"I" _Z)) D PRO VINF(IBIFN ,Z,.IBID," ",$S(IBCOB N=Z:"C",1: "O")) ;*43 2/TAZ - Ad ded call t o gather l ine provid ers and ap ply busine ss rules D ALLIDS^IB CEFP(IBIFN ,.IBID) ;* 432/TAZ - Rewrote fo llowing co de to take info from the IBID array inst ead of Fil e 399. Thi s allows c hanges fro m the appl ication of the busin ess rules. S IBQUIT= 0 ; F IBPR V=4,3,1,2, 5,9 D ; P rocess pro viders in order: Att ending, Re ndering, R eferring, Operating, Supervisi ng, and Ot her Operat ing if the y exist . I '$D(IBID ("PROVINF" ,IBIFN,"C" ,1,IBPRV)) Q . I ($Y +5)>IOSL S IBQUIT=$$ NOMORE() Q :IBQUIT . W !!?5,$$E XTERNAL^DI LFD(399.02 22,.01,"", IBPRV),": "_$$EXTERN AL^DILFD(3 99.0222,.0 2,"",$P(IB ID("PROVIN F",IBIFN," C",1,IBPRV ),U)) . W !?8,"NPI: ",?40,$S($ P($G(IBID( "PROVINF", IBIFN,"C", 1,IBPRV,0) ),U,4)]"": $P(IBID("P ROVINF",IB IFN,"C",1, IBPRV,0),U ,4),1:"*** MISSING*** ") . K IBT YP . F CO= "C","O" D .. F IBN=1 ,2 I $D(IB ID("PROVIN F",IBIFN,C O,IBN,IBPR V)) D ... F Z0=1:1 Q :'$D(IBID( "PROVINF", IBIFN,CO,I BN,IBPRV,Z 0))!IBQUIT D .... S IBCODE=+$ P(IBID("PR OVINF",IBI FN,CO,IBN, IBPRV,Z0), U,9) .... Q:$D(IBTYP (IBCODE)) ;1st of ea ch type tr ansmits .. .. I ($Y+5 )>IOSL S I BQUIT=$$NO MORE() Q:I BQUIT .... S IBTYP(I BCODE)="" .... W !,? 8,"(",IBID ("PROVINF" ,IBIFN,CO, IBN),") ", $$EXTERNAL ^DILFD(36, 4.01,"",IB CODE),?40, $P(IBID("P ROVINF",IB IFN,CO,IBN ,IBPRV,Z0) ,U,4) ; I IBQUIT G D ISPIDX ; ; IB*2*320 - display additional IDs for ? ID D EN^IB CEF74A(IBI FN,.IBQUIT ,.IBID) ;D ISPIDX ; I '$G(IBQUI T) S DIR(0 )="EA",DIR ("A")="Pre ss RETURN to continu e " W ! D ^DIR K DIR Q ;NOMORE () ; S DIR (0)="EA",D IR("A")="P ress RETUR N for more IDs or '^ ' to exit: " W ! D ^ DIR W @IOF Q (Y'=1) ;DEFSEC(IB IFN,IBARR) ; Returns array in IBARR for default pr ov sec ids for ien I BIFN ; IBA RR if pass ed by ref is returne d IBARR(pr ov functio n,COBN)=de f id I $G( IBIFN)="" N IBCAR,IB COBN,IBPC, IBINS,IBAR RX,Q,Z,Z0, ZINS,X K I BARR S ZIN S="",IBCOB N=$$COBN^I BCEF(IBIFN ),IBPC=$S( $$FT^IBCEF (IBIFN)=3: 2,1:1) S I BCAR=$$INP AT^IBCEF(I BIFN,1),IB CAR=$S('IB CAR:2,1:1) F Z=1:1:3 S ZINS=ZI NS_+$G(^DG CR(399,IBI FN,"I"_Z)) _U F Z=1:1 :3 I $P(ZI NS,U,Z),'$ P($G(^DIC( 36,+$P(ZIN S,U,Z),4)) ,U,IBPC) S $P(ZINS,U ,Z)="" S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," PRV",Z)) Q :'Z S Z0= $G(^(Z,0)) D . F Q=1 :1:3 D .. I $P(Z0,U, Q+4)'="" S IBARR(+Z0 ,Q)=$P(Z0, U,Q+4) Q ; Override .. S IBIN S=$P(ZINS, U,Q) .. Q: 'IBINS .. S X=$$IDFI ND^IBCEP2( IBIFN,"",$ P(Z0,U,2), Q,1) .. I X'="" S IB ARR(+Z0,Q) =X Q ; | |
| 1441 | Modified L ogic (Chan ges are in bold) | |
| 1442 | IBCEF74 ;W OIFO/SS - FORMATTER/ EXTRACT BI LL FUNCTIO NS ;31-JUL -03 ;;2.0; INTEGRATED BILLING;* *232,280,1 55,290,291 ,320,358,3 43,374,432 ,592**;21- MAR-94;Bui ld 192 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;SORT( IBPRNUM,IB PRTYP,IB39 9,IBSRC,IB DST,IBN,IB EXC,IBSEQ, IBLIMIT) ; D SORT^IB CEF77($G(I BPRNUM),$G (IBPRTYP), $G(IB399), .IBSRC,.IB DST,$G(IBN ),$G(IBEXC ),$G(IBSEQ ),$G(IBLIM IT)) Q ; ; -- PROVINF -- ;Creat e array wi th prov in fo ;Input: ; IB399 - ien #399 ; IBPRNUM - 1=prim i ns, 2= sec , 3 -tert ; IBRES - for result s ; IBSORT - to sort OTHER INS URANCE dat a ; if PR OVINF is c alled for "C" mode o f PROVIDER subroutin e then ; IBSORT can be any (s ay 1) ; if PROVINF i s called f or "O" mod e then can be more t han set of data ; - need to so rt array t o use it ( like IBXDA TA(1) and IBXDATA(2) ) ; for mo de "O" it should be 1 or 2 (se e PROVIDER section) ;IBINSTP - "C" -curr ent ins, " O"-other ; Output: ; IBRES(PRNU M,PRTYPE,S EQ#)=PROV^ INSUR^IDTY PE^ID^FORM TYP^CARETY P ; where: (see PROVI DER)PROVIN F(IB399,IB PRNUM,IBRE S,IBSORT,I BINSTP) ; I $G(IB399 )="" Q I + $G(IBSORT) =0 S IBSOR T=$G(IBPRN UM) N IBPR TYP,IBINSC O,IBPROV,I BFRMTYP,IB CARE,IB355 91,IBN,IBC URR,IBEXC, IBLIMIT S IBN=0 S IB INSCO=+$P( $G(^DGCR(3 99,IB399," M")),"^",I BPRNUM) ;J RA IB*2.0* 592 Modify for Denta l form 7 - treat the same as C MS-1500 ;S IBFRMTYP= $$FT^IBCEF (IB399),IB FRMTYP=$S( IBFRMTYP=2 :2,IBFRMTY P=3:1,1:0) ;JRA IB*2 .0*592 ';' S IBFRMTY P=$$FT^IBC EF(IB399), IBFRMTYP=$ S((IBFRMTY P=2!(IBFRM TYP=7)):2, IBFRMTYP=3 :1,1:0) ;J RA IB*2.0* 592 S IBCA RE=$S($$IS RX^IBCEF1( IB399):3,1 :0) ;if an Rx refill bill S:IB CARE=0 IBC ARE=$$INPA T^IBCEF(IB 399,1) S:' IBCARE IBC ARE=2 ;1-i np,2-out S IBLIMIT=$ S($G(IBINS TP)="C":5, 1:3) ; Lim its on sec ondary IDs F IBPRTYP =1:1:9 D . N Z,IB355 OV . S IBP ROV=$$PROV PTR^IBCEF7 (IB399,IBP RTYP) . Q: +IBPROV=0 . ;don't c reate anyt hing if fo rm type no t CMS-1500 or UB . Q :IBFRMTYP= 0 . N IBRE TARR S IBR ETARR=0 . D PRACT^IB CEF71(IBIN SCO,IBFRMT YP,IBCARE, IBPROV,.IB RETARR,IBP RTYP,$G(IB INSTP)) . S IB355OV= "",IBEXC=" " . S Z=$O (^DGCR(399 ,IB399,"PR V","B",IBP RTYP,0)) . I Z S Z=$ G(^DGCR(39 9,IB399,"P RV",Z,0)) D .. I $P( Z,U,IBPRNU M+4)'="",$ P(Z,U,IBPR NUM+11)'=" " S IB355O V=$P(Z,U,I BPRNUM+4)_ U_$P(Z,U,I BPRNUM+11) . S IBCUR R=$$COB^IB CEF(IB399) . S IBN=0 ,IB35591=$ $CH35591^I BCEF72(IBI NSCO,IBFRM TYP,IBCARE ) . ;JRA I B*2.0*592 Modify for Dental fo rm 7 - tre at the sam e as CMS-1 500 . I $G (IBINSTP)= "C",$G(IBP RNUM)=1,"3 4"[$G(IBPR TYP),"P"[$ G(IBCURR), ($G(IBFRMT YP)=2!($G( IBFRMTYP)= 7)),$$MCRO NBIL^IBEFU NC(IB399) S IB355OV= $$MCR24K^I BCEU3(IB39 9)_"^12" ;JRA IB*2. 0*592 . ;C alculate M EDICARE (W NR) specif ic provide r qualifie r and ID f or CMS-150 0 secondar y claim ;J RA IB*2.0* 592 . I $G (IBINSTP)= "O","34"[$ G(IBPRTYP) ,"ST"[$G(I BCURR),($G (IBFRMTYP) =2!($G(IBF RMTYP)=7)) ,$$MCRONBI L^IBEFUNC( IB399) S I B355OV=$$M CR24K^IBCE U3(IB399)_ "^12" . I $P(IB355OV ,U,2) D .. I $$CHCKS EC^IBCEF73 (IBFRMTYP, IBPRTYP,$G (IBINSTP), $P($G(^IBE (355.97,+$ P(IB355OV, U,2),0)),U ,3)) D ... S IBEXC=$ P(IB355OV, U,2),IBN=I BN+1,IBRES (IBSORT,IB PRTYP,IBN) ="OVERRIDE ^"_IBINSCO _U_$P($G(^ IBE(355.97 ,+IBEXC,0) ),U,3)_U_$ P(IB355OV, U)_"^^^^^" _+IBEXC . I IB35591' ="",IBEXC' =$P(IB3559 1,U,3) S:$ $CHCKSEC^I BCEF73(IBF RMTYP,IBPR TYP,$G(IBI NSTP),$P(I B35591,"^" )) IBN=IBN +1,IBRES(I BSORT,IBPR TYP,IBN)=" DEFAULT^"_ IBINSCO_"^ "_IB35591_ "^^",$P(IB RES(IBSORT ,IBPRTYP,I BN),U,9)=$ P(IB35591, U,3) . D S ORT(IBSORT ,IBPRTYP,I B399,.IBRE TARR,.IBRE S,IBN,IBEX C,IBPRNUM, IBLIMIT) . S IBRES(I BSORT,IBPR TYP)=IBPRO V S IBRES( IBSORT)=$S (IBPRNUM=3 :"T",IBPRN UM=2:"S",1 :"P") Q ;S ECIDCK(IBI FN,IBSEQ,I BTYP,IBIFN 1) ; Funct ion return s 1 if ID type ptr i n ; IBTYP is valid X 12 code fo r the clai m/prov fun ction (IBP ROVF) ; as a sec id ; IBSEQ = COB seq be ing checke d ; IBIFN1 = entry # in PRV mu ltiple bei ng checked ; Called from input transform of fields .12-.14, subfile 39 9.0222 I $ G(IBIFN)=" " Q N IBOK ,IBFRM,IBC OBN,IBX12, IBPROVF S IBPROVF=+$ G(^DGCR(39 9,IBIFN,"P RV",IBIFN1 ,0)) S IBF RM=$$FT^IB CEF(IBIFN) ,IBFRM=$S( IBFRM=3:1, 1:2) ; For m type S I BCOBN=$$CO BN^IBCEF(I BIFN) S:'I BCOBN IBCO BN=1 ; Cur rent COB s eq S IBX12 =$P($G(^IB E(355.97,+ IBTYP,0)), U,3) ; X12 code for prov id ty p Q $$CHSE C^IBCEF73( IBFRM,IBPR OVF,$S(IBS EQ=IBCOBN: "C",1:"O") ,IBX12) ;D EFID(IBIFN ,IBPRV) ; ; IBIFN = ien of bil l ; IBPRV = ien of e ntry subfi le 399.022 2 ; Functi on returns default i ds: prim i d def^sec id def^ter t id def ; SSN canno t be the d efault ID I $G(IBIFN )="" Q "" N Z,Z1,ID, IBZ,IBINS, IBINS4,IBU B S IBZ="" S IBUB=($ $FT^IBCEF( IBIFN)=3) D F^IBCEF( "N-ALL ATT /REND PROV SSN/EI"," IBZ","",IB IFN) S Z=$ G(^DGCR(39 9,IBIFN,"P RV",IBPRV, 0)),ID=$P( Z,U,5,7) F Z1=1:1:3 I $P(ID,U, Z1)="" D . Q:'$G(^DG CR(399,IBI FN,"I"_Z1) ) S IBINS= +^("I"_Z1) . S $P(ID ,U,Z1)=$$G ETID^IBCEP 2(IBIFN,2, $P(Z,U,2), Z1) . ; Se t default if null . I $P(ID,U, Z1)="" S $ P(ID,U,Z1) ="VAD000" Q ID ;DISP ID(IBXIEN) ; Display list of a ll prov an d fac ids that will ; extract for this b ill if tra nsmitted e lectronica lly I $G(I BXIEN)="" Q N IBID,I BID1,IBZ,I BCT,IBFRM, IBCOBN,IBQ UIT,IBTYP, DIR,IBIFN, X,Y,Z,Z0,Z 1,CO,IBN,I BCODE S IB IFN=IBXIEN S IBFRM=$ $FT^IBCEF( IBIFN),IBC OBN=$$COBN ^IBCEF(IBI FN) W @IOF W !,"If t his bill i s transmit ted electr onically, the follow ing IDs wi ll be sent :" ; Retur ns all pro v sec ids to be tran smitted in indicated segments S Z=+$G(^D GCR(399,IB IFN,"I1")) I Z W !," Primary I ns Co: ",$ $EXTERNAL^ DILFD(399, 101,"",Z) I IBCOBN=1 W ?54,"<< <Current I ns" S Z=+$ G(^DGCR(39 9,IBIFN,"I 2")) I Z W !,"Second ary Ins Co : ",$$EXTE RNAL^DILFD (399,101," ",Z) I IBC OBN=2 W ?5 4,"<<<Curr ent Ins" S Z=+$G(^DG CR(399,IBI FN,"I3")) I Z W !," Tertiary I ns Co: ",$ $EXTERNAL^ DILFD(399, 101,"",Z) I IBCOBN=3 W ?54,"<< <Current I ns" ;JWS;I B*2.0*592; added Assi stant Surg eon record s to heade r display W !!,"Prov ider IDs: (VistA Rec ords OP1,O P2,OP4,OP8 ,OP9,OP10, OPR,OPR1,O PR2,OPR3,O PR4,",!?29 ,"OPR5,OPR 7,OPR8,OPR 9,OPRA,OPR B,OPRC):" ;F Z=1:1:3 I $G(^DGC R(399,IBIF N,"I"_Z)) D PROVINF( IBIFN,Z,.I BID,"",$S( IBCOBN=Z:" C",1:"O")) ;*432/TAZ - Added c all to gat her line p roviders a nd apply b usiness ru les D ALLI DS^IBCEFP( IBIFN,.IBI D) ;*432/T AZ - Rewro te followi ng code to take info from the IBID array instead o f File 399 . This all ows change s from the applicati on of the business r ules. S IB QUIT=0 ; ; JWS;IB*2.0 *592; adde d assistan t surgeon F IBPRV=4, 3,1,2,5,6, 9 D ; Pro cess provi ders in or der: Atten ding, Rend ering, Ref erring, Op erating, S upervising , and Othe r Operatin g if they exist . I '$D(IBID(" PROVINF",I BIFN,"C",1 ,IBPRV)) Q . I ($Y+5 )>IOSL S I BQUIT=$$NO MORE() Q:I BQUIT . W !!?5,$$EXT ERNAL^DILF D(399.0222 ,.01,"",IB PRV),": "_ $$EXTERNAL ^DILFD(399 .0222,.02, "",$P(IBID ("PROVINF" ,IBIFN,"C" ,1,IBPRV), U)) . W !? 8,"NPI: ", ?40,$S($P( $G(IBID("P ROVINF",IB IFN,"C",1, IBPRV,0)), U,4)]"":$P (IBID("PRO VINF",IBIF N,"C",1,IB PRV,0),U,4 ),1:"***MI SSING***") . K IBTYP . F CO="C ","O" D .. F IBN=1,2 I $D(IBID ("PROVINF" ,IBIFN,CO, IBN,IBPRV) ) D ... F Z0=1:1 Q:' $D(IBID("P ROVINF",IB IFN,CO,IBN ,IBPRV,Z0) )!IBQUIT D .... S I BCODE=+$P( IBID("PROV INF",IBIFN ,CO,IBN,IB PRV,Z0),U, 9) .... Q: $D(IBTYP(I BCODE)) ;1 st of each type tran smits .... I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE() Q:IBQ UIT .... S IBTYP(IBC ODE)="" .. .. W !,?8, "(",IBID(" PROVINF",I BIFN,CO,IB N),") ",$$ EXTERNAL^D ILFD(36,4. 01,"",IBCO DE),?40,$P (IBID("PRO VINF",IBIF N,CO,IBN,I BPRV,Z0),U ,4) ; I IB QUIT G DIS PIDX ; ; I B*2*320 - display ad ditional I Ds for ?ID D EN^IBCE F74A(IBIFN ,.IBQUIT,. IBID) ;DIS PIDX ; I ' $G(IBQUIT) S DIR(0)= "EA",DIR(" A")="Press RETURN to continue " W ! D ^D IR K DIR Q ;NOMORE() ; S DIR(0 )="EA",DIR ("A")="Pre ss RETURN for more I Ds or '^' to exit: " W ! D ^DI R W @IOF Q (Y'=1) ;D EFSEC(IBIF N,IBARR) ; Returns a rray in IB ARR for de fault prov sec ids f or ien IBI FN ; IBARR if passed by ref is returned IBARR(prov function, COBN)=def id I $G(IB IFN)="" N IBCAR,IBCO BN,IBPC,IB INS,IBARRX ,Q,Z,Z0,ZI NS,X K IBA RR S ZINS= "",IBCOBN= $$COBN^IBC EF(IBIFN), IBPC=$S($$ FT^IBCEF(I BIFN)=3:2, 1:1) S IBC AR=$$INPAT ^IBCEF(IBI FN,1),IBCA R=$S('IBCA R:2,1:1) F Z=1:1:3 S ZINS=ZINS _+$G(^DGCR (399,IBIFN ,"I"_Z))_U F Z=1:1:3 I $P(ZINS ,U,Z),'$P( $G(^DIC(36 ,+$P(ZINS, U,Z),4)),U ,IBPC) S $ P(ZINS,U,Z )="" S Z=0 F S Z=$O (^DGCR(399 ,IBIFN,"PR V",Z)) Q:' Z S Z0=$G (^(Z,0)) D . F Q=1:1 :3 D .. I $P(Z0,U,Q+ 4)'="" S I BARR(+Z0,Q )=$P(Z0,U, Q+4) Q ; Override . . S IBINS= $P(ZINS,U, Q) .. Q:'I BINS .. S X=$$IDFIND ^IBCEP2(IB IFN,"",$P( Z0,U,2),Q, 1) .. I X' ="" S IBAR R(+Z0,Q)=X Q ; | |
| 1443 | ||
| 1444 | Routines | |
| 1445 | Activities | |
| 1446 | Routine Na me | |
| 1447 | IBCEF74A | |
| 1448 | Enhancemen t Category | |
| 1449 | New | |
| 1450 | Modify | |
| 1451 | Delete | |
| 1452 | No Change | |
| 1453 | RTM | |
| 1454 | ||
| 1455 | Related Op tions | |
| 1456 | None | |
| 1457 | Related Ro utines | |
| 1458 | Routines “ Called By” | |
| 1459 | Routines “ Called” | |
| 1460 | ||
| 1461 | ||
| 1462 | ||
| 1463 | ||
| 1464 | Data Dicti onary (DD) Reference s | |
| 1465 | ||
| 1466 | Related Pr otocols | |
| 1467 | None | |
| 1468 | Related In tegration Control Re gistration s (ICRs) | |
| 1469 | None | |
| 1470 | Data Passi ng | |
| 1471 | Input | |
| 1472 | Output Re ference | |
| 1473 | Both | |
| 1474 | Global Re ference | |
| 1475 | Local | |
| 1476 | Input Attr ibute Name and Defin ition | |
| 1477 | Name: | |
| 1478 | Definition : | |
| 1479 | Output Att ribute Nam e and Defi nition | |
| 1480 | Name: | |
| 1481 | Definition : | |
| 1482 | Current Lo gic | |
| 1483 | IBCEF74A ; ALB/ESG - Provider I D maint ?I D continua tion ;7 Ma r 2006 ;;2 .0;INTEGRA TED BILLIN G;**320,34 3,349,395, 400,432,51 6**;21-MAR -94;Build 123 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ; Q ;EN(IBIFN, IBQUIT,IBI D) ; Displ ay billing provider and servic e provider IDs as pa rt ; of th e ?ID disp lay/help i n the bill ing screen s. ; Calle d from DIS PID^IBCEF7 4. NEW IBX ,Z,ZI,ZN,S EQ,PSIN,DA TA,QUALNM, IDNUM,FACN AME,IBZ,OR GNPI,BPZ,B PNAME,BPNP I,BPTAX,SF NPI,SFTAX ; ;D ALLID S^IBCEF75( IBIFN,.IBI D) ; ; Re- sort array by insura nce sequen ce (P/S/T) K IBX F Z ="BILLING PRV","LAB/ FAC" F ZI= "C","O" S ZN=0 F S ZN=$O(IBID (Z,IBIFN,Z I,ZN)) Q:' ZN D . S SEQ=$P($G( IBID(Z,IBI FN,ZI,ZN)) ,U,1) Q:SE Q="" . S I BX(Z,SEQ,Z I,ZN)="" . Q ; ; Dis play billi ng provide r informat ion - IB*2 *400 S BPZ =$$B^IBCEF 79(IBIFN) D GETBP^IB CEF79(IBIF N,"",+BPZ, "?ID",.IBZ ) S ORGNPI =$$ORGNPI^ IBCEF73A(I BIFN) I ($ Y+5)>IOSL S IBQUIT=$ $NOMORE^IB CEF74() I IBQUIT G E X W !!,"Bi lling Prov ider Name and ID Inf ormation" S BPNAME=$ G(IBZ("?ID ","NAME")) I BPNAME= "" S BPNAM E="***MISS ING***" I ($Y+5)>IOS L S IBQUIT =$$NOMORE^ IBCEF74() I IBQUIT G EX W !,"B illing Pro vider: ",B PNAME ; S BPNPI=$P(O RGNPI,U,3) I BPNPI=" " S BPNPI= "***MISSIN G***" I ($ Y+5)>IOSL S IBQUIT=$ $NOMORE^IB CEF74() I IBQUIT G E X W !?5,"B illing Pro vider NPI: ",BPNPI ; S BPTAX=$ $NOPUNCT^I BCEF($P($G (^IBE(350. 9,1,1)),U, 5),1) I BP TAX="" S B PTAX="***M ISSING***" I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE^IBCEF74 () I IBQUI T G EX W ! ?5,"Billin g Provider Tax ID (V istA Recor d PRV): ", BPTAX ; ; Display bi lling prov ider secon dary ID's (current i ns only) I ($Y+5)>IO SL S IBQUI T=$$NOMORE ^IBCEF74() I IBQUIT G EX W !?5 ,"Billing Provider S econdary I Ds (VistA Record CI1 A):" S Z=" BILLING PR V" D SECID (Z,.IBQUIT ) I IBQUIT G EX ; ; Now displa y the lab or facilit y primary and second ary IDs ; This is th e service facility i nformation ; IB*2*40 0 - check to make su re there i s a servic e facility ; I $P(BP Z,U,3)="" G LPRV ; no serv ice facili ty informa tion to di splay ; ; Service fa cility nam e, similar code as f ound in SU B-2 I ($Y+ 5)>IOSL S IBQUIT=$$N OMORE^IBCE F74() I IB QUIT G EX W !!,"Serv ice Facili ty Name an d ID Infor mation" ; ; MRD;IB*2 .0*516 - D ue to fiel ds being m arked for deletion, the ; func tion $$SEN DSF^IBCEF7 9 will alw ays return '1'. Refe r to ; tha t function and INSFL GS^IBCEF79 for more informatio n. ; ; Dis play note if ins co flag to su ppress lab /fac data is set (on ly applies in switch back mode) ;I '$$SEN DSF^IBCEF7 9(IBIFN) D I IBQUIT G EX ;. I ($Y+5)>IOS L S IBQUIT =$$NOMORE^ IBCEF74() Q:IBQUIT ; . W !!,"No te: Servic e Facility Data not sent for C urrent Ins urance" ;. W !," 'Se nd VA Lab/ Facility I Ds or Faci lity Data for VAMC?' is set to NO",! ;. Q ; S FACN AME=$$GETF AC^IBCEP8( +$P(BPZ,U, 4),$P(BPZ, U,3),0) I FACNAME="" S FACNAME ="***MISSI NG***" I ( $Y+5)>IOSL S IBQUIT= $$NOMORE^I BCEF74() I IBQUIT G EX W !?5," Facility: ",FACNAME ; S SFNPI= $P(ORGNPI, U,1) I SFN PI="" S SF NPI="***MI SSING***" I ($Y+5)>I OSL S IBQU IT=$$NOMOR E^IBCEF74( ) I IBQUIT G EX W !? 5,"Lab or Facility N PI: ",SFNP I ; S SFTA X=$$NOPUNC T^IBCEF($$ EIN^IBCEP8 A(IBIFN),1 ) I SFTAX= "" S SFTAX ="***MISSI NG***" I ( $Y+5)>IOSL S IBQUIT= $$NOMORE^I BCEF74() I IBQUIT G EX W !?5," Lab or Fac ility Tax ID (VistA Record SUB ): ",SFTAX ; ; lab/f ac seconda ry IDs I ( $Y+5)>IOSL S IBQUIT= $$NOMORE^I BCEF74() I IBQUIT G EX W !?5," Lab or Fac ility Seco ndary IDs (VistA Rec ords SUB1, SUB2,OP3,O P6,OP7):" S Z="LAB/F AC" D SECI D(Z,.IBQUI T) I IBQUI T G EX ;LP RV ;Servic e Line Pro viders I ' $D(IBID("L -PROV")) G EX ; No Line Level Providers N IBSLC,I BN,CO,IBCO DE,IBTYP,I BPRTYP,Z0 S IBSLC=0 W !!,"Serv ice Line P roviders" F S IBSLC =$O(IBID(" L-PROV",IB IFN,IBSLC) ) Q:'IBSLC D I IBQ UIT Q . I ($Y+6)>IOS L S IBQUIT =$$NOMORE^ IBCEF74() I IBQUIT Q . W !!?5, "Service L ine: ",IBS LC . F IBP RTYP=4,3,1 ,2,5,9 I $ D(IBID("L- PROV",IBIF N,IBSLC,"C ",1,IBPRTY P)) D ; P rocess pro viders in order: Att ending, Re ndering, R eferring, Operating, Supervisi ng, and Ot her Operat ing if the y exist .. I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE^IBCEF74 () I IBQUI T Q .. W ! ?5,$$EXTER NAL^DILFD( 399.0404,. 01,"",IBPR TYP),": ", $$EXTERNAL ^DILFD(399 .0404,.02, "",$P(IBID ("L-PROV", IBIFN,IBSL C,"C",1,IB PRTYP),U,1 )) .. W !? 8,"NPI:",? 40,$S($P(I BID("L-PRO V",IBIFN,I BSLC,"C",1 ,IBPRTYP,0 ),U,4)]"": $P(IBID("L -PROV",IBI FN,IBSLC," C",1,IBPRT YP,0),U,4) ,1:"***MIS SING***") .. K IBTYP .. F CO=" C","O" D . .. F IBN=1 ,2 D .... F Z0=1:1 Q :'$D(IBID( "L-PROV",I BIFN,IBSLC ,CO,IBN,IB PRTYP,Z0)) !IBQUIT D ..... S I BCODE=$P(I BID("L-PRO V",IBIFN,I BSLC,CO,IB N,IBPRTYP, Z0),U,9) . .... Q:$D( IBTYP(IBCO DE)) ; 1st of each t ype transm its ..... I ($Y+5)>I OSL S IBQU IT=$$NOMOR E^IBCEF74( ) Q:IBQUIT ..... S I BTYP(IBCOD E)="" .... . W !,?8," (",IBID("L -PROV",IBI FN,IBSLC,C O,IBN),") ",$$EXTERN AL^DILFD(3 6,4.01,"", IBCODE),?4 0,$P(IBID( "L-PROV",I BIFN,IBSLC ,CO,IBN,IB PRTYP,Z0), U,4) ;EX ; Q ;QUAL(Z ,FORMTYPE) ; turn th e qualifie r code int o a qualif ier descri ption NEW QUAL,IEN S QUAL="" I $G(Z)="" G QUALX I Z="1C" D G QUALX ; qualifie r for Medi care Part ? . I $G(F ORMTYPE)=2 S QUAL="M EDICARE PA RT B" ; 1500 . I $ G(FORMTYPE )=3 S QUAL ="MEDICARE PART A" ; ub . Q I Z=34 S Z ="SY" ; qualif ier for SS N S IEN=+$ O(^IBE(355 .97,"C",Z, "")) I 'IE N G QUALX S QUAL=$P( $G(^IBE(35 5.97,IEN,0 )),U,1)QUA LX ; Q QUA L ;SECID(Z ,IBQUIT) ; Display s econdary I D and qual ifier info rmation ; Z is the t ype of IDs passed in ; either B ILLING PRV or LAB/FA C ; IBQUIT is return ed if pass ed by refe rence NEW SEQ,ZI,ZN, PSIN,DATA, QUALNM,IDN UM,NODATA S IBQUIT=0 ,NODATA=1 F SEQ="P", "S","T" D Q:IBQUIT . ; . ; cu rrent ins only for b illing pro vider seco ndary IDs . I Z="BIL LING PRV", SEQ'=$$COB ^IBCEF(IBI FN) Q . S ZI="" . F S ZI=$O(I BX(Z,SEQ,Z I)) Q:ZI=" " D Q:IB QUIT .. S ZN=0 .. F S ZN=$O(I BX(Z,SEQ,Z I,ZN)) Q:' ZN D Q:I BQUIT ... S PSIN=0 ; start at 0 to skip primary ID s ... ;*43 2/TAZ - Ch anged Q:PS IN="" to Q :'PSIN to prevent "C ONTACTS" n ode from p rinting as secondary ID ... F S PSIN=$O (IBID(Z,IB IFN,ZI,ZN, PSIN)) Q:' PSIN D Q :IBQUIT .. .. S DATA= $G(IBID(Z, IBIFN,ZI,Z N,PSIN)) . ... S QUAL NM=$$QUAL( $P(DATA,U, 1),$$FT^IB CEF(IBIFN) ) .... S I DNUM=$P(DA TA,U,2) .. .. I ($Y+5 )>IOSL S I BQUIT=$$NO MORE^IBCEF 74() Q:IBQ UIT .... S NODATA=0 .... W !?8 ,"(",SEQ," ) ",QUALNM ,?40,IDNUM .... I Z= "LAB/FAC", $D(^DGCR(3 99,IBIFN," I2")),SEQ= $$COB^IBCE F(IBIFN) W ?54,"<<<C urrent Ins " .... I Z ="BILLING PRV",PSIN= 1 W ?54,"< <<System G enerated I D" .... Q ... Q .. Q . Q I NOD ATA,'IBQUI T W !?8,"( -) None Fo und"SECIDX ; Q ; | |
| 1484 | Modified L ogic (Chan ges are in bold) | |
| 1485 | IBCEF74A ; ALB/ESG - Provider I D maint ?I D continua tion ;7 Ma r 2006 ;;2 .0;INTEGRA TED BILLIN G;**320,34 3,349,395, 400,432,51 6,592**;21 -MAR-94;Bu ild 123 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; Q ;EN(IB IFN,IBQUIT ,IBID) ; D isplay bil ling provi der and se rvice prov ider IDs a s part ; o f the ?ID display/he lp in the billing sc reens. ; C alled from DISPID^IB CEF74. NEW IBX,Z,ZI, ZN,SEQ,PSI N,DATA,QUA LNM,IDNUM, FACNAME,IB Z,ORGNPI,B PZ,BPNAME, BPNPI,BPTA X,SFNPI,SF TAX ; ;D A LLIDS^IBCE F75(IBIFN, .IBID) ; ; Re-sort a rray by in surance se quence (P/ S/T) K IBX F Z="BILL ING PRV"," LAB/FAC" F ZI="C","O " S ZN=0 F S ZN=$O( IBID(Z,IBI FN,ZI,ZN)) Q:'ZN D . S SEQ=$P ($G(IBID(Z ,IBIFN,ZI, ZN)),U,1) Q:SEQ="" . S IBX(Z,S EQ,ZI,ZN)= "" . Q ; ; Display b illing pro vider info rmation - IB*2*400 S BPZ=$$B^I BCEF79(IBI FN) D GETB P^IBCEF79( IBIFN,"",+ BPZ,"?ID", .IBZ) S OR GNPI=$$ORG NPI^IBCEF7 3A(IBIFN) I ($Y+5)>I OSL S IBQU IT=$$NOMOR E^IBCEF74( ) I IBQUIT G EX W !! ,"Billing Provider N ame and ID Informati on" S BPNA ME=$G(IBZ( "?ID","NAM E")) I BPN AME="" S B PNAME="*** MISSING*** " I ($Y+5) >IOSL S IB QUIT=$$NOM ORE^IBCEF7 4() I IBQU IT G EX W !,"Billing Provider: ",BPNAME ; S BPNPI= $P(ORGNPI, U,3) I BPN PI="" S BP NPI="***MI SSING***" I ($Y+5)>I OSL S IBQU IT=$$NOMOR E^IBCEF74( ) I IBQUIT G EX W !? 5,"Billing Provider NPI: ",BPN PI ; S BPT AX=$$NOPUN CT^IBCEF($ P($G(^IBE( 350.9,1,1) ),U,5),1) I BPTAX="" S BPTAX=" ***MISSING ***" I ($Y +5)>IOSL S IBQUIT=$$ NOMORE^IBC EF74() I I BQUIT G EX W !?5,"Bi lling Prov ider Tax I D (VistA R ecord PRV) : ",BPTAX ; ; Displa y billing provider s econdary I D's (curre nt ins onl y) I ($Y+5 )>IOSL S I BQUIT=$$NO MORE^IBCEF 74() I IBQ UIT G EX W !?5,"Bill ing Provid er Seconda ry IDs (Vi stA Record CI1A):" S Z="BILLIN G PRV" D S ECID(Z,.IB QUIT) I IB QUIT G EX ; ; Now di splay the lab or fac ility prim ary and se condary ID s ; This i s the serv ice facili ty informa tion ; IB* 2*400 - ch eck to mak e sure the re is a se rvice faci lity ; I $ P(BPZ,U,3) ="" G LPRV ; no service fa cility inf ormation t o display ; ; Servic e facility name, sim ilar code as found i n SUB-2 I ($Y+5)>IOS L S IBQUIT =$$NOMORE^ IBCEF74() I IBQUIT G EX W !!," Service Fa cility Nam e and ID I nformation " ; ; MRD; IB*2.0*516 - Due to fields bei ng marked for deleti on, the ; function $ $SENDSF^IB CEF79 will always re turn '1'. Refer to ; that func tion and I NSFLGS^IBC EF79 for m ore inform ation. ; ; Display n ote if ins co flag t o suppress lab/fac d ata is set (only app lies in sw itchback m ode) ;I '$ $SENDSF^IB CEF79(IBIF N) D I IBQ UIT G EX ; . I ($Y+5) >IOSL S IB QUIT=$$NOM ORE^IBCEF7 4() Q:IBQU IT ;. W !! ,"Note: Se rvice Faci lity Data not sent f or Current Insurance " ;. W !," 'Send VA Lab/Facili ty IDs or Facility D ata for VA MC?' is se t to NO",! ;. Q ; S FACNAME=$$ GETFAC^IBC EP8(+$P(BP Z,U,4),$P( BPZ,U,3),0 ) I FACNAM E="" S FAC NAME="***M ISSING***" I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE^IBCEF74 () I IBQUI T G EX W ! ?5,"Facili ty: ",FACN AME ; S SF NPI=$P(ORG NPI,U,1) I SFNPI="" S SFNPI="* **MISSING* **" I ($Y+ 5)>IOSL S IBQUIT=$$N OMORE^IBCE F74() I IB QUIT G EX W !?5,"Lab or Facili ty NPI: ", SFNPI ; S SFTAX=$$NO PUNCT^IBCE F($$EIN^IB CEP8A(IBIF N),1) I SF TAX="" S S FTAX="***M ISSING***" I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE^IBCEF74 () I IBQUI T G EX W ! ?5,"Lab or Facility Tax ID (Vi stA Record SUB): ",S FTAX ; ; l ab/fac sec ondary IDs I ($Y+5)> IOSL S IBQ UIT=$$NOMO RE^IBCEF74 () I IBQUI T G EX W ! ?5,"Lab or Facility Secondary IDs (VistA Records S UB1,SUB2,O P3,OP6,OP7 ):" S Z="L AB/FAC" D SECID(Z,.I BQUIT) I I BQUIT G EX ;LPRV ;Se rvice Line Providers I '$D(IBI D("L-PROV" )) G EX ; No Line L evel Provi ders N IBS LC,IBN,CO, IBCODE,IBT YP,IBPRTYP ,Z0 S IBSL C=0 W !!," Service Li ne Provide rs" F S I BSLC=$O(IB ID("L-PROV ",IBIFN,IB SLC)) Q:'I BSLC D I IBQUIT Q . I ($Y+6) >IOSL S IB QUIT=$$NOM ORE^IBCEF7 4() I IBQU IT Q . W ! !?5,"Servi ce Line: " ,IBSLC . ; JWS;IB*2.0 *592; 6 - Assistant Surgeon . F IBPRTYP= 4,3,1,2,5, 6,9 I $D(I BID("L-PRO V",IBIFN,I BSLC,"C",1 ,IBPRTYP)) D ; Proc ess provid ers in ord er: Attend ing, Rende ring, Refe rring, Ope rating, Su pervising, Assistant Surgeon a nd Other O perating i f they exi st .. I ($ Y+5)>IOSL S IBQUIT=$ $NOMORE^IB CEF74() I IBQUIT Q . . W !?5,$$ EXTERNAL^D ILFD(399.0 404,.01,"" ,IBPRTYP), ": ",$$EXT ERNAL^DILF D(399.0404 ,.02,"",$P (IBID("L-P ROV",IBIFN ,IBSLC,"C" ,1,IBPRTYP ),U,1)) .. W !?8,"NP I:",?40,$S ($P(IBID(" L-PROV",IB IFN,IBSLC, "C",1,IBPR TYP,0),U,4 )]"":$P(IB ID("L-PROV ",IBIFN,IB SLC,"C",1, IBPRTYP,0) ,U,4),1:"* **MISSING* **") .. K IBTYP .. F CO="C","O " D ... F IBN=1,2 D .... F Z0= 1:1 Q:'$D( IBID("L-PR OV",IBIFN, IBSLC,CO,I BN,IBPRTYP ,Z0))!IBQU IT D .... . S IBCODE =$P(IBID(" L-PROV",IB IFN,IBSLC, CO,IBN,IBP RTYP,Z0),U ,9) ..... Q:$D(IBTYP (IBCODE)) ; 1st of e ach type t ransmits . .... I ($Y +5)>IOSL S IBQUIT=$$ NOMORE^IBC EF74() Q:I BQUIT .... . S IBTYP( IBCODE)="" ..... W ! ,?8,"(",IB ID("L-PROV ",IBIFN,IB SLC,CO,IBN ),") ",$$E XTERNAL^DI LFD(36,4.0 1,"",IBCOD E),?40,$P( IBID("L-PR OV",IBIFN, IBSLC,CO,I BN,IBPRTYP ,Z0),U,4) ;EX ; Q ;Q UAL(Z,FORM TYPE) ; tu rn the qua lifier cod e into a q ualifier d escription NEW QUAL, IEN S QUAL ="" I $G(Z )="" G QUA LX I Z="1C " D G QUA LX ; qua lifier for Medicare Part ? . I $G(FORMTY PE)=2 S QU AL="MEDICA RE PART B" ; 1500 . I $G(FOR MTYPE)=3 S QUAL="MED ICARE PART A" ; ub . Q I Z=3 4 S Z="SY" ; q ualifier f or SSN S I EN=+$O(^IB E(355.97," C",Z,"")) I 'IEN G Q UALX S QUA L=$P($G(^I BE(355.97, IEN,0)),U, 1)QUALX ; Q QUAL ;SE CID(Z,IBQU IT) ; Disp lay second ary ID and qualifier informati on ; Z is the type o f IDs pass ed in; eit her BILLIN G PRV or L AB/FAC ; I BQUIT is r eturned if passed by reference NEW SEQ,Z I,ZN,PSIN, DATA,QUALN M,IDNUM,NO DATA S IBQ UIT=0,NODA TA=1 F SEQ ="P","S"," T" D Q:IB QUIT . ; . ; current ins only for billin g provider secondary IDs . I Z ="BILLING PRV",SEQ'= $$COB^IBCE F(IBIFN) Q . S ZI="" . F S ZI =$O(IBX(Z, SEQ,ZI)) Q :ZI="" D Q:IBQUIT .. S ZN=0 .. F S ZN =$O(IBX(Z, SEQ,ZI,ZN) ) Q:'ZN D Q:IBQUIT ... S PSI N=0 ; star t at 0 to skip prima ry IDs ... ;*432/TAZ - Changed Q:PSIN="" to Q:'PSI N to preve nt "CONTAC TS" node f rom printi ng as seco ndary ID . .. F S PS IN=$O(IBID (Z,IBIFN,Z I,ZN,PSIN) ) Q:'PSIN D Q:IBQU IT .... S DATA=$G(IB ID(Z,IBIFN ,ZI,ZN,PSI N)) .... S QUALNM=$$ QUAL($P(DA TA,U,1),$$ FT^IBCEF(I BIFN)) ... . S IDNUM= $P(DATA,U, 2) .... I ($Y+5)>IOS L S IBQUIT =$$NOMORE^ IBCEF74() Q:IBQUIT . ... S NODA TA=0 .... W !?8,"(", SEQ,") ",Q UALNM,?40, IDNUM .... I Z="LAB/ FAC",$D(^D GCR(399,IB IFN,"I2")) ,SEQ=$$COB ^IBCEF(IBI FN) W ?54, "<<<Curren t Ins" ... . I Z="BIL LING PRV", PSIN=1 W ? 54,"<<<Sys tem Genera ted ID" .. .. Q ... Q .. Q . Q I NODATA,' IBQUIT W ! ?8,"(-) No ne Found"S ECIDX ; Q ; | |
| 1486 | ||
| 1487 | Routines | |
| 1488 | Activities | |
| 1489 | Routine Na me | |
| 1490 | IBCEF75 | |
| 1491 | Enhancemen t Category | |
| 1492 | New | |
| 1493 | Modify | |
| 1494 | Delete | |
| 1495 | No Change | |
| 1496 | RTM | |
| 1497 | ||
| 1498 | Related Op tions | |
| 1499 | None | |
| 1500 | Related Ro utines | |
| 1501 | Routines “ Called By” | |
| 1502 | Routines “ Called” | |
| 1503 | ||
| 1504 | ||
| 1505 | ||
| 1506 | ||
| 1507 | Data Dicti onary (DD) Reference s | |
| 1508 | ||
| 1509 | Related Pr otocols | |
| 1510 | None | |
| 1511 | Related In tegration Control Re gistration s (ICRs) | |
| 1512 | None | |
| 1513 | Data Passi ng | |
| 1514 | Input | |
| 1515 | Output Re ference | |
| 1516 | Both | |
| 1517 | Global Re ference | |
| 1518 | Local | |
| 1519 | Input Attr ibute Name and Defin ition | |
| 1520 | Name: | |
| 1521 | Definition : | |
| 1522 | Output Att ribute Nam e and Defi nition | |
| 1523 | Name: | |
| 1524 | Definition : | |
| 1525 | Current Lo gic | |
| 1526 | IBCEF75 ;A LB/WCJ - P rovider ID functions ;13 Feb 2 006 ;;2.0; INTEGRATED BILLING;* *320,371,4 00,432**;2 1-MAR-94;B uild 192 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ; G AWAYAWAY Q ;ALLIDS(I BIFN,IBXSA VE,IBSTRIP ,SEG) ; Re turn all o f the Prov ider IDS I '$D(IBST RIP) S IBS TRIP=0 I ' $D(SEG) S SEG="" N I BXIEN,ARIN FO,ARID,AR Q,IBFRMTYP ,ARIEN,ARI NS,Z0,DAT, I,SORT1,SO RT2,SORT3, COB,IBCCOB ; S IBXIE N=IBIFN D ALLPROV^IB CEF7 ; Get the Perso n ID's (Re turns IBXS AVE) S DAT =$$PROVID^ IBCEF73(IB IFN) S DAT ("QUAL")=I BXSAVE("ID ") ; this value was also passe d back by above func tion S SOR T1="" F S SORT1=$O( IBXSAVE("P ROVINF",IB IFN,SORT1) ) Q:SORT1= "" D . S SORT2=0 F S SORT2=$ O(IBXSAVE( "PROVINF", IBIFN,SORT 1,SORT2)) Q:SORT2="" D .. S S ORT3=0 F S SORT3=$O (IBXSAVE(" PROVINF",I BIFN,SORT1 ,SORT2,SOR T3)) Q:SOR T3="" D . .. ;*432/T AZ - Prima ry node no w points t o NPI ... N IBPRVPTR ,IBNPI ... S IBPRVPT R=IBXSAVE( "PROVINF", IBIFN,SORT 1,SORT2,SO RT3),IBNPI =$$GETNPI^ IBCEF73A(I BPRVPTR) . .. S IBXSA VE("PROVIN F",IBIFN,S ORT1,SORT2 ,SORT3,0)= "PRIMARY"_ U_U_$$STRI P^IBCEF76( $S(IBNPI]" ":"XX",1:" ")_U_IBNPI ,1,U,IBSTR IP) ... F I=1:1 Q:'$ D(IBXSAVE( "PROVINF", IBIFN,SORT 1,SORT2,SO RT3,I)) D .... S $P( IBXSAVE("P ROVINF",IB IFN,SORT1, SORT2,SORT 3,I),U,3,4 )=$$STRIP^ IBCEF76($P (IBXSAVE(" PROVINF",I BIFN,SORT1 ,SORT2,SOR T3,I),U,3, 4),1,U,IBS TRIP) ; D LFIDS^IBCE F76(IBIFN, .IBXSAVE,I BSTRIP,SEG ) ; Get th e Lab/Faci lity IDs ; S IBFRMTY P=$$FT^IBC EF(IBIFN) S ARIEN=$S (IBFRMTYP= 2:3,1:4) S IBCCOB=$$ COBN^IBCEF (IBIFN) ; Current In surance F COB=1:1:3 D . S SORT 1=$S(COB=I BCCOB:"C", 1:"O") . S SORT2=$S( SORT1="C": 1,COB=1:1, COB=2&(IBC COB=1):1,1 :2) . S AR INFO=$G(IB XSAVE("PRO VINF",IBIF N,SORT1,SO RT2,ARIEN, 1)) . ; . D BPIDS(IB IFN,.IBXSA VE,SORT1,S ORT2,COB,I BSTRIP,SEG ) Q ; BPID S(IBIFN,ID S,SORT1,SO RT2,COB,IB STRIP,SEG) ; Get all the billi ng provide r IDs and qualifiers from the claim and file 355.9 2 N DAT,IB FRMTYP,IBC ARE,IBDIV, IBINS,MAIN ,IBCCOB,US ED,PLANTYP E,I,CNT,QU AL,ARF,M1, DEF,IDDIV, IBLIMIT,IE N,ID,IB2 ; S DAT=$G( ^DGCR(399, IBIFN,0)) S IBFRMTYP =$$FT^IBCE F(IBIFN),I BFRMTYP=$S (IBFRMTYP= 2:2,IBFRMT YP=3:1,1:0 ) S IBCARE =$S($$ISRX ^IBCEF1(IB IFN):3,1:0 ) ;if an R x refill b ill S:IBCA RE=0 IBCAR E=$$INPAT^ IBCEF(IBIF N) S:'IBCA RE IBCARE= 2 ;1-inp,2 -out S IBD IV=+$P(DAT ,U,22) S M AIN=$$MAIN ^IBCEP2B() ; get the IEN for m ain Divisi on S IBCCO B=$$COBN^I BCEF(IBIFN ) ; Curren t Insuranc e S IBINS= $P($G(^DGC R(399,IBIF N,"I"_COB) ),U) Q:IBI NS="" ; S IDS("BILLI NG PRV",IB IFN,SORT1, SORT2)=$E( "PST",COB) ; ; Prima ry ID S ID S("BILLING PRV",IBIF N,SORT1,SO RT2,0)=$$S TRIP^IBCEF 76($$TAXID (),1,U,IBS TRIP) S US ED($P(IDS( "BILLING P RV",IBIFN, SORT1,SORT 2,0),U))=" " ; ; Seco ndary #1 - This is t he ID Emde on uses fo r sorting S IDS("BIL LING PRV", IBIFN,SORT 1,SORT2,1) =$$STRIP^I BCEF76($$B PSID1(IBDI V),1,U,IBS TRIP) S US ED($P(IDS( "BILLING P RV",IBIFN, SORT1,SORT 2,1),U))=" " ; ; Chec k if this is a plan type which gets no s econdary I Ds S M1=$G (^DGCR(399 ,IBIFN,"M1 ")) ; the following check is t he current value of the flag, not when t he claim w as created . S PLANT YPE=$$POLT YP^IBCEF3( IBIFN,COB) I PLANTYP E]"",$D(^D IC(36,IBIN S,13,"B",P LANTYPE)) Q ; ; Sec ondary #2 ; If there is a ID s end with q uailifer ( stored or computed) I $TR($P(M 1,U,COB+1) ," ")]"" D . S QUAL= "" . S DAT =$P(M1,U,C OB+9) . I DAT S QUAL =$$STRIP^I BCEF76($P( $G(^IBE(35 5.97,DAT,0 )),U,3),1, ,IBSTRIP) . ; the nu ll check i s needed t o be backw ards compa tible . I QUAL=""!(Q UAL="1J") S QUAL=$$S TRIP^IBCEF 76($$OLDWA Y(IBIFN,CO B),1,,IBST RIP) . S I B2=QUAL_U_ $$STRIP^IB CEF76($P(M 1,U,COB+1) ,1,,IBSTRI P) ; ;WCJ; IB*2.0*432 ;START ;I $TR($P(M1, U,COB+1)," ")="" S I B2=$$STRIP ^IBCEF76($ $OLDWAY(IB IFN,COB),1 ,,IBSTRIP) _U_$$STRIP ^IBCEF76($ $GET1^DIQ( 350.9,1,1. 05),1,,IBS TRIP) ; I $G(IB2)]"" ,$P(IB2,U) ]"",$P(IB2 ,U,2)]"" D ;TAZ - C hanged $G( IB2) to $G (IB2)]"" . S IDS("BI LLING PRV" ,IBIFN,SOR T1,SORT2,2 )=IB2 . ;S IDS("BILL ING PRV",I BIFN,SORT1 ,SORT2,2," PTQ")=$$OL DWAY(IBIFN ,COB) . S USED($P(IB 2,U))="" ; WCJ;IB*2.0 *432 ; S C NT=$S('$D( IDS("BILLI NG PRV",IB IFN,SORT1, SORT2,2)): 2,1:3) S I BLIMIT=8 S IEN=0 F S IEN=$O(^ IBA(355.92 ,"B",IBINS ,IEN)) Q:I EN="" D Q:CNT>IBLI MIT . S DA T=$G(^IBA( 355.92,IEN ,0)) . Q:$ P(DAT,U,8) '="A" ; only allow additiona l IDs . Q: $P(DAT,U,7 )="" ; No Provider ID . Q:$P( DAT,U,6)=" " ; No ID Qualifier . I IBFRM TYP=1 Q:$P (DAT,U,4)= 2 . I IBFR MTYP=2 Q:$ P(DAT,U,4) =1 . ; . ; Check if we already have one of these . S QUAL=$$ STRIP^IBCE F76($P(DAT ,U,6),1,,I BSTRIP) . S QUAL=$P( $G(^IBE(35 5.97,QUAL, 0)),U,3) . Q:QUAL="" . Q:$D(US ED(QUAL)) . ; . S ID S("BILLING PRV",IBIF N,SORT1,SO RT2,CNT)=Q UAL_U_$$ST RIP^IBCEF7 6($P(DAT,U ,7),1,,IBS TRIP) . S CNT=CNT+1, USED(QUAL) ="" ; Q ;O LDWAY(IBIF N,COB) ; F igure out the qualif ier the ol d way if i t's not st ored with the claim. ; It's ba sed on the plan type . This is used for B illing Pro vider Seco ndary ID # 2 N PLANTY PE S PLANT YPE=$$POLT YP^IBCEF3( IBIFN,COB) Q $$SOP^I BCEP2B(IBI FN,PLANTYP E) ;BPSID1 (DIV) ; Re turn the B illing Pro vider Seco ndary ID # 1 and qual ifier whic h Emdeon u ses to sor t IBIFNs N DATA S DA TA=$P($$SI TE^VASITE( DT,$S(DIV: DIV,1:+$$P RIM^VASITE (DT))),U,3 ) S DATA=$ E("0000",1 ,7-$L(DATA ))_$E(DATA ,4,7) Q "G 5"_U_DATA ;TAXID() ; Return th e Billing Provider P rimary ID and qualif ier which is the TAX ID for the site and also the q ualifier N DATA S DA TA=$P($G(^ IBE(350.9, 1,1)),U,5) S DATA=$$ NOPUNCT^IB CEF(DATA,1 ) Q 24_U_D ATA ;CLEAN UP(IBXSAVE ) ; Clean up K IBXS AVE("PROVI NF") K IBX SAVE("LAB/ FAC") K IB XSAVE("BIL LING PRV") K IBXSAVE ("ID") Q | |
| 1527 | Modified L ogic (Chan ges are in bold) | |
| 1528 | IBCEF75 ;A LB/WCJ - P rovider ID functions ;13 Feb 2 006 ;;2.0; INTEGRATED BILLING;* *320,371,4 00,432,592 **;21-MAR- 94;Build 1 92 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; G AWAYAW AY Q ;ALLI DS(IBIFN,I BXSAVE,IBS TRIP,SEG) ; Return a ll of the Provider I DS I '$D( IBSTRIP) S IBSTRIP=0 I '$D(SEG ) S SEG="" N IBXIEN, ARINFO,ARI D,ARQ,IBFR MTYP,ARIEN ,ARINS,Z0, DAT,I,SORT 1,SORT2,SO RT3,COB,IB CCOB ; S I BXIEN=IBIF N D ALLPRO V^IBCEF7 ; Get the P erson ID's (Returns IBXSAVE) S DAT=$$PRO VID^IBCEF7 3(IBIFN) S DAT("QUAL ")=IBXSAVE ("ID") ; t his value was also p assed back by above function S SORT1="" F S SORT1 =$O(IBXSAV E("PROVINF ",IBIFN,SO RT1)) Q:SO RT1="" D . S SORT2= 0 F S SOR T2=$O(IBXS AVE("PROVI NF",IBIFN, SORT1,SORT 2)) Q:SORT 2="" D .. S SORT3=0 F S SORT 3=$O(IBXSA VE("PROVIN F",IBIFN,S ORT1,SORT2 ,SORT3)) Q :SORT3="" D ... ;*4 32/TAZ - P rimary nod e now poin ts to NPI ... N IBPR VPTR,IBNPI ... S IBP RVPTR=IBXS AVE("PROVI NF",IBIFN, SORT1,SORT 2,SORT3),I BNPI=$$GET NPI^IBCEF7 3A(IBPRVPT R) ... S I BXSAVE("PR OVINF",IBI FN,SORT1,S ORT2,SORT3 ,0)="PRIMA RY"_U_U_$$ STRIP^IBCE F76($S(IBN PI]"":"XX" ,1:"")_U_I BNPI,1,U,I BSTRIP) .. . F I=1:1 Q:'$D(IBXS AVE("PROVI NF",IBIFN, SORT1,SORT 2,SORT3,I) ) D .... S $P(IBXSAV E("PROVINF ",IBIFN,SO RT1,SORT2, SORT3,I),U ,3,4)=$$ST RIP^IBCEF7 6($P(IBXSA VE("PROVIN F",IBIFN,S ORT1,SORT2 ,SORT3,I), U,3,4),1,U ,IBSTRIP) ; D LFIDS^ IBCEF76(IB IFN,.IBXSA VE,IBSTRIP ,SEG) ; Ge t the Lab/ Facility I Ds ; S IBF RMTYP=$$FT ^IBCEF(IBI FN) ;JWS;I B*2.0*592; Dental fo rm 7 S ARI EN=$S(IBFR MTYP=2:3,I BFRMTYP=7: 3,1:4) S I BCCOB=$$CO BN^IBCEF(I BIFN) ; Cu rrent Insu rance F CO B=1:1:3 D . S SORT1= $S(COB=IBC COB:"C",1: "O") . S S ORT2=$S(SO RT1="C":1, COB=1:1,CO B=2&(IBCCO B=1):1,1:2 ) . S ARIN FO=$G(IBXS AVE("PROVI NF",IBIFN, SORT1,SORT 2,ARIEN,1) ) . ; . D BPIDS(IBIF N,.IBXSAVE ,SORT1,SOR T2,COB,IBS TRIP,SEG) Q ; BPIDS( IBIFN,IDS, SORT1,SORT 2,COB,IBST RIP,SEG) ; Get all t he billing provider IDs and qu alifiers f rom the cl aim and fi le 355.92 N DAT,IBFR MTYP,IBCAR E,IBDIV,IB INS,MAIN,I BCCOB,USED ,PLANTYPE, I,CNT,QUAL ,ARF,M1,DE F,IDDIV,IB LIMIT,IEN, ID,IB2 ; S DAT=$G(^D GCR(399,IB IFN,0)) ;J WS;IB*2.0* 592;Dental form 7 S IBFRMTYP=$ $FT^IBCEF( IBIFN),IBF RMTYP=$S(I BFRMTYP=2: 2,IBFRMTYP =7:4,IBFRM TYP=3:1,1: 0) S IBCAR E=$S($$ISR X^IBCEF1(I BIFN):3,1: 0) ;if an Rx refill bill S:IBC ARE=0 IBCA RE=$$INPAT ^IBCEF(IBI FN) S:'IBC ARE IBCARE =2 ;1-inp, 2-out S IB DIV=+$P(DA T,U,22) S MAIN=$$MAI N^IBCEP2B( ) ; get th e IEN for main Divis ion S IBCC OB=$$COBN^ IBCEF(IBIF N) ; Curre nt Insuran ce S IBINS =$P($G(^DG CR(399,IBI FN,"I"_COB )),U) Q:IB INS="" ; S IDS("BILL ING PRV",I BIFN,SORT1 ,SORT2)=$E ("PST",COB ) ; ; Prim ary ID S I DS("BILLIN G PRV",IBI FN,SORT1,S ORT2,0)=$$ STRIP^IBCE F76($$TAXI D(),1,U,IB STRIP) S U SED($P(IDS ("BILLING PRV",IBIFN ,SORT1,SOR T2,0),U))= "" ; ; Sec ondary #1 - This is the ID Emd eon uses f or sorting S IDS("BI LLING PRV" ,IBIFN,SOR T1,SORT2,1 )=$$STRIP^ IBCEF76($$ BPSID1(IBD IV),1,U,IB STRIP) S U SED($P(IDS ("BILLING PRV",IBIFN ,SORT1,SOR T2,1),U))= "" ; ; Che ck if this is a plan type whic h gets no secondary IDs S M1=$ G(^DGCR(39 9,IBIFN,"M 1")) ; the following check is the curren t value of the flag, not when the claim was create d. S PLAN TYPE=$$POL TYP^IBCEF3 (IBIFN,COB ) I PLANTY PE]"",$D(^ DIC(36,IBI NS,13,"B", PLANTYPE)) Q ; ; Se condary #2 ; If ther e is a ID send with quailifer (stored or computed) I $TR($P( M1,U,COB+1 )," ")]"" D . S QUAL ="" . S DA T=$P(M1,U, COB+9) . I DAT S QUA L=$$STRIP^ IBCEF76($P ($G(^IBE(3 55.97,DAT, 0)),U,3),1 ,,IBSTRIP) . ; the n ull check is needed to be back wards comp atible . I QUAL=""!( QUAL="1J") S QUAL=$$ STRIP^IBCE F76($$OLDW AY(IBIFN,C OB),1,,IBS TRIP) . S IB2=QUAL_U _$$STRIP^I BCEF76($P( M1,U,COB+1 ),1,,IBSTR IP) ; ;WCJ ;IB*2.0*43 2;START ;I $TR($P(M1 ,U,COB+1), " ")="" S IB2=$$STRI P^IBCEF76( $$OLDWAY(I BIFN,COB), 1,,IBSTRIP )_U_$$STRI P^IBCEF76( $$GET1^DIQ (350.9,1,1 .05),1,,IB STRIP) ; I $G(IB2)]" ",$P(IB2,U )]"",$P(IB 2,U,2)]"" D ;TAZ - Changed $G (IB2) to $ G(IB2)]"" . S IDS("B ILLING PRV ",IBIFN,SO RT1,SORT2, 2)=IB2 . ; S IDS("BIL LING PRV", IBIFN,SORT 1,SORT2,2, "PTQ")=$$O LDWAY(IBIF N,COB) . S USED($P(I B2,U))="" ;WCJ;IB*2. 0*432 ; S CNT=$S('$D (IDS("BILL ING PRV",I BIFN,SORT1 ,SORT2,2)) :2,1:3) S IBLIMIT=8 S IEN=0 F S IEN=$O( ^IBA(355.9 2,"B",IBIN S,IEN)) Q: IEN="" D Q:CNT>IBL IMIT . S D AT=$G(^IBA (355.92,IE N,0)) . Q: $P(DAT,U,8 )'="A" ; only allo w addition al IDs . Q :$P(DAT,U, 7)="" ; N o Provider ID . Q:$P (DAT,U,6)= "" ; No I D Qualifie r . ;JWS;I B*2.0*592; exclude de ntal now . I IBFRMTY P=1 Q:$P(D AT,U,4)=2 Q:$P(DAT,U ,4)=4 . I IBFRMTYP=2 Q:$P(DAT, U,4)=1 Q:$ P(DAT,U,4) =4 . ;JWS; IB*2.0*592 ;Dental fo rm . I IBF RMTYP=4 Q: $P(DAT,U,4 )=1 Q:$P(D AT,U,4)=2 . ; . ; Ch eck if we already ha ve one of these . S QUAL=$$STR IP^IBCEF76 ($P(DAT,U, 6),1,,IBST RIP) . S Q UAL=$P($G( ^IBE(355.9 7,QUAL,0)) ,U,3) . Q: QUAL="" . Q:$D(USED( QUAL)) . ; . S IDS(" BILLING PR V",IBIFN,S ORT1,SORT2 ,CNT)=QUAL _U_$$STRIP ^IBCEF76($ P(DAT,U,7) ,1,,IBSTRI P) . S CNT =CNT+1,USE D(QUAL)="" ; Q ;OLDW AY(IBIFN,C OB) ; Figu re out the qualifier the old w ay if it's not store d with the claim. ; It's based on the pl an type. T his is use d for Bill ing Provid er Seconda ry ID #2 N PLANTYPE S PLANTYPE =$$POLTYP^ IBCEF3(IBI FN,COB) Q $$SOP^IBCE P2B(IBIFN, PLANTYPE) ;BPSID1(DI V) ; Retur n the Bill ing Provid er Seconda ry ID #1 a nd qualifi er which E mdeon uses to sort I BIFNs N DA TA S DATA= $P($$SITE^ VASITE(DT, $S(DIV:DIV ,1:+$$PRIM ^VASITE(DT ))),U,3) S DATA=$E(" 0000",1,7- $L(DATA))_ $E(DATA,4, 7) Q "G5"_ U_DATA ;TA XID() ; Re turn the B illing Pro vider Prim ary ID and qualifier which is the TAXID for the si te and als o the qual ifier N DA TA S DATA= $P($G(^IBE (350.9,1,1 )),U,5) S DATA=$$NOP UNCT^IBCEF (DATA,1) Q 24_U_DATA ;CLEANUP( IBXSAVE) ; Clean up K IBXSAVE ("PROVINF" ) K IBXSAV E("LAB/FAC ") K IBXSA VE("BILLIN G PRV") K IBXSAVE("I D") Q | |
| 1529 | ||
| 1530 | Routines | |
| 1531 | Activities | |
| 1532 | Routine Na me | |
| 1533 | IBCEF76 | |
| 1534 | Enhancemen t Category | |
| 1535 | New | |
| 1536 | Modify | |
| 1537 | Delete | |
| 1538 | No Change | |
| 1539 | RTM | |
| 1540 | ||
| 1541 | Related Op tions | |
| 1542 | None | |
| 1543 | Related Ro utines | |
| 1544 | Routines “ Called By” | |
| 1545 | Routines “ Called” | |
| 1546 | ||
| 1547 | ||
| 1548 | ||
| 1549 | ||
| 1550 | Data Dicti onary (DD) Reference s | |
| 1551 | ||
| 1552 | Related Pr otocols | |
| 1553 | None | |
| 1554 | Related In tegration Control Re gistration s (ICRs) | |
| 1555 | None | |
| 1556 | Data Passi ng | |
| 1557 | Input | |
| 1558 | Output Re ference | |
| 1559 | Both | |
| 1560 | Global Re ference | |
| 1561 | Local | |
| 1562 | Input Attr ibute Name and Defin ition | |
| 1563 | Name: | |
| 1564 | Definition : | |
| 1565 | Output Att ribute Nam e and Defi nition | |
| 1566 | Name: | |
| 1567 | Definition : | |
| 1568 | Current Lo gic | |
| 1569 | IBCEF76 ;A LB/WCJ - P rovider ID functions ;13 Feb 2 006 ;;2.0; INTEGRATED BILLING;* *320,349,4 00,432,516 **;21-MAR- 94;Build 1 23 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ; G A WAYAWAY Q ;LFIDS(IBI FN,IDS,IBS TRIP,SEG) ; ; Pass i n the the internal c laim numbe r and retu rn the arr ay of IDS. ; IDS("C" urrent or "O"ther, O rder of In surance wi thin subsc ript 1, or der of ID within sub script 2) ; IDS("C", 1)="P" ; I DS("C",1,0 )=Qualifie r^Primary ID ; IDS(" C",1,1)=Qu alifier^Se c ID #1 ; IDS("C",1, 2)=Qualifi er^Sec ID #2 ; N DAT ,IBFRMTYP, IBCARE,IBD IV,IBINS,O UTFAC,MAIN ,IBCCOB,TM PIDS,COB,I BSORT1,IBS ORT2,IBLIM IT,IBLF ; S DAT=$G(^ DGCR(399,I BIFN,0)) S IBFRMTYP= $$FT^IBCEF (IBIFN),IB FRMTYP=$S( IBFRMTYP=2 :2,IBFRMTY P=3:1,1:0) S IBCARE= $S($$ISRX^ IBCEF1(IBI FN):3,1:0) ;if an Rx refill bi ll S:IBCAR E=0 IBCARE =$$INPAT^I BCEF(IBIFN ) S:'IBCAR E IBCARE=2 ;1-inp,2- out S IBDI V=+$P(DAT, U,22) S OU TFAC=$P($G (^DGCR(399 ,IBIFN,"U2 ")),U,10) S MAIN=$$M AIN^IBCEP2 B() ; get the IEN fo r main Div ision ; S IBCCOB=$$C OBN^IBCEF( IBIFN) F C OB=1:1:3 D . S IBSOR T1=$S(COB= IBCCOB:"C" ,1:"O") . S IBSORT2= $S(IBSORT1 ="C":1,COB =1:1,COB=2 &(IBCCOB=1 ):1,1:2) . S IBLIMIT =$S(IBSORT 1="C":5,1: 3) ; Limit secondary IDs . S D AT=$G(^DGC R(399,IBIF N,"I"_COB) ) . ; . S IBINS=$P(D AT,U) ; in surance PT R 36 . Q:I BINS="" . ; . ; IB*2 *400 - esg - 9/24/08 , 2/24/09 - if there is no ser vice facil ity for th is claim a t this COB , then get out . S I BLF=$$B^IB CEF79(IBIF N,COB) ; b illing pro vider/serv ice facili ty functio n . I $P(I BLF,U,3)=" " Q ; no servi ce facilit y data at this COB, don't buil d this "LA B/FAC" are a . ; . I OUTFAC]"" D Q .. D NONVALF(IB IFN,OUTFAC _";IBA(355 .93,",IBIN S,IBFRMTYP ,IBCARE,.I DS,IBSORT1 ,IBSORT2,C OB,IBLIMIT ,IBSTRIP,S EG) . ; . I OUTFAC=" " D .. ; . . ; MRD;IB *2.0*516 - Due to fi elds being marked fo r deletion , the .. ; function $$SENDSF^I BCEF79 wil l always r eturn '1'. Refer to .. ; that function a nd INSFLGS ^^IBCEF79 for more i nformation . .. ; .. ; if ins c o flag say s to not s end svc fa c data and we're sen ding an ED I claim, t hen get ou t .. ;I '$ $SENDSF^IB CEF79(IBIF N,COB),$G( ^TMP("IBTX ",$J,IBIFN )) Q .. ; .. ;IB*2.0 *432/TAZ M oved Taxid setup ins ide VALF l ook to sen d as secon dary ID fo r Medicare claims. . . ;S IDS(" LAB/FAC",I BIFN,IBSOR T1,IBSORT2 ,0)=$$STRI P($$TAXID^ IBCEF75(), 1,U,IBSTRI P) .. D VA LF(IBIFN,I BINS,IBFRM TYP,IBDIV, .IDS,IBSOR T1,IBSORT2 ,COB,IBLIM IT,IBSTRIP ,SEG) Q ;V ALF(IBIFN, INS,FT,DIV ,IDS,SORT1 ,SORT2,COB ,IBLIMIT,I BSTRIP,SEG ) ; Get VA Lab/Fac S econdary I Ds ; Pass in INS - I EN to file 36 ; FT - 1 = UB 2 = 1500 ; D IV - PTR t o 40.8 ; N Z,Z0,ID,Q UAL,MAIN,I DTBL,CNT,Z ,IBMCR S M AIN=$$MAIN ^IBCEP2B() ; get the IEN for m ain Divisi on S Z=0 F S Z=$O(^ IBA(355.92 ,"B",INS,Z )) Q:'Z D . S Z0=$G (^IBA(355. 92,Z,0)) . Q:$P(Z0,U ,8)'="LF" ; Screen out anyth ing other than Lab o r Facility . I +$P(Z 0,U,4) Q:$ P(Z0,U,4)' =FT ; Fo rm type mu st match t hat passed in or be a 0 which allows bot h . S ID=$ $STRIP($P( Z0,U,7),1, ,IBSTRIP) . S QUAL=$ $STRIP($P( Z0,U,6),1, ,IBSTRIP) . Q:QUAL=" " ; Need s a qualif ier . S QU AL=$P($G(^ IBE(355.97 ,QUAL,0)), U,3) . I F T=1,SORT1= "O" Q:$$OP 3^IBCEF73( FT)'[(U_QU AL_U) ; In stitutiona l . I FT=2 ,SORT1="O" Q:$$OP7^I BCEF73(FT) '[(U_QUAL_ U) ; Profe ssional . I $P(Z0,U, 5)=""!($P( Z0,U,5)=0) !($P(Z0,U, 5)=MAIN) S IDTBL("DE F",QUAL)=I D ; set u p default for main d ivision . I $P(Z0,U, 5)=DIV S I DTBL("DIV" ,QUAL)=ID ; set up default fo r division S CNT=0 S IDS("LAB/ FAC",IBIFN ,SORT1,SOR T2)=$E("PS T",COB) ;I B*2.0*432/ TAZ If Med icare send Tax ID as 1st Secon dary ID ; only if it 's not a p rinted for m S IBMCR= "" I '(($G (IBXFORM)= 2)!($G(IBX FORM)=3)) S IBMCR=$$ MCRONBIL^I BEFUNC(IBI FN) I IBMC R S CNT=CN T+1,IDS("L AB/FAC",IB IFN,SORT1, SORT2,CNT) ="LU"_U_$$ STRIP($P($ $TAXID^IBC EF75(),U,2 ),1,U,IBST RIP) I $D( IDTBL("DIV ")) D Q . S Z="" F S Z=$O(ID TBL("DIV", Z)) Q:Z="" D .. ;IB *2.0*432/T AZ If Medi care, scre en out Tax ID .. I I BMCR,(Z=24 ) Q .. S C NT=CNT+1,I DS("LAB/FA C",IBIFN,S ORT1,SORT2 ,CNT)=Z_U_ IDTBL("DIV ",Z) Q:CNT =IBLIMIT I $D(IDTBL( "DEF")) D Q . S Z=" " F S Z=$ O(IDTBL("D EF",Z)) Q: Z="" D .. ;IB*2.0*4 32/TAZ If Medicare, screen out Tax ID .. I IBMCR,( Z=24) Q .. S CNT=CNT +1,IDS("LA B/FAC",IBI FN,SORT1,S ORT2,CNT)= Z_U_IDTBL( "DEF",Z) Q :CNT=IBLIM IT Q ;NONV ALF(IBIFN, PRV,INS,FT ,PT,IDS,SO RT1,SORT2, COB,IBLIMI T,IBSTRIP, SEG) ; Get Non VA La b/Fac Seco ndary IDs ; Pass in PRV - VPTR - PTR to 355.93 (in format of variabel pointer IE N;IBA(355. 93, ; Pass in INS - PTR to 36 of null (n ot provide by insura nce compan y) ; FT - 1 = UB 2 = 1500 ; PT - Patient Type - 1 inpatient 2 outpatie nt ; IDS a rray being returned ; SORT1 - "C"urrent or "O"ther ; SORT2 - 1 if curr ent or (1 or 2 if ot her) N Z,Z 0,ID,QUAL, IDTBL,CNT, IBMCR S Z= 0 F S Z=$ O(^IBA(355 .9,"B",PRV ,Z)) Q:'Z D . S Z0= $G(^IBA(35 5.9,Z,0)) . I +$P(Z0 ,U,4) Q:$P (Z0,U,4)'= FT ; For m type mus t match th at passed in or be a 0 which a llows both UB and 15 00 . I +$P (Z0,U,5) Q :$P(Z0,U,5 )'=PT ; Patient ty pe must ma tch that p assed in o r be a 0 w hich allow s both in patient an d outpatie nt . I INS ]"",$P(Z0, U,2)]"",IN S'=$P(Z0,U ,2) Q . S ID=$$STRIP ($P(Z0,U,7 ),1,,IBSTR IP) . Q:ID ="" . S QU AL=$$STRIP ($P(Z0,U,6 ),1,,IBSTR IP) . Q:QU AL="" ; Needs a qu alifier . S QUAL=$P( $G(^IBE(35 5.97,QUAL, 0)),U,3) . Q:QUAL="" . I FT=1, SORT1="O" Q:$$OP3^IB CEF73(FT)' [(U_QUAL_U ) ; Instit utional . I FT=2,SOR T1="O" Q:$ $OP7^IBCEF 73(FT)'[(U _QUAL_U) ; Professio nal . I $G (SEG)="SUB 1" Q:$$SUB 1^IBCEF73( FT)'[(U_QU AL_U) . I $P(Z0,U,2) ="" S IDTB L("OWN",QU AL)=ID ; set up def ault of la b or facil ities own ids . I $P (Z0,U,2)=I NS S IDTBL ("INS",QUA L)=ID ; s et up defa ult for di vision ; S CNT=0 S I DS("LAB/FA C",IBIFN,S ORT1,SORT2 )=$E("PST" ,COB)_U_PR V S IDS("L AB/FAC",IB IFN,SORT1, SORT2,"CON TACT")=$G( ^IBA(355.9 3,+PRV,1)) ; get pri mary S Z0= $G(^IBA(35 5.93,+PRV, 0)) ;IB*2. 0*432/TAZ If Medicar e send Tax ID as 1st Secondary ID S IBMC R="" I '(( $G(IBXFORM )=2)!($G(I BXFORM)=3) ) S IBMCR= $$MCRONBIL ^IBEFUNC(I BIFN) ;I $ P(Z0,U,9)] "",$P(Z0,U ,13)]"",IB MCR S CNT= CNT+1,IDS( "LAB/FAC", IBIFN,SORT 1,SORT2,CN T)="LU"_U_ $$STRIP($P ($G(^IBE(3 55.97,$P(Z 0,U,13),0) ),U,3)_U_$ P(Z0,U,9), 1,U,IBSTRI P) I $P(Z0 ,U,9)]"",$ P(Z0,U,13) ]"",IBMCR S CNT=CNT+ 1,IDS("LAB /FAC",IBIF N,SORT1,SO RT2,CNT)=" LU"_U_$$ST RIP($P(Z0, U,9),1,U,I BSTRIP) ; get second arys in or der I $D(I DTBL("INS" )) D . N Z S Z="" F S Z=$O(ID TBL("INS", Z)) Q:Z="" D .. ;IB *2.0*432/T AZ If Medi care, scre en out Tax ID .. I I BMCR,(Z=24 ) Q .. S C NT=CNT+1,I DS("LAB/FA C",IBIFN,S ORT1,SORT2 ,CNT)=Z_U_ IDTBL("INS ",Z) Q:CNT =IBLIMIT I $D(IDTBL( "OWN")),CN T'=IBLIMIT D . N Z S Z="" F S Z=$O(IDTB L("OWN",Z) ) Q:Z="" D .. ;IB*2 .0*432/TAZ If Medica re, screen out Tax I D .. I IBM CR,(Z=24) Q .. I '$D (IDTBL("IN S",Z)) S C NT=CNT+1,I DS("LAB/FA C",IBIFN,S ORT1,SORT2 ,CNT)=Z_U_ IDTBL("OWN ",Z) Q:CNT =IBLIMIT Q ;STRIP(X, SPACE,EXC, IBSTRIP) ; ; Strip p unctuation from data in X ; SP ACE = flag if 1 stri p SPACES ; EXC = lis t of punct not to st rip ; Q:' $G(IBSTRIP ) X Q $$NO PUNCT^IBCE F(X,$G(SPA CE),$G(EXC )) ;OTH(IB IFN,IBXSAV E,IBXDATA, COND,SEG) ; Procedur e used in piece 2 of some outp ut ; forma tter segme nts for ot her insura nce ; COND = 0/1 val ue passed in that de termines w hether or not to cal l the ; pr ovider ID function ; SEG = nam e of segme nt for use in callin g ID^IBCEF 2 (4 chara cters) ; N Z ;*432/T AZ - Chang ed Clean u p and Setu p routines to IBCEFP * ;D CLEAN UP^IBCEF75 (.IBXSAVE) ;I COND D ALLIDS^IB CEF75(IBIF N,.IBXSAVE ,1) D CLEA NUP^IBCEFP 1(.IBXSAVE ) I COND D ALLIDS^IB CEFP(IBIFN ,.IBXSAVE, 1) ; ; Spe cial Check : if Other Insurance #2 has se condary ID 's while O ther ; Ins urance #1 does not, then move up #2 to b e #1 here. This is t o ; ensure the outpu t formatte r IBXDATA array is b uilt prope rly. ; I $ O(IBXSAVE( "LAB/FAC", IBIFN,"O", 2,0)),'$O( IBXSAVE("L AB/FAC",IB IFN,"O",1, 0)) D . K IBXSAVE("L AB/FAC",IB IFN,"O",1) . M IBXSA VE("LAB/FA C",IBIFN," O",1)=IBXS AVE("LAB/F AC",IBIFN, "O",2) . K IBXSAVE(" LAB/FAC",I BIFN,"O",2 ) . Q ; K IBXDATA S Z=0 F S Z =$O(IBXSAV E("LAB/FAC ",IBIFN,"O ",Z)) Q:'Z D . I '$ O(IBXSAVE( "LAB/FAC", IBIFN,"O", Z,0)) Q . S IBXDATA( Z)=$P($G(I BXSAVE("LA B/FAC",IBI FN,"O",Z)) ,U,1) . I Z>1 D ID^I BCEF2(Z,SE G) . QOTHX ; Q ; | |
| 1570 | Modified L ogic (Chan ges are in bold) | |
| 1571 | IBCEF76 ;A LB/WCJ - P rovider ID functions ;13 Feb 2 006 ;;2.0; INTEGRATED BILLING;* *320,349,4 00,432,516 ,592**;21- MAR-94;Bui ld 123 ;;P er VA Dire ctive 6402 , this rou tine shoul d not be m odified. ; G AWAYAWA Y Q ;LFIDS (IBIFN,IDS ,IBSTRIP,S EG) ; ; Pa ss in the the intern al claim n umber and return the array of IDS. ; IDS ("C"urrent or "O"the r, Order o f Insuranc e within s ubscript 1 , order of ID within subscript 2) ; IDS( "C",1)="P" ; IDS("C" ,1,0)=Qual ifier^Prim ary ID ; I DS("C",1,1 )=Qualifie r^Sec ID # 1 ; IDS("C ",1,2)=Qua lifier^Sec ID #2 ; N DAT,IBFRM TYP,IBCARE ,IBDIV,IBI NS,OUTFAC, MAIN,IBCCO B,TMPIDS,C OB,IBSORT1 ,IBSORT2,I BLIMIT,IBL F ; S DAT= $G(^DGCR(3 99,IBIFN,0 )) ;JWS;IB *2.0*592;D ental form 7, same a s form 2 S IBFRMTYP= $$FT^IBCEF (IBIFN),IB FRMTYP=$S( IBFRMTYP=2 :2,IBFRMTY P=7:4,IBFR MTYP=3:1,1 :0) S IBCA RE=$S($$IS RX^IBCEF1( IBIFN):3,1 :0) ;if an Rx refill bill S:IB CARE=0 IBC ARE=$$INPA T^IBCEF(IB IFN) S:'IB CARE IBCAR E=2 ;1-inp ,2-out S I BDIV=+$P(D AT,U,22) S OUTFAC=$P ($G(^DGCR( 399,IBIFN, "U2")),U,1 0) S MAIN= $$MAIN^IBC EP2B() ; g et the IEN for main Division ; S IBCCOB= $$COBN^IBC EF(IBIFN) F COB=1:1: 3 D . S IB SORT1=$S(C OB=IBCCOB: "C",1:"O") . S IBSOR T2=$S(IBSO RT1="C":1, COB=1:1,CO B=2&(IBCCO B=1):1,1:2 ) . S IBLI MIT=$S(IBS ORT1="C":5 ,1:3) ; Li mit second ary IDs . S DAT=$G(^ DGCR(399,I BIFN,"I"_C OB)) . ; . S IBINS=$ P(DAT,U) ; insurance PTR 36 . Q:IBINS="" . ; . ; I B*2*400 - esg - 9/24 /08, 2/24/ 09 - if th ere is no service fa cility for this clai m at this COB, then get out . S IBLF=$$B ^IBCEF79(I BIFN,COB) ; billing provider/s ervice fac ility func tion . I $ P(IBLF,U,3 )="" Q ; no se rvice faci lity data at this CO B, don't b uild this "LAB/FAC" area . ; . I OUTFAC] "" D Q .. D NONVALF (IBIFN,OUT FAC_";IBA( 355.93,",I BINS,IBFRM TYP,IBCARE ,.IDS,IBSO RT1,IBSORT 2,COB,IBLI MIT,IBSTRI P,SEG) . ; . I OUTFA C="" D .. ; .. ; MRD ;IB*2.0*51 6 - Due to fields be ing marked for delet ion, the . . ; functi on $$SENDS F^IBCEF79 will alway s return ' 1'. Refer to .. ; th at functio n and INSF LGS^^IBCEF 79 for mor e informat ion. .. ; .. ; if in s co flag says to no t send svc fac data and we're sending an EDI claim , then get out .. ;I '$$SENDSF ^IBCEF79(I BIFN,COB), $G(^TMP("I BTX",$J,IB IFN)) Q .. ; .. ;IB* 2.0*432/TA Z Moved Ta xid setup inside VAL F look to send as se condary ID for Medic are claims . .. ;S ID S("LAB/FAC ",IBIFN,IB SORT1,IBSO RT2,0)=$$S TRIP($$TAX ID^IBCEF75 (),1,U,IBS TRIP) .. D VALF(IBIF N,IBINS,IB FRMTYP,IBD IV,.IDS,IB SORT1,IBSO RT2,COB,IB LIMIT,IBST RIP,SEG) Q ;VALF(IBI FN,INS,FT, DIV,IDS,SO RT1,SORT2, COB,IBLIMI T,IBSTRIP, SEG) ; Get VA Lab/Fa c Secondar y IDs ; Pa ss in INS - IEN to f ile 36 ; F T - 1 = UB 2 = 1500 4 = J430D ; DIV - PT R to 40.8 ; N Z,Z0,I D,QUAL,MAI N,IDTBL,CN T,Z,IBMCR S MAIN=$$M AIN^IBCEP2 B() ; get the IEN fo r main Div ision S Z= 0 F S Z=$ O(^IBA(355 .92,"B",IN S,Z)) Q:'Z D . S Z0 =$G(^IBA(3 55.92,Z,0) ) . Q:$P(Z 0,U,8)'="L F" ; Scr een out an ything oth er than La b or Facil ity . I +$ P(Z0,U,4) Q:$P(Z0,U, 4)'=FT ; Form type must matc h that pas sed in or be a 0 whi ch allows both . S I D=$$STRIP( $P(Z0,U,7) ,1,,IBSTRI P) . S QUA L=$$STRIP( $P(Z0,U,6) ,1,,IBSTRI P) . Q:QUA L="" ; N eeds a qua lifier . S QUAL=$P($ G(^IBE(355 .97,QUAL,0 )),U,3) . I FT=1,SOR T1="O" Q:$ $OP3^IBCEF 73(FT)'[(U _QUAL_U) ; Instituti onal . I F T=2,SORT1= "O" Q:$$OP 7^IBCEF73( FT)'[(U_QU AL_U) ; Pr ofessional . ;JWS;IB *2.0*592;D ental form . I FT=4, SORT1="O" Q:$$OP7^IB CEF73(FT)' [(U_QUAL_U ) ; Profes sional (De ntal) . I $P(Z0,U,5) =""!($P(Z0 ,U,5)=0)!( $P(Z0,U,5) =MAIN) S I DTBL("DEF" ,QUAL)=ID ; set up default fo r main div ision . I $P(Z0,U,5) =DIV S IDT BL("DIV",Q UAL)=ID ; set up de fault for division S CNT=0 S I DS("LAB/FA C",IBIFN,S ORT1,SORT2 )=$E("PST" ,COB) ;IB* 2.0*432/TA Z If Medic are send T ax ID as 1 st Seconda ry ID ; on ly if it's not a pri nted form S IBMCR="" ;JWS;IB*2 .0*592;Den tal I '(($ G(IBXFORM) =2)!($G(IB XFORM)=3)! ($G(IBXFOR M)=7)) S I BMCR=$$MCR ONBIL^IBEF UNC(IBIFN) I IBMCR S CNT=CNT+1 ,IDS("LAB/ FAC",IBIFN ,SORT1,SOR T2,CNT)="L U"_U_$$STR IP($P($$TA XID^IBCEF7 5(),U,2),1 ,U,IBSTRIP ) I $D(IDT BL("DIV")) D Q . S Z="" F S Z=$O(IDTBL ("DIV",Z)) Q:Z="" D .. ;IB*2. 0*432/TAZ If Medicar e, screen out Tax ID .. I IBMC R,(Z=24) Q .. S CNT= CNT+1,IDS( "LAB/FAC", IBIFN,SORT 1,SORT2,CN T)=Z_U_IDT BL("DIV",Z ) Q:CNT=IB LIMIT I $D (IDTBL("DE F")) D Q . S Z="" F S Z=$O(I DTBL("DEF" ,Z)) Q:Z=" " D .. ;I B*2.0*432/ TAZ If Med icare, scr een out Ta x ID .. I IBMCR,(Z=2 4) Q .. S CNT=CNT+1, IDS("LAB/F AC",IBIFN, SORT1,SORT 2,CNT)=Z_U _IDTBL("DE F",Z) Q:CN T=IBLIMIT Q ;NONVALF (IBIFN,PRV ,INS,FT,PT ,IDS,SORT1 ,SORT2,COB ,IBLIMIT,I BSTRIP,SEG ) ; Get No n VA Lab/F ac Seconda ry IDs ; P ass in PRV - VPTR - PTR to 355 .93 (in fo rmat of va riabel poi nter IEN;I BA(355.93, ; Pass in INS - PTR to 36 of null (not provide by insurance company) ; FT - 1 = UB 2 = 15 00 4 = J43 0D ; PT - Patient Ty pe - 1 inp atient 2 o utpatient ; IDS arra y being re turned ; S ORT1 - "C" urrent or "O"ther ; SORT2 - 1 if current or (1 or 2 if other ) N Z,Z0,I D,QUAL,IDT BL,CNT,IBM CR S Z=0 F S Z=$O(^ IBA(355.9, "B",PRV,Z) ) Q:'Z D . S Z0=$G( ^IBA(355.9 ,Z,0)) . I +$P(Z0,U, 4) Q:$P(Z0 ,U,4)'=FT ; Form t ype must m atch that passed in or be a 0 which allo ws both UB and 1500 . I +$P(Z0 ,U,5) Q:$P (Z0,U,5)'= PT ; Pat ient type must match that pass ed in or b e a 0 whic h allows b oth in pat ient and o utpatient . I INS]"" ,$P(Z0,U,2 )]"",INS'= $P(Z0,U,2) Q . S ID= $$STRIP($P (Z0,U,7),1 ,,IBSTRIP) . Q:ID="" . S QUAL= $$STRIP($P (Z0,U,6),1 ,,IBSTRIP) . Q:QUAL= "" ; Nee ds a quali fier . S Q UAL=$P($G( ^IBE(355.9 7,QUAL,0)) ,U,3) . Q: QUAL="" . I FT=1,SOR T1="O" Q:$ $OP3^IBCEF 73(FT)'[(U _QUAL_U) ; Instituti onal . I F T=2,SORT1= "O" Q:$$OP 7^IBCEF73( FT)'[(U_QU AL_U) ; Pr ofessional . ;JWS;IB *2.0*592;D ental - pr ofessional . I FT=4, SORT1="O" Q:$$OP7^IB CEF73(FT)' [(U_QUAL_U ) ; Profes sional - D ental . I $G(SEG)="S UB1" Q:$$S UB1^IBCEF7 3(FT)'[(U_ QUAL_U) . I $P(Z0,U, 2)="" S ID TBL("OWN", QUAL)=ID ; set up d efault of lab or fac ilities ow n ids . I $P(Z0,U,2) =INS S IDT BL("INS",Q UAL)=ID ; set up de fault for division ; S CNT=0 S IDS("LAB/ FAC",IBIFN ,SORT1,SOR T2)=$E("PS T",COB)_U_ PRV S IDS( "LAB/FAC", IBIFN,SORT 1,SORT2,"C ONTACT")=$ G(^IBA(355 .93,+PRV,1 )) ; get p rimary S Z 0=$G(^IBA( 355.93,+PR V,0)) ;IB* 2.0*432/TA Z If Medic are send T ax ID as 1 st Seconda ry ID S IB MCR="" ;JW S;IB*2.0*5 92;Dental I '(($G(IB XFORM)=2)! ($G(IBXFOR M)=3)!($G( IBXFORM)=7 )) S IBMCR =$$MCRONBI L^IBEFUNC( IBIFN) ;I $P(Z0,U,9) ]"",$P(Z0, U,13)]"",I BMCR S CNT =CNT+1,IDS ("LAB/FAC" ,IBIFN,SOR T1,SORT2,C NT)="LU"_U _$$STRIP($ P($G(^IBE( 355.97,$P( Z0,U,13),0 )),U,3)_U_ $P(Z0,U,9) ,1,U,IBSTR IP) I $P(Z 0,U,9)]"", $P(Z0,U,13 )]"",IBMCR S CNT=CNT +1,IDS("LA B/FAC",IBI FN,SORT1,S ORT2,CNT)= "LU"_U_$$S TRIP($P(Z0 ,U,9),1,U, IBSTRIP) ; get secon darys in o rder I $D( IDTBL("INS ")) D . N Z S Z="" F S Z=$O(I DTBL("INS" ,Z)) Q:Z=" " D .. ;I B*2.0*432/ TAZ If Med icare, scr een out Ta x ID .. I IBMCR,(Z=2 4) Q .. S CNT=CNT+1, IDS("LAB/F AC",IBIFN, SORT1,SORT 2,CNT)=Z_U _IDTBL("IN S",Z) Q:CN T=IBLIMIT I $D(IDTBL ("OWN")),C NT'=IBLIMI T D . N Z S Z="" F S Z=$O(IDT BL("OWN",Z )) Q:Z="" D .. ;IB* 2.0*432/TA Z If Medic are, scree n out Tax ID .. I IB MCR,(Z=24) Q .. I '$ D(IDTBL("I NS",Z)) S CNT=CNT+1, IDS("LAB/F AC",IBIFN, SORT1,SORT 2,CNT)=Z_U _IDTBL("OW N",Z) Q:CN T=IBLIMIT Q ;STRIP(X ,SPACE,EXC ,IBSTRIP) ; ; Strip punctuatio n from dat a in X ; S PACE = fla g if 1 str ip SPACES ; EXC = li st of punc t not to s trip ; Q: '$G(IBSTRI P) X Q $$N OPUNCT^IBC EF(X,$G(SP ACE),$G(EX C)) ;OTH(I BIFN,IBXSA VE,IBXDATA ,COND,SEG) ; Procedu re used in piece 2 o f some out put ; form atter segm ents for o ther insur ance ; CON D = 0/1 va lue passed in that d etermines whether or not to ca ll the ; p rovider ID function ; SEG = na me of segm ent for us e in calli ng ID^IBCE F2 (4 char acters) ; N Z ;*432/ TAZ - Chan ged Clean up and Set up routine s to IBCEF P* ;D CLEA NUP^IBCEF7 5(.IBXSAVE ) ;I COND D ALLIDS^I BCEF75(IBI FN,.IBXSAV E,1) D CLE ANUP^IBCEF P1(.IBXSAV E) I COND D ALLIDS^I BCEFP(IBIF N,.IBXSAVE ,1) ; ; Sp ecial Chec k: if Othe r Insuranc e #2 has s econdary I D's while Other ; In surance #1 does not, then move up #2 to be #1 here . This is to ; ensur e the outp ut formatt er IBXDATA array is built prop erly. ; I $O(IBXSAVE ("LAB/FAC" ,IBIFN,"O" ,2,0)),'$O (IBXSAVE(" LAB/FAC",I BIFN,"O",1 ,0)) D . K IBXSAVE(" LAB/FAC",I BIFN,"O",1 ) . M IBXS AVE("LAB/F AC",IBIFN, "O",1)=IBX SAVE("LAB/ FAC",IBIFN ,"O",2) . K IBXSAVE( "LAB/FAC", IBIFN,"O", 2) . Q ; K IBXDATA S Z=0 F S Z=$O(IBXSA VE("LAB/FA C",IBIFN," O",Z)) Q:' Z D . I ' $O(IBXSAVE ("LAB/FAC" ,IBIFN,"O" ,Z,0)) Q . S IBXDATA (Z)=$P($G( IBXSAVE("L AB/FAC",IB IFN,"O",Z) ),U,1) . I Z>1 D ID^ IBCEF2(Z,S EG) . QOTH X ; Q ; | |
| 1572 | ||
| 1573 | Routines | |
| 1574 | Activities | |
| 1575 | Routine Na me | |
| 1576 | IBCEF77 | |
| 1577 | Enhancemen t Category | |
| 1578 | New | |
| 1579 | Modify | |
| 1580 | Delete | |
| 1581 | No Change | |
| 1582 | RTM | |
| 1583 | ||
| 1584 | Related Op tions | |
| 1585 | None | |
| 1586 | Related Ro utines | |
| 1587 | Routines “ Called By” | |
| 1588 | Routines “ Called” | |
| 1589 | ||
| 1590 | ||
| 1591 | ||
| 1592 | ||
| 1593 | Data Dicti onary (DD) Reference s | |
| 1594 | ||
| 1595 | Related Pr otocols | |
| 1596 | None | |
| 1597 | Related In tegration Control Re gistration s (ICRs) | |
| 1598 | None | |
| 1599 | Data Passi ng | |
| 1600 | Input | |
| 1601 | Output Re ference | |
| 1602 | Both | |
| 1603 | Global Re ference | |
| 1604 | Local | |
| 1605 | Input Attr ibute Name and Defin ition | |
| 1606 | Name: | |
| 1607 | Definition : | |
| 1608 | Output Att ribute Nam e and Defi nition | |
| 1609 | Name: | |
| 1610 | Definition : | |
| 1611 | Current Lo gic | |
| 1612 | IBCEF77 ;W OIFO/SS - FORMATTER/ EXTRACT BI LL FUNCTIO NS ;31-JUL -03 ;;2.0; INTEGRATED BILLING;* *232,280,1 55,290,291 ,320,348,3 49,516**;2 1-MAR-94;B uild 123 ; ;Per VA Di rective 64 02, this r outine sho uld not be modified. ;SORT(IBP RNUM,IBPRT YP,IB399,I BSRC,IBDST ,IBN,IBEXC ,IBSEQ,IBL IMIT) ; N IBXIEN,IBX DATA,IBNET ,IBTRI,IB1 ,IB2,IBID, Z,IBZ,IBZ1 ,IBSVP S ( IB1,IB2,IB Z,IBZ1,IBT RI)="" D F ^IBCEF("N- ALL ATT/RE NDERING PR OV SSN","I BZ",,IB399 ) S IBZ1=$ $ALLPTYP^I BCEF3(IB39 9) F Z=1:1 :3 S $P(IB Z1,U,Z)=$S ($P(IBZ1,U ,Z)="CH":1 ,1:"") S:$ P(IBZ1,U,Z ) IBTRI=1 S IBNET=$$ NETID^IBCE P() ; netw rk id type I $G(IBN) D . S Z=0 F S Z=$O (IBDST(IBP RNUM,IBPRT YP,Z)) Q:' Z S IBID( +$P(IBDST( IBPRNUM,IB PRTYP,Z),U ,9))="" F S IB1=$O( IBSRC(IB1) ) Q:IB1="" D Q:IBN =IBLIMIT . N OK,IBST LIC . S IB STLIC="" . F S IB2= $O(IBSRC(I B1,IB2)) Q :IB2="" D Q:IBN=IB LIMIT . . S IBSVP=$P (IBSRC(IB1 ,IB2),U) . . ; If ID overridde n, output no others of this ty pe . . I $ G(IBEXC),$ P($G(IBSRC (IB1,IB2)) ,U,9)=IBEX C Q . . ; Ck state o f care/lic match if st lic# . . I $P($G( IBSRC(IB1, IB2)),U,3) ="0B" S OK =1 D Q:'O K . . . I +$$CAREST^ IBCEP2A(IB 399)'=$P(I BSRC(IB1,I B2),U,7) S IBSTLIC=1 Q . . . I $G(IBSTLI C(0))'="" S OK=0 Q . . . S IBS TLIC(0)=$G (IBSRC(IB1 ,IB2)),OK= 0 . . ; Ex clude SSN from sec i ds unless required . . I $P($G (IBSRC(IB1 ,IB2)),U,3 )="SY" Q . . ; Only 1 of each prov id ty pe . . Q:$ D(IBID(+$P ($G(IBSRC( IB1,IB2)), U,9))) . . S IBN=IBN +1,IBID(+$ P($G(IBSRC (IB1,IB2)) ,U,9))="" . . S IBDS T(IBPRNUM, IBPRTYP,IB N)=$G(IBSR C(IB1,IB2) ) . I IBN' =IBLIMIT,' $G(IBSTLIC ),$G(IBSTL IC(0))'="" S IBN=IBN +1,IBDST(I BPRNUM,IBP RTYP,IBN)= IBSTLIC(0) I $$FT^IB CEF(IB399) =2,$G(IBID (IBNET))=" ",IBTRI,$P (IBZ1,U,IB SEQ) D ; WCJ 02/1 3/2006 . Q :$P(IBZ,U, IBPRTYP)=" " . ; here , no netwo rk id & TR ICARE ins co. . N Z . S Z=+$O( ^DGCR(399, IB399,"PRV ","B",IBPR TYP,0)),Z= $P($G(^DGC R(399,IB39 9,"PRV",Z, 0)),U,2) . S IBN=IBN +1,IBDST(I BPRNUM,IBP RTYP,IBN)= Z_U_+$$POL ICY^IBCEF( IB399,1,IB SEQ)_U_$P( $G(^IBE(35 5.97,IBNET ,0)),U,3)_ U_$P(IBZ,U ,IBPRTYP)_ U_"0^0^^^" _IBNET Q ; ; esg - 8 /25/06 - I B*2*348 - CFIDS func tion ;CFID S(IBIFN,PR VTYP,ALLOW IDS) ; Cla im Form ID s for huma n provider s ; Functi on returns a 3 piece string: [ 1] default secondary ID qual ; [2] defau lt seconda ry ID ; [3 ] NPI ; In put: IBIFN - interna l claim# ; PRVTYP - internal p rovider ty pe ID numb er ; - 1:R EFER;2:OPE R;3:REND;4 :ATT;5:SUP ER;9:OTHER ; - if bl ank, then default At t/Rend bas ed on form type ; AL LOWIDS - L ist of all owable Sec ondary IDS ^ delimit ed. ; ex "^1A^1B^1C ^1H^G2^LU^ N5^" ; UB- 04 only wa nts IDs pr ovided by the payer, not the p roviders o wn IDS ; A lso, they want the q ualifier t o be G2 (C ommercial) ; if it i s a payer provided I D NEW ID,F T,IBZ,IBQ, IBSID,IBNP I,I,OK S I D="" I '$G (IBIFN) G CFIDSX S F T=$$FT^IBC EF(IBIFN) I '$G(PRVT YP) S PRVT YP=3 I FT= 3 S PRVTYP =4 D ALLID S^IBCEF75( IBIFN,.IBZ ,1) S OK=0 I $G(ALLO WIDS)="" S OK=1 F I= 1:1 D Q:O K . S IBQ= $P($G(IBZ( "PROVINF", IBIFN,"C", 1,PRVTYP,I )),U,3) ; qualifier . S IBSID= $P($G(IBZ( "PROVINF", IBIFN,"C", 1,PRVTYP,I )),U,4) ; ID# . I IB Q="",IBSID ="" S OK=1 Q . Q:OK . I $G(ALL OWIDS)[(U_ IBQ_U) S O K=1,IBQ="G 2" Q . S ( IBQ,IBSID) ="" S IBNP I="" D F^I BCEF("N-PR OVIDER NPI CODES","I BNPI",,IBI FN) S IBNP I=$P(IBNPI ,U,PRVTYP) ; NPI ; ; special c heck for t he referri ng doc I P RVTYP=1,$D (IBZ("PROV INF",IBIFN ,"C",1,PRV TYP)),IBQ= "",IBSID=" " S IBQ="1 G",IBSID=" VAD000" ; ; If UB-04 and no ID s, use VA UPIN as de afult I $D (IBZ("PROV INF",IBIFN ,"C",1,PRV TYP)),FT=3 ,IBQ="",IB SID="" S I BQ="1G",IB SID="VAD00 0" ; ; det ermine if legacy ID' s should b e displaye d I '$$PRT LID(IBIFN, IBNPI) S ( IBQ,IBSID) ="" ; S ID =IBQ_U_IBS ID_U_IBNPI CFIDSX ; Q ID ;DOL(A MT,LEN,DEC ) ; format dollar am ounts for printed cl aim forms ; AMT = am ount to be formatted ; LEN = l ength of f ield - rig ht justifi ed to this length ; DEC = flag to includ e the deci mal point or not ; D EFAULT val ue is to n ot include the decim al point ; if DEC is not defin ed or 0, a ssume no d ecimal poi nt ; so 15 will be r eturned as 1500, 6.7 7 will be returned a s 677 ; if DEC is 1, then the decimal po int will b e included ; S LEN=$ G(LEN,10), DEC=$G(DEC ,0) ; defa ults S AMT =$FN(+$G(A MT),"",2) ; format # with 2 de cimals I ' DEC S AMT= $TR(AMT,". ") ; strip or leave decimal S AMT=$J(AMT ,LEN) ; ri ght justif y Q AMT ;P RTLID(IBIF N,NPI) ; Y MG; Print Legacy IDs on the CM S-1500 or UB-04 form ; Functio n fetches form type associated with give n claim nu mber ; (va lues: 2 - CMS-1500 f orm, 3 - U B-04 form) , then loo ks at ; "P rint Legac y ID" site parameter for this particular form type . ; ; Pos sible site parameter values ar e: ; "Y" - always pr int Legacy ID ; "N" - never pr int Legacy ID ; "C" - only pri nt Legacy ID if NPI is not ava ilable. ; ; This in formation is used to determine if Legacy ID should be printe d ; for cl aim number in questi on. ; ; N ote: Situa tion when "Print Leg acy ID" si te paramet er is not set is tre ated ; as if this pa rameter wa s set to " Y" - alway s print Le gacy ID. ; ; Input: ; IBIFN - internal claim numb er ; NPI - NPI numbe r (or "" i f no NPI i s availabl e) ; ; Re turns: ; 0 - Legacy ID should not be pri nted ; 1 - Legacy ID should be printed ; Q $S(NPI= "":"YC",1: "Y")[$P($G (^IBE(350. 9,1,1)),U, $S($$FT^IB CEF(IBIFN) =2:32,1:33 )) ;REMARK (IBIFN,IBX DATA,OFLG) ; procedu re to retu rn array o f UB-04 re mark text ; for clai m IBIFN. D ata pulled from fiel d# 402 of file 399 a nd ; forma tted into an array I BXDATA(n) where each line is n ot greater ; than 24 character s long. Th is will fi t into UB- 04 FL-80. ; ; OFLG=1 only when called in the outpu t formatte r. In this case, onl y ; 4 line s in IBXDA TA will be returned. ; NEW TEX T,LEN,IBZ, J,PCE,CHS, NEWCHS,IBK ,J,TX,IBCP 1 K IBXDAT A ; ; MRD; IB*2.0*516 - Pull th e Bill Rem arks for t he claim. If this wa s ; called from the Output For matter, th en look at lines of claim for ; NDC's. I f any are found, the y should b e added to the end o f TEXT. ; S TEXT=$P( $G(^DGCR(3 99,+$G(IBI FN),"UF2") ),U,3) I $ G(OFLG) D . S J=0 . F S J=$O( ^DGCR(399, +$G(IBIFN) ,"CP",J)) Q:'J S IB CP1=$G(^(J ,1)) I $P( IBCP1,U,7) '="" D . . I TEXT'=" " S TEXT=T EXT_" " . . S TEXT=T EXT_"N4"_$ TR($P(IBCP 1,U,7),"-" )_" UN"_$P (IBCP1,U,8 ) . . Q . Q ; ; If t here's not hing in TE XT, then Q uit. ; I T EXT="" Q ; ; need to break up large word s for word wrapping purposes t o get ; as many char acters as possible i n the box. S LEN=17 F PCE=1:1 Q:PCE>$L(T EXT," ") S CHS=$P(TE XT," ",PCE ) I $L(CHS )>LEN D . S NEWCHS=$ E(CHS,1,LE N)_" "_$E( CHS,LEN+1, 999) . S $ P(TEXT," " ,PCE)=NEWC HS . Q ; ; When call ing FSTRNG ^IBJU1 whi ch calls ^ DIWP, File Man builds the ; arr ay with st rings of m ax length= 1 less tha n what you tell it. ; S LEN=20 ; line 1 is 19 char s D FSTRNG ^IBJU1(TEX T,LEN,.IBZ ) ; build IBZ array S IBK=$$TR IM^XLFSTR( $G(IBZ(1)) ) ; save o ff the fir st line S TEXT=$P(TE XT,IBK,2,9 9) ; resto re the res t of the t ext S TEXT =$$TRIM^XL FSTR(TEXT) ; trim sp aces ; S L EN=25 ; th e rest is 24 chars D FSTRNG^IB JU1(TEXT,L EN,.IBZ) ; build IBZ array S I BXDATA(1)= " "_IBK ; line 1 S J=0 F S J=$O(IBZ(J )) Q:'J D ; li nes 2-n . I J>3,$G(O FLG) Q ; onl y 4 lines for output formatter . S TX=$$ TRIM^XLFST R($G(IBZ(J ))) . I TX '="" S IBX DATA(J+1)= TX . Q Q ; | |
| 1613 | Modified L ogic (Chan ges are in bold) | |
| 1614 | IBCEF77 ;W OIFO/SS - FORMATTER/ EXTRACT BI LL FUNCTIO NS ;31-JUL -03 ;;2.0; INTEGRATED BILLING;* *232,280,1 55,290,291 ,320,348,3 49,516,577 ,592**;21- MAR-94;Bui ld 1 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ;SO RT(IBPRNUM ,IBPRTYP,I B399,IBSRC ,IBDST,IBN ,IBEXC,IBS EQ,IBLIMIT ) ; N IBXI EN,IBXDATA ,IBNET,IBT RI,IB1,IB2 ,IBID,Z,IB Z,IBZ1,IBS VP S (IB1, IB2,IBZ,IB Z1,IBTRI)= "" D F^IBC EF("N-ALL ATT/RENDER ING PROV S SN","IBZ", ,IB399) S IBZ1=$$ALL PTYP^IBCEF 3(IB399) F Z=1:1:3 S $P(IBZ1,U ,Z)=$S($P( IBZ1,U,Z)= "CH":1,1:" ") S:$P(IB Z1,U,Z) IB TRI=1 S IB NET=$$NETI D^IBCEP() ; netwrk i d type I $ G(IBN) D . S Z=0 F S Z=$O(IBD ST(IBPRNUM ,IBPRTYP,Z )) Q:'Z S IBID(+$P( IBDST(IBPR NUM,IBPRTY P,Z),U,9)) ="" F S I B1=$O(IBSR C(IB1)) Q: IB1="" D Q:IBN=IBL IMIT . N O K,IBSTLIC . S IBSTLI C="" . F S IB2=$O(I BSRC(IB1,I B2)) Q:IB2 ="" D Q: IBN=IBLIMI T . . S IB SVP=$P(IBS RC(IB1,IB2 ),U) . . ; If ID ove rridden, o utput no o thers of t his type . . I $G(IB EXC),$P($G (IBSRC(IB1 ,IB2)),U,9 )=IBEXC Q . . ; Ck s tate of ca re/lic mat ch if st l ic# . . I $P($G(IBSR C(IB1,IB2) ),U,3)="0B " S OK=1 D Q:'OK . . . I +$$C AREST^IBCE P2A(IB399) '=$P(IBSRC (IB1,IB2), U,7) S IBS TLIC=1 Q . . . I $G( IBSTLIC(0) )'="" S OK =0 Q . . . S IBSTLIC (0)=$G(IBS RC(IB1,IB2 )),OK=0 . . ; Exclud e SSN from sec ids u nless requ ired . . I $P($G(IBS RC(IB1,IB2 )),U,3)="S Y" Q . . ; Only 1 of each prov id type . . Q:$D(IB ID(+$P($G( IBSRC(IB1, IB2)),U,9) )) . . S I BN=IBN+1,I BID(+$P($G (IBSRC(IB1 ,IB2)),U,9 ))="" . . S IBDST(IB PRNUM,IBPR TYP,IBN)=$ G(IBSRC(IB 1,IB2)) . I IBN'=IBL IMIT,'$G(I BSTLIC),$G (IBSTLIC(0 ))'="" S I BN=IBN+1,I BDST(IBPRN UM,IBPRTYP ,IBN)=IBST LIC(0) ;JR A IB*2.0*5 92 Treat D ental Form 7 (J430D) same as C MS-1500 - added 'FT' ;I $$FT^I BCEF(IB399 )=2,$G(IBI D(IBNET))= "",IBTRI,$ P(IBZ1,U,I BSEQ) D ; WCJ 02/13/ 2006 ;JRA IB*2.0*592 ';' N FT S FT=$$FT^ IBCEF(IB39 9) ;JRA IB *2.0*592 I (FT=2!(FT =7)),$G(IB ID(IBNET)) ="",IBTRI, $P(IBZ1,U, IBSEQ) D ;JRA IB*2. 0*592 . Q: $P(IBZ,U,I BPRTYP)="" . ; here, no networ k id & TRI CARE ins c o. . N Z . S Z=+$O(^ DGCR(399,I B399,"PRV" ,"B",IBPRT YP,0)),Z=$ P($G(^DGCR (399,IB399 ,"PRV",Z,0 )),U,2) . S IBN=IBN+ 1,IBDST(IB PRNUM,IBPR TYP,IBN)=Z _U_+$$POLI CY^IBCEF(I B399,1,IBS EQ)_U_$P($ G(^IBE(355 .97,IBNET, 0)),U,3)_U _$P(IBZ,U, IBPRTYP)_U _"0^0^^^"_ IBNET Q ; ; esg - 8/ 25/06 - IB *2*348 - C FIDS funct ion ;CFIDS (IBIFN,PRV TYP,ALLOWI DS) ; Clai m Form IDs for human providers ; Functio n returns a 3 piece string: [1 ] default secondary ID qual ; [2] defaul t secondar y ID ; [3] NPI ; Inp ut: IBIFN - internal claim# ; PRVTYP - i nternal pr ovider typ e ID numbe r ; - 1:RE FER;2:OPER ;3:REND;4: ATT;5:SUPE R;9:OTHER ; - if bla nk, then d efault Att /Rend base d on form type ; ALL OWIDS - Li st of allo wable Seco ndary IDS ^ delimite d. ; ex " ^1A^1B^1C^ 1H^G2^LU^N 5^" ; UB-0 4 only wan ts IDs pro vided by t he payer, not the pr oviders ow n IDS ; Al so, they w ant the qu alifier to be G2 (Co mmercial) ; if it is a payer p rovided ID NEW ID,FT ,IBZ,IBQ,I BSID,IBNPI ,I,OK S ID ="" I '$G( IBIFN) G C FIDSX S FT =$$FT^IBCE F(IBIFN) I '$G(PRVTY P) S PRVTY P=3 I FT=3 S PRVTYP= 4 D ALLIDS ^IBCEF75(I BIFN,.IBZ, 1) S OK=0 I $G(ALLOW IDS)="" S OK=1 F I=1 :1 D Q:OK . S IBQ=$ P($G(IBZ(" PROVINF",I BIFN,"C",1 ,PRVTYP,I) ),U,3) ; q ualifier . S IBSID=$ P($G(IBZ(" PROVINF",I BIFN,"C",1 ,PRVTYP,I) ),U,4) ; I D# . I IBQ ="",IBSID= "" S OK=1 Q . Q:OK . I $G(ALLO WIDS)[(U_I BQ_U) S OK =1,IBQ="G2 " Q . S (I BQ,IBSID)= "" S IBNPI ="" D F^IB CEF("N-PRO VIDER NPI CODES","IB NPI",,IBIF N) S IBNPI =$P(IBNPI, U,PRVTYP) ; NPI ; ; special ch eck for th e referrin g doc I PR VTYP=1,$D( IBZ("PROVI NF",IBIFN, "C",1,PRVT YP)),IBQ=" ",IBSID="" S IBQ="1G ",IBSID="V AD000" ; ; If UB-04 and no IDs , use VA U PIN as dea fult I $D( IBZ("PROVI NF",IBIFN, "C",1,PRVT YP)),FT=3, IBQ="",IBS ID="" S IB Q="1G",IBS ID="VAD000 " ; ; dete rmine if l egacy ID's should be displayed I '$$PRTL ID(IBIFN,I BNPI) S (I BQ,IBSID)= "" ; S ID= IBQ_U_IBSI D_U_IBNPIC FIDSX ; Q ID ;DOL(AM T,LEN,DEC) ; format dollar amo unts for p rinted cla im forms ; AMT = amo unt to be formatted ; LEN = le ngth of fi eld - righ t justifie d to this length ; D EC = flag to include the decim al point o r not ; DE FAULT valu e is to no t include the decima l point ; if DEC is not define d or 0, as sume no de cimal poin t ; so 15 will be re turned as 1500, 6.77 will be r eturned as 677 ; if DEC is 1, then the d ecimal poi nt will be included ; S LEN=$G (LEN,10),D EC=$G(DEC, 0) ; defau lts S AMT= $FN(+$G(AM T),"",2) ; format # with 2 dec imals I 'D EC S AMT=$ TR(AMT,"." ) ; strip or leave d ecimal S A MT=$J(AMT, LEN) ; rig ht justify Q AMT ;PR TLID(IBIFN ,NPI) ; YM G; Print L egacy IDs on the CMS -1500 or U B-04 form ; Function fetches f orm type a ssociated with given claim num ber ; (val ues: 2 - C MS-1500 fo rm, 3 - UB -04 form), then look s at ; "Pr int Legacy ID" site parameter for this p articular form type. ; ; Poss ible site parameter values are : ; "Y" - always pri nt Legacy ID ; "N" - never pri nt Legacy ID ; "C" - only prin t Legacy I D if NPI i s not avai lable. ; ; This inf ormation i s used to determine if Legacy ID should be printed ; for cla im number in questio n. ; ; No te: Situat ion when " Print Lega cy ID" sit e paramete r is not s et is trea ted ; as i f this par ameter was set to "Y " - always print Leg acy ID. ; ; Input: ; IBIFN - internal c laim numbe r ; NPI - NPI number (or "" if no NPI is available ) ; ; Ret urns: ; 0 - Legacy I D should n ot be prin ted ; 1 - Legacy ID should be printed ; ;JRA IB*2. 0*592 Trea t Dental F orm 7 (J43 0D) same a s CMS-1500 - added ' FT' ;Q $S( NPI="":"YC ",1:"Y")[$ P($G(^IBE( 350.9,1,1) ),U,$S($$F T^IBCEF(IB IFN)=2:32, 1:33)) ;JR A IB*2.0*5 92 ';' N F T S FT=$$F T^IBCEF(IB IFN) ;JRA IB*2.0*592 Q $S(NPI= "":"YC",1: "Y")[$P($G (^IBE(350. 9,1,1)),U, $S((FT=2!( FT=7)):32, 1:33)) ;JR A IB*2.0*5 92 ;REMARK (IBIFN,IBX DATA,OFLG) ; procedu re to retu rn array o f UB-04 re mark text ; for clai m IBIFN. D ata pulled from fiel d# 402 of file 399 a nd ; forma tted into an array I BXDATA(n) where each line is n ot greater ; than 24 character s long. Th is will fi t into UB- 04 FL-80. ; ; OFLG=1 only when called in the outpu t formatte r. In this case, onl y ; 4 line s in IBXDA TA will be returned. ; NEW TEX T,LEN,IBZ, J,PCE,CHS, NEWCHS,IBK ,J,TX,IBCP 1 K IBXDAT A ; ; MRD; IB*2.0*516 - Pull th e Bill Rem arks for t he claim. If this wa s ; called from the Output For matter, th en look at lines of claim for ; NDC's. I f any are found, the y should b e added to the end o f TEXT. ; S TEXT=$P( $G(^DGCR(3 99,+$G(IBI FN),"UF2") ),U,3) ; V AD/ Begin of IB*2*57 7 changes ; NDC, Qua ntity, and Unit of M easure now printed i n FL-43 ; instead of here in F L-80 ;I $G (OFLG) D ; . S J=0 ;. F S J=$O( ^DGCR(399, +$G(IBIFN) ,"CP",J)) Q:'J S IBC P1=$G(^(J, 1)) I $P(I BCP1,U,7)' ="" D ;. . I TEXT'=" " S TEXT=T EXT_" " ;. . S TEXT= TEXT_"N4"_ $TR($P(IBC P1,U,7),"- ")_" UN"_$ P(IBCP1,U, 8) ;. . Q ;. Q ; VAD / End of I B*2*577 ch anges ; ; If there's nothing i n TEXT, th en Quit. ; I TEXT="" Q ; ; nee d to break up large words for word wrapp ing purpos es to get ; as many characters as possib le in the box. S LEN =17 F PCE= 1:1 Q:PCE> $L(TEXT," ") S CHS=$ P(TEXT," " ,PCE) I $L (CHS)>LEN D . S NEWC HS=$E(CHS, 1,LEN)_" " _$E(CHS,LE N+1,999) . S $P(TEXT ," ",PCE)= NEWCHS . Q ; ; When calling FS TRNG^IBJU1 which cal ls ^DIWP, FileMan bu ilds the ; array wit h strings of max len gth=1 less than what you tell it. ; S LE N=20 ; lin e 1 is 19 chars D FS TRNG^IBJU1 (TEXT,LEN, .IBZ) ; bu ild IBZ ar ray S IBK= $$TRIM^XLF STR($G(IBZ (1))) ; sa ve off the first lin e S TEXT=$ P(TEXT,IBK ,2,99) ; r estore the rest of t he text S TEXT=$$TRI M^XLFSTR(T EXT) ; tri m spaces ; S LEN=25 ; the rest is 24 cha rs D FSTRN G^IBJU1(TE XT,LEN,.IB Z) ; build IBZ array S IBXDATA (1)=" "_IB K ; line 1 S J=0 F S J=$O(I BZ(J)) Q:' J D ; lines 2- n . I J>3, $G(OFLG) Q ; only 4 li nes for ou tput forma tter . S T X=$$TRIM^X LFSTR($G(I BZ(J))) . I TX'="" S IBXDATA(J +1)=TX . Q Q ;B43(ND CDATA) ; T his is pas sed a stri ng and pro perly form ats if the re is NDC drug infor mation. ; The drug i nformation is in pie ces 21-23 of that st ring. ; It was part of the out put format ter entry 364.7[1406 ] used for FL43 but that got t oo big for a FileMan Mumps dat a element ; It retur ns a strin g with N4 - the NDC Drug quali fier ; NDC Code with out the hy phens ; a space ; Un its qualif ier ; Unit s ; Ex "N4 1234567890 1 ML1.5" I NDCDATA=" " Q "" S N DCDATA=$P( NDCDATA,U, 21,23) Q:$ P(NDCDATA, U)="" "" Q "N4"_$TR( $P(NDCDATA ,U),"-")_" "_$TR($P( NDCDATA,U, 2,3),U) ; | |
| 1615 | ||
| 1616 | Routines | |
| 1617 | Activities | |
| 1618 | Routine Na me | |
| 1619 | IBCEF78 | |
| 1620 | Enhancemen t Category | |
| 1621 | New | |
| 1622 | Modify | |
| 1623 | Delete | |
| 1624 | No Change | |
| 1625 | RTM | |
| 1626 | ||
| 1627 | Related Op tions | |
| 1628 | None | |
| 1629 | Related Ro utines | |
| 1630 | Routines “ Called By” | |
| 1631 | Routines “ Called” | |
| 1632 | ||
| 1633 | ||
| 1634 | ||
| 1635 | ||
| 1636 | Data Dicti onary (DD) Reference s | |
| 1637 | ||
| 1638 | Related Pr otocols | |
| 1639 | None | |
| 1640 | Related In tegration Control Re gistration s (ICRs) | |
| 1641 | None | |
| 1642 | Data Passi ng | |
| 1643 | Input | |
| 1644 | Output Re ference | |
| 1645 | Both | |
| 1646 | Global Re ference | |
| 1647 | Local | |
| 1648 | Input Attr ibute Name and Defin ition | |
| 1649 | Name: | |
| 1650 | Definition : | |
| 1651 | Output Att ribute Nam e and Defi nition | |
| 1652 | Name: | |
| 1653 | Definition : | |
| 1654 | Current Lo gic | |
| 1655 | IBCEF78 ;A LB/WCJ - P rovider ID functions ;13 May 2 007 ;;2.0; INTEGRATED BILLING;* *371,516** ;21-MAR-94 ;Build 123 ;;Per VA Directive 6402, this routine s hould not be modifie d. ;; G AW AYAWAY Q ; PAYERIDS(I BXIEN,IBRE T) ; This function r eturns all the PAYER IDS for t he current and other insurance (s) ; D P RIPAYID(IB XIEN,.IBRE T) D SECPA YID(IBXIEN ,.IBRET) Q ;PRIPAYID (IBXIEN,IB XRET) ; Pr imary Paye r IDs ; In coming: ; IBXIEN = I EN for Fil e # 399 ; IBXRET = R eturn Arra y for Qual ifiers and IDs ; ; O utgoing ; IBXRET("CI _PID",1)=Q UAL^ID ; I BXRET("OI_ PID",#)=QU AL^ID ; N RET,I S R ET=$$PAYER ID^IBCEF2( IBXIEN) I RET]"" S I BXRET("CI_ PID",1)="P I"_U_RET ; ; MRD;IB* 2.0*516 - Added HPID here (CI) and below (OI). S R ET=$$HPID( IBXIEN) I RET]"" S I BXRET("CI_ HPID",1)=" XV"_U_RET ; S RET="" D OTHINSI D^IBCEF72( IBXIEN,.RE T) F I=1,2 D . I $P( $G(RET(I)) ,U)]"" S I BXRET("OI_ PID",I)="P I"_U_$P(RE T(I),U) . I $P($G(RE T(I)),U,2) ]"" S IBXR ET("OI_HPI D",I)="XV" _U_$P(RET( I),U,2) . Q Q ;SECPA YID(IBXIEN ,IBXRET) ; This retu rns all of the secon dary payer IDs from file #36 ; for the insurance companies on a given claim ; ; Incoming : ; IBXIEN = IEN for File # 39 9 ; IBXRET = Return Array for Qualifiers and IDs ; ; Outgoin g ; IBXRET ("CI_PSIDS ",1)=QUAL^ ID^QUAL^ID ; IBXRET( "OI_PSIDS" ,#)=QUAL^I D^QUAL^ID ; N Z,C,IB Z,Z0,FT F Z=1:1:3 S IBZ(Z)=$$P OLICY^IBCE F(IBXIEN,1 ,Z) S Z0=0 ,C=$$COBN^ IBCEF(IBXI EN),FT=$$F T^IBCEF(IB XIEN) F Z= 1:1:3 S:C' =Z Z0=Z0+1 S IBXRET( $S(C=Z:"CI _PSIDS",1: "OI_PSIDS" ),$S(C=Z:1 ,1:Z0))=$$ SPIDS(+IBZ (Z),FT) Q ;SPIDS(INS ,FT) ; ; F T = FORM T YPE (2 PRO FESSIONAL 3 INSTITUT IONAL) ; I NS = INSUR ANCE COMPA NY (FILE # 36) IEN ; Returns St ring (^ de limited) ; [1] = QUA L 1 ; [2] = PAYER ID 1 ; [3] = QUAL 2 ; [4] = PAYE R ID 2 Q:' +INS "" ; N DATA,PCE S DATA=$S (FT=3:$P($ G(^DIC(36, +INS,6)),U ,1,4),FT=2 :$P($G(^DI C(36,+INS, 6)),U,5,8) ,1:"") ; ; Check for dangling IDs/Qualif iers F PCE =1,3 D . I $P(DATA,U ,PCE)'="", $P(DATA,U, PCE+1)'="" Q . S ($P (DATA,U,PC E),$P(DATA ,U,PCE+1)) ="" ; ; fi ll in the gap if the re is one I $P(DATA, U,1)="",$P (DATA,U,3) '="" D . S $P(DATA,U ,1)=$P(DAT A,U,3) . S $P(DATA,U ,2)=$P(DAT A,U,4) . S ($P(DATA, U,3),$P(DA TA,U,4))=" " ; Q DATA ;HPID(IBX IEN) ; Det ermine HPI D for curr ent payer. ; MRD;IB* 2.0*516 - Added HPID . ; N IBHP ID,IBSEQ S IBSEQ=$$C OBN^IBCEF( IBXIEN) ; IBSEQ shou ld be 1, 2 or 3. I I BSEQ S IBH PID=$P($G( ^DGCR(399, IBXIEN,"M1 ")),U,12+I BSEQ) ; Pu ll piece 1 3, 14 or 1 5. Q IBHPI D ;CLEANUP (IBRET) ; K IBRET("C I_PID"),IB RET("OI_PI D"),IBRET( "CI_PSIDS" ),IBRET("O I_PSIDS"), IBRET("CI_ HPID"),IBR ET("OI_HPI D") Q ; | |
| 1656 | Modified L ogic (Chan ges are in bold) | |
| 1657 | IBCEF78 ;A LB/WCJ - P rovider ID functions ;13 May 2 007 ;;2.0; INTEGRATED BILLING;* *371,516,5 92**;21-MA R-94;Build 123 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ;; G AWAYAWAY Q ;PAYERI DS(IBXIEN, IBRET) ; T his functi on returns all the P AYER IDS f or the cur rent and o ther insur ance(s) ; D PRIPAYI D(IBXIEN,. IBRET) D S ECPAYID(IB XIEN,.IBRE T) Q ;PRIP AYID(IBXIE N,IBXRET) ; Primary Payer IDs ; Incoming : ; IBXIEN = IEN for File # 39 9 ; IBXRET = Return Array for Qualifiers and IDs ; ; Outgoin g ; IBXRET ("CI_PID", 1)=QUAL^ID ; IBXRET( "OI_PID",# )=QUAL^ID ; N RET,I S RET=$$P AYERID^IBC EF2(IBXIEN ) I RET]"" S IBXRET( "CI_PID",1 )="PI"_U_R ET ; ; MRD ;IB*2.0*51 6 - Added HPID here (CI) and b elow (OI). S RET=$$H PID(IBXIEN ) I RET]"" S IBXRET( "CI_HPID", 1)="XV"_U_ RET ; S RE T="" D OTH INSID^IBCE F72(IBXIEN ,.RET) F I =1,2 D . I $P($G(RET (I)),U)]"" S IBXRET( "OI_PID",I )="PI"_U_$ P(RET(I),U ) . I $P($ G(RET(I)), U,2)]"" S IBXRET("OI _HPID",I)= "XV"_U_$P( RET(I),U,2 ) . Q Q ;S ECPAYID(IB XIEN,IBXRE T) ; This returns al l of the s econdary p ayer IDs f rom file # 36 ; for the insura nce compan ies on a g iven claim ; ; Inco ming: ; IB XIEN = IEN for File # 399 ; IB XRET = Ret urn Array for Qualif iers and I Ds ; ; Out going ; IB XRET("CI_P SIDS",1)=Q UAL^ID^QUA L^ID ; IBX RET("OI_PS IDS",#)=QU AL^ID^QUAL ^ID ; N Z, C,IBZ,Z0,F T F Z=1:1: 3 S IBZ(Z) =$$POLICY^ IBCEF(IBXI EN,1,Z) S Z0=0,C=$$C OBN^IBCEF( IBXIEN),FT =$$FT^IBCE F(IBXIEN) F Z=1:1:3 S:C'=Z Z0= Z0+1 S IBX RET($S(C=Z :"CI_PSIDS ",1:"OI_PS IDS"),$S(C =Z:1,1:Z0) )=$$SPIDS( +IBZ(Z),FT ) Q ;SPIDS (INS,FT) ; ; FT = FO RM TYPE (2 PROFESSIO NAL 3 INST ITUTIONAL) ; INS = I NSURANCE C OMPANY (FI LE #36) IE N ; Return s String ( ^ delimite d) ; [1] = QUAL 1 ; [2] = PAYE R ID 1 ; [ 3] = QUAL 2 ; [4] = PAYER ID 2 Q:'+INS " " ; N DATA ,PCE ;JWS; IB*2.0*592 ;Dental fo rm 7 same as form 2 - no secon daries for Dental S DATA=$S(FT =3:$P($G(^ DIC(36,+IN S,6)),U,1, 4),FT=2:$P ($G(^DIC(3 6,+INS,6)) ,U,5,8),1: "") ; ; Ch eck for da ngling IDs /Qualifier s F PCE=1, 3 D . I $P (DATA,U,PC E)'="",$P( DATA,U,PCE +1)'="" Q . S ($P(DA TA,U,PCE), $P(DATA,U, PCE+1))="" ; ; fill in the gap if there is one I $ P(DATA,U,1 )="",$P(DA TA,U,3)'=" " D . S $P (DATA,U,1) =$P(DATA,U ,3) . S $P (DATA,U,2) =$P(DATA,U ,4) . S ($ P(DATA,U,3 ),$P(DATA, U,4))="" ; Q DATA ;H PID(IBXIEN ) ; Determ ine HPID f or current payer. ; MRD;IB*2.0 *516 - Add ed HPID. ; N IBHPID, IBSEQ S IB SEQ=$$COBN ^IBCEF(IBX IEN) ; IBS EQ should be 1, 2 or 3. I IBSE Q S IBHPID =$P($G(^DG CR(399,IBX IEN,"M1")) ,U,12+IBSE Q) ; Pull piece 13, 14 or 15. Q IBHPID ; CLEANUP(IB RET) ; K I BRET("CI_P ID"),IBRET ("OI_PID") ,IBRET("CI _PSIDS"),I BRET("OI_P SIDS"),IBR ET("CI_HPI D"),IBRET( "OI_HPID") Q ; | |
| 1658 | ||
| 1659 | Routines | |
| 1660 | Activities | |
| 1661 | Routine Na me | |
| 1662 | IBCEF81 | |
| 1663 | Enhancemen t Category | |
| 1664 | New | |
| 1665 | Modify | |
| 1666 | Delete | |
| 1667 | No Change | |
| 1668 | RTM | |
| 1669 | ||
| 1670 | Related Op tions | |
| 1671 | None | |
| 1672 | Related Ro utines | |
| 1673 | Routines “ Called By” | |
| 1674 | Routines “ Called” | |
| 1675 | ||
| 1676 | ||
| 1677 | ||
| 1678 | ||
| 1679 | Data Dicti onary (DD) Reference s | |
| 1680 | ||
| 1681 | Related Pr otocols | |
| 1682 | None | |
| 1683 | Related In tegration Control Re gistration s (ICRs) | |
| 1684 | None | |
| 1685 | Data Passi ng | |
| 1686 | Input | |
| 1687 | Output Re ference | |
| 1688 | Both | |
| 1689 | Global Re ference | |
| 1690 | Local | |
| 1691 | Input Attr ibute Name and Defin ition | |
| 1692 | Name: | |
| 1693 | Definition : | |
| 1694 | Output Att ribute Nam e and Defi nition | |
| 1695 | Name: | |
| 1696 | Definition : | |
| 1697 | Current Lo gic | |
| 1698 | IBCEF81 ;A LB/BI - PR OVIDER ADJ USTMENTS ; 11-OCT-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32,473**;2 1-MAR-94;B uild 29 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ; Q ; EN(INPUT) ; FIRST EN TRY POINT N INSLEVEL ,PRTYPE,OU TPUT,IBIEN ,CMODE,CPR NUM,STATUS S STATUS= 1 I $D(INP UT)=0 S ST ATUS=0 Q S TATUS I (( $G(IBXFORM )=2)!($G(I BXFORM)=3) ) D EN^IBC EF82(.INPU T) Q STATU S ; PER FORM LOCAL PRINT BUS INESS RULE S K OUTPUT M OUTPUT= INPUT D CI NIT1 Q:IBI EN="" STAT US F INSLE VEL="P","S ","T" D ; P=PRIMA RY, S=SECO NDARY, T=T ERTIARY . D CINIT2 . F PRTYPE= 1,2,3,5,9 D ; 1=R EFERRING, 2=OPERATIN G, 3=RENDE RING, 5=SU PERVISING, 9=OTHER O PERATING . . D START( INSLEVEL,P RTYPE,.OUT PUT) K INP UT M INPUT =OUTPUT Q STATUSSTAR T(INSLEVEL ,PRTYPE,OU TPUT) ; ST ART PROCES SING N INT ERM,PROVIN FO,MAXAINF O,FIRSTINF S INTERM= "A" S INTE RM=INTERM_ $$TEST1 ; Does Clai m Level Pr ovider Exi st, 0=NO, 1=YES S IN TERM=INTER M_$$TEST2 ; All pro cedures ha ve a line level prov ider, 0=NO , 1=YES S INTERM=INT ERM_$$TEST 3 ; One L ine Level provider i s most sig nificant, 0=NO, 1=YE S S INTERM =INTERM_$$ TEST4 ; A t least on e line lev el provide r matches the claim level prov ider, 0=NO , 1=YES S INTERM=INT ERM_$$TEST 5 ; There is only o ne procedu re without a line le vel provid er, 0=NO, 1=YES D @I NTERM Q ; TEST1() ; Does Claim Level Pro vider Exis t, 0=NO, 1 =YES N PRO VX,PROVY I $D(CMODE( INSLEVEL)) #10=0 Q 0 I $D(CPRNU M(INSLEVEL ))#10=0 Q 0 S (PROVX ,PROVY)=$G (INPUT("PR OVINF",IBI EN,CMODE(I NSLEVEL),C PRNUM(INSL EVEL),PRTY PE)) Q:PRO VX="" 0 S PROVX="^"_ $P(PROVX," ;",2)_$P(P ROVX,";",1 )_")" I $D (@PROVX) D Q 1 ;CLA IM PROVIDE R EXISTS, RETURN TRU E. . ; LOA D CLAIM LE VEL PROVID ER INFORMA TION . S P ROVINFO=PR OVY . S PR OVINFO("PR OVINF",IBI EN)=IBIEN . S PROVIN FO("PROVIN F",IBIEN,C MODE(INSLE VEL))="" . S PROVINF O("PROVINF ",IBIEN,CM ODE(INSLEV EL),CPRNUM (INSLEVEL) )=INSLEVEL . M PROVI NFO("PROVI NF",IBIEN, CMODE(INSL EVEL),CPRN UM(INSLEVE L),PRTYPE) =INPUT("PR OVINF",IBI EN,CMODE(I NSLEVEL),C PRNUM(INSL EVEL),PRTY PE) Q 0 ;T EST2() ; A ll procedu res have a line leve l provider , 0=NO, 1= YES N SLC, RESULT,LMO DE,LPRNUM, PROVX,LINE CNT S SLC= 0,RESULT=1 ,LINECNT=0 F S SLC= $$LINIT1(S LC) Q:+SLC =0 D . S L INECNT=LIN ECNT+1 . D LINIT2 . I $D(LMODE (INSLEVEL) )#10=0 S R ESULT=0 Q . I $D(LPR NUM(INSLEV EL))#10=0 S RESULT=0 Q . S PRO VX=$G(INPU T("L-PROV" ,IBIEN,SLC ,LMODE(INS LEVEL),LPR NUM(INSLEV EL),PRTYPE )) . I PRO VX="" D Q .. S RESU LT=RESULT* 0 . S PROV X="^"_$P(P ROVX,";",2 )_$P(PROVX ,";",1)_") " . S RESU LT=RESULT* ($D(@PROVX )'=0) I +$ G(INPUT("S LC"))'=0,I NPUT("SLC" )>LINECNT S RESULT=0 Q RESULT ;TEST3() ; One Line Level prov ider is mo st signifi cant, 0=NO , 1=YES N SLC,RESULT ,LMODE,LPR NUM,PCOUNT ,PCOUNTF,P COUNTL,PRO VX,TEMPNOD E S SLC=0, RESULT=0 F S SLC=$$ LINIT1(SLC ) Q:+SLC=0 D . D LIN IT2 . I $D (LMODE(INS LEVEL))#10 =0 Q . I $ D(LPRNUM(I NSLEVEL))# 10=0 Q . S PROVX=$G( INPUT("L-P ROV",IBIEN ,SLC,LMODE (INSLEVEL) ,LPRNUM(IN SLEVEL),PR TYPE)) Q:P ROVX="" . I $D(FIRST INF)=0 D . . ; LOAD F IRST AVAIL ABLE PROVI DER INFORM ATION .. S FIRSTINF= $G(INPUT(" L-PROV",IB IEN,SLC,LM ODE(INSLEV EL),LPRNUM (INSLEVEL) ,PRTYPE)) .. S FIRST INF("L-PRO V",IBIEN)= IBIEN .. S FIRSTINF( "L-PROV",I BIEN,LMODE (INSLEVEL) ,LPRNUM(IN SLEVEL))=I NSLEVEL .. M FIRSTIN F("L-PROV" ,IBIEN,LMO DE(INSLEVE L),LPRNUM( INSLEVEL), PRTYPE)=IN PUT("L-PRO V",IBIEN,S LC,LMODE(I NSLEVEL),L PRNUM(INSL EVEL),PRTY PE) . S PC OUNT(PROVX )=$P($G(PC OUNT(PROVX )),"^",1)+ 1_"^"_SLC_ "^"_LMODE( INSLEVEL)_ "^"_LPRNUM (INSLEVEL) _"^"_PRTYP E S PROVX= "" F S PR OVX=$O(PCO UNT(PROVX) ) Q:PROVX= "" D . S PCOUNTF($P (PCOUNT(PR OVX),"^",1 ),PROVX)=$ P(PCOUNT(P ROVX),"^", 2,5) S PCO UNTL(1)=$O (PCOUNTF(" "),-1) Q:P COUNTL(1)= "" RESULT S PCOUNTL( 2,1)=$O(PC OUNTF(PCOU NTL(1),"") ,-1) Q:PCO UNTL(2,1)= "" RESULT S PCOUNTL( 2,2)=$O(PC OUNTF(PCOU NTL(1),PCO UNTL(2,1)) ,-1) I PCO UNTL(2,2)= "" D . S R ESULT=1 . ; LOAD MOS T SIGNIFIC ANT LINE L EVEL PROVI DER INFORM ATION . S MAXAINFO=P COUNTL(2,1 ) . S TEMP NODE=PCOUN TF(PCOUNTL (1),PCOUNT L(2,1)) . S MAXAINFO ("L-PROV", IBIEN)=IBI EN . S MAX AINFO("L-P ROV",IBIEN ,$P(TEMPNO DE,"^",2), $P(TEMPNOD E,"^",3))= INSLEVEL . M MAXAINF O("L-PROV" ,IBIEN,$P( TEMPNODE," ^",2),$P(T EMPNODE,"^ ",3),$P(TE MPNODE,"^" ,4))=INPUT ("L-PROV", IBIEN,$P(T EMPNODE,"^ ",1),$P(TE MPNODE,"^" ,2),$P(TEM PNODE,"^", 3),$P(TEMP NODE,"^",4 )) Q RESUL T ;TEST4() ; At leas t one line level pro vider matc hes the cl aim level provider, 0=NO, 1=YE S N CPROV, RESULT,LMO DE,LPRNUM, LPROV,SLC I $D(CMODE (INSLEVEL) )#10=0 Q 0 I $D(CPRN UM(INSLEVE L))#10=0 Q 0 S CPROV =$G(INPUT( "PROVINF", IBIEN,CMOD E(INSLEVEL ),CPRNUM(I NSLEVEL),P RTYPE)) Q: CPROV="" 0 S SLC=0,R ESULT=0 F S SLC=$$L INIT1(SLC) Q:+SLC=0 D . D LINI T2 . I $D( LMODE(INSL EVEL))#10= 0 Q . I $D (LPRNUM(IN SLEVEL))#1 0=0 Q . S LPROV=$G(I NPUT("L-PR OV",IBIEN, SLC,LMODE( INSLEVEL), LPRNUM(INS LEVEL),PRT YPE)) Q:LP ROV="" . I LPROV=CPR OV S RESUL T=1 Q RESU LT ;TEST5( ) ; There is only on e procedur e without a line lev el provide r, 0=NO, 1 =YES N SLC ,LMODE,LPR NUM,PROVCN T,RESULT S SLC=0,PRO VCNT=0,RES ULT=0 F S SLC=$$LIN IT1(SLC) Q :+SLC=0 D . D LINIT2 . I $D(LM ODE(INSLEV EL))#10=0 Q . I $D(L PRNUM(INSL EVEL))#10= 0 Q . S PR OVX=$G(INP UT("L-PROV ",IBIEN,SL C,LMODE(IN SLEVEL),LP RNUM(INSLE VEL),PRTYP E)) . S:PR OVX'="" PR OVCNT=PROV CNT+1 I +$ G(INPUT("S LC"))'=0,I NPUT("SLC" )=(PROVCNT +1) S RESU LT=1 Q RES ULT ;A0000 0 ; Case 1 ; TESTS: Does Clai m Level Pr ovider Exi st: 0=NO ; All proce dures have a line le vel provid er: 0=NO ; One Line Level prov ider is mo st signifi cant: 0=NO ; At leas t one line level pro vider matc hes the cl aim level provider: 0=NO ; The re is only one proce dure witho ut a line level prov ider: 0=NO ; ; Move the first available line level provider to the cla im level. I $G(FIRST INF)="" Q M OUTPUT(" PROVINF",I BIEN)=FIRS TINF("L-PR OV",IBIEN) ; ; Remov e the clai m lines as sociated w ith the pr imary prov ider. S PR OVINFO=FIR STINF D RE MOVELN Q ; A00001 ; Case 2 ; T ESTS: Does Claim Lev el Provide r Exist: 0 =NO ; All procedures have a li ne level p rovider: 0 =NO ; One Line Level provider is most si gnificant: 0=NO ; At least one line leve l provider matches t he claim l evel provi der: 0=NO ; There is only one procedure without a line level provider: 1=YES ; ; Move the first avai lable line level pro vider to t he claim l evel. I $G (FIRSTINF) ="" Q M OU TPUT("PROV INF",IBIEN )=FIRSTINF ("L-PROV", IBIEN) ; ; Remove th e claim li nes associ ated with the primar y provider . S PROVIN FO=FIRSTIN F D REMOVE LN Q ;A000 10 ; Case 3 - This case can n ever happe n! ; ACTIO NS: N/A - Transmit a s is. Q ;A 00011 ; C ase 4 - Th is case ca n never ha ppen! ; AC TIONS: N/A - Transmi t as is. Q ;A00100 ; Case 5 ; TESTS: Do es Claim L evel Provi der Exist: 0=NO ; Al l procedur es have a line level provider: 0=NO ; On e Line Lev el provide r is most significan t: 1=YES ; At least one line l evel provi der matche s the clai m level pr ovider: 0= NO ; There is only o ne procedu re without a line le vel provid er: 0=NO ; ; Set the claim lev el provide r equal to the most significan t line lev el provide r. I $G(MA XAINFO)="" Q M OUTPU T("PROVINF ",IBIEN)=M AXAINFO("L -PROV",IBI EN) ; ; Re move the c laim lines associate d with the primary p rovider. S PROVINFO= MAXAINFO D REMOVELN ; Q ;A0010 1 ; Case 6 ; TESTS: Does Clai m Level Pr ovider Exi st: 0=NO ; All proce dures have a line le vel provid er: 0=NO ; One Line Level prov ider is mo st signifi cant: 1=YE S ; At lea st one lin e level pr ovider mat ches the c laim level provider: 0=NO ; Th ere is onl y one proc edure with out a line level pro vider: 1=Y ES ; ; Set the claim level pro vider equa l to the m ost signif icant line level pro vider. I $ G(MAXAINFO )="" Q M O UTPUT("PRO VINF",IBIE N)=MAXAINF O("L-PROV" ,IBIEN) ; ; Remove t he claim l ines assoc iated with the prima ry provide r. S PROVI NFO=MAXAIN FO D REMOV ELN ; Q ;A 00110 ; C ase 7 - Th is case ca n never ha ppen! ; AC TIONS: N/A - Transmi t as is. Q ;A00111 ; Case 8 - This case can never happen! ; ACTIONS: N/A - Tran smit as is . Q ;A0100 0 ; Case 9 ; TESTS: Does Clai m Level Pr ovider Exi st: 0=NO ; All proce dures have a line le vel provid er: 1=YES ; One Line Level pro vider is m ost signif icant: 0=N O ; At lea st one lin e level pr ovider mat ches the c laim level provider: 0=NO ; Th ere is onl y one proc edure with out a line level pro vider: 0=N O ; ; Move the first available line leve l provider to the cl aim level. ; Set the claim lev el provide r equal to the most significan t line lev el provide r. I $G(FI RSTINF)="" Q M OUTPU T("PROVINF ",IBIEN)=F IRSTINF("L -PROV",IBI EN) ; ; Re move the c laim lines associate d with the primary p rovider. S PROVINFO= FIRSTINF D REMOVELN Q ;A01001 ; Case 10 - This ca se can nev er happen! ; ACTIONS : N/A - Tr ansmit as is. Q ;A01 010 ; Cas e 11 - Thi s case can never hap pen! ; ACT IONS: N/A - Transmit as is. Q ;A01011 ; Case 12 - This case can never happen! ; ACTIONS: N/A - Tran smit as is . Q ;A0110 0 ; Case 13 ; TESTS : Does Cla im Level P rovider Ex ist: 0=NO ; All proc edures hav e a line l evel provi der: 1=YES ; One Lin e Level pr ovider is most signi ficant: 1= YES ; At l east one l ine level provider m atches the claim lev el provide r: 0=NO ; There is o nly one pr ocedure wi thout a li ne level p rovider: 0 =NO ; ; Se t the clai m level pr ovider equ al to the most signi ficant lin e level pr ovider. I $G(MAXAINF O)="" Q M OUTPUT("PR OVINF",IBI EN)=MAXAIN FO("L-PROV ",IBIEN) ; ; Remove the claim lines asso ciated wit h the prim ary provid er. S PROV INFO=MAXAI NFO D REMO VELN ; Q ; A01101 ; Case 14 - This case can never happen! ; ACTIONS: N /A - Trans mit as is. Q ;A01110 ; Case 1 5 - This c ase can ne ver happen ! ; ACTION S: N/A - T ransmit as is. Q ;A0 1111 ; Ca se 16 - Th is case ca n never ha ppen! ; AC TIONS: N/A - Transmi t as is. Q ;A10000 ; Case 17 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 0=NO ; One Line L evel provi der is mos t signific ant: 0=NO ; At least one line level prov ider match es the cla im level p rovider: 0 =NO ; Ther e is only one proced ure withou t a line l evel provi der: 0=NO ; ; ACTION S: Transmi t as is. ; Q ;A10001 ; Case 18 ; TESTS : Does Cla im Level P rovider Ex ist: 1=YES ; All pro cedures ha ve a line level prov ider: 0=NO ; One Lin e Level pr ovider is most signi ficant: 0= NO ; At le ast one li ne level p rovider ma tches the claim leve l provider : 0=NO ; T here is on ly one pro cedure wit hout a lin e level pr ovider: 1= YES ; ; AC TIONS: Tra nsmit as i s. ; Q ;A1 0010 ; C ase 19 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 0=NO ; One Line Leve l provider is most s ignificant : 0=NO ; A t least on e line lev el provide r matches the claim level prov ider: 1=YE S ; There is only on e procedur e without a line lev el provide r: 0=NO ; ; Remove t he claim l ines assoc iated with the claim level pro vider. D R EMOVELN ; Q ;A10011 ; Case 2 0 ; TESTS: Does Clai m Level Pr ovider Exi st: 1=YES ; All proc edures hav e a line l evel provi der: 0=NO ; One Line Level pro vider is m ost signif icant: 0=N O ; At lea st one lin e level pr ovider mat ches the c laim level provider: 1=YES ; T here is on ly one pro cedure wit hout a lin e level pr ovider: 1= YES ; ; Re move the c laim lines associate d with the claim lev el provide r. D REMOV ELN ; Q ;A 10100 ; Case 21 ; TESTS: Doe s Claim Le vel Provid er Exist: 1=YES ; Al l procedur es have a line level provider: 0=NO ; On e Line Lev el provide r is most significan t: 1=YES ; At least one line l evel provi der matche s the clai m level pr ovider: 0= NO ; There is only o ne procedu re without a line le vel provid er: 0=NO ; ; ACTIONS : Transmit as is. ; Q ;A10101 ; Case 2 2 ; TESTS: Does Clai m Level Pr ovider Exi st: 1=YES ; All proc edures hav e a line l evel provi der: 0=NO ; One Line Level pro vider is m ost signif icant: 1=Y ES ; At le ast one li ne level p rovider ma tches the claim leve l provider : 0=NO ; T here is on ly one pro cedure wit hout a lin e level pr ovider: 1= YES ; ; AC TIONS: Tra nsmit as i s. ; Q ;A1 0110 ; C ase 23 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 0=NO ; One Line Leve l provider is most s ignificant : 1=YES ; At least o ne line le vel provid er matches the claim level pro vider: 1=Y ES ; There is only o ne procedu re without a line le vel provid er: 0=NO ; ; Remove the claim lines asso ciated wit h the clai m level pr ovider. D REMOVELN ; Q ;A10111 ; Case 24 ; TESTS : Does Cla im Level P rovider Ex ist: 1=YES ; All pro cedures ha ve a line level prov ider: 0=NO ; One Lin e Level pr ovider is most signi ficant: 1= YES ; At l east one l ine level provider m atches the claim lev el provide r: 1=YES ; There is only one p rocedure w ithout a l ine level provider: 1=YES ; ; Remove the claim lin es associa ted with t he claim l evel provi der. D REM OVELN ; Q ;A11000 ; Case 25 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 1=YES ; One Line Level prov ider is mo st signifi cant: 0=NO ; At leas t one line level pro vider matc hes the cl aim level provider: 0=NO ; The re is only one proce dure witho ut a line level prov ider: 0=NO ; S STATU S="0^CASE 25 ERROR" ; Q ;A1100 1 ; Case 26 - This case can never happ en! ; ACTI ONS: N/A - Transmit as is. Q ; A11010 ; Case 27 ; TESTS: Do es Claim L evel Provi der Exist: 1=YES ; A ll procedu res have a line leve l provider : 1=YES ; One Line L evel provi der is mos t signific ant: 0=NO ; At least one line level prov ider match es the cla im level p rovider: 1 =YES ; The re is only one proce dure witho ut a line level prov ider: 0=NO ; ; Remov e the clai m lines as sociated w ith the cl aim level provider. D REMOVELN ; Q ;A110 11 ; Cas e 28 - Thi s case can never hap pen! ; ACT IONS: N/A - Transmit as is. Q ;A11100 ; Case 29 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 1=YES ; One Line Level prov ider is mo st signifi cant: 1=YE S ; At lea st one lin e level pr ovider mat ches the c laim level provider: 0=NO ; Th ere is onl y one proc edure with out a line level pro vider: 0=N O ; S STAT US="0^CASE 29 ERROR" ; Q ;A111 01 ; Cas e 30 - Thi s case can never hap pen! ; ACT IONS: N/A - Transmit as is. Q ;A11110 ; Case 31 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 1=YES ; One Line Level prov ider is mo st signifi cant: 1=YE S ; At lea st one lin e level pr ovider mat ches the c laim level provider: 1=YES ; T here is on ly one pro cedure wit hout a lin e level pr ovider: 0= NO ; ; Rem ove the cl aim lines associated with the claim leve l provider . D REMOVE LN ; Q ;A1 1111 ; C ase 32 - T his case c an never h appen! ; A CTIONS: N/ A - Transm it as is. Q ;CINIT1 ; Claim level ini tiation S IBIEN=$O(I NPUT("L-PR OV",0)) I IBIEN="" S IBIEN=$O( INPUT("PRO VINF",0)) I IBIEN="" S IBIEN=$ O(INPUT("L AB/FAC",0) ) Q ;CINIT 2 ; Cla im level i nitiation N MODEX,PR NUMX,PROVX F MODEX=" C","O" D . S PRNUMX= 0 F S PRN UMX=$O(INP UT("PROVIN F",IBIEN,M ODEX,PRNUM X)) Q:+PRN UMX=0 D .. I $G(INPU T("PROVINF ",IBIEN,MO DEX,PRNUMX ))="" Q .. I INPUT(" PROVINF",I BIEN,MODEX ,PRNUMX)=I NSLEVEL S CMODE(INSL EVEL)=MODE X,CPRNUM(I NSLEVEL)=P RNUMX Q ;L INIT1(SLC) ; Line le vel initia tion Q $O( INPUT("L-P ROV",IBIEN ,SLC)) ;LI NIT2 ; Line level initiatio n N MODEX, PRNUMX,PRO VX F MODEX ="C","O" D . S PRNUM X=0 F S P RNUMX=$O(I NPUT("L-PR OV",IBIEN, SLC,MODEX, PRNUMX)) Q :+PRNUMX=0 D .. I IN PUT("L-PRO V",IBIEN,S LC,MODEX,P RNUMX)=INS LEVEL S LM ODE(INSLEV EL)=MODEX, LPRNUM(INS LEVEL)=PRN UMX Q ;REM OVELN ; Remove th e claim li nes associ ated with the claim level prov ider. N MO DEX,PRNUMX ,PROVX S S LC=0 F S SLC=$O(OUT PUT("L-PRO V",IBIEN,S LC)) Q:+SL C=0 D . F MODEX="C", "O" D .. S PRNUMX=0 F S PRNUM X=$O(OUTPU T("L-PROV" ,IBIEN,SLC ,MODEX,PRN UMX)) Q:+P RNUMX=0 D ... Q:$G(P ROVINFO)=" " ... I $G (OUTPUT("L -PROV",IBI EN,SLC,MOD EX,PRNUMX, PRTYPE))=P ROVINFO D .... K OUT PUT("L-PRO V",IBIEN,S LC,MODEX,P RNUMX,PRTY PE) .... I $D(OUTPUT ("L-PROV", IBIEN,SLC, MODEX,PRNU MX))=1 K O UTPUT("L-P ROV",IBIEN ,SLC,MODEX ,PRNUMX) . ... I $D(O UTPUT("L-P ROV",IBIEN ,SLC,MODEX ))=1 K OUT PUT("L-PRO V",IBIEN,S LC,MODEX) .... I $D( OUTPUT("L- PROV",IBIE N,SLC))=1 K OUTPUT(" L-PROV",IB IEN,SLC) Q | |
| 1699 | Modified L ogic (Chan ges are in bold) | |
| 1700 | IBCEF81 ;A LB/BI - PR OVIDER ADJ USTMENTS ; 11-OCT-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32,473,592 **;21-MAR- 94;Build 2 9 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; Q ;EN(INP UT) ; FIRS T ENTRY PO INT N INSL EVEL,PRTYP E,OUTPUT,I BIEN,CMODE ,CPRNUM,ST ATUS S STA TUS=1 I $D (INPUT)=0 S STATUS=0 Q STATUS I (($G(IBX FORM)=2)!( $G(IBXFORM )=3)) D EN ^IBCEF82(. INPUT) Q S TATUS ; PERFORM L OCAL PRINT BUSINESS RULES K OU TPUT M OUT PUT=INPUT D CINIT1 Q :IBIEN="" STATUS F I NSLEVEL="P ","S","T" D ; P=P RIMARY, S= SECONDARY, T=TERTIAR Y . D CINI T2 . ;JWS; IB*2.0*592 ; 6 assist ant surgeo n for dent al . F PRT YPE=1,2,3, 5,6,9 D ; 1=REFER RING, 2=OP ERATING, 3 =RENDERING , 5=SUPERV ISING, 6=A SSISTANT S URGEON, 9= OTHER OPER ATING .. D START(INS LEVEL,PRTY PE,.OUTPUT ) K INPUT M INPUT=OU TPUT Q STA TUSSTART(I NSLEVEL,PR TYPE,OUTPU T) ; START PROCESSIN G N INTERM ,PROVINFO, MAXAINFO,F IRSTINF S INTERM="A" S INTERM= INTERM_$$T EST1 ; Do es Claim L evel Provi der Exist, 0=NO, 1=Y ES S INTER M=INTERM_$ $TEST2 ; All proced ures have a line lev el provide r, 0=NO, 1 =YES S INT ERM=INTERM _$$TEST3 ; One Line Level pro vider is m ost signif icant, 0=N O, 1=YES S INTERM=IN TERM_$$TES T4 ; At l east one l ine level provider m atches the claim lev el provide r, 0=NO, 1 =YES S INT ERM=INTERM _$$TEST5 ; There is only one procedure without a line level provider, 0=NO, 1=Y ES D @INTE RM Q ;TES T1() ; Doe s Claim Le vel Provid er Exist, 0=NO, 1=YE S N PROVX, PROVY I $D (CMODE(INS LEVEL))#10 =0 Q 0 I $ D(CPRNUM(I NSLEVEL))# 10=0 Q 0 S (PROVX,PR OVY)=$G(IN PUT("PROVI NF",IBIEN, CMODE(INSL EVEL),CPRN UM(INSLEVE L),PRTYPE) ) Q:PROVX= "" 0 S PRO VX="^"_$P( PROVX,";", 2)_$P(PROV X,";",1)_" )" I $D(@P ROVX) D Q 1 ;CLAIM PROVIDER E XISTS, RET URN TRUE. . ; LOAD C LAIM LEVEL PROVIDER INFORMATIO N . S PROV INFO=PROVY . S PROVI NFO("PROVI NF",IBIEN) =IBIEN . S PROVINFO( "PROVINF", IBIEN,CMOD E(INSLEVEL ))="" . S PROVINFO(" PROVINF",I BIEN,CMODE (INSLEVEL) ,CPRNUM(IN SLEVEL))=I NSLEVEL . M PROVINFO ("PROVINF" ,IBIEN,CMO DE(INSLEVE L),CPRNUM( INSLEVEL), PRTYPE)=IN PUT("PROVI NF",IBIEN, CMODE(INSL EVEL),CPRN UM(INSLEVE L),PRTYPE) Q 0 ;TEST 2() ; All procedures have a li ne level p rovider, 0 =NO, 1=YES N SLC,RES ULT,LMODE, LPRNUM,PRO VX,LINECNT S SLC=0,R ESULT=1,LI NECNT=0 F S SLC=$$L INIT1(SLC) Q:+SLC=0 D . S LINE CNT=LINECN T+1 . D LI NIT2 . I $ D(LMODE(IN SLEVEL))#1 0=0 S RESU LT=0 Q . I $D(LPRNUM (INSLEVEL) )#10=0 S R ESULT=0 Q . S PROVX= $G(INPUT(" L-PROV",IB IEN,SLC,LM ODE(INSLEV EL),LPRNUM (INSLEVEL) ,PRTYPE)) . I PROVX= "" D Q .. S RESULT= RESULT*0 . S PROVX=" ^"_$P(PROV X,";",2)_$ P(PROVX,"; ",1)_")" . S RESULT= RESULT*($D (@PROVX)'= 0) I +$G(I NPUT("SLC" ))'=0,INPU T("SLC")>L INECNT S R ESULT=0 Q RESULT ;TE ST3() ; On e Line Lev el provide r is most significan t, 0=NO, 1 =YES N SLC ,RESULT,LM ODE,LPRNUM ,PCOUNT,PC OUNTF,PCOU NTL,PROVX, TEMPNODE S SLC=0,RES ULT=0 F S SLC=$$LIN IT1(SLC) Q :+SLC=0 D . D LINIT2 . I $D(LM ODE(INSLEV EL))#10=0 Q . I $D(L PRNUM(INSL EVEL))#10= 0 Q . S PR OVX=$G(INP UT("L-PROV ",IBIEN,SL C,LMODE(IN SLEVEL),LP RNUM(INSLE VEL),PRTYP E)) Q:PROV X="" . I $ D(FIRSTINF )=0 D .. ; LOAD FIRS T AVAILABL E PROVIDER INFORMATI ON .. S FI RSTINF=$G( INPUT("L-P ROV",IBIEN ,SLC,LMODE (INSLEVEL) ,LPRNUM(IN SLEVEL),PR TYPE)) .. S FIRSTINF ("L-PROV", IBIEN)=IBI EN .. S FI RSTINF("L- PROV",IBIE N,LMODE(IN SLEVEL),LP RNUM(INSLE VEL))=INSL EVEL .. M FIRSTINF(" L-PROV",IB IEN,LMODE( INSLEVEL), LPRNUM(INS LEVEL),PRT YPE)=INPUT ("L-PROV", IBIEN,SLC, LMODE(INSL EVEL),LPRN UM(INSLEVE L),PRTYPE) . S PCOUN T(PROVX)=$ P($G(PCOUN T(PROVX)), "^",1)+1_" ^"_SLC_"^" _LMODE(INS LEVEL)_"^" _LPRNUM(IN SLEVEL)_"^ "_PRTYPE S PROVX="" F S PROVX =$O(PCOUNT (PROVX)) Q :PROVX="" D . S PCO UNTF($P(PC OUNT(PROVX ),"^",1),P ROVX)=$P(P COUNT(PROV X),"^",2,5 ) S PCOUNT L(1)=$O(PC OUNTF(""), -1) Q:PCOU NTL(1)="" RESULT S P COUNTL(2,1 )=$O(PCOUN TF(PCOUNTL (1),""),-1 ) Q:PCOUNT L(2,1)="" RESULT S P COUNTL(2,2 )=$O(PCOUN TF(PCOUNTL (1),PCOUNT L(2,1)),-1 ) I PCOUNT L(2,2)="" D . S RESU LT=1 . ; L OAD MOST S IGNIFICANT LINE LEVE L PROVIDER INFORMATI ON . S MAX AINFO=PCOU NTL(2,1) . S TEMPNOD E=PCOUNTF( PCOUNTL(1) ,PCOUNTL(2 ,1)) . S M AXAINFO("L -PROV",IBI EN)=IBIEN . S MAXAIN FO("L-PROV ",IBIEN,$P (TEMPNODE, "^",2),$P( TEMPNODE," ^",3))=INS LEVEL . M MAXAINFO(" L-PROV",IB IEN,$P(TEM PNODE,"^", 2),$P(TEMP NODE,"^",3 ),$P(TEMPN ODE,"^",4) )=INPUT("L -PROV",IBI EN,$P(TEMP NODE,"^",1 ),$P(TEMPN ODE,"^",2) ,$P(TEMPNO DE,"^",3), $P(TEMPNOD E,"^",4)) Q RESULT ; TEST4() ; At least o ne line le vel provid er matches the claim level pro vider, 0=N O, 1=YES N CPROV,RES ULT,LMODE, LPRNUM,LPR OV,SLC I $ D(CMODE(IN SLEVEL))#1 0=0 Q 0 I $D(CPRNUM( INSLEVEL)) #10=0 Q 0 S CPROV=$G (INPUT("PR OVINF",IBI EN,CMODE(I NSLEVEL),C PRNUM(INSL EVEL),PRTY PE)) Q:CPR OV="" 0 S SLC=0,RESU LT=0 F S SLC=$$LINI T1(SLC) Q: +SLC=0 D . D LINIT2 . I $D(LMO DE(INSLEVE L))#10=0 Q . I $D(LP RNUM(INSLE VEL))#10=0 Q . S LPR OV=$G(INPU T("L-PROV" ,IBIEN,SLC ,LMODE(INS LEVEL),LPR NUM(INSLEV EL),PRTYPE )) Q:LPROV ="" . I LP ROV=CPROV S RESULT=1 Q RESULT ;TEST5() ; There is only one p rocedure w ithout a l ine level provider, 0=NO, 1=YE S N SLC,LM ODE,LPRNUM ,PROVCNT,R ESULT S SL C=0,PROVCN T=0,RESULT =0 F S SL C=$$LINIT1 (SLC) Q:+S LC=0 D . D LINIT2 . I $D(LMODE (INSLEVEL) )#10=0 Q . I $D(LPRN UM(INSLEVE L))#10=0 Q . S PROVX =$G(INPUT( "L-PROV",I BIEN,SLC,L MODE(INSLE VEL),LPRNU M(INSLEVEL ),PRTYPE)) . S:PROVX '="" PROVC NT=PROVCNT +1 I +$G(I NPUT("SLC" ))'=0,INPU T("SLC")=( PROVCNT+1) S RESULT= 1 Q RESULT ;A00000 ; Case 1 ; TESTS: Do es Claim L evel Provi der Exist: 0=NO ; Al l procedur es have a line level provider: 0=NO ; On e Line Lev el provide r is most significan t: 0=NO ; At least o ne line le vel provid er matches the claim level pro vider: 0=N O ; There is only on e procedur e without a line lev el provide r: 0=NO ; ; Move the first ava ilable lin e level pr ovider to the claim level. I $ G(FIRSTINF )="" Q M O UTPUT("PRO VINF",IBIE N)=FIRSTIN F("L-PROV" ,IBIEN) ; ; Remove t he claim l ines assoc iated with the prima ry provide r. S PROVI NFO=FIRSTI NF D REMOV ELN Q ;A00 001 ; Cas e 2 ; TEST S: Does Cl aim Level Provider E xist: 0=NO ; All pro cedures ha ve a line level prov ider: 0=NO ; One Lin e Level pr ovider is most signi ficant: 0= NO ; At le ast one li ne level p rovider ma tches the claim leve l provider : 0=NO ; T here is on ly one pro cedure wit hout a lin e level pr ovider: 1= YES ; ; Mo ve the fir st availab le line le vel provid er to the claim leve l. I $G(FI RSTINF)="" Q M OUTPU T("PROVINF ",IBIEN)=F IRSTINF("L -PROV",IBI EN) ; ; Re move the c laim lines associate d with the primary p rovider. S PROVINFO= FIRSTINF D REMOVELN Q ;A00010 ; Case 3 - This cas e can neve r happen! ; ACTIONS: N/A - Tra nsmit as i s. Q ;A000 11 ; Case 4 - This case can n ever happe n! ; ACTIO NS: N/A - Transmit a s is. Q ;A 00100 ; C ase 5 ; TE STS: Does Claim Leve l Provider Exist: 0= NO ; All p rocedures have a lin e level pr ovider: 0= NO ; One L ine Level provider i s most sig nificant: 1=YES ; At least one line leve l provider matches t he claim l evel provi der: 0=NO ; There is only one procedure without a line level provider: 0=NO ; ; Set the cl aim level provider e qual to th e most sig nificant l ine level provider. I $G(MAXAI NFO)="" Q M OUTPUT(" PROVINF",I BIEN)=MAXA INFO("L-PR OV",IBIEN) ; ; Remov e the clai m lines as sociated w ith the pr imary prov ider. S PR OVINFO=MAX AINFO D RE MOVELN ; Q ;A00101 ; Case 6 ; TESTS: Do es Claim L evel Provi der Exist: 0=NO ; Al l procedur es have a line level provider: 0=NO ; On e Line Lev el provide r is most significan t: 1=YES ; At least one line l evel provi der matche s the clai m level pr ovider: 0= NO ; There is only o ne procedu re without a line le vel provid er: 1=YES ; ; Set th e claim le vel provid er equal t o the most significa nt line le vel provid er. I $G(M AXAINFO)=" " Q M OUTP UT("PROVIN F",IBIEN)= MAXAINFO(" L-PROV",IB IEN) ; ; R emove the claim line s associat ed with th e primary provider. S PROVINFO =MAXAINFO D REMOVELN ; Q ;A001 10 ; Case 7 - This case can n ever happe n! ; ACTIO NS: N/A - Transmit a s is. Q ;A 00111 ; C ase 8 - Th is case ca n never ha ppen! ; AC TIONS: N/A - Transmi t as is. Q ;A01000 ; Case 9 ; TESTS: Do es Claim L evel Provi der Exist: 0=NO ; Al l procedur es have a line level provider: 1=YES ; O ne Line Le vel provid er is most significa nt: 0=NO ; At least one line l evel provi der matche s the clai m level pr ovider: 0= NO ; There is only o ne procedu re without a line le vel provid er: 0=NO ; ; Move th e first av ailable li ne level p rovider to the claim level. ; Set the cl aim level provider e qual to th e most sig nificant l ine level provider. I $G(FIRST INF)="" Q M OUTPUT(" PROVINF",I BIEN)=FIRS TINF("L-PR OV",IBIEN) ; ; Remov e the clai m lines as sociated w ith the pr imary prov ider. S PR OVINFO=FIR STINF D RE MOVELN Q ; A01001 ; Case 10 - This case can never happen! ; ACTIONS: N /A - Trans mit as is. Q ;A01010 ; Case 1 1 - This c ase can ne ver happen ! ; ACTION S: N/A - T ransmit as is. Q ;A0 1011 ; Ca se 12 - Th is case ca n never ha ppen! ; AC TIONS: N/A - Transmi t as is. Q ;A01100 ; Case 13 ; TESTS: D oes Claim Level Prov ider Exist : 0=NO ; A ll procedu res have a line leve l provider : 1=YES ; One Line L evel provi der is mos t signific ant: 1=YES ; At leas t one line level pro vider matc hes the cl aim level provider: 0=NO ; The re is only one proce dure witho ut a line level prov ider: 0=NO ; ; Set t he claim l evel provi der equal to the mos t signific ant line l evel provi der. I $G( MAXAINFO)= "" Q M OUT PUT("PROVI NF",IBIEN) =MAXAINFO( "L-PROV",I BIEN) ; ; Remove the claim lin es associa ted with t he primary provider. S PROVINF O=MAXAINFO D REMOVEL N ; Q ;A01 101 ; Cas e 14 - Thi s case can never hap pen! ; ACT IONS: N/A - Transmit as is. Q ;A01110 ; Case 15 - This case can never happen! ; ACTIONS: N/A - Tran smit as is . Q ;A0111 1 ; Case 16 - This case can n ever happe n! ; ACTIO NS: N/A - Transmit a s is. Q ;A 10000 ; C ase 17 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 0=NO ; One Line Leve l provider is most s ignificant : 0=NO ; A t least on e line lev el provide r matches the claim level prov ider: 0=NO ; There i s only one procedure without a line leve l provider : 0=NO ; ; ACTIONS: Transmit a s is. ; Q ;A10001 ; Case 18 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 0=NO ; One Line L evel provi der is mos t signific ant: 0=NO ; At least one line level prov ider match es the cla im level p rovider: 0 =NO ; Ther e is only one proced ure withou t a line l evel provi der: 1=YES ; ; ACTIO NS: Transm it as is. ; Q ;A1001 0 ; Case 19 ; TEST S: Does Cl aim Level Provider E xist: 1=YE S ; All pr ocedures h ave a line level pro vider: 0=N O ; One Li ne Level p rovider is most sign ificant: 0 =NO ; At l east one l ine level provider m atches the claim lev el provide r: 1=YES ; There is only one p rocedure w ithout a l ine level provider: 0=NO ; ; R emove the claim line s associat ed with th e claim le vel provid er. D REMO VELN ; Q ; A10011 ; Case 20 ; TESTS: Do es Claim L evel Provi der Exist: 1=YES ; A ll procedu res have a line leve l provider : 0=NO ; O ne Line Le vel provid er is most significa nt: 0=NO ; At least one line l evel provi der matche s the clai m level pr ovider: 1= YES ; Ther e is only one proced ure withou t a line l evel provi der: 1=YES ; ; Remov e the clai m lines as sociated w ith the cl aim level provider. D REMOVELN ; Q ;A101 00 ; Cas e 21 ; TES TS: Does C laim Level Provider Exist: 1=Y ES ; All p rocedures have a lin e level pr ovider: 0= NO ; One L ine Level provider i s most sig nificant: 1=YES ; At least one line leve l provider matches t he claim l evel provi der: 0=NO ; There is only one procedure without a line level provider: 0=NO ; ; ACTIONS: T ransmit as is. ; Q ; A10101 ; Case 22 ; TESTS: Do es Claim L evel Provi der Exist: 1=YES ; A ll procedu res have a line leve l provider : 0=NO ; O ne Line Le vel provid er is most significa nt: 1=YES ; At least one line level prov ider match es the cla im level p rovider: 0 =NO ; Ther e is only one proced ure withou t a line l evel provi der: 1=YES ; ; ACTIO NS: Transm it as is. ; Q ;A1011 0 ; Case 23 ; TEST S: Does Cl aim Level Provider E xist: 1=YE S ; All pr ocedures h ave a line level pro vider: 0=N O ; One Li ne Level p rovider is most sign ificant: 1 =YES ; At least one line level provider matches th e claim le vel provid er: 1=YES ; There is only one procedure without a line level provider: 0=NO ; ; Remove the claim lin es associa ted with t he claim l evel provi der. D REM OVELN ; Q ;A10111 ; Case 24 ; TESTS: D oes Claim Level Prov ider Exist : 1=YES ; All proced ures have a line lev el provide r: 0=NO ; One Line L evel provi der is mos t signific ant: 1=YES ; At leas t one line level pro vider matc hes the cl aim level provider: 1=YES ; Th ere is onl y one proc edure with out a line level pro vider: 1=Y ES ; ; Rem ove the cl aim lines associated with the claim leve l provider . D REMOVE LN ; Q ;A1 1000 ; C ase 25 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 1=YES ; On e Line Lev el provide r is most significan t: 0=NO ; At least o ne line le vel provid er matches the claim level pro vider: 0=N O ; There is only on e procedur e without a line lev el provide r: 0=NO ; S STATUS=" 0^CASE 25 ERROR" ; Q ;A11001 ; Case 26 - This ca se can nev er happen! ; ACTIONS : N/A - Tr ansmit as is. Q ;A11 010 ; Ca se 27 ; TE STS: Does Claim Leve l Provider Exist: 1= YES ; All procedures have a li ne level p rovider: 1 =YES ; One Line Leve l provider is most s ignificant : 0=NO ; A t least on e line lev el provide r matches the claim level prov ider: 1=YE S ; There is only on e procedur e without a line lev el provide r: 0=NO ; ; Remove t he claim l ines assoc iated with the claim level pro vider. D R EMOVELN ; Q ;A11011 ; Case 2 8 - This c ase can ne ver happen ! ; ACTION S: N/A - T ransmit as is. Q ;A1 1100 ; C ase 29 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 1=YES ; On e Line Lev el provide r is most significan t: 1=YES ; At least one line l evel provi der matche s the clai m level pr ovider: 0= NO ; There is only o ne procedu re without a line le vel provid er: 0=NO ; S STATUS= "0^CASE 29 ERROR" ; Q ;A11101 ; Case 3 0 - This c ase can ne ver happen ! ; ACTION S: N/A - T ransmit as is. Q ;A1 1110 ; C ase 31 ; T ESTS: Does Claim Lev el Provide r Exist: 1 =YES ; All procedure s have a l ine level provider: 1=YES ; On e Line Lev el provide r is most significan t: 1=YES ; At least one line l evel provi der matche s the clai m level pr ovider: 1= YES ; Ther e is only one proced ure withou t a line l evel provi der: 0=NO ; ; Remove the claim lines ass ociated wi th the cla im level p rovider. D REMOVELN ; Q ;A1111 1 ; Case 32 - This case can never happ en! ; ACTI ONS: N/A - Transmit as is. Q ; CINIT1 ; Claim le vel initia tion S IBI EN=$O(INPU T("L-PROV" ,0)) I IBI EN="" S IB IEN=$O(INP UT("PROVIN F",0)) I I BIEN="" S IBIEN=$O(I NPUT("LAB/ FAC",0)) Q ;CINIT2 ; Claim level init iation N M ODEX,PRNUM X,PROVX F MODEX="C", "O" D . S PRNUMX=0 F S PRNUMX =$O(INPUT( "PROVINF", IBIEN,MODE X,PRNUMX)) Q:+PRNUMX =0 D .. I $G(INPUT(" PROVINF",I BIEN,MODEX ,PRNUMX))= "" Q .. I INPUT("PRO VINF",IBIE N,MODEX,PR NUMX)=INSL EVEL S CMO DE(INSLEVE L)=MODEX,C PRNUM(INSL EVEL)=PRNU MX Q ;LINI T1(SLC) ; Line level initiatio n Q $O(INP UT("L-PROV ",IBIEN,SL C)) ;LINIT 2 ; Lin e level in itiation N MODEX,PRN UMX,PROVX F MODEX="C ","O" D . S PRNUMX=0 F S PRNU MX=$O(INPU T("L-PROV" ,IBIEN,SLC ,MODEX,PRN UMX)) Q:+P RNUMX=0 D .. I INPUT ("L-PROV", IBIEN,SLC, MODEX,PRNU MX)=INSLEV EL S LMODE (INSLEVEL) =MODEX,LPR NUM(INSLEV EL)=PRNUMX Q ;REMOVE LN ; Re move the c laim lines associate d with the claim lev el provide r. N MODEX ,PRNUMX,PR OVX S SLC= 0 F S SLC =$O(OUTPUT ("L-PROV", IBIEN,SLC) ) Q:+SLC=0 D . F MOD EX="C","O" D .. S PR NUMX=0 F S PRNUMX=$ O(OUTPUT(" L-PROV",IB IEN,SLC,MO DEX,PRNUMX )) Q:+PRNU MX=0 D ... Q:$G(PROV INFO)="" . .. I $G(OU TPUT("L-PR OV",IBIEN, SLC,MODEX, PRNUMX,PRT YPE))=PROV INFO D ... . K OUTPUT ("L-PROV", IBIEN,SLC, MODEX,PRNU MX,PRTYPE) .... I $D (OUTPUT("L -PROV",IBI EN,SLC,MOD EX,PRNUMX) )=1 K OUTP UT("L-PROV ",IBIEN,SL C,MODEX,PR NUMX) .... I $D(OUTP UT("L-PROV ",IBIEN,SL C,MODEX))= 1 K OUTPUT ("L-PROV", IBIEN,SLC, MODEX) ... . I $D(OUT PUT("L-PRO V",IBIEN,S LC))=1 K O UTPUT("L-P ROV",IBIEN ,SLC) Q | |
| 1701 | ||
| 1702 | Routines | |
| 1703 | Activities | |
| 1704 | Routine Na me | |
| 1705 | IBCEM03 | |
| 1706 | Enhancemen t Category | |
| 1707 | New | |
| 1708 | Modify | |
| 1709 | Delete | |
| 1710 | No Change | |
| 1711 | RTM | |
| 1712 | ||
| 1713 | Related Op tions | |
| 1714 | None | |
| 1715 | Related Ro utines | |
| 1716 | Routines “ Called By” | |
| 1717 | Routines “ Called” | |
| 1718 | ||
| 1719 | ||
| 1720 | ||
| 1721 | ||
| 1722 | Data Dicti onary (DD) Reference s | |
| 1723 | ||
| 1724 | Related Pr otocols | |
| 1725 | None | |
| 1726 | Related In tegration Control Re gistration s (ICRs) | |
| 1727 | None | |
| 1728 | Data Passi ng | |
| 1729 | Input | |
| 1730 | Output Re ference | |
| 1731 | Both | |
| 1732 | Global Re ference | |
| 1733 | Local | |
| 1734 | Input Attr ibute Name and Defin ition | |
| 1735 | Name: | |
| 1736 | Definition : | |
| 1737 | Output Att ribute Nam e and Defi nition | |
| 1738 | Name: | |
| 1739 | Definition : | |
| 1740 | Current Lo gic | |
| 1741 | IBCEM03 ;A LB/TMP - 8 37 EDI RES UBMIT INDI VIDUAL BIL L PROCESSI NG ;17-SEP -96 ;;2.0; INTEGRATED BILLING;* *137,199,2 96,348,349 **;21-MAR- 94;Build 4 6 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. Q ;BILL2 ; Resubmit a transmitt ed bill wi th a new b atch # N D IC,DIR,DIE ,DA,DR,IB, IB0,IBDA,I BDA1,IBE,I BSTAT,IBBD A,IBOK,IBN EW,Y,ZTSK, IBTEST K ^ TMP("IBEDI _TEST_BATC H",$J) ; S DIR("A")= "ARE YOU R ESUBMITTIN G CLAIMS F OR TESTING ?: ",DIR(" B")="NO",D IR(0)="YA" D ^DIR K DIR I $D(D TOUT)!$D(D UOUT) Q I +Y S ^TMP( "IBEDI_TES T_BATCH",$ J)=1ASK N DPTNOFZY S DPTNOFZY= 1 ;Suppres s PATIENT file fuzzy lookups S IBTEST=+$ G(^TMP("IB EDI_TEST_B ATCH",$J)) ; Only au th or prin ted transm ittable bi ll valid f or non-tes t ; All pr eviously t ransmitted valid for test S DI C="^DGCR(3 99,",DIC(0 )="AEMQ",D IC("S")=$S ('IBTEST:" I $P($G(^( ""TX"")),U ,2),$P($G( ^(0)),U,13 )'="""","" 234""[$P($ G(^(0)),U, 13)",1:"I $O(^IBA(36 4,""B"",+Y ,0))") I I BTEST S DI C("A")="Se lect BILL/ CLAIMS BIL L NUMBER ( FOR RESUBM IT AS TEST ): " D ^DI C K DIC I Y<0 D Q . Q:'IBTEST . I $O(^T MP("IBEDI_ TEST_BATCH ",$J,0)) D .. M ^TMP ("IBRESUBM IT",$J)=^T MP("IBEDI_ TEST_BATCH ",$J) .. D ONE^IBCE8 37 . ; . K ^TMP("IBE DI_TEST_BA TCH",$J),^ TMP("IBRES UBMIT",$J) ; S IBIFN =+Y,IBDA=+ $$LAST364^ IBCEF4(IBI FN),IB0=$G (^IBA(364, IBDA,0)),I BSTAT=$P(I B0,U,3) ; I IB0="" W !,"Bill d oes not ex ist in BIL L TRANSMIS SION file" G ASK I I BTEST,$D(^ TMP("IBEDI _TEST_BATC H",$J,IBDA )) W !,"Bi ll already selected for test t ransmissio n" G ASK I $$COBN^IB CEF(IBIFN) =1,IBTEST S IBOK=1 D G:'IBOK ASK . S DI R("A")="BI LL IS A PR IMARY BILL , ARE YOU SURE YOU W ANT TO SEN D IT AS A TEST CLAIM ?: " . S D IR("B")="N O",DIR(0)= "YA" W ! D ^DIR K DI R . I Y'=1 S IBOK=0 ; I 'IBTES T,IBSTAT=" X" W !,"Bi ll is curr ently awai ting extra ct - will be submitt ed with ne xt batch r un" G ASK S IBBDA=+$ P(IB0,U,2) ,IB=$P($G( ^IBA(364.1 ,IBBDA,0)) ,U,9) ; I IB,'IBTEST D G:'IBO K ASK . S IBOK=1,ZTS K=IB D STA T^%ZTLOAD . I ZTSK(0 )=0 S DIE= "^IBA(364. 1,",DA=IBB DA,DR=".09 ///@" D ^D IE Q ;Tas k not sche duled - de lete task # . I "125 "[ZTSK(1) W *7,!,"Ca nnot resub mit this b ill.",!,"T his bill's current b atch is al ready ",$S ("2"[ZTSK( 1):"being resubmitte d",1:"sche duled for resubmissi on")," - T ask # is: ",IB,! S I BOK=0 ; W ! S DIR("A ",1)=" Pre viously In Batch #: "_$$EXPAND ^IBTRE(364 ,.02,$P(IB 0,U,2)) S DIR("A",2) ="Bill Tra nsmission Status: "_ $$EXPAND^I BTRE(364,. 03,IBSTAT) S DIR("A" ,3)=" Stat us Date: " _$$FMTE^XL FDT($P(IB0 ,U,4),2) S DIR("A",5 )=" " S DI R("A",4)=" Current B ill Status : "_$$EXPA ND^IBTRE(3 99,.13,$P( $G(^DGCR(3 99,+IBIFN, 0)),U,13)) I 'IBTEST ,IBSTAT'=" P" S DIR(" A",11)="WA RNING - BI LL TRANSMI TTED PREVI OUSLY" S:I BSTAT?1"A" .E DIR("A" ,11)=DIR(" A",11)_" & CONFIRMED AS RECEIV ED BY "_$P ("AUSTIN^G ENTRAN^INT ERMEDIARY^ CARRIER",U ,$TR(IBSTA T,"A")+1) S DIR("A") ="ARE YOU SURE YOU W ANT TO RES UBMIT THIS BILL"_$S( 'IBTEST:"" ,1:" AS A TEST CLAIM ")_"?: " S DIR(0)="Y A",DIR("B" )="NO" D ^ DIR K DIR ; W ! G:'Y ASK ; I I BTEST S ^T MP("IBEDI_ TEST_BATCH ",$J,IBDA) ="" G ASK ; S IBDA1= +$$ADDTBIL L^IBCB1(IB IFN) ;Add a new tran smit bill record ; S Y=$$TX1^I BCB1(IBDA1 ,1) ; I 'Y D G ASK . W !,*7," An error h as occurre d ... bill NOT re-su bmitted!!" . S DIK=" ^IBA(364," ,DA=IBDA1 D:DA ^DIK . L -^IBA( 364,IBDA) ; S IBNEW= $P($G(^IBA (364,+IBDA 1,0)),U,2) ; ;Update the old t ransmit bi ll record D UPDEDI^I BCEM(IBDA, "R") ; W ! ,"Bill # " ,$P($G(^DG CR(399,+IB 0,0)),U)," was re-su bmitted in batch # " ,$P($G(^IB A(364.1,+I BNEW,0)),U ) ; L -^IB A(364,IBDA ) G ASK ;P RINT1(IBIF N,IBDA,IB3 64,IBRESUB ) ; Print bill, subm it manuall y as resol ution ; fo r a return ed message ; IBIFN = ien of bi ll in file 399 ; IBD A = array returned f rom select ion of mes sage ; IB3 64 = ien o f transmit bill entr y in file 364 ; IBRE SUB = flag to indica te if bill is being resubmitte d via prin t ; N IBAC ,IBV,IB399 ,DFN,ZTSK, PRCASV,IBH OLD,IBTXPR T W ! I IB IFN="" S I BDA="" G P RINT1Q S I B399=$G(^D GCR(399,IB IFN,0)) I "34"'[$P(I B399,U,13) W !,*7,"B ill status must be A UTHORIZED or PRNT/TX to print the bill" S IBDA="" G PRINT1Q ; I $P($G( ^DGCR(399, IBIFN,"S") ),U,14)=DT W !,*7,"T his bill w as last pr inted toda y. You mus t wait at least 1 da y from the last",!," print date to print this bill using this function. " S IBDA=" " D PAUSE^ VALM1 G PR INT1Q ; S IBV=1,IBAC =4,DFN=$P( IB399,U,2) ,IBTXPRT=0 M IBHOLD( "IBDA")=IB DA D 4^IBC B1,ENS^%ZI SS M IBDA= IBHOLD("IB DA") ; I ' IBTXPRT W !,"Bill wa s not prin ted" S IBD A="" G PRI NT1Q ; D U PDEDI^IBCE M(IB364,"P ") ;PRINT1 Q Q ;SUB1 ; Select b ills in re ady for ex tract stat us to tran smit indiv idually N IB0,IB399, IBDA,IBIFN ,IBSEL,IBU ,X,Y,DA,DI C,Z,DIR K ^TMP("IBSE LX",$J) ; S IBSEL="" F D Q:' IBSEL . S DIR("S")=" I $P(^(0), U,3)=""X"" " . S DIR( 0)="PAO^36 4:AEMQ",DI R("A")="SE LECT "_$S( $D(^TMP("I BSELX",$J) ):"NEXT ", 1:"")_"BIL L TO TRANS MIT: " . S DIR("?")= "ONLY BILL S IN 'READ Y FOR EXTR ACT' STATU S CAN BE T RANSMITTED WITH THIS OPTION" . D ^DIR K DIR . I Y' >0 K:Y=U ^ TMP("IBSEL X",$J) S I BSEL="" Q . S IBSEL= +Y . S IBD A=+Y,IB0=$ G(^IBA(364 ,IBDA,0)), IBIFN=+IB0 ,IBU=$G(^D GCR(399,IB IFN,"U")), IB399=$G(^ (0)) . S Z =+$$NEEDMR A^IBEFUNC( IBIFN) . I '$$TXMT^I BCEF4(IBIF N,.IBNOTX) ,IBNOTX=2 D Q .. W !,$S(Z:"MR A",1:"EDI" )_" TRANSM ISSION PAR AMETER HAS BEEN TURN ED OFF",!! ,"BILL CAN NOT BE SEL ECTED" . ; . W ! . S DIR("A",1 )=" YOU HA VE SELECTE D BILL #: "_$P(IB399 ,U)_" ("_$ S($$INPAT^ IBCEF(IBIF N):"INPATI ENT",1:"OU TPATIENT") _"/"_$S($$ FT^IBCEF(I BIFN)=3:"U B-04",1:"C MS-1500")_ " FORMAT)" . S DIR(" A",2)=" PA TIENT NAME : "_$E($P( $G(^DPT(+$ P(IB399,U, 2),0)),U)_ $J("",28), 1,28)_" SS N: "_$P($G (^DPT(+$P( IB399,U,2) ,0)),U,9) . S DIR("A ",3)=" CAR E DATE(S): "_$$EXPAN D^IBTRE(39 9,151,$P(I BU,U))_" - "_$$EXPAN D^IBTRE(39 9,152,$P(I BU,U,2)) . S DIR("A" ,4)="'READ Y TO EXTRA CT' STATUS DATE: "_$ $EXPAND^IB TRE(364,.0 4,$P(IB0,U ,4)) . S D IR("?",1)= " " . S DI R("A",5)=" ",DIR("?" )="IF THIS IS THE BI LL YOU WAN T TO TRANS MIT, RESPO ND YES, OT HERWISE, R ESPOND NO" . S DIR(" A")="ARE Y OU SURE TH IS IS THE CORRECT BI LL TO TRAN SMIT?: " . S DIR(0)= "YAO",DIR( "B")="NO" D ^DIR K D IR W ! . I Y'=1 W !, "BILL NOT SELECTED" Q . ; . S ^TMP("IBSE LX",$J,IBD A)="" ; I '$O(^TMP(" IBSELX",$J ,0)) G SUB 1Q ; W !," Bills to b e transmit ted: " S Z =0 F S Z= $O(^TMP("I BSELX",$J, Z)) Q:'Z W !,?8,$P( $G(^DGCR(3 99,+$G(^IB A(364,Z,0) ),0)),U) W ! S DIR(" A")="OK TO TRANSMIT NOW?: ",DI R(0)="YA0" ,DIR("B")= "NO" D ^DI R K DIR G: Y'=1 SUB1Q W ! S ^TM P("IBSELX" ,$J)=0 D O NE^IBCE837 W !,"BILL (s) TRANSM ITTED ... BATCH #(s) : " S Z=0 F S Z=$O( ^TMP("IBCE -BATCH",$J ,Z)) Q:'Z W Z,$S($O (^(Z)):", ",1:"") I '$O(^TMP(" IBCE-BATCH ",$J,0)) W !,"NO BIL L(S) TRANS MITTED - C HECK ALERT S/MAIL FOR DETAILS" ;SUB1Q D P AUSE^VALM1 K ^TMP("I BSELX",$J) ,^TMP("IBC E-BATCH",$ J) Q ; | |
| 1742 | Modified L ogic (Chan ges are in bold) | |
| 1743 | IBCEM03 ;A LB/TMP - 8 37 EDI RES UBMIT INDI VIDUAL BIL L PROCESSI NG ;17-SEP -96 ;;2.0; INTEGRATED BILLING;* *137,199,2 96,348,349 ,592**;21- MAR-94;Bui ld 46 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. Q ;BILL 2 ; Resubm it a trans mitted bil l with a n ew batch # N DIC,DIR ,DIE,DA,DR ,IB,IB0,IB DA,IBDA1,I BE,IBSTAT, IBBDA,IBOK ,IBNEW,Y,Z TSK,IBTEST K ^TMP("I BEDI_TEST_ BATCH",$J) ; S DIR(" A")="ARE Y OU RESUBMI TTING CLAI MS FOR TES TING?: ",D IR("B")="N O",DIR(0)= "YA" D ^DI R K DIR I $D(DTOUT)! $D(DUOUT) Q I +Y S ^ TMP("IBEDI _TEST_BATC H",$J)=1AS K N DPTNOF ZY S DPTNO FZY=1 ;Sup press PATI ENT file f uzzy looku ps S IBTES T=+$G(^TMP ("IBEDI_TE ST_BATCH", $J)) ; Onl y auth or printed tr ansmittabl e bill val id for non -test ; Al l previous ly transmi tted valid for test S DIC="^DG CR(399,",D IC(0)="AEM Q",DIC("S" )=$S('IBTE ST:"I $P($ G(^(""TX"" )),U,2),$P ($G(^(0)), U,13)'=""" ",""234""[ $P($G(^(0) ),U,13)",1 :"I $O(^IB A(364,""B" ",+Y,0))") I IBTEST S DIC("A") ="Select B ILL/CLAIMS BILL NUMB ER (FOR RE SUBMIT AS TEST): " D ^DIC K DI C I Y<0 D Q . Q:'IB TEST . I $ O(^TMP("IB EDI_TEST_B ATCH",$J,0 )) D .. M ^TMP("IBRE SUBMIT",$J )=^TMP("IB EDI_TEST_B ATCH",$J) .. D ONE^I BCE837 . ; . K ^TMP( "IBEDI_TES T_BATCH",$ J),^TMP("I BRESUBMIT" ,$J) ; S I BIFN=+Y,IB DA=+$$LAST 364^IBCEF4 (IBIFN),IB 0=$G(^IBA( 364,IBDA,0 )),IBSTAT= $P(IB0,U,3 ) ; I IB0= "" W !,"Bi ll does no t exist in BILL TRAN SMISSION f ile" G ASK I IBTEST, $D(^TMP("I BEDI_TEST_ BATCH",$J, IBDA)) W ! ,"Bill alr eady selec ted for te st transmi ssion" G A SK I $$COB N^IBCEF(IB IFN)=1,IBT EST S IBOK =1 D G:'I BOK ASK . S DIR("A") ="BILL IS A PRIMARY BILL, ARE YOU SURE Y OU WANT TO SEND IT A S A TEST C LAIM?: " . S DIR("B" )="NO",DIR (0)="YA" W ! D ^DIR K DIR . I Y'=1 S IBO K=0 ; I 'I BTEST,IBST AT="X" W ! ,"Bill is currently awaiting e xtract - w ill be sub mitted wit h next bat ch run" G ASK S IBBD A=+$P(IB0, U,2),IB=$P ($G(^IBA(3 64.1,IBBDA ,0)),U,9) ; I IB,'IB TEST D G: 'IBOK ASK . S IBOK=1 ,ZTSK=IB D STAT^%ZTL OAD . I ZT SK(0)=0 S DIE="^IBA( 364.1,",DA =IBBDA,DR= ".09///@" D ^DIE Q ;Task not scheduled - delete t ask # . I "125"[ZTSK (1) W *7,! ,"Cannot r esubmit th is bill.", !,"This bi ll's curre nt batch i s already ",$S("2"[Z TSK(1):"be ing resubm itted",1:" scheduled for resubm ission")," - Task # is: ",IB,! S IBOK=0 ; W ! S DI R("A",1)=" Previousl y In Batch #: "_$$EX PAND^IBTRE (364,.02,$ P(IB0,U,2) ) S DIR("A ",2)="Bill Transmiss ion Status : "_$$EXPA ND^IBTRE(3 64,.03,IBS TAT) S DIR ("A",3)=" Status Dat e: "_$$FMT E^XLFDT($P (IB0,U,4), 2) S DIR(" A",5)=" " S DIR("A", 4)=" Curre nt Bill St atus: "_$$ EXPAND^IBT RE(399,.13 ,$P($G(^DG CR(399,+IB IFN,0)),U, 13)) I 'IB TEST,IBSTA T'="P" S D IR("A",11) ="WARNING - BILL TRA NSMITTED P REVIOUSLY" S:IBSTAT? 1"A".E DIR ("A",11)=D IR("A",11) _" & CONFI RMED AS RE CEIVED BY "_$P("AUST IN^GENTRAN ^INTERMEDI ARY^CARRIE R",U,$TR(I BSTAT,"A") +1) S DIR( "A")="ARE YOU SURE Y OU WANT TO RESUBMIT THIS BILL" _$S('IBTES T:"",1:" A S A TEST C LAIM")_"?: " S DIR(0 )="YA",DIR ("B")="NO" D ^DIR K DIR ; W ! G:'Y ASK ; I IBTEST S ^TMP("IB EDI_TEST_B ATCH",$J,I BDA)="" G ASK ; S IB DA1=+$$ADD TBILL^IBCB 1(IBIFN) ; Add a new transmit b ill record ; S Y=$$T X1^IBCB1(I BDA1,1) ; I 'Y D G ASK . W !, *7,"An err or has occ urred ... bill NOT r e-submitte d!!" . S D IK="^IBA(3 64,",DA=IB DA1 D:DA ^ DIK . L -^ IBA(364,IB DA) ; S IB NEW=$P($G( ^IBA(364,+ IBDA1,0)), U,2) ; ;Up date the o ld transmi t bill rec ord D UPDE DI^IBCEM(I BDA,"R") ; W !,"Bill # ",$P($G (^DGCR(399 ,+IB0,0)), U)," was r e-submitte d in batch # ",$P($G (^IBA(364. 1,+IBNEW,0 )),U) ; L -^IBA(364, IBDA) G AS K ;PRINT1( IBIFN,IBDA ,IB364,IBR ESUB) ; Pr int bill, submit man ually as r esolution ; for a re turned mes sage ; IBI FN = ien o f bill in file 399 ; IBDA = ar ray return ed from se lection of message ; IB364 = i en of tran smit bill entry in f ile 364 ; IBRESUB = flag to in dicate if bill is be ing resubm itted via print ; N IBAC,IBV,I B399,DFN,Z TSK,PRCASV ,IBHOLD,IB TXPRT W ! I IBIFN="" S IBDA="" G PRINT1Q S IB399=$ G(^DGCR(39 9,IBIFN,0) ) I "34"'[ $P(IB399,U ,13) W !,* 7,"Bill st atus must be AUTHORI ZED or PRN T/TX to pr int the bi ll" S IBDA ="" G PRIN T1Q ; I $P ($G(^DGCR( 399,IBIFN, "S")),U,14 )=DT W !,* 7,"This bi ll was las t printed today. You must wait at least 1 day from the last" ,!,"print date to pr int this b ill using this funct ion." S IB DA="" D PA USE^VALM1 G PRINT1Q ; S IBV=1, IBAC=4,DFN =$P(IB399, U,2),IBTXP RT=0 M IBH OLD("IBDA" )=IBDA D 4 ^IBCB1,ENS ^%ZISS M I BDA=IBHOLD ("IBDA") ; I 'IBTXPR T W !,"Bil l was not printed" S IBDA="" G PRINT1Q ; D UPDEDI^ IBCEM(IB36 4,"P") ;PR INT1Q Q ;S UB1 ; Sele ct bills i n ready fo r extract status to transmit i ndividuall y N IB0,IB 399,IBDA,I BIFN,IBSEL ,IBU,X,Y,D A,DIC,Z,DI R K ^TMP(" IBSELX",$J ) ; S IBSE L="" F D Q:'IBSEL . S DIR("S ")="I $P(^ (0),U,3)=" "X""" . S DIR(0)="PA O^364:AEMQ ",DIR("A") ="SELECT " _$S($D(^TM P("IBSELX" ,$J)):"NEX T ",1:"")_ "BILL TO T RANSMIT: " . S DIR(" ?")="ONLY BILLS IN ' READY FOR EXTRACT' S TATUS CAN BE TRANSMI TTED WITH THIS OPTIO N" . D ^DI R K DIR . I Y'>0 K:Y =U ^TMP("I BSELX",$J) S IBSEL=" " Q . S IB SEL=+Y . S IBDA=+Y,I B0=$G(^IBA (364,IBDA, 0)),IBIFN= +IB0,IBU=$ G(^DGCR(39 9,IBIFN,"U ")),IB399= $G(^(0)) . S Z=+$$NE EDMRA^IBEF UNC(IBIFN) . I '$$TX MT^IBCEF4( IBIFN,.IBN OTX),IBNOT X=2 D Q . . W !,$S(Z :"MRA",1:" EDI")_" TR ANSMISSION PARAMETER HAS BEEN TURNED OFF ",!!,"BILL CANNOT BE SELECTED" . ; . W ! . ;JWS;IB *2.0*592; added form #7 J430D to display . S DIR(" A",1)=" YO U HAVE SEL ECTED BILL #: "_$P(I B399,U)_" ("_$S($$IN PAT^IBCEF( IBIFN):"IN PATIENT",1 :"OUTPATIE NT")_"/"_$ S($$FT^IBC EF(IBIFN)= 3:"UB-04", $$FT^IBCEF (IBIFN)=7: "J430D",1: "CMS-1500" )_" FORMAT )" . S DIR ("A",2)=" PATIENT NA ME: "_$E($ P($G(^DPT( +$P(IB399, U,2),0)),U )_$J("",28 ),1,28)_" SSN: "_$P( $G(^DPT(+$ P(IB399,U, 2),0)),U,9 ) . S DIR( "A",3)=" C ARE DATE(S ): "_$$EXP AND^IBTRE( 399,151,$P (IBU,U))_" - "_$$EXP AND^IBTRE( 399,152,$P (IBU,U,2)) . S DIR(" A",4)="'RE ADY TO EXT RACT' STAT US DATE: " _$$EXPAND^ IBTRE(364, .04,$P(IB0 ,U,4)) . S DIR("?",1 )=" " . S DIR("A",5) =" ",DIR(" ?")="IF TH IS IS THE BILL YOU W ANT TO TRA NSMIT, RES POND YES, OTHERWISE, RESPOND N O" . S DIR ("A")="ARE YOU SURE THIS IS TH E CORRECT BILL TO TR ANSMIT?: " . S DIR(0 )="YAO",DI R("B")="NO " D ^DIR K DIR W ! . I Y'=1 W !,"BILL NO T SELECTED " Q . ; . S ^TMP("IB SELX",$J,I BDA)="" ; I '$O(^TMP ("IBSELX", $J,0)) G S UB1Q ; W ! ,"Bills to be transm itted: " S Z=0 F S Z=$O(^TMP( "IBSELX",$ J,Z)) Q:'Z W !,?8,$ P($G(^DGCR (399,+$G(^ IBA(364,Z, 0)),0)),U) W ! S DIR ("A")="OK TO TRANSMI T NOW?: ", DIR(0)="YA 0",DIR("B" )="NO" D ^ DIR K DIR G:Y'=1 SUB 1Q W ! S ^ TMP("IBSEL X",$J)=0 D ONE^IBCE8 37 W !,"BI LL(s) TRAN SMITTED .. . BATCH #( s): " S Z= 0 F S Z=$ O(^TMP("IB CE-BATCH", $J,Z)) Q:' Z W Z,$S( $O(^(Z)):" , ",1:"") I '$O(^TMP ("IBCE-BAT CH",$J,0)) W !,"NO B ILL(S) TRA NSMITTED - CHECK ALE RTS/MAIL F OR DETAILS " ;SUB1Q D PAUSE^VAL M1 K ^TMP( "IBSELX",$ J),^TMP("I BCE-BATCH" ,$J) Q ; | |
| 1744 | ||
| 1745 | ||
| 1746 | Routines | |
| 1747 | Activities | |
| 1748 | Routine Na me | |
| 1749 | IBCEMU4 | |
| 1750 | Enhancemen t Category | |
| 1751 | New | |
| 1752 | Modify | |
| 1753 | Delete | |
| 1754 | No Change | |
| 1755 | RTM | |
| 1756 | ||
| 1757 | Related Op tions | |
| 1758 | None | |
| 1759 | Related Ro utines | |
| 1760 | Routines “ Called By” | |
| 1761 | Routines “ Called” | |
| 1762 | ||
| 1763 | ||
| 1764 | ||
| 1765 | ||
| 1766 | Data Dicti onary (DD) Reference s | |
| 1767 | ||
| 1768 | Related Pr otocols | |
| 1769 | None | |
| 1770 | Related In tegration Control Re gistration s (ICRs) | |
| 1771 | None | |
| 1772 | Data Passi ng | |
| 1773 | Input | |
| 1774 | Output Re ference | |
| 1775 | Both | |
| 1776 | Global Re ference | |
| 1777 | Local | |
| 1778 | Input Attr ibute Name and Defin ition | |
| 1779 | Name: | |
| 1780 | Definition : | |
| 1781 | Output Att ribute Nam e and Defi nition | |
| 1782 | Name: | |
| 1783 | Definition : | |
| 1784 | Current Lo gic | |
| 1785 | IBCEMU4 ;A LB/ESG - M RA UTILITI ES ;25-OCT -2004 ;;2. 0;INTEGRAT ED BILLING ;**288,432 ,447**;21- MAR-94;Bui ld 80 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ; Q ;DE NDUP(IBEOB ,IBMRANOT) ; Denied for Duplic ate Functi on ;WCJ IB *2.0*432 ; Function returns tr ue if MRA is Denied AND Reason code 18 i s present (Duplicate claim/ser vice) NEW IBX,IBM,LI NE,DUP,ADJ S IBX=0,I BM=$G(^IBM (361.1,+$G (IBEOB),0) ) I '$G(IB MRANOT),$P (IBM,U,4)' =1 G DENDU PX ; no t an MRA ; WCJ IB*2.0 *432 I $G( IBMRANOT), $P(IBM,U,4 )'=0 G DEN DUPX ; not an EOB ;WCJ IB*2 .0*432 I $ P(IBM,U,13 )'=2 G DEN DUPX ; n ot Denied ; ; check line item adjustment s for reas on code 18 S LINE=0, DUP=0 F S LINE=$O(^ IBM(361.1, IBEOB,15,L INE)) Q:'L INE D Q: DUP . S AD J=0 . F S ADJ=$O(^I BM(361.1,I BEOB,15,LI NE,1,ADJ)) Q:'ADJ D Q:DUP .. I $D(^IBM (361.1,IBE OB,15,LINE ,1,ADJ,1," B",18)) S DUP=1 Q .. Q . Q ; I DUP S IBX =1DENDUPX ; Q IBX ; ; the rema ining func tions are all new w/ IB*2.0*44 7 and have to do wit h calculat ing ; diff erent amou nts based on percent ages store d in the e ffective d ate multip le of ; th e TYPE OF PLAN file (#355.1) f or Medicar e Suppleme ntal plans ;MSPRE(IB IFN,IBEXF, IBTYPLAN) ; Medicare supplemen tal PR and Excess ca lculations ; determi ne PR amou nt in orde r to calcu late balan ce due aft er medicar e for seco ndary/tert iary ; if type of pl an is a Me dicare sup plemental or EGHP pl an seconda ry to Medi care, PR ; calculat ions are d etermined based on t he effecti ve date mu ltiple in the TYPE O F PLAN fil e ; and ma y or may n ot include d Excess c harges (CO -45), base d on Plan Type. ; ne ed to pass in: ; IBI FN (REQUIR ED) = clai m ien ; IB EXF = Exce ss Flag, s et to 1 if NOT to in clude exce ss charges in calcul ation but to ; retur n "e" (IBE ) for exce ss indicat or if plan allows ex cess and t here are ; excess c harges. Us ed by PR c olumn of M RW screen to show PR without e xcess ; am ounts incl uded in ca lculation. ; IBTYPLA N = ien in TYPE OF P LAN file ( 355.1) ; r eturns "" if no effe ctive date for type of plan to calculate on ; N IB FRMTYP,IBP NCAT,IBINP AT,IBMGBD, IBEOB,LNLV L,EOBADJ,I BPCE,IBEDT ,IBE,IBTOT Q:$G(IBIF N)="" "" S :$G(IBTYPL AN)="" IBT YPLAN=$$TY PLN(IBIFN) S IBEDT=$ $MSEDT(IBI FN,IBTYPLA N) Q:IBEDT ="" "" S I BINPAT=$$I NPAT^IBCEF (IBIFN) ;I npat/Outpa t Flag S I BFRMTYP=$P ($G(^DGCR( 399,IBIFN, 0)),U,19) ; Form Typ e 2=1500, 3=UB ; pla n category - PART A is Inpatie nt Institu tional, B is all Out patient an d Inpatien t Professi onal S IBP NCAT="B" I IBINPAT=1 ,IBFRMTYP= 3 S IBPNCA T="A" Q:IB PNCAT="" " " ; Medica re supplem ental plan Offset am ount = tot al charges - what me dicare sec ondary pla n will pay ; so bala nce due = whatever m edicare se condary wi ll pay ; ; plan cate gory - PAR T A =1st p iece of AE DT Index, B =2nd S I BPCE=$S(IB PNCAT="B": 2,1:1) S I BMGBD=0,IB EOB=0 F S IBEOB=$O( ^IBM(361.1 ,"B",IBIFN ,IBEOB)) Q :'IBEOB D .N I .F I =0,1,2 S I BEOB(I)=$G (^IBM(361. 1,IBEOB,I) ) .I $P(IB EOB(0),U,4 )'=1 Q ;m ake sure i t's an MRA .; .; Han dle CMS-15 00 Form Ty pe and UB Outpatient : .I IBFRM TYP=2!('IB INPAT) D Q ..; calc ulate Medi care unpai d amount f rom line-l evel (outp atient) .. S LNLVL=0 F S LNLVL =$O(^IBM(3 61.1,IBEOB ,15,LNLVL) ) Q:'LNLVL D ; ... K EOBADJ . ..M EOBADJ =^IBM(361. 1,IBEOB,15 ,LNLVL,1) ...; Total up the Me dicare Con tract Adju stment acr oss ALL Se rvice Line s to find ...; Medic are supple mental Bal ance Due . ..S IBTOT= $$CALC(.EO BADJ,IBTYP LAN,IBPCE, IBEDT,$G(I BEXF)),IBE =$P(IBTOT, U,2) ...S IBMGBD=$G( IBMGBD)+$P (IBTOT,U) .; .; Hand le Inpatie nt UB Form Type Next : Calculat e from Cla im level d ata .K EOB ADJ .M EOB ADJ=^IBM(3 61.1,IBEOB ,10) .S IB TOT=$$CALC (.EOBADJ,I BTYPLAN,IB PCE,IBEDT, $G(IBEXF)) ,IBE=$P(IB TOT,U,2) . S IBMGBD=$ G(IBMGBD)+ $P(IBTOT,U ) Q IBMGBD _$G(IBE) ; CALC(EOBAD J,IBTYPLAN ,IBPCE,IBE DT,IBEXF) ; FUNCTION - Calcula te Medicar e Suppleme ntal Balan ce due ; S ums up Amo unts on AL L Reason C odes under ALL Group Codes = ' PR' and CO /Reason co de=45. ; I f those re ason codes have an e ntry in th e effectiv e date mut liple, mul tiples tha t ; reason amount by the % the Type of p lan will p ay. If no entry, ass ume 100% p ayment for PR. ; any other Gro up and rea son codes would be 0 %. ; Adds up all th ose sums a nd returns that valu e as the t otal PR&CO the Medic are ; Sup plemental plan will pay. ; ; I nput EOBAD J = Array of Group C odes & Rea son Codes from eithe r the Clai m ; Level (10) or S ervice Lin e Level (1 5) of EOB file (#361 .1) ; IBTY PLAN = ien in TYPE O F PLAN fil e ; IBPCE = 2 for P ART A, 3 f or PART B - REQUIRED ; IBEDT = effective date of p lan rates ; IBEXF = Excess Fl ag, set to 1 if NOT to include excess ch arges in c alculation but to ; return "e" for exces s indicato r if plan allows exc ess and th ere are ex cess ; ch arges. Use d by PR co lumn of MR W screen t o show PR without ex cess ; amo unts inclu ded in cal culation. ; Output a mount that Medicare supplement al plan wi ll pay ; N GRPLVL,RS NLVL,RSNAM T,MCA,GRPC D,RSNCD,RS N0,CALC,IB IND Q:$G(I BPCE)="" " " S:$G(IBT YPLAN)="" IBTYPLAN=$ $TYPLN(IBI FN) I $G(I BEDT)="" S IBEDT=$$M SEDT(IBIFN ,IBTYPLAN) Q:IBEDT=" " "" S (GR PLVL,MCA)= 0 F S GRP LVL=$O(EOB ADJ(GRPLVL )) Q:'GRPL VL D .S GRPCD=$P($ G(EOBADJ(G RPLVL,0)), U) .; For now they w ant to cal culate all PR but on ly apply % age calcs to PR-1,2 & 3 .I GR PCD'="PR" Q:'$D(^IBE (355.1,IBT YPLAN,14," AEDT",IBED T,GRPCD)) .S RSNLVL= 0 .F S RS NLVL=$O(EO BADJ(GRPLV L,1,RSNLVL )) Q:'RSNL VL D ; . .S RSN0=$G (EOBADJ(GR PLVL,1,RSN LVL,0)),RS NAMT=$P(RS N0,U,2),RS NCD=$P(RSN 0,U) ..I G RPCD="PR", RSNCD="AAA " Q ; ign ore PR-AAA ..; For n ow they wa nt to calc ulate all PR but onl y apply %a ge calcs t o PR-1,2 & 3 ..I GRP CD="PR","1 ^2^3"'[RSN CD,'$D(^IB E(355.1,IB TYPLAN,14, "AEDT",IBE DT,GRPCD,R SNCD)) S M CA=MCA+RSN AMT Q ..Q: '$D(^IBE(3 55.1,IBTYP LAN,14,"AE DT",IBEDT, GRPCD,RSNC D)) ..; if there is an entry i n the effe ctive date multiple for this g rp/rsn cod e use it t o calculat e amount f or PART A and B. ..; for MRW, don't add up excess charges if IBEXF=1, just send back an "e " indicato r to alert user of e xcess ..I $G(IBEXF) =1,GRPCD=" CO",RSNCD= 45,$P($G(^ IBE(355.1, IBTYPLAN,1 4,"AEDT",I BEDT,GRPCD ,RSNCD)),U ,IBPCE)>0 S IBIND="e " Q ..S CA LC=$P($G(^ IBE(355.1, IBTYPLAN,1 4,"AEDT",I BEDT,GRPCD ,RSNCD)),U ,IBPCE)/10 0 ..S MCA= MCA+(RSNAM T*CALC) Q MCA_U_$G(I BIND) ;MSE DT(IBIFN,I BTYPLAN) ; does this claim's T YPE OF PLA N have an effective date multi ple on or before the ; claim ' statement covers fro m' date ; IBIFN = cl aim ien - REQUIRED ; IBTYPLAN = Type of Plan ien ; returns e ff.date ca lculation multiple t o use or n ull ; call ed from SK IP^IBCCCB, BLD^IBCEC OB1, TOT^I BCECOB2, C RIT^IBCEMQ C, & SECON D^IBCEMSR ; ; IB*2.0 *447: the below quit statement has been added beca use CBO ha s decided not to imp lement ; t hese chang es with pa tch 447 af ter all. O nce a long -term main tenance pl an for the plan type ; calcula tions can be worked out and CB O is ready to implem ent the sp ecial calc ulations, the ; belo w quit sta tement and these com ments shou ld be remo ved and th e type of plan speci al calcula tions ; w ill immedi ately take effect. F or now, re turning a null will allow exis ting code to bypass ; the spe cial calcu lation tab le in file 355.1 and calculate everythin g as 100% of Patient Responsib ility (PR) . Q "" ; N IBSVDT Q: $G(IBIFN)= "" "" S:$G (IBTYPLAN) ="" IBTYPL AN=+$$TYPL N(IBIFN) S IBSVDT=+$ P($G(^DGCR (399,IBIFN ,"U")),U) Q:$D(^IBE( 355.1,IBTY PLAN,14,"B ",IBSVDT)) IBSVDT Q $O(^IBE(35 5.1,IBTYPL AN,14,"B", IBSVDT),-1 ) ;TYPLN(I BIFN) ; fi nd type of plan for claim ; IB IFN = clai m ien - RE QUIRED ; r eturns ien from file 355.1 or null if no ne found ; Q:$G(IBIF N)="" "" N IBCOBN,IB GRPNO S IB COBN=$$COB N^IBCEF(IB IFN)+1 ;fi nd next pa yer S IBGR PNO=+$P($G (^DGCR(399 ,IBIFN,"I" _IBCOBN)), U,18) ; gr oup plan n umber Q $P ($G(^IBA(3 55.3,IBGRP NO,0)),U,9 ) ; type o f plan - I EN ; | |
| 1786 | Modified L ogic (Chan ges are in bold) | |
| 1787 | IBCEMU4 ;A LB/ESG - M RA UTILITI ES ;25-OCT -2004 ;;2. 0;INTEGRAT ED BILLING ;**288,432 ,447,592** ;21-MAR-94 ;Build 80 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ; Q ;DENDUP(I BEOB,IBMRA NOT) ; Den ied for Du plicate Fu nction ;WC J IB*2.0*4 32 ; Funct ion return s true if MRA is Den ied AND Re ason code 18 is pres ent (Dupli cate claim /service) NEW IBX,IB M,LINE,DUP ,ADJ S IBX =0,IBM=$G( ^IBM(361.1 ,+$G(IBEOB ),0)) I '$ G(IBMRANOT ),$P(IBM,U ,4)'=1 G D ENDUPX ; not an M RA ;WCJ IB *2.0*432 I $G(IBMRAN OT),$P(IBM ,U,4)'=0 G DENDUPX ; not an EOB ;WCJ IB*2.0*432 I $P(IBM, U,13)'=2 G DENDUPX ; not Den ied ; ; ch eck line i tem adjust ments for reason cod e 18 S LIN E=0,DUP=0 F S LINE= $O(^IBM(36 1.1,IBEOB, 15,LINE)) Q:'LINE D Q:DUP . S ADJ=0 . F S ADJ=$ O(^IBM(361 .1,IBEOB,1 5,LINE,1,A DJ)) Q:'AD J D Q:DU P .. I $D( ^IBM(361.1 ,IBEOB,15, LINE,1,ADJ ,1,"B",18) ) S DUP=1 Q .. Q . Q ; I DUP S IBX=1DEND UPX ; Q IB X ; ; the remaining functions are all ne w w/ IB*2. 0*447 and have to do with calc ulating ; different amounts ba sed on per centages s tored in t he effecti ve date mu ltiple of ; the TYPE OF PLAN f ile (#355. 1) for Med icare Supp lemental p lans ;MSPR E(IBIFN,IB EXF,IBTYPL AN) ; Medi care suppl emental PR and Exces s calculat ions ; det ermine PR amount in order to c alculate b alance due after med icare for secondary/ tertiary ; if type o f plan is a Medicare supplemen tal or EGH P plan sec ondary to Medicare, PR ; calc ulations a re determi ned based on the eff ective dat e multiple in the TY PE OF PLAN file ; an d may or m ay not inc luded Exce ss charges (CO-45), based on P lan Type. ; need to pass in: ; IBIFN (RE QUIRED) = claim ien ; IBEXF = Excess Fla g, set to 1 if NOT t o include excess cha rges in ca lculation but to ; r eturn "e" (IBE) for excess ind icator if plan allow s excess a nd there a re ; exce ss charges . Used by PR column of MRW scr een to sho w PR witho ut excess ; amounts included i n calculat ion. ; IBT YPLAN = ie n in TYPE OF PLAN fi le (355.1) ; returns "" if no effective date for t ype of pla n to calcu late on ; N IBFRMTYP ,IBPNCAT,I BINPAT,IBM GBD,IBEOB, LNLVL,EOBA DJ,IBPCE,I BEDT,IBE,I BTOT Q:$G( IBIFN)="" "" S:$G(IB TYPLAN)="" IBTYPLAN= $$TYPLN(IB IFN) S IBE DT=$$MSEDT (IBIFN,IBT YPLAN) Q:I BEDT="" "" S IBINPAT =$$INPAT^I BCEF(IBIFN ) ;Inpat/O utpat Flag S IBFRMTY P=$P($G(^D GCR(399,IB IFN,0)),U, 19) ; Form Type 2=15 00, 3=UB, 7=J430D ;J RA IB*2.0* 592 Add De ntal form 7 ; plan c ategory - PART A is Inpatient Institutio nal, B is all Outpat ient and I npatient P rofessiona l S IBPNCA T="B" I IB INPAT=1,IB FRMTYP=3 S IBPNCAT=" A" Q:IBPNC AT="" "" ; Medicare supplement al plan Of fset amoun t = total charges - what medic are second ary plan w ill pay ; so balance due = wha tever medi care secon dary will pay ; ; pl an categor y - PART A =1st piec e of AEDT Index, B = 2nd S IBPC E=$S(IBPNC AT="B":2,1 :1) S IBMG BD=0,IBEOB =0 F S IB EOB=$O(^IB M(361.1,"B ",IBIFN,IB EOB)) Q:'I BEOB D .N I .F I=0, 1,2 S IBEO B(I)=$G(^I BM(361.1,I BEOB,I)) . I $P(IBEOB (0),U,4)'= 1 Q ;make sure it's an MRA .; .; Handle CMS-1500 Form Type and UB Out patient: . ;JRA IB*2. 0*592 Do t he same fo r Dental J 430D as fo r CMS-1500 .;I IBFRM TYP=2!('IB INPAT) D Q ;JRA IB*2 .0*592 ';' .I IBFRMT YP=2!(IBFR MTYP=7!('I BINPAT)) D Q ;JRA IB*2.0*592 ..; calcu late Medic are unpaid amount fr om line-le vel (outpa tient) ..S LNLVL=0 F S LNLVL= $O(^IBM(36 1.1,IBEOB, 15,LNLVL)) Q:'LNLVL D ; ...K EOBADJ .. .M EOBADJ= ^IBM(361.1 ,IBEOB,15, LNLVL,1) . ..; Total up the Med icare Cont ract Adjus tment acro ss ALL Ser vice Lines to find . ..; Medica re supplem ental Bala nce Due .. .S IBTOT=$ $CALC(.EOB ADJ,IBTYPL AN,IBPCE,I BEDT,$G(IB EXF)),IBE= $P(IBTOT,U ,2) ...S I BMGBD=$G(I BMGBD)+$P( IBTOT,U) . ; .; Handl e Inpatien t UB Form Type Next: Calculate from Clai m level da ta .K EOBA DJ .M EOBA DJ=^IBM(36 1.1,IBEOB, 10) .S IBT OT=$$CALC( .EOBADJ,IB TYPLAN,IBP CE,IBEDT,$ G(IBEXF)), IBE=$P(IBT OT,U,2) .S IBMGBD=$G (IBMGBD)+$ P(IBTOT,U) Q IBMGBD_ $G(IBE) ;C ALC(EOBADJ ,IBTYPLAN, IBPCE,IBED T,IBEXF) ; FUNCTION - Calculat e Medicare Supplemen tal Balanc e due ; Su ms up Amou nts on ALL Reason Co des under ALL Group Codes = 'P R' and CO/ Reason cod e=45. ; If those rea son codes have an en try in the effective date mutl iple, mult iples that ; reason amount by the % the Type of pl an will pa y. If no e ntry, assu me 100% pa yment for PR. ; any other Grou p and reas on codes w ould be 0% . ; Adds up all tho se sums an d returns that value as the to tal PR&CO the Medica re ; Supp lemental p lan will p ay. ; ; In put EOBADJ = Array o f Group Co des & Reas on Codes f rom either the Claim ; Level (10) or Se rvice Line Level (15 ) of EOB f ile (#361. 1) ; IBTYP LAN = ien in TYPE OF PLAN file ; IBPCE = 2 for PA RT A, 3 fo r PART B - REQUIRED ; IBEDT = effective date of pl an rates ; IBEXF = Excess Fla g, set to 1 if NOT t o include excess cha rges in ca lculation but to ; r eturn "e" for excess indicator if plan a llows exce ss and the re are exc ess ; cha rges. Used by PR col umn of MRW screen to show PR w ithout exc ess ; amou nts includ ed in calc ulation. ; Output am ount that Medicare s upplementa l plan wil l pay ; N GRPLVL,RSN LVL,RSNAMT ,MCA,GRPCD ,RSNCD,RSN 0,CALC,IBI ND Q:$G(IB PCE)="" "" S:$G(IBTY PLAN)="" I BTYPLAN=$$ TYPLN(IBIF N) I $G(IB EDT)="" S IBEDT=$$MS EDT(IBIFN, IBTYPLAN) Q:IBEDT="" "" S (GRP LVL,MCA)=0 F S GRPL VL=$O(EOBA DJ(GRPLVL) ) Q:'GRPLV L D .S G RPCD=$P($G (EOBADJ(GR PLVL,0)),U ) .; For n ow they wa nt to calc ulate all PR but onl y apply %a ge calcs t o PR-1,2 & 3 .I GRP CD'="PR" Q :'$D(^IBE( 355.1,IBTY PLAN,14,"A EDT",IBEDT ,GRPCD)) . S RSNLVL=0 .F S RSN LVL=$O(EOB ADJ(GRPLVL ,1,RSNLVL) ) Q:'RSNLV L D ; .. S RSN0=$G( EOBADJ(GRP LVL,1,RSNL VL,0)),RSN AMT=$P(RSN 0,U,2),RSN CD=$P(RSN0 ,U) ..I GR PCD="PR",R SNCD="AAA" Q ; igno re PR-AAA ..; For no w they wan t to calcu late all P R but only apply %ag e calcs to PR-1,2 & 3 ..I GRPC D="PR","1^ 2^3"'[RSNC D,'$D(^IBE (355.1,IBT YPLAN,14," AEDT",IBED T,GRPCD,RS NCD)) S MC A=MCA+RSNA MT Q ..Q:' $D(^IBE(35 5.1,IBTYPL AN,14,"AED T",IBEDT,G RPCD,RSNCD )) ..; if there is a n entry in the effec tive date multiple f or this gr p/rsn code use it to calculate amount fo r PART A a nd B. ..; for MRW, d on't add u p excess c harges if IBEXF=1, j ust send b ack an "e" indicator to alert user of ex cess ..I $G(IBEXF)= 1,GRPCD="C O",RSNCD=4 5,$P($G(^I BE(355.1,I BTYPLAN,14 ,"AEDT",IB EDT,GRPCD, RSNCD)),U, IBPCE)>0 S IBIND="e" Q ..S CAL C=$P($G(^I BE(355.1,I BTYPLAN,14 ,"AEDT",IB EDT,GRPCD, RSNCD)),U, IBPCE)/100 ..S MCA=M CA+(RSNAMT *CALC) Q M CA_U_$G(IB IND) ;MSED T(IBIFN,IB TYPLAN) ; does this claim's TY PE OF PLAN have an e ffective d ate multip le on or b efore the ; claim 's tatement c overs from ' date ; I BIFN = cla im ien - R EQUIRED ; IBTYPLAN = Type of P lan ien ; returns ef f.date cal culation m ultiple to use or nu ll ; calle d from SKI P^IBCCCB, BLD^IBCECO B1, TOT^IB CECOB2, CR IT^IBCEMQC , & SECOND ^IBCEMSR ; ; IB*2.0* 447: the b elow quit statement has been a dded becau se CBO has decided n ot to impl ement ; th ese change s with pat ch 447 aft er all. On ce a long- term maint enance pla n for the plan type ; calculat ions can b e worked o ut and CBO is ready to impleme nt the spe cial calcu lations, t he ; below quit stat ement and these comm ents shoul d be remov ed and the type of p lan specia l calculat ions ; wi ll immedia tely take effect. Fo r now, ret urning a n ull will a llow exist ing code t o bypass ; the spec ial calcul ation tabl e in file 355.1 and calculate everything as 100% o f Patient Responsibi lity (PR). Q "" ; N IBSVDT Q:$ G(IBIFN)=" " "" S:$G( IBTYPLAN)= "" IBTYPLA N=+$$TYPLN (IBIFN) S IBSVDT=+$P ($G(^DGCR( 399,IBIFN, "U")),U) Q :$D(^IBE(3 55.1,IBTYP LAN,14,"B" ,IBSVDT)) IBSVDT Q $ O(^IBE(355 .1,IBTYPLA N,14,"B",I BSVDT),-1) ;TYPLN(IB IFN) ; fin d type of plan for c laim ; IBI FN = claim ien - REQ UIRED ; re turns ien from file 355.1 or n ull if non e found ; Q:$G(IBIFN )="" "" N IBCOBN,IBG RPNO S IBC OBN=$$COBN ^IBCEF(IBI FN)+1 ;fin d next pay er S IBGRP NO=+$P($G( ^DGCR(399, IBIFN,"I"_ IBCOBN)),U ,18) ; gro up plan nu mber Q $P( $G(^IBA(35 5.3,IBGRPN O,0)),U,9) ; type of plan - IE N ; | |
| 1788 | ||
| 1789 | ||
| 1790 | Routines | |
| 1791 | Activities | |
| 1792 | Routine Na me | |
| 1793 | IBCEP | |
| 1794 | Enhancemen t Category | |
| 1795 | New | |
| 1796 | Modify | |
| 1797 | Delete | |
| 1798 | No Change | |
| 1799 | RTM | |
| 1800 | ||
| 1801 | Related Op tions | |
| 1802 | None | |
| 1803 | Related Ro utines | |
| 1804 | Routines “ Called By” | |
| 1805 | Routines “ Called” | |
| 1806 | ||
| 1807 | ||
| 1808 | ||
| 1809 | ||
| 1810 | Data Dicti onary (DD) Reference s | |
| 1811 | ||
| 1812 | Related Pr otocols | |
| 1813 | None | |
| 1814 | Related In tegration Control Re gistration s (ICRs) | |
| 1815 | None | |
| 1816 | Data Passi ng | |
| 1817 | Input | |
| 1818 | Output Re ference | |
| 1819 | Both | |
| 1820 | Global Re ference | |
| 1821 | Local | |
| 1822 | Input Attr ibute Name and Defin ition | |
| 1823 | Name: | |
| 1824 | Definition : | |
| 1825 | Output Att ribute Nam e and Defi nition | |
| 1826 | Name: | |
| 1827 | Definition : | |
| 1828 | Current Lo gic | |
| 1829 | IBCEP ;ALB /TMP - Fun ctions for PROVIDER ID MAINT - INS CO PA RAMS ;11-0 2-00 ;;2.0 ;INTEGRATE D BILLING; **137,232, 320,348,34 9**;21-MAR -94;Build 46 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ;EN ; -- m ain entry point for IBCE PRV I NS PARAMS N IBINS,IB CUINC ; Va riable sho uld be ava ilable thr oughout ac tions D FU LL^VALM1 D EN^VALM(" IBCE PRV I NS PARAMS" ) Q ;HDR ; -- header code K VA LMHDR I $G (IBINS) S VALMHDR(1) ="INSURANC E CO: "_$P ($G(^DIC(3 6,+IBINS,0 )),U) Q ;I NIT ; Init ialization N DIR,DIC ,DA,X,Y,DT OUT,DUOUT S DIC(0)=" AEMQ",DIC= "^DIC(36," D ^DIC I Y'>0 D . S VALMQUIT= 1 E D . S DIR="YA", DIR("A")=" DO YOU WAN T TO INCLU DE ANY CAR E UNIT DET AIL?: ",DI R("?",1)=" If you wan t to see t he specifi c care uni t defined for the in surance co ",DIR("?") ="you shou ld respond yes here" . W ! D ^ DIR K DIR W ! . I $D (DTOUT)!$D (DUOUT) S VALMQUIT=1 Q . S IBC UINC=(Y=1) . S IBINS =+Y D BLD( IBINS,IBCU INC) Q ;BL D(IBINS,IB CUINC) ; B uild displ ay for ins co level provider I D paramete rs ; IBINS = ien of ins co (fi le 36) ; I BCUINC = f lag: ; = 1 if care u nit list s hould be i ncluded or 0 if not N A,A0,A1, A2,A3,Z0,I B1,IB12,IB 4,IBLCT,IB PTYP S IBL CT=0 S IB4 =$G(^DIC(3 6,IBINS,4) ) K ^TMP(" IBPRV_INS_ ID_PARAMS" ,$J) ; S Z 0="Perf Pr ov Seconda ry ID Type (1500): " _$E($$EXPA ND^IBTRE(3 6,4.01,+$P (IB4,U))_$ J("",20),1 ,20) D SET 1(.IBLCT,Z 0) S Z0="P erf Prov S econdary I D Type (UB 04): "_$E( $$EXPAND^I BTRE(36,4. 02,+$P(IB4 ,U,2))_$J( "",20),1,2 0) D SET1( .IBLCT,Z0) S Z0=$J(" ",20)_"Req uired: "_$ $EXPAND^IB TRE(36,4.0 3,$P(IB4,U ,3)) D SET 1(.IBLCT,Z 0) S Z0=$J ("",10)_"C are Unit N ame: "_$$E XPAND^IBTR E(36,4.09, $P(IB4,U,9 )) D SET1( .IBLCT,Z0) S Z0="" D SET1(.IB LCT,Z0) ; I '$D(^IBA (355.96,"D ",IBINS)) D G BLDQ ;No care u nit needed . S Z0=$J ("",7)_"** * NO CARE UNITS DEFI NED FOR TH IS INS CO PROVIDER S ECONDARY I D ***" D S ET1(.IBLCT ,Z0) ; S Z 0=$J("",17 )_"VALID C ARE UNITS FOR THIS I NSURANCE C OMPANY" D SET1(.IBLC T,Z0),CNTR L^VALM10(I BLCT,18,46 ,IORVON,IO RVOFF) S A =0 F S A= $O(^IBA(35 5.96,"AC", IBINS,A)) Q:'A S IB PTYP=$P($G (^IBE(355. 97,A,0)),U ) I IBPTYP '="" D . S A2=IBPTYP _U_A,^TMP( "IBPRV_INS _ID_PARAMS _SORT",$J, A2)="" . S A0=0 F S A0=$O(^IB A(355.96," AC",IBINS, A,A0)) Q:' A0 S A1=$ G(^IBA(355 .96,A0,0)) D .. I '$ G(IBCUINC) S:'$D(^TM P("IBPRV_I NS_ID_PARA MS_SORT",$ J,A2,$P(A1 ,U,4)_U_$P (A1,U,5))) ^($P(A1,U ,4)_U_$P(A 1,U,5))="" Q .. I $P (A1,U,4)'= "",$P(A1,U ,5)'="" D ... S A3=$ E($P($G(^I BE(355.95, +A1,0)),U) _$J("",1,3 0),1,30)_U _$S($P($G( ^(0)),U,2) '="":$P(^( 0),U,2),1: "<No descr iption ava ilable>") ... I '$D( ^TMP("IBPR V_INS_ID_P ARAMS_SORT ",$J,A2,$P (A1,U,4)_U _$P(A1,U,5 ),$P(A3,U) )) S ^($P( A3,U))=$P( A3,U,2) . ; records are fully sorted S A ="" F S A =$O(^TMP(" IBPRV_INS_ ID_PARAMS_ SORT",$J,A )) Q:'A S A2="PROVI DER ID TYP E: "_$P(A, U),IB1=1 D :'IB1 SET1 (.IBLCT,"" ) D SET1(. IBLCT,A2) S IB12=1 S :$G(IBCUIN C) IB1=0 D . S A0="" F S A0=$ O(^TMP("IB PRV_INS_ID _PARAMS_SO RT",$J,A,A 0)) Q:A0=" " D .. S Z0=$J("",5 )_"FORM TY PE: "_$E($ $EXPAND^IB TRE(355.96 ,.04,$P(A0 ,U))_$J("" ,25),1,25) _" CARE TY PE: "_$E($ $EXPAND^IB TRE(355.96 ,.05,$P(A0 ,U,2))_$J( "",25),1,2 5) .. D:'I B12 SET1(. IBLCT,"") D SET1(.IB LCT,Z0) .. Q:'$G(IBC UINC) .. S IB12=0 .. S A1="" F S A1=$O( ^TMP("IBPR V_INS_ID_P ARAMS_SORT ",$J,A,A0, A1)) Q:A1= "" S Z0=$ J("",10)_A 1_$G(^(A1) ) D SET1(. IBLCT,Z0) ;BLDQ K ^T MP("IBPRV_ INS_ID_PAR AMS_SORT", $J) S VALM CNT=IBLCT, VALMBG=1 Q ;SET1(IBL CT,Z0) ; S IBLCT=IBL CT+1 D SET ^VALM10(IB LCT,Z0) Q ;EXPND ; Q ;HELP ; Q ;EXIT ; K ^TMP("IBP RV_INS_ID_ PARAMS",$J ) D CLEAN^ VALM10 Q ; EDIT ; Ent rypoint ca lled from IBCSCE to invoke pro vider id e dit functi ons Q ;EDI T1 ; Edit parameters N IB,IBY, IBCNS,DIE, DR,X,Y D F ULL^VALM1 S IBCNS=IB INS,IBY=12 D MAIN^IB CNSC1 S VA LMBCK="R" Q ;NETID() ; Returns the ien o f the entr y in file 355.97 tha t is desig nated as t he ; NETWO RK ID N Z S Z=0 F S Z=$O(^IBE (355.97,Z) ) Q:'Z Q: $P($G(^(Z, 1)),U,6) Q Z ;EMCID( ) ; Return s the ien of the ent ry in file 355.97 th at is desi gnated as the ; EMC ID N Z S Z =0 F S Z= $O(^IBE(35 5.97,Z)) Q :'Z Q:$P( $G(^(Z,1)) ,U,5) Q Z ;UPIN() ; Returns th e ien of t he entry i n file 355 .97 that i s designat ed as the ; UPIN ID Q +$O(^IBE (355.97,"B ","UPIN",0 )) ;EDITID (IBCNS) ; Edit provi der id's f rom insura nce co ent er/edit ; IBCNS = ie n of file 36 Q ; W CJ 12/30/2 005 N X,Y, Z4,DIR S Z 4=$G(^DIC( 36,IBCNS,4 )) I 'Z4,' $P(Z4,U,2) Q S DIR(" A",1)="USE PROVIDER ID MAINTEN ANCE TO EN TER/EDIT P ROV SECOND ARY ID'S F OR THIS CO .",DIR("A" )="PRESS R ETURN TO C ONTINUE: " ,DIR(0)="E A" W ! D ^ DIR K DIR Q ; | |
| 1830 | Modified L ogic (Chan ges are in bold) | |
| 1831 | IBCEP ;ALB /TMP - Fun ctions for PROVIDER ID MAINT - INS CO PA RAMS ;11-0 2-00 ;;2.0 ;INTEGRATE D BILLING; **137,232, 320,348,34 9,592**;21 -MAR-94;Bu ild 46 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;EN ; -- main en try point for IBCE P RV INS PAR AMS N IBIN S,IBCUINC ; Variable should be available throughou t actions D FULL^VAL M1 D EN^VA LM("IBCE P RV INS PAR AMS") Q ;H DR ; -- he ader code K VALMHDR I $G(IBINS ) S VALMHD R(1)="INSU RANCE CO: "_$P($G(^D IC(36,+IBI NS,0)),U) Q ;INIT ; Initializa tion N DIR ,DIC,DA,X, Y,DTOUT,DU OUT S DIC( 0)="AEMQ", DIC="^DIC( 36," D ^DI C I Y'>0 D . S VALMQ UIT=1 E D . S DIR=" YA",DIR("A ")="DO YOU WANT TO I NCLUDE ANY CARE UNIT DETAIL?: ",DIR("?", 1)="If you want to s ee the spe cific care unit defi ned for th e insuranc e co",DIR( "?")="you should res pond yes h ere" . W ! D ^DIR K DIR W ! . I $D(DTOUT )!$D(DUOUT ) S VALMQU IT=1 Q . S IBCUINC=( Y=1) . S I BINS=+Y D BLD(IBINS, IBCUINC) Q ;BLD(IBIN S,IBCUINC) ; Build d isplay for ins co le vel provid er ID para meters ; I BINS = ien of ins co (file 36) ; IBCUINC = flag: ; = 1 if ca re unit li st should be include d or 0 if not N A,A0 ,A1,A2,A3, Z0,IB1,IB1 2,IB4,IBLC T,IBPTYP S IBLCT=0 S IB4=$G(^D IC(36,IBIN S,4)) K ^T MP("IBPRV_ INS_ID_PAR AMS",$J) ; S Z0="Per f Prov Sec ondary ID Type (1500 ): "_$E($$ EXPAND^IBT RE(36,4.01 ,+$P(IB4,U ))_$J("",2 0),1,20) D SET1(.IBL CT,Z0) ;JW S;IB*2.0*5 92; form J 430D S Z0= "Perf Prov Secondary ID Type ( J430D): "_ $E($$EXPAN D^IBTRE(36 ,4.14,+$P( IB4,U,14)) _$J("",20) ,1,20) D S ET1(.IBLCT ,Z0) S Z0= "Perf Prov Secondary ID Type ( UB04): "_$ E($$EXPAND ^IBTRE(36, 4.02,+$P(I B4,U,2))_$ J("",20),1 ,20) D SET 1(.IBLCT,Z 0) S Z0=$J ("",20)_"R equired: " _$$EXPAND^ IBTRE(36,4 .03,$P(IB4 ,U,3)) D S ET1(.IBLCT ,Z0) S Z0= $J("",10)_ "Care Unit Name: "_$ $EXPAND^IB TRE(36,4.0 9,$P(IB4,U ,9)) D SET 1(.IBLCT,Z 0) S Z0="" D SET1(. IBLCT,Z0) ; I '$D(^I BA(355.96, "D",IBINS) ) D G BLD Q ;No care unit need ed . S Z0= $J("",7)_" *** NO CAR E UNITS DE FINED FOR THIS INS C O PROVIDER SECONDARY ID ***" D SET1(.IBL CT,Z0) ; S Z0=$J("", 17)_"VALID CARE UNIT S FOR THIS INSURANCE COMPANY" D SET1(.IB LCT,Z0),CN TRL^VALM10 (IBLCT,18, 46,IORVON, IORVOFF) S A=0 F S A=$O(^IBA( 355.96,"AC ",IBINS,A) ) Q:'A S IBPTYP=$P( $G(^IBE(35 5.97,A,0)) ,U) I IBPT YP'="" D . S A2=IBPT YP_U_A,^TM P("IBPRV_I NS_ID_PARA MS_SORT",$ J,A2)="" . S A0=0 F S A0=$O(^ IBA(355.96 ,"AC",IBIN S,A,A0)) Q :'A0 S A1 =$G(^IBA(3 55.96,A0,0 )) D .. I '$G(IBCUIN C) S:'$D(^ TMP("IBPRV _INS_ID_PA RAMS_SORT" ,$J,A2,$P( A1,U,4)_U_ $P(A1,U,5) )) ^($P(A1 ,U,4)_U_$P (A1,U,5))= "" Q .. I $P(A1,U,4) '="",$P(A1 ,U,5)'="" D ... S A3 =$E($P($G( ^IBE(355.9 5,+A1,0)), U)_$J("",1 ,30),1,30) _U_$S($P($ G(^(0)),U, 2)'="":$P( ^(0),U,2), 1:"<No des cription a vailable>" ) ... I '$ D(^TMP("IB PRV_INS_ID _PARAMS_SO RT",$J,A2, $P(A1,U,4) _U_$P(A1,U ,5),$P(A3, U))) S ^($ P(A3,U))=$ P(A3,U,2) . ; record s are full y sorted S A="" F S A=$O(^TMP ("IBPRV_IN S_ID_PARAM S_SORT",$J ,A)) Q:'A S A2="PRO VIDER ID T YPE: "_$P( A,U),IB1=1 D:'IB1 SE T1(.IBLCT, "") D SET1 (.IBLCT,A2 ) S IB12=1 S:$G(IBCU INC) IB1=0 D . S A0= "" F S A0 =$O(^TMP(" IBPRV_INS_ ID_PARAMS_ SORT",$J,A ,A0)) Q:A0 ="" D .. S Z0=$J("" ,5)_"FORM TYPE: "_$E ($$EXPAND^ IBTRE(355. 96,.04,$P( A0,U))_$J( "",25),1,2 5)_" CARE TYPE: "_$E ($$EXPAND^ IBTRE(355. 96,.05,$P( A0,U,2))_$ J("",25),1 ,25) .. D: 'IB12 SET1 (.IBLCT,"" ) D SET1(. IBLCT,Z0) .. Q:'$G(I BCUINC) .. S IB12=0 .. S A1="" F S A1=$ O(^TMP("IB PRV_INS_ID _PARAMS_SO RT",$J,A,A 0,A1)) Q:A 1="" S Z0 =$J("",10) _A1_$G(^(A 1)) D SET1 (.IBLCT,Z0 ) ;BLDQ K ^TMP("IBPR V_INS_ID_P ARAMS_SORT ",$J) S VA LMCNT=IBLC T,VALMBG=1 Q ;SET1(I BLCT,Z0) ; S IBLCT=I BLCT+1 D S ET^VALM10( IBLCT,Z0) Q ;EXPND ; Q ;HELP ; Q ;EXIT ; K ^TMP("I BPRV_INS_I D_PARAMS", $J) D CLEA N^VALM10 Q ;EDIT ; E ntrypoint called fro m IBCSCE t o invoke p rovider id edit func tions Q ;E DIT1 ; Edi t paramete rs N IB,IB Y,IBCNS,DI E,DR,X,Y D FULL^VALM 1 S IBCNS= IBINS,IBY= 12 D MAIN^ IBCNSC1 S VALMBCK="R " Q ;NETID () ; Retur ns the ien of the en try in fil e 355.97 t hat is des ignated as the ; NET WORK ID N Z S Z=0 F S Z=$O(^I BE(355.97, Z)) Q:'Z Q:$P($G(^( Z,1)),U,6) Q Z ;EMCI D() ; Retu rns the ie n of the e ntry in fi le 355.97 that is de signated a s the ; EM C ID N Z S Z=0 F S Z=$O(^IBE( 355.97,Z)) Q:'Z Q:$ P($G(^(Z,1 )),U,5) Q Z ;UPIN() ; Returns the ien of the entry in file 3 55.97 that is design ated as th e ; UPIN I D Q +$O(^I BE(355.97, "B","UPIN" ,0)) ;EDIT ID(IBCNS) ; Edit pro vider id's from insu rance co e nter/edit ; IBCNS = ien of fil e 36 Q ; WCJ 12/30 /2005 N X, Y,Z4,DIR S Z4=$G(^DI C(36,IBCNS ,4)) I 'Z4 ,'$P(Z4,U, 2) Q S DIR ("A",1)="U SE PROVIDE R ID MAINT ENANCE TO ENTER/EDIT PROV SECO NDARY ID'S FOR THIS CO.",DIR(" A")="PRESS RETURN TO CONTINUE: ",DIR(0)= "EA" W ! D ^DIR K DI R Q ; | |
| 1832 | ||
| 1833 | ||
| 1834 | ||
| 1835 | ||
| 1836 | ||
| 1837 | ||
| 1838 | ||
| 1839 | Routines | |
| 1840 | Activities | |
| 1841 | Routine Na me | |
| 1842 | IBCEP0 | |
| 1843 | Enhancemen t Category | |
| 1844 | New | |
| 1845 | Modify | |
| 1846 | Delete | |
| 1847 | No Change | |
| 1848 | RTM | |
| 1849 | ||
| 1850 | Related Op tions | |
| 1851 | None | |
| 1852 | Related Ro utines | |
| 1853 | Routines “ Called By” | |
| 1854 | Routines “ Called” | |
| 1855 | ||
| 1856 | ||
| 1857 | ||
| 1858 | ||
| 1859 | Data Dicti onary (DD) Reference s | |
| 1860 | ||
| 1861 | Related Pr otocols | |
| 1862 | None | |
| 1863 | Related In tegration Control Re gistration s (ICRs) | |
| 1864 | None | |
| 1865 | Data Passi ng | |
| 1866 | Input | |
| 1867 | Output Re ference | |
| 1868 | Both | |
| 1869 | Global Re ference | |
| 1870 | Local | |
| 1871 | Input Attr ibute Name and Defin ition | |
| 1872 | Name: | |
| 1873 | Definition : | |
| 1874 | Output Att ribute Nam e and Defi nition | |
| 1875 | Name: | |
| 1876 | Definition : | |
| 1877 | Current Lo gic | |
| 1878 | IBCEP0 ;AL B/TMP - Fu nctions fo r PROVIDER ID MAINTE NANCE ;13- DEC-99 ;;2 .0;INTEGRA TED BILLIN G;**137,19 1,239,232, 320,348,34 9,377**;21 -MAR-94;Bu ild 23 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;EN ; -- main en try point for IBCE P RV INS ID N IBINS,IB DSP,IBSORT ,IBPRV ; V ariables s hould be a vailable t hroughout actions K IBFASTXT D FULL^VALM 1 D EN^VAL M("IBCE PR VINS ID") Q ;EN1(IBI NS) ; Entr ypoint fro m insuranc e co maint enance N I BDSP,IBSOR T ; Variab les should be availa ble throug hout actio ns D FULL^ VALM1 D EN ^VALM("IBC E PRVINS I D FROM INS MAINT") Q ;HDR ; -- header co de N Z,Z0, Z1,IBCT,IB PPTYP,IBEM CTYP S IBC T=1 K VALM HDR I $G(I BINS) D . N PCF,PCDI SP . S PCF =$P($G(^DI C(36,+IBIN S,3)),U,13 ) . S PCDI SP=$S(PCF= "C":"(Chil d)",PCF="P ":"(Parent )",1:"") . S VALMHDR (1)="Insur ance Co: " _$P($G(^DI C(36,+IBIN S,0)),U)_" "_PCDISP . ; Get pe rforming p rovider id type for insurance co . S IBP PTYP=$$PPT YP(IBINS) . ; Get ie n of EMC I D from fil e 355.97 . S IBEMCTY P=+$$EMCID ^IBCEP() . I $G(IBSO RT)="ALL"! ($G(IBDSP) ="I")!($G( IBSORT)=IB PPTYP)!($G (IBSORT)=I BEMCTYP) D .. ; Look for care unit in ei ther of th ese id typ es - if th ere, repor t on line 2 of heade r .. I $G( IBSORT)=IB PPTYP S IB EMCTYP=0 . . I $G(IBS ORT)=IBEMC TYP S IBPP TYP=0 .. F Z0=IBPPTY P_"P",IBEM CTYP_"E" S Z1="" F S Z1=$O(^I BA(355.96, "D",+IBINS ,+Z0,Z1)) Q:Z1="" I Z1'="*N/A *" S Z($E( Z0,$L(Z0)) )=1 Q .. I $D(Z("P") )!$D(Z("E" )) D ... S IBCT=IBCT +1 ... S V ALMHDR(IBC T)=" "_$S( $D(Z("P")) :"PERFORMI NG PROV ID "_$S($D(Z( "E")):" AN D ",1:""), 1:"")_$S($ D(Z("E")): "EMC PROV ID",1:"")_ " MAY REQU IRE CARE U NIT" . I $ D(Z("P"))! $D(Z("E")) S IBCT=IB CT+1,VALMH DR(IBCT)=" " . S IBC T=IBCT+1,V ALMHDR(IBC T)=" PROVI DER "_$S($ G(IBDSP)=" I":"ID TYP E",1:"NAME ")_$J("", 6)_"FORM C ARE TYPE C ARE UNIT I D#" Q ;INI T ; Initia lization K ^TMP("IB_ EDITED_IDS ",$J) ; Th is will be to keep t rack of ID 's edited during thi s session D INSID(.I BINS,.IBDS P,.IBSORT) I $G(IBDS P)="I",$G( IBSORT) S IBPRV=IBSO RT I '$G(I BINS) S VA LMQUIT=1 Q ;INSID(IB INS,IBDSP, IBSORT) ; N DIC,DIR, DA,X,Y,IBO K,DTOUT,DU OUT S IBOK =1 I '$G(I BINS) D . S DIC(0)=" AEMQ",DIC= "^DIC(36," D ^DIC . I Y'>0 S I BOK=0 Q . S IBINS=+Y I '$G(IBI NS) S IBOK =0 I 'IBOK G INSIDQ ; S DIR(0) ="SA^D:INS URANCE CO DEFAULT ID S;I:INDIVI DUAL PROVI DER IDS FU RNISHED BY THE INS C O;A:ALL ID S FURNISHE D BY THE I NS CO BY P ROVIDER TY PE" S DIR( "A")="SELE CT DISPLAY CONTENT: ",DIR("B") ="A" S DIR ("?",1)="( D) DISPLAY CONTAINS ONLY THOSE IDS ASSIG NED AS DEF AULTS TO T HE FACILIT Y BY",DIR( "?",2)=" T HE INSURAN CE COMPANY " S DIR("? ",3)="(I) DISPLAY CO NTAINS ONL Y THOSE ID S ASSIGNED TO INDIVI DUAL PROVI DERS BY TH E",DIR("?" ,4)=" INSU RANCE COMP ANY" S DIR ("?",5)="( A) DISPLAY CONTAINS ALL IDS AS SIGNED BY THE INSURA NCE COMPAN Y FOR ONE OR ALL",DI R("?")=" P ROVIDER ID TYPES" W ! D ^DIR K DIR W ! I $D(DTOUT) !$D(DUOUT) !("DIA"'[Y ) S IBOK=0 G INSIDQ S IBDSP=Y, IBSORT="" I IBDSP="A "!(IBDSP=" I") F D Q:'IBOK!(I BSORT'="") . ; . I I BDSP="A" D .. S DIR( "A")="Disp lay only I Ds with a specific I D Qualifie r?: " .. S DIR("?",1 )="Answer Yes to sel ect a spec ific ID Qu alifier by which to display ID s." .. S D IR("?")="A nswer No t o display all IDs." .. Q . ; . I IBDSP=" I" D .. S DIR("A")=" Display ID s for a sp ecific Pro vider?: " .. S DIR(" ?",1)="Ans wer Yes to select a specific P rovider." .. S DIR(" ?")="Answe r No to di splay all Providers. " .. Q . ; . S DIR(" B")="NO",D IR(0)="YA" . W ! D ^ DIR K DIR W ! . I $D (DTOUT)!$D (DUOUT) S IBOK=0 Q . I Y'=1 S IBSORT="AL L" Q . ; . I IBDSP=" A" D Q .. S DIC(0)= "AEMQ",DIC ="^IBE(355 .97,",DIC( "S")="I $S ('$P(^(0), U,2):1,1:$ P(^(0),U,2 )=3)" .. S DIC("A")= "Select ty pe of ID Q ualifier: " .. D ^DI C K DIC .. I Y>0 S I BSORT=+Y Q .. I $D(D TOUT)!$D(D UOUT) S IB OK=0 . ; . I IBDSP=" I" D Q .. N DA .. S DIR(0)="3 99.0222,.0 2A",DIR("A ")="SELECT PROVIDER: " .. W ! D ^DIR K D IR W ! .. I Y>0 S IB SORT=Y Q . . I $D(DTO UT)!$D(DUO UT) S IBOK =0 Q . S I BOK=0 Q ; G:'IBOK IN SIDQ D BLD (IBINS,IBD SP,IBSORT) INSIDQ I ' IBOK S VAL MQUIT=1 Q ;BLD(IBINS ,IBDSP,IBS ORT) ; Bui ld display for Insur ance co le vel provid er ID's N IB,IBENT,I BLCT,IBCT, IBPRV,IBSR T1,IBSRT2, IBOSRT1,IB OSRT2,CU,F T,PT,CT,Z, Z0 K ^TMP( "IBPRV_INS _ID",$J),^ TMP("IBPRV _INS_SORT" ,$J) ; S ( IBENT,IBCT ,IBLCT)=0 ; I "DA"[$ G(IBDSP) D . S CU="" F S CU=$ O(^IBA(355 .91,"AUNIQ ",IBINS,CU )) Q:CU="" S FT="" F S FT=$O (^IBA(355. 91,"AUNIQ" ,IBINS,CU, FT)) Q:FT= "" D .. S CT="" F S CT=$O(^I BA(355.91, "AUNIQ",IB INS,CU,FT, CT)) Q:CT= "" S PT=0 F S PT=$ S(IBDSP="A "&IBSORT:I BSORT,1:$O (^IBA(355. 91,"AUNIQ" ,IBINS,CU, FT,CT,PT)) ) Q:'PT D Q:IBDSP= "A"&IBSORT ... S Z=0 F S Z=$O (^IBA(355. 91,"AUNIQ" ,IBINS,CU, FT,CT,PT,Z )) Q:'Z S IB=$G(^IB A(355.91,Z ,0)) S ^TM P("IBPRV_I NS_SORT",$ J,PT,"^<<I NS CO DEFA ULT>>",FT, CT,CU,Z)=$ P(IB,U,7)_ U ; I "IA" [$G(IBDSP) D . S IBP RV="" . N IB1,IB2 . F S IBPRV =$O(^IBA(3 55.9,"AE", IBINS,IBPR V)) Q:'IBP RV S Z=0 F S Z=$O( ^IBA(355.9 ,"AE",IBIN S,IBPRV,Z) ) Q:'Z S IB=$G(^IBA (355.9,Z,0 )) D .. Q: $P(IB,U,4) =""!($P(IB ,U,5)="")! ($P(IB,U,6 )="")!($P( IB,U,16)=" ") .. I IB SORT,$S(IB DSP="I":IB PRV'=IBSOR T,1:$P(IB, U,6)'=IBSO RT) Q .. S IB1=$S(IB DSP="A":$P (IB,U,6),1 :U_$$EXPAN D^IBTRE(35 5.9,.01,IB PRV)_U_IBP RV) .. S I B2=$S(IBDS P="I":$P(I B,U,6),1:U _$$EXPAND^ IBTRE(355. 9,.01,IBPR V)_U_IBPRV ) .. S ^TM P("IBPRV_I NS_SORT",$ J,IB1,IB2, $P(IB,U,4) ,$P(IB,U,5 ),$P(IB,U, 16),Z)=$P( IB,U,7)_U_ IBPRV ; S IBOSRT1="" S IBSRT1= "" F S IB SRT1=$O(^T MP("IBPRV_ INS_SORT", $J,IBSRT1) ) Q:IBSRT1 ="" D . S IBSRT2="" ,IBOSRT2=" " . F S I BSRT2=$O(^ TMP("IBPRV _INS_SORT" ,$J,IBSRT1 ,IBSRT2)) Q:IBSRT2=" " D .. I IBOSRT1'=I BSRT1 D .. . I IBOSRT 1'="" S IB LCT=IBLCT+ 1 D SET^VA LM10(IBLCT ," ",IBCT+ 1) ... S I BLCT=IBLCT +1 D SET^V ALM10(IBLC T,$S(IBDSP '="I":"ID Qualifier" ,1:"Provid er")_": "_ $S(IBDSP'= "I":$$EXPA ND^IBTRE(3 55.91,.06, IBSRT1),1: $P(IBSRT1, U,2_$S($P( IBSRT2,U,3 )["VA(200" :" (VA)",1 :"(NON-VA) "))),IBCT+ 1) ... S I BOSRT1=IBS RT1 .. ; . . S FT="" F S FT=$O (^TMP("IBP RV_INS_SOR T",$J,IBSR T1,IBSRT2, FT)) Q:FT= "" S CT=" " F S CT= $O(^TMP("I BPRV_INS_S ORT",$J,IB SRT1,IBSRT 2,FT,CT)) Q:CT="" D ... S CU= "" F S CU =$O(^TMP(" IBPRV_INS_ SORT",$J,I BSRT1,IBSR T2,FT,CT,C U)) Q:CU=" " S Z=0 F S Z=$O(^ TMP("IBPRV _INS_SORT" ,$J,IBSRT1 ,IBSRT2,FT ,CT,CU,Z)) Q:'Z S I B=$G(^(Z)) D .... S IBLCT=IBLC T+1,IBCT=I BCT+1 .... S Z0=$E(I BCT_$J("", 4),1,4)_" " .... I I BDSP'="I" S Z0=Z0_$E ($S(IBOSRT 2'=IBSRT2: $P(IBSRT2, U,2),1:"") _$J("",20) ,1,20) ... . I IBDSP= "I" S Z0=Z 0_$E($S(IB OSRT2'=IBS RT2:$$EXPA ND^IBTRE(3 55.9,.06,I BSRT2),1:" ")_$J("",2 0),1,20) . ... S IBOS RT2=IBSRT2 .... S Z0 =Z0_" "_$S (FT=1:"UB- 04",FT=2:" 1500 ",1:" BOTH ")_" "_$E($S(CT =3:"RX",CT =1:"INPT", CT=2:"OUTP T",1:"INPT /OUTPT")_$ J("",11),1 ,11)_" "_$ E($S(CU'=" *N/A*":$P( $G(^IBA(35 5.95,+$P($ G(^IBA(355 .96,+CU,0) ),U),0)),U ),1:"")_$J ("",15),1, 15) .... D SET^VALM1 0(IBLCT,Z0 _" "_$P(IB ,U),IBCT) .... S ^TM P("IBPRV_I NS_ID",$J, "ZIDX",IBC T)=Z,^(IBC T,"PRV")=$ P(IB,U,2) .... I '$D (^TMP("IBP RV_INS_ID" ,$J,$S(IBD SP="I":"ZX PRV",1:"ZX PTYP"),IBS RT1)) S ^( IBSRT1)=IB LCT-1 K ^T MP("IBPRV_ INS_SORT", $J) ; I IB LCT=0 D G BLDQ ; No entries f ound . D S ET^VALM10( 1," ") . S Z=" No "_ $S(IBDSP=" D":"defaul t ",1:"") . S Z=Z_"I D's found for "_$S(I BDSP="I":" provider " _$S(IBSORT :"("_$$EXP AND^IBTRE( 355.9,.01, IBSORT)_") ",1:"")_" and ",IBDS P="A":"pro vider type "_$S(IBSO RT:"("_$$E XPAND^IBTR E(355.9,.0 6,IBSORT)_ ") ",1:"") _"and ",1: "")_"insur ance co" . D SET^VAL M10(2,Z) . S IBLCT=2 ;BLDQ S V ALMCNT=IBL CT,VALMBG= 1 Q ;EXPND ; Q ;HELP ; Q ;EXIT ; K IBFAS TXT D COPY PROV^IBCEP 5A(IBINS) K ^TMP("IB PRV_INS_ID ",$J) D CL EAN^VALM10 Q ;SEL(IB DA,MANY) ; Select fr om provide r id list ; IBDA is passed by reference and IBDA(1 ) returned containin g ; ien's of the pro vider id r ecords sel ected (fil e 355.9). ; If > 1 e ntry can b e selected , MANY is set to 1 N Z S IBDA= 0 D EN^VAL M2($G(XQOR NOD(0)),$S ($G(MANY): "",1:"S")) S Z=0 F S Z=$O(VAL MY(Z)) Q:' Z S IBDA= IBDA+1,IBD A(IBDA)=+$ G(^TMP("IB PRV_INS_ID ",$J,"ZIDX ",Z))_U_$G (^(Z,"PRV" )) Q ;ENX( IBINS1) ; Insurance co level d efaults fo r all prov iders or ; for all p roviders b y care uni t N DIC,DI E,DR,DA,X, Y,DLAYGO I '$G(IBINS 1) D G:'$ G(IBINS1) ENQ . S DI C="^IBA(35 5.91,",DIC (0)="AELMQ ",DLAYGO=3 55.91 D ^D IC . I Y>0 S IBINS1= +Y S DIE=" ^IBA(355.9 1,",DA=IBI NS1,DR=".0 1;.06;.04; .05;.03;.0 7" D ^DIE ;ENQ Q ;PP TYP(IBINS) ; Returns the ien o f the defa ult perfor ming provi der type f or ; insu rance comp any IBINS (ien file 36) Q +$G( ^DIC(36,+I BINS,4)) ; SCREEN(WHI CH) ; This screen is used the menu proto col to scr een out th e ID funct ions if it is a chil d ins co Q :'$G(DA) 0 Q:'$G(DA( 1)) 0 N FI LE,IENS,FI ELD,FLAG,T ARGET S FI LE=101.01, IENS=DA_", "_DA(1),FI ELD=".01", FLAG="I" D GETS^DIQ( FILE,IENS, FIELD,FLAG ,"TARGET") Q:'$D(TAR GET) 0 N I EN S IEN=$ G(TARGET(F ILE,IENS_" ,",FIELD,F LAG)) Q:'+ IEN 0 S FI LE=101,FIE LD=1,FLAG= "E" K TARG ET D GETS^ DIQ(FILE,I EN,FIELD,F LAG,"TARGE T") Q:'$D( TARGET) 0 I $G(TARGE T(FILE,IEN _",",FIELD ,FLAG))'[W HICH Q 1 Q :'$G(IBINS ) 0 N PCF S PCF=$P($ G(^DIC(36, +IBINS,3)) ,U,13) I P CF="C" Q 0 Q 1 | |
| 1879 | Modified L ogic (Chan ges are in bold) | |
| 1880 | IBCEP0 ;AL B/TMP - Fu nctions fo r PROVIDER ID MAINTE NANCE ;13- DEC-99 ;;2 .0;INTEGRA TED BILLIN G;**137,19 1,239,232, 320,348,34 9,377,592* *;21-MAR-9 4;Build 23 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;E N ; -- mai n entry po int for IB CE PRV INS ID N IBIN S,IBDSP,IB SORT,IBPRV ; Variabl es should be availab le through out action s K IBFAST XT D FULL^ VALM1 D EN ^VALM("IBC E PRVINS I D") Q ;EN1 (IBINS) ; Entrypoint from insu rance co m aintenance N IBDSP,I BSORT ; Va riables sh ould be av ailable th roughout a ctions D F ULL^VALM1 D EN^VALM( "IBCE PRVI NS ID FROM INS MAINT ") Q ;HDR ; -- heade r code N Z ,Z0,Z1,IBC T,IBPPTYP, IBEMCTYP S IBCT=1 K VALMHDR I $G(IBINS) D . N PCF, PCDISP . S PCF=$P($G (^DIC(36,+ IBINS,3)), U,13) . S PCDISP=$S( PCF="C":"( Child)",PC F="P":"(Pa rent)",1:" ") . S VAL MHDR(1)="I nsurance C o: "_$P($G (^DIC(36,+ IBINS,0)), U)_" "_PCD ISP . ; Ge t performi ng provide r id type for insura nce co . S IBPPTYP=$ $PPTYP(IBI NS) . ; Ge t ien of E MC ID from file 355. 97 . S IBE MCTYP=+$$E MCID^IBCEP () . I $G( IBSORT)="A LL"!($G(IB DSP)="I")! ($G(IBSORT )=IBPPTYP) !($G(IBSOR T)=IBEMCTY P) D .. ; Look for c are unit i n either o f these id types - i f there, r eport on l ine 2 of h eader .. I $G(IBSORT )=IBPPTYP S IBEMCTYP =0 .. I $G (IBSORT)=I BEMCTYP S IBPPTYP=0 .. F Z0=IB PPTYP_"P", IBEMCTYP_" E" S Z1="" F S Z1=$ O(^IBA(355 .96,"D",+I BINS,+Z0,Z 1)) Q:Z1=" " I Z1'=" *N/A*" S Z ($E(Z0,$L( Z0)))=1 Q .. I $D(Z( "P"))!$D(Z ("E")) D . .. S IBCT= IBCT+1 ... S VALMHDR (IBCT)=" " _$S($D(Z(" P")):"PERF ORMING PRO V ID"_$S($ D(Z("E")): " AND ",1: ""),1:"")_ $S($D(Z("E ")):"EMC P ROV ID",1: "")_" MAY REQUIRE CA RE UNIT" . I $D(Z("P "))!$D(Z(" E")) S IBC T=IBCT+1,V ALMHDR(IBC T)=" " . S IBCT=IBCT +1,VALMHDR (IBCT)=" P ROVIDER "_ $S($G(IBDS P)="I":"ID TYPE",1:" NAME ")_$J ("",6)_"FO RM CARE TY PE CARE UN IT ID#" Q ;INIT ; In itializati on K ^TMP( "IB_EDITED _IDS",$J) ; This wil l be to ke ep track o f ID's edi ted during this sess ion D INSI D(.IBINS,. IBDSP,.IBS ORT) I $G( IBDSP)="I" ,$G(IBSORT ) S IBPRV= IBSORT I ' $G(IBINS) S VALMQUIT =1 Q ;INSI D(IBINS,IB DSP,IBSORT ) ; N DIC, DIR,DA,X,Y ,IBOK,DTOU T,DUOUT S IBOK=1 I ' $G(IBINS) D . S DIC( 0)="AEMQ", DIC="^DIC( 36," D ^DI C . I Y'>0 S IBOK=0 Q . S IBIN S=+Y I '$G (IBINS) S IBOK=0 I ' IBOK G INS IDQ ; S DI R(0)="SA^D :INSURANCE CO DEFAUL T IDS;I:IN DIVIDUAL P ROVIDER ID S FURNISHE D BY THE I NS CO;A:AL L IDS FURN ISHED BY T HE INS CO BY PROVIDE R TYPE" S DIR("A")=" SELECT DIS PLAY CONTE NT: ",DIR( "B")="A" S DIR("?",1 )="(D) DIS PLAY CONTA INS ONLY T HOSE IDS A SSIGNED AS DEFAULTS TO THE FAC ILITY BY", DIR("?",2) =" THE INS URANCE COM PANY" S DI R("?",3)=" (I) DISPLA Y CONTAINS ONLY THOS E IDS ASSI GNED TO IN DIVIDUAL P ROVIDERS B Y THE",DIR ("?",4)=" INSURANCE COMPANY" S DIR("?",5 )="(A) DIS PLAY CONTA INS ALL ID S ASSIGNED BY THE IN SURANCE CO MPANY FOR ONE OR ALL ",DIR("?") =" PROVIDE R ID TYPES " W ! D ^D IR K DIR W ! I $D(DT OUT)!$D(DU OUT)!("DIA "'[Y) S IB OK=0 G INS IDQ S IBDS P=Y,IBSORT ="" I IBDS P="A"!(IBD SP="I") F D Q:'IBO K!(IBSORT' ="") . ; . I IBDSP=" A" D .. S DIR("A")=" Display on ly IDs wit h a specif ic ID Qual ifier?: " .. S DIR(" ?",1)="Ans wer Yes to select a specific I D Qualifie r by which to displa y IDs." .. S DIR("?" )="Answer No to disp lay all ID s." .. Q . ; . I IBD SP="I" D . . S DIR("A ")="Displa y IDs for a specific Provider? : " .. S D IR("?",1)= "Answer Ye s to selec t a specif ic Provide r." .. S D IR("?")="A nswer No t o display all Provid ers." .. Q . ; . S D IR("B")="N O",DIR(0)= "YA" . W ! D ^DIR K DIR W ! . I $D(DTOUT )!$D(DUOUT ) S IBOK=0 Q . I Y'= 1 S IBSORT ="ALL" Q . ; . I IBD SP="A" D Q .. S DIC (0)="AEMQ" ,DIC="^IBE (355.97,", DIC("S")=" I $S('$P(^ (0),U,2):1 ,1:$P(^(0) ,U,2)=3)" .. S DIC(" A")="Selec t type of ID Qualifi er: " .. D ^DIC K DI C .. I Y>0 S IBSORT= +Y Q .. I $D(DTOUT)! $D(DUOUT) S IBOK=0 . ; . I IBD SP="I" D Q .. N DA .. S DIR(0 )="399.022 2,.02A",DI R("A")="SE LECT PROVI DER: " .. W ! D ^DIR K DIR W ! .. I Y>0 S IBSORT=Y Q .. I $D (DTOUT)!$D (DUOUT) S IBOK=0 Q . S IBOK=0 Q ; G:'IBO K INSIDQ D BLD(IBINS ,IBDSP,IBS ORT)INSIDQ I 'IBOK S VALMQUIT= 1 Q ;BLD(I BINS,IBDSP ,IBSORT) ; Build dis play for I nsurance c o level pr ovider ID' s N IB,IBE NT,IBLCT,I BCT,IBPRV, IBSRT1,IBS RT2,IBOSRT 1,IBOSRT2, CU,FT,PT,C T,Z,Z0 K ^ TMP("IBPRV _INS_ID",$ J),^TMP("I BPRV_INS_S ORT",$J) ; S (IBENT, IBCT,IBLCT )=0 ; I "D A"[$G(IBDS P) D . S C U="" F S CU=$O(^IBA (355.91,"A UNIQ",IBIN S,CU)) Q:C U="" S FT ="" F S F T=$O(^IBA( 355.91,"AU NIQ",IBINS ,CU,FT)) Q :FT="" D .. S CT="" F S CT=$ O(^IBA(355 .91,"AUNIQ ",IBINS,CU ,FT,CT)) Q :CT="" S PT=0 F S PT=$S(IBDS P="A"&IBSO RT:IBSORT, 1:$O(^IBA( 355.91,"AU NIQ",IBINS ,CU,FT,CT, PT))) Q:'P T D Q:IB DSP="A"&IB SORT ... S Z=0 F S Z=$O(^IBA( 355.91,"AU NIQ",IBINS ,CU,FT,CT, PT,Z)) Q:' Z S IB=$G (^IBA(355. 91,Z,0)) S ^TMP("IBP RV_INS_SOR T",$J,PT," ^<<INS CO DEFAULT>>" ,FT,CT,CU, Z)=$P(IB,U ,7)_U ; I "IA"[$G(IB DSP) D . S IBPRV="" . N IB1,IB 2 . F S I BPRV=$O(^I BA(355.9," AE",IBINS, IBPRV)) Q: 'IBPRV S Z=0 F S Z =$O(^IBA(3 55.9,"AE", IBINS,IBPR V,Z)) Q:'Z S IB=$G( ^IBA(355.9 ,Z,0)) D . . Q:$P(IB, U,4)=""!($ P(IB,U,5)= "")!($P(IB ,U,6)="")! ($P(IB,U,1 6)="") .. I IBSORT,$ S(IBDSP="I ":IBPRV'=I BSORT,1:$P (IB,U,6)'= IBSORT) Q .. S IB1=$ S(IBDSP="A ":$P(IB,U, 6),1:U_$$E XPAND^IBTR E(355.9,.0 1,IBPRV)_U _IBPRV) .. S IB2=$S( IBDSP="I": $P(IB,U,6) ,1:U_$$EXP AND^IBTRE( 355.9,.01, IBPRV)_U_I BPRV) .. S ^TMP("IBP RV_INS_SOR T",$J,IB1, IB2,$P(IB, U,4),$P(IB ,U,5),$P(I B,U,16),Z) =$P(IB,U,7 )_U_IBPRV ; S IBOSRT 1="" S IBS RT1="" F S IBSRT1=$ O(^TMP("IB PRV_INS_SO RT",$J,IBS RT1)) Q:IB SRT1="" D . S IBSRT 2="",IBOSR T2="" . F S IBSRT2= $O(^TMP("I BPRV_INS_S ORT",$J,IB SRT1,IBSRT 2)) Q:IBSR T2="" D . . I IBOSRT 1'=IBSRT1 D ... I IB OSRT1'="" S IBLCT=IB LCT+1 D SE T^VALM10(I BLCT," ",I BCT+1) ... S IBLCT=I BLCT+1 D S ET^VALM10( IBLCT,$S(I BDSP'="I": "ID Qualif ier",1:"Pr ovider")_" : "_$S(IBD SP'="I":$$ EXPAND^IBT RE(355.91, .06,IBSRT1 ),1:$P(IBS RT1,U,2_$S ($P(IBSRT2 ,U,3)["VA( 200":" (VA )",1:"(NON -VA)"))),I BCT+1) ... S IBOSRT1 =IBSRT1 .. ; .. S FT ="" F S F T=$O(^TMP( "IBPRV_INS _SORT",$J, IBSRT1,IBS RT2,FT)) Q :FT="" S CT="" F S CT=$O(^TM P("IBPRV_I NS_SORT",$ J,IBSRT1,I BSRT2,FT,C T)) Q:CT=" " D ... S CU="" F S CU=$O(^T MP("IBPRV_ INS_SORT", $J,IBSRT1, IBSRT2,FT, CT,CU)) Q: CU="" S Z =0 F S Z= $O(^TMP("I BPRV_INS_S ORT",$J,IB SRT1,IBSRT 2,FT,CT,CU ,Z)) Q:'Z S IB=$G(^ (Z)) D ... . S IBLCT= IBLCT+1,IB CT=IBCT+1 .... S Z0= $E(IBCT_$J ("",4),1,4 )_" " .... I IBDSP'= "I" S Z0=Z 0_$E($S(IB OSRT2'=IBS RT2:$P(IBS RT2,U,2),1 :"")_$J("" ,20),1,20) .... I IB DSP="I" S Z0=Z0_$E($ S(IBOSRT2' =IBSRT2:$$ EXPAND^IBT RE(355.9,. 06,IBSRT2) ,1:"")_$J( "",20),1,2 0) .... S IBOSRT2=IB SRT2 .... ;JRA IB*2. 0*592 Modi fy to acco modate Den tal form ' J430D' ... . S Z0=Z0_ " "_$S(FT= 1:"UB-04", FT=2:"1500 ",FT=4:"J4 30D",1:"AL L ")_" "_$ E($S(CT=3: "RX",CT=1: "INPT",CT= 2:"OUTPT", 1:"INPT/OU TPT")_$J(" ",11),1,11 ) ;JWS;JRA IB*2.0*59 2 .... S Z 0=Z0_" "_$ E($S(CU'=" *N/A*":$P( $G(^IBA(35 5.95,+$P($ G(^IBA(355 .96,+CU,0) ),U),0)),U ),1:"")_$J ("",15),1, 15) ;JWS;J RA IB*2.0* 592 .... D SET^VALM1 0(IBLCT,Z0 _" "_$P(IB ,U),IBCT) .... S ^TM P("IBPRV_I NS_ID",$J, "ZIDX",IBC T)=Z,^(IBC T,"PRV")=$ P(IB,U,2) .... I '$D (^TMP("IBP RV_INS_ID" ,$J,$S(IBD SP="I":"ZX PRV",1:"ZX PTYP"),IBS RT1)) S ^( IBSRT1)=IB LCT-1 K ^T MP("IBPRV_ INS_SORT", $J) ; I IB LCT=0 D G BLDQ ; No entries f ound . D S ET^VALM10( 1," ") . S Z=" No "_ $S(IBDSP=" D":"defaul t ",1:"") . S Z=Z_"I D's found for "_$S(I BDSP="I":" provider " _$S(IBSORT :"("_$$EXP AND^IBTRE( 355.9,.01, IBSORT)_") ",1:"")_" and ",IBDS P="A":"pro vider type "_$S(IBSO RT:"("_$$E XPAND^IBTR E(355.9,.0 6,IBSORT)_ ") ",1:"") _"and ",1: "")_"insur ance co" . D SET^VAL M10(2,Z) . S IBLCT=2 ;BLDQ S V ALMCNT=IBL CT,VALMBG= 1 Q ;EXPND ; Q ;HELP ; Q ;EXIT ; K IBFAS TXT D COPY PROV^IBCEP 5A(IBINS) K ^TMP("IB PRV_INS_ID ",$J) D CL EAN^VALM10 Q ;SEL(IB DA,MANY) ; Select fr om provide r id list ; IBDA is passed by reference and IBDA(1 ) returned containin g ; ien's of the pro vider id r ecords sel ected (fil e 355.9). ; If > 1 e ntry can b e selected , MANY is set to 1 N Z S IBDA= 0 D EN^VAL M2($G(XQOR NOD(0)),$S ($G(MANY): "",1:"S")) S Z=0 F S Z=$O(VAL MY(Z)) Q:' Z S IBDA= IBDA+1,IBD A(IBDA)=+$ G(^TMP("IB PRV_INS_ID ",$J,"ZIDX ",Z))_U_$G (^(Z,"PRV" )) Q ;ENX( IBINS1) ; Insurance co level d efaults fo r all prov iders or ; for all p roviders b y care uni t N DIC,DI E,DR,DA,X, Y,DLAYGO I '$G(IBINS 1) D G:'$ G(IBINS1) ENQ . S DI C="^IBA(35 5.91,",DIC (0)="AELMQ ",DLAYGO=3 55.91 D ^D IC . I Y>0 S IBINS1= +Y S DIE=" ^IBA(355.9 1,",DA=IBI NS1,DR=".0 1;.06;.04; .05;.03;.0 7" D ^DIE ;ENQ Q ;PP TYP(IBINS) ; Returns the ien o f the defa ult perfor ming provi der type f or ; insu rance comp any IBINS (ien file 36) Q +$G( ^DIC(36,+I BINS,4)) ; SCREEN(WHI CH) ; This screen is used the menu proto col to scr een out th e ID funct ions if it is a chil d ins co Q :'$G(DA) 0 Q:'$G(DA( 1)) 0 N FI LE,IENS,FI ELD,FLAG,T ARGET S FI LE=101.01, IENS=DA_", "_DA(1),FI ELD=".01", FLAG="I" D GETS^DIQ( FILE,IENS, FIELD,FLAG ,"TARGET") Q:'$D(TAR GET) 0 N I EN S IEN=$ G(TARGET(F ILE,IENS_" ,",FIELD,F LAG)) Q:'+ IEN 0 S FI LE=101,FIE LD=1,FLAG= "E" K TARG ET D GETS^ DIQ(FILE,I EN,FIELD,F LAG,"TARGE T") Q:'$D( TARGET) 0 I $G(TARGE T(FILE,IEN _",",FIELD ,FLAG))'[W HICH Q 1 Q :'$G(IBINS ) 0 N PCF S PCF=$P($ G(^DIC(36, +IBINS,3)) ,U,13) I P CF="C" Q 0 Q 1 | |
| 1881 | ||
| 1882 | ||
| 1883 | Routines | |
| 1884 | Activities | |
| 1885 | Routine Na me | |
| 1886 | IBCEP2 | |
| 1887 | Enhancemen t Category | |
| 1888 | New | |
| 1889 | Modify | |
| 1890 | Delete | |
| 1891 | No Change | |
| 1892 | RTM | |
| 1893 | ||
| 1894 | Related Op tions | |
| 1895 | None | |
| 1896 | Related Ro utines | |
| 1897 | Routines “ Called By” | |
| 1898 | Routines “ Called” | |
| 1899 | ||
| 1900 | ||
| 1901 | ||
| 1902 | ||
| 1903 | Data Dicti onary (DD) Reference s | |
| 1904 | ||
| 1905 | Related Pr otocols | |
| 1906 | None | |
| 1907 | Related In tegration Control Re gistration s (ICRs) | |
| 1908 | None | |
| 1909 | Data Passi ng | |
| 1910 | Input | |
| 1911 | Output Re ference | |
| 1912 | Both | |
| 1913 | Global Re ference | |
| 1914 | Local | |
| 1915 | Input Attr ibute Name and Defin ition | |
| 1916 | Name: | |
| 1917 | Definition : | |
| 1918 | Output Att ribute Nam e and Defi nition | |
| 1919 | Name: | |
| 1920 | Definition : | |
| 1921 | Current Lo gic | |
| 1922 | IBCEP2 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;1 3-DEC-99 ; ;2.0;INTEG RATED BILL ING;**137, 181,232,28 0,320,349, 432**;21-M AR-94;Buil d 192 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ; DBIA for access to fields 53.2,54.1 ,54.2 in f ile 200: 2 24 ;GETID( IBIFN,IBTY PE,IBPROV, IBSEQ,IBT, IBT1,IBFUN C) ; Extra ct IBTYPE id for the bill ; IB IFN = bill ien (file 399) ; IB TYPE = 2:P ERFORMING PROVIDER I D (1 and 3 deleted) ; IBSEQ = numeric CO B sequence of the in surance on bill ; IB FUNC = 1:R EFERRING;2 :OPERATING ;3:RENDERI NG;4:ATTEN DING;5:SUP ERVISING;9 :OTHER; ; Returns IB T = ien of the provi der id typ e^ien of e ntry^file # for id ; S IBT=0 Q :IBTYPE'=2 "" N IBID ,IBPTYP S IBID=$$IDF IND(IBIFN, "",IBPROV, IBSEQ,1,.I BT,$G(IBFU NC)) I IBI D="" S IBT ="" ; Q IB ID ;IDFIND (IBIFN,IBP TYP,IBPROV ,IBSEQ,IBP ERF,IBT,IB FUNC) ;Loo p thru sou rce levels ; (if id definition allows) t o find cor rect ID ; IBIFN = bi ll ien (fi le 399) ; IBPTYP = i en of the provider i d type in file 355.9 7 or if nu ll, ; the default pe rforming p rovider ID type for the ins co . in ; COB sequence IBSEQ will be calcul ated ; IBP ROV = (var iable poin ter syntax ) provider on bill I BIFN ; IBS EQ = numer ic COB seq uence of t he bill ; IBPERF = 1 if the pe rforming p rovider id is needed ; IBFUNC = 1:REFERR ING;2:OPER ATING;3:RE NDERING;4: ATTENDING; 5:SUPERVIS ING;9:OTHE R; ; Retur ns IBT = p tr to file 355.97^en try #^file # ; S IBT =+$G(IBPTY P) Q:'$G(I BPERF)!'$G (IBPROV) " " N IBSPEC ,IBINS,IBI NS4,IBSRC, IBUP,IBID, IBALT,IBPR OF,Z I $G( IBSEQ)="" S IBSEQ=+$ $COBN^IBCE F(IBIFN) ; Default t o current COB seq S IBINS=+$P( $G(^DGCR(3 99,IBIFN," I"_IBSEQ)) ,U),IBINS4 =$G(^DIC(3 6,+IBINS,4 )) S IBPRO F=($$FT^IB CEF(IBIFN) =2) S:'IBP ROF IBPROF =2 ; form type is CM S-1500 (pr of)=1, UB- 04 (inst)= 2 I $G(IBP TYP)="",$G (IBFUNC)=1 ,IBPROF=1 S (IBT,IBP TYP)=+$P(I BINS4,U,4) ; Referri ng Default ID on CMS -1500 I $G (IBPTYP)=" " S (IBT,I BPTYP)=+$P (IBINS4,U, IBPROF) ; Def to per f prv typ for form I 'IBPTYP Q "" ; No default id type S IB SPEC=$G(^I BE(355.97, IBPTYP,1)) ,IBSRC=$P( $G(^IBE(35 5.97,+IBPT YP,0)),U,2 ),IBSRC=$S ('IBSRC:5, 1:IBSRC),I BUP=1 S IB ALT=0 ; F D Q:'IBU P!($G(IBID )'="") S I BSRC=IBSRC -1 Q:'IBSR C . ; . I IBSRC=1,$T R($P(IBSPE C,U,1,3)," ^0")'="" D Q ; Ind iv prov de fault .. N IBSTATE . . I $P(IBS PEC,U,2) D Q ; Fed eral DEA # from fiel d 53.2 fil e 200 ... S IBID=$P( $G(^VA(200 ,+IBPROV," PS")),U,2) ; DBIA224 ... S $P( IBT,U,2,3) =(IBPROV_U _200) .. S IBSTATE=+ $$CAREST^I BCEP2A(IBI FN) .. I $ P(IBSPEC,U ) D Q ; State issu ed DEA # n eeded ... Q:'IBSTATE ... ; Ext ract the s tate issui ng DEA # f rom field 54.2 file 200 ... S Z=+$O(^VA( 200,+IBPRO V,"PS2","B ",IBSTATE, 0)),IBID=$ P($G(^VA(2 00,+IBPROV ,"PS2",Z,0 )),U,2) ; DBIA224 .. . S $P(IBT ,U,2,3)=(+ IBPROV_";" _Z_U_200) .. I $P(IB SPEC,U,3) D Q ; St ate licens e # needed ... Q:'IB STATE ... ; Extract the state license # from field 54.1 file 200 ... I IBPROV["V A(200" S Z =+$O(^VA(2 00,+IBPROV ,"PS1","B" ,IBSTATE,0 )),IBID=$P ($G(^VA(20 0,+IBPROV, "PS1",Z,0) ),U,2),$P( IBT,U,2,3) =(+IBPROV_ ";"_IBSTAT E_U_200) ; DBIA224 . .. I IBPRO V["IBA(355 .93" S IBI D=$P($G(^I BA(355.93, +IBPROV,0) ),U,12),$P (IBT,U,2,3 )=(+IBPROV _U_355.93) . ; . I I BSRC=2,$P( IBSPEC,U,4 ) D Q ; FACILITY F ED TAX ID # .. N IBX DATA .. D F^IBCEF("N -FEDERAL T AX ID",,,I BIFN) .. S IBID=IBXD ATA,$P(IBT ,U,2,3)=(U _350.9) . ; . I IBSR C=1 S IBID =$$SRC1(IB IFN,"*ALL* ",IBPTYP,I BPROV,.IBT ) Q . ; . I IBSRC=2 S IBID=$$S RC2(IBPTYP ,.IBT) Q . ; . I IBS RC=3 S IBI D=$$SRC3(I BIFN,IBINS ,IBPTYP,.I BT) Q . ; . I IBSRC =4 S IBID= $$SRC4(IBI FN,IBINS,I BPTYP,IBPR OV,.IBT) Q . ; . I I BSRC=5 S I BID=$$SRC5 (IBIFN,IBI NS,IBPTYP, IBSEQ,.IBT ,$G(IBFUNC )) Q . ; . I IBSRC=6 S IBID=$$ SRC6(IBIFN ,IBINS,IBP TYP,IBPROV ,IBSEQ,.IB T) Q ; Q $ G(IBID) ;G ETALL(IBTY PE,IBIFN,I BPROV,IBPI D) ; Extra ct all per forming pr ov id's fo r a ; prov ider (IBPR OV - vp fo rmat) on b ill IBIFN ; IBTYPE = type of I D to retur n (see GET ID above) ; ; Return s array IB PID(COB SE Q #)=id (p ass by ref erence) AN D ; IBPID( COB SEQ #, 1)=ien of id type (p tr to 355. 97) ; IBPI D = curren t insuranc e co's id ; N Z,COB, Z1,IBT S C OB=$$COBN^ IBCEF(IBIF N) F Z=1:1 :3 Q:'$D(^ DGCR(399,I BIFN,"I"_Z )) S IBPID (Z)=$$GETI D(IBTYPE,I BIFN,IBPRO V,Z,.IBT), IBPID(Z,1) =IBT I Z=C OB S Z1=IB PID(Z) Q $ G(Z1) ;SRC 1(IBIFN,IB INS,IBPTYP ,IBPROV,IB T) ; Licen sing/gov't issued # - provider specific ; Paramete r definiti ons for SR C1, SRC3, SRC4, SRC5 , SRC6: ; IBIFN = ie n of bill (file 399) ; IBINS = ien of in surance co (file 36) or *ALL* for all in surance ; (always *A LL* for SR C1) ; IBPT YP = ien o f the prov ider id ty pe in file 355.97 ; IBPROV = ( variable p ointer syn tax) provi der on bil l IBIFN ; IBT = retu rned as ty pe ien^fil e ien^file # ; N IBI D,IB,IBRX, IBIDSV S I BID="",IB= 0,IBRX=$$I SRX^IBCEF1 (IBIFN),IB IDSV="" I $G(IBPROV) F S IB=$ O(^IBA(355 .9,"AD",IB PTYP,IBPRO V,IBINS,IB )) Q:'IB D Q:IBID' ="" . S IB ID=$$UNIQ1 (IBIFN,IBI NS,IBPTYP, IBPROV,"", IB) . I IB RX,$P($G(^ IBA(355.9, IB,0)),U,5 )'=3 S:IBI DSV="" IBI DSV=IBID S IBID="" ; Save 1st 'match' if no rx spe cific id I IBID="",I BIDSV'="" S IBID=IBI DSV Q IBID ;SRC2(IB3 5597,IBT) ; Facility default - all provi ders ; IB3 5597 = ien of the pr ovider id type entry in file 3 55.97 ; IB T = return ed as type ien^file ien^file # ; S $P(IB T,U,2,3)=( +IB35597_U _355.97) Q $P($G(^IB E(355.97,+ IB35597,0) ),U,4) ;SR C3(IBIFN,I BINS,IBPTY P,IBT) ; I ns co/all providers ; See SRC1 for param eter defin itions N I B,IBID,IBR X,IBIDSV S IBID="",I B=0,IBRX=$ $ISRX^IBCE F1(IBIFN), IBIDSV="" F S IB=$O (^IBA(355. 91,"AC",IB INS,IBPTYP ,"*N/A*",I B)) Q:'IB D Q:IBID '="" . S I BID=$$UNIQ 2(IBIFN,IB INS,IBPTYP ,"",IB,.IB T) . I IBR X,$P($G(^I BA(355.91, IB,0)),U,5 )'=3 S:IBI DSV="" IBI DSV=IBID S IBID="" ; Save 1st 'match' if no rx spe cific id I IBID="",I BIDSV'="" S IBID=IBI DSV Q IBID ;SRC4(IBI FN,IBINS,I BPTYP,IBPR OV,IBT) ; Insurance co/individ ual provid er ; See S RC1 for pa rameter de finitions ; N IBID,I B,IBRX,IBI DSV S IBID ="",IB=0,I BRX=$$ISRX ^IBCEF1(IB IFN),IBIDS V="" I $G( IBPROV) F S IB=$O(^ IBA(355.9, "AD",IBPTY P,IBPROV,I BINS,IB)) Q:'IB D Q:IBID'="" . S IBID= $$UNIQ1(IB IFN,IBINS, IBPTYP,IBP ROV,"",IB, .IBT) . I IBRX,$P($G (^IBA(355. 9,IB,0)),U ,5)'=3 S:I BIDSV="" I BIDSV=IBID S IBID="" ; Save 1s t 'match' if no rx s pecific id I IBID="" ,IBIDSV'=" " S IBID=I BIDSV Q IB ID ;SRC5(I BIFN,IBINS ,IBPTYP,IB SEQ,IBT,IB FUNC) ; In s co/all p roviders/c are unit ; See SRC1 for missin g paramete r definiti ons ; IBSE Q = the nu meric COB sequence o f the insu rance on t he bill ; Q "" ;DEM ;432 - Pie ces 9, 10, and 11 we re deleted in 2006. So, code d oesn't do anything o ther than return NUL L. N IBP,I BUNIT,IBID ,IB,Z,IBID SV,IBRX S IBID="",Z= 0,IBRX=$$I SRX^IBCEF1 (IBIFN),IB IDSV="" ; DEM;432 - IBLNPRV va riable is a flag to indicate i f user inp ut ; is cl aim level provider o r line lev el provide r user inp ut. ; DEM; 432 - Line provider interested in fuctio n 1 and 3, referring and rende ring respe ctively. I '$G(IBLNP RV) S IBP= +$O(^DGCR( 399,IBIFN, "PRV","B", $S($G(IBFU NC)=1:1,$$ FT^IBCEF(I BIFN)=3:4, 1:3),0)),I BUNIT=$P($ G(^DGCR(39 9,IBIFN,"P RV",IBP,0) ),U,8+IBSE Q) I $G(IB LNPRV) S I BP=+$O(^DG CR(399,IBI FN,"CP",IB LNPRV("PRO CIEN"),"LN PRV","B",$ S($G(IBFUN C)=1:1,1:3 ),0)),IBUN IT=$P($G(^ DGCR(399,I BIFN,"CP", IBLNPRV("P ROCIEN")," LNPRV",IBP ,0)),U,8+I BSEQ) I IB UNIT'="" F S Z=$O(^ IBA(355.96 ,"AC",IBIN S,IBPTYP,Z )) Q:'Z D Q:IBID'= "" . S IB= 0 F S IB= $O(^IBA(35 5.91,"ACAR E",Z,IB)) Q:'IB D Q:IBID'="" .. S IBID =$$UNIQ2(I BIFN,IBINS ,IBPTYP,IB UNIT,IB,.I BT) .. I I BRX,$P($G( ^IBA(355.9 1,IB,0)),U ,5)'=3 S:I BIDSV="" I BIDSV=IBID S IBID="" ; Save 1s t 'match' if no rx s pecific id I IBID="" ,IBIDSV'=" " S IBID=I BIDSV Q IB ID ;SRC6(I BIFN,IBINS ,IBPTYP,IB PROV,IBSEQ ,IBT) ; In s co/ind p rovider/ca re unit ; See SRC1 f or missing parameter definitio ns ; IBSEQ = the num eric COB s equence of the insur ance on th e bill ; Q "" ;DEM; 432 - Piec es 9, 10, and 11 wer e deleted in 2006. S o, code do esn't do a nything ot her than r eturn NULL . N IBUNIT ,IBP,IBID, IB S IBID= "",IB=0 I '$G(IBLNPR V) S IBP=+ $O(^DGCR(3 99,"PRV"," B",$S($$FT ^IBCEF(IBI FN)=3:3,1: 4),0)),IBU NIT=$P($G( ^DGCR(399, IBIFN,"PRV ",IBP,0)), U,8+IBSEQ) I $G(IBLN PRV) S IBP =+$O(^DGCR (399,IBIFN ,"CP",IBLN PRV("PROCI EN"),"LNPR V","B",$S( $$FT^IBCEF (IBIFN)=3: 3,1:4),0)) ,IBUNIT=$P ($G(^DGCR( 399,IBIFN, "CP",IBLNP RV("PROCIE N"),"LNPRV ",IBP,0)), U,8+IBSEQ) I $G(IBPR OV),IBUNIT '="" F S IB=$O(^IBA (355.9,"AD ",IBPTYP,I BPROV,IBIN S,IB)) Q:' IB D Q:I BID'="" . S IBID=$$U NIQ1(IBIFN ,IBINS,IBP TYP,IBPROV ,IBUNIT,IB ,.IBT) Q I BID ;UNIQ1 (IBIFN,IBI NS,IBPTYP, IBPROV,IBU NIT,IBCU,I BT) ; Matc h most-lea st specifi c ; *** SE E PARAMETE R DEFINITI ONS IN IBC EP3 *** ; ; Start in file 355. 9 (Specifi c Provider ) ; IBPROV = (variab le pointer syntax) p rovider on bill IBIF N ; Q $$UN IQ1^IBCEP2 A($G(IBIFN ),$G(IBINS ),$G(IBPTY P),$G(IBPR OV),$G(IBU NIT),$G(IB CU),$G(IBT )) ;UNIQ2( IBIFN,IBIN S,IBPTYP,I BUNIT,IBCU ,IBT) ; Ma tch on mos t-least sp ecific ; * ** SEE PAR AMETER DEF INITIONS I N IBCEP3 * ** ; ; Sta rt in file 355.91 (S pecific In surance) ; Q $$UNIQ2 ^IBCEP2A($ G(IBIFN),$ G(IBINS),$ G(IBPTYP), $G(IBUNIT) ,$G(IBCU), $G(IBT)) | |
| 1923 | Modified L ogic (Chan ges are in bold) | |
| 1924 | IBCEP2 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;1 3-DEC-99 ; ;2.0;INTEG RATED BILL ING;**137, 181,232,28 0,320,349, 432,592**; 21-MAR-94; Build 192 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ; D BIA for ac cess to fi elds 53.2, 54.1,54.2 in file 20 0: 224 ;GE TID(IBIFN, IBTYPE,IBP ROV,IBSEQ, IBT,IBT1,I BFUNC) ; E xtract IBT YPE id for the bill ; IBIFN = bill ien ( file 399) ; IBTYPE = 2:PERFORM ING PROVID ER ID (1 a nd 3 delet ed) ; IBSE Q = numeri c COB sequ ence of th e insuranc e on bill ; IBFUNC = 1:REFERRI NG;2:OPERA TING;3:REN DERING;4:A TTENDING;5 :SUPERVISI NG; 6:ASSI STANT SURG EON;9:OTHE R; ; Retur ns IBT = i en of the provider i d type^ien of entry^ file # for id ; S IB T=0 Q:IBTY PE'=2 "" N IBID,IBPT YP S IBID= $$IDFIND(I BIFN,"",IB PROV,IBSEQ ,1,.IBT,$G (IBFUNC)) I IBID="" S IBT="" ; Q IBID ;I DFIND(IBIF N,IBPTYP,I BPROV,IBSE Q,IBPERF,I BT,IBFUNC) ;Loop thr u source l evels ; (i f id defin ition allo ws) to fin d correct ID ; IBIFN = bill ie n (file 39 9) ; IBPTY P = ien of the provi der id typ e in file 355.97 or if null, ; the defau lt perform ing provid er ID type for the i ns co. in ; COB sequ ence IBSEQ will be c alculated ; IBPROV = (variable pointer s yntax) pro vider on b ill IBIFN ; IBSEQ = numeric CO B sequence of the bi ll ; IBPER F = 1 if t he perform ing provid er id is n eeded ; IB FUNC = 1:R EFERRING;2 :OPERATING ;3:RENDERI NG;4:ATTEN DING;5:SUP ERVISING;9 :OTHER; ; Returns IB T = ptr to file 355. 97^entry # ^file # ; S IBT=+$G( IBPTYP) Q: '$G(IBPERF )!'$G(IBPR OV) "" N I BSPEC,IBIN S,IBINS4,I BSRC,IBUP, IBID,IBALT ,IBPROF,Z I $G(IBSEQ )="" S IBS EQ=+$$COBN ^IBCEF(IBI FN) ; Defa ult to cur rent COB s eq S IBINS =+$P($G(^D GCR(399,IB IFN,"I"_IB SEQ)),U),I BINS4=$G(^ DIC(36,+IB INS,4)) ;J RA IB*2.0* 592 Same l ogic for D ental Form 7 as for CMS-1500 ; S IBPROF=( $$FT^IBCEF (IBIFN)=2) S:'IBPROF IBPROF=2 ;JRA IB*2. 0*592 ';' N FT S FT= $$FT^IBCEF (IBIFN) ;J RA IB*2.0* 592 Added 'FT' S IBP ROF=(FT=2! (FT=7)) S: 'IBPROF IB PROF=2 ;JR A IB*2.0*5 92 ; form type is CM S-1500 (pr of)=1, UB- 04 (inst)= 2 ;JWS;IB* 2.0*592; I $G(IBPTYP )="",FT=7, $G(IBFUNC) =1,IBPROF= 1 S (IBT,I BPTYP)=+$P (IBINS4,U, 15) ;Refer ring Defau lt ID on J 430D I $G( IBPTYP)="" ,$G(IBFUNC )=1,IBPROF =1 S (IBT, IBPTYP)=+$ P(IBINS4,U ,4) ; Refe rring Defa ult ID on CMS-1500 I $G(IBPTYP )="" S (IB T,IBPTYP)= +$P(IBINS4 ,U,IBPROF) ; Def to perf prv t yp for for m I 'IBPTY P Q "" ; No default id type S IBSPEC=$G (^IBE(355. 97,IBPTYP, 1)),IBSRC= $P($G(^IBE (355.97,+I BPTYP,0)), U,2),IBSRC =$S('IBSRC :5,1:IBSRC ),IBUP=1 S IBALT=0 ; F D Q:' IBUP!($G(I BID)'="") S IBSRC=IB SRC-1 Q:'I BSRC . ; . I IBSRC=1 ,$TR($P(IB SPEC,U,1,3 ),"^0")'=" " D Q ; Indiv prov default . . N IBSTAT E .. I $P( IBSPEC,U,2 ) D Q ; Federal DE A # from f ield 53.2 file 200 . .. S IBID= $P($G(^VA( 200,+IBPRO V,"PS")),U ,2) ; DBIA 224 ... S $P(IBT,U,2 ,3)=(IBPRO V_U_200) . . S IBSTAT E=+$$CARES T^IBCEP2A( IBIFN) .. I $P(IBSPE C,U) D Q ; State i ssued DEA # needed . .. Q:'IBST ATE ... ; Extract th e state is suing DEA # from fie ld 54.2 fi le 200 ... S Z=+$O(^ VA(200,+IB PROV,"PS2" ,"B",IBSTA TE,0)),IBI D=$P($G(^V A(200,+IBP ROV,"PS2", Z,0)),U,2) ; DBIA224 ... S $P( IBT,U,2,3) =(+IBPROV_ ";"_Z_U_20 0) .. I $P (IBSPEC,U, 3) D Q ; State lic ense # nee ded ... Q: 'IBSTATE . .. ; Extra ct the sta te license # from fi eld 54.1 f ile 200 .. . I IBPROV ["VA(200" S Z=+$O(^V A(200,+IBP ROV,"PS1", "B",IBSTAT E,0)),IBID =$P($G(^VA (200,+IBPR OV,"PS1",Z ,0)),U,2), $P(IBT,U,2 ,3)=(+IBPR OV_";"_IBS TATE_U_200 ) ; DBIA22 4 ... I IB PROV["IBA( 355.93" S IBID=$P($G (^IBA(355. 93,+IBPROV ,0)),U,12) ,$P(IBT,U, 2,3)=(+IBP ROV_U_355. 93) . ; . I IBSRC=2, $P(IBSPEC, U,4) D Q ; FACILIT Y FED TAX ID # .. N IBXDATA .. D F^IBCEF ("N-FEDERA L TAX ID", ,,IBIFN) . . S IBID=I BXDATA,$P( IBT,U,2,3) =(U_350.9) . ; . I I BSRC=1 S I BID=$$SRC1 (IBIFN,"*A LL*",IBPTY P,IBPROV,. IBT) Q . ; . I IBSRC =2 S IBID= $$SRC2(IBP TYP,.IBT) Q . ; . I IBSRC=3 S IBID=$$SRC 3(IBIFN,IB INS,IBPTYP ,.IBT) Q . ; . I IB SRC=4 S IB ID=$$SRC4( IBIFN,IBIN S,IBPTYP,I BPROV,.IBT ) Q . ; . I IBSRC=5 S IBID=$$S RC5(IBIFN, IBINS,IBPT YP,IBSEQ,. IBT,$G(IBF UNC)) Q . ; . I IBSR C=6 S IBID =$$SRC6(IB IFN,IBINS, IBPTYP,IBP ROV,IBSEQ, .IBT) Q ; Q $G(IBID) ;GETALL(I BTYPE,IBIF N,IBPROV,I BPID) ; Ex tract all performing prov id's for a ; p rovider (I BPROV - vp format) o n bill IBI FN ; IBTYP E = type o f ID to re turn (see GETID abov e) ; ; Ret urns array IBPID(COB SEQ #)=id (pass by reference) AND ; IBP ID(COB SEQ #,1)=ien of id type (ptr to 3 55.97) ; I BPID = cur rent insur ance co's id ; N Z,C OB,Z1,IBT S COB=$$CO BN^IBCEF(I BIFN) F Z= 1:1:3 Q:'$ D(^DGCR(39 9,IBIFN,"I "_Z)) S IB PID(Z)=$$G ETID(IBTYP E,IBIFN,IB PROV,Z,.IB T),IBPID(Z ,1)=IBT I Z=COB S Z1 =IBPID(Z) Q $G(Z1) ; SRC1(IBIFN ,IBINS,IBP TYP,IBPROV ,IBT) ; Li censing/go v't issued # - provi der specif ic ; Param eter defin itions for SRC1, SRC 3, SRC4, S RC5, SRC6: ; IBIFN = ien of bi ll (file 3 99) ; IBIN S = ien of insurance co (file 36) or *AL L* for all insurance ; (always *ALL* for SRC1) ; I BPTYP = ie n of the p rovider id type in f ile 355.97 ; IBPROV = (variabl e pointer syntax) pr ovider on bill IBIFN ; IBT = r eturned as type ien^ file ien^f ile # ; N IBID,IB,IB RX,IBIDSV S IBID="", IB=0,IBRX= $$ISRX^IBC EF1(IBIFN) ,IBIDSV="" I $G(IBPR OV) F S I B=$O(^IBA( 355.9,"AD" ,IBPTYP,IB PROV,IBINS ,IB)) Q:'I B D Q:IB ID'="" . S IBID=$$UN IQ1(IBIFN, IBINS,IBPT YP,IBPROV, "",IB) . I IBRX,$P($ G(^IBA(355 .9,IB,0)), U,5)'=3 S: IBIDSV="" IBIDSV=IBI D S IBID=" " ; Save 1 st 'match' if no rx specific i d I IBID=" ",IBIDSV'= "" S IBID= IBIDSV Q I BID ;SRC2( IB35597,IB T) ; Facil ity defaul t - all pr oviders ; IB35597 = ien of the provider id type en try in fil e 355.97 ; IBT = ret urned as t ype ien^fi le ien^fil e # ; S $P (IBT,U,2,3 )=(+IB3559 7_U_355.97 ) Q $P($G( ^IBE(355.9 7,+IB35597 ,0)),U,4) ;SRC3(IBIF N,IBINS,IB PTYP,IBT) ; Ins co/a ll provide rs ; See S RC1 for pa rameter de finitions N IB,IBID, IBRX,IBIDS V S IBID=" ",IB=0,IBR X=$$ISRX^I BCEF1(IBIF N),IBIDSV= "" F S IB =$O(^IBA(3 55.91,"AC" ,IBINS,IBP TYP,"*N/A* ",IB)) Q:' IB D Q:I BID'="" . S IBID=$$U NIQ2(IBIFN ,IBINS,IBP TYP,"",IB, .IBT) . I IBRX,$P($G (^IBA(355. 91,IB,0)), U,5)'=3 S: IBIDSV="" IBIDSV=IBI D S IBID=" " ; Save 1 st 'match' if no rx specific i d I IBID=" ",IBIDSV'= "" S IBID= IBIDSV Q I BID ;SRC4( IBIFN,IBIN S,IBPTYP,I BPROV,IBT) ; Insuran ce co/indi vidual pro vider ; Se e SRC1 for parameter definitio ns ; N IBI D,IB,IBRX, IBIDSV S I BID="",IB= 0,IBRX=$$I SRX^IBCEF1 (IBIFN),IB IDSV="" I $G(IBPROV) F S IB=$ O(^IBA(355 .9,"AD",IB PTYP,IBPRO V,IBINS,IB )) Q:'IB D Q:IBID' ="" . S IB ID=$$UNIQ1 (IBIFN,IBI NS,IBPTYP, IBPROV,"", IB,.IBT) . I IBRX,$P ($G(^IBA(3 55.9,IB,0) ),U,5)'=3 S:IBIDSV=" " IBIDSV=I BID S IBID ="" ; Save 1st 'matc h' if no r x specific id I IBID ="",IBIDSV '="" S IBI D=IBIDSV Q IBID ;SRC 5(IBIFN,IB INS,IBPTYP ,IBSEQ,IBT ,IBFUNC) ; Ins co/al l provider s/care uni t ; See SR C1 for mis sing param eter defin itions ; I BSEQ = the numeric C OB sequenc e of the i nsurance o n the bill ; Q "" ; DEM;432 - Pieces 9, 10, and 11 were dele ted in 200 6. So, cod e doesn't do anythin g other th an return NULL. N IB P,IBUNIT,I BID,IB,Z,I BIDSV,IBRX S IBID="" ,Z=0,IBRX= $$ISRX^IBC EF1(IBIFN) ,IBIDSV="" ; DEM;432 - IBLNPRV variable is a flag to indicat e if user input ; is claim lev el provide r or line level prov ider user input. ; D EM;432 - L ine provid er interes ted in fuc tion 1 and 3, referr ing and re ndering re spectively . I '$G(IB LNPRV) S I BP=+$O(^DG CR(399,IBI FN,"PRV"," B",$S($G(I BFUNC)=1:1 ,$$FT^IBCE F(IBIFN)=3 :4,1:3),0) ),IBUNIT=$ P($G(^DGCR (399,IBIFN ,"PRV",IBP ,0)),U,8+I BSEQ) I $G (IBLNPRV) S IBP=+$O( ^DGCR(399, IBIFN,"CP" ,IBLNPRV(" PROCIEN"), "LNPRV","B ",$S($G(IB FUNC)=1:1, 1:3),0)),I BUNIT=$P($ G(^DGCR(39 9,IBIFN,"C P",IBLNPRV ("PROCIEN" ),"LNPRV", IBP,0)),U, 8+IBSEQ) I IBUNIT'=" " F S Z=$ O(^IBA(355 .96,"AC",I BINS,IBPTY P,Z)) Q:'Z D Q:IBI D'="" . S IB=0 F S IB=$O(^IBA (355.91,"A CARE",Z,IB )) Q:'IB D Q:IBID' ="" .. S I BID=$$UNIQ 2(IBIFN,IB INS,IBPTYP ,IBUNIT,IB ,.IBT) .. I IBRX,$P( $G(^IBA(35 5.91,IB,0) ),U,5)'=3 S:IBIDSV=" " IBIDSV=I BID S IBID ="" ; Save 1st 'matc h' if no r x specific id I IBID ="",IBIDSV '="" S IBI D=IBIDSV Q IBID ;SRC 6(IBIFN,IB INS,IBPTYP ,IBPROV,IB SEQ,IBT) ; Ins co/in d provider /care unit ; See SRC 1 for miss ing parame ter defini tions ; IB SEQ = the numeric CO B sequence of the in surance on the bill ; Q "" ;D EM;432 - P ieces 9, 1 0, and 11 were delet ed in 2006 . So, code doesn't d o anything other tha n return N ULL. N IBU NIT,IBP,IB ID,IB S IB ID="",IB=0 I '$G(IBL NPRV) S IB P=+$O(^DGC R(399,"PRV ","B",$S($ $FT^IBCEF( IBIFN)=3:3 ,1:4),0)), IBUNIT=$P( $G(^DGCR(3 99,IBIFN," PRV",IBP,0 )),U,8+IBS EQ) I $G(I BLNPRV) S IBP=+$O(^D GCR(399,IB IFN,"CP",I BLNPRV("PR OCIEN"),"L NPRV","B", $S($$FT^IB CEF(IBIFN) =3:3,1:4), 0)),IBUNIT =$P($G(^DG CR(399,IBI FN,"CP",IB LNPRV("PRO CIEN"),"LN PRV",IBP,0 )),U,8+IBS EQ) I $G(I BPROV),IBU NIT'="" F S IB=$O(^ IBA(355.9, "AD",IBPTY P,IBPROV,I BINS,IB)) Q:'IB D Q:IBID'="" . S IBID= $$UNIQ1(IB IFN,IBINS, IBPTYP,IBP ROV,IBUNIT ,IB,.IBT) Q IBID ;UN IQ1(IBIFN, IBINS,IBPT YP,IBPROV, IBUNIT,IBC U,IBT) ; M atch most- least spec ific ; *** SEE PARAM ETER DEFIN ITIONS IN IBCEP3 *** ; ; Start in file 3 55.9 (Spec ific Provi der) ; IBP ROV = (var iable poin ter syntax ) provider on bill I BIFN ; Q $ $UNIQ1^IBC EP2A($G(IB IFN),$G(IB INS),$G(IB PTYP),$G(I BPROV),$G( IBUNIT),$G (IBCU),$G( IBT)) ;UNI Q2(IBIFN,I BINS,IBPTY P,IBUNIT,I BCU,IBT) ; Match on most-least specific ; *** SEE PARAMETER DEFINITION S IN IBCEP 3 *** ; ; Start in f ile 355.91 (Specific Insurance ) ; Q $$UN IQ2^IBCEP2 A($G(IBIFN ),$G(IBINS ),$G(IBPTY P),$G(IBUN IT),$G(IBC U),$G(IBT) ) | |
| 1925 | ||
| 1926 | ||
| 1927 | Routines | |
| 1928 | Activities | |
| 1929 | Routine Na me | |
| 1930 | IBCEP2B | |
| 1931 | Enhancemen t Category | |
| 1932 | New | |
| 1933 | Modify | |
| 1934 | Delete | |
| 1935 | No Change | |
| 1936 | RTM | |
| 1937 | ||
| 1938 | Related Op tions | |
| 1939 | None | |
| 1940 | Related Ro utines | |
| 1941 | Routines “ Called By” | |
| 1942 | Routines “ Called” | |
| 1943 | ||
| 1944 | ||
| 1945 | ||
| 1946 | ||
| 1947 | Data Dicti onary (DD) Reference s | |
| 1948 | ||
| 1949 | Related Pr otocols | |
| 1950 | None | |
| 1951 | Related In tegration Control Re gistration s (ICRs) | |
| 1952 | None | |
| 1953 | Data Passi ng | |
| 1954 | Input | |
| 1955 | Output Re ference | |
| 1956 | Both | |
| 1957 | Global Re ference | |
| 1958 | Local | |
| 1959 | Input Attr ibute Name and Defin ition | |
| 1960 | Name: | |
| 1961 | Definition : | |
| 1962 | Output Att ribute Nam e and Defi nition | |
| 1963 | Name: | |
| 1964 | Definition : | |
| 1965 | Current Lo gic | |
| 1966 | IBCEP2B ;A LB/TMP - E DI UTILITI ES for pro vider ID ; 18-MAY-04 ;;2.0;INTE GRATED BIL LING;**232 ,320,400,4 32**;21-MA R-94;Build 192 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . ;PROVID( IBIFN,IBPR IEN,IBCOBN ,DIPA) ; P rovider id entry on billing sc reen 10, a nd line le vel provid er input o n billing screens 4& 5. ; IBIFN = ien fil e 399 ; IB PRIEN = ie n file 399 .0222, or ien file 3 99.0404. ; IBCOBN = the COB nu mber of th e id being edited ; DIPA = pas sed by ref , returned with id d ata ; DIPA ("EDIT")=- 1 if no id editing = 1 if edit id = 2 if stuff id ; DIPA("PR ID")= id t o stuff DI PA("PRIDT" )= id type to stuff N PRN0,Z Q :'$G(^DGCR (399,IBIFN ,"I1")) I $G(IBLNPRV ),'$G(IBLN PRV("LNPRV IEN")),'$G (IBLNPRV(" PROCIEN")) Q ; DEM; 432 - If l ine provid er user in put. ; DEM ;432 - Upd ated varia ble PRNO t o be equal to line l evel provi der if we are coming from line level pro vider user input. S PRN0=$S($G (IBLNPRV): $G(^DGCR(3 99,IBIFN," CP",IBLNPR V("PROCIEN "),"LNPRV" ,IBLNPRV(" LNPRVIEN") ,0)),1:$G( ^DGCR(399, IBIFN,"PRV ",IBPRIEN, 0))) S DIP A("EDIT")= 1,(DIPA("P RID"),DIPA ("PRIDT")) ="" W @IOF W !,?19," **** SECON DARY PERFO RMING PROV IDER IDs * ***" W !!, $P("PRIMAR Y^SECONDAR Y^TERTIARY ",U,IBCOBN )_" INSURA NCE CO: "_ $P($G(^DIC (36,+$G(^D GCR(399,IB IFN,"I"_IB COBN)),0)) ,U) ; DEM; 432 - Adde d line and condition s if line level prov ider user input. I ' $G(IBLNPRV ) W !,"PRO VIDER: "_$ $EXTERNAL^ DILFD(399. 0222,.02," ",$P(PRN0, U,2))_" (" _$$EXTERNA L^DILFD(39 9.0222,.01 ,"",+PRN0) _")",! I $ G(IBLNPRV) W !,"Line Level Pro vider: "_$ $EXTERNAL^ DILFD(399. 0404,.02," ",$P(PRN0, U,2))_" (" _$$EXTERNA L^DILFD(39 9.0404,.01 ,"",+PRN0) _")",! ; I $P(PRN0,U ,4+IBCOBN) ="" K DIPA ("PRID"),D IPA("PRIDT ") D NEWID (IBIFN,IBP RIEN,IBCOB N,.DIPA) ; No id cur rently exi sts for th e ins seq/ prov ; Q ; NEWID(IBIF N,IBPRIEN, IBCOBN,DIP A) ; N IBD EF,IBCT,IB NUM,IBINS, IBFRM,IBCA R,IBARR,IB ARRS,IB0,I BM,IBQUIT, IBSEL,PRN, PRT,PRN,PR N0,DIR,X,Y ,Z,Z0,IBZ, IBZ1,IBTYP ,IBREQ,IBR EQT,IBTYPN ,IBID,IBUS ED S IBREQ =0,IBREQT= "" Q:($G(I BLNPRV))&( '$G(IBLNPR V("LNPRVIE N"))&'$G(I BLNPRV("PR OCIEN"))) ; DEM;432 - If line provider u ser input. ; DEM;432 - Updated variable PRNO to be equal to line level provider if we are coming fro m line lev el provide r user inp ut. S PRN0 =$S($G(IBL NPRV):$G(^ DGCR(399,I BIFN,"CP", IBLNPRV("P ROCIEN")," LNPRV",IBL NPRV("LNPR VIEN"),0)) ,1:$G(^DGC R(399,IBIF N,"PRV",IB PRIEN,0))) S Z(IBCOB N)=$S($G(D IPA("I"_IB COBN)):$$G ETTYP^IBCE P2A(IBIFN, IBCOBN,$P( PRN0,U)),1 :"") S IBI NS=+$G(^DG CR(399,IBI FN,"I"_IBC OBN)),IB0= $S($G(IBLN PRV):$G(^D GCR(399,IB IFN,"CP",I BLNPRV("PR OCIEN"),"L NPRV",IBLN PRV("LNPRV IEN"),0)), 1:$G(^DGCR (399,IBIFN ,"PRV",IBP RIEN,0))) S IBCAR=$$ INPAT^IBCE F(IBIFN),I BCAR=$S('I BCAR:2,1:1 ) S IBFRM= $$FT^IBCEF (IBIFN),IB FRM=$S(IBF RM=2:2,1:1 ) I $P(Z(I BCOBN),U) D . W !,"I NS. COMPAN Y'S DEFAUL T SECONDAR Y ID TYPE IS: "_$$EX TERNAL^DIL FD(36,4.01 ,"",$P(Z(I BCOBN),U)) S IBREQT= +Z(IBCOBN) . I $P(Z( IBCOBN),U, 2) W !,?2, " AND IS R EQUIRED TO BE ENTERE D FOR THIS CLAIM" S IBREQ=1 I $$CUNEED^I BCEP3(IBIF N,IBCOBN) W !,"CARE UNITS ARE DEFINED"_$ S($P($G(^D IC(36,IBIN S,4)),U,9) '="":" AS "_$P(^(4), U,9),1:"") _" FOR THE SE IDs" D PRACT^IBCE F71(IBINS, IBFRM,IBCA R,$P(IB0,U ,2),.IBARR ,$P(IB0,U) ,$S($$COBN ^IBCEF(IBI FN)=IBCOBN :"C",1:"O" ),355.9,1) S (IBNUM, IBCT)=0,IB DEF="" I $ O(IBARR("" ))="" S IB CT=IBCT+1, DIR("A",IB CT)="NO SE CONDARY ID S ARE DEFI NED FOR TH IS PROV TH AT ARE VAL ID FOR THI S CLAIM" S IBCT=IBCT +1,DIR("A" ,IBCT)="SE LECT A SEC ONDARY ID OR ACTION FROM THE L IST BELOW: ",IBCT=IB CT+1,DIR(" A",IBCT)=" " ; S IBC T=IBCT+1,I BNUM=IBNUM +1,DIR("A" ,IBCT)=" " _$E(IBNUM_ $J("",3),1 ,3)_" - NO SECONDARY ID NEEDED ",IBNUM=IB NUM+1,IBCT =IBCT+1,DI R("A",IBCT )=" "_$E(I BNUM_$J("" ,3),1,3)_" - ADD AN ID FOR THI S CLAIM ON LY" I $O(I BARR(""))= "" S IBDEF =1,DIPA("E DIT")=$$SE LID(.DIR,I BDEF,.IBID ,.DIPA,IBN UM) Q ; S PRN=$$GETI D^IBCEP2(I BIFN,2,$P( PRN0,U,2), IBCOBN,.PR T,,$P(PRN0 ,U)),IBDEF ="" ; I PR N'="",PRT D . N PRT1 . S PRT1= $P($G(^IBE (355.97,+P RT,0)),U) . I $P($G( ^IBE(355.9 7,+PRT,1)) ,U,3) S PR T1="ST LIC ("_$P($G(^ DIC(5,+$$C AREST^IBCE P2A(IBIFN) ,0)),U,2)_ ")" . S IB CT=IBCT+1, IBNUM=IBNU M+1 . S DI R("A",IBCT )=" "_$E(I BNUM_$J("" ,3),1,3)_" - "_$E("< DEFAULT> " _PRN_$J("" ,29),1,29) _" "_$E(PR T1_$J("",1 5),1,15) . S DIR("A" ,IBCT)=DIR ("A",IBCT) _" "_$S($P (PRT,U,3)' ["355.9":" ",$P($G(^I BA(+$P(PRT ,U,3),+$P( PRT,U,2),0 )),U,3)'=" ":$$EXTERN AL^DILFD(3 55.9,.03," ",$P($G(^I BA(+$P(PRT ,U,3),+$P( PRT,U,2),0 )),U,3)),1 :"") . S I BID(IBNUM) =PRN_U_+PR T,IBDEF=IB NUM,IBID(I BNUM,1)=DI R("A",IBCT ),IBDEF=IB NUM,IBDEF( "IEN")=$P( PRT,U,2,3) . S IBUSE D(PRT,PRN, 0)="" ; S IBQUIT=0,I BSEL=1 ; S ort ids by id type S IBZ="" F S IBZ=$O( IBARR(IBZ) ) Q:IBZ="" S IBZ1=" " F S IBZ 1=$O(IBARR (IBZ,IBZ1) ) Q:IBZ1=" " D . S I BTYP=+$P(I BARR(IBZ,I BZ1),U,9) . I $P(IBA RR(IBZ,IBZ 1),U,4)]"" Q:$D(IBUS ED(IBTYP,$ P(IBARR(IB Z,IBZ1),U, 4),+$P(IBA RR(IBZ,IBZ 1),U,7))) . I $P($G( IBDEF("IEN ")),U,2)[" 355.9",$P( IBARR(IBZ, IBZ1),U,8) ,$P(IBARR( IBZ,IBZ1), U,8)=+$G(I BDEF("IEN" )) Q:$S($P (IBZ1,U)'[ "INS DEF": $P($G(IBDE F("IEN")), U,2)=355.9 ,1:$P($G(I BDEF("IEN" )),U,2)=35 5.91) . S IBARRS(IBT YP,IBZ,IBZ 1)=IBARR(I BZ,IBZ1) . I $P(IBAR R(IBZ,IBZ1 ),U,4)]"" S IBUSED(I BTYP,$P(IB ARR(IBZ,IB Z1),U,4),+ $P(IBARR(I BZ,IBZ1),U ,7))="" S IBTYP="" F S IBTYP= $O(IBARRS( IBTYP)) Q: IBTYP="" S IBZ="" F S IBZ=$O (IBARRS(IB TYP,IBZ)) Q:IBZ="" D Q:IBQUI T . S IBZ1 ="" F S I BZ1=$O(IBA RRS(IBTYP, IBZ,IBZ1)) Q:IBZ1="" S IBCT=I BCT+1,IBNU M=IBNUM+1 D Q:IBQUI T .. S Z0= IBARRS(IBT YP,IBZ,IBZ 1) .. S IB ARR=$S($P( Z0,U,8)&(I BZ1'["LIC" ):$G(^IBA( "355.9"_$S ($P(IBZ1,U )'="INS DE F":"",1:1) ,+$P(Z0,U, 8),0)),1:" ") .. S IB TYPN=$S(IB TYP=+$$STL IC^IBCEP8( ):"ST LIC ("_$P($G(^ DIC(5,+$P( Z0,U,7),0) ),U,2)_")" ,1:$P($G(^ IBE(355.97 ,IBTYP,0)) ,U)) .. S DIR("A",IB CT)=" "_$E (IBNUM_$J( "",3),1,3) _" - "_$E( $S($P(IBZ1 ,U)="INS D EF":"<INS DEF> ",1:" ")_$P(Z0,U ,4)_$J("", 29),1,29)_ " "_$E(IBT YPN_$J("", 15),1,15)_ " "_$S($P( IBARR,U,3) :$$EXTERNA L^DILFD(35 5.9,.03,"" ,$P(IBARR, U,3)),1:"" ) .. S IBI D(IBNUM,1) =DIR("A",I BCT),IBID( IBNUM)=$P( Z0,U,4)_U_ IBTYP .. I (IBNUM#15 )=0 S IBM= $$MORE(.DI R) D Q:IB QUIT ... I IBM<0 S I BQUIT=1,IB SEL=0 Q ; User abor ted list . .. I 'IBM S IBQUIT=1 Q ; User wants to select ... W ! K DIR S IBCT=1 I 'IBSEL S DIPA("EDI T")=-1 I I BSEL S:IBD EF=""&$G(I BREQ) IBDE F=2 S DIPA ("EDIT")=$ $SELID(.DI R,IBDEF,.I BID,.DIPA, IBNUM) Q ; SELID(DIR, IBDEF,IBID ,DIPA,IBNU M) ; Retur ns the sel ection fro m the arra y of possi ble IDs/ID actions N IDACT,IDS EL,X,Y S I DACT="" S DIR("B")=$ S('$G(IBDE F):1,1:IBD EF),DIR("A ",+$O(DIR( "A",""),-1 )+1)=" " S DIR(0)="N A^1:"_IBNU M,DIR("A") ="Selectio n: " W ! D ^DIR K DI R I $D(DTO UT)!$D(DUO UT)!(Y=1) S IDACT=-1 G SELIDQ I Y=2 S ID ACT=1 G SE LIDQ S IDS EL=Y S DIR ("A",1)="I D SELECTED :",DIR("A" ,2)=" "_$G (IBID(+Y,1 )),DIR("A" )="IS THIS CORRECT?: ",DIR("B" )="YES",DI R(0)="YA" W ! D ^DIR K DIR I Y '=1 S IDAC T=-1 G SEL IDQ S DIPA ("PRID")=$ P(IBID(IDS EL),U),DIP A("PRIDT") =$P(IBID(I DSEL),U,2) ,IDACT=2 ; SELIDQ Q I DACT ;MORE (DIR) ; N DIR,X,Y,DU OUT,DTOUT S DIR(0)=" YA",DIR("A ")="MORE?: ",DIR("B" )="NO" W ! D ^DIR K DIR("B") Q $S($D(DTO UT)!$D(DUO UT):-1,1:Y ) ; ; IBFI DFL = E = Electronic Form Type ; A = Add itional ID 's ; LF - VA Lab/Fac ilityFACID (IBINS,IBF IDFL) ; En ter/edit b illing fac ility ids ; IBINS = ien of ins co (file 36) N IBID ,Z,Z0,Y K ^TMP($J,"I BBF_ID") W @IOF D GE TBPNUM(IBI NS) K ^TMP ("IBCE_PRV FAC_MAINT_ INS",$J) S ^TMP("IBC E_PRVFAC_M AINT_INS", $J)=IBFIDF L_U_IBINS_ U_"1" D EN ^VALM("IBC E PRVFAC M AINT") K ^ TMP("IBCE_ PRVFAC_MAI NT_INS",$J ) W @IOF D FULL^VALM 1 Q ;GETBP NUM(IBINS) ; N Z,Z0, IBID,IBMAI N S IBMAIN =$$MAIN(), ^TMP($J,"I BBF_ID")=I BMAIN S IB ID=$$BF^IB CU() S Z=0 F S Z=$O (^IBA(355. 92,"B",IBI NS,Z)) Q:' Z D . S Z 0=$G(^IBA( 355.92,Z,0 )) . Q:$P( Z0,U,8)'=" E" ; WCJ 1/13/06 Th ere are se veral ID t ypes in th is file . Q:$P(Z0,U ,3)]"" . S ^TMP($J," IBBF_ID",$ S($P(Z0,U, 5)=IBMAIN: 0,1:+$P(Z0 ,U,5)),+$P (Z0,U,4))= $P(Z0,U,7) . S ^TMP( $J,"IBBF_I D",$S($P(Z 0,U,5)=IBM AIN:0,1:+$ P(Z0,U,5)) ,+$P(Z0,U, 4),"QUAL") =$P(Z0,U,6 ) Q ;MAIN( ) ; Return s ien of m ain divisi on of the database Q +$$PRIM^V ASITE() ;F ACNUM(IBIF N,IBCOB,IB QF) ; Func tion retur ns the cur rent divis ion's fac billing ; prov id fo r the COB insurance sequence f rom file 3 55.92 ; IB IFN = ien file 399 ; IBCOB = # of COB in s seq or i f "", curr ent assume d ; IBQF - 1 if qual ifier is t o be retur ned instea d of ID N Z,IBDIV,IB FT,X,BPZ S X="",IBDI V=0 S:'$G( IBCOB) IBC OB=+$$COBN ^IBCEF(IBI FN) ; ; IB *2*400 - e sg - 11/7/ 08 - Deter mine the d ivision as sociated w ith the bi lling prov ider first S BPZ=+$$ B^IBCEF79( IBIFN,IBCO B) ; Inst file point er as the billing pr ovider for payer seq IBCOB I B PZ S IBDIV =+$O(^DG(4 0.8,"AD",B PZ,0)) ; B illing Pro vider divi sion (may not exist) ; I 'IBDI V S IBDIV= +$P($G(^DG CR(399,IBI FN,0)),U,2 2) ; Divis ion on cla im I 'IBDI V S IBDIV= $$MAIN() ; main divi sion ; S I BFT=$$FT^I BCEF(IBIFN ),IBFT=$S( IBFT=3:1,1 :2) K ^TMP ($J,"IBBF_ ID") D GET BPNUM(+$P( $G(^DGCR(3 99,IBIFN," M")),U,IBC OB)) I IBD IV=+$G(^TM P($J,"IBBF _ID")) S I BDIV=0 I ' $G(IBQF) S X=$S($D(^ TMP($J,"IB BF_ID",IBD IV,IBFT)): ^(IBFT),1: $G(^TMP($J ,"IBBF_ID" ,0,IBFT))) I $G(IBQF ) S X=$S($ D(^TMP($J, "IBBF_ID", IBDIV,IBFT ,"QUAL")): ^("QUAL"), 1:$G(^TMP( $J,"IBBF_I D",0,IBFT, "QUAL"))) K ^TMP($J, "IBBF_ID") Q X ;SOP( IBIFN,IBZD ) ; Return s X12 curr ent source of pay co de for bil l ien IBIF N ; IBZD = the curre nt ins pol icy type, if known N IBZ S IBZ ="" I $G(I BZD)="" D F^IBCEF("N -CURRENT I NS POLICY TYPE","IBZ D",,IBIFN) S IBZ=$S( $G(IBZD)=" ":"G2","MA MB16"[IBZD :"1C",IBZD ="TV"!(IBZ D="MC"):"1 D",IBZD="C H":"1H",IB ZD="BL":$S ($$FT^IBCE F(IBIFN)=2 :"1B",1:"1 A"),1:"G2" ) Q IBZ ; | |
| 1967 | Modified L ogic (Chan ges are in bold) | |
| 1968 | IBCEP2B ;A LB/TMP - E DI UTILITI ES for pro vider ID ; 18-MAY-04 ;;2.0;INTE GRATED BIL LING;**232 ,320,400,4 32,592**;2 1-MAR-94;B uild 192 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ;PRO VID(IBIFN, IBPRIEN,IB COBN,DIPA) ; Provide r id entry on billin g screen 1 0, and lin e level pr ovider inp ut on bill ing screen s 4&5. ; I BIFN = ien file 399 ; IBPRIEN = ien file 399.0222, or ien fi le 399.040 4. ; IBCOB N = the CO B number o f the id b eing edite d ; DIPA = passed by ref, retu rned with id data ; DIPA("EDIT ")=-1 if n o id editi ng = 1 if edit id = 2 if stuff id ; DIPA ("PRID")= id to stuf f DIPA("PR IDT")= id type to st uff N PRN0 ,Z Q:'$G(^ DGCR(399,I BIFN,"I1") ) I $G(IBL NPRV),'$G( IBLNPRV("L NPRVIEN")) ,'$G(IBLNP RV("PROCIE N")) Q ; DEM;432 - If line pr ovider use r input. ; DEM;432 - Updated v ariable PR NO to be e qual to li ne level p rovider if we are co ming from line level provider user input . S PRN0=$ S($G(IBLNP RV):$G(^DG CR(399,IBI FN,"CP",IB LNPRV("PRO CIEN"),"LN PRV",IBLNP RV("LNPRVI EN"),0)),1 :$G(^DGCR( 399,IBIFN, "PRV",IBPR IEN,0))) S DIPA("EDI T")=1,(DIP A("PRID"), DIPA("PRID T"))="" W @IOF W !,? 19,"**** S ECONDARY P ERFORMING PROVIDER I Ds ****" W !!,$P("PR IMARY^SECO NDARY^TERT IARY",U,IB COBN)_" IN SURANCE CO : "_$P($G( ^DIC(36,+$ G(^DGCR(39 9,IBIFN,"I "_IBCOBN)) ,0)),U) ; DEM;432 - Added line and condi tions if l ine level provider u ser input. I '$G(IBL NPRV) W !, "PROVIDER: "_$$EXTER NAL^DILFD( 399.0222,. 02,"",$P(P RN0,U,2))_ " ("_$$EXT ERNAL^DILF D(399.0222 ,.01,"",+P RN0)_")",! I $G(IBLN PRV) W !," Line Level Provider: "_$$EXTER NAL^DILFD( 399.0404,. 02,"",$P(P RN0,U,2))_ " ("_$$EXT ERNAL^DILF D(399.0404 ,.01,"",+P RN0)_")",! ; I $P(PR N0,U,4+IBC OBN)="" K DIPA("PRID "),DIPA("P RIDT") D N EWID(IBIFN ,IBPRIEN,I BCOBN,.DIP A) ; No id currently exists fo r the ins seq/prov ; Q ;NEWID( IBIFN,IBPR IEN,IBCOBN ,DIPA) ; N IBDEF,IBC T,IBNUM,IB INS,IBFRM, IBCAR,IBAR R,IBARRS,I B0,IBM,IBQ UIT,IBSEL, PRN,PRT,PR N,PRN0,DIR ,X,Y,Z,Z0, IBZ,IBZ1,I BTYP,IBREQ ,IBREQT,IB TYPN,IBID, IBUSED S I BREQ=0,IBR EQT="" Q:( $G(IBLNPRV ))&('$G(IB LNPRV("LNP RVIEN"))&' $G(IBLNPRV ("PROCIEN" ))) ; DEM; 432 - If l ine provid er user in put. ; DEM ;432 - Upd ated varia ble PRNO t o be equal to line l evel provi der if we are coming from line level pro vider user input. S PRN0=$S($G (IBLNPRV): $G(^DGCR(3 99,IBIFN," CP",IBLNPR V("PROCIEN "),"LNPRV" ,IBLNPRV(" LNPRVIEN") ,0)),1:$G( ^DGCR(399, IBIFN,"PRV ",IBPRIEN, 0))) S Z(I BCOBN)=$S( $G(DIPA("I "_IBCOBN)) :$$GETTYP^ IBCEP2A(IB IFN,IBCOBN ,$P(PRN0,U )),1:"") S IBINS=+$G (^DGCR(399 ,IBIFN,"I" _IBCOBN)), IB0=$S($G( IBLNPRV):$ G(^DGCR(39 9,IBIFN,"C P",IBLNPRV ("PROCIEN" ),"LNPRV", IBLNPRV("L NPRVIEN"), 0)),1:$G(^ DGCR(399,I BIFN,"PRV" ,IBPRIEN,0 ))) S IBCA R=$$INPAT^ IBCEF(IBIF N),IBCAR=$ S('IBCAR:2 ,1:1) ;JRA IB*2.0*59 2 Same log ic for Den tal Form 7 as for CM S-1500 ;S IBFRM=$$FT ^IBCEF(IBI FN),IBFRM= $S(IBFRM=2 :2,1:1) ;J RA IB*2.0* 592 ';' S IBFRM=$$FT ^IBCEF(IBI FN),IBFRM= $S(IBFRM=2 :2,IBFRM=7 :4,1:1) ;J WS;JRA IB* 2.0*592 I $P(Z(IBCOB N),U) D . W !,"INS. COMPANY'S DEFAULT SE CONDARY ID TYPE IS: "_$$EXTERN AL^DILFD(3 6,4.01,"", $P(Z(IBCOB N),U)) S I BREQT=+Z(I BCOBN) . I $P(Z(IBCO BN),U,2) W !,?2," AN D IS REQUI RED TO BE ENTERED FO R THIS CLA IM" S IBRE Q=1 I $$CU NEED^IBCEP 3(IBIFN,IB COBN) W !, "CARE UNIT S ARE DEFI NED"_$S($P ($G(^DIC(3 6,IBINS,4) ),U,9)'="" :" AS "_$P (^(4),U,9) ,1:"")_" F OR THESE I Ds" D PRAC T^IBCEF71( IBINS,IBFR M,IBCAR,$P (IB0,U,2), .IBARR,$P( IB0,U),$S( $$COBN^IBC EF(IBIFN)= IBCOBN:"C" ,1:"O"),35 5.9,1) S ( IBNUM,IBCT )=0,IBDEF= "" I $O(IB ARR(""))=" " S IBCT=I BCT+1,DIR( "A",IBCT)= "NO SECOND ARY IDS AR E DEFINED FOR THIS P ROV THAT A RE VALID F OR THIS CL AIM" S IBC T=IBCT+1,D IR("A",IBC T)="SELECT A SECONDA RY ID OR A CTION FROM THE LIST BELOW: ",I BCT=IBCT+1 ,DIR("A",I BCT)=" " ; S IBCT=IB CT+1,IBNUM =IBNUM+1,D IR("A",IBC T)=" "_$E( IBNUM_$J(" ",3),1,3)_ " - NO SEC ONDARY ID NEEDED",IB NUM=IBNUM+ 1,IBCT=IBC T+1,DIR("A ",IBCT)=" "_$E(IBNUM _$J("",3), 1,3)_" - A DD AN ID F OR THIS CL AIM ONLY" I $O(IBARR (""))="" S IBDEF=1,D IPA("EDIT" )=$$SELID( .DIR,IBDEF ,.IBID,.DI PA,IBNUM) Q ; S PRN= $$GETID^IB CEP2(IBIFN ,2,$P(PRN0 ,U,2),IBCO BN,.PRT,,$ P(PRN0,U)) ,IBDEF="" ; I PRN'=" ",PRT D . N PRT1 . S PRT1=$P($ G(^IBE(355 .97,+PRT,0 )),U) . I $P($G(^IBE (355.97,+P RT,1)),U,3 ) S PRT1=" ST LIC("_$ P($G(^DIC( 5,+$$CARES T^IBCEP2A( IBIFN),0)) ,U,2)_")" . S IBCT=I BCT+1,IBNU M=IBNUM+1 . S DIR("A ",IBCT)=" "_$E(IBNUM _$J("",3), 1,3)_" - " _$E("<DEFA ULT> "_PRN _$J("",29) ,1,29)_" " _$E(PRT1_$ J("",15),1 ,15) . S D IR("A",IBC T)=DIR("A" ,IBCT)_" " _$S($P(PRT ,U,3)'["35 5.9":"",$P ($G(^IBA(+ $P(PRT,U,3 ),+$P(PRT, U,2),0)),U ,3)'="":$$ EXTERNAL^D ILFD(355.9 ,.03,"",$P ($G(^IBA(+ $P(PRT,U,3 ),+$P(PRT, U,2),0)),U ,3)),1:"") . S IBID( IBNUM)=PRN _U_+PRT,IB DEF=IBNUM, IBID(IBNUM ,1)=DIR("A ",IBCT),IB DEF=IBNUM, IBDEF("IEN ")=$P(PRT, U,2,3) . S IBUSED(PR T,PRN,0)=" " ; S IBQU IT=0,IBSEL =1 ; Sort ids by id type S IBZ ="" F S I BZ=$O(IBAR R(IBZ)) Q: IBZ="" S IBZ1="" F S IBZ1=$O (IBARR(IBZ ,IBZ1)) Q: IBZ1="" D . S IBTYP =+$P(IBARR (IBZ,IBZ1) ,U,9) . I $P(IBARR(I BZ,IBZ1),U ,4)]"" Q:$ D(IBUSED(I BTYP,$P(IB ARR(IBZ,IB Z1),U,4),+ $P(IBARR(I BZ,IBZ1),U ,7))) . I $P($G(IBDE F("IEN")), U,2)["355. 9",$P(IBAR R(IBZ,IBZ1 ),U,8),$P( IBARR(IBZ, IBZ1),U,8) =+$G(IBDEF ("IEN")) Q :$S($P(IBZ 1,U)'["INS DEF":$P($ G(IBDEF("I EN")),U,2) =355.9,1:$ P($G(IBDEF ("IEN")),U ,2)=355.91 ) . S IBAR RS(IBTYP,I BZ,IBZ1)=I BARR(IBZ,I BZ1) . I $ P(IBARR(IB Z,IBZ1),U, 4)]"" S IB USED(IBTYP ,$P(IBARR( IBZ,IBZ1), U,4),+$P(I BARR(IBZ,I BZ1),U,7)) ="" S IBTY P="" F S IBTYP=$O(I BARRS(IBTY P)) Q:IBTY P="" S IB Z="" F S IBZ=$O(IBA RRS(IBTYP, IBZ)) Q:IB Z="" D Q :IBQUIT . S IBZ1="" F S IBZ1= $O(IBARRS( IBTYP,IBZ, IBZ1)) Q:I BZ1="" S IBCT=IBCT+ 1,IBNUM=IB NUM+1 D Q :IBQUIT .. S Z0=IBAR RS(IBTYP,I BZ,IBZ1) . . S IBARR= $S($P(Z0,U ,8)&(IBZ1' ["LIC"):$G (^IBA("355 .9"_$S($P( IBZ1,U)'=" INS DEF":" ",1:1),+$P (Z0,U,8),0 )),1:"") . . S IBTYPN =$S(IBTYP= +$$STLIC^I BCEP8():"S T LIC ("_$ P($G(^DIC( 5,+$P(Z0,U ,7),0)),U, 2)_")",1:$ P($G(^IBE( 355.97,IBT YP,0)),U)) .. S DIR( "A",IBCT)= " "_$E(IBN UM_$J("",3 ),1,3)_" - "_$E($S($ P(IBZ1,U)= "INS DEF": "<INS DEF> ",1:"")_$ P(Z0,U,4)_ $J("",29), 1,29)_" "_ $E(IBTYPN_ $J("",15), 1,15)_" "_ $S($P(IBAR R,U,3):$$E XTERNAL^DI LFD(355.9, .03,"",$P( IBARR,U,3) ),1:"") .. S IBID(IB NUM,1)=DIR ("A",IBCT) ,IBID(IBNU M)=$P(Z0,U ,4)_U_IBTY P .. I (IB NUM#15)=0 S IBM=$$MO RE(.DIR) D Q:IBQUIT ... I IBM <0 S IBQUI T=1,IBSEL= 0 Q ; Use r aborted list ... I 'IBM S IB QUIT=1 Q ; User wan ts to sele ct ... W ! K DIR S I BCT=1 I 'I BSEL S DIP A("EDIT")= -1 I IBSEL S:IBDEF=" "&$G(IBREQ ) IBDEF=2 S DIPA("ED IT")=$$SEL ID(.DIR,IB DEF,.IBID, .DIPA,IBNU M) Q ;SELI D(DIR,IBDE F,IBID,DIP A,IBNUM) ; Returns t he selecti on from th e array of possible IDs/ID act ions N IDA CT,IDSEL,X ,Y S IDACT ="" S DIR( "B")=$S('$ G(IBDEF):1 ,1:IBDEF), DIR("A",+$ O(DIR("A", ""),-1)+1) =" " S DIR (0)="NA^1: "_IBNUM,DI R("A")="Se lection: " W ! D ^DI R K DIR I $D(DTOUT)! $D(DUOUT)! (Y=1) S ID ACT=-1 G S ELIDQ I Y= 2 S IDACT= 1 G SELIDQ S IDSEL=Y S DIR("A" ,1)="ID SE LECTED:",D IR("A",2)= " "_$G(IBI D(+Y,1)),D IR("A")="I S THIS COR RECT?: ",D IR("B")="Y ES",DIR(0) ="YA" W ! D ^DIR K D IR I Y'=1 S IDACT=-1 G SELIDQ S DIPA("PR ID")=$P(IB ID(IDSEL), U),DIPA("P RIDT")=$P( IBID(IDSEL ),U,2),IDA CT=2 ;SELI DQ Q IDACT ;MORE(DIR ) ; N DIR, X,Y,DUOUT, DTOUT S DI R(0)="YA", DIR("A")=" MORE?: ",D IR("B")="N O" W ! D ^ DIR K DIR( "B") Q $S( $D(DTOUT)! $D(DUOUT): -1,1:Y) ; ; IBFIDFL = E = Elec tronic For m Type ; A = Additio nal ID's ; LF - VA L ab/Facilit yFACID(IBI NS,IBFIDFL ) ; Enter/ edit billi ng facilit y ids ; IB INS = ien of ins co (file 36) N IBID,Z,Z 0,Y K ^TMP ($J,"IBBF_ ID") W @IO F D GETBPN UM(IBINS) K ^TMP("IB CE_PRVFAC_ MAINT_INS" ,$J) S ^TM P("IBCE_PR VFAC_MAINT _INS",$J)= IBFIDFL_U_ IBINS_U_"1 " D EN^VAL M("IBCE PR VFAC MAINT ") K ^TMP( "IBCE_PRVF AC_MAINT_I NS",$J) W @IOF D FUL L^VALM1 Q ;GETBPNUM( IBINS) ; N Z,Z0,IBID ,IBMAIN S IBMAIN=$$M AIN(),^TMP ($J,"IBBF_ ID")=IBMAI N S IBID=$ $BF^IBCU() S Z=0 F S Z=$O(^IB A(355.92," B",IBINS,Z )) Q:'Z D . S Z0=$G (^IBA(355. 92,Z,0)) . Q:$P(Z0,U ,8)'="E" ; WCJ 1/13 /06 There are severa l ID types in this f ile . Q:$ P(Z0,U,3)] "" . S ^TM P($J,"IBBF _ID",$S($P (Z0,U,5)=I BMAIN:0,1: +$P(Z0,U,5 )),+$P(Z0, U,4))=$P(Z 0,U,7) . S ^TMP($J," IBBF_ID",$ S($P(Z0,U, 5)=IBMAIN: 0,1:+$P(Z0 ,U,5)),+$P (Z0,U,4)," QUAL")=$P( Z0,U,6) Q ;MAIN() ; Returns ie n of main division o f the data base Q +$$ PRIM^VASIT E() ;FACNU M(IBIFN,IB COB,IBQF) ; Function returns t he current division' s fac bill ing ; prov id for th e COB insu rance sequ ence from file 355.9 2 ; IBIFN = ien file 399 ; IBC OB = # of COB ins se q or if "" , current assumed ; IBQF - 1 i f qualifie r is to be returned instead of ID N Z,IB DIV,IBFT,X ,BPZ S X=" ",IBDIV=0 S:'$G(IBCO B) IBCOB=+ $$COBN^IBC EF(IBIFN) ; ; IB*2*4 00 - esg - 11/7/08 - Determine the divis ion associ ated with the billin g provider first S B PZ=+$$B^IB CEF79(IBIF N,IBCOB) ; Inst file pointer a s the bill ing provid er for pay er seq IBC OB I BPZ S IBDIV=+$O (^DG(40.8, "AD",BPZ,0 )) ; Billi ng Provide r division (may not exist) ; I 'IBDIV S IBDIV=+$P( $G(^DGCR(3 99,IBIFN,0 )),U,22) ; Division on claim I 'IBDIV S IBDIV=$$MA IN() ; mai n division ;JWS;IB*2 .0*592; S IBFT=$$FT^ IBCEF(IBIF N),IBFT=$S (IBFT=3:1, IBFT=7:4,1 :2) K ^TMP ($J,"IBBF_ ID") D GET BPNUM(+$P( $G(^DGCR(3 99,IBIFN," M")),U,IBC OB)) I IBD IV=+$G(^TM P($J,"IBBF _ID")) S I BDIV=0 I ' $G(IBQF) S X=$S($D(^ TMP($J,"IB BF_ID",IBD IV,IBFT)): ^(IBFT),1: $G(^TMP($J ,"IBBF_ID" ,0,IBFT))) I $G(IBQF ) S X=$S($ D(^TMP($J, "IBBF_ID", IBDIV,IBFT ,"QUAL")): ^("QUAL"), 1:$G(^TMP( $J,"IBBF_I D",0,IBFT, "QUAL"))) K ^TMP($J, "IBBF_ID") Q X ;SOP( IBIFN,IBZD ) ; Return s X12 curr ent source of pay co de for bil l ien IBIF N ; IBZD = the curre nt ins pol icy type, if known N IBZ,IBFT ;JRA IB*2 .0*592 Add ed 'IBFT' S IBZ="" I $G(IBZD)= "" D F^IBC EF("N-CURR ENT INS PO LICY TYPE" ,"IBZD",,I BIFN) S IB FT=$$FT^IB CEF(IBIFN) ;JRA IB*2 .0*592 ;S IBZ=$S($G( IBZD)="":" G2","MAMB1 6"[IBZD:"1 C",IBZD="T V"!(IBZD=" MC"):"1D", IBZD="CH": "1H",IBZD= "BL":$S($$ FT^IBCEF(I BIFN)=2:"1 B",1:"1A") ,1:"G2") ; JRA IB*2.0 *592 ';' S IBZ=$S($G (IBZD)="": "G2","MAMB 16"[IBZD:" 1C",IBZD=" TV"!(IBZD= "MC"):"1D" ,IBZD="CH" :"1H",IBZD ="BL":$S(( IBFT=2!(IB FT=7)):"1B ",1:"1A"), 1:"G2") ;J RA IB*2.0* 592 Q IBZ ; | |
| 1969 | ||
| 1970 | ||
| 1971 | Routines | |
| 1972 | Activities | |
| 1973 | Routine Na me | |
| 1974 | IBCEP3 | |
| 1975 | Enhancemen t Category | |
| 1976 | New | |
| 1977 | Modify | |
| 1978 | Delete | |
| 1979 | No Change | |
| 1980 | RTM | |
| 1981 | ||
| 1982 | Related Op tions | |
| 1983 | None | |
| 1984 | Related Ro utines | |
| 1985 | Routines “ Called By” | |
| 1986 | Routines “ Called” | |
| 1987 | ||
| 1988 | ||
| 1989 | ||
| 1990 | ||
| 1991 | Data Dicti onary (DD) Reference s | |
| 1992 | ||
| 1993 | Related Pr otocols | |
| 1994 | None | |
| 1995 | Related In tegration Control Re gistration s (ICRs) | |
| 1996 | None | |
| 1997 | Data Passi ng | |
| 1998 | Input | |
| 1999 | Output Re ference | |
| 2000 | Both | |
| 2001 | Global Re ference | |
| 2002 | Local | |
| 2003 | Input Attr ibute Name and Defin ition | |
| 2004 | Name: | |
| 2005 | Definition : | |
| 2006 | Output Att ribute Nam e and Defi nition | |
| 2007 | Name: | |
| 2008 | Definition : | |
| 2009 | Current Lo gic | |
| 2010 | IBCEP3 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 5-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 207,232,28 0,349**;21 -MAR-94;Bu ild 46 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;CUNEE D(IBIFN,IB SEQ,IBPTYP ,IBRET,IBE MC) ; Dete rmine if c are unit n eeded for ; provider type and insurance company(s) on bill ; IBIFN = i en of bill (file 399 ) ; IBSEQ = specific COB seque nce to che ck or null for check all ; IBP TYP = the ien of the provider id type in file 355. 97 or if n ull, ; the default p erforming provider I D type for the ins c o's. ; IBR ET = flag to return insurance ien (0) or file 355. 97 ien (1) ; IBEMC = no longer used ; ; Function r eturns car e unit nee ded flag ( 0=not need ed, 1=need ed) ^ ; AN D if IBSEQ ="": prima ry ins or 355.97 ien if care u nit needed ^ ; secon dary ins o r 355.97 i en if care unit need ed ^ ; ter tiary ins or 355.97 ien if car e unit nee ded ; (the se would b e '^' piec es 2,3,4) ; if IBSEQ : IBSEQ s eq ins or 355.97 ien if care u nit needed ; (this w ould be '^ ' piece 2) ; Q:$G(IB EMC) 0 N Q ,Z,Z0,Z4,I B,IBCTYP,I BFTYP,IBQ, IBRX,IBPT S (IBRX,IB )=0 S IBFT YP=$$FT^IB CEF(IBIFN) ,IBCTYP=$$ INPAT^IBCE F(IBIFN,1) S IBFTYP= $S(IBFTYP= 3:1,1:2) S :IBCTYP'=1 IBCTYP=2 I IBCTYP=2 S IBRX=$$ ISRX^IBCEF 1(IBIFN) ; Outpatien t pharmacy S IBPT=$G (IBPTYP) ; S (Z,IBQ) =0 F D Q :IBQ . I $ G(IBSEQ) S Z=IBSEQ,I BQ=1 ; Onl y once for specific COB sequen ce . I '$G (IBSEQ) S Z=Z+1,IBPT YP=IBPT I Z>3 S IBQ= 1 Q ; Up to 3 times - all ins . S Z0=$$ INSSEQ^IBC EP1(IBIFN, Z),Z4=$G(^ DIC(36,+Z0 ,4)) . I ' $G(IBPTYP) S IBPTYP= +Z4 . I 'Z 0!'IBPTYP S:'Z0 IBQ= 1 Q . S Q= +$$CAREUN( Z0,IBPTYP, IBFTYP,IBC TYP,IBRX) . I Q S $P (IB,U,$S($ G(IBSEQ):Z +1,1:2))=$ S($G(IBRET ):Q,1:Z0) ; I $TR(IB ,"^0") S $ P(IB,U)=1 Q IB ;CARE UN(IBINS,I BPTYP,IBFT YP,IBCTYP, IBRX) ; Fi nd ien (fi le 355.96) for care ; unit for the combi nation of ins co, pr ov type, f orm type a nd ; care type ; IBI NS = ien o f ins co ( file 36) ; IBPTYP = ien of pro vider id t ype (file 355.97) ; IBFTYP = f orm type ( 1=UB,2=150 0) ; IBCTY P = care t ype (1=inp at,2=outpa t) ; IBRX = 1 if out pat/Rx bil l ; N IB S IB="" ; I $G(IBRX) D . N T . S T=$O(^IB A(355.96," AD",IBINS, IBFTYP,3,I BPTYP,0)) . I 'T S T =$O(^IBA(3 55.96,"AD" ,IBINS,0,3 ,IBPTYP,0) ) . I T S IB=T ; I ' IB D ; Fi nd from mo st specifi c to least specific . I $O(^IB A(355.96," AD",IBINS, IBFTYP,IBC TYP,IBPTYP ,0)) S IB= +$O(^(0)) Q . I $O(^ IBA(355.96 ,"AD",IBIN S,IBFTYP,0 ,IBPTYP,0) ) S IB=+$O (^(0)) Q . I $O(^IBA (355.96,"A D",IBINS,0 ,IBCTYP,IB PTYP,0)) S IB=+$O(^( 0)) Q . I $O(^IBA(35 5.96,"AD", IBINS,0,0, IBPTYP,0)) S IB=+$O( ^(0)) Q ; Q IB ;DISP (IBINS,IBT YPE) ; Ret urn the na me of the type of ca re unit ne eded ; IBI NS = ien o f ins co ( file 36) ; IBTYPE = 2:PERFORMI NG PROVIDE R ID I $G( IBTYPE)'=2 Q "" Q $P ($G(^DIC(3 6,+IBINS,4 )),U,9) ;D ELID(IBIFN ,IBSEQ,IBX ) ; Delete all provi der data s pecific to an ins co ; represe nted by th e COB sequ ence IBSEQ for bill IBIFN ; IB X = 1 if c alled from care unit prompt - don't dele te value N IBZ,IBDR, X,Y,Z0,Z1 S IBZ=0 Q: '$G(IBSEQ) !($G(IBSEQ )>3) F S IBZ=$O(^DG CR(399,IBI FN,"PRV",I BZ)) Q:'IB Z S Z0=$G (^(IBZ,0)) ,Z1=$G(^(1 )) D . ; D elete prov ider id's . I $P(Z0, U,4+IBSEQ) '="" S IBD R(399.0222 ,IBZ_","_I BIFN_",",( 4+IBSEQ/10 0))="@" . ; Delete p rovider id types . I $P(Z0,U,1 1+IBSEQ)'= "" S IBDR( 399.0222,I BZ_","_IBI FN_",",(11 +IBSEQ/100 ))="@" . I $D(IBDR) D FILE^DIE (,"IBDR") Q ;SETID(I BIFN,IBSEQ ) ; Defaul t provider id for bi ll IBIFN a nd ins co for COB ; sequence I BSEQ N IBZ ,X,Y,IBDR, IBT S IBZ= 0 Q ; No longer use d as of pa tch 232 ;Q :'$G(IBSEQ )!($G(IBSE Q)>3) ;F S IBZ=$O(^D GCR(399,IB IFN,"PRV", IBZ)) Q:'I BZ S Z0=$G (^(IBZ,0)) ,Z1=$G(^(1 )) D ;. ; Update pro vider id's if no car e unit is needed ;. I $P(Z0,U, 2)'="" D ; .. S Z=$$G ETID^IBCEP 2(IBIFN,2, $P(Z0,U,2) ,IBSEQ,.IB T) ;.. I Z '="",IBT S IBDR(399. 0222,IBZ_" ,"_IBIFN_" ,",(4+IBSE Q/100))=Z, IBDR(399.0 222,IBZ_", "_IBIFN_", ",(11+IBSE Q/100))=+I BT ;. I $D (IBDR) D F ILE^DIE(," IBDR") Q ; ALLID(IBIF N,IBFLD,IB FUNC) ; If form type or care t ype (I/O/R X) changes , ; determ ine new pr ovider id values if possible a nd update them ; thi s includes primary, secondary, tertiary id's ; IBI FN = ien o f claim (f ile 399) ; IBFLD = i en of the field bein g changed when this call is ma de ; (.19 = form typ e .25 = ca re type) ; IBFUNC = 1 to add, 2 to delet e N Z,Z0,I BC,IBDR,IB T S Z=0 F S Z=$O(^D GCR(399,IB IFN,"PRV", Z)) Q:'Z S Z0=$G(^( Z,0)) D . F IBC=5:1: 7 I $S(IBF UNC=2:$P(Z 0,U,IBC)'= "",1:1) S IBDR(399.0 222,IBC_", "_IBIFN_", ",(IBC/100 ))=$S(IBFU NC=2:"@",1 :$$GETID^I BCEP2(IBIF N,2,$P(Z0, U,2),IBC-4 ,.IBT)) I $D(IBDR) D FILE^DIE( ,"IBDR") Q ;CUMNT ; Add/edit c are unit N D,DIE,DIC ,DIK,DIR,D A,X,Y,IB,I BINS,IBF,I BCT,IBOK,I BPTYP,IBOL D,IBY,IBIN S1,IBPTYP1 ,DUOUT,DTO UTINS F D Q:Y'>0 . S DIC="^D IC(36,",DI C(0)="AEMQ " D ^DIC K DIC . I $ D(DUOUT)!$ D(DTOUT) S Y=-1 Q . I Y'>0 S D IR(0)="EA" ,DIR("A")= "Insurance Co is req uired - pr ess enter to continu e: " D ^DI R K DIR Q . S IBINS= +Y,IBF="A" ,IBINS1=$P (Y,U,2) I $O(^IBA(35 5.96,"D",I BINS,""))' ="" D . W ! S DIR("A ")="(A)dd or (E)dit entries?: ",DIR("B") ="Add",DIR (0)="SA^A: Add;E:Edit " D ^DIR W ! K DIR . S IBF=Y Q :$G(IBF)=" "!("AE"'[$ G(IBF)) ; I IBINS>0 D . I IBF= "A" D NEW^ IBCEP4A(1) . I IBF=" E" D CHANG E^IBCEP4A( 1) ; Q ;DU P(IBDA,IBO LD,IBFUNC) ; Check i f the comb ination of ins co, p rov type, care ; typ e and form already e xists in f ile 355.96 ; IBDA = ien of ent ry in file 355.96 ; IBOLD = th e 0-node b efore chan ges were m ade - used to reset the fields N DUP,IB0 ,DR,X,Y,DI K,DIE,DA S IB0=$G(^I BA(355.96, IBDA,0)),D UP=0 ; I $ O(^IBA(355 .96,"AUNIQ ",+$P(IB0, U,3),+IB0, +$P(IB0,U, 4),+$P(IB0 ,U,5),+$P( IB0,U,6),0 ))'=IBDA!( $O(^IBA(35 5.96,"AUNI Q",+$P(IB0 ,U,3),+IB0 ,+$P(IB0,U ,4),+$P(IB 0,U,5),+$P (IB0,U,6), ""),-1)'=I BDA) D . S DUP=1 . I IBFUNC="E " D .. S D R=";.01/// "_$P(IBOLD ,U)_";.03/ //"_$S($P( IBOLD,U,3) '="":"/"_$ P(IBOLD,U, 3),1:"@")_ ";.04///"_ $S($P(IBOL D,U,4)'="" :"/"_$P(IB OLD,U,4),1 :"@") .. S DR=DR_";0 5///"_$S($ P(IBOLD,U, 5)'="":"/" _$P(IBOLD, U,5),1:"@" )_";.06/// "_$S($P(IB OLD,U,6)'= "":"/"_$P( IBOLD,U,6) ,1:"@") .. S DA=IBDA ,DIE="^IBA (355.96," D ^DIE . I IBFUNC="A " D .. S D A=IBDA,DIK ="^IBA(355 .96," D ^D IK Q DUP ; PROFID(IBI FN,IBSEQ,I BID) ; Ret urn id and type of r endering p rovider id ; used fo r insuranc e co at CO B seq IBSE Q for bill ien IBIFN ; RETURN VALUES: ; piece 1: ; 1 = FEDER AL TAX ID ; 2 = INSU RANCE CO S PECIFIC ID ; 3 = NET WORK ID ; "" = not a CMS-1500 bill or no id found ; piece 2: ; the id # N IBTYP, IBXDATA,IB Z S:'$G(IB SEQ) IBSEQ =+$$COBN^I BCEF(IBXIE N) S IBTYP =""_U_$G(I BID) G:$$F T^IBCEF(IB IFN)'=2 PR OFIDQ I '$ D(IBID) D F^IBCEF("N -ALL ATT/R ENDERING P ROV ID","I BZ",,IBIFN ) S IBID=$ $NOPUNCT^I BCEF($P(IB Z,U,IBSEQ+ 1)) G:IBID ="" PROFID Q S IBTYP= $S($$NOPUN CT^IBCEF(I BID)=$$NOP UNCT^IBCEF ($P($G(^IB E(350.9,1, 1)),U,5)): 1,$$NETWRK (IBIFN,IBI D,IBSEQ):3 ,1:2) S IB TYP=IBTYP_ U_IBID ;PR OFIDQ Q IB TYP ;NETWR K(IBIFN,IB ID,IBSEQ) ; Determin e if ID nu mber IBID is the sam e as the ; network i d for the insurance co ; IBIFN = bill ie n (file 39 9) ; IBSEQ = COB seq # of bill ; Returns 1 if netw ork ID mat ch is foun d for bill IBIFN, CO B seq IBSE Q N IBINS, IBNET S IB NET=0 Q IB NET ; This section n eeds work ********* I '$G(IBSE Q) S IBSEQ =+$$COBN^I BCEF(IBXIE N) S IBINS =+$G(^DGCR (399,IBIFN ,"I"_IBSEQ )) I $P($G (^IBE(355. 97,+$$PPTY P^IBCEP0(I BINS),1)), U,6) D . ; performin g provider id type i s a networ k id type . I $$NOPU NCT^IBCEF( $G(IBID))= $$NOPUNCT^ IBCEF($$GE TID^IBCEP2 (IBIFN,3,$ $PERFPRV^I BCEP2A(IBI FN),IBSEQ) ) S IBNET= 1 Q IBNET ; ; ; Para meter defi nitions fo r UNIQ1 an d UNIQ2 in IBCEP2 ; IBIFN = ie n of bill (file 399) ; IBINS = ien of in surance co (file 36) or *ALL* for all in surance ; IBPTYP = t he ien of the provid er id type in file 3 55.97 ; IB UNIT = the value of the specif ic care un it to use for a matc h ; or *N/ A* if none needed ; IBCU = the ien of th e entry be ing matche d in start file ; IB T = the se cond and t hird piece s are set to the ent ry ien^fil e # | |
| 2011 | Modified L ogic (Chan ges are in bold) | |
| 2012 | IBCEP3 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 5-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 207,232,28 0,349,592* *;21-MAR-9 4;Build 46 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;C UNEED(IBIF N,IBSEQ,IB PTYP,IBRET ,IBEMC) ; Determine if care un it needed for ; prov ider type and insura nce compan y(s) on bi ll ; IBIFN = ien of bill (file 399) ; IB SEQ = spec ific COB s equence to check or null for c heck all ; IBPTYP = the ien of the provi der id typ e in file 355.97 or if null, ; the defau lt perform ing provid er ID type for the i ns co's. ; IBRET = f lag to ret urn insura nce ien (0 ) or file 355.97 ien (1) ; IBE MC = no lo nger used ; ; Functi on returns care unit needed fl ag (0=not needed, 1= needed) ^ ; AND if I BSEQ="": p rimary ins or 355.97 ien if ca re unit ne eded ^ ; s econdary i ns or 355. 97 ien if care unit needed ^ ; tertiary ins or 355 .97 ien if care unit needed ; (these wou ld be '^' pieces 2,3 ,4) ; if I BSEQ : IBS EQ seq ins or 355.97 ien if ca re unit ne eded ; (th is would b e '^' piec e 2) ; Q:$ G(IBEMC) 0 N Q,Z,Z0, Z4,IB,IBCT YP,IBFTYP, IBQ,IBRX,I BPT S (IBR X,IB)=0 S IBFTYP=$$F T^IBCEF(IB IFN),IBCTY P=$$INPAT^ IBCEF(IBIF N,1) ;JWS; IB*2.0*592 S IBFTYP= $S(IBFTYP= 3:1,IBFTYP =7:4,1:2) S:IBCTYP'= 1 IBCTYP=2 I IBCTYP= 2 S IBRX=$ $ISRX^IBCE F1(IBIFN) ; Outpatie nt pharmac y S IBPT=$ G(IBPTYP) ; S (Z,IBQ )=0 F D Q:IBQ . I $G(IBSEQ) S Z=IBSEQ, IBQ=1 ; On ly once fo r specific COB seque nce . I '$ G(IBSEQ) S Z=Z+1,IBP TYP=IBPT I Z>3 S IBQ =1 Q ; Up to 3 time s - all in s . S Z0=$ $INSSEQ^IB CEP1(IBIFN ,Z),Z4=$G( ^DIC(36,+Z 0,4)) . I '$G(IBPTYP ) S IBPTYP =+Z4 . I ' Z0!'IBPTYP S:'Z0 IBQ =1 Q . S Q =+$$CAREUN (Z0,IBPTYP ,IBFTYP,IB CTYP,IBRX) . I Q S $ P(IB,U,$S( $G(IBSEQ): Z+1,1:2))= $S($G(IBRE T):Q,1:Z0) ; I $TR(I B,"^0") S $P(IB,U)=1 Q IB ;CAR EUN(IBINS, IBPTYP,IBF TYP,IBCTYP ,IBRX) ; F ind ien (f ile 355.96 ) for care ; unit fo r the comb ination of ins co, p rov type, form type and ; care type ; IB INS = ien of ins co (file 36) ; IBPTYP = ien of pr ovider id type (file 355.97) ; IBFTYP = form type (1=UB,2=15 00) ; IBCT YP = care type (1=in pat,2=outp at) ; IBRX = 1 if ou tpat/Rx bi ll ; N IB S IB="" ; I $G(IBRX) D . N T . S T=$O(^I BA(355.96, "AD",IBINS ,IBFTYP,3, IBPTYP,0)) . I 'T S T=$O(^IBA( 355.96,"AD ",IBINS,0, 3,IBPTYP,0 )) . I T S IB=T ; I 'IB D ; F ind from m ost specif ic to leas t specific . I $O(^I BA(355.96, "AD",IBINS ,IBFTYP,IB CTYP,IBPTY P,0)) S IB =+$O(^(0)) Q . I $O( ^IBA(355.9 6,"AD",IBI NS,IBFTYP, 0,IBPTYP,0 )) S IB=+$ O(^(0)) Q . I $O(^IB A(355.96," AD",IBINS, 0,IBCTYP,I BPTYP,0)) S IB=+$O(^ (0)) Q . I $O(^IBA(3 55.96,"AD" ,IBINS,0,0 ,IBPTYP,0) ) S IB=+$O (^(0)) Q ; Q IB ;DIS P(IBINS,IB TYPE) ; Re turn the n ame of the type of c are unit n eeded ; IB INS = ien of ins co (file 36) ; IBTYPE = 2:PERFORM ING PROVID ER ID I $G (IBTYPE)'= 2 Q "" Q $ P($G(^DIC( 36,+IBINS, 4)),U,9) ; DELID(IBIF N,IBSEQ,IB X) ; Delet e all prov ider data specific t o an ins c o ; repres ented by t he COB seq uence IBSE Q for bill IBIFN ; I BX = 1 if called fro m care uni t prompt - don't del ete value N IBZ,IBDR ,X,Y,Z0,Z1 S IBZ=0 Q :'$G(IBSEQ )!($G(IBSE Q)>3) F S IBZ=$O(^D GCR(399,IB IFN,"PRV", IBZ)) Q:'I BZ S Z0=$ G(^(IBZ,0) ),Z1=$G(^( 1)) D . ; Delete pro vider id's . I $P(Z0 ,U,4+IBSEQ )'="" S IB DR(399.022 2,IBZ_","_ IBIFN_",", (4+IBSEQ/1 00))="@" . ; Delete provider i d types . I $P(Z0,U, 11+IBSEQ)' ="" S IBDR (399.0222, IBZ_","_IB IFN_",",(1 1+IBSEQ/10 0))="@" . I $D(IBDR) D FILE^DI E(,"IBDR") Q ;SETID( IBIFN,IBSE Q) ; Defau lt provide r id for b ill IBIFN and ins co for COB ; sequence IBSEQ N IB Z,X,Y,IBDR ,IBT S IBZ =0 Q ; No longer us ed as of p atch 232 ; Q:'$G(IBSE Q)!($G(IBS EQ)>3) ;F S IBZ=$O(^ DGCR(399,I BIFN,"PRV" ,IBZ)) Q:' IBZ S Z0=$ G(^(IBZ,0) ),Z1=$G(^( 1)) D ;. ; Update pr ovider id' s if no ca re unit is needed ;. I $P(Z0,U ,2)'="" D ;.. S Z=$$ GETID^IBCE P2(IBIFN,2 ,$P(Z0,U,2 ),IBSEQ,.I BT) ;.. I Z'="",IBT S IBDR(399 .0222,IBZ_ ","_IBIFN_ ",",(4+IBS EQ/100))=Z ,IBDR(399. 0222,IBZ_" ,"_IBIFN_" ,",(11+IBS EQ/100))=+ IBT ;. I $ D(IBDR) D FILE^DIE(, "IBDR") Q ;ALLID(IBI FN,IBFLD,I BFUNC) ; I f form typ e or care type (I/O/ RX) change s, ; deter mine new p rovider id values if possible and update them ; th is include s primary, secondary , tertiary id's ; IB IFN = ien of claim ( file 399) ; IBFLD = ien of the field bei ng changed when this call is m ade ; (.19 = form ty pe .25 = c are type) ; IBFUNC = 1 to add, 2 to dele te N Z,Z0, IBC,IBDR,I BT S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"PRV" ,Z)) Q:'Z S Z0=$G(^ (Z,0)) D . F IBC=5:1 :7 I $S(IB FUNC=2:$P( Z0,U,IBC)' ="",1:1) S IBDR(399. 0222,IBC_" ,"_IBIFN_" ,",(IBC/10 0))=$S(IBF UNC=2:"@", 1:$$GETID^ IBCEP2(IBI FN,2,$P(Z0 ,U,2),IBC- 4,.IBT)) I $D(IBDR) D FILE^DIE (,"IBDR") Q ;CUMNT ; Add/edit care unit N D,DIE,DI C,DIK,DIR, DA,X,Y,IB, IBINS,IBF, IBCT,IBOK, IBPTYP,IBO LD,IBY,IBI NS1,IBPTYP 1,DUOUT,DT OUTINS F D Q:Y'>0 . S DIC="^ DIC(36,",D IC(0)="AEM Q" D ^DIC K DIC . I $D(DUOUT)! $D(DTOUT) S Y=-1 Q . I Y'>0 S DIR(0)="EA ",DIR("A") ="Insuranc e Co is re quired - p ress enter to contin ue: " D ^D IR K DIR Q . S IBINS =+Y,IBF="A ",IBINS1=$ P(Y,U,2) I $O(^IBA(3 55.96,"D", IBINS,"")) '="" D . W ! S DIR(" A")="(A)dd or (E)dit entries?: ",DIR("B" )="Add",DI R(0)="SA^A :Add;E:Edi t" D ^DIR W ! K DIR . S IBF=Y Q:$G(IBF)= ""!("AE"'[ $G(IBF)) ; I IBINS>0 D . I IBF ="A" D NEW ^IBCEP4A(1 ) . I IBF= "E" D CHAN GE^IBCEP4A (1) ; Q ;D UP(IBDA,IB OLD,IBFUNC ) ; Check if the com bination o f ins co, prov type, care ; ty pe and for m already exists in file 355.9 6 ; IBDA = ien of en try in fil e 355.96 ; IBOLD = t he 0-node before cha nges were made - use d to reset the field s N DUP,IB 0,DR,X,Y,D IK,DIE,DA S IB0=$G(^ IBA(355.96 ,IBDA,0)), DUP=0 ; I $O(^IBA(35 5.96,"AUNI Q",+$P(IB0 ,U,3),+IB0 ,+$P(IB0,U ,4),+$P(IB 0,U,5),+$P (IB0,U,6), 0))'=IBDA! ($O(^IBA(3 55.96,"AUN IQ",+$P(IB 0,U,3),+IB 0,+$P(IB0, U,4),+$P(I B0,U,5),+$ P(IB0,U,6) ,""),-1)'= IBDA) D . S DUP=1 . I IBFUNC=" E" D .. S DR=";.01// /"_$P(IBOL D,U)_";.03 ///"_$S($P (IBOLD,U,3 )'="":"/"_ $P(IBOLD,U ,3),1:"@") _";.04///" _$S($P(IBO LD,U,4)'=" ":"/"_$P(I BOLD,U,4), 1:"@") .. S DR=DR_"; 05///"_$S( $P(IBOLD,U ,5)'="":"/ "_$P(IBOLD ,U,5),1:"@ ")_";.06// /"_$S($P(I BOLD,U,6)' ="":"/"_$P (IBOLD,U,6 ),1:"@") . . S DA=IBD A,DIE="^IB A(355.96," D ^DIE . I IBFUNC=" A" D .. S DA=IBDA,DI K="^IBA(35 5.96," D ^ DIK Q DUP ;PROFID(IB IFN,IBSEQ, IBID) ; Re turn id an d type of rendering provider i d ; used f or insuran ce co at C OB seq IBS EQ for bil l ien IBIF N ; RETURN VALUES: ; piece 1: ; 1 = FEDE RAL TAX ID ; 2 = INS URANCE CO SPECIFIC I D ; 3 = NE TWORK ID ; "" = not a CMS-1500 bill or n o id found ; piece 2 : ; the id # N IBTYP ,IBXDATA,I BZ S:'$G(I BSEQ) IBSE Q=+$$COBN^ IBCEF(IBXI EN) S IBTY P=""_U_$G( IBID) ;JWS ;IB*2.0*59 2 I $$FT^I BCEF(IBIFN )'=2,$$FT^ IBCEF(IBIF N)'=7 G PR OFIDQ I '$ D(IBID) D F^IBCEF("N -ALL ATT/R ENDERING P ROV ID","I BZ",,IBIFN ) S IBID=$ $NOPUNCT^I BCEF($P(IB Z,U,IBSEQ+ 1)) G:IBID ="" PROFID Q S IBTYP= $S($$NOPUN CT^IBCEF(I BID)=$$NOP UNCT^IBCEF ($P($G(^IB E(350.9,1, 1)),U,5)): 1,$$NETWRK (IBIFN,IBI D,IBSEQ):3 ,1:2) S IB TYP=IBTYP_ U_IBID ;PR OFIDQ Q IB TYP ;NETWR K(IBIFN,IB ID,IBSEQ) ; Determin e if ID nu mber IBID is the sam e as the ; network i d for the insurance co ; IBIFN = bill ie n (file 39 9) ; IBSEQ = COB seq # of bill ; Returns 1 if netw ork ID mat ch is foun d for bill IBIFN, CO B seq IBSE Q N IBINS, IBNET S IB NET=0 Q IB NET ; This section n eeds work ********* I '$G(IBSE Q) S IBSEQ =+$$COBN^I BCEF(IBXIE N) S IBINS =+$G(^DGCR (399,IBIFN ,"I"_IBSEQ )) I $P($G (^IBE(355. 97,+$$PPTY P^IBCEP0(I BINS),1)), U,6) D . ; performin g provider id type i s a networ k id type . I $$NOPU NCT^IBCEF( $G(IBID))= $$NOPUNCT^ IBCEF($$GE TID^IBCEP2 (IBIFN,3,$ $PERFPRV^I BCEP2A(IBI FN),IBSEQ) ) S IBNET= 1 Q IBNET ; ; ; Para meter defi nitions fo r UNIQ1 an d UNIQ2 in IBCEP2 ; IBIFN = ie n of bill (file 399) ; IBINS = ien of in surance co (file 36) or *ALL* for all in surance ; IBPTYP = t he ien of the provid er id type in file 3 55.97 ; IB UNIT = the value of the specif ic care un it to use for a matc h ; or *N/ A* if none needed ; IBCU = the ien of th e entry be ing matche d in start file ; IB T = the se cond and t hird piece s are set to the ent ry ien^fil e # | |
| 2013 | ||
| 2014 | ||
| 2015 | Routines | |
| 2016 | Activities | |
| 2017 | Routine Na me | |
| 2018 | IBCEP4 | |
| 2019 | Enhancemen t Category | |
| 2020 | New | |
| 2021 | Modify | |
| 2022 | Delete | |
| 2023 | No Change | |
| 2024 | RTM | |
| 2025 | ||
| 2026 | Related Op tions | |
| 2027 | None | |
| 2028 | Related Ro utines | |
| 2029 | Routines “ Called By” | |
| 2030 | Routines “ Called” | |
| 2031 | ||
| 2032 | ||
| 2033 | ||
| 2034 | ||
| 2035 | Data Dicti onary (DD) Reference s | |
| 2036 | ||
| 2037 | Related Pr otocols | |
| 2038 | None | |
| 2039 | Related In tegration Control Re gistration s (ICRs) | |
| 2040 | None | |
| 2041 | Data Passi ng | |
| 2042 | Input | |
| 2043 | Output Re ference | |
| 2044 | Both | |
| 2045 | Global Re ference | |
| 2046 | Local | |
| 2047 | Input Attr ibute Name and Defin ition | |
| 2048 | Name: | |
| 2049 | Definition : | |
| 2050 | Output Att ribute Nam e and Defi nition | |
| 2051 | Name: | |
| 2052 | Definition : | |
| 2053 | Current Lo gic | |
| 2054 | IBCEP4 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 9-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 320,348,34 9,377**;21 -MAR-94;Bu ild 23 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;EN ; -- main en try point N IBINS,IB ALL,IB95 D ENX Q ;EN 1(IBINS) ; -- Entry point from provider number mai ntenence N IBPRV,IBA LL,IB95 S VALMBCK="R " D ENX Q ;ENX ; Com mon call t o list tem plate for dual entry points N IBSLEV,DIR ,Y K IBFAS TXT D FULL ^VALM1 S D IR(0)="SA^ 1:Performi ng Provide r Care Uni ts;2:Billi ng Provide r Care Uni ts" S DIR( "A")="Ente r Type of Care Unit: ",DIR("B" )=$P($P(DI R(0),":",2 ),";",1) W ! D ^DIR K DIR W ! I Y'>0 Q S IBSLEV=+Y I IBSLEV= 2 D EN^VAL M("IBCE 2N D PRVID CA RE UNIT MA INT") Q D EN^VALM("I BCE PRVCAR E UNIT MAI NT") Q ;HD R ; -- hea der K VALM HDR S VALM HDR(1)=" " S VALMHDR (2)="Insur ance Co: " _$S('$G(IB ALL)&$G(IB INS):$P($G (^DIC(36,+ IBINS,0)), U),1:"ALL" ) Q ;INIT ; -- init variables, list arra y N Z,IB,I BLCT,IBENT ,IBNM,IB0, Z0,Z1,IBQ, DIR,Y,X I $G(IBINS) S Y=IBINS ; For entr ypoint fro m provider number ma intenance ; I '$G(IB INS) D . S DIR(0)="P A^DIC(36,: AEMQ",DIR( "A")="Sele ct INSURAN CE CO: ",D IR("?")="S elect an I NSURANCE C O to displ ay its car e units" . D ^DIR K DIR . I $D (DTOUT)!$D (DUOUT) S Y=-2 Q . I Y>0 S IBI NS=+Y Q ; I Y'=-2 D . D BLD E D . S VAL MQUIT=1 Q ;BLD ; Bld display - IBINS mus t = ien of file 36 K ^TMP("IBP RV_CU",$J) ; I $G(IB SLEV)=2 Q ; S (IBENT ,IBLCT)=0, IBNM="" F S IBNM=$O (^IBA(355. 95,"C",IBI NS,IBNM)) Q:IBNM="" S Z=0 F S Z=$O(^IB A(355.95," C",IBINS,I BNM,Z)) Q: 'Z S IB=$ G(^IBA(355 .95,Z,0)) I IB'="",$ P(IB,U,4)= "" D . S I BLCT=IBLCT +1,IBENT=I BENT+1 . I '$D(^IBA( 355.96,"AU NIQ",IBINS ,Z)) D SET ^VALM10(IB LCT,$E(IBE NT_" ",1,4 )_$E($P(IB ,U)_$J("", 30),1,30)_ " "_$E($P( IB,U,2)_$J ("",20),1, 20)_" (NO COMBINATIO NS FOUND)" ,IBENT) Q . D SET^VA LM10(IBLCT ,$E(IBENT_ " ",1,4)_$ E($P(IB,U) _$J("",30) ,1,30)_" " _$E($P(IB, U,2)_$J("" ,20),1,20) ,IBENT) . S ^TMP("IB PRV_CU",$J ,"ZIDX",IB ENT)=Z . S Z0=0 F S Z0=$O(^IB A(355.96," AE",Z,Z0)) Q:'Z0 S Z1=0 F S Z1=$O(^IBA (355.96,"A E",Z,Z0,Z1 )) Q:'Z1 S IB0=$G(^ IBA(355.96 ,Z1,0)) I IB0'="" D .. S IBLCT =IBLCT+1 . . S IBQ=$J ("",28)_"o "_$E($$EX PAND^IBTRE (355.96,.0 6,+$P(IB0, U,6))_$J(" ",20),1,20 ) .. S IBQ =IBQ_" "_$ E($P("Both form type s^UB-04 On ly^CMS-150 0 Only",U, $P(IB0,U,4 )+1)_$J("" ,15),1,15) _" "_$E($P ("Inpt/Out pt^Inpt On ly^Outpt O nly^RX Onl y",U,+$P(I B0,U,5)+1) _$J("",10) ,1,10) .. D SET^VALM 10(IBLCT,I BQ,IBENT) ; I 'IBLCT D SET^VAL M10(1,"No CARE UNITs Found"_$S ('$G(IBINS ):"",1:" f or Insuran ce Co")) S IBLCT=1 S VALMCNT=I BLCT,VALMB G=1 Q ;HEL P ; -- hel p ; I $G(I BSLEV)=2 Q ; S X="?" D DISP^XQ ORM1 W !! Q ;EXIT ; -- exit D CLEAN^VALM 10 K ^TMP( "IBPRV_CU" ,$J),IBINS ,IBALL Q ; EXPND ; Q ;SEL(IBDA, MANY) ; Se lect from care unit list ; IBD A is passe d by refer ence and I BDA(1) ret urned cont aining ; i en's of th e care uni t selected (file 355 .95). ; If > 1 entry can be se lected, MA NY is set to 1 N Z S IBDA=0 D EN^VALM2($ G(XQORNOD( 0)),$S($G( MANY):"",1 :"S")) S Z =0 F S Z= $O(VALMY(Z )) Q:'Z S IBDA=IBDA +1,IBDA(IB DA)=+$G(^T MP("IBPRV_ CU",$J,"ZI DX",Z)) Q ;DISP(IBVA R,IBINS,IB PTYP,IBFT, IBCT,START ,END) ; Se t up displ ay array f or ; provi der id N Z S START=$ S($G(START ):START,1: 1) S (Z,EN D)=$G(STAR T) S @IBVA R@(START)= "INSURANCE : "_$S(IBI NS:$P($G(^ DIC(36,+IB INS,0)),U) ,1:"ALL IN SURANCE") S @IBVAR@( START+1)=" PROV TYPE: "_$$EXPAN D^IBTRE(35 5.96,.06,I BPTYP) S @ IBVAR@(STA RT+2)="FOR M TYPE: "_ $$EXPAND^I BTRE(355.9 6,.04,IBFT ) S @IBVAR @(START+3) ="CARE TYP E: "_$$EXP AND^IBTRE( 355.96,.05 ,IBCT) S E ND=$G(STAR T)+3 Q ;CA REUOK(IBIF N,IBCU,IBT YPE,IBSEQ) ; Returns 1 if care unit is a ppropriate ; for bi ll based o n provider type, car e type, bi ll type an d insuranc e co ; IBI FN = ien o f bill (fi le 399) ; IBCU = the ien of th e care uni t (file 35 5.96) ; IB TYPE = typ e of ID be ing checke d (1=perfo rming, 2=E MC) ; IBSE Q = the CO B seq bein g checked (1-3) N Z, IBOK,IBINS ,IBCT,IBFT ,IBPTYP,IB RX S IBOK= 0 S IBINS= +$$FINDINS ^IBCEF1(IB IFN,+IBSEQ ),IBFT=$S( $$FT^IBCEF (IBIFN)=2: 2,1:1) S I BPTYP=+$S( IBTYPE=1:$ $PPTYP^IBC EP0(IBINS) ,1:$$EMCID ^IBCEP()) S IBRX=$$I SRX^IBCEF1 (IBIFN) S IBCT=$S('I BRX:$S($$I NPAT^IBCEF (IBIFN,1): 1,1:2),1:3 ) ;Check f rom most g eneral to most speci fic I $D(^ IBA(355.96 ,"AD",IBIN S,0,0,IBPT YP,IBCU)) S IBOK=1 G CAREOKQ I 'IBRX,$D( ^IBA(355.9 6,"AD",IBI NS,IBFT,0, IBPTYP,IBC U)) S IBOK =1 G CAREO KQ I $D(^I BA(355.96, "AD",IBINS ,0,IBCT,IB PTYP,IBCU) ) S IBOK=1 G CAREOKQ I $D(^IBA (355.96,"A D",IBINS,I BFT,IBCT,I BPTYP,IBCU )) S IBOK= 1 G CAREOK Q ;CAREOKQ Q IBOK ; | |
| 2055 | Modified L ogic (Chan ges are in bold) | |
| 2056 | IBCEP4 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 9-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 320,348,34 9,377,592* *;21-MAR-9 4;Build 23 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;E N ; -- mai n entry po int N IBIN S,IBALL,IB 95 D ENX Q ;EN1(IBIN S) ; -- En try point from provi der number maintenen ce N IBPRV ,IBALL,IB9 5 S VALMBC K="R" D EN X Q ;ENX ; Common ca ll to list template for dual e ntry point s N IBSLEV ,DIR,Y K I BFASTXT D FULL^VALM1 S DIR(0)= "SA^1:Perf orming Pro vider Care Units;2:B illing Pro vider Care Units" S DIR("A")=" Enter Type of Care U nit: ",DIR ("B")=$P($ P(DIR(0)," :",2),";", 1) W ! D ^ DIR K DIR W ! I Y'>0 Q S IBSLE V=+Y I IBS LEV=2 D EN ^VALM("IBC E 2ND PRVI D CARE UNI T MAINT") Q D EN^VAL M("IBCE PR VCARE UNIT MAINT") Q ;HDR ; -- header K VALMHDR S VALMHDR(1) =" " S VAL MHDR(2)="I nsurance C o: "_$S('$ G(IBALL)&$ G(IBINS):$ P($G(^DIC( 36,+IBINS, 0)),U),1:" ALL") Q ;I NIT ; -- i nit variab les, list array N Z, IB,IBLCT,I BENT,IBNM, IB0,Z0,Z1, IBQ,DIR,Y, X I $G(IBI NS) S Y=IB INS ; For entrypoint from prov ider numbe r maintena nce ; I '$ G(IBINS) D . S DIR(0 )="PA^DIC( 36,:AEMQ", DIR("A")=" Select INS URANCE CO: ",DIR("?" )="Select an INSURAN CE CO to d isplay its care unit s" . D ^DI R K DIR . I $D(DTOUT )!$D(DUOUT ) S Y=-2 Q . I Y>0 S IBINS=+Y Q ; I Y'=- 2 D . D BL D E D . S VALMQUIT= 1 Q ;BLD ; Bld displ ay - IBINS must = ie n of file 36 K ^TMP( "IBPRV_CU" ,$J) ; I $ G(IBSLEV)= 2 Q ; S (I BENT,IBLCT )=0,IBNM=" " F S IBN M=$O(^IBA( 355.95,"C" ,IBINS,IBN M)) Q:IBNM ="" S Z=0 F S Z=$O (^IBA(355. 95,"C",IBI NS,IBNM,Z) ) Q:'Z S IB=$G(^IBA (355.95,Z, 0)) I IB'= "",$P(IB,U ,4)="" D . S IBLCT=I BLCT+1,IBE NT=IBENT+1 . I '$D(^ IBA(355.96 ,"AUNIQ",I BINS,Z)) D SET^VALM1 0(IBLCT,$E (IBENT_" " ,1,4)_$E($ P(IB,U)_$J ("",30),1, 30)_" "_$E ($P(IB,U,2 )_$J("",20 ),1,20)_" (NO COMBIN ATIONS FOU ND)",IBENT ) Q . D SE T^VALM10(I BLCT,$E(IB ENT_" ",1, 4)_$E($P(I B,U)_$J("" ,30),1,30) _" "_$E($P (IB,U,2)_$ J("",20),1 ,20),IBENT ) . S ^TMP ("IBPRV_CU ",$J,"ZIDX ",IBENT)=Z . S Z0=0 F S Z0=$O (^IBA(355. 96,"AE",Z, Z0)) Q:'Z0 S Z1=0 F S Z1=$O( ^IBA(355.9 6,"AE",Z,Z 0,Z1)) Q:' Z1 S IB0= $G(^IBA(35 5.96,Z1,0) ) I IB0'=" " D .. S I BLCT=IBLCT +1 .. S IB Q=$J("",28 )_"o "_$E( $$EXPAND^I BTRE(355.9 6,.06,+$P( IB0,U,6))_ $J("",20), 1,20) .. ; JRA IB*2.0 *592 Modif y to accom modate Den tal Form J 430D .. ;S IBQ=IBQ_" "_$E($P(" Both form types^UB-0 4 Only^CMS -1500 Only ",U,$P(IB0 ,U,4)+1)_$ J("",15),1 ,15)_" "_$ E($P("Inpt /Outpt^Inp t Only^Out pt Only^RX Only",U,+ $P(IB0,U,5 )+1)_$J("" ,10),1,10) ;JRA IB*2 .0*592 ';' .. S IBQ= IBQ_" "_$E ($P("All F orm Types^ UB-04 Only ^CMS-1500 Only^^J430 D Only",U, $P(IB0,U,4 )+1)_$J("" ,15),1,15) _" "_$E($P ("Inpt/Out pt^Inpt On ly^Outpt O nly^RX Onl y",U,+$P(I B0,U,5)+1) _$J("",10) ,1,10) ;JR A IB*2.0*5 92 .. D SE T^VALM10(I BLCT,IBQ,I BENT) ; I 'IBLCT D S ET^VALM10( 1,"No CARE UNITs Fou nd"_$S('$G (IBINS):"" ,1:" for I nsurance C o")) S IBL CT=1 S VAL MCNT=IBLCT ,VALMBG=1 Q ;HELP ; -- help ; I $G(IBSLE V)=2 Q ; S X="?" D D ISP^XQORM1 W !! Q ;E XIT ; -- e xit D CLEA N^VALM10 K ^TMP("IBP RV_CU",$J) ,IBINS,IBA LL Q ;EXPN D ; Q ;SEL (IBDA,MANY ) ; Select from care unit list ; IBDA is passed by reference and IBDA( 1) returne d containi ng ; ien's of the ca re unit se lected (fi le 355.95) . ; If > 1 entry can be select ed, MANY i s set to 1 N Z S IBD A=0 D EN^V ALM2($G(XQ ORNOD(0)), $S($G(MANY ):"",1:"S" )) S Z=0 F S Z=$O(V ALMY(Z)) Q :'Z S IBD A=IBDA+1,I BDA(IBDA)= +$G(^TMP(" IBPRV_CU", $J,"ZIDX", Z)) Q ;DIS P(IBVAR,IB INS,IBPTYP ,IBFT,IBCT ,START,END ) ; Set up display a rray for ; provider id N Z S S TART=$S($G (START):ST ART,1:1) S (Z,END)=$ G(START) S @IBVAR@(S TART)="INS URANCE: "_ $S(IBINS:$ P($G(^DIC( 36,+IBINS, 0)),U),1:" ALL INSURA NCE") S @I BVAR@(STAR T+1)="PROV TYPE: "_$ $EXPAND^IB TRE(355.96 ,.06,IBPTY P) S @IBVA R@(START+2 )="FORM TY PE: "_$$EX PAND^IBTRE (355.96,.0 4,IBFT) S @IBVAR@(ST ART+3)="CA RE TYPE: " _$$EXPAND^ IBTRE(355. 96,.05,IBC T) S END=$ G(START)+3 Q ;CAREUO K(IBIFN,IB CU,IBTYPE, IBSEQ) ; R eturns 1 i f care uni t is appro priate ; for bill b ased on pr ovider typ e, care ty pe, bill t ype and in surance co ; IBIFN = ien of bi ll (file 3 99) ; IBCU = the ien of the ca re unit (f ile 355.96 ) ; IBTYPE = type of ID being checked (1 =performin g, 2=EMC) ; IBSEQ = the COB se q being ch ecked (1-3 ) N Z,IBOK ,IBINS,IBC T,IBFT,IBP TYP,IBRX S IBOK=0 S IBINS=+$$F INDINS^IBC EF1(IBIFN, +IBSEQ),IB FT=$S($$FT ^IBCEF(IBI FN)=2:2,1: 1) S IBPTY P=+$S(IBTY PE=1:$$PPT YP^IBCEP0( IBINS),1:$ $EMCID^IBC EP()) S IB RX=$$ISRX^ IBCEF1(IBI FN) S IBCT =$S('IBRX: $S($$INPAT ^IBCEF(IBI FN,1):1,1: 2),1:3) ;C heck from most gener al to most specific I $D(^IBA( 355.96,"AD ",IBINS,0, 0,IBPTYP,I BCU)) S IB OK=1 G CAR EOKQ I 'IB RX,$D(^IBA (355.96,"A D",IBINS,I BFT,0,IBPT YP,IBCU)) S IBOK=1 G CAREOKQ I $D(^IBA(3 55.96,"AD" ,IBINS,0,I BCT,IBPTYP ,IBCU)) S IBOK=1 G C AREOKQ I $ D(^IBA(355 .96,"AD",I BINS,IBFT, IBCT,IBPTY P,IBCU)) S IBOK=1 G CAREOKQ ;C AREOKQ Q I BOK ; | |
| 2057 | ||
| 2058 | ||
| 2059 | Routines | |
| 2060 | Activities | |
| 2061 | Routine Na me | |
| 2062 | IBCEP5 | |
| 2063 | Enhancemen t Category | |
| 2064 | New | |
| 2065 | Modify | |
| 2066 | Delete | |
| 2067 | No Change | |
| 2068 | RTM | |
| 2069 | ||
| 2070 | Related Op tions | |
| 2071 | None | |
| 2072 | Related Ro utines | |
| 2073 | Routines “ Called By” | |
| 2074 | Routines “ Called” | |
| 2075 | ||
| 2076 | ||
| 2077 | ||
| 2078 | ||
| 2079 | Data Dicti onary (DD) Reference s | |
| 2080 | ||
| 2081 | Related Pr otocols | |
| 2082 | None | |
| 2083 | Related In tegration Control Re gistration s (ICRs) | |
| 2084 | None | |
| 2085 | Data Passi ng | |
| 2086 | Input | |
| 2087 | Output Re ference | |
| 2088 | Both | |
| 2089 | Global Re ference | |
| 2090 | Local | |
| 2091 | Input Attr ibute Name and Defin ition | |
| 2092 | Name: | |
| 2093 | Definition : | |
| 2094 | Output Att ribute Nam e and Defi nition | |
| 2095 | Name: | |
| 2096 | Definition : | |
| 2097 | Current Lo gic | |
| 2098 | IBCEP5 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 9-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 232,320,34 8,349,377* *;21-MAR-9 4;Build 23 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;E N ; -- mai n entry po int for IB CE PRV MAI NT N IBPRV ,IBINSEN1 ; Entrypoi nt for non -VA provid er ID main tenance ho ok N IBSLE V,DIR,Y,X, IBPRMPT,IB NVAFL,IBIF K IBFASTX T S IBIF=" " I $G(IBP RV) S IBIF =$$GET1^DI Q(355.93,I BPRV,.02," I") D FULL ^VALM1 S I BPRMPT=$S( IBIF=1:"LA B OR FACIL ITY",1:"PR OVIDER") S DIR(0)="S A^1:"_IBPR MPT_"'S OW N IDS;2:"_ IBPRMPT_" IDS FURNIS HED BY AN INSURANCE COMPANY" S DIR("A")= "SELECT SO URCE OF ID : ",DIR("B ")=$P($P(D IR(0),":", 2),";") W ! D ^DIR K DIR W ! I Y'>0 Q S IBSLEV=+Y D EN^VALM( "IBCE PRVP RV MAINT") Q ;HDR ; -- header code N IBC ,Z,IBIF S IBIF="" I $G(IBNPRV) S IBIF=$$ GET1^DIQ(3 55.93,IBNP RV,.02,"I" ) K VALMHD R S IBC=1 S IBPRMPT= $S(IBIF=1: "Lab or Fa cility",1: "Performin g Provider ") S Z="** "_$S($G(I BSLEV)=1:I BPRMPT_"'s Own IDs ( No Specifi c Insuranc e Co)",1:I BPRMPT_" I Ds from In surance Co ")_" **" S VALMHDR(I BC)=$J("", 80-$L(Z)\2 )_Z,IBC=IB C+1 I $G(I BPRV),'+IB IF S VALMH DR(IBC)="P ROVIDER : "_$$EXPAND ^IBTRE(355 .9,.01,IBP RV)_$S(IBP RV["VA(200 ":" (VA PR OVIDER)",1 :" (NON-VA PROVIDER) "),IBC=IBC +1 I $G(IB PRV),+IBIF S VALMHDR (IBC)="Pro vider: "_$ $EXPAND^IB TRE(355.9, .01,IBPRV) _$S(IBIF=1 :"(Non-VA Lab or Fac ility)",1: ""),IBC=IB C+1 I $G(I BINS) D . N PCF,PCDI SP . S PCF =$P($G(^DI C(36,+IBIN S,3)),"^", 13) . S PC DISP=$S($G (IBSLEV)'= 2!($G(IBPR V)'["VA(20 0,"):"",PC F="C":"(Ch ild)",PCF= "P":"(Pare nt)",1:"") . S VALMH DR(IBC)=$S (IBIF:"Ins urance Co: ",1:"INSU RANCE CO: ")_$P($G(^ DIC(36,+IB INS,0)),U) _" "_PCDIS P Q ;INIT ; -- init variables and list a rray N IBF ILE,DIR,DI C,Y,X,DTOU T,DUOUT,IB IF,AGAIN ; K ^TMP("I B_EDITED_I DS",$J) ; This will be to keep track of ID's edite d during t his sessio n S IBIF=" " I $G(IBN PRV) S IBI F=$$GET1^D IQ(355.93, IBNPRV,.02 ,"I") ; ; Removing C are Unit u nder certa in conditi ons ; This list is u sed for mu ltiple pur poses and not all ha ve Care Un its Associ ated with them ; Als o, a diffe rent proto col menu i s used wit h these ; IBNPRV is a non VA p rovider ; IBIF = 1 m eans this is a group or facili ty, not an individua l. ; I $G (IBNPRV),$ G(IBIF)=1 D . S VALM ("TITLE")= "Secondary Provider ID" . K VA LMDDF("CAR EUNIT") . I VALMCAP[ "Care Unit " S VALMCA P=$P(VALMC AP,"Care U nit")_" "_ $P(VALMCAP ,"Care Uni t",2) . K VALM("PROT OCOL") . S Y=$$FIND1 ^DIC(101,, ,"IBCE PRV NVA LOF MA INT") . I Y S VALM(" PROTOCOL") =+Y_";ORD( 101," ; I $G(IBPRV) S IBFILE=" IBA(355.93 ,",IBPRV=+ IBPRV_";"_ IBFILE I ' $G(IBPRV) D G:$G(VA LMQUIT) IN ITQ . S DI R(0)="SAO^ V:VA PROVI DER;N:NON- VA PROVIDE R",DIR("A" )="(V)A or (N)on-VA provider: ",DIR("B") ="V" . D ^ DIR K DIR . I "NV"'[ Y!(Y="") S VALMQUIT= 1 Q . S IB FILE=$S(Y= "V":"VA(20 0,",1:"IBA (355.93,") . S DIC=U _IBFILE,DI C(0)="AEMQ "_$S(IBFIL E["355.93" :"L",1:"") . S DIC(" A")="Selec t "_$S(IBF ILE["355.9 3":"NON-", 1:"")_"V.A . PROVIDER NAME: " . S:IBFILE[ "355.93" D IC("DR")=" .02////2;. 03;.04" . F D I $G (IBPRV)!$G (VALMQUIT) K DIC Q . . D ^DIC . . I $D(DTO UT)!$D(DUO UT) S VALM QUIT=1 Q . . I Y'>0 W !,*7,"Thi s is a req uired resp onse. Ente r '^' to e xit" Q .. S IBPRV=+Y _";"_IBFIL E ;AGAIN I $G(IBSLEV )=2 D G:$ G(AGAIN) A GAIN G:$G( VALMQUIT) INITQ . S AGAIN=0 . S DIR(0)=" PA^DIC(36, :AEMQ",DIR ("A")="Sel ect INSURA NCE CO: ", DIR("?",1) ="Select a n INSURANC E CO to di splay its provider I D's" . D ^ DIR K DIR . I $D(DTO UT)!$D(DUO UT) S VALM QUIT=1 Q . S IBINS=$ S(Y>0:+Y,1 :"NO") . I $G(IBPRV) '["VA(200, " Q ; O nly VA pro viders . I $P($G(^DI C(36,+IBIN S,3)),"^", 13)="C" D S AGAIN=1 Q .. W !, *7,"This i s a Child Insurance Company. E diting IDs is not pe rmitted." ; E D . S IBINS="NO " D BLDINI TQ Q ;BLD ; Build in itial disp lay ; Assu mes IBPRV = the vari able ptr f or prov id file (355 .9) ; IBIN S = the ie n of the i ns co or i f null, AL L is assum ed ; IBSLE V = 1 to d isplay onl y provider default i ds ; = 2 t o display all provid er/insuran ce co ids N IB,IBLCT ,IBCT,CT,P T,CU,INS,F T,Z,IBENT, IB1,IBIF ; S IBIF="" I $G(IBPR V)[355.93 S IBIF=$$G ET1^DIQ(35 5.93,+IBPR V,.02,"I") ; K ^TMP( "IBPRV_",$ J),^TMP("I BPRV_SORT" ,$J) K Z0 S (IBENT,I BCT,IBLCT) =0,INS="", IB1=1 F S INS=$S($G (IBINS):IB INS,IBSLEV =1:"*ALL*" ,1:$O(^IBA (355.9,"AU NIQ",IBPRV ,INS))) Q: $S(INS="": 1,$G(IBINS )!(IBSLEV= 1):$D(CU), 1:0) S CU= "",IB1=0 F S CU=$O( ^IBA(355.9 ,"AUNIQ",I BPRV,INS,C U)) Q:CU=" " D . S F T="" F S FT=$O(^IBA (355.9,"AU NIQ",IBPRV ,INS,CU,FT )) Q:FT="" S CT="" F S CT=$O (^IBA(355. 9,"AUNIQ", IBPRV,INS, CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^I BA(355.9," AUNIQ",IBP RV,INS,CU, FT,CT,PT)) Q:'PT D .. S Z=0 F S Z=$O(^ IBA(355.9, "AUNIQ",IB PRV,INS,CU ,FT,CT,PT, Z)) Q:'Z S IB=$G(^I BA(355.9,Z ,0)) D ... S ^TMP("I BPRV_SORT" ,$J,$S(INS :$P($G(^DI C(36,+INS, 0)),U)_" " ,1:" ALL") ,PT,FT,CT, CU,Z)=$P(I B,U,7) ; I IBSLEV=1, IBPRV["IBA (355.93",$ P($G(^IBA( 355.93,+IB PRV,0)),U, 12)'="" S ^TMP("IBPR V_SORT",$J ," ALL",+$ $STLIC^IBC EP8(),0,0, "*N/A*",0) =$P(^IBA(3 55.93,+IBP RV,0),U,12 ) S INS="" F S INS= $O(^TMP("I BPRV_SORT" ,$J,INS)) Q:INS="" D . I '$G( IBINS),'IB IF D:IBLCT SET^VALM1 0(IBLCT+1, " ",IBCT) S IBLCT=$S (IBLCT:IBL CT+2,1:1) D SET^VALM 10(IBLCT," INSURANCE CO: "_$S($ E(INS)=" " :"ALL INSU RANCE",1:I NS),$S(IBC T:IBCT,1:1 )) . S PT= "" . F S PT=$O(^TMP ("IBPRV_SO RT",$J,INS ,PT)) Q:PT ="" S FT= "" F S FT =$O(^TMP(" IBPRV_SORT ",$J,INS,P T,FT)) Q:F T="" S CT ="" F S C T=$O(^TMP( "IBPRV_SOR T",$J,INS, PT,FT,CT)) Q:CT="" D .. S CU= "" F S CU =$O(^TMP(" IBPRV_SORT ",$J,INS,P T,FT,CT,CU )) Q:CU="" S Z="" F S Z=$O(^ TMP("IBPRV _SORT",$J, INS,PT,FT, CT,CU,Z)) Q:Z="" S IB=$G(^(Z) ) D ... S IBLCT=IBLC T+1,IBCT=I BCT+1 ... S Z0=$E(IB CT_" ",1,4 )_" "_$E($ $EXPAND^IB TRE(355.9, .06,PT)_$S (PT=$$STLI C^IBCEP8() :"("_$P($G (^DIC(5,+$ P($G(^IBA( 355.93,+IB PRV,0)),U, 7),0)),U,2 )_")",1:"" )_$J("",20 ),1,20)_" "_$S(FT=1: "UB-04",FT =2:"1500 " ,1:"BOTH " ) ... S Z0 =Z0_" "_$E ($S(CT=3:" RX",CT=1:" INPT",CT=2 :"OUTPT",1 :"INPT/OUT PT")_$J("" ,11),1,11) ... S Z0= Z0_" "_$E( $S(CU'="*N /A*":$P($G (^IBA(355. 95,+$G(^IB A(355.96,C U,0)),0)), U),1:"")_$ J("",15),1 ,15) I Z0[ "MEDICINE" X "*" ... D SET^VAL M10(IBLCT, Z0_" "_IB, IBCT) ... S ^TMP("IB PRV_",$J," ZIDX",IBCT )=$S(Z'=0: Z,1:"LIC^" _IBPRV) I IBSLEV=1,I BPRV["VA(2 00" D . N IBP . S IB P=+IBPRV . Q:'$$GETL IC^IBCEP5D (.IBP) . I IBCT S IB LCT=IBLCT+ 1 D SET^VA LM10(IBLCT ," ",IBCT) . S Z=0 F S Z=$O(I BP(Z)) Q:' Z D .. S IBLCT=IBLC T+1,IBCT=I BCT+1 .. D SET^VALM1 0(IBLCT,$E (IBCT_" ", 1,4)_$E($P ($G(^DIC(5 ,+Z,0)),U, 2)_" STATE LICENSE # "_$J("",20 ),1,20)_$J ("",39)_IB P(Z),IBCT) .. S ^TMP ("IBPRV_", $J,"ZIDX", IBCT)="LIC ^"_+IBPRV K ^TMP("IB PRV_SORT", $J) ; I IB LCT=0 D G BLDQ ; No entries f or ins co selected . D SET^VAL M10(1," ") . D SET^V ALM10(2," No ID's fo und for pr ovider "_$ S('$G(IBIN S):"",1:"a nd selecte d insuranc e co")) . S IBLCT=2 ;BLDQ K VA LMCNT,VALM BG S VALMC NT=IBLCT,V ALMBG=1 Q ;HELP ; -- help code S X="?" D DISP^XQOR M1 W !! Q ;EXIT ; -- exit code D COPYPRO V^IBCEP5A( IBINS) K I BPRV D CLE AN^VALM10 K ^TMP("IB PRV_",$J), ^TMP("IBPR V_SORT",$J ),IBINS,IB ALL Q ;EXP ND ; -- ex pand code Q ;SEL(IBD A,MANY) ; Select fro m provider id list ; IBDA is p assed by r eference a nd IBDA(1) returned containing ; ien's o f the prov ider id re cords sele cted (file 355.9). ; If > 1 en try can be selected, MANY is s et to 1 N Z S IBDA=0 D EN^VALM 2($G(XQORN OD(0)),$S( $G(MANY):" ",1:"S")) S Z=0 F S Z=$O(VALM Y(Z)) Q:'Z S IBDA=I BDA+1,IBDA (IBDA)=$G( ^TMP("IBPR V_",$J,"ZI DX",Z)) Q ; | |
| 2099 | Modified L ogic (Chan ges are in bold) | |
| 2100 | IBCEP5 ;AL B/TMP - ED I UTILITIE S for prov ider ID ;2 9-SEP-00 ; ;2.0;INTEG RATED BILL ING;**137, 232,320,34 8,349,377, 592**;21-M AR-94;Buil d 23 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . ;EN ; -- main entr y point fo r IBCE PRV MAINT N I BPRV,IBINS EN1 ; Entr ypoint for non-VA pr ovider ID maintenanc e hook N I BSLEV,DIR, Y,X,IBPRMP T,IBNVAFL, IBIF K IBF ASTXT S IB IF="" I $G (IBPRV) S IBIF=$$GET 1^DIQ(355. 93,IBPRV,. 02,"I") D FULL^VALM1 S IBPRMPT =$S(IBIF=1 :"LAB OR F ACILITY",1 :"PROVIDER ") S DIR(0 )="SA^1:"_ IBPRMPT_"' S OWN IDS; 2:"_IBPRMP T_" IDS FU RNISHED BY AN INSURA NCE COMPAN Y" S DIR(" A")="SELEC T SOURCE O F ID: ",DI R("B")=$P( $P(DIR(0), ":",2),";" ) W ! D ^D IR K DIR W ! I Y'>0 Q S IBSLEV =+Y D EN^V ALM("IBCE PRVPRV MAI NT") Q ;HD R ; -- hea der code N IBC,Z,IBI F S IBIF=" " I $G(IBN PRV) S IBI F=$$GET1^D IQ(355.93, IBNPRV,.02 ,"I") K VA LMHDR S IB C=1 S IBPR MPT=$S(IBI F=1:"Lab o r Facility ",1:"Perfo rming Prov ider") S Z ="** "_$S( $G(IBSLEV) =1:IBPRMPT _"'s Own I Ds (No Spe cific Insu rance Co)" ,1:IBPRMPT _" IDs fro m Insuranc e Co")_" * *" S VALMH DR(IBC)=$J ("",80-$L( Z)\2)_Z,IB C=IBC+1 I $G(IBPRV), '+IBIF S V ALMHDR(IBC )="PROVIDE R : "_$$EX PAND^IBTRE (355.9,.01 ,IBPRV)_$S (IBPRV["VA (200":" (V A PROVIDER )",1:" (NO N-VA PROVI DER)"),IBC =IBC+1 I $ G(IBPRV),+ IBIF S VAL MHDR(IBC)= "Provider: "_$$EXPAN D^IBTRE(35 5.9,.01,IB PRV)_$S(IB IF=1:"(Non -VA Lab or Facility) ",1:""),IB C=IBC+1 I $G(IBINS) D . N PCF, PCDISP . S PCF=$P($G (^DIC(36,+ IBINS,3)), "^",13) . S PCDISP=$ S($G(IBSLE V)'=2!($G( IBPRV)'["V A(200,"):" ",PCF="C": "(Child)", PCF="P":"( Parent)",1 :"") . S V ALMHDR(IBC )=$S(IBIF: "Insurance Co: ",1:" INSURANCE CO: ")_$P( $G(^DIC(36 ,+IBINS,0) ),U)_" "_P CDISP Q ;I NIT ; -- i nit variab les and li st array N IBFILE,DI R,DIC,Y,X, DTOUT,DUOU T,IBIF,AGA IN ; K ^TM P("IB_EDIT ED_IDS",$J ) ; This w ill be to keep track of ID's e dited duri ng this se ssion S IB IF="" I $G (IBNPRV) S IBIF=$$GE T1^DIQ(355 .93,IBNPRV ,.02,"I") ; ; Removi ng Care Un it under c ertain con ditions ; This list is used fo r multiple purposes and not al l have Car e Units As sociated w ith them ; Also, a d ifferent p rotocol me nu is used with thes e ; IBNPRV is a non VA provide r ; IBIF = 1 means t his is a g roup or fa cility, no t an indiv idual. ; I $G(IBNPR V),$G(IBIF )=1 D . S VALM("TITL E")="Secon dary Provi der ID" . K VALMDDF( "CAREUNIT" ) . I VALM CAP["Care Unit" S VA LMCAP=$P(V ALMCAP,"Ca re Unit")_ " "_$P(VAL MCAP,"Care Unit",2) . K VALM(" PROTOCOL") . S Y=$$F IND1^DIC(1 01,,,"IBCE PRVNVA LO F MAINT") . I Y S VA LM("PROTOC OL")=+Y_"; ORD(101," ; I $G(IBP RV) S IBFI LE="IBA(35 5.93,",IBP RV=+IBPRV_ ";"_IBFILE I '$G(IBP RV) D G:$ G(VALMQUIT ) INITQ . S DIR(0)=" SAO^V:VA P ROVIDER;N: NON-VA PRO VIDER",DIR ("A")="(V) A or (N)on -VA provid er: ",DIR( "B")="V" . D ^DIR K DIR . I "N V"'[Y!(Y=" ") S VALMQ UIT=1 Q . S IBFILE=$ S(Y="V":"V A(200,",1: "IBA(355.9 3,") . S D IC=U_IBFIL E,DIC(0)=" AEMQ"_$S(I BFILE["355 .93":"L",1 :"") . S D IC("A")="S elect "_$S (IBFILE["3 55.93":"NO N-",1:"")_ "V.A. PROV IDER NAME: " . S:IBF ILE["355.9 3" DIC("DR ")=".02/// /2;.03;.04 " . F D I $G(IBPRV )!$G(VALMQ UIT) K DIC Q .. D ^D IC .. I $D (DTOUT)!$D (DUOUT) S VALMQUIT=1 Q .. I Y' >0 W !,*7, "This is a required response. Enter '^' to exit" Q .. S IBPR V=+Y_";"_I BFILE ;AGA IN I $G(IB SLEV)=2 D G:$G(AGAI N) AGAIN G :$G(VALMQU IT) INITQ . S AGAIN= 0 . S DIR( 0)="PA^DIC (36,:AEMQ" ,DIR("A")= "Select IN SURANCE CO : ",DIR("? ",1)="Sele ct an INSU RANCE CO t o display its provid er ID's" . D ^DIR K DIR . I $D (DTOUT)!$D (DUOUT) S VALMQUIT=1 Q . S IBI NS=$S(Y>0: +Y,1:"NO") . I $G(IB PRV)'["VA( 200," Q ; Only VA providers . I $P($G (^DIC(36,+ IBINS,3)), "^",13)="C " D S AGA IN=1 Q .. W !,*7,"Th is is a Ch ild Insura nce Compan y. Editing IDs is no t permitte d." ; E D . S IBINS ="NO" D BL DINITQ Q ; BLD ; Buil d initial display ; Assumes IB PRV = the variable p tr for pro v id file (355.9) ; IBINS = th e ien of t he ins co or if null , ALL is a ssumed ; I BSLEV = 1 to display only prov ider defau lt ids ; = 2 to disp lay all pr ovider/ins urance co ids N IB,I BLCT,IBCT, CT,PT,CU,I NS,FT,Z,IB ENT,IB1,IB IF,FORM,CA REUNT,CARE TYP ;JRA IB*2.0*592 Added: FO RM,CAREUNT ,CARETYP ; S IBIF="" I $G(IBPR V)[355.93 S IBIF=$$G ET1^DIQ(35 5.93,+IBPR V,.02,"I") ; K ^TMP( "IBPRV_",$ J),^TMP("I BPRV_SORT" ,$J) K Z0 S (IBENT,I BCT,IBLCT) =0,INS="", IB1=1 F S INS=$S($G (IBINS):IB INS,IBSLEV =1:"*ALL*" ,1:$O(^IBA (355.9,"AU NIQ",IBPRV ,INS))) Q: $S(INS="": 1,$G(IBINS )!(IBSLEV= 1):$D(CU), 1:0) S CU= "",IB1=0 F S CU=$O( ^IBA(355.9 ,"AUNIQ",I BPRV,INS,C U)) Q:CU=" " D . S F T="" F S FT=$O(^IBA (355.9,"AU NIQ",IBPRV ,INS,CU,FT )) Q:FT="" S CT="" F S CT=$O (^IBA(355. 9,"AUNIQ", IBPRV,INS, CU,FT,CT)) Q:CT="" S PT=0 F S PT=$O(^I BA(355.9," AUNIQ",IBP RV,INS,CU, FT,CT,PT)) Q:'PT D .. S Z=0 F S Z=$O(^ IBA(355.9, "AUNIQ",IB PRV,INS,CU ,FT,CT,PT, Z)) Q:'Z S IB=$G(^I BA(355.9,Z ,0)) D ... S ^TMP("I BPRV_SORT" ,$J,$S(INS :$P($G(^DI C(36,+INS, 0)),U)_" " ,1:" ALL") ,PT,FT,CT, CU,Z)=$P(I B,U,7) ; I IBSLEV=1, IBPRV["IBA (355.93",$ P($G(^IBA( 355.93,+IB PRV,0)),U, 12)'="" S ^TMP("IBPR V_SORT",$J ," ALL",+$ $STLIC^IBC EP8(),0,0, "*N/A*",0) =$P(^IBA(3 55.93,+IBP RV,0),U,12 ) S INS="" F S INS= $O(^TMP("I BPRV_SORT" ,$J,INS)) Q:INS="" D . I '$G( IBINS),'IB IF D:IBLCT SET^VALM1 0(IBLCT+1, " ",IBCT) S IBLCT=$S (IBLCT:IBL CT+2,1:1) D SET^VALM 10(IBLCT," INSURANCE CO: "_$S($ E(INS)=" " :"ALL INSU RANCE",1:I NS),$S(IBC T:IBCT,1:1 )) . S PT= "" . F S PT=$O(^TMP ("IBPRV_SO RT",$J,INS ,PT)) Q:PT ="" S FT= "" F S FT =$O(^TMP(" IBPRV_SORT ",$J,INS,P T,FT)) Q:F T="" S CT ="" F S C T=$O(^TMP( "IBPRV_SOR T",$J,INS, PT,FT,CT)) Q:CT="" D .. S CU= "" F S CU =$O(^TMP(" IBPRV_SORT ",$J,INS,P T,FT,CT,CU )) Q:CU="" S Z="" F S Z=$O(^ TMP("IBPRV _SORT",$J, INS,PT,FT, CT,CU,Z)) Q:Z="" S IB=$G(^(Z) ) D ... S IBLCT=IBLC T+1,IBCT=I BCT+1 ... ;JRA IB*2. 0*592 Modi fy to acco mmodate De ntal Form 7 (FT=4) . .. ;S Z0=$ E(IBCT_" " ,1,4)_" "_ $E($$EXPAN D^IBTRE(35 5.9,.06,PT )_$S(PT=$$ STLIC^IBCE P8():"("_$ P($G(^DIC( 5,+$P($G(^ IBA(355.93 ,+IBPRV,0) ),U,7),0)) ,U,2)_")", 1:"")_$J(" ",20),1,20 )_" "_$S(F T=1:"UB-04 ",FT=2:"15 00 ",1:"BO TH ") ;JRA IB*2.0*59 2 ';' ... S FORM=$S( FT=1:"UB-0 4",FT=2:"C MS-1500",F T=4:"J430D ",1:"ALL") ;JRA IB*2 .0*592 ... S Z0=$E(I BCT_" ",1, 4)_" "_$E( $$EXPAND^I BTRE(355.9 ,.06,PT)_$ S(PT=$$STL IC^IBCEP8( ):"("_$P($ G(^DIC(5,+ $P($G(^IBA (355.93,+I BPRV,0)),U ,7),0)),U, 2)_")",1:" ")_$J("",2 0),1,20)_" "_FORM ; JRA IB*2.0 *592 ... ; S Z0=Z0_" "_$E($S(CT =3:"RX",CT =1:"INPT", CT=2:"OUTP T",1:"INPT /OUTPT")_$ J("",11),1 ,11) ;JRA IB*2.0*592 ';' ... S CARETYP=$ E($S(CT=3: "RX",CT=1: "INPT",CT= 2:"OUTPT", 1:"INPT/OU TPT"),1,10 ) ;JRA IB* 2.0*592 .. . S Z0=Z0_ $J("",11-$ L(FORM))_C ARETYP ;J RA IB*2.0* 592 ... ;S Z0=Z0_" " _$E($S(CU' ="*N/A*":$ P($G(^IBA( 355.95,+$G (^IBA(355. 96,CU,0)), 0)),U),1:" ")_$J("",1 5),1,15)_" |" I Z0["M EDICINE" X "*" ;JRA IB*2.0*592 ';' ... S CAREUNT=$ E($S(CU'=" *N/A*":$P( $G(^IBA(35 5.95,+$G(^ IBA(355.96 ,CU,0)),0) ),U),1:"") ,1,12) ;JR A IB*2.0*5 92 ... S C AREUNT=CAR EUNT_$J("" ,12-$L(CAR EUNT)+1) ; JRA IB*2.0 *592 ... S Z0=Z0_($J ("",(12-$L (CARETYP)+ 1))) ;JRA IB*2.0*592 ... S Z0= Z0_CAREUNT ;JRA IB* 2.0*592 .. . ;D SET^V ALM10(IBLC T,Z0_" "_I B,IBCT) ;J RA IB*2.0* 592 ';' .. . D SET^VA LM10(IBLCT ,Z0_IB,IBC T) ;JRA IB *2.0*592 . .. S ^TMP( "IBPRV_",$ J,"ZIDX",I BCT)=$S(Z' =0:Z,1:"LI C^"_IBPRV) I IBSLEV= 1,IBPRV["V A(200" D . N IBP . S IBP=+IBPR V . Q:'$$G ETLIC^IBCE P5D(.IBP) . I IBCT S IBLCT=IBL CT+1 D SET ^VALM10(IB LCT," ",IB CT) . S Z= 0 F S Z=$ O(IBP(Z)) Q:'Z D .. S IBLCT=I BLCT+1,IBC T=IBCT+1 . . D SET^VA LM10(IBLCT ,$E(IBCT_" ",1,4)_$E ($P($G(^DI C(5,+Z,0)) ,U,2)_" ST ATE LICENS E #"_$J("" ,20),1,20) _$J("",39) _IBP(Z),IB CT) .. S ^ TMP("IBPRV _",$J,"ZID X",IBCT)=" LIC^"_+IBP RV K ^TMP( "IBPRV_SOR T",$J) ; I IBLCT=0 D G BLDQ ; No entrie s for ins co selecte d . D SET^ VALM10(1," ") . D SE T^VALM10(2 ," No ID's found for provider "_$S('$G(I BINS):"",1 :"and sele cted insur ance co")) . S IBLCT =2 ;BLDQ K VALMCNT,V ALMBG S VA LMCNT=IBLC T,VALMBG=1 Q ;HELP ; -- help c ode S X="? " D DISP^X QORM1 W !! Q ;EXIT ; -- exit c ode D COPY PROV^IBCEP 5A(IBINS) K IBPRV D CLEAN^VALM 10 K ^TMP( "IBPRV_",$ J),^TMP("I BPRV_SORT" ,$J),IBINS ,IBALL Q ; EXPND ; -- expand co de Q ;SEL( IBDA,MANY) ; Select from provi der id lis t ; IBDA i s passed b y referenc e and IBDA (1) return ed contain ing ; ien' s of the p rovider id records s elected (f ile 355.9) . ; If > 1 entry can be select ed, MANY i s set to 1 N Z S IBD A=0 D EN^V ALM2($G(XQ ORNOD(0)), $S($G(MANY ):"",1:"S" )) S Z=0 F S Z=$O(V ALMY(Z)) Q :'Z S IBD A=IBDA+1,I BDA(IBDA)= $G(^TMP("I BPRV_",$J, "ZIDX",Z)) Q ; | |
| 2101 | ||
| 2102 | ||
| 2103 | Routines | |
| 2104 | Activities | |
| 2105 | Routine Na me | |
| 2106 | IBCEP5B | |
| 2107 | Enhancemen t Category | |
| 2108 | New | |
| 2109 | Modify | |
| 2110 | Delete | |
| 2111 | No Change | |
| 2112 | RTM | |
| 2113 | ||
| 2114 | Related Op tions | |
| 2115 | None | |
| 2116 | Related Ro utines | |
| 2117 | Routines “ Called By” | |
| 2118 | Routines “ Called” | |
| 2119 | ||
| 2120 | ||
| 2121 | ||
| 2122 | ||
| 2123 | Data Dicti onary (DD) Reference s | |
| 2124 | ||
| 2125 | Related Pr otocols | |
| 2126 | None | |
| 2127 | Related In tegration Control Re gistration s (ICRs) | |
| 2128 | None | |
| 2129 | Data Passi ng | |
| 2130 | Input | |
| 2131 | Output Re ference | |
| 2132 | Both | |
| 2133 | Global Re ference | |
| 2134 | Local | |
| 2135 | Input Attr ibute Name and Defin ition | |
| 2136 | Name: | |
| 2137 | Definition : | |
| 2138 | Output Att ribute Nam e and Defi nition | |
| 2139 | Name: | |
| 2140 | Definition : | |
| 2141 | Current Lo gic | |
| 2142 | IBCEP5B ;A LB/TMP - E DI UTILITI ES for pro v ID ;29-S EP-00 ;;2. 0;INTEGRAT ED BILLING ;**137,239 ,232,320,3 48,349**;2 1-MAR-94;B uild 46 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ;NEWI D(IBFILE,I BINS,IBPRV ,IBPTYP,IB IEN,IBF) ; Generic a dd prov id ; at both prov (fil e 355.9) a nd ins co levels (35 5.91) ; IB FILE = 355 .9 or 355. 91 - the f ile being edited ; I BINS = ien of ins co (36) or * ALL* for a ll ins co ; IBPRV = vp ien of billing pr ov ; IBPTY P = ien of prov type (file 355 .97) ; IBI EN = ien o f entry be ing added (req'd) ; IBF = 1 if deleting from ins-r elated opt ions, "" f rom prov-r elated N D IC,DIR,X,Y ,Z,DA,DR,D IE,DO,DD,D LAYGO,DTOU T,DUOUT,IB Q,IBCUND,I B3559,IB35 591,Q,IBDR ,IBID,AFT S IB35591( .03)="",IB PTYP=$G(IB PTYP) F Z= .04,.05,.0 3 D G:Z=" " NEWQ . I $S(Z'=.03 :1,1:$S('$ G(IBINS):0 ,1:$G(IBCU ND))) D Q :Z="" .. N DA .. I Z '=.03 S DI R(0)=IBFIL E_","_Z .. I Z=.03 D ... S DIR (0)="PAO^3 55.95:AEMQ " ... S DI R("S")="I $O(^IBA(35 5.96,""AUN IQ"","_IBI NS_",Y,"_$ G(IB3559(. 04))_","_$ G(IB3559(. 05))_","_I BPTYP_",0) )!($O(^IBA (355.96,"" AUNIQ"","_ IBINS_",Y, "_$G(IB355 9(.04))_", 0,"_IBPTYP _",0)))" . .. S DIR(" S")=DIR("S ")_"!($O(^ IBA(355.96 ,""AUNIQ"" ,"_IBINS_" ,Y,0,"_$G( IB3559(.05 ))_","_IBP TYP_",0))) !($O(^IBA( 355.96,""A UNIQ"","_I BINS_",Y,0 ,0,"_IBPTY P_",0)))" ... S DIR( "?",1)="Ca re unit de scribes ar eas of ser vice and i s assigned by the pa yer, if",D IR("?")=" applicable . Use Care Unit Main tenance to add or mo dify care units." .. ; .. I Z= .04,IBPRV[ "355.93",$ $GET1^DIQ( 355.93,+IB PRV,.02,"I ")=1 D ... I $$GET1^ DIQ(355.97 ,IBPTYP,.0 3,"I")="EI " S $P(DIR (0),U,3)=" K:Y'=1 X", DIR("?")=" Provider I D Qualifie r selected only allo ws institu tional (UB type) for ms" Q ... I $$GET1^D IQ(355.97, IBPTYP,.03 ,"I")="TJ" S $P(DIR( 0),U,3)="K :Y'=2 X",D IR("?")="P rovider ID Qualifier selected only allow s professi onal (CMS- 1500) form s" Q ... N AFT ... S AFT=$$GET 1^DIQ(355. 97,IBPTYP, .07,"I") ; get allow able form type for t his Provid er ID Type ... I AFT ="B" S $P( DIR(0),U,3 )="K:"".0. 1.2.""'[(" ".""_Y_"". "") X",DIR ("?")="Pro vider ID Q ualifier s elected al lows insti tutional, profession al or both " Q ... I AFT="P" S $P(DIR(0), U,3)="K:Y' =2 X",DIR( "?")="Prov ider ID Qu alifier se lected onl y allows p rofessiona l (CMS-150 0) forms" Q ... I AF T="I" S $P (DIR(0),U, 3)="K:Y'=1 X",DIR("? ")="Provid er ID Qual ifier sele cted only allows ins titutional (UB type) forms" Q .. ; .. S DA=0 .. I Z=.04,$P($ G(^IBE(355 .97,+IBPTY P,0)),U,3) ="1A" D SE TDIR(.DIR) .. D ^DIR K DIR .. I $D(DTOUT )!$D(DUOUT ) S Z="" K IB3559,IB 35591 Q .. S IB3559( Z)=$S(Z'=. 03:$P(Y,U) ,1:$S($P(Y ,U)>0:$P(Y ,U),1:"*N/ A*")) . I Z=.05 D .. S IBCUND= $$CAREUN^I BCEP3(IBIN S,IBPTYP,I B3559(.04) ,IB3559(.0 5),IB3559( .05)=3) .. S:'IBCUND !($G(IB355 9(.03))=0) IB3559(.0 3)="*N/A*" .. I '$G( IBINS) S I BINS="*ALL *" . I Z=. 03 D CAREU N^IBCEP5C ; I $D(IB3 559) D . N Q,Z2,Z3,Z 4,Z5,Z6,IB LAST,IBOK, DIR,Y,X . S IBLAST=0 . D DISP^ IBCEP4("Q" ,IBINS,IBP TYP,IB3559 (.04),IB35 59(.05),1) . W !!,"T HE FOLLOWI NG WAS CHO SEN:" . S Q=0 F S Q =$O(Q(Q)) Q:'Q W !, ?3,Q(Q) . I IBCUND W !,?3,"CAR E UNIT: "_ $$EXPAND^I BTRE(355.9 6,.01,IB35 59(.03)) . S Z2=IBIN S,Z3=IB355 91(.03),Z4 =IB3559(.0 4),Z5=IB35 59(.05),Z6 =IBPTYP . S IBOK=1 . ; If both forms, ch k for spec ific . I ' Z4 S IBOK= $$COMBOK^I BCEP5C(IBF ILE,IBPRV_ U_4_U_Z2_U _Z3_U_Z4_U _Z5_U_Z6,1 ,$G(IBFILE )=355.91) . ; If spe cific form , chk for all . I IB OK,Z4 S IB OK=$$COMBO K^IBCEP5C( IBFILE,IBP RV_U_4_U_Z 2_U_Z3_U_Z 4_U_Z5_U_Z 6,0,$G(IBF ILE)=355.9 1) . ; If both care types, chk for speci fic . I IB OK,'Z5 S I BOK=$$COMB OK^IBCEP5C (IBFILE,IB PRV_U_5_U_ Z2_U_Z3_U_ Z4_U_Z5_U_ Z6,1,$G(IB FILE)=355. 91) . ; If specific care type, chk for a ll . I IBO K,Z5 S IBO K=$$COMBOK ^IBCEP5C(I BFILE,IBPR V_U_5_U_Z2 _U_Z3_U_Z4 _U_Z5_U_Z6 ,0,$G(IBFI LE)=355.91 ) . I 'IBO K K IB3559 ,IB35591 . I IBOK D .. S DIR(0 )=IBFILE_" ,.07" .. W ! D ^DIR K DIR .. S IBID=Y .. I $D(DTOU T)!$D(DUOU T) K IB355 9,IB35591 S IBOK=0 Q .. S IBDR =$S(IBFILE =355.9:$S( $G(IBINS): ".02////"_ IBINS_";", 1:""),1:"" )_$S($G(IB CUND):".03 ////"_$S(I B35591(.03 ):IB35591( .03),1:"*N /A*")_";", 1:"")_".04 ////"_IB35 59(.04)_"; .05////"_I B3559(.05) _";.06//// "_IBPTYP_$ S(IBID'="" :";.07//// "_IBID,1:" ") .. ; .. I $G(IBIE N) D ... S DR=IBDR,D A=IBIEN,DI E="^IBA("_ IBFILE_"," ... D ^DI E ... I $D (Y) K IB35 59,IB35591 S IBOK=0 ;NEWQ ; I '$D(IB3559 ),$G(IBIEN ) D Q . N DIR,DIK,D A,X,Y . S DA=IBIEN,D IK="^IBA(" _IBFILE_", " D ^DIK . S DIR(0)= "EA",DIR(" A",1)=$S(' $G(IBOK):" ",1:"PROBL EM ENCOUNT ERED FILIN G THE RECO RD - ")_"R ECORD NOT ADDED",DIR ("A")="PRE SS ENTER t o continue " W ! D ^ DIR K DIR ; ; Save t his for Co py ID acti ons I $G(I BIEN) D . I IBFILE=3 55.91!(IBF ILE=355.9& ($P($G(^IB A(IBFILE,I BIEN,0)),U )["VA(200, ")) D .. N NEXTONE S NEXTONE=$ $NEXTONE^I BCEP5A() . . S ^TMP(" IB_EDITED_ IDS",$J,NE XTONE)=IBI EN_U_"ADD" _U_IBFILE .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE,0)= $G(^IBA(IB FILE,IBIEN ,0)) Q ;CH G(IBFILE,I BDA) ; Gen eric call - edit pro v id ; IBF ILE = 355. 9 or 355.9 1 (file be ing edited ) ; IBDA = ien in fi le ; N DIR ,DIE,DA,DR ,IBCUCHK,I BOK,IB0,IB OLD,X,Y,Z F Z=1:1:3 L +^IBA(IB FILE,IBDA) :5 Q:$T W !,"Attemp ting to lo ck record" I '$T D G CHGQ . W !,"RECORD LOCKED BY ANOTHER U SER - TRY AGAIN LATE R" . D ENT ER(.DIR) . W ! D ^DI R K DIR W ! S (IB0,I BOLD)=$G(^ IBA(IBFILE ,IBDA,0)) G:IB0="" C HGQ F Z=.0 4,.05,.06, .03 S IBOK =$$EDIT(IB FILE,Z,IB0 ,IBOLD,IBD A,0) S:IBO K="*ALL*" IBOK="" Q: $P(IBOK,U, 2) S $P(IB 0,U,Z*100) =$P(IBOK,U ) I $P(IBO K,U,2) S D IR(0)="EA" ,DIR("A")= "NO CHANGE S MADE, PR ESS ENTER TO CONTINU E: " W ! D ^DIR K DI R W ! G CH GQ S IBOK= $$EDIT(IBF ILE,.07,IB 0,IBOLD,IB DA,1) I '$ P(IBOK,U,2 ) S $P(IB0 ,U,7)=$P(I BOK,U) I $ P(IBOK,U,2 )!(IB0=IBO LD) S DIR( 0)="EA",DI R("A")="NO CHANGES M ADE, PRESS ENTER TO CONTINUE: " W ! D ^D IR K DIR W ! G CHGQ S IBCUCHK= $$CUCHK^IB CEP5C(IBDA ,IB0) G:IB CUCHK CHGQ S DR="" F Z=2,4:1:7 ,3 I $P(IB 0,U,Z)'=$P (IBOLD,U,Z ) S DR=DR_ $S(DR'="": ";",1:"")_ (Z/100)_"/ //"_$S($P( IB0,U,Z)'= "@":"/",1: "")_$P(IB0 ,U,Z) I DR '="" D . I IBFILE=35 5.91!(IBFI LE=355.9&( $P(IB0,U)[ "VA(200,") ) D .. N N EXTONE .. S NEXTONE= $$NEXTONE^ IBCEP5A() .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE)=IB DA_U_"MOD" _U_IBFILE_ U_IBDA .. S ^TMP("IB _EDITED_ID S",$J,NEXT ONE,"OLD0" )=IBOLD .. S ^TMP("I B_EDITED_I DS",$J,NEX TONE,0)=IB 0 . S DIE= "^IBA("_IB FILE_",",D A=IBDA D ^ DIECHGQ L -^IBA(IBFI LE,IBDA) Q ;DEL(IBFI LE,IBDA,IB F) ; Delet e prov spe cific ID's ; IBFILE = 355.9 or 355.91 fo r the file ; IBDA = ien of ent ry in file IBFILE ; IBF = 1 if deleting from ins c o-related options, " " ; from p rov-relate d options D DEL^IBCE P5C(IBFILE ,IBDA,$G(I BF)) Q ;ED IT(IBFILE, IBFLD,IB0, IBOLD,IBIE N,IBCK1) ; Generic e dit flds Q $$EDIT^IB CEP5D($G(I BFILE),$G( IBFLD),$G( IB0),$G(IB OLD),$G(IB IEN),$G(IB CK1)) ;SET DIR(DIR) ; Sets dir for BLUE C ROSS only UB-04 form type S DI R("B")="UB -04",$P(DI R(0),U,3)= "K:Y'=1 X" ,DIR("?")= "ONLY UB-0 4 FORM TYP E IS VALID FOR BLUE CROSS ID" Q ;ENTER(D IR) ; S DI R(0)="EA", DIR("A")=" PRESS ENTE R TO CONTI NUE: " Q | |
| 2143 | Modified L ogic (Chan ges are in bold) | |
| 2144 | IBCEP5B ;A LB/TMP - E DI UTILITI ES for pro v ID ;29-S EP-00 ;;2. 0;INTEGRAT ED BILLING ;**137,239 ,232,320,3 48,349,592 **;21-MAR- 94;Build 4 6 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; NEWID(IBFI LE,IBINS,I BPRV,IBPTY P,IBIEN,IB F) ; Gener ic add pro v id ; at both prov (file 355. 9) and ins co levels (355.91) ; IBFILE = 355.9 or 355.91 - t he file be ing edited ; IBINS = ien of in s co (36) or *ALL* f or all ins co ; IBPR V = vp ien of billin g prov ; I BPTYP = ie n of prov type (file 355.97) ; IBIEN = i en of entr y being ad ded (req'd ) ; IBF = 1 if delet ing from i ns-related options, "" from pr ov-related N DIC,DIR ,X,Y,Z,DA, DR,DIE,DO, DD,DLAYGO, DTOUT,DUOU T,IBQ,IBCU ND,IB3559, IB35591,Q, IBDR,IBID, AFT S IB35 591(.03)=" ",IBPTYP=$ G(IBPTYP) F Z=.04,.0 5,.03 D G :Z="" NEWQ . I $S(Z' =.03:1,1:$ S('$G(IBIN S):0,1:$G( IBCUND))) D Q:Z="" .. N DA .. I Z'=.03 S DIR(0)=I BFILE_","_ Z .. I Z=. 03 D ... S DIR(0)="P AO^355.95: AEMQ" ... S DIR("S") ="I $O(^IB A(355.96," "AUNIQ""," _IBINS_",Y ,"_$G(IB35 59(.04))_" ,"_$G(IB35 59(.05))_" ,"_IBPTYP_ ",0))!($O( ^IBA(355.9 6,""AUNIQ" ","_IBINS_ ",Y,"_$G(I B3559(.04) )_",0,"_IB PTYP_",0)) )" ... S D IR("S")=DI R("S")_"!( $O(^IBA(35 5.96,""AUN IQ"","_IBI NS_",Y,0," _$G(IB3559 (.05))_"," _IBPTYP_", 0)))!($O(^ IBA(355.96 ,""AUNIQ"" ,"_IBINS_" ,Y,0,0,"_I BPTYP_",0) ))" ... S DIR("?",1) ="Care uni t describe s areas of service a nd is assi gned by th e payer, i f",DIR("?" )=" applic able. Use Care Unit Maintenanc e to add o r modify c are units. " .. ; .. I Z=.04,IB PRV["355.9 3",$$GET1^ DIQ(355.93 ,+IBPRV,.0 2,"I")=1 D ... I $$G ET1^DIQ(35 5.97,IBPTY P,.03,"I") ="EI" S $P (DIR(0),U, 3)="K:Y'=1 X",DIR("? ")="Provid er ID Qual ifier sele cted only allows ins titutional (UB type) forms" Q ... ;JRA I B*2.0*592 Modify to accommodat e Dental F orm J430D (same logi c as CMS-1 500) ... ; I $$GET1^D IQ(355.97, IBPTYP,.03 ,"I")="TJ" S $P(DIR( 0),U,3)="K :Y'=2 X",D IR("?")="P rovider ID Qualifier selected only allow s professi onal (CMS- 1500) form s" Q ;JRA IB*2.0*592 ';' ... I $$GET1^DI Q(355.97,I BPTYP,.03, "I")="TJ" S $P(DIR(0 ),U,3)="K: Y'=2 X",DI R("?")="Pr ovider ID Qualifier selected o nly allows professio nal (CMS-1 500 & J430 D) forms" Q ;JRA IB *2.0*592 . .. N AFT . .. S AFT=$ $GET1^DIQ( 355.97,IBP TYP,.07,"I ") ; get a llowable f orm type f or this Pr ovider ID Type ... I AFT="B" S $P(DIR(0) ,U,3)="K:" ".0.1.2."" '[("".""_Y _""."") X" ,DIR("?")= "Provider ID Qualifi er selecte d allows i nstitution al, profes sional or both" Q .. . ;JRA IB* 2.0*592 Mo dify to ac commodate Dental For m J430D (s ame logic as CMS-150 0) ... ;I AFT="P" S $P(DIR(0), U,3)="K:Y' =2 X",DIR( "?")="Prov ider ID Qu alifier se lected onl y allows p rofessiona l (CMS-150 0) forms" Q ;JRA IB* 2.0*592 '; ' ... I AF T="P" S $P (DIR(0),U, 3)="K:Y'=2 X",DIR("? ")="Provid er ID Qual ifier sele cted only allows pro fessional (CMS-1500 & J430D) f orms" Q ; JRA IB*2.0 *592 ... I AFT="I" S $P(DIR(0) ,U,3)="K:Y '=1 X",DIR ("?")="Pro vider ID Q ualifier s elected on ly allows institutio nal (UB ty pe) forms" Q .. ; .. S DA=0 .. I Z=.04,$ P($G(^IBE( 355.97,+IB PTYP,0)),U ,3)="1A" D SETDIR(.D IR) .. D ^ DIR K DIR .. I $D(DT OUT)!$D(DU OUT) S Z=" " K IB3559 ,IB35591 Q .. S IB35 59(Z)=$S(Z '=.03:$P(Y ,U),1:$S($ P(Y,U)>0:$ P(Y,U),1:" *N/A*")) . I Z=.05 D .. S IBCU ND=$$CAREU N^IBCEP3(I BINS,IBPTY P,IB3559(. 04),IB3559 (.05),IB35 59(.05)=3) .. S:'IBC UND!($G(IB 3559(.03)) =0) IB3559 (.03)="*N/ A*" .. I ' $G(IBINS) S IBINS="* ALL*" . I Z=.03 D CA REUN^IBCEP 5C ; I $D( IB3559) D . N Q,Z2,Z 3,Z4,Z5,Z6 ,IBLAST,IB OK,DIR,Y,X . S IBLAS T=0 . D DI SP^IBCEP4( "Q",IBINS, IBPTYP,IB3 559(.04),I B3559(.05) ,1) . W !! ,"THE FOLL OWING WAS CHOSEN:" . S Q=0 F S Q=$O(Q(Q )) Q:'Q W !,?3,Q(Q) . I IBCUN D W !,?3," CARE UNIT: "_$$EXPAN D^IBTRE(35 5.96,.01,I B3559(.03) ) . S Z2=I BINS,Z3=IB 35591(.03) ,Z4=IB3559 (.04),Z5=I B3559(.05) ,Z6=IBPTYP . S IBOK= 1 . ; If b oth forms, chk for s pecific . I 'Z4 S IB OK=$$COMBO K^IBCEP5C( IBFILE,IBP RV_U_4_U_Z 2_U_Z3_U_Z 4_U_Z5_U_Z 6,1,$G(IBF ILE)=355.9 1) . ; If specific f orm, chk f or all . I IBOK,Z4 S IBOK=$$CO MBOK^IBCEP 5C(IBFILE, IBPRV_U_4_ U_Z2_U_Z3_ U_Z4_U_Z5_ U_Z6,0,$G( IBFILE)=35 5.91) . ; If both ca re types, chk for sp ecific . I IBOK,'Z5 S IBOK=$$C OMBOK^IBCE P5C(IBFILE ,IBPRV_U_5 _U_Z2_U_Z3 _U_Z4_U_Z5 _U_Z6,1,$G (IBFILE)=3 55.91) . ; If specif ic care ty pe, chk fo r all . I IBOK,Z5 S IBOK=$$COM BOK^IBCEP5 C(IBFILE,I BPRV_U_5_U _Z2_U_Z3_U _Z4_U_Z5_U _Z6,0,$G(I BFILE)=355 .91) . I ' IBOK K IB3 559,IB3559 1 . I IBOK D .. S DI R(0)=IBFIL E_",.07" . . W ! D ^D IR K DIR . . S IBID=Y .. I $D(D TOUT)!$D(D UOUT) K IB 3559,IB355 91 S IBOK= 0 Q .. S I BDR=$S(IBF ILE=355.9: $S($G(IBIN S):".02/// /"_IBINS_" ;",1:""),1 :"")_$S($G (IBCUND):" .03////"_$ S(IB35591( .03):IB355 91(.03),1: "*N/A*")_" ;",1:"")_" .04////"_I B3559(.04) _";.05//// "_IB3559(. 05)_";.06/ ///"_IBPTY P_$S(IBID' ="":";.07/ ///"_IBID, 1:"") .. ; .. I $G(I BIEN) D .. . S DR=IBD R,DA=IBIEN ,DIE="^IBA ("_IBFILE_ "," ... D ^DIE ... I $D(Y) K I B3559,IB35 591 S IBOK =0 ;NEWQ ; I '$D(IB3 559),$G(IB IEN) D Q . N DIR,DI K,DA,X,Y . S DA=IBIE N,DIK="^IB A("_IBFILE _"," D ^DI K . S DIR( 0)="EA",DI R("A",1)=$ S('$G(IBOK ):"",1:"PR OBLEM ENCO UNTERED FI LING THE R ECORD - ") _"RECORD N OT ADDED", DIR("A")=" PRESS ENTE R to conti nue " W ! D ^DIR K D IR ; ; Sav e this for Copy ID a ctions I $ G(IBIEN) D . I IBFIL E=355.91!( IBFILE=355 .9&($P($G( ^IBA(IBFIL E,IBIEN,0) ),U)["VA(2 00,")) D . . N NEXTON E S NEXTON E=$$NEXTON E^IBCEP5A( ) .. S ^TM P("IB_EDIT ED_IDS",$J ,NEXTONE)= IBIEN_U_"A DD"_U_IBFI LE .. S ^T MP("IB_EDI TED_IDS",$ J,NEXTONE, 0)=$G(^IBA (IBFILE,IB IEN,0)) Q ;CHG(IBFIL E,IBDA) ; Generic ca ll - edit prov id ; IBFILE = 3 55.9 or 35 5.91 (file being edi ted) ; IBD A = ien in file ; N DIR,DIE,DA ,DR,IBCUCH K,IBOK,IB0 ,IBOLD,X,Y ,Z F Z=1:1 :3 L +^IBA (IBFILE,IB DA):5 Q:$T W !,"Att empting to lock reco rd" I '$T D G CHGQ . W !,"REC ORD LOCKED BY ANOTHE R USER - T RY AGAIN L ATER" . D ENTER(.DIR ) . W ! D ^DIR K DIR W ! S (IB 0,IBOLD)=$ G(^IBA(IBF ILE,IBDA,0 )) G:IB0=" " CHGQ F Z =.04,.05,. 06,.03 S I BOK=$$EDIT (IBFILE,Z, IB0,IBOLD, IBDA,0) S: IBOK="*ALL *" IBOK="" Q:$P(IBOK ,U,2) S $P (IB0,U,Z*1 00)=$P(IBO K,U) I $P( IBOK,U,2) S DIR(0)=" EA",DIR("A ")="NO CHA NGES MADE, PRESS ENT ER TO CONT INUE: " W ! D ^DIR K DIR W ! G CHGQ S IB OK=$$EDIT( IBFILE,.07 ,IB0,IBOLD ,IBDA,1) I '$P(IBOK, U,2) S $P( IB0,U,7)=$ P(IBOK,U) I $P(IBOK, U,2)!(IB0= IBOLD) S D IR(0)="EA" ,DIR("A")= "NO CHANGE S MADE, PR ESS ENTER TO CONTINU E: " W ! D ^DIR K DI R W ! G CH GQ S IBCUC HK=$$CUCHK ^IBCEP5C(I BDA,IB0) G :IBCUCHK C HGQ S DR=" " F Z=2,4: 1:7,3 I $P (IB0,U,Z)' =$P(IBOLD, U,Z) S DR= DR_$S(DR'= "":";",1:" ")_(Z/100) _"///"_$S( $P(IB0,U,Z )'="@":"/" ,1:"")_$P( IB0,U,Z) I DR'="" D . I IBFILE =355.91!(I BFILE=355. 9&($P(IB0, U)["VA(200 ,")) D .. N NEXTONE .. S NEXTO NE=$$NEXTO NE^IBCEP5A () .. S ^T MP("IB_EDI TED_IDS",$ J,NEXTONE) =IBDA_U_"M OD"_U_IBFI LE_U_IBDA .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE,"OL D0")=IBOLD .. S ^TMP ("IB_EDITE D_IDS",$J, NEXTONE,0) =IB0 . S D IE="^IBA(" _IBFILE_", ",DA=IBDA D ^DIECHGQ L -^IBA(I BFILE,IBDA ) Q ;DEL(I BFILE,IBDA ,IBF) ; De lete prov specific I D's ; IBFI LE = 355.9 or 355.91 for the f ile ; IBDA = ien of entry in f ile IBFILE ; IBF = 1 if deleti ng from in s co-relat ed options , "" ; fro m prov-rel ated optio ns D DEL^I BCEP5C(IBF ILE,IBDA,$ G(IBF)) Q ;EDIT(IBFI LE,IBFLD,I B0,IBOLD,I BIEN,IBCK1 ) ; Generi c edit fld s Q $$EDIT ^IBCEP5D($ G(IBFILE), $G(IBFLD), $G(IB0),$G (IBOLD),$G (IBIEN),$G (IBCK1)) ; SETDIR(DIR ) ; Sets d ir for BLU E CROSS on ly UB-04 f orm type S DIR("B")= "UB-04",$P (DIR(0),U, 3)="K:Y'=1 X",DIR("? ")="ONLY U B-04 FORM TYPE IS VA LID FOR BL UE CROSS I D" Q ;ENTE R(DIR) ; S DIR(0)="E A",DIR("A" )="PRESS E NTER TO CO NTINUE: " Q | |
| 2145 | ||
| 2146 | ||
| 2147 | Routines | |
| 2148 | Activities | |
| 2149 | Routine Na me | |
| 2150 | IBCEP5C | |
| 2151 | Enhancemen t Category | |
| 2152 | New | |
| 2153 | Modify | |
| 2154 | Delete | |
| 2155 | No Change | |
| 2156 | RTM | |
| 2157 | ||
| 2158 | Related Op tions | |
| 2159 | None | |
| 2160 | Related Ro utines | |
| 2161 | Routines “ Called By” | |
| 2162 | Routines “ Called” | |
| 2163 | ||
| 2164 | ||
| 2165 | ||
| 2166 | ||
| 2167 | Data Dicti onary (DD) Reference s | |
| 2168 | ||
| 2169 | Related Pr otocols | |
| 2170 | None | |
| 2171 | Related In tegration Control Re gistration s (ICRs) | |
| 2172 | None | |
| 2173 | Data Passi ng | |
| 2174 | Input | |
| 2175 | Output Re ference | |
| 2176 | Both | |
| 2177 | Global Re ference | |
| 2178 | Local | |
| 2179 | Input Attr ibute Name and Defin ition | |
| 2180 | Name: | |
| 2181 | Definition : | |
| 2182 | Output Att ribute Nam e and Defi nition | |
| 2183 | Name: | |
| 2184 | Definition : | |
| 2185 | Current Lo gic | |
| 2186 | IBCEP5C ;A LB/TMP - E DI UTILITI ES for pro vider ID ; 02-NOV-00 ;;2.0;INTE GRATED BIL LING;**137 ,239,232,3 20,348,349 **;21-MAR- 94;Build 4 6 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; COMBOK(IBF ILE,IBDAT, IBALL,IBF) ; Generic ask if co nflict, sh ould id re c still ; be added? ; IBFILE = 355.9 or 355.91 for the file being edit ed ; IBDAT = var ptr prov ien (355.9) ^ pc to chec k ^ ; ins co ien or *ALL* ^ ca re unit or *N/A* ^ ; form type code ^ ca re type co de ^ prov id type pt r ; IBALL = flag: ; 0 = Indivi dual entry selected - check fo r existing ALL entry ; 1 = 'AL L' selecte d - check for existi ng individ ual ones ; IBF = 1 i f deleting from ins co-related options, "" ; from provider-r elated opt ions ; Ret urns 1 if ok to cont inue, 0 if not ; N X ,Y,Q,DIR,Z ,IBD,IBDD, IBOK,IBSPE C S IBALL= $G(IBALL), IBOK=1 S I BD=+$P(IBD AT,U,2),IB DD=$S(IBD= 4:5,1:4) F Z=2:1:6 D . I IBD'= Z,$P(IBDAT ,U,Z+1)'=" " S Z(Z)=$ P(IBDAT,U, Z+1) Q . I IBD=Z S I BD(Z)=$P(I BDAT,U,Z+1 ) K IBSPEC I IBALL D ; Check for specif ic . N X0, X1 . S X1= 0 . F S X 1=$O(^IBA( IBFILE,"AC ",$S(IBFIL E=355.9:Z( 6),1:Z(2)) ,$S(IBFILE =355.9:Z(2 ),1:Z(6)), $S(IBFILE= 355.9:$P(I BDAT,U),1: Z(3)),X1)) Q:'X1 S X0=$G(^IBA (IBFILE,X1 ,0)) I $S( IBFILE=355 .9:$P(X0,U ,3)=Z(3),1 :1) D .. I $P(X0,U,I BD)'=IBD(I BD),"12"[$ P(X0,U,IBD ),($P(X0,U ,IBDD)=Z(I BDD)!($P(X 0,U,IBDD)= 0)!(Z(IBDD )=0&(IBD(I BD)=0))) S X1($P(X0, U,IBD))=X1 Q .. I IB D(IBD)=0,Z (IBDD)=0 S X1(0)=X1 . S X0=0 F S X0=$O( X1(X0)) Q: X0="" D . . S IBSPEC =$S($G(IBS PEC)'="":I BSPEC_" ", 1:"")_$P($ S(IBD=4:"U B-04^CMS-1 500",1:"IN PT^OUTPT") ,U,X0)_" O NLY" . I $ D(X1(0)) S IBSPEC=$S ($G(IBSPEC )'="":IBSP EC_" ",1:" ")_$S(IBD= 4:"BOTH UB -04 and CM S-1500 for m type AND BOTH INPT and OUTPT care type ",1:"BOTH INPT and O UTPT care type AND B OTH UB-04 and CMS-15 00 form ty pe") . ; I 'IBALL D . N X0,X1 . S X1=0 . F S X1=$ O(^IBA(IBF ILE,"AC",$ S(IBFILE=3 55.9:Z(6), 1:Z(2)),$S (IBFILE=35 5.9:Z(2),1 :Z(6)),$S( IBFILE=355 .9:$P(IBDA T,U),1:Z(3 )),X1)) Q: 'X1 D .. S X0=$G(^I BA(IBFILE, X1,0)) .. I $S(IBFIL E=355.9:$P (X0,U,16)= Z(3),1:1), $P(X0,U,IB D)=0,$S($P (X0,U,IBDD )=Z(IBDD): 1,1:$P(X0, U,IBDD)=0) S IBSPEC= "" ; I $D( IBSPEC) D . N X0,X1, TEXT,IBWHA T . S IBWH AT=$S(IBFI LE=355.9:$ S($G(IBF): "INS CO AN D PROVIDER ",1:"PROVI DER"),1:"I NSURANCE C O") . S X0 =$S($D(IBD (4)):"UB-0 4^CMS-1500 ",1:"INPT^ OUTPT") . S X1=$S($D (IBD(4)):" FORM TYPE" ,1:"CARE T YPE") . S DIR(0)="YA " . S TEXT (1)="WARNI NG ... POT ENTIAL CON FLICT DETE CTED!!" . S TEXT(2)= " YOUR NEW COMBINATI ON APPLIES TO "_$S(I BALL:"BOTH "_$S(IBD= 4:"FORM ", 1:"INPT AN D OUTPT CA RE ")_"TYP ES",1:"ONL Y "_$P(X0, U,IBD(IBD) )_" "_X1) . S TEXT(3 )=" THIS S AME COMBIN ATION ALRE ADY EXISTS FOR THE " _IBWHAT_" & "_$S('IB ALL:"ALL " _X1_"S",1: "SPECIFIC "_X1_"(S): ") . S:IBS PEC'="" TE XT(4)=$J(" ",4)_IBSPE C . S TEXT ($S($D(TEX T(4)):5,1: 4))=" " . S DIR("A") ="ARE YOU SURE YOU S TILL WANT TO ADD THI S RECORD?: " . S DIR ("?",1)=" " . S DIR( "?",2)="Th is combina tion appea rs to be c onflicting with one( s) already on file." . S DIR(" ?",3)="It has alread y been def ined for t he "_$$LOW ^XLFSTR(IB WHAT)_" fo r "_$S(IBA LL:"at lea st 1 speci fic ",1:"A LL ")_$S(I BD=4:"form ",1:"care" )_" type"_ $S(IBALL:" .",1:"s.") . S DIR(" ?")="Respo nd NO to r eject this conflicti ng record or YES to continue o n to add i t in spite of the ap parent con flict.",DI R("B")="NO " . W !! F Q=1:1 Q:' $D(TEXT(Q) ) W TEXT(Q ),! . D ^D IR K DIR W ! . S IBO K=(Y=1) Q IBOK ;CARE UN ;Called from NEWI D^IBCEP5B to check f or existin g record c ombination N DIR I I BFILE'=355 .9 D . S I B35591(.03 )=IB3559(. 03) . I "0 "[IB35591( .03) S IB3 5591(.03)= "*N/A*" . I IB35591( .03)'="*N/ A*" S IB35 591(.03)=$ O(^IBA(355 .96,"AUNIQ ",IBINS,IB 3559(.03), IB3559(.04 ),IB3559(. 05),IBPTYP ,"")) I 'I B35591(.03 ) D .. S I B35591(.03 )=$O(^IBA( 355.96,"AU NIQ",IBINS ,IB3559(.0 3),IB3559( .04),0,IBP TYP,"")) I 'IB35591( .03) D ... S IB35591 (.03)=$O(^ IBA(355.96 ,"AUNIQ",I BINS,IB355 9(.03),0,I B3559(.05) ,IBPTYP,"" )) I 'IB35 591(.03) D .... S IB 35591(.03) =$O(^IBA(3 55.96,"AUN IQ",IBINS, IB3559(.03 ),0,0,IBPT YP,"")) . I $D(^IBA( 355.91,"AU NIQ",IBINS ,IB35591(. 03),IB3559 (.04),IB35 59(.05),IB PTYP)) D Q .. S DIR (0)="EA",D IR("A",1)= "This reco rd already exists - NOT ADDED" ,DIR("A")= "PRESS the ENTER key to contin ue" W ! D ^DIR K DIR ,IB3559,IB 35591 W ! I IBFILE=3 55.9 D . S IB35591(. 03)=IB3559 (.03) . I "0"[IB3559 1(.03) S I B35591(.03 )="*N/A*" . I IB3559 1(.03)'="* N/A*" S IB 35591(.03) =$O(^IBA(3 55.96,"AUN IQ",IBINS, IB3559(.03 ),IB3559(. 04),IB3559 (.05),IBPT YP,"")) I 'IB35591(. 03) D .. S IB35591(. 03)=$O(^IB A(355.96," AUNIQ",IBI NS,IB3559( .03),IB355 9(.04),0,I BPTYP,"")) I 'IB3559 1(.03) D . .. S IB355 91(.03)=$O (^IBA(355. 96,"AUNIQ" ,IBINS,IB3 559(.03),0 ,IB3559(.0 5),IBPTYP, "")) I 'IB 35591(.03) D .... S IB35591(.0 3)=$O(^IBA (355.96,"A UNIQ",IBIN S,IB3559(. 03),0,0,IB PTYP,"")) . I $D(^IB A(355.9,"A UNIQ",IBPR V,IBINS,IB 35591(.03) ,IB3559(.0 4),IB3559( .05),IBPTY P)) D Q . . S DIR(0) ="EA",DIR( "A",1)="Th is record already ex ists - NOT ADDED",DI R("A")="PR ESS the EN TER key to continue" W ! D ^DI R K DIR,IB 3559,IB355 91 W ! Q ; DEL(IBFILE ,IBDA,IBF) ; Delete prov speci fic ID's ; IBFILE = 355.9 or 3 55.91 for the file ; IBDA = ie n of entry in file I BFILE ; IB F = 1 if d eleting fr om ins co- related op tions, "" ; from pro v-related options N IB0,IBLAST ,IBX,DIK,D A,DIR,X,Y, Z F Z=1:1: 3 L +^IBA( IBFILE,IBD A):5 Q:$T I '$T D G DELQ . W !,"RECORD IS LOCKED BY ANOTHER USER - TR Y AGAIN LA TER" . D E NTER^IBCEP 5B(.DIR) . W ! D ^DI R K DIR W ! S IB0=$G (^IBA(IBFI LE,IBDA,0) ) S IBX=0 S IBX=IBX+ 1,DIR("A", IBX)=" PRO VIDER: "_$ S(IBFILE=3 55.9:$$EXP AND^IBTRE( 355.9,.01, $P(IB0,U)) ,1:"*ALL*" ) D DISP^I BCEP4("DIR (""A"")",$ P(IB0,U,$S (IBFILE=35 5.9:2,1:1) ),$P(IB0,U ,6),$P(IB0 ,U,4),$P(I B0,U,5),IB X+1,.IBLAS T) I $P(IB 0,U,3)'="" S DIR("A" ,IBLAST+1) ="CARE UNI T: "_$$EXP AND^IBTRE( 355.91,.03 ,$P(IB0,U, 3)) S DIR( "A",IBLAST +2)=" PROV ID: "_$P( IB0,U,7),D IR("A",IBL AST+3)=" " S DIR("A" )="OK TO D ELETE THIS "_$S($G(I BF):"INSUR ANCE COMPA NY ",1:"") _"PROVIDER ID RECORD ?: ",DIR(" B")="NO" S DIR(0)="Y A" W ! D ^ DIR K DIR W ! I Y'=1 G DELQ I IBDA>0 D . I IBFILE= 355.91!(IB FILE=355.9 &($P($G(^I BA(IBFILE, IBDA,0)),U )["VA(200, ")) D .. N NEXTONE S NEXTONE=$ $NEXTONE^I BCEP5A() . . S ^TMP(" IB_EDITED_ IDS",$J,NE XTONE)=IBD A_U_"DEL"_ U_IBFILE_U _IBDA .. S ^TMP("IB_ EDITED_IDS ",$J,NEXTO NE,0)=$G(^ IBA(IBFILE ,IBDA,0)) . S DA=IBD A,DIK="^IB A("_IBFILE _"," D ^DI KDELQ L -^ IBA(IBFILE ,IBDA) Q ; CUCHK(IBDA ,IB0) ;Cal led from C HG^IBCEP5B to check for existi ng combina tion ; dur ing edit ; IBDA = t he ien of the record being edi ted ; IB0 = Proposed changed 0 node of t he entry i n the file ; FUNCTIO N RETURNS 0 if no du plicate fo und, 1 if record alr eady exist s N Z,IBCU CHK,DIR,X, Y S IBCUCH K=0 I IBFI LE=355.91 S Z=+$O(^I BA(355.91, "AUNIQ",$P (IB0,U,1), $S($P(IB0, U,3)="@":" *N/A*",$P( IB0,U,3):$ P(IB0,U,3) ,1:$P(IB0, U,10)),$P( IB0,U,4),$ P(IB0,U,5) ,$P(IB0,U, 6),0)) I Z ,Z'=IBDA S IBCUCHK=1 I IBFILE= 355.9 D . N X,X1 . S X=$S($P(I B0,U,2):$P (IB0,U,2), 1:$P(IB0,U ,15)) S:X= "" X="*ALL *" . S X1= $S($P(IB0, U,3):$P(IB 0,U,3),$P( IB0,U,3)=" @":"",1:$P (IB0,U,16) ) S:X1="" X1="*N/A*" . S Z=+$O (^IBA(355. 9,"AUNIQ", $P(IB0,U,1 ),X,X1,$P( IB0,U,4),$ P(IB0,U,5) ,$P(IB0,U, 6),0)) I Z ,Z'=IBDA S IBCUCHK=1 I IBCUCHK D . S DIR (0)="EA",D IR("A",1)= "This comb ination al ready exis ts - RECOR D NOT CHAN GED",DIR(" A")="PRESS the ENTER key to co ntinue" W ! D ^DIR K DIR W ! Q IBCUCHK ; | |
| 2187 | Modified L ogic (Chan ges are in bold) | |
| 2188 | IBCEP5C ;A LB/TMP - E DI UTILITI ES for pro vider ID ; 02-NOV-00 ;;2.0;INTE GRATED BIL LING;**137 ,239,232,3 20,348,349 ,592**;21- MAR-94;Bui ld 46 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ;COMBOK (IBFILE,IB DAT,IBALL, IBF) ; Gen eric ask i f conflict , should i d rec stil l ; be add ed? ; IBFI LE = 355.9 or 355.91 for the f ile being edited ; I BDAT = var ptr prov ien (355.9 ) ^ pc to check ^ ; ins co ien or *ALL* ^ care uni t or *N/A* ^ ; form type code ^ care typ e code ^ p rov id typ e ptr ; IB ALL = flag : ; 0 = In dividual e ntry selec ted - chec k for exis ting ALL e ntry ; 1 = 'ALL' sel ected - ch eck for ex isting ind ividual on es ; IBF = 1 if dele ting from ins co-rel ated optio ns, "" ; f rom provid er-related options ; Returns 1 if ok to continue, 0 if not ; N X,Y,Q,D IR,Z,IBD,I BDD,IBOK,I BSPEC S IB ALL=$G(IBA LL),IBOK=1 S IBD=+$P (IBDAT,U,2 ),IBDD=$S( IBD=4:5,1: 4) F Z=2:1 :6 D . I I BD'=Z,$P(I BDAT,U,Z+1 )'="" S Z( Z)=$P(IBDA T,U,Z+1) Q . I IBD=Z S IBD(Z)= $P(IBDAT,U ,Z+1) K IB SPEC I IBA LL D ; Ch eck for sp ecific . N X0,X1 . S X1=0 . F S X1=$O(^ IBA(IBFILE ,"AC",$S(I BFILE=355. 9:Z(6),1:Z (2)),$S(IB FILE=355.9 :Z(2),1:Z( 6)),$S(IBF ILE=355.9: $P(IBDAT,U ),1:Z(3)), X1)) Q:'X1 S X0=$G( ^IBA(IBFIL E,X1,0)) I $S(IBFILE =355.9:$P( X0,U,3)=Z( 3),1:1) D .. I $P(X0 ,U,IBD)'=I BD(IBD),"1 2"[$P(X0,U ,IBD),($P( X0,U,IBDD) =Z(IBDD)!( $P(X0,U,IB DD)=0)!(Z( IBDD)=0&(I BD(IBD)=0) )) S X1($P (X0,U,IBD) )=X1 Q .. I IBD(IBD) =0,Z(IBDD) =0 S X1(0) =X1 . S X0 =0 F S X0 =$O(X1(X0) ) Q:X0="" D .. ;JRA IB*2.0*59 2 Modify f or Dental form J340D (treat th e same as the CMS-15 00) .. ;S IBSPEC=$S( $G(IBSPEC) '="":IBSPE C_" ",1:"" )_$P($S(IB D=4:"UB-04 ^CMS-1500" ,1:"INPT^O UTPT"),U,X 0)_" ONLY" ;JRA IB*2 .0*592 ';' .. S IBSP EC=$S($G(I BSPEC)'="" :IBSPEC_" ",1:"")_$P ($S(IBD=4: "UB-04^CMS -1500/J430 D",1:"INPT ^OUTPT"),U ,X0)_" ONL Y" ;JRA I B*2.0*592 . ;I $D(X1 (0)) S IBS PEC=$S($G( IBSPEC)'=" ":IBSPEC_" ",1:"")_$ S(IBD=4:"B OTH UB-04 and CMS-15 00 form ty pe AND BOT H INPT and OUTPT car e type",1: "BOTH INPT and OUTPT care type AND BOTH UB-04 and CMS-1500 f orm type") ;JRA IB*2 .0*592 ';' . I $D(X1( 0)) S IBSP EC=$S($G(I BSPEC)'="" :IBSPEC_" ",1:"")_$S (IBD=4:"UB -04, CMS-1 500 and J4 30D form t ypes AND B OTH INPT a nd OUTPT c are type", 1:"BOTH IN PT and OUT PT care ty pe AND UB- 04, CMS-15 00 and J43 0D form ty pes") ;JRA IB*2.0*59 2 . ; I 'I BALL D . N X0,X1 . S X1=0 . F S X1=$O(^ IBA(IBFILE ,"AC",$S(I BFILE=355. 9:Z(6),1:Z (2)),$S(IB FILE=355.9 :Z(2),1:Z( 6)),$S(IBF ILE=355.9: $P(IBDAT,U ),1:Z(3)), X1)) Q:'X1 D .. S X 0=$G(^IBA( IBFILE,X1, 0)) .. I $ S(IBFILE=3 55.9:$P(X0 ,U,16)=Z(3 ),1:1),$P( X0,U,IBD)= 0,$S($P(X0 ,U,IBDD)=Z (IBDD):1,1 :$P(X0,U,I BDD)=0) S IBSPEC="" ; I $D(IBS PEC) D . N X0,X1,TEX T,IBWHAT . S IBWHAT= $S(IBFILE= 355.9:$S($ G(IBF):"IN S CO AND P ROVIDER",1 :"PROVIDER "),1:"INSU RANCE CO") . ;JRA IB *2.0*592 M odify for Dental for m J340D (t reat the s ame as the CMS-1500) . ;S X0=$ S($D(IBD(4 )):"UB-04^ CMS-1500", 1:"INPT^OU TPT") ;JRA IB*2.0*59 2 ';' . S X0=$S($D(I BD(4)):"UB -04^CMS-15 00/J430D", 1:"INPT^OU TPT") ;JRA IB*2.0*59 2 . S X1=$ S($D(IBD(4 )):"FORM T YPE",1:"CA RE TYPE") . S DIR(0) ="YA" . S TEXT(1)="W ARNING ... POTENTIAL CONFLICT DETECTED!! " . S TEXT (2)=" YOUR NEW COMBI NATION APP LIES TO "_ $S(IBALL:" BOTH "_$S( IBD=4:"FOR M ",1:"INP T AND OUTP T CARE ")_ "TYPES",1: "ONLY "_$P (X0,U,IBD( IBD))_" "_ X1) . S TE XT(3)=" TH IS SAME CO MBINATION ALREADY EX ISTS FOR T HE "_IBWHA T_" & "_$S ('IBALL:"A LL "_X1_"S ",1:"SPECI FIC "_X1_" (S):") . S :IBSPEC'=" " TEXT(4)= $J("",4)_I BSPEC . S TEXT($S($D (TEXT(4)): 5,1:4))=" " . S DIR( "A")="ARE YOU SURE Y OU STILL W ANT TO ADD THIS RECO RD?: " . S DIR("?",1 )=" " . S DIR("?",2) ="This com bination a ppears to be conflic ting with one(s) alr eady on fi le." . S D IR("?",3)= "It has al ready been defined f or the "_$ $LOW^XLFST R(IBWHAT)_ " for "_$S (IBALL:"at least 1 s pecific ", 1:"ALL ")_ $S(IBD=4:" form",1:"c are")_" ty pe"_$S(IBA LL:".",1:" s.") . S D IR("?")="R espond NO to reject this confl icting rec ord or YES to contin ue on to a dd it in s pite of th e apparent conflict. ",DIR("B") ="NO" . W !! F Q=1:1 Q:'$D(TEX T(Q)) W TE XT(Q),! . D ^DIR K D IR W ! . S IBOK=(Y=1 ) Q IBOK ; CAREUN ;Ca lled from NEWID^IBCE P5B to che ck for exi sting reco rd combina tion N DIR I IBFILE' =355.9 D . S IB35591 (.03)=IB35 59(.03) . I "0"[IB35 591(.03) S IB35591(. 03)="*N/A* " . I IB35 591(.03)'= "*N/A*" S IB35591(.0 3)=$O(^IBA (355.96,"A UNIQ",IBIN S,IB3559(. 03),IB3559 (.04),IB35 59(.05),IB PTYP,"")) I 'IB35591 (.03) D .. S IB35591 (.03)=$O(^ IBA(355.96 ,"AUNIQ",I BINS,IB355 9(.03),IB3 559(.04),0 ,IBPTYP,"" )) I 'IB35 591(.03) D ... S IB3 5591(.03)= $O(^IBA(35 5.96,"AUNI Q",IBINS,I B3559(.03) ,0,IB3559( .05),IBPTY P,"")) I ' IB35591(.0 3) D .... S IB35591( .03)=$O(^I BA(355.96, "AUNIQ",IB INS,IB3559 (.03),0,0, IBPTYP,"") ) . I $D(^ IBA(355.91 ,"AUNIQ",I BINS,IB355 91(.03),IB 3559(.04), IB3559(.05 ),IBPTYP)) D Q .. S DIR(0)="E A",DIR("A" ,1)="This record alr eady exist s - NOT AD DED",DIR(" A")="PRESS the ENTER key to co ntinue" W ! D ^DIR K DIR,IB355 9,IB35591 W ! I IBFI LE=355.9 D . S IB355 91(.03)=IB 3559(.03) . I "0"[IB 35591(.03) S IB35591 (.03)="*N/ A*" . I IB 35591(.03) '="*N/A*" S IB35591( .03)=$O(^I BA(355.96, "AUNIQ",IB INS,IB3559 (.03),IB35 59(.04),IB 3559(.05), IBPTYP,"") ) I 'IB355 91(.03) D .. S IB355 91(.03)=$O (^IBA(355. 96,"AUNIQ" ,IBINS,IB3 559(.03),I B3559(.04) ,0,IBPTYP, "")) I 'IB 35591(.03) D ... S I B35591(.03 )=$O(^IBA( 355.96,"AU NIQ",IBINS ,IB3559(.0 3),0,IB355 9(.05),IBP TYP,"")) I 'IB35591( .03) D ... . S IB3559 1(.03)=$O( ^IBA(355.9 6,"AUNIQ", IBINS,IB35 59(.03),0, 0,IBPTYP," ")) . I $D (^IBA(355. 9,"AUNIQ", IBPRV,IBIN S,IB35591( .03),IB355 9(.04),IB3 559(.05),I BPTYP)) D Q .. S DI R(0)="EA", DIR("A",1) ="This rec ord alread y exists - NOT ADDED ",DIR("A") ="PRESS th e ENTER ke y to conti nue" W ! D ^DIR K DI R,IB3559,I B35591 W ! Q ;DEL(IB FILE,IBDA, IBF) ; Del ete prov s pecific ID 's ; IBFIL E = 355.9 or 355.91 for the fi le ; IBDA = ien of e ntry in fi le IBFILE ; IBF = 1 if deletin g from ins co-relate d options, "" ; from prov-rela ted option s N IB0,IB LAST,IBX,D IK,DA,DIR, X,Y,Z F Z= 1:1:3 L +^ IBA(IBFILE ,IBDA):5 Q :$T I '$T D G DELQ . W !,"REC ORD IS LOC KED BY ANO THER USER - TRY AGAI N LATER" . D ENTER^I BCEP5B(.DI R) . W ! D ^DIR K DI R W ! S IB 0=$G(^IBA( IBFILE,IBD A,0)) S IB X=0 S IBX= IBX+1,DIR( "A",IBX)=" PROVIDER: "_$S(IBFI LE=355.9:$ $EXPAND^IB TRE(355.9, .01,$P(IB0 ,U)),1:"*A LL*") D DI SP^IBCEP4( "DIR(""A"" )",$P(IB0, U,$S(IBFIL E=355.9:2, 1:1)),$P(I B0,U,6),$P (IB0,U,4), $P(IB0,U,5 ),IBX+1,.I BLAST) I $ P(IB0,U,3) '="" S DIR ("A",IBLAS T+1)="CARE UNIT: "_$ $EXPAND^IB TRE(355.91 ,.03,$P(IB 0,U,3)) S DIR("A",IB LAST+2)=" PROV ID: " _$P(IB0,U, 7),DIR("A" ,IBLAST+3) =" " S DIR ("A")="OK TO DELETE THIS "_$S( $G(IBF):"I NSURANCE C OMPANY ",1 :"")_"PROV IDER ID RE CORD?: ",D IR("B")="N O" S DIR(0 )="YA" W ! D ^DIR K DIR W ! I Y'=1 G DEL Q I IBDA>0 D . I IBF ILE=355.91 !(IBFILE=3 55.9&($P($ G(^IBA(IBF ILE,IBDA,0 )),U)["VA( 200,")) D .. N NEXTO NE S NEXTO NE=$$NEXTO NE^IBCEP5A () .. S ^T MP("IB_EDI TED_IDS",$ J,NEXTONE) =IBDA_U_"D EL"_U_IBFI LE_U_IBDA .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE,0)= $G(^IBA(IB FILE,IBDA, 0)) . S DA =IBDA,DIK= "^IBA("_IB FILE_"," D ^DIKDELQ L -^IBA(IB FILE,IBDA) Q ;CUCHK( IBDA,IB0) ;Called fr om CHG^IBC EP5B to ch eck for ex isting com bination ; during ed it ; IBDA = the ien of the re cord being edited ; IB0 = Prop osed chang ed 0 node of the ent ry in the file ; FUN CTION RETU RNS 0 if n o duplicat e found, 1 if record already e xists N Z, IBCUCHK,DI R,X,Y S IB CUCHK=0 I IBFILE=355 .91 S Z=+$ O(^IBA(355 .91,"AUNIQ ",$P(IB0,U ,1),$S($P( IB0,U,3)=" @":"*N/A*" ,$P(IB0,U, 3):$P(IB0, U,3),1:$P( IB0,U,10)) ,$P(IB0,U, 4),$P(IB0, U,5),$P(IB 0,U,6),0)) I Z,Z'=IB DA S IBCUC HK=1 I IBF ILE=355.9 D . N X,X1 . S X=$S( $P(IB0,U,2 ):$P(IB0,U ,2),1:$P(I B0,U,15)) S:X="" X=" *ALL*" . S X1=$S($P( IB0,U,3):$ P(IB0,U,3) ,$P(IB0,U, 3)="@":"", 1:$P(IB0,U ,16)) S:X1 ="" X1="*N /A*" . S Z =+$O(^IBA( 355.9,"AUN IQ",$P(IB0 ,U,1),X,X1 ,$P(IB0,U, 4),$P(IB0, U,5),$P(IB 0,U,6),0)) I Z,Z'=IB DA S IBCUC HK=1 I IBC UCHK D . S DIR(0)="E A",DIR("A" ,1)="This combinatio n already exists - R ECORD NOT CHANGED",D IR("A")="P RESS the E NTER key t o continue " W ! D ^D IR K DIR W ! Q IBCUC HK ; | |
| 2189 | ||
| 2190 | ||
| 2191 | Routines | |
| 2192 | Activities | |
| 2193 | Routine Na me | |
| 2194 | IBCEP7 | |
| 2195 | Enhancemen t Category | |
| 2196 | New | |
| 2197 | Modify | |
| 2198 | Delete | |
| 2199 | No Change | |
| 2200 | RTM | |
| 2201 | ||
| 2202 | Related Op tions | |
| 2203 | None | |
| 2204 | Related Ro utines | |
| 2205 | Routines “ Called By” | |
| 2206 | Routines “ Called” | |
| 2207 | ||
| 2208 | ||
| 2209 | ||
| 2210 | ||
| 2211 | Data Dicti onary (DD) Reference s | |
| 2212 | ||
| 2213 | Related Pr otocols | |
| 2214 | None | |
| 2215 | Related In tegration Control Re gistration s (ICRs) | |
| 2216 | None | |
| 2217 | Data Passi ng | |
| 2218 | Input | |
| 2219 | Output Re ference | |
| 2220 | Both | |
| 2221 | Global Re ference | |
| 2222 | Local | |
| 2223 | Input Attr ibute Name and Defin ition | |
| 2224 | Name: | |
| 2225 | Definition : | |
| 2226 | Output Att ribute Nam e and Defi nition | |
| 2227 | Name: | |
| 2228 | Definition : | |
| 2229 | Current Lo gic | |
| 2230 | IBCEP7 ;AL B/TMP - Fu nctions fo r fac leve l PROVIDER ID MAINT ;11-07-00 ;;2.0;INTE GRATED BIL LING;**137 ,232,320,3 48,349**;2 1-MAR-94;B uild 46 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ;HDR ; -- hdr c ode I '$D( ^TMP("IBCE _PRVFAC_MA INT",$J)) D INIT N I BINS,PCF,P CDISP,IBPA RAM,IBEFTF L K VALMHD R S IBPARA M=$G(^TMP( "IBCE_PRVF AC_MAINT_I NS",$J)) S IBEFTFL=$ P(IBPARAM, U) ; Elect ronic Form type flag S IBINS=+ $P(IBPARAM ,U,2) ; In surance co S PCF=$P( $G(^DIC(36 ,+IBINS,3) ),U,13),PC DISP=$S(PC F="P":"(Pa rent)",1:" ") S VALMH DR(1)="Ins urance Co: "_$P($G(^ DIC(36,+IB INS,0)),U) _PCDISP S VALMHDR(1) =VALMHDR(1 )_$S(IBEFT FL="E":" B illing Pro vider Seco ndary IDs" ,IBEFTFL=" A":" Addit ional Bill ing Provid er Sec. ID s",IBEFTFL ="LF":" VA -Lab/Facil ity Second ary IDs",1 :"") I IBE FTFL="LF" S VALMHDR( 2)="VA-Lab /Facility Primary ID : Federal Tax ID" Q ;INIT ; In itialize N IBCT,IBD, Z,Z0,Z00,Z 1,IBS,IBX, IBDIV,IBEF TFL,IBINS, IBPARAM,IB LCT,IBCU K ^TMP("IBC E_PRVFAC_M AINT",$J) S (IBLCT,I BCT)=0 S I BPARAM=$G( ^TMP("IBCE _PRVFAC_MA INT_INS",$ J)) S IBEF TFL=$P(IBP ARAM,U) ; Electronic Form type flag S IB INS=+$P(IB PARAM,U,2) ; Insuran ce co ; I IBEFTFL="A " D . K VA LM("PROTOC OL") . S Y =$$FIND1^D IC(101,,," IBCE PRVFA C ADDIDS M AINT") . I Y S VALM( "PROTOCOL" )=+Y_";ORD (101," ; I IBEFTFL=" LF" D . S VALM("TITL E")="VA-La b/Facility IDs" . K VALM("PROT OCOL") . S Y=$$FIND1 ^DIC(101,, ,"IBCE PRV FAC VALF M AINT") . I Y S VALM( "PROTOCOL" )=+Y_";ORD (101," ; ; Compile t he appropr iate list of IDs S Z =0 F S Z= $O(^IBA(35 5.92,"B",I BINS,Z)) Q :'Z D . S Z0=$G(^IB A(355.92,Z ,0)) . Q:' $P(Z0,U,6) !($P(Z0,U, 7)="") ; Q uit if no provider i d or id ty pe . Q:'($ P(Z0,U,8)= IBEFTFL) . ;Q:$S($P( IBPARAM,U, 3)=1:'$P($ G(^IBE(355 .97,+$P(Z0 ,U,6),1)), U,9),1:$P( $G(^IBE(35 5.97,+$P(Z 0,U,6),1)) ,U,9)) . S Z1=$G(^IB E(355.97,+ $P(Z0,U,6) ,0)) . S I BS(+$P(Z0, U,5),+$P(Z 0,U,3),+$P (Z1,U,2)_" ;"_Z,$P(Z1 ,U))=+$P(Z 0,U,6)_U_$ P(Z0,U,7)_ U_Z ; S IB D="" F S IBD=$O(IBS (IBD)) Q:I BD="" D . D:IBCT SE T1(.IBLCT, " ",IBCT+1 ) . D SET1 (.IBLCT,"D ivision: " _$$DIV(IBD ),IBCT+1) . S IBCU=" " F S IBC U=$O(IBS(I BD,IBCU)) Q:IBCU="" D .. I IB CU D SET1( .IBLCT," C are Unit: "_$$EXTERN AL^DILFD(3 55.92,.03, "",IBCU),I BCT+1) .. S Z="" F S Z=$O(IBS (IBD,IBCU, Z),-1) Q:Z ="" D ... S Z0="" F S Z0=$O( IBS(IBD,IB CU,Z,Z0)) Q:Z0="" S IBX=IBS(I BD,IBCU,Z, Z0) D .... S IBCT=IB CT+1 .... I $P(Z,";" ,2) D Q . .... S Z00 =$G(^IBA(3 55.92,+$P( Z,";",2),0 )) ..... S Z1=$E(IBC T_$J("",3) ,1,3)_" "_ $E(Z0_$J(" ",25),1,25 )_" "_$E($ S($P(IBX,U ,2)'="":$P (IBX,U,2), 1:$$IDNUM^ IBCEP7A(+I BX))_$J("" ,15),1,15) _" "_$P("B OTH^UB04^1 500^RX",U, $P(Z00,U,4 )+1) ..... D SET1(.I BLCT,Z1,IB CT) ..... S ^TMP("IB CE_PRVFAC_ MAINT",$J, "ZIDX",IBC T)=+$P(Z," ;",2) ; I 'IBLCT D . D SET1(1, " ") . N T EXT . I IB EFTFL="E" S TEXT="No Billing P rovider Se condary ID s found" . I IBEFTFL ="A" S TEX T="No Bill ing Provid er Additio nal IDs fo und" . I I BEFTFL="LF " S TEXT=" No VA Lab/ Facility I Ds found" . D SET1(2 ,TEXT) . S IBLCT=2 S VALMBG=1, VALMCNT=IB LCT Q ;SET 1(IBLCT,TE XT,IBCT) ; S IBLCT=I BLCT+1 D S ET^VALM10( IBLCT,TEXT ,$G(IBCT)) Q ;DIV(IB D) ; Retur ns 'ALL/DE FAULT' or div NAME w hose ien=I BD N MAIN I IBD Q $$ EXTERNAL^D ILFD(355.9 2,.05,"",I BD) S MAIN =$$MAIN^IB CEP2B() S MAIN=$$EXT ERNAL^DILF D(355.92,. 05,"",MAIN ) S MAIN=M AIN_"/Defa ult for Al l Division s" Q MAIN ;EDIT1 ; N IBFUNC,IB INS,IBDA,Z ,DIR,X,Y,D TOUT,DUOUT ,DP,IBPARA M,IBEFTFL D FULL^VAL M1 S IBPAR AM=$G(^TMP ("IBCE_PRV FAC_MAINT_ INS",$J)) S IBEFTFL= $P(IBPARAM ,U) ; Elec tronic For m type fla g S IBINS= +$P(IBPARA M,U,2) ; I nsurance c o S IBFUNC ="E" D SEL I $G(IBDA ) S Z=$$ED ITFAC(IBDA ,IBFUNC,IB EFTFL) I Z D INIT ;E DIT1Q S VA LMBCK="R" QEXPND ; Q HELP ; QEX IT ; N IBP ARAM,IBEFT FL S IBPAR AM=$G(^TMP ("IBCE_PRV FAC_MAINT_ INS",$J)) S IBEFTFL= $P(IBPARAM ,U) ; Elec tronic For m type fla g I IBEFTF L="A" D CO PYPROV^IBC EP5A(0) ; S (IBLCT,I BCT)=0 K ^ TMP("IBCE_ PRVFAC_MAI NT",$J),^T MP("IBCE_P RVFAC_MAIN T_INS",$J) D CLEAN^V ALM10 QSEL ; N Z K I BDA D FULL ^VALM1,EN^ VALM2($G(X QORNOD(0)) ,"OS") S Z =+$O(VALMY (0)) Q:'Z ; fac/ins co default S IBDA=$G (^TMP("IBC E_PRVFAC_M AINT",$J," ZIDX",Z)) Q ;EDITFAC (IBDA,IBFU NC,IBEFTFL ) ; edits ins co fac ility id ( 355.92), e ntry IBDA N IBRBLD,Z ,Z0,DIK,DI E,DP,DA,DR ,DIR,X,Y,I BDA0,IBDIV ,IBITYP,IB FORM,IBCAR EUN,NEXTON E S IBRBLD =0 S:$G(IB DA) IBDA0= $G(^IBA(35 5.92,+IBDA ,0)) ; "E" diting 355 .92 entry I IBFUNC=" E" D . S Z 0=$TR(IBDA 0,U) . Q:' $$FACFLDS^ IBCEP7C(IB DA,IBINS,. IBITYP,.IB FORM,.IBDI V,"E",.IBC AREUN,IBEF TFL) . S D IE="^IBA(3 55.92,",DA =IBDA . S DR=".03/// /"_$S($G(I BCAREUN)]" "&($G(IBCA REUN)'="*N /A*"):IBCA REUN,1:"") _";.04//// "_IBFORM_$ S(IBDIV:"; .05////"_I BDIV,1:"") _";.06//// "_IBITYP_" ;" . S DR= DR_".07"_$ S(IBEFTFL= "E"!(IBEFT FL="A"):"B illing Pro vider Seco ndary ID", 1:"VA Lab or Facilit y Secondar y ID") . I IBEFTFL=" A" D .. S NEXTONE=$$ NEXTONE() .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE)=IB DA_U_"MOD" _U_355.92 .. S ^TMP( "IB_EDITED _IDS",$J,N EXTONE,"OL D0")=^IBA( 355.92,IBD A,0) . D ^ DIE . I IB EFTFL="A" S ^TMP("IB _EDITED_ID S",$J,NEXT ONE,0)=^IB A(355.92,I BDA,0) . I $TR($G(^I BA(355.92, IBDA,0)),U )'=Z0 S IB RBLD=1 ; ; "D"eletin g 355.92 e ntry I IBF UNC="D" D . W !!," I nsurance C o: ",$P($G (^DIC(36,+ IBDA0,0)), U) . W !," Division: ",$$DIV($ P(IBDA0,U, 5)) . W:$P (IBDA0,U,3 )]"" !," C are Unit: ",$$EXTERN AL^DILFD(3 55.92,.03, "",$P(IBDA 0,U,3)) . W !," ID Q ualifier: ",$$EXTERN AL^DILFD(3 55.92,.06, "",$P(IBDA 0,U,6)) . W !," Form Type: ",$ $EXTERNAL^ DILFD(355. 92,.04,"", $P(IBDA0,U ,4)) . W ! ," ID: ",$ P(IBDA0,U, 7),! . S D IR(0)="YA" ,DIR("A")= "ARE YOU S URE YOU WA NT TO DELE TE THIS ID RECORD?: ",DIR("B") ="NO" D ^D IR K DIR . S DIR("A" )="NOTHING DELETED - PRESS RET URN TO CON TINUE: " . I Y=1 D . . S DIK="^ IBA(355.92 ,",DA=IBDA .. D ^DIK .. I IBEF TFL="A" D ... N NEXT ONE ... S NEXTONE=$$ NEXTONE() ... S ^TMP ("IB_EDITE D_IDS",$J, NEXTONE)=I BDA_U_"DEL "_U_355.92 ... S ^TM P("IB_EDIT ED_IDS",$J ,NEXTONE,0 )=IBDA0 .. S DIR("A" )="ID DELE TED - PRES S RETURN T O CONTINUE : ",IBRBLD =1 .. S DI R(0)="EA" W ! D ^DIR K DIR ; Q IBRBLD ;F ACID(Y) ; N Z,Z1,Z2 S Z=U_$P($ G(^IBE(355 .97,+Y,0)) ,U,3)_U,Z1 =$$SUB2^IB CEF73(1),Z 2=$$SUB2^I BCEF73(2) I Z1[Z!(Z2 [Z) Q 1 Q 0 ;ADD1 ; N IBFUNC,I BINS,IBDA, Z,DIR,X,Y, DTOUT,DUOU T,DP,IBPAR AM,IBEFTFL ,IBINS D F ULL^VALM1 ; S IBPARA M=$G(^TMP( "IBCE_PRVF AC_MAINT_I NS",$J)) S IBEFTFL=$ P(IBPARAM, U) ; Elect ronic Form type flag S IBINS=+ $P(IBPARAM ,U,2) ; In surance co ; ; S Z=$ $ADDFAC^IB CEP7A(IBIN S,IBEFTFL) I Z D INI T ;ADD1Q S VALMBCK=" R" Q ;DEL1 ; N IBFUN C,IBINS,IB DA,Z,DIR,X ,Y,DTOUT,D UOUT,DP,IB PARAM,IBEF TDL,IBINS D FULL^VAL M1 ; S IB PARAM=$G(^ TMP("IBCE_ PRVFAC_MAI NT_INS",$J )) S IBEFT FL=$P(IBPA RAM,U) ; E lectronic Form type flag S IBI NS=+$P(IBP ARAM,U,2) ; Insuranc e co ; S I BFUNC="D" D SEL I $G (IBDA) S Z =$$EDITFAC (IBDA,IBFU NC,IBEFTFL ) I Z D IN IT ;DEL1Q S VALMBCK= "R" Q ; ; Get the ne xt number so that th e edits ca n be repli cated in o rder for o ther provi ders/insur ance compa niesNEXTON E() ; Q $O (^TMP("IB_ EDITED_IDS ",$J,""),- 1)+1 | |
| 2231 | Modified L ogic (Chan ges are in bold) | |
| 2232 | IBCEP7 ;AL B/TMP - Fu nctions fo r fac leve l PROVIDER ID MAINT ;11-07-00 ;;2.0;INTE GRATED BIL LING;**137 ,232,320,3 48,349,592 **;21-MAR- 94;Build 4 6 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. ; HDR ; -- h dr code I '$D(^TMP(" IBCE_PRVFA C_MAINT",$ J)) D INIT N IBINS,P CF,PCDISP, IBPARAM,IB EFTFL K VA LMHDR S IB PARAM=$G(^ TMP("IBCE_ PRVFAC_MAI NT_INS",$J )) S IBEFT FL=$P(IBPA RAM,U) ; E lectronic Form type flag S IBI NS=+$P(IBP ARAM,U,2) ; Insuranc e co S PCF =$P($G(^DI C(36,+IBIN S,3)),U,13 ),PCDISP=$ S(PCF="P": "(Parent)" ,1:"") S V ALMHDR(1)= "Insurance Co: "_$P( $G(^DIC(36 ,+IBINS,0) ),U)_PCDIS P S VALMHD R(1)=VALMH DR(1)_$S(I BEFTFL="E" :" Billing Provider Secondary IDs",IBEFT FL="A":" A dditional Billing Pr ovider Sec . IDs",IBE FTFL="LF": " VA-Lab/F acility Se condary ID s",1:"") I IBEFTFL=" LF" S VALM HDR(2)="VA -Lab/Facil ity Primar y ID: Fede ral Tax ID " Q ;INIT ; Initiali ze N IBCT, IBD,Z,Z0,Z 00,Z1,IBS, IBX,IBDIV, IBEFTFL,IB INS,IBPARA M,IBLCT,IB CU K ^TMP( "IBCE_PRVF AC_MAINT", $J) S (IBL CT,IBCT)=0 S IBPARAM =$G(^TMP(" IBCE_PRVFA C_MAINT_IN S",$J)) S IBEFTFL=$P (IBPARAM,U ) ; Electr onic Form type flag S IBINS=+$ P(IBPARAM, U,2) ; Ins urance co ; I IBEFTF L="A" D . K VALM("PR OTOCOL") . S Y=$$FIN D1^DIC(101 ,,,"IBCE P RVFAC ADDI DS MAINT") . I Y S V ALM("PROTO COL")=+Y_" ;ORD(101," ; I IBEFT FL="LF" D . S VALM(" TITLE")="V A-Lab/Faci lity IDs" . K VALM(" PROTOCOL") . S Y=$$F IND1^DIC(1 01,,,"IBCE PRVFAC VA LF MAINT") . I Y S V ALM("PROTO COL")=+Y_" ;ORD(101," ; ; Compi le the app ropriate l ist of IDs S Z=0 F S Z=$O(^IB A(355.92," B",IBINS,Z )) Q:'Z D . S Z0=$G (^IBA(355. 92,Z,0)) . Q:'$P(Z0, U,6)!($P(Z 0,U,7)="") ; Quit if no provid er id or i d type . Q :'($P(Z0,U ,8)=IBEFTF L) . ;Q:$S ($P(IBPARA M,U,3)=1:' $P($G(^IBE (355.97,+$ P(Z0,U,6), 1)),U,9),1 :$P($G(^IB E(355.97,+ $P(Z0,U,6) ,1)),U,9)) . S Z1=$G (^IBE(355. 97,+$P(Z0, U,6),0)) . S IBS(+$P (Z0,U,5),+ $P(Z0,U,3) ,+$P(Z1,U, 2)_";"_Z,$ P(Z1,U))=+ $P(Z0,U,6) _U_$P(Z0,U ,7)_U_Z ; S IBD="" F S IBD=$O (IBS(IBD)) Q:IBD="" D . D:IBC T SET1(.IB LCT," ",IB CT+1) . D SET1(.IBLC T,"Divisio n: "_$$DIV (IBD),IBCT +1) . S IB CU="" F S IBCU=$O(I BS(IBD,IBC U)) Q:IBCU ="" D .. I IBCU D S ET1(.IBLCT ," Care Un it: "_$$EX TERNAL^DIL FD(355.92, .03,"",IBC U),IBCT+1) .. S Z="" F S Z=$O (IBS(IBD,I BCU,Z),-1) Q:Z="" D ... S Z0= "" F S Z0 =$O(IBS(IB D,IBCU,Z,Z 0)) Q:Z0=" " S IBX=I BS(IBD,IBC U,Z,Z0) D .... S IBC T=IBCT+1 . ... I $P(Z ,";",2) D Q ..... S Z00=$G(^I BA(355.92, +$P(Z,";", 2),0)) ... .. ;JWS;IB *2.0*592;D ental form #7 J430D: changed B OTH to ALL , add J430 D ..... S Z1=$E(IBCT _$J("",3), 1,3)_" "_$ E(Z0_$J("" ,25),1,25) _" "_$E($S ($P(IBX,U, 2)'="":$P( IBX,U,2),1 :$$IDNUM^I BCEP7A(+IB X))_$J("", 15),1,15)_ " "_$P("AL L^UB04^150 0^RX^J430D ",U,$P(Z00 ,U,4)+1) . .... D SET 1(.IBLCT,Z 1,IBCT) .. ... S ^TMP ("IBCE_PRV FAC_MAINT" ,$J,"ZIDX" ,IBCT)=+$P (Z,";",2) ; I 'IBLCT D . D SET 1(1," ") . N TEXT . I IBEFTFL= "E" S TEXT ="No Billi ng Provide r Secondar y IDs foun d" . I IBE FTFL="A" S TEXT="No Billing Pr ovider Add itional ID s found" . I IBEFTFL ="LF" S TE XT="No VA Lab/Facili ty IDs fou nd" . D SE T1(2,TEXT) . S IBLCT =2 S VALMB G=1,VALMCN T=IBLCT Q ;SET1(IBLC T,TEXT,IBC T) ; S IBL CT=IBLCT+1 D SET^VAL M10(IBLCT, TEXT,$G(IB CT)) Q ;DI V(IBD) ; R eturns 'AL L/DEFAULT' or div NA ME whose i en=IBD N M AIN I IBD Q $$EXTERN AL^DILFD(3 55.92,.05, "",IBD) S MAIN=$$MAI N^IBCEP2B( ) S MAIN=$ $EXTERNAL^ DILFD(355. 92,.05,"", MAIN) S MA IN=MAIN_"/ Default fo r All Divi sions" Q M AIN ;EDIT1 ; N IBFUN C,IBINS,IB DA,Z,DIR,X ,Y,DTOUT,D UOUT,DP,IB PARAM,IBEF TFL D FULL ^VALM1 S I BPARAM=$G( ^TMP("IBCE _PRVFAC_MA INT_INS",$ J)) S IBEF TFL=$P(IBP ARAM,U) ; Electronic Form type flag S IB INS=+$P(IB PARAM,U,2) ; Insuran ce co S IB FUNC="E" D SEL I $G( IBDA) S Z= $$EDITFAC( IBDA,IBFUN C,IBEFTFL) I Z D INI T ;EDIT1Q S VALMBCK= "R" QEXPND ; QHELP ; QEXIT ; N IBPARAM,I BEFTFL S I BPARAM=$G( ^TMP("IBCE _PRVFAC_MA INT_INS",$ J)) S IBEF TFL=$P(IBP ARAM,U) ; Electronic Form type flag I IB EFTFL="A" D COPYPROV ^IBCEP5A(0 ) ; S (IBL CT,IBCT)=0 K ^TMP("I BCE_PRVFAC _MAINT",$J ),^TMP("IB CE_PRVFAC_ MAINT_INS" ,$J) D CLE AN^VALM10 QSEL ; N Z K IBDA D FULL^VALM1 ,EN^VALM2( $G(XQORNOD (0)),"OS") S Z=+$O(V ALMY(0)) Q :'Z ; fac/ ins co def ault S IBD A=$G(^TMP( "IBCE_PRVF AC_MAINT", $J,"ZIDX", Z)) Q ;EDI TFAC(IBDA, IBFUNC,IBE FTFL) ; ed its ins co facility id (355.92 ), entry I BDA N IBRB LD,Z,Z0,DI K,DIE,DP,D A,DR,DIR,X ,Y,IBDA0,I BDIV,IBITY P,IBFORM,I BCAREUN,NE XTONE S IB RBLD=0 S:$ G(IBDA) IB DA0=$G(^IB A(355.92,+ IBDA,0)) ; "E"diting 355.92 en try I IBFU NC="E" D . S Z0=$TR( IBDA0,U) . Q:'$$FACF LDS^IBCEP7 C(IBDA,IBI NS,.IBITYP ,.IBFORM,. IBDIV,"E", .IBCAREUN, IBEFTFL) . S DIE="^I BA(355.92, ",DA=IBDA . S DR=".0 3////"_$S( $G(IBCAREU N)]""&($G( IBCAREUN)' ="*N/A*"): IBCAREUN,1 :"")_";.04 ////"_IBFO RM_$S(IBDI V:";.05/// /"_IBDIV,1 :"")_";.06 ////"_IBIT YP_";" . S DR=DR_".0 7"_$S(IBEF TFL="E"!(I BEFTFL="A" ):"Billing Provider Secondary ID",1:"VA Lab or Fac ility Seco ndary ID") . I IBEFT FL="A" D . . S NEXTON E=$$NEXTON E() .. S ^ TMP("IB_ED ITED_IDS", $J,NEXTONE )=IBDA_U_" MOD"_U_355 .92 .. S ^ TMP("IB_ED ITED_IDS", $J,NEXTONE ,"OLD0")=^ IBA(355.92 ,IBDA,0) . D ^DIE . I IBEFTFL= "A" S ^TMP ("IB_EDITE D_IDS",$J, NEXTONE,0) =^IBA(355. 92,IBDA,0) . I $TR($ G(^IBA(355 .92,IBDA,0 )),U)'=Z0 S IBRBLD=1 ; ; "D"el eting 355. 92 entry I IBFUNC="D " D . W !! ," Insuran ce Co: ",$ P($G(^DIC( 36,+IBDA0, 0)),U) . W !," Divis ion: ",$$D IV($P(IBDA 0,U,5)) . W:$P(IBDA0 ,U,3)]"" ! ," Care Un it: ",$$EX TERNAL^DIL FD(355.92, .03,"",$P( IBDA0,U,3) ) . W !," ID Qualifi er: ",$$EX TERNAL^DIL FD(355.92, .06,"",$P( IBDA0,U,6) ) . W !," Form Type: ",$$EXTER NAL^DILFD( 355.92,.04 ,"",$P(IBD A0,U,4)) . W !," ID: ",$P(IBDA 0,U,7),! . S DIR(0)= "YA",DIR(" A")="ARE Y OU SURE YO U WANT TO DELETE THI S ID RECOR D?: ",DIR( "B")="NO" D ^DIR K D IR . S DIR ("A")="NOT HING DELET ED - PRESS RETURN TO CONTINUE: " . I Y=1 D .. S DI K="^IBA(35 5.92,",DA= IBDA .. D ^DIK .. I IBEFTFL="A " D ... N NEXTONE .. . S NEXTON E=$$NEXTON E() ... S ^TMP("IB_E DITED_IDS" ,$J,NEXTON E)=IBDA_U_ "DEL"_U_35 5.92 ... S ^TMP("IB_ EDITED_IDS ",$J,NEXTO NE,0)=IBDA 0 .. S DIR ("A")="ID DELETED - PRESS RETU RN TO CONT INUE: ",IB RBLD=1 .. S DIR(0)=" EA" W ! D ^DIR K DIR ; Q IBRBL D ;FACID(Y ) ; N Z,Z1 ,Z2 S Z=U_ $P($G(^IBE (355.97,+Y ,0)),U,3)_ U,Z1=$$SUB 2^IBCEF73( 1),Z2=$$SU B2^IBCEF73 (2) I Z1[Z !(Z2[Z) Q 1 Q 0 ;ADD 1 ; N IBFU NC,IBINS,I BDA,Z,DIR, X,Y,DTOUT, DUOUT,DP,I BPARAM,IBE FTFL,IBINS D FULL^VA LM1 ; S IB PARAM=$G(^ TMP("IBCE_ PRVFAC_MAI NT_INS",$J )) S IBEFT FL=$P(IBPA RAM,U) ; E lectronic Form type flag S IBI NS=+$P(IBP ARAM,U,2) ; Insuranc e co ; ; S Z=$$ADDFA C^IBCEP7A( IBINS,IBEF TFL) I Z D INIT ;ADD 1Q S VALMB CK="R" Q ; DEL1 ; N I BFUNC,IBIN S,IBDA,Z,D IR,X,Y,DTO UT,DUOUT,D P,IBPARAM, IBEFTDL,IB INS D FULL ^VALM1 ; S IBPARAM= $G(^TMP("I BCE_PRVFAC _MAINT_INS ",$J)) S I BEFTFL=$P( IBPARAM,U) ; Electro nic Form t ype flag S IBINS=+$P (IBPARAM,U ,2) ; Insu rance co ; S IBFUNC= "D" D SEL I $G(IBDA) S Z=$$EDI TFAC(IBDA, IBFUNC,IBE FTFL) I Z D INIT ;DE L1Q S VALM BCK="R" Q ; ; Get th e next num ber so tha t the edit s can be r eplicated in order f or other p roviders/i nsurance c ompaniesNE XTONE() ; Q $O(^TMP( "IB_EDITED _IDS",$J," "),-1)+1 | |
| 2233 | ||
| 2234 | ||
| 2235 | Routines | |
| 2236 | Activities | |
| 2237 | Routine Na me | |
| 2238 | IBCEP7B | |
| 2239 | Enhancemen t Category | |
| 2240 | New | |
| 2241 | Modify | |
| 2242 | Delete | |
| 2243 | No Change | |
| 2244 | RTM | |
| 2245 | ||
| 2246 | Related Op tions | |
| 2247 | None | |
| 2248 | Related Ro utines | |
| 2249 | Routines “ Called By” | |
| 2250 | Routines “ Called” | |
| 2251 | ||
| 2252 | ||
| 2253 | ||
| 2254 | ||
| 2255 | Data Dicti onary (DD) Reference s | |
| 2256 | ||
| 2257 | Related Pr otocols | |
| 2258 | None | |
| 2259 | Related In tegration Control Re gistration s (ICRs) | |
| 2260 | None | |
| 2261 | Data Passi ng | |
| 2262 | Input | |
| 2263 | Output Re ference | |
| 2264 | Both | |
| 2265 | Global Re ference | |
| 2266 | Local | |
| 2267 | Input Attr ibute Name and Defin ition | |
| 2268 | Name: | |
| 2269 | Definition : | |
| 2270 | Output Att ribute Nam e and Defi nition | |
| 2271 | Name: | |
| 2272 | Definition : | |
| 2273 | Current Lo gic | |
| 2274 | IBCEP7B ;A LB/TMP - F unctions f or PROVIDE R ID ;1-16 -05 ;;2.0; INTEGRATED BILLING;* *320,348,3 49**;16-JA N-2005;Bui ld 46 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. Q ;GETI D(CLAIM,CO B) ; N DIR ,X,Y,DTOUT ,DUOUT,WHI CH,ID,IBMA IN,IBDIV,D IC,IBINS,D A,DIC,Z,Z0 ,IBCU,OK,I BCU ; S ID ="" S IBIN S=$P($G(^D GCR(399,CL AIM,"I"_CO B)),U) I I BINS="" Q ID ; ; Mak e sure the y have car eunits IDS defined f or this in surance co mpany befo re we both er asking S OK=0 S Z =0 F S Z= $O(^IBA(35 5.92,"B",I BINS,Z)) Q :'Z D Q: OK . S Z0= $G(^IBA(35 5.92,Z,0)) . Q:$P(Z0 ,U,8)'="E" . Q:$P(Z0 ,U,3)="" . S OK=1 I 'OK Q ID ; S WHICH=$ S(COB=1:"P rimary",CO B=2:"Secon dary",1:"T ertiary") S DIR("A") ="Define " _WHICH_" P ayer ID by Care Unit ? " S DIR( "B")="No" S DIR(0)=" YA" S DIR( "?",1)="En ter No to select "_W HICH_" Pro vider # by Division. " S DIR("? ")="Enter Yes to sel ect "_WHIC H_" Provid er # for a specific Care Unit. " D ^DIR I Y'=1 Q ID ; ; Get t he Divisio n S IBMAIN =$$MAIN^IB CEP2B() S IBDIV=$$EX TERNAL^DIL FD(399,.22 ,"",$P($G( ^DGCR(399, CLAIM,0)), U,22)) S D IR("A")="D ivision: " ,DIR(0)="3 55.92,.05A Or" ; Defa ult Divisi on S DIR(" B")=$S(IBD IV]"":IBDI V,1:IBMAIN ) D ^DIR K DIR S IBD IV=+$S(Y>0 :+Y,1:0) I Y<0 Q ID ; ; Get th e Care Uni t S DIC("A ")="Care U nit: " S D IC("W")="W "" "",$P( ^(0),U,2)" S DIC=355 .95,DIC("S ")="I $P(^ (0),U,3)=+ $G(IBINS), $P(^(0),U, 4)=+$G(IBD IV)",DIC(0 )="AEMQ" D ^DIC I Y< 0 Q ID S I BCU=+Y ; ; Compile t he appropr iate list of IDs S Z =0 F S Z= $O(^IBA(35 5.92,"B",I BINS,Z)) Q :'Z D Q: ID]"" . S Z0=$G(^IBA (355.92,Z, 0)) . Q:$P (Z0,U,8)'= "E" . Q:$P (Z0,U,3)'= IBCU . S I D=$P(Z0,U, 7)_U_$P(Z0 ,U,6) Q ID ; ; See i f the insu rance comp any flag i s set to s end the AT T/REND ID as the Bil ling Provi derATTREND (CLAIM,COB ) ; N ID,I BINS S ID= "" S IBINS =$P($G(^DG CR(399,CLA IM,"I"_COB )),U) I IB INS="" Q 0 ; I $$FT^ IBCEF(CLAI M)=2,$$GET 1^DIQ(36,I BINS,4.06, "I") Q 1 ; 1500 I $$ FT^IBCEF(C LAIM)=3,$$ GET1^DIQ(3 6,IBINS,4. 08,"I") Q 1 ; ub Q 0 ; ; Get a list of t he plan ty pes that s upress Bil ling Provi der Second ary IDs fo r this Ins urance Co ; and see if the cur rent plan type is on e of them. SUPPPT(CLA IM,COB) ; N IBINS,SU PPFL S SUP PFL=0 S IB INS=$P($G( ^DGCR(399, CLAIM,"I"_ COB)),U) I IBINS="" Q SUPPFL ; I $D(^DIC (36,IBINS, 13)) D . N PLAN,PLAN TYPE . S P LAN=$P($G( ^DGCR(399, CLAIM,"I"_ COB)),U,18 ) Q:'PLAN . S PLANTY PE=$P($G(^ IBA(355.3, PLAN,0)),U ,15) Q:PLA NTYPE="" . Q:'$D(^DI C(36,IBINS ,13,"B",PL ANTYPE)) . S SUPPFL= 1 Q SUPPFL | |
| 2275 | Modified L ogic (Chan ges are in bold) | |
| 2276 | IBCEP7B ;A LB/TMP - F unctions f or PROVIDE R ID ;1-16 -05 ;;2.0; INTEGRATED BILLING;* *320,348,3 49,592**;1 6-JAN-2005 ;Build 46 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. Q ; GETID(CLAI M,COB) ; N DIR,X,Y,D TOUT,DUOUT ,WHICH,ID, IBMAIN,IBD IV,DIC,IBI NS,DA,DIC, Z,Z0,IBCU, OK,IBCU ; S ID="" S IBINS=$P($ G(^DGCR(39 9,CLAIM,"I "_COB)),U) I IBINS=" " Q ID ; ; Make sure they have careunits IDS defin ed for thi s insuranc e company before we bother ask ing S OK=0 S Z=0 F S Z=$O(^IB A(355.92," B",IBINS,Z )) Q:'Z D Q:OK . S Z0=$G(^IB A(355.92,Z ,0)) . Q:$ P(Z0,U,8)' ="E" . Q:$ P(Z0,U,3)= "" . S OK= 1 I 'OK Q ID ; S WHI CH=$S(COB= 1:"Primary ",COB=2:"S econdary", 1:"Tertiar y") S DIR( "A")="Defi ne "_WHICH _" Payer I D by Care Unit? " S DIR("B")=" No" S DIR( 0)="YA" S DIR("?",1) ="Enter No to select "_WHICH_" Provider # by Divis ion." S DI R("?")="En ter Yes to select "_ WHICH_" Pr ovider # f or a speci fic Care U nit." D ^D IR I Y'=1 Q ID ; ; G et the Div ision S IB MAIN=$$MAI N^IBCEP2B( ) S IBDIV= $$EXTERNAL ^DILFD(399 ,.22,"",$P ($G(^DGCR( 399,CLAIM, 0)),U,22)) S DIR("A" )="Divisio n: ",DIR(0 )="355.92, .05AOr" ; Default Di vision S D IR("B")=$S (IBDIV]"": IBDIV,1:IB MAIN) D ^D IR K DIR S IBDIV=+$S (Y>0:+Y,1: 0) I Y<0 Q ID ; ; Ge t the Care Unit S DI C("A")="Ca re Unit: " S DIC("W" )="W "" "" ,$P(^(0),U ,2)" S DIC =355.95,DI C("S")="I $P(^(0),U, 3)=+$G(IBI NS),$P(^(0 ),U,4)=+$G (IBDIV)",D IC(0)="AEM Q" D ^DIC I Y<0 Q ID S IBCU=+Y ; ; Compi le the app ropriate l ist of IDs S Z=0 F S Z=$O(^IB A(355.92," B",IBINS,Z )) Q:'Z D Q:ID]"" . S Z0=$G( ^IBA(355.9 2,Z,0)) . Q:$P(Z0,U, 8)'="E" . Q:$P(Z0,U, 3)'=IBCU . S ID=$P(Z 0,U,7)_U_$ P(Z0,U,6) Q ID ; ; S ee if the insurance company fl ag is set to send th e ATT/REND ID as the Billing P roviderATT REND(CLAIM ,COB) ; N ID,IBINS S ID="" S I BINS=$P($G (^DGCR(399 ,CLAIM,"I" _COB)),U) I IBINS="" Q 0 I $$F T^IBCEF(CL AIM)=2,$$G ET1^DIQ(36 ,IBINS,4.0 6,"I") Q 1 ; 1500 ;J WS;IB*2.0* 592;Dental form #7 J 430D I $$F T^IBCEF(CL AIM)=7,$$G ET1^DIQ(36 ,IBINS,4.1 6,"I") Q 1 ;J430D I $$FT^IBCEF (CLAIM)=3, $$GET1^DIQ (36,IBINS, 4.08,"I") Q 1 ; ub Q 0 ; ; Get a list of the plan types that supress B illing Pro vider Seco ndary IDs for this I nsurance C o ; and se e if the c urrent pla n type is one of the m.SUPPPT(C LAIM,COB) ; N IBINS, SUPPFL S S UPPFL=0 S IBINS=$P($ G(^DGCR(39 9,CLAIM,"I "_COB)),U) I IBINS=" " Q SUPPFL ; I $D(^D IC(36,IBIN S,13)) D . N PLAN,PL ANTYPE . S PLAN=$P($ G(^DGCR(39 9,CLAIM,"I "_COB)),U, 18) Q:'PLA N . S PLAN TYPE=$P($G (^IBA(355. 3,PLAN,0)) ,U,15) Q:P LANTYPE="" . Q:'$D(^ DIC(36,IBI NS,13,"B", PLANTYPE)) . S SUPPF L=1 Q SUPP FL | |
| 2277 | ||
| 2278 | ||
| 2279 | Routines | |
| 2280 | Activities | |
| 2281 | Routine Na me | |
| 2282 | IBCEP7C | |
| 2283 | Enhancemen t Category | |
| 2284 | New | |
| 2285 | Modify | |
| 2286 | Delete | |
| 2287 | No Change | |
| 2288 | RTM | |
| 2289 | ||
| 2290 | Related Op tions | |
| 2291 | None | |
| 2292 | Related Ro utines | |
| 2293 | Routines “ Called By” | |
| 2294 | Routines “ Called” | |
| 2295 | ||
| 2296 | ||
| 2297 | ||
| 2298 | ||
| 2299 | Data Dicti onary (DD) Reference s | |
| 2300 | ||
| 2301 | Related Pr otocols | |
| 2302 | None | |
| 2303 | Related In tegration Control Re gistration s (ICRs) | |
| 2304 | None | |
| 2305 | Data Passi ng | |
| 2306 | Input | |
| 2307 | Output Re ference | |
| 2308 | Both | |
| 2309 | Global Re ference | |
| 2310 | Local | |
| 2311 | Input Attr ibute Name and Defin ition | |
| 2312 | Name: | |
| 2313 | Definition : | |
| 2314 | Output Att ribute Nam e and Defi nition | |
| 2315 | Name: | |
| 2316 | Definition : | |
| 2317 | Current Lo gic | |
| 2318 | IBCEP7C ;A LB/TMP - F unctions f or fac lev el PROVIDE R ID MAINT ;11-07-00 ;;2.0;INT EGRATED BI LLING;**13 7,232,320, 348,349**; 21-MAR-94; Build 46 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ; G AWAYAWAY Q ; ; IBDA - IEN for file 355.9 2 ; IBFUNC = "A"dd o r "E"ditFA CFLDS(IBDA ,IBINS,IBI TYP,IBFORM ,IBDIV,IBF UNC,IBCARE UN,IBEFTFL ) ; Chk fo r dups on fac id fld combos ; N IB,IBOK, DIC,DIR,X, Y,DTOUT,DU OUT,Z,Z0,D IE,DA,IBMA IN,IBQUIT, IBPARAM,IB CUF,IBDA0, IBCNTADD,I ,IBLIMIT ; S IBOK=0, IBDA0="" I $G(IBDA) S IBDA0=$G (^IBA(355. 92,IBDA,0) ) S IBPARA M=$G(^TMP( "IBCE_PRVF AC_MAINT_I NS",$J)) S IBCUF=$S( $P(IBDA0,U ,3)]"":1,1 :0) ; Care Unit Flag ; I IBEFT FL="E",IBF UNC="A" D G:$D(DTOU T)!$D(DUOU T) FLDSQ . K DIR . S DIR("A")= "Define Bi lling Prov ider Secon dary IDs b y Care Uni ts? " . S DIR("B")=" No" . S DI R(0)="YAO" . S DIR(" ?",1)="Ent er No to d efine a Bi lling Prov ider Secon dary ID fo r the Divi sion." . S DIR("?",2 )="Enter Y es to defi ne a Billi ng Provide r Secondar y ID for a specific Care Unit. " . S DIR( "?",3)="If no Care U nit is ent ered on Bi lling Scre en 3, the Billing Pr ovider" . S DIR("?") ="Secondar y ID defin ed for the Division will be tr ansmitted in the cla im." . D ^ DIR . S IB CUF=$G(Y) ; Care Uni t Flag ; ; Get the D ivision S IBMAIN=$$M AIN^IBCEP2 B() S IBDI V=0 I IBEF TFL="E"!(I BEFTFL="LF ") D G:$D (DTOUT)!$D (DUOUT) FL DSQ . K DI R . S (IBQ UIT,IBOK)= 0,DA=$G(IB DA) . S DI R("A")="Di vision: ", DIR(0)="35 5.92,.05AO r" . ; Def ault Divis ion - Main if adding or Existi ng if edit ing . I IB FUNC="E" S DIR("B")= $P($$DIV^I BCEP7($P(I BDA0,U,5)) ,"/") . I IBFUNC="A" S DIR("B" )=$P($$EXT ERNAL^DILF D(355.92,. 05,"",IBMA IN),"/") . D ^DIR K DIR . Q:$D (DTOUT)!$D (DUOUT) . S IBDIV=+$ S(Y>0:+Y,1 :0) ; ; Se e if there are any C are Units S IBCAREUN ="*N/A*" I IBEFTFL=" E",IBCUF D . N TAR . D LIST^DI C(355.95,, .01,,,,,," I $P(^(0), U,3)=+$G(I BINS),$P(^ (0),U,4)=+ $G(IBDIV)" ,,"TAR") . Q:+$G(TAR ("DILIST", 0)) . S IB CUF=0 . W !!,"There are no Car e Units de fined for this Divis ion.",! ; ; Get the Care Unit I IBEFTFL= "E",IBCUF D I Y<1 G FLDSQ . K DIC . S D IC("A")="C are Unit: " . I IBFU NC="E" D ; default only if ed iting .. Q :IBDIV'=$P (IBDA0,U,5 ) ; don't default if division has change d .. S DIC ("B")=$$EX TERNAL^DIL FD(355.92, .03,"",$P( IBDA0,U,3) ) . S DIC= 355.95,DIC ("S")="I $ P(^(0),U,3 )=+$G(IBIN S),$P(^(0) ,U,4)=+$G( IBDIV)",DI C(0)="AEMQ " . D ^DIC . I Y>0 S IBCAREUN= +Y ; ; Thi nk this is done for sorting pu rposes. Ma kes the ma in divisio n first I IBDIV=IBMA IN S IBDIV =0 ; ; Get the Provi der ID Typ e K DIR S IBQUIT=0 I $P(IBPARA M,U,3)'=1 D . S DIR( "?")="Can NOT be Sta te LIC # o r Billing Facility P rimary" . S DIR("A") ="ID Quali fier: " . S DIR(0)=" 355.92,.06 A^^K:'$$FA CID^IBCEP7 (+Y)!$P($G (^IBE(355. 97,+Y,1)), U,9)!($P($ G(^(0)),U, 3)=""0B"") X" . W ! D ^DIR K D IR . I $D( DTOUT)!$D( DUOUT) S I BQUIT=1 E D G:$D(D TOUT)!$D(D UOUT) FLDS Q . S DIR( "A")="ID Q ualifier: " ;,DIR (0)="355.9 2,.06Ar" . S DIR(0)= "PAr^355.9 7:AEMQ" . S DIR("?") ="Enter a Qualifier to indenti fy the typ e of ID nu mber you a re enterin g." . ; De fault Type of ID - E lectronic Plan Type if adding or Existin g if editi ng . N PIT IEN S PITI EN=$S(IBFU NC="A"&(IB EFTFL="E") :$$BF^IBCU (),IBFUNC= "E":$P(IBD A0,U,6),1: "") . I PI TIEN]"" S DIR("B")=$ P($G(^IBE( 355.97,PIT IEN,0)),U) . I IBEFT FL="E" D . . S DIR("? ",1)=" The current d efault ID Qualifier is based u pon the El ectronic P lan Type." .. S DIR( "?",2)=" Y ou may cha nge the ID Qualifier and the c hange will apply to all Plan" .. S DIR(" ?")=" Type s." .. S D IR("S")="I ($P($G(^( 0)),U,3)=$ P($G(^IBE( 355.97,PIT IEN,0)),U, 3))!$$BPS^ IBCEPU(Y)" . I IBEFT FL="A" S D IR("S")="I $$BPS^IBC EPU(Y)" . I IBEFTFL= "LF" S DIR ("S")="I $ $LFINS^IBC EPU(Y)" . D ^DIR K D IR G:IBQUI T FLDSQ S IBITYP=$P( Y,U) ; ; G et Form Ty pe K DIR S DIR("A")= "Form Type : " S DIR( 0)=$S(IBEF TFL="LF":" SA^0:BOTH; 1:UB-04;2: CMS-1500", 1:"SA^1:UB -04;2:CMS- 1500") ; I $G(IBDA) S DIR("B") =$S(+$P($G (^IBA(355. 92,IBDA,0) ),U,4)=0:" BOTH",1:$P ("UB-04^CM S-1500",U, +$P($G(^IB A(355.92,I BDA,0)),U, 4))) ; D ^ DIR K DIR G:$D(DTOUT )!$D(DUOUT ) FLDSQ S IBFORM=$P( Y,U) ; ; S et up arra y of exisi ting IDs b y form typ e, divison , and care units to avoid dupl ications S Z=0 F S Z=$O(^IBA( 355.92,"B" ,IBINS,Z)) Q:'Z D . S Z0=$G(^ IBA(355.92 ,Z,0)) . I '(IBFUNC= "E"&(Z=IBD A)) D .. I IBEFTFL=" LF",$P(Z0, U,8)'="LF" Q ; If lab/facili ty ID, it only needs to be uni que among lab/facili ty IDs .. I IBEFTFL' ="LF",$P(Z 0,U,8)="LF " Q ; If not lab/f acility ID , it must be unigue for the ot hers (seco ndary and additional ) .. I IBE FTFL="A",$ P(Z0,U,8)= "E" Q .. I $P(Z0,U,8 )="E",IBEF TFL'="A" S IB("*N/A* ",$P(Z0,U, 4),+$P(Z0, U,5),$S($P (Z0,U,3)]" ":$P(Z0,U, 3),1:"*N/A *"))=Z .. S IB($P(Z0 ,U,6),$P(Z 0,U,4),+$P (Z0,U,5),$ S($P(Z0,U, 3)]"":$P(Z 0,U,3),1:" *N/A*"))=Z . ; . ; c ount them . I IBFUNC ="A",$P(Z0 ,U,8)=IBEF TFL,IBDIV= $P(Z0,U,5) !(IBDIV=0& ($P(Z0,U,5 )="")) D . . I ".1.2. "[("."_$P( Z0,U,4)_". ") S IBCNT ADD($P(Z0, U,4))=$G(I BCNTADD($P (Z0,U,4))) +1 Q .. N I .. F I=1 ,2 S IBCNT ADD(I)=$G( IBCNTADD(I ))+1 ; Che ck for dup lications S IBOK=1 ; Don't che ck if noth ing is bei ng changed . The ID i tself can be changed after ret urn to cal ling progr am. I IBFU NC="E" S Z 0=$G(^IBA( 355.92,IBD A,0)) I $P (Z0,U,3)=I BCAREUN!($ P(Z0,U,3)= ""&(IBCARE UN="*N/A*" )),IBFORM= $P(Z0,U,4) ,IBDIV=$P( Z0,U,5),IB ITYP=$P(Z0 ,U,6) G FL DSQ I $G(I B($S(IBEFT FL="E":"*N /A*",1:IBI TYP),IBFOR M,IBDIV,IB CAREUN)) D . N Z,ZPC 8 S Z=$G(I B($S(IBEFT FL="E":"*N /A*",1:IBI TYP),IBFOR M,IBDIV,IB CAREUN)) . S ZPC8="" . I +Z S ZPC8=$P($G (^IBA(355. 92,Z,0)),U ,8) . S IB OK="0^DUPL ICATE"_U_Z PC8 I IBOK ,IBFORM=0, $S($D(IB($ S(IBEFTFL= "E":"*N/A* ",1:IBITYP ),1,IBDIV, IBCAREUN)) !$D(IB($S( IBEFTFL="E ":"*N/A*", 1:IBITYP), 2,IBDIV,IB CAREUN)):1 ,1:0) S IB OK="0^FORM ^SPECIFIC" I IBOK,IB FORM'=0,IB FORM'=3,$S ($D(IB($S( IBEFTFL="E ":"*N/A*", 1:IBITYP), 0,IBDIV,IB CAREUN)):1 ,1:0) S IB OK="0^FORM ^BOTH" ; S IBLIMIT=$ S(IBEFTFL= "A":6,IBEF TFL="LF":5 ,1:"") I I BOK,IBFUNC ="A",IBEFT FL'="E" D . I ".1.2. "[("."_IBF ORM_".") D Q .. I $ G(IBCNTADD (IBFORM))> (IBLIMIT-1 ) S IBOK=" 0^LIMIT" . N I . I I BFORM=0 F I=1,2 I $G (IBCNTADD( I))>IBLIMI T S IBOK=" 0^LIMIT" Q ; I 'IBOK D . I $P( IBOK,U,2)= "DUPLICATE " D Q .. S DIR("A", 1)="This I D combinat ion is alr eady defin ed",DIR("A ",2)="" .. ; under " _$S($P(IBO K,U,3)="A" :" Additon al IDs",$P (IBOK,U,3) ="E":"Bill ing Provid er Seconda ry ID",1:" VA Lab/Fac ility IDs" )_$S(IBFUN C="A":" - try editin g it inste ad",1:""), DIR("A",2) =" " . ; . I $P(IBOK ,U,2)="BOT H" D Q .. S DIR("A" ,1)="An ID combinati on for bot h form typ es already exists. D elete this one",DIR( "A",2)="be fore defin ing and fo rm specifi c IDs"_$S( IBDIV:" fo r this div ision"),DI R("A",4)=" " . ; . I $P(IBOK,U ,2)="FORM" D Q .. I $P(IBOK,U ,3)="BOTH" S DIR("A" ,1)="This ID already exists fo r both for m types - Delete it to enter t his ID for ",DIR("A", 2)=" a spe cific form type",DIR ("A",3)=" " Q .. S D IR("A",1)= "This ID a lready exi sts for a specific f orm type - Delete sp ecific for m type",DI R("A",2)=" ID(s) bef ore enteri ng one for both form types",DI R("A",3)=" " . ; . I $P(IBOK, U,2)="LIMI T" D Q .. S DIR("A" ,1)="Limit is "_IBLI MIT_" IDs for each f orm type", DIR("A",2) =" " .. I IBEFTFL="A " D ... S DIR("A",1) ="A maximu m of 6 Add itional Bi lling Prov ider Sec I Ds can be entered fo r each For m" ... S D IR("A",2)= "Type. Bef ore you ca n add anot her ID, yo u must del ete an exi sting ID." ... S DIR ("A",3)=" " ; I 'IBO K S DIR(0) ="EA",DIR( "A")="PRES S RETURN T O CONTINUE : " W ! D ^DIR K DIR ;FLDSQ Q +IBOK | |
| 2319 | Modified L ogic (Chan ges are in bold) | |
| 2320 | IBCEP7C ;A LB/TMP - F unctions f or fac lev el PROVIDE R ID MAINT ;11-07-00 ;;2.0;INT EGRATED BI LLING;**13 7,232,320, 348,349,59 2**;21-MAR -94;Build 46 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; G AWAYAW AY Q ; ; I BDA - IEN for file 3 55.92 ; IB FUNC = "A" dd or "E"d itFACFLDS( IBDA,IBINS ,IBITYP,IB FORM,IBDIV ,IBFUNC,IB CAREUN,IBE FTFL) ; Ch k for dups on fac id fld combo s ; N IB,I BOK,DIC,DI R,X,Y,DTOU T,DUOUT,Z, Z0,DIE,DA, IBMAIN,IBQ UIT,IBPARA M,IBCUF,IB DA0,IBCNTA DD,I,IBLIM IT ; S IBO K=0,IBDA0= "" I $G(IB DA) S IBDA 0=$G(^IBA( 355.92,IBD A,0)) S IB PARAM=$G(^ TMP("IBCE_ PRVFAC_MAI NT_INS",$J )) S IBCUF =$S($P(IBD A0,U,3)]"" :1,1:0) ; Care Unit Flag ; I I BEFTFL="E" ,IBFUNC="A " D G:$D( DTOUT)!$D( DUOUT) FLD SQ . K DIR . S DIR(" A")="Defin e Billing Provider S econdary I Ds by Care Units? " . S DIR("B ")="No" . S DIR(0)=" YAO" . S D IR("?",1)= "Enter No to define a Billing Provider S econdary I D for the Division." . S DIR(" ?",2)="Ent er Yes to define a B illing Pro vider Seco ndary ID f or a speci fic Care U nit." . S DIR("?",3) ="If no Ca re Unit is entered o n Billing Screen 3, the Billin g Provider " . S DIR( "?")="Seco ndary ID d efined for the Divis ion will b e transmit ted in the claim." . D ^DIR . S IBCUF=$G (Y) ; Care Unit Flag ; ; Get t he Divisio n S IBMAIN =$$MAIN^IB CEP2B() S IBDIV=0 I IBEFTFL="E "!(IBEFTFL ="LF") D G:$D(DTOUT )!$D(DUOUT ) FLDSQ . K DIR . S (IBQUIT,IB OK)=0,DA=$ G(IBDA) . S DIR("A") ="Division : ",DIR(0) ="355.92,. 05AOr" . ; Default D ivision - Main if ad ding or Ex isting if editing . I IBFUNC=" E" S DIR(" B")=$P($$D IV^IBCEP7( $P(IBDA0,U ,5)),"/") . I IBFUNC ="A" S DIR ("B")=$P($ $EXTERNAL^ DILFD(355. 92,.05,"", IBMAIN),"/ ") . D ^DI R K DIR . Q:$D(DTOUT )!$D(DUOUT ) . S IBDI V=+$S(Y>0: +Y,1:0) ; ; See if t here are a ny Care Un its S IBCA REUN="*N/A *" I IBEFT FL="E",IBC UF D . N T AR . D LIS T^DIC(355. 95,,.01,,, ,,,"I $P(^ (0),U,3)=+ $G(IBINS), $P(^(0),U, 4)=+$G(IBD IV)",,"TAR ") . Q:+$G (TAR("DILI ST",0)) . S IBCUF=0 . W !!,"Th ere are no Care Unit s defined for this D ivision.", ! ; ; Get the Care U nit I IBEF TFL="E",IB CUF D I Y <1 G FLDSQ . K DIC . S DIC("A" )="Care Un it: " . I IBFUNC="E" D ; defa ult only i f editing .. Q:IBDIV '=$P(IBDA0 ,U,5) ; do n't defaul t if divis ion has ch anged .. S DIC("B")= $$EXTERNAL ^DILFD(355 .92,.03,"" ,$P(IBDA0, U,3)) . S DIC=355.95 ,DIC("S")= "I $P(^(0) ,U,3)=+$G( IBINS),$P( ^(0),U,4)= +$G(IBDIV) ",DIC(0)=" AEMQ" . D ^DIC . I Y >0 S IBCAR EUN=+Y ; ; Think thi s is done for sortin g purposes . Makes th e main div ision firs t I IBDIV= IBMAIN S I BDIV=0 ; ; Get the P rovider ID Type K DI R S IBQUIT =0 I $P(IB PARAM,U,3) '=1 D . S DIR("?")=" Can NOT be State LIC # or Bill ing Facili ty Primary " . S DIR( "A")="ID Q ualifier: " . S DIR( 0)="355.92 ,.06A^^K:' $$FACID^IB CEP7(+Y)!$ P($G(^IBE( 355.97,+Y, 1)),U,9)!( $P($G(^(0) ),U,3)=""0 B"") X" . W ! D ^DIR K DIR . I $D(DTOUT) !$D(DUOUT) S IBQUIT= 1 E D G: $D(DTOUT)! $D(DUOUT) FLDSQ . S DIR("A")=" ID Qualifi er: " ; ,DIR(0)="3 55.92,.06A r" . S DIR (0)="PAr^3 55.97:AEMQ " . S DIR( "?")="Ente r a Qualif ier to ind entify the type of I D number y ou are ent ering." . ; Default Type of ID - Electro nic Plan T ype if add ing or Exi sting if e diting . N PITIEN S PITIEN=$S( IBFUNC="A" &(IBEFTFL= "E"):$$BF^ IBCU(),IBF UNC="E":$P (IBDA0,U,6 ),1:"") . I PITIEN]" " S DIR("B ")=$P($G(^ IBE(355.97 ,PITIEN,0) ),U) . I I BEFTFL="E" D .. S DI R("?",1)=" The curre nt default ID Qualif ier is bas ed upon th e Electron ic Plan Ty pe." .. S DIR("?",2) =" You may change th e ID Quali fier and t he change will apply to all Pl an" .. S D IR("?")=" Types." .. S DIR("S" )="I ($P($ G(^(0)),U, 3)=$P($G(^ IBE(355.97 ,PITIEN,0) ),U,3))!$$ BPS^IBCEPU (Y)" . I I BEFTFL="A" S DIR("S" )="I $$BPS ^IBCEPU(Y) " . I IBEF TFL="LF" S DIR("S")= "I $$LFINS ^IBCEPU(Y) " . D ^DIR K DIR G:I BQUIT FLDS Q S IBITYP =$P(Y,U) ; ; Get For m Type K D IR S DIR(" A")="Form Type: " ;J WS;IB*2.0* 592;Dental form #7 J 430D S DIR (0)=$S(IBE FTFL="LF": "SA^0:ALL; 1:UB-04;2: CMS-1500;4 :J430D",1: "SA^1:UB-0 4;2:CMS-15 00;4:J430D ") I $G(IB DA) S DIR( "B")=$S(+$ P($G(^IBA( 355.92,IBD A,0)),U,4) =0:"ALL",1 :$P("UB-04 ^CMS-1500^ ^J430D",U, +$P($G(^IB A(355.92,I BDA,0)),U, 4))) ; end ;JWS;IB*2 .0*592;Den tal form # 7 J430D D ^DIR K DIR G:$D(DTOU T)!$D(DUOU T) FLDSQ S IBFORM=$P (Y,U) ; ; Set up arr ay of exis iting IDs by form ty pe, diviso n, and car e units to avoid dup lications S Z=0 F S Z=$O(^IBA (355.92,"B ",IBINS,Z) ) Q:'Z D . S Z0=$G( ^IBA(355.9 2,Z,0)) . I '(IBFUNC ="E"&(Z=IB DA)) D .. I IBEFTFL= "LF",$P(Z0 ,U,8)'="LF " Q ; If lab/facil ity ID, it only need s to be un ique among lab/facil ity IDs .. I IBEFTFL '="LF",$P( Z0,U,8)="L F" Q ; I f not lab/ facility I D, it must be unigue for the o thers (sec ondary and additiona l) .. I IB EFTFL="A", $P(Z0,U,8) ="E" Q .. I $P(Z0,U, 8)="E",IBE FTFL'="A" S IB("*N/A *",$P(Z0,U ,4),+$P(Z0 ,U,5),$S($ P(Z0,U,3)] "":$P(Z0,U ,3),1:"*N/ A*"))=Z .. S IB($P(Z 0,U,6),$P( Z0,U,4),+$ P(Z0,U,5), $S($P(Z0,U ,3)]"":$P( Z0,U,3),1: "*N/A*"))= Z . ; . ; count them . I IBFUN C="A",$P(Z 0,U,8)=IBE FTFL,IBDIV =$P(Z0,U,5 )!(IBDIV=0 &($P(Z0,U, 5)="")) D .. I ".1.2 ."[("."_$P (Z0,U,4)_" .") S IBCN TADD($P(Z0 ,U,4))=$G( IBCNTADD($ P(Z0,U,4)) )+1 Q .. N I .. F I= 1,2 S IBCN TADD(I)=$G (IBCNTADD( I))+1 ; Ch eck for du plications S IBOK=1 ; Don't ch eck if not hing is be ing change d. The ID itself can be change d after re turn to ca lling prog ram. I IBF UNC="E" S Z0=$G(^IBA (355.92,IB DA,0)) I $ P(Z0,U,3)= IBCAREUN!( $P(Z0,U,3) =""&(IBCAR EUN="*N/A* ")),IBFORM =$P(Z0,U,4 ),IBDIV=$P (Z0,U,5),I BITYP=$P(Z 0,U,6) G F LDSQ I $G( IB($S(IBEF TFL="E":"* N/A*",1:IB ITYP),IBFO RM,IBDIV,I BCAREUN)) D . N Z,ZP C8 S Z=$G( IB($S(IBEF TFL="E":"* N/A*",1:IB ITYP),IBFO RM,IBDIV,I BCAREUN)) . S ZPC8=" " . I +Z S ZPC8=$P($ G(^IBA(355 .92,Z,0)), U,8) . S I BOK="0^DUP LICATE"_U_ ZPC8 I IBO K,IBFORM=0 ,$S($D(IB( $S(IBEFTFL ="E":"*N/A *",1:IBITY P),1,IBDIV ,IBCAREUN) )!$D(IB($S (IBEFTFL=" E":"*N/A*" ,1:IBITYP) ,2,IBDIV,I BCAREUN)): 1,1:0) S I BOK="0^FOR M^SPECIFIC " ;JWS;IB* 2.0*592;De ntal form #7 J430D c hanged BOT H to ALL I IBOK,IBFO RM'=0,IBFO RM'=3,$S($ D(IB($S(IB EFTFL="E": "*N/A*",1: IBITYP),0, IBDIV,IBCA REUN)):1,1 :0) S IBOK ="0^FORM^A LL" ; S IB LIMIT=$S(I BEFTFL="A" :6,IBEFTFL ="LF":5,1: "") I IBOK ,IBFUNC="A ",IBEFTFL' ="E" D . I ".1.2."[( "."_IBFORM _".") D Q .. I $G(I BCNTADD(IB FORM))>(IB LIMIT-1) S IBOK="0^L IMIT" . N I . I IBFO RM=0 F I=1 ,2 I $G(IB CNTADD(I)) >IBLIMIT S IBOK="0^L IMIT" Q ; I 'IBOK D . I $P(IBO K,U,2)="DU PLICATE" D Q .. S D IR("A",1)= "This ID c ombination is alread y defined" ,DIR("A",2 )="" .. ; under "_$S ($P(IBOK,U ,3)="A":" Additonal IDs",$P(IB OK,U,3)="E ":"Billing Provider Secondary ID",1:"VA Lab/Facili ty IDs")_$ S(IBFUNC=" A":" - try editing i t instead" ,1:""),DIR ("A",2)=" " . ; . ;J WS;IB*2.0* 592;Dental form #7 J 430D chang ed to ALL from BOTH . I $P(IBO K,U,2)="AL L" D Q .. ;JWS;IB*2 .0*592;Den tal form # 7 J430D ch anged to ' all' from 'both' .. S DIR("A", 1)="An ID combinatio n for all form types already e xists. Del ete this o ne",DIR("A ",2)="befo re definin g a form s pecific ID "_$S(IBDIV :" for thi s division "),DIR("A" ,4)=" " . ; . I $P(I BOK,U,2)=" FORM" D Q .. ;JWS;I B*2.0*592; Dental for m #7 J430D changed t o ALL from BOTH .. I $P(IBOK,U ,3)="ALL" S DIR("A", 1)="This I D already exists for all form types - De lete it to enter thi s ID for", DIR("A",2) =" a speci fic form t ype",DIR(" A",3)=" " Q .. S DIR ("A",1)="T his ID alr eady exist s for a sp ecific for m type - D elete spec ific form type",DIR( "A",2)=" I D(s) befor e entering one for a ll form ty pes",DIR(" A",3)=" " . ; . I $ P(IBOK,U,2 )="LIMIT" D Q .. S DIR("A",1) ="Limit is "_IBLIMIT _" IDs for each form type",DIR ("A",2)=" " .. I IBE FTFL="A" D ... S DIR ("A",1)="A maximum o f 6 Additi onal Billi ng Provide r Sec IDs can be ent ered for e ach Form" ... S DIR( "A",2)="Ty pe. Before you can a dd another ID, you m ust delete an existi ng ID." .. . S DIR("A ",3)=" " ; I 'IBOK S DIR(0)="E A",DIR("A" )="PRESS R ETURN TO C ONTINUE: " W ! D ^DI R K DIR ;F LDSQ Q +IB OK | |
| 2321 | ||
| 2322 | ||
| 2323 | Routines | |
| 2324 | Activities | |
| 2325 | Routine Na me | |
| 2326 | IBCEP8A | |
| 2327 | Enhancemen t Category | |
| 2328 | New | |
| 2329 | Modify | |
| 2330 | Delete | |
| 2331 | No Change | |
| 2332 | RTM | |
| 2333 | ||
| 2334 | Related Op tions | |
| 2335 | None | |
| 2336 | Related Ro utines | |
| 2337 | Routines “ Called By” | |
| 2338 | Routines “ Called” | |
| 2339 | ||
| 2340 | ||
| 2341 | ||
| 2342 | ||
| 2343 | Data Dicti onary (DD) Reference s | |
| 2344 | ||
| 2345 | Related Pr otocols | |
| 2346 | None | |
| 2347 | Related In tegration Control Re gistration s (ICRs) | |
| 2348 | None | |
| 2349 | Data Passi ng | |
| 2350 | Input | |
| 2351 | Output Re ference | |
| 2352 | Both | |
| 2353 | Global Re ference | |
| 2354 | Local | |
| 2355 | Input Attr ibute Name and Defin ition | |
| 2356 | Name: | |
| 2357 | Definition : | |
| 2358 | Output Att ribute Nam e and Defi nition | |
| 2359 | Name: | |
| 2360 | Definition : | |
| 2361 | Current Lo gic | |
| 2362 | IBCEP8A ;A LB/ESG - F unctions f or provide r ID maint ;12/27/20 05 ;;2.0;I NTEGRATED BILLING;** 320,349**; 21-MAR-94; Build 46 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ; Q ;CLIA(IBIF N) ; Defau lt CLIA# f or claim N EW CLIA,NO NVA,DIV,IN ST S CLIA= "",IBIFN=+ $G(IBIFN) S NONVA=+$ P($G(^DGCR (399,IBIFN ,"U2")),U, 10) ; non- VA facilit y ptr I NO NVA S CLIA =$$CLIANVA ^IBCEP8(IB IFN) G CLI AX ; ; ret rieve the default VA clia# bas ed on clai m data S D IV=+$P($G( ^DGCR(399, IBIFN,0)), U,22) ; cl aim's divi sion I 'DI V G CLIAX S INST=+$P ($G(^DG(40 .8,DIV,0)) ,U,7) ; in st file po inter I 'I NST G CLIA X S CLIA=$ $ID^XUAF4( "CLIA",INS T) ; API f or clia#CL IAX ; Q CL IA ;LAB(IB IFN) ; Fun ction dete rmines if LAB type o f service is on clai m ; Claim must be a CMS-1500 c laim form type NEW L AB,LN,IBXD ATA S LAB= 0 I $$FT^I BCEF(IBIFN )'=2 G LAB X ;cms- 1500 form types only D F^IBCEF ("N-HCFA 1 500 SERVIC ES (PRINT) ",,,IBIFN) S LN=0 F S LN=$O(I BXDATA(LN) ) Q:'LN I $P(IBXDAT A(LN),U,4) =5 S LAB=1 QLABX ; Q LAB ;CLIA REQ(IBIFN) ; Functio n determin es if the CLIA# is r equired fo r claim ; Return val ue=1 Yes, the CLIA# is require d; otherwi se 0. NEW REQ S REQ= 0 I $$FT^I BCEF(IBIFN )'=2 G CLI AREQX ; cms-1 500 claim I '$$LAB(I BIFN) G CL IAREQX ; lab typ e of servi ce ; ; thi s is requi red for VA facility I '$P($G(^ DGCR(399,I BIFN,"U2") ),U,10) S REQ=1 G CL IAREQX ; ; for non-V A facility , further check non- VA care ty pe ; Codes 1 and 3 a re specifi cally Non- Lab I '$F( ".1.3.",". "_$P($G(^D GCR(399,IB IFN,"U2")) ,U,11)_"." ) S REQ=1C LIAREQX ; Q REQ ;MAM MO(IBIFN,I BMC) ; Fun ction to d etermine t he default mammograp hy certifi cation ; n umber for the claim ; Array IB MC is retu rned if pa ssed by re ference ; IBMC = # o f associat ed mammo#' s ; IBMC(n ) = [1] co ding syste m or "" fo r Non-VA F acilities ; [2] mamm o cert# NE W MAMMO,NO NVA,INST,C ODSYS,IBMC ID,CDSYS S MAMMO="", IBIFN=+$G( IBIFN),IBM C=0 S NONV A=+$P($G(^ DGCR(399,I BIFN,"U2") ),U,10) ; non-VA fac ility ptr I NONVA D G MAMMOX . S MAMMO= $P($G(^IBA (355.93,NO NVA,0)),U, 15) Q:MAMM O="" . S I BMC=1,IBMC (1)=""_U_M AMMO . Q ; ; retriev e the defa ult VA mam mo# based on claim d ata S INST =+$$SITE^V ASITE() ; inst file pointer I 'INST G MA MMOX ; ; K ernel API from XU*8* 394 to get a list of coding sy stems D LC DSYS^XUAF4 (.CDSYS) S CODSYS="M AMMO" F S CODSYS=$O (CDSYS(COD SYS)) Q:$E (CODSYS,1, 5)'="MAMMO " D . S I BMCID=$$ID ^XUAF4(COD SYS,INST) Q:IBMCID=" " . S IBMC =IBMC+1 . S IBMC(IBM C)=$P(CODS YS,"-",2)_ U_IBMCID . I $P(CODS YS,"-",2)= "FDA" S MA MMO=IBMCID ; FDA is default ID# . Q I IBMC,MAMM O="" S MAM MO=$P(IBMC (1),U,2)MA MMOX ; Q M AMMO ;MAMM ODP(IBIFN) ; Procedu re to disp lay a list ing of def ault mammo cert#'s ; Used duri ng input t emplate on screen 8 for CMS-15 00 claims NEW IBMC,I BZ I $$MAM MO(IBIFN,. IBMC) I 'I BMC W !!?3 ,"No defau lt mammogr aphy certi fication n umbers on file.",! G MAMMODPX W !!?3,"Th e Mammogra phy Certif ication #" W:IBMC>1 "'s" W " d efined for this " W: $P($G(^DGC R(399,IBIF N,"U2")),U ,10) "non- " W "VA fa cility " W :IBMC>1 "a re:" W:IBM C'>1 "is:" S IBZ=0 F S IBZ=$O (IBMC(IBZ) ) Q:'IBZ W !?7,$P(I BMC(IBZ),U ,2),?21,$P (IBMC(IBZ) ,U,1) W !? 3,"If you enter a di fferent nu mber it wi ll be sent with this claim onl y." I $P($ G(^DGCR(39 9,IBIFN,"U 2")),U,10) W !?3,"To change th e defined Mammograph y Certific ation #, u se Prov ID Maint." W !MAMMODPX ; Q ;XRAY (IBIFN) ; Function d etermines if X-RAY t ype of ser vice is on claim ; C laim must be a CMS-1 500 claim form type NEW XRAY,L N,IBXDATA S XRAY=0 I $$FT^IBCE F(IBIFN)'= 2 G XRAYX ;cms-15 00 form ty pes only D F^IBCEF(" N-HCFA 150 0 SERVICES (PRINT)", ,,IBIFN) S LN=0 F S LN=$O(IBX DATA(LN)) Q:'LN I $ P(IBXDATA( LN),U,4)=4 S XRAY=1 QXRAYX ; Q XRAY ;EIN (IBIFN) ; Function t o return t he EIN/tax ID for ei ther the V A facility ; or the non-VA fac ility. Use d for SUB- 9. NEW ID, IBU2,NONVA S ID="",I BU2=$G(^DG CR(399,IBI FN,"U2")) S NONVA=+$ P(IBU2,U,1 0) ; non-V A facility ptr I NON VA D G EI NX . S ID= $P($G(^IBA (355.93,NO NVA,0)),U, 9) ; ID# f rom file 3 55.93 . ; . ; if not defined i n file 355 .93, then use legacy field# 23 4 in file . ; 399 - non-va car e id#. See NONVAID^I BCEF72. . I ID="",$P (IBU2,U,12 )'="" S ID =$P(IBU2,U ,12) . Q ; ; VA faci lity S ID= $P($G(^IBE (350.9,1,1 )),U,5) ; Federal ta x id from site param sEINX ; Q ID ;BOX324 (IBIFN,IBX SAVE,IBXDA TA) ; Proc edure whic h further defines an d formats ; form 150 0, box 32, line 4. ; *** THIS IS NOT USE D FOR THE NEW CMS-15 00 CLAIM F ORM *** ; This is ei ther the f acility Ta x ID or it is the ma mmography ; certific ation numb er. ; Inpu t: IBIFN, IBXSAVE ar ray (pass by ref), I BXDATA (pa ss by ref) ; Output: IBXDATA ( pass by re f) ; NEW I BZ ; ; ret rieve the mammo# if it exists into varia ble IBZ D F^IBCEF("N -MAMMOGRAP HY CERT#", "IBZ",,IBI FN) ; ; If the claim is for th e main VAM C and ther e is no ma mmo# then print ; no thing here . See 364. 7 iens# 34 8, 319, 32 7 for simi lar I '$G( IBXSAVE("R EMOTE")),I BZ="" KILL IBXDATA G BOX32X ; ; If the m ammo# exis ts, then d isplay tha t I IBZ'=" " S IBXDAT A="Mammogr aphy Cert# "_IBZ G B OX32X ; ; Otherwise, display t he facilit y tax id S IBXDATA=" FAC. ID:"_ $G(IBXDATA )BOX32X ; KILL IBXSA VE("OFAC") ,IBXSAVE(" REMOTE") ; cleanup Q ;SUB1OK(I BIFN) ; Th is functio n determin es if the claim meet s the crit eria ; for being eli gible to o utput a SU B1 segment which is for profes sional ; p urchased s ervices. M ust be CMS -1500, non -VA facili ty, and Fe e Basis. ; NEW OK,IB U2 S OK=0, IBU2=$G(^D GCR(399,IB IFN,"U2")) ; I $$FT^ IBCEF(IBIF N)'=2 G SX ; must b e cms-1500 I '$P(IBU 2,U,10) G SX ; must be non-VA fac I '$F(".1 .2.","."_$ P(IBU2,U,1 1)_".") G SX ; must be FEE servic es ; S OK= 1 ; all ch ecks passe d, OK for SUB1 outpu tSX ; Q OK ; | |
| 2363 | Modified L ogic (Chan ges are in bold) | |
| 2364 | IBCEP8A ;A LB/ESG - F unctions f or provide r ID maint ;12/27/20 05 ;;2.0;I NTEGRATED BILLING;** 320,349,59 2**;21-MAR -94;Build 46 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; Q ;CLIA( IBIFN) ; D efault CLI A# for cla im NEW CLI A,NONVA,DI V,INST S C LIA="",IBI FN=+$G(IBI FN) S NONV A=+$P($G(^ DGCR(399,I BIFN,"U2") ),U,10) ; non-VA fac ility ptr I NONVA S CLIA=$$CLI ANVA^IBCEP 8(IBIFN) G CLIAX ; ; retrieve the defaul t VA clia# based on claim data S DIV=+$P ($G(^DGCR( 399,IBIFN, 0)),U,22) ; claim's division I 'DIV G CL IAX S INST =+$P($G(^D G(40.8,DIV ,0)),U,7) ; inst fil e pointer I 'INST G CLIAX S CL IA=$$ID^XU AF4("CLIA" ,INST) ; A PI for cli a#CLIAX ; Q CLIA ;LA B(IBIFN) ; Function determines if LAB ty pe of serv ice is on claim ; Cl aim must b e a CMS-15 00 claim f orm type N LAB,LN,IB XDATA S LA B=0 ;JWS;I B*2.0*592; Dental for m #7 J430D I $$FT^IB CEF(IBIFN) '=2,$$FT^I BCEF(IBIFN )'=7 G LAB X ;cms-15 00 and Den tal J430D form types only D F^ IBCEF("N-H CFA 1500 S ERVICES (P RINT)",,,I BIFN) S LN =0 F S LN =$O(IBXDAT A(LN)) Q:' LN I $P(I BXDATA(LN) ,U,4)=5 S LAB=1 QLAB X ; Q LAB ;CLIAREQ(I BIFN) ; Fu nction det ermines if the CLIA# is requir ed for cla im ; Retur n value=1 Yes, the C LIA# is re quired; ot herwise 0. N REQ S R EQ=0 ;JWS; IB*2.0*592 ;Dental fo rm #7 J430 D I $$FT^I BCEF(IBIFN )'=2,$$FT^ IBCEF(IBIF N)'=7 G CL IAREQX ; cms-1500 a nd Dental J430D I '$ $LAB(IBIFN ) G CLIARE QX ; lab type of se rvice ; ; this is re quired for VA facili ty I '$P($ G(^DGCR(39 9,IBIFN,"U 2")),U,10) S REQ=1 G CLIAREQX ; ; for no n-VA facil ity, furth er check n on-VA care type ; Co des 1 and 3 are spec ifically N on-Lab I ' $F(".1.3." ,"."_$P($G (^DGCR(399 ,IBIFN,"U2 ")),U,11)_ ".") S REQ =1CLIAREQX ; Q REQ ; MAMMO(IBIF N,IBMC) ; Function t o determin e the defa ult mammog raphy cert ification ; number f or the cla im ; Array IBMC is r eturned if passed by reference ; IBMC = # of assoc iated mamm o#'s ; IBM C(n) = [1] coding sy stem or "" for Non-V A Faciliti es ; [2] m ammo cert# NEW MAMMO ,NONVA,INS T,CODSYS,I BMCID,CDSY S S MAMMO= "",IBIFN=+ $G(IBIFN), IBMC=0 S N ONVA=+$P($ G(^DGCR(39 9,IBIFN,"U 2")),U,10) ; non-VA facility p tr I NONVA D G MAMM OX . S MAM MO=$P($G(^ IBA(355.93 ,NONVA,0)) ,U,15) Q:M AMMO="" . S IBMC=1,I BMC(1)=""_ U_MAMMO . Q ; ; retr ieve the d efault VA mammo# bas ed on clai m data S I NST=+$$SIT E^VASITE() ; inst fi le pointer I 'INST G MAMMOX ; ; Kernel A PI from XU *8*394 to get a list of coding systems D LCDSYS^XU AF4(.CDSYS ) S CODSYS ="MAMMO" F S CODSYS =$O(CDSYS( CODSYS)) Q :$E(CODSYS ,1,5)'="MA MMO" D . S IBMCID=$ $ID^XUAF4( CODSYS,INS T) Q:IBMCI D="" . S I BMC=IBMC+1 . S IBMC( IBMC)=$P(C ODSYS,"-", 2)_U_IBMCI D . I $P(C ODSYS,"-", 2)="FDA" S MAMMO=IBM CID ; F DA is defa ult ID# . Q I IBMC,M AMMO="" S MAMMO=$P(I BMC(1),U,2 )MAMMOX ; Q MAMMO ;M AMMODP(IBI FN) ; Proc edure to d isplay a l isting of default ma mmo cert#' s ; Used d uring inpu t template on screen 8 for CMS -1500 clai ms NEW IBM C,IBZ I $$ MAMMO(IBIF N,.IBMC) I 'IBMC W ! !?3,"No de fault mamm ography ce rtificatio n numbers on file.", ! G MAMMOD PX W !!?3, "The Mammo graphy Cer tification #" W:IBMC >1 "'s" W " defined for this " W:$P($G(^ DGCR(399,I BIFN,"U2") ),U,10) "n on-" W "VA facility " W:IBMC>1 "are:" W: IBMC'>1 "i s:" S IBZ= 0 F S IBZ =$O(IBMC(I BZ)) Q:'IB Z W !?7,$ P(IBMC(IBZ ),U,2),?21 ,$P(IBMC(I BZ),U,1) W !?3,"If y ou enter a different number it will be s ent with t his claim only." I $ P($G(^DGCR (399,IBIFN ,"U2")),U, 10) W !?3, "To change the defin ed Mammogr aphy Certi fication # , use Prov ID Maint. " W !MAMMO DPX ; Q ;X RAY(IBIFN) ; Functio n determin es if X-RA Y type of service is on claim ; Claim mu st be a CM S-1500 cla im form ty pe NEW XRA Y,LN,IBXDA TA S XRAY= 0 ;JWS;IB* 2.0*592;De ntal form #7 J430D I $$FT^IBCE F(IBIFN)'= 2,$$FT^IBC EF(IBIFN)' =7 G XRAYX ;cms-150 0 and Dent al J430D f orm types only D F^I BCEF("N-HC FA 1500 SE RVICES (PR INT)",,,IB IFN) S LN= 0 F S LN= $O(IBXDATA (LN)) Q:'L N I $P(IB XDATA(LN), U,4)=4 S X RAY=1 QXRA YX ; Q XRA Y ;EIN(IBI FN) ; Func tion to re turn the E IN/tax ID for either the VA fa cility ; o r the non- VA facilit y. Used fo r SUB-9. N EW ID,IBU2 ,NONVA S I D="",IBU2= $G(^DGCR(3 99,IBIFN," U2")) S NO NVA=+$P(IB U2,U,10) ; non-VA fa cility ptr I NONVA D G EINX . S ID=$P($ G(^IBA(355 .93,NONVA, 0)),U,9) ; ID# from file 355.9 3 . ; . ; if not def ined in fi le 355.93, then use legacy fie ld# 234 in file . ; 399 - non- va care id #. See NON VAID^IBCEF 72. . I ID ="",$P(IBU 2,U,12)'=" " S ID=$P( IBU2,U,12) . Q ; ; V A facility S ID=$P($ G(^IBE(350 .9,1,1)),U ,5) ; Fede ral tax id from site paramsEIN X ; Q ID ; BOX324(IBI FN,IBXSAVE ,IBXDATA) ; Procedur e which fu rther defi nes and fo rmats ; fo rm 1500, b ox 32, lin e 4. ; *** THIS IS N OT USED FO R THE NEW CMS-1500 C LAIM FORM *** ; This is either the facil ity Tax ID or it is the mammog raphy ; ce rtificatio n number. ; Input: I BIFN, IBXS AVE array (pass by r ef), IBXDA TA (pass b y ref) ; O utput: IBX DATA (pass by ref) ; NEW IBZ ; ; retriev e the mamm o# if it e xists into variable IBZ D F^IB CEF("N-MAM MOGRAPHY C ERT#","IBZ ",,IBIFN) ; ; If the claim is for the ma in VAMC an d there is no mammo# then prin t ; nothin g here. Se e 364.7 ie ns# 348, 3 19, 327 fo r similar I '$G(IBXS AVE("REMOT E")),IBZ=" " KILL IBX DATA G BOX 32X ; ; If the mammo # exists, then displ ay that I IBZ'="" S IBXDATA="M ammography Cert# "_I BZ G BOX32 X ; ; Othe rwise, dis play the f acility ta x id S IBX DATA="FAC. ID:"_$G(I BXDATA)BOX 32X ; KILL IBXSAVE(" OFAC"),IBX SAVE("REMO TE") ; cle anup Q ;SU B1OK(IBIFN ) ; This f unction de termines i f the clai m meets th e criteria ; for bei ng eligibl e to outpu t a SUB1 s egment whi ch is for profession al ; purch ased servi ces. Must be CMS-150 0, non-VA facility, and Fee Ba sis. ; NEW OK,IBU2 S OK=0,IBU2 =$G(^DGCR( 399,IBIFN, "U2")) ; ; JWS;IB*2.0 *592;Denta l form #7 J430D I $$ FT^IBCEF(I BIFN)'=2,$ $FT^IBCEF( IBIFN)'=7 G SX ; mu st be cms- 1500 or De ntal J430D I '$P(IBU 2,U,10) G SX ; must be non-VA fac I '$F(".1 .2.","."_$ P(IBU2,U,1 1)_".") G SX ; must be FEE servic es ; S OK= 1 ; all ch ecks passe d, OK for SUB1 outpu tSX ; Q OK ; | |
| 2365 | ||
| 2366 | ||
| 2367 | Routines | |
| 2368 | Activities | |
| 2369 | Routine Na me | |
| 2370 | IBCEP9 | |
| 2371 | Enhancemen t Category | |
| 2372 | New | |
| 2373 | Modify | |
| 2374 | Delete | |
| 2375 | No Change | |
| 2376 | RTM | |
| 2377 | ||
| 2378 | Related Op tions | |
| 2379 | None | |
| 2380 | Related Ro utines | |
| 2381 | Routines “ Called By” | |
| 2382 | Routines “ Called” | |
| 2383 | ||
| 2384 | ||
| 2385 | ||
| 2386 | ||
| 2387 | Data Dicti onary (DD) Reference s | |
| 2388 | ||
| 2389 | Related Pr otocols | |
| 2390 | None | |
| 2391 | Related In tegration Control Re gistration s (ICRs) | |
| 2392 | None | |
| 2393 | Data Passi ng | |
| 2394 | Input | |
| 2395 | Output Re ference | |
| 2396 | Both | |
| 2397 | Global Re ference | |
| 2398 | Local | |
| 2399 | Input Attr ibute Name and Defin ition | |
| 2400 | Name: | |
| 2401 | Definition : | |
| 2402 | Output Att ribute Nam e and Defi nition | |
| 2403 | Name: | |
| 2404 | Definition : | |
| 2405 | Current Lo gic | |
| 2406 | IBCEP9 ;AL B/TMP - MA SS UPDATE OF PROVIDE R ID FROM FILE OR MA NUAL ;08-N OV-00 ;;2. 0;INTEGRAT ED BILLING ;**137,200 ,320,348,3 49**;21-MA R-94;Build 46 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ;EN ; Get parameter s and mass input pro vider id b y ins co N A,DA,DIC, DIE,DIK,DI R,DR,POP,Q ,Q0,X,Y,Y3 ,Z,Z0 N IB CND,IBCU,I BCT,IBDELI M,IBFILE,I BFILEN,IBF ILEP,IBFOR MAT N IBFT ,IBINFILE, IBINS,IBL, IBN,IBOK,I BOPEN,IBPO S,IBPT,IBQ UIT N IBQU IT1,IBQUOT ES,IBRA,IB S,IBSA,IBS TART,IBSRC ,IBVERIFY, IBVNAME K ^TMP("IBPI D_IN",$J), ^TMP("IBPI D-ERR",$J) ,^TMP("IBP ID",$J) S IBQUIT=01 ; Select I NSURANCE C OMPANY NAM E: G:IBQUI T ENQ S IB QUIT1=0 S DIC("S")=" I $P($G(^D IC(36,+Y,3 )),U,13)'= ""C""" S D IC(0)="AEM Q",DIC="^D IC(36," D ^DIC I Y'> 0 G ENQ S IBINS=+Y S IBQUIT=$$ LOCK^IBCEP 9B(IBINS) I IBQUIT,$ G(IBINS) D G 1 . D UNLOCK^IBC EP9B(IBINS ) . S IBIN S="",IBQUI T=0 . W !! ,"Unable t o lock all associate d insuranc e companie s.",!,"Ple ase try ag ain later. ",!! ;2 ; get data s ource S IB QUIT1=0 S DIR(0)="SA ^M:Manual Entry;F:En try from f ile" S DIR ("A")="PRO VIDER ID D ATA SOURCE : ",DIR("B ")="Manual Entry" S Y=$$DIR(.D IR,.IBQUIT ,.IBQUIT1) I Y=""!(" FM"'[Y)!IB QUIT1 D UN LOCK^IBCEP 9B(IBINS) G 1 S IBSR C=Y,IBVERI FY=0 S IBV ERIFY=(Y=" M") I 'IBV ERIFY D G :IBQUIT EN Q G:IBQUIT 2 . S DIR (0)="YA",D IR("A")="D O YOU WANT TO VIEW/V ERIFY EACH ENTRY BEF ORE IT GET S UPDATED? : " . S Y= $$DIR(.DIR ,.IBQUIT,. IBQUIT1) . I Y=1 S I BVERIFY=1 ; G:IBSRC= "M" 421 ; get parame ters for f ile type G :IBQUIT EN Q S IBQUIT 1=0 S DIR( 0)="SA^D:D ELIMITED;F :FIXED LEN GTH",DIR(" B")="D",DI R("A")="SE LECT FILE FORMAT: " S Y=$$DIR( .DIR,.IBQU IT,.IBQUIT 1) I IBQUI T1 G 2 S I BPOS=Y I I BPOS="D" D G:IBQUIT 1 21 . S D IR(0)="FA^ 1:1",DIR(" B")=",",DI R("A")="DE LIMITER CH ARACTER: " . S Y=$$D IR(.DIR,.I BQUIT,.IBQ UIT1) . Q: IBQUIT1 . S $P(IBPOS ,U,2)=Y . S DIR(0)=" YA",DIR("B ")="NO",DI R("A")="AR E QUOTES W ITHIN A FI ELD DOUBLE QUOTED?: " . S Y=$$ DIR(.DIR,. IBQUIT,.IB QUIT1,,,1) . Q:IBQUI T1 . S $P( IBPOS,U,3) =Y3 ; sele ct externa l file nam e G:IBQUIT ENQ S IBQ UIT1=0 G:I BSRC="M" 2 S DIR(0)= "FA^1:60" S DIR("A") ="FILE NAM E PATH: ", DIR("B")=$ $PWD^%ZISH S Y=$$DIR (.DIR,.IBQ UIT,.IBQUI T1) G:IBQU IT1 2 S IB FILEP=$P(Y ,U) S DIR( 0)="FA^1:6 0" S DIR(" A")="FILE NAME: " S IBSA("*")= "" S DIR(" ?")="^S Y3 =$$LIST^%Z ISH(IBFILE P,""IBSA"" ,""IBRA"") I Y3=1 S Y3="""" F S Y3=$O(IB RA(Y3)) Q: Y3="""" W !,Y3" S Y= $$DIR(.DIR ,.IBQUIT,. IBQUIT1,,, 1) G:IBQUI T1 2 S IBF ILEN=$P(Y, U) K ^TMP( $J),IBRA,Y 3 N Y S Y= $$FTG^%ZIS H(IBFILEP, IBFILEN,$N A(^TMP($J, 1)),2) I Y =0 W !,"FI LE ",IBFIL EP,IBFILEN ," COULD N OT BE FOUN D OR COULD NOT BE OP ENED",! G 3 S IBFILE =IO4 ; sel ect Provid er ID Type G:IBQUIT ENQ S IBQU IT1=0 S DI R(0)="355. 9,.06" I I BSRC="M" S Z=$P($G(^ IBE(355.97 ,+$$PPTYP^ IBCEP0(IBI NS),0)),U) S:Z'="" D IR("B")=Z S Y=$$DIR( .DIR,.IBQU IT,.IBQUIT 1) G:Y=""! IBQUIT1 3 S IBPTYP=$ P(Y,U)5 ; select For ms Type G: IBQUIT ENQ S IBQUIT1 =0 S DIR(0 )="355.9,. 04r",DIR(" B")="BOTH UB-04 AND CMS-1500 F ORMS" S Y= $$DIR(.DIR ,.IBQUIT,. IBQUIT1) G :IBQUIT1 4 I Y=""!(" 012"'[Y) G 5 S IBFT= $P(Y,U)6 ; select Bi ll Care Ty pe G:IBQUI T ENQ S IB QUIT1=0 S DIR(0)="35 5.9,.05r", DIR("B")=" BOTH INPAT IENT AND O UTPATIENT" S Y=$$DIR (.DIR,.IBQ UIT,.IBQUI T1) G:IBQU IT1 5 I Y= ""!("0123" '[$P(Y,U)) G 6 S IBC T=$P(Y,U) ; S IBCND= $$CAREUN^I BCEP3(IBIN S,IBPTYP,I BFT,IBCT,I BCT=3)7 ; get Care U nit G:IBQU IT ENQ S I BQUIT1=0 I IBCND D G:IBQUIT1 6 . S DIR( 0)="355.9, .03O" . S Y=$$DIR(.D IR,.IBQUIT ,.IBQUIT1) . Q:IBQUI T1 . S IBC U=$P(Y,U) . I IBCU=" " W !!,$J( "",22),"** *** WARNIN G *****",! ," YOU WIL L NEED TO MANUALLY E NTER THE C ARE UNIT F OR EACH PR OVIDER",!! ; ; Manua l entry to get provi ders from VistA I IB SRC="M" D MANUAL^IBC EP9B G:IBQ UIT1 6 ; F or 'OTHER' files ask position/ length or delimiter/ piece for data I IBS RC="F" D I IBQUIT1 G:'IBCND 6 G 7 . F Z ="PROV. SS N^SSN^15^1 ","PROV. N AME^NAM^30 ","PROV. 1 500 ID^PRO F_ID^15"," PROV. UB-0 4 ID^INST_ ID^15" D Q:IBQUIT1 .. I $P(IB POS,U)'="D " D ... N X ... I IB FT=0!(IBFT =1) Q:Z["P ROF_ID" I Z["INST_I D" S $P(Z, U)="PROV. ID" ... I IBFT=2 Q:Z ["INST_ID" ... S DIR ("A")="STA RT POSITIO N OF "_$P( Z,U)_" FIE LD: " ... S DIR(0)=" NA"_$S($P( Z,U,4)!($P (Z,U)["PRO V. ID")!($ P(Z,U)["_I D"):"",1:" O")_"^1:25 0" ... W ! S X=$$DIR 1^IBCEP9B( .DIR,Z,.IB QUIT,.IBQU IT1) ... Q :IBQUIT1 . .. I X>0 D .... S IB POS($P(Z,U ,2))=X ... . S DIR("A ")="LENGTH OF "_$P(Z ,U)_" FIEL D: " .... S DIR(0)=" NA"_$S($P( Z,U,3):"^1 :"_$P(Z,U, 3),1:"") . ... S X=$$ DIR1^IBCEP 9B(.DIR,Z, .IBQUIT,.I BQUIT1) .. .. Q:IBQUI T1 .... S $P(IBPOS($ P(Z,U,2)), U,2)=IBPOS ($P(Z,U,2) )+X-1 .. ; .. I $P(I BPOS,U)="D " D ... I IBFT=0!(IB FT=1) Q:Z[ "PROF_ID" I Z["INST _ID" S $P( Z,U)="PROV . ID" ... I IBFT=2 Q :Z["INST_I D" ... W ! S DIR("A" )="STARTIN G '"_$P(IB POS,U,2)_" ' PIECE # OF "_$P(Z, U)_" FIELD : " ... S DIR(0)="NA "_$S($P(Z, U,4)!($P(Z ,U)["PROV. ID")!($P( Z,U)["_ID" ):"",1:"O" ) ... S X= $$DIR1^IBC EP9B(.DIR, Z,.IBQUIT, .IBQUIT1) ... Q:IBQU IT1 ... I X>0 D .... S (DIR("B "),IBPOS($ P(Z,U,2))) =X .... S DIR("A")=" ENDING '"_ $P(IBPOS,U ,2)_"' PIE CE # OF "_ $P(Z,U)_" FIELD: " . ... S DIR( 0)="NA"_$S ($P(Z,U,4) :"",1:"O") _U_(IBPOS( $P(Z,U,2)) )_":99" .. .. S DIR(" ?")="JUST PRESS THE ENTER KEY IF THIS FI ELD IS CON TAINED IN ONLY 1 PIE CE" .... S Y=$$DIR1^ IBCEP9B(.D IR,Z,.IBQU IT,.IBQUIT 1) .... Q: IBQUIT1 .. .. W ! I Y >0,Y'=IBPO S($P(Z,U,2 )) S $P(IB POS($P(Z,U ,2)),U,2)= Y .. ; . Q :IBQUIT1 . D READFIL E^IBCEP9B . ;P1 ; S Z="" F S Z=$O(^TMP( "IBPID_IN" ,$J,Z)) Q: Z="" S Z0 =0 F S Z0 =$O(^TMP(" IBPID_IN", $J,Z,Z0)) Q:'Z0 S Q =$G(^(Z0)) D G:IBQU IT ENQ . ; . I IBSRC ="M" D Q .. D DISP^ IBCEP9B(Q, 0,IBINS,IB PTYP,IBFT, IBCT,$G(IB CU),,IBSRC ) .. ; Man ually add IDs .. S I BN=$$DUP(+ Z0_";VA(20 0,",IBINS, $S($G(IBCU )'="":IBCU ,1:"*N/A*" ),IBFT,IBC T,IBPTYP) .. I 'IBN D Q:IBQUI T!(IBN'>0) ... S IBN =$$ADDID^I BCEP9B(Z0, IBINS,$G(I BCU),IBFT, IBCT,IBPTY P,,.IBQUIT ) .. S DIE ="^IBA(355 .9,",DR=". 07",DA=+IB N D ^DIE . . I $D(Y)! ($P($G(^IB A(355.9,+I BN,0)),U,7 )="") D .. . I $P(IBN ,U,3) S DA =+IBN,DIK= "^IBA(355. 9," D ^DIK ... S DIR (0)="YA",D IR("B")="N O",DIR("A" )="DO YOU WANT TO ST OP ENTERIN G PROVIDER IDs?: " . .. S Y=$$D IR(.DIR,.I BQUIT,.IBQ UIT1,,1,1) ... I Y=1 S IBQUIT= 1 .. S IBI D=$P($G(^I BA(355.9,+ IBN,0)),U, 7) .. S:$L (IBID) ^TM P("IBPID_I N",$J,U,Z0 ,"INST_ID" )=IBID .. I IBID="" K ^TMP("IB PID_IN",$J ,U,Z0) .. I IBQUIT=1 F S Z0=$ O(^TMP("IB PID_IN",$J ,U,Z0)) Q: Z0="" K ^ TMP("IBPID _IN",$J,U, Z0) ; user wants to stop, remo ve all rem aining nam es from li st . ; . S IBOK=1 . N IBX,IBID . M IBX=^ TMP("IBPID _IN",$J,Z, Z0) . I IB SRC="F" S IBID=$S(IB FT=0!(IBFT =1):$G(IBX ("INST_ID" )),1:$G(IB X("PROF_ID "))) . I $ G(IBVERIFY ) D ; Dis play recor d, ask OK to file id 's .. D DI SP^IBCEP9B (Q,0,IBINS ,IBPTYP,IB FT,IBCT,$G (IBCU),,IB SRC) .. W !,"PROVIDE R ID: ",IB ID .. S DI R("A")="OK TO FILE T HIS ID FOR THIS PROV IDER?: ",D IR(0)="YA" ,DIR("B")= "NO" .. S Y=$$DIR(.D IR,,,,1,1) .. I Y'=1 D Q ; S end to err or array . .. S IBOK= 0 ... S ^T MP("IBPID- ERR",$J,2, $P(IBX,U), $P(IBX,U,2 )_" ","PRO V ID")=IBI D ... S ^T MP("IBPID_ IN",$J,U,Z 0,0)="NO P RINT" ... N Z1 ... S Z1="" F S Z1=$O(IB X(Z1)) Q:Z 1="" I $G (IBX(Z1))' ="",Z1'["_ ID" S ^TMP ("IBPID-ER R",$J,2,$P (IBX,U),$P (IBX,U,2)_ " ",Z1)=IB X(Z1) . I IBOK D ; Add/update the recor d .. I IBS RC="F" D . .. I IBID' ="" D .... S IBN=$$A DDID^IBCEP 9B(+Z0,IBI NS,$G(IBCU ),IBFT,IBC T,IBPTYP,, .IBQUIT) . ... I IBQU IT D:IBN>0 Q ..... S DA=+IBN,D IK="^IBA(3 55.9," D ^ DIK .... I IBN>0 S D IE="^IBA(3 55.9,",DA= +IBN,DR=". 07////"_IB ID D ^DIE .. ; ;ENQ ; Print re port, exit I $G(IBIN S) D . D C OPY^IBCEPC ID(IBINS) . D UNLOCK ^IBCEP9B(I BINS) ; I ($D(^TMP(" IBPID-ERR" ,$J)))!($D (^TMP("IBP ID_IN",$J) )) D . N % ZIS,ZTSAVE ,ZTRTN,ZTD ESC,IBDUZ . S IBDUZ= $G(DUZ) . S %ZIS="QM " D ^%ZIS Q:POP . I $D(IO("Q") ) K IO("Q" ) D D ^%Z TLOAD K ZT SK D HOME^ %ZIS Q .. S ZTRTN="P RTERR^IBCE P9B",ZTSAV E("^TMP("" IBPID-ERR" ",$J,")="" .. S ZTSA VE("^TMP(" "IBPID_IN" ",$J,")="" ,ZTSAVE("I B*")="" .. S ZTDESC= "IB - PROV IDER ID BA TCH UPDATE ERROR LOG " . U IO . D PRTERR^ IBCEP9B K ^TMP("IBPI D_IN",$J), ^TMP("IBPI D-ERR",$J) ,^TMP("IBP ID",$J) U IO(0) Q ;D UP(IBPRV,I BINS,IBCU, IBFT,IBCT, IBPTYP) ; Check if p rovider id record al ready exis ts in file 355.9 Q + $O(^IBA(35 5.9,"AUNIQ ",IBPRV,IB INS,IBCU,I BFT,IBCT,I BPTYP,0)) ;ERREOF ; Traps EOF error on f ile read f or non-DSM systems N IBERROR S IBERROR=$ $EC^%ZOSV I IBERROR[ "ENDOFFILE " D CLOSE( .IBOPEN) G ENQ D ^%Z TER Q ;CLO SE(IBOPEN) ; Close f ile D CLOS E^%ZISH("I BINFILE") S IBOPEN=0 Q ;DIR(DI R,IBQUIT,I BQUIT1,X,I BW1,IBW2) ; Standard call to ^ DIR ; Inpu ts DIR arr ay ; Retur ns IBQUIT, IBQUIT1,X if passed by referen ce ; AND ; FUNCTION returns th e value of Y ; IBW1 = 1 if ini tial write ! should be done ; IBW2 = 1 i f last wri te ! shoul d be done N DIROUT,D TOUT,DUOUT ,DA W:$G(I BW1) ! D ^ DIR K DIR W:$G(IBW2) ! S (IBQU IT,IBQUIT1 )=0 S DIR( "?")="Ente r '^' to b ack up one prompt or '^^' to e xit the op tion" I $D (DIROUT) S (IBQUIT,I BQUIT1)=1 I $D(DTOUT )!$D(DUOUT ) S IBQUIT 1=1 Q Y ;E RR ; Error list ;; I NVALID OR MISSING SS N - NO PRO VIDER MATC H FOUND ;; NO UPDATE PER USER REQUEST ;; | |
| 2407 | Modified L ogic (Chan ges are in bold) | |
| 2408 | IBCEP9 ;AL B/TMP - MA SS UPDATE OF PROVIDE R ID FROM FILE OR MA NUAL ;08-N OV-00 ;;2. 0;INTEGRAT ED BILLING ;**137,200 ,320,348,3 49,592**;2 1-MAR-94;B uild 46 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ;EN ; Get param eters and mass input provider id by ins co N A,DA, DIC,DIE,DI K,DIR,DR,P OP,Q,Q0,X, Y,Y3,Z,Z0 N IBCND,IB CU,IBCT,IB DELIM,IBFI LE,IBFILEN ,IBFILEP,I BFORMAT N IBFT,IBINF ILE,IBINS, IBL,IBN,IB OK,IBOPEN, IBPOS,IBPT ,IBQUIT N IBQUIT1,IB QUOTES,IBR A,IBS,IBSA ,IBSTART,I BSRC,IBVER IFY,IBVNAM E K ^TMP(" IBPID_IN", $J),^TMP(" IBPID-ERR" ,$J),^TMP( "IBPID",$J ) S IBQUIT =01 ; Sele ct INSURAN CE COMPANY NAME: G:I BQUIT ENQ S IBQUIT1= 0 S DIC("S ")="I $P($ G(^DIC(36, +Y,3)),U,1 3)'=""C""" S DIC(0)= "AEMQ",DIC ="^DIC(36, " D ^DIC I Y'>0 G EN Q S IBINS= +Y S IBQUI T=$$LOCK^I BCEP9B(IBI NS) I IBQU IT,$G(IBIN S) D G 1 . D UNLOCK ^IBCEP9B(I BINS) . S IBINS="",I BQUIT=0 . W !!,"Unab le to lock all assoc iated insu rance comp anies.",!, "Please tr y again la ter.",!! ; 2 ; get da ta source S IBQUIT1= 0 S DIR(0) ="SA^M:Man ual Entry; F:Entry fr om file" S DIR("A")= "PROVIDER ID DATA SO URCE: ",DI R("B")="Ma nual Entry " S Y=$$DI R(.DIR,.IB QUIT,.IBQU IT1) I Y=" "!("FM"'[Y )!IBQUIT1 D UNLOCK^I BCEP9B(IBI NS) G 1 S IBSRC=Y,IB VERIFY=0 S IBVERIFY= (Y="M") I 'IBVERIFY D G:IBQUI T ENQ G:IB QUIT 2 . S DIR(0)="Y A",DIR("A" )="DO YOU WANT TO VI EW/VERIFY EACH ENTRY BEFORE IT GETS UPDA TED?: " . S Y=$$DIR( .DIR,.IBQU IT,.IBQUIT 1) . I Y=1 S IBVERIF Y=1 ; G:IB SRC="M" 42 1 ; get pa rameters f or file ty pe G:IBQUI T ENQ S IB QUIT1=0 S DIR(0)="SA ^D:DELIMIT ED;F:FIXED LENGTH",D IR("B")="D ",DIR("A") ="SELECT F ILE FORMAT : " S Y=$$ DIR(.DIR,. IBQUIT,.IB QUIT1) I I BQUIT1 G 2 S IBPOS=Y I IBPOS=" D" D G:IB QUIT1 21 . S DIR(0)= "FA^1:1",D IR("B")=", ",DIR("A") ="DELIMITE R CHARACTE R: " . S Y =$$DIR(.DI R,.IBQUIT, .IBQUIT1) . Q:IBQUIT 1 . S $P(I BPOS,U,2)= Y . S DIR( 0)="YA",DI R("B")="NO ",DIR("A") ="ARE QUOT ES WITHIN A FIELD DO UBLE QUOTE D?: " . S Y=$$DIR(.D IR,.IBQUIT ,.IBQUIT1, ,,1) . Q:I BQUIT1 . S $P(IBPOS, U,3)=Y3 ; select ext ernal file name G:IB QUIT ENQ S IBQUIT1=0 G:IBSRC=" M" 2 S DIR (0)="FA^1: 60" S DIR( "A")="FILE NAME PATH : ",DIR("B ")=$$PWD^% ZISH S Y=$ $DIR(.DIR, .IBQUIT,.I BQUIT1) G: IBQUIT1 2 S IBFILEP= $P(Y,U) S DIR(0)="FA ^1:60" S D IR("A")="F ILE NAME: " S IBSA(" *")="" S D IR("?")="^ S Y3=$$LIS T^%ZISH(IB FILEP,""IB SA"",""IBR A"") I Y3= 1 S Y3=""" " F S Y3=$ O(IBRA(Y3) ) Q:Y3=""" " W !,Y3" S Y=$$DIR( .DIR,.IBQU IT,.IBQUIT 1,,,1) G:I BQUIT1 2 S IBFILEN=$ P(Y,U) K ^ TMP($J),IB RA,Y3 N Y S Y=$$FTG^ %ZISH(IBFI LEP,IBFILE N,$NA(^TMP ($J,1)),2) I Y=0 W ! ,"FILE ",I BFILEP,IBF ILEN," COU LD NOT BE FOUND OR C OULD NOT B E OPENED", ! G 3 S IB FILE=IO4 ; select Pr ovider ID Type G:IBQ UIT ENQ S IBQUIT1=0 S DIR(0)=" 355.9,.06" I IBSRC=" M" S Z=$P( $G(^IBE(35 5.97,+$$PP TYP^IBCEP0 (IBINS),0) ),U) S:Z'= "" DIR("B" )=Z S Y=$$ DIR(.DIR,. IBQUIT,.IB QUIT1) G:Y =""!IBQUIT 1 3 S IBPT YP=$P(Y,U) 5 ; select Forms Typ e G:IBQUIT ENQ S IBQ UIT1=0 ;JW S;IB*2.0*5 92 US1108 - Dental E DI 837D / form J430D S DIR(0)= "355.9,.04 r",DIR("B" )="UB-04, CMS-1500 a nd J430D F ORMS" S Y= $$DIR(.DIR ,.IBQUIT,. IBQUIT1) G :IBQUIT1 4 I Y=""!(" 012"'[Y) G 5 S IBFT= $P(Y,U)6 ; select Bi ll Care Ty pe G:IBQUI T ENQ S IB QUIT1=0 S DIR(0)="35 5.9,.05r", DIR("B")=" BOTH INPAT IENT AND O UTPATIENT" S Y=$$DIR (.DIR,.IBQ UIT,.IBQUI T1) G:IBQU IT1 5 I Y= ""!("0123" '[$P(Y,U)) G 6 S IBC T=$P(Y,U) ; S IBCND= $$CAREUN^I BCEP3(IBIN S,IBPTYP,I BFT,IBCT,I BCT=3)7 ; get Care U nit G:IBQU IT ENQ S I BQUIT1=0 I IBCND D G:IBQUIT1 6 . S DIR( 0)="355.9, .03O" . S Y=$$DIR(.D IR,.IBQUIT ,.IBQUIT1) . Q:IBQUI T1 . S IBC U=$P(Y,U) . I IBCU=" " W !!,$J( "",22),"** *** WARNIN G *****",! ," YOU WIL L NEED TO MANUALLY E NTER THE C ARE UNIT F OR EACH PR OVIDER",!! ; ; Manua l entry to get provi ders from VistA I IB SRC="M" D MANUAL^IBC EP9B G:IBQ UIT1 6 ; F or 'OTHER' files ask position/ length or delimiter/ piece for data I IBS RC="F" D I IBQUIT1 G:'IBCND 6 G 7 . F Z ="PROV. SS N^SSN^15^1 ","PROV. N AME^NAM^30 ","PROV. 1 500 ID^PRO F_ID^15"," PROV. UB-0 4 ID^INST_ ID^15" D Q:IBQUIT1 .. I $P(IB POS,U)'="D " D ... N X ... I IB FT=0!(IBFT =1) Q:Z["P ROF_ID" I Z["INST_I D" S $P(Z, U)="PROV. ID" ... I IBFT=2 Q:Z ["INST_ID" ... S DIR ("A")="STA RT POSITIO N OF "_$P( Z,U)_" FIE LD: " ... S DIR(0)=" NA"_$S($P( Z,U,4)!($P (Z,U)["PRO V. ID")!($ P(Z,U)["_I D"):"",1:" O")_"^1:25 0" ... W ! S X=$$DIR 1^IBCEP9B( .DIR,Z,.IB QUIT,.IBQU IT1) ... Q :IBQUIT1 . .. I X>0 D .... S IB POS($P(Z,U ,2))=X ... . S DIR("A ")="LENGTH OF "_$P(Z ,U)_" FIEL D: " .... S DIR(0)=" NA"_$S($P( Z,U,3):"^1 :"_$P(Z,U, 3),1:"") . ... S X=$$ DIR1^IBCEP 9B(.DIR,Z, .IBQUIT,.I BQUIT1) .. .. Q:IBQUI T1 .... S $P(IBPOS($ P(Z,U,2)), U,2)=IBPOS ($P(Z,U,2) )+X-1 .. ; .. I $P(I BPOS,U)="D " D ... I IBFT=0!(IB FT=1) Q:Z[ "PROF_ID" I Z["INST _ID" S $P( Z,U)="PROV . ID" ... I IBFT=2 Q :Z["INST_I D" ... W ! S DIR("A" )="STARTIN G '"_$P(IB POS,U,2)_" ' PIECE # OF "_$P(Z, U)_" FIELD : " ... S DIR(0)="NA "_$S($P(Z, U,4)!($P(Z ,U)["PROV. ID")!($P( Z,U)["_ID" ):"",1:"O" ) ... S X= $$DIR1^IBC EP9B(.DIR, Z,.IBQUIT, .IBQUIT1) ... Q:IBQU IT1 ... I X>0 D .... S (DIR("B "),IBPOS($ P(Z,U,2))) =X .... S DIR("A")=" ENDING '"_ $P(IBPOS,U ,2)_"' PIE CE # OF "_ $P(Z,U)_" FIELD: " . ... S DIR( 0)="NA"_$S ($P(Z,U,4) :"",1:"O") _U_(IBPOS( $P(Z,U,2)) )_":99" .. .. S DIR(" ?")="JUST PRESS THE ENTER KEY IF THIS FI ELD IS CON TAINED IN ONLY 1 PIE CE" .... S Y=$$DIR1^ IBCEP9B(.D IR,Z,.IBQU IT,.IBQUIT 1) .... Q: IBQUIT1 .. .. W ! I Y >0,Y'=IBPO S($P(Z,U,2 )) S $P(IB POS($P(Z,U ,2)),U,2)= Y .. ; . Q :IBQUIT1 . D READFIL E^IBCEP9B . ;P1 ; S Z="" F S Z=$O(^TMP( "IBPID_IN" ,$J,Z)) Q: Z="" S Z0 =0 F S Z0 =$O(^TMP(" IBPID_IN", $J,Z,Z0)) Q:'Z0 S Q =$G(^(Z0)) D G:IBQU IT ENQ . ; . I IBSRC ="M" D Q .. D DISP^ IBCEP9B(Q, 0,IBINS,IB PTYP,IBFT, IBCT,$G(IB CU),,IBSRC ) .. ; Man ually add IDs .. S I BN=$$DUP(+ Z0_";VA(20 0,",IBINS, $S($G(IBCU )'="":IBCU ,1:"*N/A*" ),IBFT,IBC T,IBPTYP) .. I 'IBN D Q:IBQUI T!(IBN'>0) ... S IBN =$$ADDID^I BCEP9B(Z0, IBINS,$G(I BCU),IBFT, IBCT,IBPTY P,,.IBQUIT ) .. S DIE ="^IBA(355 .9,",DR=". 07",DA=+IB N D ^DIE . . I $D(Y)! ($P($G(^IB A(355.9,+I BN,0)),U,7 )="") D .. . I $P(IBN ,U,3) S DA =+IBN,DIK= "^IBA(355. 9," D ^DIK ... S DIR (0)="YA",D IR("B")="N O",DIR("A" )="DO YOU WANT TO ST OP ENTERIN G PROVIDER IDs?: " . .. S Y=$$D IR(.DIR,.I BQUIT,.IBQ UIT1,,1,1) ... I Y=1 S IBQUIT= 1 .. S IBI D=$P($G(^I BA(355.9,+ IBN,0)),U, 7) .. S:$L (IBID) ^TM P("IBPID_I N",$J,U,Z0 ,"INST_ID" )=IBID .. I IBID="" K ^TMP("IB PID_IN",$J ,U,Z0) .. I IBQUIT=1 F S Z0=$ O(^TMP("IB PID_IN",$J ,U,Z0)) Q: Z0="" K ^ TMP("IBPID _IN",$J,U, Z0) ; user wants to stop, remo ve all rem aining nam es from li st . ; . S IBOK=1 . N IBX,IBID . M IBX=^ TMP("IBPID _IN",$J,Z, Z0) . I IB SRC="F" S IBID=$S(IB FT=0!(IBFT =1):$G(IBX ("INST_ID" )),1:$G(IB X("PROF_ID "))) . I $ G(IBVERIFY ) D ; Dis play recor d, ask OK to file id 's .. D DI SP^IBCEP9B (Q,0,IBINS ,IBPTYP,IB FT,IBCT,$G (IBCU),,IB SRC) .. W !,"PROVIDE R ID: ",IB ID .. S DI R("A")="OK TO FILE T HIS ID FOR THIS PROV IDER?: ",D IR(0)="YA" ,DIR("B")= "NO" .. S Y=$$DIR(.D IR,,,,1,1) .. I Y'=1 D Q ; S end to err or array . .. S IBOK= 0 ... S ^T MP("IBPID- ERR",$J,2, $P(IBX,U), $P(IBX,U,2 )_" ","PRO V ID")=IBI D ... S ^T MP("IBPID_ IN",$J,U,Z 0,0)="NO P RINT" ... N Z1 ... S Z1="" F S Z1=$O(IB X(Z1)) Q:Z 1="" I $G (IBX(Z1))' ="",Z1'["_ ID" S ^TMP ("IBPID-ER R",$J,2,$P (IBX,U),$P (IBX,U,2)_ " ",Z1)=IB X(Z1) . I IBOK D ; Add/update the recor d .. I IBS RC="F" D . .. I IBID' ="" D .... S IBN=$$A DDID^IBCEP 9B(+Z0,IBI NS,$G(IBCU ),IBFT,IBC T,IBPTYP,, .IBQUIT) . ... I IBQU IT D:IBN>0 Q ..... S DA=+IBN,D IK="^IBA(3 55.9," D ^ DIK .... I IBN>0 S D IE="^IBA(3 55.9,",DA= +IBN,DR=". 07////"_IB ID D ^DIE .. ; ;ENQ ; Print re port, exit I $G(IBIN S) D . D C OPY^IBCEPC ID(IBINS) . D UNLOCK ^IBCEP9B(I BINS) ; I ($D(^TMP(" IBPID-ERR" ,$J)))!($D (^TMP("IBP ID_IN",$J) )) D . N % ZIS,ZTSAVE ,ZTRTN,ZTD ESC,IBDUZ . S IBDUZ= $G(DUZ) . S %ZIS="QM " D ^%ZIS Q:POP . I $D(IO("Q") ) K IO("Q" ) D D ^%Z TLOAD K ZT SK D HOME^ %ZIS Q .. S ZTRTN="P RTERR^IBCE P9B",ZTSAV E("^TMP("" IBPID-ERR" ",$J,")="" .. S ZTSA VE("^TMP(" "IBPID_IN" ",$J,")="" ,ZTSAVE("I B*")="" .. S ZTDESC= "IB - PROV IDER ID BA TCH UPDATE ERROR LOG " . U IO . D PRTERR^ IBCEP9B K ^TMP("IBPI D_IN",$J), ^TMP("IBPI D-ERR",$J) ,^TMP("IBP ID",$J) U IO(0) Q ;D UP(IBPRV,I BINS,IBCU, IBFT,IBCT, IBPTYP) ; Check if p rovider id record al ready exis ts in file 355.9 Q + $O(^IBA(35 5.9,"AUNIQ ",IBPRV,IB INS,IBCU,I BFT,IBCT,I BPTYP,0)) ;ERREOF ; Traps EOF error on f ile read f or non-DSM systems N IBERROR S IBERROR=$ $EC^%ZOSV I IBERROR[ "ENDOFFILE " D CLOSE( .IBOPEN) G ENQ D ^%Z TER Q ;CLO SE(IBOPEN) ; Close f ile D CLOS E^%ZISH("I BINFILE") S IBOPEN=0 Q ;DIR(DI R,IBQUIT,I BQUIT1,X,I BW1,IBW2) ; Standard call to ^ DIR ; Inpu ts DIR arr ay ; Retur ns IBQUIT, IBQUIT1,X if passed by referen ce ; AND ; FUNCTION returns th e value of Y ; IBW1 = 1 if ini tial write ! should be done ; IBW2 = 1 i f last wri te ! shoul d be done N DIROUT,D TOUT,DUOUT ,DA W:$G(I BW1) ! D ^ DIR K DIR W:$G(IBW2) ! S (IBQU IT,IBQUIT1 )=0 S DIR( "?")="Ente r '^' to b ack up one prompt or '^^' to e xit the op tion" I $D (DIROUT) S (IBQUIT,I BQUIT1)=1 I $D(DTOUT )!$D(DUOUT ) S IBQUIT 1=1 Q Y ;E RR ; Error list ;; I NVALID OR MISSING SS N - NO PRO VIDER MATC H FOUND ;; NO UPDATE PER USER REQUEST ;; | |
| 2409 | ||
| 2410 | ||
| 2411 | Routines | |
| 2412 | Activities | |
| 2413 | Routine Na me | |
| 2414 | IBCEPTC | |
| 2415 | Enhancemen t Category | |
| 2416 | New | |
| 2417 | Modify | |
| 2418 | Delete | |
| 2419 | No Change | |
| 2420 | RTM | |
| 2421 | ||
| 2422 | Related Op tions | |
| 2423 | None | |
| 2424 | Related Ro utines | |
| 2425 | Routines “ Called By” | |
| 2426 | Routines “ Called” | |
| 2427 | ||
| 2428 | ||
| 2429 | ||
| 2430 | ||
| 2431 | Data Dicti onary (DD) Reference s | |
| 2432 | ||
| 2433 | Related Pr otocols | |
| 2434 | None | |
| 2435 | Related In tegration Control Re gistration s (ICRs) | |
| 2436 | None | |
| 2437 | Data Passi ng | |
| 2438 | Input | |
| 2439 | Output Re ference | |
| 2440 | Both | |
| 2441 | Global Re ference | |
| 2442 | Local | |
| 2443 | Input Attr ibute Name and Defin ition | |
| 2444 | Name: | |
| 2445 | Definition : | |
| 2446 | Output Att ribute Nam e and Defi nition | |
| 2447 | Name: | |
| 2448 | Definition : | |
| 2449 | Current Lo gic | |
| 2450 | IBCEPTC ;A LB/TMK - E DI PREVIOU SLY TRANSM ITTED CLAI MS ; 4/12/ 05 11:15am ;;2.0;INT EGRATED BI LLING;**29 6,320,348, 349,547**; 21-MAR-94; Build 119 ;;Per VA D irective 6 402, this routine sh ould not b e modified . ;EN ; Ma in entrypo int ; IBDT 1,IBDT2 = last trans mit date r ange to us e ; IBSORT = primary sort crit eria to us e B=BATCH #,I=INS CO NAME ; IB FORM = for m type to limit sele ction to U =UB-04,C=C MS-1500,B= BOTH ; IBC RIT = the additional sort crit eria neede d ; IBPTCC AN = wheth er or not to include cancelled claims ; IBRCBFPC = whether o r not to i nclude for ce print @ clearingh ouse ; ^TM P("IB_PREV _CLAIM_INS ",$J) = 1 for specif ic ins co/ null for a ll ; ^($J, 1,ien)="" for ien of each ins co selecte d ; ^($J,2 ,payer ID, ien)="" if selected ; IBREP = format out put should be put in R=report, S=Listman ; N DIR,DI C,X,Y,Z,Z0 ,Z1,IBHOW, IBACT,IBCT ,IBREP,IBC RIT,IBDT1, IBDT2,IBLO C N IBFORM ,IBOK,IBQU IT,IBSORT, IBY,DTOUT, DUOUT,%ZIS ,ZTSAVE,ZT RTN,ZTDESC N POP,IBP AYER,EDI,I NST,PROF,I BPTCCAN,DI ROUT,DIRUT ,DTOUT,DUO UT,IBRCBFP C ; W !!," *** Please Note ***" W ?20,"2 '^' are ne eded to ab ort this o ption (^^) " W !?20," 1 '^' brin gs you bac k to the p revious pr ompt (^)" W ! ; IB*2 .0*547 add new promp t for loca lly printe d vs. tran smitted cl aims S DIR (0)="SA^P: Printed;T: Transmitte d",DIR("A" )="Run rep ort for (P )rinted or (T)ransmi tted claim s?: ",DIR( "B")="Tran smitted" D ^DIR K DI R I $D(DTO UT)!$D(DUO UT) G ENQ ; Set a fl ag here to indicate user wants locally p rinted cla ims and us e that to control ho w the rest of the pr ompts act. S IBLOC=$ S(Y="T":"" ,1:1) ;Q1 ; W ! ;S D IR(0)="SA^ C:Claim;B: Batch;L:Li st",DIR("A ")="Select By: (C)la im, (B)atc h or see a (L)ist to pick from ?: ",DIR(" B")="List" S DIR(0)= "SA^C:Clai m;"_$S(IBL OC:"",1:"B :Batch;")_ "L:List",D IR("A")="S elect By: (C)laim"_$ S(IBLOC:"" ,1:", (B)a tch")_" or see a (L) ist to pic k from?: " ,DIR("B")= "List" D ^ DIR K DIR I $D(DTOUT )!$D(DUOUT ) G ENQ S IBHOW=Y I IBLOC=1 W !,"Previou sly printe d claims t o a payer that does not accept EDI are o mitted." I IBHOW="L" G Q1A ; S IBQUIT=0, IBCT=0 K ^ TMP($J,IBH OW) F D Q:IBQUIT . ;I IBHOW=" C" S DIR(" A")="Selec t a"_$S(IB CT:"nother ",1:"")_" Claim: ",D IR(0)="PA^ 364:AEMQZ" ,DIR("S")= "I '$P(^(0 ),U,7),'$O (^IBA(364, ""B"",+^(0 ),Y))" . I IBHOW="C" ,IBLOC="" S DIR("A") ="Select a "_$S(IBCT: "nother",1 :"")_" Cla im: ",DIR( 0)="PA^364 :AEMQZ",DI R("S")="I '$P(^(0),U ,7),'$O(^I BA(364,""B "",+^(0),Y ))" . I IB HOW="C",IB LOC=1 S DI R("A")="Se lect a"_$S (IBCT:"not her",1:"") _" Locally Printed C laim: ",DI R(0)="PA^3 99:AEMQZ", DIR("S")=" I '$D(^IBA (364,""B"" ,Y)),$$INS OK^IBCEF4( +$$CURR^IB CEF2(Y))" . I IBHOW= "B" S DIR( "A")="Sele ct a"_$S(I BCT:"nothe r",1:"")_" Batch: ", DIR(0)="PA ^IBA(364.1 ,:AEMQ^W " " "",$P(^( 0),U,3),"" Claims""" ,DIR("S")= "I '$P(^(0 ),U,14)" . S DIR("?" )="^D SELD SP^IBCEPTC (IBHOW)" . S:IBCT $P (DIR(0),U) =$P(DIR(0) ,U)_"O" ; Optional p rompt afte r one is s elected . D ^DIR K D IR . I Y'> 0 S IBQUIT =$S(X="^": 2,X="^^":3 ,1:1) Q . S IBY=$S(I BHOW="C":+ Y,1:""),Y= $S(IBHOW=" C":+Y(0),1 :Y) S:IBLO C=1 Y=IBY . I '$D(^T MP($J,IBHO W,+Y)) S I BCT=IBCT+1 ,^TMP($J,I BHOW,+Y)=I BY ; G:IBQ UIT=3 ENQ G:IBQUIT=2 !'$O(^TMP( $J,IBHOW,0 )) Q1 S Z= 0 I IBHOW= "C" F S Z =$O(^TMP($ J,"C",Z)) Q:'Z S ^T MP("IB_PRE V_CLAIM_SE LECT",$J,Z ,0)=^TMP($ J,"C",Z) I IBHOW="B" S (Z,IBCT )=0 F S Z =$O(^TMP($ J,"B",Z)) Q:'Z D . S Z0=0 F S Z0=$O(^I BA(364,"C" ,Z,Z0)) Q: 'Z0 S Z1= +$G(^IBA(3 64,Z0,0)) I Z1,'$D(^ TMP("IB_PR EV_CLAIM_S ELECT",$J, Z1,0)) S ^ (0)=Z0,IBC T=IBCT+1 S ^TMP("IB_ PREV_CLAIM _SELECT",$ J)=IBCT D RESUB^IBCE PTC3 G ENQ ;Q1A K ^T MP("IB_PRE V_CLAIM_IN S",$J) S D IR(0)="SA^ A:All Paye rs;S:Selec ted Payers " S DIR("A ")="Run fo r (A)ll Pa yers or (S )elected P ayers?: " S DIR("B") ="Selected Payers" W !!,"PAYER SELECTION :" D ^DIR K DIR I X= "^^" G ENQ I $D(DTOU T)!$D(DUOU T) G Q1 ; I Y="A" S ^TMP("IB_P REV_CLAIM_ INS",$J)=" " G Q2 ; ; esg - 11/ 21/05 - pa tch 320 qu estion W ! S DIR(0)= "Y",DIR("A ")=" Inclu de all pay ers with t he same el ectronic P ayer ID",D IR("B")="Y es" D ^DIR K DIR I $ D(DIROUT) G ENQ I $D (DIRUT) G Q1A S IBPA YER=Y W ! ; S ^TMP(" IB_PREV_CL AIM_INS",$ J)=1 S IBQ UIT=0 F D Q:IBQUIT . ; IB*2. 0*547 allo w lookup b y EDI#'s u sing new c ross-ref . ;S DIC(0) ="AEMQ",DI C=36,DIC(" A")=" Sele ct Insuran ce Company : " . S DI C(0)="AEMQ n",DIC=36, DIC("A")=" Select In surance Co mpany: " . I $O(^TMP ("IB_PREV_ CLAIM_INS" ,$J,1,"")) S DIC("A" )=" Select Another I nsurance C ompany: " . S DIC("W ")="D INSL IST^IBCEMC A(Y)" . ;D ^DIC K DI C ; lookup . N D S D ="B^AEI^AE P" D MIX^D IC1 K DIC, D . I X="^ ^" S IBQUI T=2 Q ; use r entered "^^" . I + Y'>0 S IBQ UIT=1 Q ; user is do ne . W ! . S ^TMP("I B_PREV_CLA IM_INS",$J ,1,+Y)="" . I 'IBPAY ER Q . S E DI=$$UP^XL FSTR($G(^D IC(36,+Y,3 ))) . S PR OF=$P(EDI, U,2),INST= $P(EDI,U,4 ) . I PROF '="",PROF' ["PRNT" S ^TMP("IB_P REV_CLAIM_ INS",$J,2, PROF,+Y)=" " . I INST '="",INST' ["PRNT" S ^TMP("IB_P REV_CLAIM_ INS",$J,2, INST,+Y)=" " . Q ; I IBQUIT=2 G ENQ ; I ' $O(^TMP("I B_PREV_CLA IM_INS",$J ,1,0)) D G Q1A . W *7,!!?3,"N o payers h ave been s elected. P lease try again." . Q ;Q2 S DI R(0)="SA^C :CMS-1500; U:UB-04;B: Both",DIR( "B")="Both " S DIR("A ")="Run fo r (U)B-04, (C)MS-150 0 or (B)ot h: " W !!, "BILL FORM TYPE SELE CTION:" D ^DIR K DIR I X="^^" G ENQ I $D (DTOUT)!$D (DUOUT) G Q1A S IBFO RM=Y ;Q3 S DIR(0)="D A^0:999999 9:EPX",DIR ("A")="Sta rt with Da te "_$S(IB LOC:"First Printed: ",1:"Last Transmitte d: ") ;S D IR("?",1)= "This is t he earlies t date on which a ba tch that y ou want to include o n this",DI R("?",2)=" report wa s last tra nsmitted. You may ch oose a max imum date range of 9 0 days.",D IR("?")=" " S DIR("? ",1)="This is the ea rliest dat e on which a batch t hat you wa nt to incl ude on thi s",DIR("?" ,2)=" repo rt was "_$ S(IBLOC=1: "first pri nted",1:"l ast transm itted")_". You may c hoose a ma ximum date range of 90 days.", DIR("?")=" " ;W !!," LAST BATCH TRANSMIT DATE RANGE SELECTION :" D ^DIR K DIR W !! ,$S(IBLOC: "FIRST PRI NT",1:"LAS T BATCH TR ANSMIT")_" DATE RANG E SELECTIO N:" D ^DIR K DIR I X ="^^" G EN Q I $D(DTO UT)!$D(DUO UT) G Q2 S IBDT1=Y S IBDT2=$$F MADD^XLFDT (IBDT1,90) I IBDT2>D T S IBDT2= DT S DIR(" ?",1)="Thi s is the l atest date on which a batch th at you wan t to inclu de on this ",DIR("?", 2)=" repor t was "_$S (IBLOC:"fi rst printe d",1:"last transmitt ed")_". Yo u may choo se a maxim um date ra nge of 90 days.",DIR ("?")=" " S DIR("B") =$$FMTE^XL FDT(IBDT2, 2),DIR(0)= "DA^"_IBDT 1_":"_IBDT 2_":EPX" S DIR("A")= "Go to Dat e "_$S(IBL OC:"First Printed",1 :"Last Tra nsmitted") _":("_$$FM TE^XLFDT(I BDT1,2)_"- "_$$FMTE^X LFDT(IBDT2 ,2)_"): " D ^DIR K D IR I X="^^ " G ENQ I $D(DTOUT)! $D(DUOUT) G Q3 S IBD T2=Y ;Q4 ; Additiona l selectio n criteria S DIR(0)= "SAO^1:MRA Secondary Only;2:Pr imary Clai ms Only;3: Secondary Claims Onl y;4:Claims Previousl y Printed at Clearin ghouse" S DIR("A",1) ="ADDITION AL SELECTI ON CRITERI A:",DIR("A ",2)=" ",D IR("A",3)= "1 - MRA S econdary O nly",DIR(" A",4)="2 - Primary C laims Only ",DIR("A", 5)="3 - Se condary Cl aims Only" S DIR("A" ,6)=$S(IBL OC:"",1:"4 - Claims Sent to Pr int at Cle aringhouse Only"),DI R("A",7)=" ",DIR("A" )="Select Additional Limiting Criteria ( optional): " S DIR(" ?")="Selec t one of t he listed criteria t o further limit the claims to include" W ! D ^DIR K DIR I X= "^^" G ENQ I $D(DTOU T)!$D(DUOU T) G Q3 S IBCRIT=Y ; Q41 ; Ask user if th ey want to include c ancelled c laims S DI R(0)="Y",D IR("B")="N o",DIR("A" )="Would y ou like to include c ancelled c laims" W ! D ^DIR K DIR I X="^ ^" G ENQ I $D(DIRUT) G Q4 S IB PTCCAN=Y ; IB*2.0*54 7 skip nex t 2 questi ons if loo king for l ocally pri nted claim s I IBLOC S IBSORT=2 ,IBRCBFPC= 0 G Q6 ;Q4 2 ; Includ e claims t hat are fo rced to pr int at cle aringhouse ? S DIR(0) ="Y",DIR(" B")="No",D IR("A")="W ould you l ike to inc lude claim s Forced t o Print at the Clear inghouse" W ! D ^DIR K DIR I X ="^^" G EN Q I $D(DIR UT) G Q41 S IBRCBFPC =Y ;Q5 S D IR("L",1)= "Select on e of the f ollowing: ",DIR("L", 2)=" ",DIR ("L",3)=$J ("",10)_"1 Batch By Last Trans mitted Dat e (Claims within a B atch)",DIR ("L",4)=$J ("",10)_"2 Current P ayer (Insu rance Comp any)" S DI R("L",5)=" " S DIR(0 )="SA^1:Ba tch By Las t Transmit ted Date ( Claims wit hin a Batc h);2:Curre nt Payer ( Insurance Company)", DIR("B")=" Current Pa yer" S DIR ("A")="Sor t By: " W ! D ^DIR K DIR I X=" ^^" G ENQ I $D(DTOUT )!$D(DUOUT ) G Q42 S IBSORT=Y ; Q6 S DIR(0 )="SA^R:Re port;S:Scr een List" S DIR("A") ="Do you w ant a (R)e port or a (S)creen L ist format ?: " S DIR ("B")="Scr een List" W ! D ^DIR K DIR I X ="^^" G EN Q I $D(DTO UT)!$D(DUO UT) G Q5 S IBREP=Y ; IB *2.0*5 47 call ne w SUB-rout ine for lo cally prin ted claims (not in f ile 364) I IBREP="S" ,IBLOC D L OC^IBCEPTC 0 G ENQ ; I IBREP="S ",'IBLOC D LIST^IBCE PTC0 G ENQ ;Q7 ; Sel ect device F S IBAC T=0 D DEVS EL(.IBACT) Q:IBACT I IBACT=99 G ENQ U IO ; IB *2.0 *547 call new SUB-ro utine for locally pr inted clai ms (not in file 364) D:'IBLOC LIST^IBCEP TC0 D:IBLO C LOC^IBCE PTC0 ;ENQ K ^TMP("IB _PREV_CLAI M_INS",$J) ,^TMP("IB_ PREV_CLAIM _SELECT",$ J) Q ;DEVS EL(IBACT) ; N DIR,PO P,X,Y,ZTRT N,ZTSAVE W !!,"You w ill need a 132 colum n printer for this r eport!" S %ZIS="QM" D ^%ZIS I POP S IBAC T=99 G DEV SELQ I $G( IOM),IOM<1 32 S IBOK= 1 D I 'IB OK S IBACT =0 G DEVSE LQ . S DIR (0)="YA",D IR("A",1)= "This repo rt require s output t o a 132 co lumn devic e.",DIR("A ",2)="The device you have chos en is only set for " _IOM_".",D IR("A")="A re you sur e you want to contin ue?: ",DIR ("B")="No" . W ! D ^ DIR K DIR . I Y'=1 S IBOK=0 W ! I $D(IO( "Q")) D S IBACT=99 G DEVSELQ . K IO("Q" ) . S ZTRT N="LIST^IB CEPTC0",ZT SAVE("IBCR IT(")="",Z TSAVE("IB* ")="",ZTSA VE("^TMP(" "IB_PREV_C LAIM_INS"" ,$J)")="", ZTSAVE("^T MP(""IB_PR EV_CLAIM_I NS"",$J,") ="",ZTDESC ="IB - Pre viously Tr ansmitted Claims Rep ort" . D ^ %ZTLOAD K ZTSK D HOM E^%ZIS S I BACT=1DEVS ELQ Q ;SEL DSP(IBHOW) ; Display list of s elected cl aims/batch es ; IBHOW = "C" for claims "B " for batc hes N Z,DI R,CT,QUIT I '$O(^TMP ($J,IBHOW, 0)) Q S (C T,QUIT)=0 W !!,$S(IB HOW="C":"C laims",1:" Batches"), " Already Selected:" S Z=0 F S Z=$O(^TM P($J,IBHOW ,Z)) Q:'Z! QUIT S Z0 =$G(^(Z)) D Q:QUIT . I IBHOW= "C" W !,?3 ,$P($G(^DG CR(399,Z,0 )),U) Q . W !,?3,$P( $G(^IBA(36 4.1,Z,0)), U)," ",$P( ^(0),U,3), " Claims" . S CT=CT+ 1 . I '(CT #10),$O(^T MP($J,IBHO W,Z)) S DI R("A")="Pr ess return for more or '^' to exit ",DIR (0)="EA" W ! D ^DIR K DIR I $D (DTOUT)!$D (DUOUT) S QUIT=1 W ! Q ; | |
| 2451 | Modified L ogic (Chan ges are in bold) | |
| 2452 | IBCEPTC ;A LB/TMK - E DI PREVIOU SLY TRANSM ITTED CLAI MS ; 4/12/ 05 11:15am ;;2.0;INT EGRATED BI LLING;**29 6,320,348, 349,547,59 2**;21-MAR -94;Build 119 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ;EN ; Main ent rypoint ; IBDT1,IBDT 2 = last t ransmit da te range t o use ; IB SORT = pri mary sort criteria t o use B=BA TCH #,I=IN S CO NAME ; IBFORM = form type to limit selection to U=UB-04 ,C=CMS-150 0,B=BOTH ; IBCRIT = the additi onal sort criteria n eeded ; IB PTCCAN = w hether or not to inc lude cance lled claim s ; IBRCBF PC = wheth er or not to include force pri nt @ clear inghouse ; ^TMP("IB_ PREV_CLAIM _INS",$J) = 1 for sp ecific ins co/null f or all ; ^ ($J,1,ien) ="" for ie n of each ins co sel ected ; ^( $J,2,payer ID,ien)=" " if selec ted ; IBRE P = format output sh ould be pu t in R=rep ort,S=List man ; N DI R,DIC,X,Y, Z,Z0,Z1,IB HOW,IBACT, IBCT,IBREP ,IBCRIT,IB DT1,IBDT2, IBLOC N IB FORM,IBOK, IBQUIT,IBS ORT,IBY,DT OUT,DUOUT, %ZIS,ZTSAV E,ZTRTN,ZT DESC N POP ,IBPAYER,E DI,INST,PR OF,IBPTCCA N,DIROUT,D IRUT,DTOUT ,DUOUT,IBR CBFPC ; W !!,"*** Pl ease Note ***" W ?20 ,"2 '^' ar e needed t o abort th is option (^^)" W !? 20,"1 '^' brings you back to t he previou s prompt ( ^)" W ! ; IB*2.0*547 add new p rompt for locally pr inted vs. transmitte d claims S DIR(0)="S A^P:Printe d;T:Transm itted",DIR ("A")="Run report fo r (P)rinte d or (T)ra nsmitted c laims?: ", DIR("B")=" Transmitte d" D ^DIR K DIR I $D (DTOUT)!$D (DUOUT) G ENQ ; Set a flag her e to indic ate user w ants local ly printed claims an d use that to contro l how the rest of th e prompts act. S IBL OC=$S(Y="T ":"",1:1) ;Q1 ; W ! ;S DIR(0)= "SA^C:Clai m;B:Batch; L:List",DI R("A")="Se lect By: ( C)laim, (B )atch or s ee a (L)is t to pick from?: ",D IR("B")="L ist" S DIR (0)="SA^C: Claim;"_$S (IBLOC:"", 1:"B:Batch ;")_"L:Lis t",DIR("A" )="Select By: (C)lai m"_$S(IBLO C:"",1:", (B)atch")_ " or see a (L)ist to pick from ?: ",DIR(" B")="List" D ^DIR K DIR I $D(D TOUT)!$D(D UOUT) G EN Q S IBHOW= Y I IBLOC= 1 W !,"Pre viously pr inted clai ms to a pa yer that d oes not ac cept EDI a re omitted ." I IBHOW ="L" G Q1A ; S IBQUI T=0,IBCT=0 K ^TMP($J ,IBHOW) F D Q:IBQU IT .;I IBH OW="C" S D IR("A")="S elect a"_$ S(IBCT:"no ther",1:"" )_" Claim: ",DIR(0)= "PA^364:AE MQZ",DIR(" S")="I '$P (^(0),U,7) ,'$O(^IBA( 364,""B"", +^(0),Y))" . I IBHOW ="C",IBLOC ="" S DIR( "A")="Sele ct a"_$S(I BCT:"nothe r",1:"")_" Claim: ", DIR(0)="PA ^364:AEMQZ ",DIR("S") ="I '$P(^( 0),U,7),'$ O(^IBA(364 ,""B"",+^( 0),Y))" . I IBHOW="C ",IBLOC=1 S DIR("A") ="Select a "_$S(IBCT: "nother",1 :"")_" Loc ally Print ed Claim: ",DIR(0)=" PA^399:AEM QZ",DIR("S ")="I '$D( ^IBA(364," "B"",Y)),$ $INSOK^IBC EF4(+$$CUR R^IBCEF2(Y ))" . I IB HOW="B" S DIR("A")=" Select a"_ $S(IBCT:"n other",1:" ")_" Batch : ",DIR(0) ="PA^IBA(3 64.1,:AEMQ ^W "" "",$ P(^(0),U,3 ),"" Claim s""",DIR(" S")="I '$P (^(0),U,14 )" . S DIR ("?")="^D SELDSP^IBC EPTC(IBHOW )" . S:IBC T $P(DIR(0 ),U)=$P(DI R(0),U)_"O " ; Option al prompt after one is selecte d . D ^DIR K DIR . I Y'>0 S IB QUIT=$S(X= "^":2,X="^ ^":3,1:1) Q . S IBY= $S(IBHOW=" C":+Y,1:"" ),Y=$S(IBH OW="C":+Y( 0),1:Y) S: IBLOC=1 Y= IBY . I '$ D(^TMP($J, IBHOW,+Y)) S IBCT=IB CT+1,^TMP( $J,IBHOW,+ Y)=IBY ; G :IBQUIT=3 ENQ G:IBQU IT=2!'$O(^ TMP($J,IBH OW,0)) Q1 S Z=0 I IB HOW="C" F S Z=$O(^T MP($J,"C", Z)) Q:'Z S ^TMP("IB _PREV_CLAI M_SELECT", $J,Z,0)=^T MP($J,"C", Z) I IBHOW ="B" S (Z, IBCT)=0 F S Z=$O(^T MP($J,"B", Z)) Q:'Z D . S Z0=0 F S Z0=$ O(^IBA(364 ,"C",Z,Z0) ) Q:'Z0 S Z1=+$G(^I BA(364,Z0, 0)) I Z1,' $D(^TMP("I B_PREV_CLA IM_SELECT" ,$J,Z1,0)) S ^(0)=Z0 ,IBCT=IBCT +1 S ^TMP( "IB_PREV_C LAIM_SELEC T",$J)=IBC T D RESUB^ IBCEPTC3 G ENQ ;Q1A K ^TMP("IB _PREV_CLAI M_INS",$J) S DIR(0)= "SA^A:All Payers;S:S elected Pa yers" S DI R("A")="Ru n for (A)l l Payers o r (S)elect ed Payers? : " S DIR( "B")="Sele cted Payer s" W !!,"P AYER SELEC TION:" D ^ DIR K DIR I X="^^" G ENQ I $D( DTOUT)!$D( DUOUT) G Q 1 ; I Y="A " S ^TMP(" IB_PREV_CL AIM_INS",$ J)="" G Q2 ; ; esg - 11/21/05 - patch 32 0 question W ! S DIR (0)="Y",DI R("A")=" I nclude all payers wi th the sam e electron ic Payer I D",DIR("B" )="Yes" D ^DIR K DIR I $D(DIRO UT) G ENQ I $D(DIRUT ) G Q1A S IBPAYER=Y W ! ; S ^T MP("IB_PRE V_CLAIM_IN S",$J)=1 S IBQUIT=0 F D Q:IB QUIT . ; I B*2.0*547 allow look up by EDI# 's using n ew cross-r ef . ;S DI C(0)="AEMQ ",DIC=36,D IC("A")=" Select Ins urance Com pany: " . S DIC(0)=" AEMQn",DIC =36,DIC("A ")=" Selec t Insuranc e Company: " . I $O( ^TMP("IB_P REV_CLAIM_ INS",$J,1, "")) S DIC ("A")=" Se lect Anoth er Insuran ce Company : " . S DI C("W")="D INSLIST^IB CEMCA(Y)" . ;D ^DIC K DIC ; lo okup . N D S D="B^AE I^AEP" D M IX^DIC1 K DIC,D . I X="^^" S I BQUIT=2 Q ; user ente red "^^" . I +Y'>0 S IBQUIT=1 Q ; user i s done . W ! . S ^TM P("IB_PREV _CLAIM_INS ",$J,1,+Y) ="" . I 'I BPAYER Q . S EDI=$$U P^XLFSTR($ G(^DIC(36, +Y,3))) . S PROF=$P( EDI,U,2),I NST=$P(EDI ,U,4) . I PROF'="",P ROF'["PRNT " S ^TMP(" IB_PREV_CL AIM_INS",$ J,2,PROF,+ Y)="" . I INST'="",I NST'["PRNT " S ^TMP(" IB_PREV_CL AIM_INS",$ J,2,INST,+ Y)="" . Q ; I IBQUIT =2 G ENQ ; I '$O(^TM P("IB_PREV _CLAIM_INS ",$J,1,0)) D G Q1A . W *7,!!? 3,"No paye rs have be en selecte d. Please try again. " . Q ;Q2 ;; JWS;IB* 2.0*592 US 1108 - Den tal EDI 83 7D / form J430D S DI R(0)="SA^C :CMS-1500; U:UB-04;D: J430D;A:Al l",DIR("B" )="All" S DIR("A")=" Run for (U )B-04, (C) MS-1500, ( D)Dental J 430D or (A )ll: " W ! !,"BILL FO RM TYPE SE LECTION:" D ^DIR K D IR I X="^^ " G ENQ I $D(DTOUT)! $D(DUOUT) G Q1A S IB FORM=Y ;Q3 S DIR(0)= "DA^0:9999 999:EPX",D IR("A")="S tart with Date "_$S( IBLOC:"Fir st Printed : ",1:"Las t Transmit ted: ") ;S DIR("?",1 )="This is the earli est date o n which a batch that you want to include on this", DIR("?",2) =" report was last t ransmitted . You may choose a m aximum dat e range of 90 days." ,DIR("?")= " " S DIR( "?",1)="Th is is the earliest d ate on whi ch a batch that you want to in clude on t his",DIR(" ?",2)=" re port was " _$S(IBLOC= 1:"first p rinted",1: "last tran smitted")_ ". You may choose a maximum da te range o f 90 days. ",DIR("?") =" " ;W !! ,"LAST BAT CH TRANSMI T DATE RAN GE SELECTI ON:" D ^DI R K DIR W !!,$S(IBLO C:"FIRST P RINT",1:"L AST BATCH TRANSMIT") _" DATE RA NGE SELECT ION:" D ^D IR K DIR I X="^^" G ENQ I $D(D TOUT)!$D(D UOUT) G Q2 S IBDT1=Y S IBDT2=$ $FMADD^XLF DT(IBDT1,9 0) I IBDT2 >DT S IBDT 2=DT S DIR ("?",1)="T his is the latest da te on whic h a batch that you w ant to inc lude on th is",DIR("? ",2)=" rep ort was "_ $S(IBLOC:" first prin ted",1:"la st transmi tted")_". You may ch oose a max imum date range of 9 0 days.",D IR("?")=" " S DIR("B ")=$$FMTE^ XLFDT(IBDT 2,2),DIR(0 )="DA^"_IB DT1_":"_IB DT2_":EPX" S DIR("A" )="Go to D ate "_$S(I BLOC:"Firs t Printed" ,1:"Last T ransmitted ")_":("_$$ FMTE^XLFDT (IBDT1,2)_ "-"_$$FMTE ^XLFDT(IBD T2,2)_"): " D ^DIR K DIR I X=" ^^" G ENQ I $D(DTOUT )!$D(DUOUT ) G Q3 S I BDT2=Y ;Q4 ; Additio nal select ion criter ia S DIR(0 )="SAO^1:M RA Seconda ry Only;2: Primary Cl aims Only; 3:Secondar y Claims O nly;4:Clai ms Previou sly Printe d at Clear inghouse" S DIR("A", 1)="ADDITI ONAL SELEC TION CRITE RIA:",DIR( "A",2)=" " ,DIR("A",3 )="1 - MRA Secondary Only",DIR ("A",4)="2 - Primary Claims On ly",DIR("A ",5)="3 - Secondary Claims Onl y" S DIR(" A",6)=$S(I BLOC:"",1: "4 - Claim s Sent to Print at C learinghou se Only"), DIR("A",7) =" ",DIR(" A")="Selec t Addition al Limitin g Criteria (optional ): " S DIR ("?")="Sel ect one of the liste d criteria to furthe r limit th e claims t o include" W ! D ^DI R K DIR I X="^^" G E NQ I $D(DT OUT)!$D(DU OUT) G Q3 S IBCRIT=Y ;Q41 ; As k user if they want to include cancelled claims S DIR(0)="Y" ,DIR("B")= "No",DIR(" A")="Would you like to include cancelled claims" W ! D ^DIR K DIR I X= "^^" G ENQ I $D(DIRU T) G Q4 S IBPTCCAN=Y ; IB*2.0* 547 skip n ext 2 ques tions if l ooking for locally p rinted cla ims I IBLO C S IBSORT =2,IBRCBFP C=0 G Q6 ; Q42 ; Incl ude claims that are forced to print at c learinghou se? S DIR( 0)="Y",DIR ("B")="No" ,DIR("A")= "Would you like to i nclude cla ims Forced to Print at the Cle aringhouse " W ! D ^D IR K DIR I X="^^" G ENQ I $D(D IRUT) G Q4 1 S IBRCBF PC=Y ;Q5 S DIR("L",1 )="Select one of the following : ",DIR("L ",2)=" ",D IR("L",3)= $J("",10)_ "1 Batch B y Last Tra nsmitted D ate (Claim s within a Batch)",D IR("L",4)= $J("",10)_ "2 Current Payer (In surance Co mpany)" S DIR("L",5) =" " S DIR (0)="SA^1: Batch By L ast Transm itted Date (Claims w ithin a Ba tch);2:Cur rent Payer (Insuranc e Company) ",DIR("B") ="Current Payer" S D IR("A")="S ort By: " W ! D ^DIR K DIR I X ="^^" G EN Q I $D(DTO UT)!$D(DUO UT) G Q42 S IBSORT=Y ;Q6 S DIR (0)="SA^R: Report;S:S creen List " S DIR("A ")="Do you want a (R )eport or a (S)creen List form at?: " S D IR("B")="S creen List " W ! D ^D IR K DIR I X="^^" G ENQ I $D(D TOUT)!$D(D UOUT) G Q5 S IBREP=Y ; IB *2.0 *547 call new SUB-ro utine for locally pr inted clai ms (not in file 364) I IBREP=" S",IBLOC D LOC^IBCEP TC0 G ENQ ; I IBREP= "S",'IBLOC D LIST^IB CEPTC0 G E NQ ;Q7 ; S elect devi ce F S IB ACT=0 D DE VSEL(.IBAC T) Q:IBACT I IBACT=9 9 G ENQ U IO ; IB *2 .0*547 cal l new SUB- routine fo r locally printed cl aims (not in file 36 4) D:'IBLO C LIST^IBC EPTC0 D:IB LOC LOC^IB CEPTC0 ;EN Q K ^TMP(" IB_PREV_CL AIM_INS",$ J),^TMP("I B_PREV_CLA IM_SELECT" ,$J) Q ;DE VSEL(IBACT ) ; N DIR, POP,X,Y,ZT RTN,ZTSAVE W !!,"You will need a 132 col umn printe r for this report!" S %ZIS="QM " D ^%ZIS I POP S IB ACT=99 G D EVSELQ I $ G(IOM),IOM <132 S IBO K=1 D I ' IBOK S IBA CT=0 G DEV SELQ . S D IR(0)="YA" ,DIR("A",1 )="This re port requi res output to a 132 column dev ice.",DIR( "A",2)="Th e device y ou have ch osen is on ly set for "_IOM_"." ,DIR("A")= "Are you s ure you wa nt to cont inue?: ",D IR("B")="N o" . W ! D ^DIR K DI R . I Y'=1 S IBOK=0 W ! I $D(I O("Q")) D S IBACT=9 9 G DEVSEL Q . K IO(" Q") . S ZT RTN="LIST^ IBCEPTC0", ZTSAVE("IB CRIT(")="" ,ZTSAVE("I B*")="",ZT SAVE("^TMP (""IB_PREV _CLAIM_INS "",$J)")=" ",ZTSAVE(" ^TMP(""IB_ PREV_CLAIM _INS"",$J, ")="",ZTDE SC="IB - P reviously Transmitte d Claims R eport" . D ^%ZTLOAD K ZTSK D H OME^%ZIS S IBACT=1DE VSELQ Q ;S ELDSP(IBHO W) ; Displ ay list of selected claims/bat ches ; IBH OW = "C" f or claims "B" for ba tches N Z, DIR,CT,QUI T I '$O(^T MP($J,IBHO W,0)) Q S (CT,QUIT)= 0 W !!,$S( IBHOW="C": "Claims",1 :"Batches" )," Alread y Selected :" S Z=0 F S Z=$O(^ TMP($J,IBH OW,Z)) Q:' Z!QUIT S Z0=$G(^(Z) ) D Q:QUI T . I IBHO W="C" W !, ?3,$P($G(^ DGCR(399,Z ,0)),U) Q . W !,?3,$ P($G(^IBA( 364.1,Z,0) ),U)," ",$ P(^(0),U,3 )," Claims " . S CT=C T+1 . I '( CT#10),$O( ^TMP($J,IB HOW,Z)) S DIR("A")=" Press retu rn for mor e or '^' t o exit ",D IR(0)="EA" W ! D ^DI R K DIR I $D(DTOUT)! $D(DUOUT) S QUIT=1 W ! Q ; | |
| 2453 | ||
| 2454 | ||
| 2455 | Routines | |
| 2456 | Activities | |
| 2457 | Routine Na me | |
| 2458 | IBCEPTC0 | |
| 2459 | Enhancemen t Category | |
| 2460 | New | |
| 2461 | Modify | |
| 2462 | Delete | |
| 2463 | No Change | |
| 2464 | RTM | |
| 2465 | ||
| 2466 | Related Op tions | |
| 2467 | None | |
| 2468 | Related Ro utines | |
| 2469 | Routines “ Called By” | |
| 2470 | Routines “ Called” | |
| 2471 | ||
| 2472 | ||
| 2473 | ||
| 2474 | ||
| 2475 | Data Dicti onary (DD) Reference s | |
| 2476 | ||
| 2477 | Related Pr otocols | |
| 2478 | None | |
| 2479 | Related In tegration Control Re gistration s (ICRs) | |
| 2480 | None | |
| 2481 | Data Passi ng | |
| 2482 | Input | |
| 2483 | Output Re ference | |
| 2484 | Both | |
| 2485 | Global Re ference | |
| 2486 | Local | |
| 2487 | Input Attr ibute Name and Defin ition | |
| 2488 | Name: | |
| 2489 | Definition : | |
| 2490 | Output Att ribute Nam e and Defi nition | |
| 2491 | Name: | |
| 2492 | Definition : | |
| 2493 | Current Lo gic | |
| 2494 | IBCEPTC0 ; ALB/ESG - EDI PREVIO USLY TRANS MITTED CLA IMS CONT ; 12/19/05 ;;2.0;INTE GRATED BIL LING;**320 ,348,547** ;21-MAR-94 ;Build 119 ;;Per VA Directive 6402, this routine s hould not be modifie d. ; Q ;LI ST ; Queue d report f ormat entr ypoint ; v ariables p re-defined : IBREP,IB SORT,IBFOR M,IBDT1,IB DT2, ; IBC RIT,IBPTCC AN,IBRCBFP C ; ^TMP(" IB_PREV_CL AIM_INS,$J ) global K ^TMP("IB_ PREV_CLAIM ",$J) N IB BDA,IBBDA0 ,IBCURI,IB DA,IBDT,IB FT,IBIFN,I BS1,IBS2,I BDTX N INC LUDE,EDI,P ROF,INST,I B0,IBZ1,DA TA,IB364,C URSEQ,IBZ, IBZDAT I I BREP="R" N IBPAGE,IB STOP,IBHDR DT S (IBPA GE,IBSTOP) =0 ; ; eva luate clai m transmis sion data from files 364.1 and 364 S IBD T=IBDT1-.1 F S IBDT =$O(^IBA(3 64.1,"ALT" ,IBDT)) Q: 'IBDT!((IB DT\1)>IBDT 2) S IBBDA =0 F S IB BDA=$O(^IB A(364.1,"A LT",IBDT,I BBDA)) Q:' IBBDA D . S IBDTX=I BDT\1 . S IBDA=0 F S IBDA=$O( ^IBA(364," C",IBBDA,I BDA)) Q:'I BDA D .. D STORE(IB DA,IBBDA,I BDTX,$P($G (^IBA(364, IBDA,0)),U ,7)+1) .. Q . Q ; ; evaluate t he test tr ansmission s from fil e 361.4 (S RS 3.2.10. 3) S IBDT= IBDT1-.1 F S IBDT=$ O(^IBM(361 .4,"ALT",I BDT)) Q:'I BDT!(IBDT> IBDT2) S I BIFN=0 F S IBIFN=$O (^IBM(361. 4,"ALT",IB DT,IBIFN)) Q:'IBIFN S IBZ1=0 F S IBZ1= $O(^IBM(36 1.4,IBIFN, 1,IBZ1)) Q :'IBZ1 D . S DATA=$ G(^IBM(361 .4,IBIFN,1 ,IBZ1,0)) Q:DATA="" . S IBDTX= $P(DATA,U, 1)\1 ; tra nsmit date . Q:IBDTX <IBDT1 ; too early . Q:IBDTX >IBDT2 ; too late . S IBBDA= +$P(DATA,U ,2) ; batc h ien . Q: 'IBBDA . ; . ; attem pt to find the corre sponding e ntry in fi le 364 for this one . S IB364= "",CURSEQ= $TR(+$P(DA TA,U,4),"1 23","PST") . S IBZ=" " F S IB Z=$O(^IBA( 364,"B",IB IFN,IBZ),- 1) Q:'IBZ D Q:IB36 4 .. S IBZ DAT=$G(^IB A(364,IBZ, 0)) .. I $ P(IBZDAT,U ,8)'=CURSE Q Q ; no match on payer s equence .. I $F(".X. P.","."_$P (IBZDAT,U, 3)_".") Q ; trans mission st atus must be farther than this .. S IB36 4=IBZ Q .. Q . ; . I 'IB364 Q ; nee d to have an entry i n file 364 to procee d . ; . D STORE(IB36 4,IBBDA,IB DTX,3) . Q ; I IBREP ="R" D RPT ^IBCEPTC1( IBSORT,IBD T1,IBDT2) G END ; O utput repo rt ; D EN^ VALM("IBCE VIEW PREV TRANS"_IB SORT) ; Li st Manager ;END K ^T MP("IB_PRE V_CLAIM",$ J),^TMP("I B_PREV_CLA IM_INS",$J ) Q ;LOC ; new sub-r outine for locally p rinted cla ims (use L IST & STOR E tags as a guide) ; Use the e xisting AP x-ref to narrow dow n the list of claims by date, then check s for exis tence in f ile 364 (E DI TRANSMI T BILL). ; If a clai m is NOT i n file 364 , it is a printed-on ly claim ; variables pre-defin ed: IBREP, IBSORT,IBF ORM,IBDT1, IBDT2, ; I BCRIT,IBPT CCAN,IBRCB FPC ; ^TMP ("IB_PREV_ CLAIM_INS, $J) global K ^TMP("I B_PREV_CLA IM",$J) N IBBDA,IBBD A0,IBCURI, IBDA,IBDT, IBFT,IBIFN ,IBS1,IBS2 ,IBDTX N I NCLUDE,EDI ,PROF,INST ,IB0,IBZ1, DATA,IB364 ,CURSEQ,IB Z,IBZDAT I IBREP="R" N IBPAGE, IBSTOP,IBH DRDT S (IB PAGE,IBSTO P)=0 S IBD T=IBDT1-.1 F S IBDT =$O(^DGCR( 399,"AP",I BDT)) Q:'I BDT!(IBDT> IBDT2) S I BIFN=0 F S IBIFN=$O (^DGCR(399 ,"AP",IBDT ,IBIFN)) Q :'IBIFN D .; if it' s in the t ransmit fi le it is n ot a print ed claim . Q:$D(^IBA( 364,"B",IB IFN)) .S I B0=$G(^DGC R(399,IBIF N,0)) .S I BFT=$$FT^I BCEF(IBIFN ) ; form t ype of cla im .I IBFO RM'="B",$S (IBFT=3:IB FORM="C",I BFT=2:IBFO RM="U",1:1 ) Q .S IBC URI=$$CURR ^IBCEF2(IB IFN) I 'IB CURI Q ; current i ns ien .S EDI=$$UP^X LFSTR($G(^ DIC(36,IBC URI,3))) ; 3 node ED I data .; do not inc lude claim s where th e ins.co. still cann ot transmi t electron ically .Q: +$P(EDI,U) =0 .S PROF =$P(EDI,U, 2),INST=$P (EDI,U,4) ; payer ID s .; .; sc reen for u ser select ed insuran ce compani es/payers .I +$G(^TM P("IB_PREV _CLAIM_INS ",$J)) D I 'INCLUDE Q ..S INC LUDE=0 ..I $D(^TMP(" IB_PREV_CL AIM_INS",$ J,1,IBCURI )) S INCLU DE=1 Q ..I '$D(^TMP( "IB_PREV_C LAIM_INS", $J,2)) Q . .I PROF'=" ",$D(^TMP( "IB_PREV_C LAIM_INS", $J,2,PROF) ) S INCLUD E=1 Q ..I INST'="",$ D(^TMP("IB _PREV_CLAI M_INS",$J, 2,INST)) S INCLUDE=1 Q ..Q .; .I IBCRIT= 1,'$$MRASE C^IBCEF4(I BIFN) Q .I IBCRIT=2, ($$COBN^IB CEF(IBIFN) >1) Q .I I BCRIT=3,($ $COBN^IBCE F(IBIFN)=1 ) Q .I IBC RIT=4,'$P( $G(^DGCR(3 99,IBIFN," TX")),U,7) Q .; .; s kip cancel led claims condition ally .I $P (IB0,U,13) =7,'IBPTCC AN Q .; .S IBS1=$P($ G(^DIC(36, +IBCURI,0) ),U)_U_+IB CURI,IBS2= IBDT .; .; Meets all selection criteria - extract to sort gl obal .S:IB S1="" IBS1 =" " S:IBS 2="" IBS2= " " .I '$D (^TMP("IB_ PREV_CLAIM ",$J,IBS1) ) S ^TMP(" IB_PREV_CL AIM",$J,IB S1)=IBIFN .S ^TMP("I B_PREV_CLA IM",$J,IBS 1,IBS2,IBI FN)=3 ; 3 = test tra nsmission ; I IBREP= "R" D RPT^ IBCEPTC1(I BSORT,IBDT 1,IBDT2) G END ; Ou tput repor t ; D EN^V ALM("IBCE VIEW LOC P RINT") ; L ist Manage r, new one for sort =2 ; D END Q ;STORE( IB364,IBBD A,IBDTX,IB TYP) ; Che ck and sto re transmi ssion data ; Paramet ers ; IB36 4 - ien to file 364 (claim tra nsmission ien) ; IBB DA - ien t o file 364 .1 (batch ien) ; IBD TX - fm tr ansmit dat e (no time ) (either from 364.1 or 361.41 ) ; IBTYP - 1 = tran smission d ata from f ile 364 (f ield .07 i s live) ; 2 = transm ission dat a from fil e 364 (fie ld .07 is test) ; 3 = transmis sion data from file 361.41 (te st always) ; Note: ; Variables IBFORM, I BCRIT, IBP TCCAN, IBR CBFPC, and IBSORT ar e ; assume d to exist here in t his proced ure. ; NEW IBIFN,IB0 ,IBFT,IBCU RI,INCLUDE ,EDI,PROF, INST,IBBDA 0,IBS1,IBS 2 ; S IBIF N=+$G(^IBA (364,IB364 ,0)) S IB0 =$G(^DGCR( 399,IBIFN, 0)) S IBFT =$$FT^IBCE F(IBIFN) ; form type of claim I IBFORM'= "B",$S(IBF T=3:IBFORM ="C",IBFT= 2:IBFORM=" U",1:1) G STOREX S I BCURI=$$CU RR^IBCEF2( IBIFN) I ' IBCURI G S TOREX ; current in s ien S ED I=$$UP^XLF STR($G(^DI C(36,IBCUR I,3))) ; 3 node EDI data S PRO F=$P(EDI,U ,2),INST=$ P(EDI,U,4) ; payer I Ds ; ; scr een for us er selecte d insuranc e companie s/payers I +$G(^TMP( "IB_PREV_C LAIM_INS", $J)) D I 'INCLUDE G STOREX . S INCLUDE= 0 . I $D(^ TMP("IB_PR EV_CLAIM_I NS",$J,1,I BCURI)) S INCLUDE=1 Q . I '$D( ^TMP("IB_P REV_CLAIM_ INS",$J,2) ) Q . I PR OF'="",$D( ^TMP("IB_P REV_CLAIM_ INS",$J,2, PROF)) S I NCLUDE=1 Q . I INST' ="",$D(^TM P("IB_PREV _CLAIM_INS ",$J,2,INS T)) S INCL UDE=1 Q . Q ; I IBCR IT=1,'$$MR ASEC^IBCEF 4(IBIFN) G STOREX I IBCRIT=2,( $$COBN^IBC EF(IBIFN)> 1) G STORE X I IBCRIT =3,($$COBN ^IBCEF(IBI FN)=1) G S TOREX I IB CRIT=4,'$P ($G(^DGCR( 399,IBIFN, "TX")),U,7 ) G STOREX ; ; skip cancelled claims con ditionally I $P(IB0, U,13)=7,'I BPTCCAN G STOREX ; ; skip clai ms forced to print a t clearing house (cla im check) I $P($G(^D GCR(399,IB IFN,"TX")) ,U,8)=2,'I BRCBFPC G STOREX ; ; skip clai ms forced to print a t clearing house (pay er check) I IBFT=2,P ROF["PRNT" ,'IBRCBFPC G STOREX ; 1500, prof paye r ID I IBF T=3,INST[" PRNT",'IBR CBFPC G ST OREX ; ub, inst p ayer ID ; S IBBDA0=$ G(^IBA(364 .1,+IBBDA, 0)) ; 0 no de of batc h ; S IBS1 =$S(IBSORT =1:(999999 99-IBDTX)_ U_$P(IBBDA 0,U)_U_$P( IBBDA0,U,1 4)_U_+$P(I BBDA0,U,5) ,1:$P($G(^ DIC(36,+IB CURI,0)),U )_U_+IBCUR I) S IBS2= $S(IBSORT= 1:$P(IB0,U ,1),1:9999 9999-IBDTX ) ; ; Meet s all sele ction crit eria - ext ract to so rt global S:IBS1="" IBS1=" " S :IBS2="" I BS2=" " I '$D(^TMP(" IB_PREV_CL AIM",$J,IB S1)) S ^TM P("IB_PREV _CLAIM",$J ,IBS1)=$S( IBSORT=1:$ $FMTE^XLFD T(IBDTX,"1 "),1:IBIFN ) S ^TMP(" IB_PREV_CL AIM",$J,IB S1,IBS2,IB 364)=IBTYP ;STOREX ; Q ; | |
| 2495 | Modified L ogic (Chan ges are in bold) | |
| 2496 | IBCEPTC0 ; ALB/ESG - EDI PREVIO USLY TRANS MITTED CLA IMS CONT ; 12/19/05 ;;2.0;INTE GRATED BIL LING;**320 ,348,547,5 92**;21-MA R-94;Build 119 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ; Q ;LIST ; Q ueued repo rt format entrypoint ; variabl es pre-def ined: IBRE P,IBSORT,I BFORM,IBDT 1,IBDT2, ; IBCRIT,IB PTCCAN,IBR CBFPC ; ^T MP("IB_PRE V_CLAIM_IN S,$J) glob al K ^TMP( "IB_PREV_C LAIM",$J) N IBBDA,IB BDA0,IBCUR I,IBDA,IBD T,IBFT,IBI FN,IBS1,IB S2,IBDTX N INCLUDE,E DI,PROF,IN ST,IB0,IBZ 1,DATA,IB3 64,CURSEQ, IBZ,IBZDAT I IBREP=" R" N IBPAG E,IBSTOP,I BHDRDT S ( IBPAGE,IBS TOP)=0 ; ; evaluate claim tran smission d ata from f iles 364.1 and 364 S IBDT=IBDT 1-.1 F S IBDT=$O(^I BA(364.1," ALT",IBDT) ) Q:'IBDT! ((IBDT\1)> IBDT2) S I BBDA=0 F S IBBDA=$O (^IBA(364. 1,"ALT",IB DT,IBBDA)) Q:'IBBDA D . S IBD TX=IBDT\1 . S IBDA=0 F S IBDA =$O(^IBA(3 64,"C",IBB DA,IBDA)) Q:'IBDA D .. D STOR E(IBDA,IBB DA,IBDTX,$ P($G(^IBA( 364,IBDA,0 )),U,7)+1) .. Q . Q ; ; evalua te the tes t transmis sions from file 361. 4 (SRS 3.2 .10.3) S I BDT=IBDT1- .1 F S IB DT=$O(^IBM (361.4,"AL T",IBDT)) Q:'IBDT!(I BDT>IBDT2) S IBIFN=0 F S IBIF N=$O(^IBM( 361.4,"ALT ",IBDT,IBI FN)) Q:'IB IFN S IBZ 1=0 F S I BZ1=$O(^IB M(361.4,IB IFN,1,IBZ1 )) Q:'IBZ1 D . S DA TA=$G(^IBM (361.4,IBI FN,1,IBZ1, 0)) Q:DATA ="" . S IB DTX=$P(DAT A,U,1)\1 ; transmit date . Q:I BDTX<IBDT1 ; too e arly . Q:I BDTX>IBDT2 ; too l ate . S IB BDA=+$P(DA TA,U,2) ; batch ien . Q:'IBBDA . ; . ; a ttempt to find the c orrespondi ng entry i n file 364 for this one . S IB 364="",CUR SEQ=$TR(+$ P(DATA,U,4 ),"123","P ST") . S I BZ=" " F S IBZ=$O(^ IBA(364,"B ",IBIFN,IB Z),-1) Q:' IBZ D Q: IB364 .. S IBZDAT=$G (^IBA(364, IBZ,0)) .. I $P(IBZD AT,U,8)'=C URSEQ Q ; no ma tch on pay er sequenc e .. I $F( ".X.P.",". "_$P(IBZDA T,U,3)_"." ) Q ; t ransmissio n status m ust be far ther than this .. S IB364=IBZ Q .. Q . ; . I 'IB36 4 Q ; need to h ave an ent ry in file 364 to pr oceed . ; . D STORE( IB364,IBBD A,IBDTX,3) . Q ; I I BREP="R" D RPT^IBCEP TC1(IBSORT ,IBDT1,IBD T2) G END ; Output report ; D EN^VALM(" IBCE VIEW PREV TRANS "_IBSORT) ; List Man ager ;END K ^TMP("IB _PREV_CLAI M",$J),^TM P("IB_PREV _CLAIM_INS ",$J) Q ;L OC ; new s ub-routine for local ly printed claims (u se LIST & STORE tags as a guid e) ; Use t he existin g AP x-ref to narrow down the list of cl aims by da te, then c hecks for existence in file 36 4 (EDI TRA NSMIT BILL ). ; If a claim is N OT in file 364, it i s a printe d-only cla im ; varia bles pre-d efined: IB REP,IBSORT ,IBFORM,IB DT1,IBDT2, ; IBCRIT, IBPTCCAN,I BRCBFPC ; ^TMP("IB_P REV_CLAIM_ INS,$J) gl obal K ^TM P("IB_PREV _CLAIM",$J ) N IBBDA, IBBDA0,IBC URI,IBDA,I BDT,IBFT,I BIFN,IBS1, IBS2,IBDTX N INCLUDE ,EDI,PROF, INST,IB0,I BZ1,DATA,I B364,CURSE Q,IBZ,IBZD AT I IBREP ="R" N IBP AGE,IBSTOP ,IBHDRDT S (IBPAGE,I BSTOP)=0 S IBDT=IBDT 1-.1 F S IBDT=$O(^D GCR(399,"A P",IBDT)) Q:'IBDT!(I BDT>IBDT2) S IBIFN=0 F S IBIF N=$O(^DGCR (399,"AP", IBDT,IBIFN )) Q:'IBIF N D .; if it's in t he transmi t file it is not a p rinted cla im .Q:$D(^ IBA(364,"B ",IBIFN)) .S IB0=$G( ^DGCR(399, IBIFN,0)) .S IBFT=$$ FT^IBCEF(I BIFN) ; fo rm type of claim .;J WS;IB*2.0* 592 US1108 - Dental EDI 837D / form J430 D .I IBFOR M'="A",$S( IBFT=3:IBF ORM='"U",I BFT=2:IBFO RM'="C",IB FT=7:IBFOR M'="D",1:1 ) Q .S IBC URI=$$CURR ^IBCEF2(IB IFN) I 'IB CURI Q ; current i ns ien .S EDI=$$UP^X LFSTR($G(^ DIC(36,IBC URI,3))) ; 3 node ED I data .; do not inc lude claim s where th e ins.co. still cann ot transmi t electron ically .Q: +$P(EDI,U) =0 .S PROF =$P(EDI,U, 2),INST=$P (EDI,U,4) ; payer ID s .; .; sc reen for u ser select ed insuran ce compani es/payers .I +$G(^TM P("IB_PREV _CLAIM_INS ",$J)) D I 'INCLUDE Q ..S INC LUDE=0 ..I $D(^TMP(" IB_PREV_CL AIM_INS",$ J,1,IBCURI )) S INCLU DE=1 Q ..I '$D(^TMP( "IB_PREV_C LAIM_INS", $J,2)) Q . .I PROF'=" ",$D(^TMP( "IB_PREV_C LAIM_INS", $J,2,PROF) ) S INCLUD E=1 Q ..I INST'="",$ D(^TMP("IB _PREV_CLAI M_INS",$J, 2,INST)) S INCLUDE=1 Q ..Q .; .I IBCRIT= 1,'$$MRASE C^IBCEF4(I BIFN) Q .I IBCRIT=2, ($$COBN^IB CEF(IBIFN) >1) Q .I I BCRIT=3,($ $COBN^IBCE F(IBIFN)=1 ) Q .I IBC RIT=4,'$P( $G(^DGCR(3 99,IBIFN," TX")),U,7) Q .; .; s kip cancel led claims condition ally .I $P (IB0,U,13) =7,'IBPTCC AN Q .; .S IBS1=$P($ G(^DIC(36, +IBCURI,0) ),U)_U_+IB CURI,IBS2= IBDT .; .; Meets all selection criteria - extract to sort gl obal .S:IB S1="" IBS1 =" " S:IBS 2="" IBS2= " " .I '$D (^TMP("IB_ PREV_CLAIM ",$J,IBS1) ) S ^TMP(" IB_PREV_CL AIM",$J,IB S1)=IBIFN .S ^TMP("I B_PREV_CLA IM",$J,IBS 1,IBS2,IBI FN)=3 ; 3 = test tra nsmission ; I IBREP= "R" D RPT^ IBCEPTC1(I BSORT,IBDT 1,IBDT2) G END ; Ou tput repor t ; D EN^V ALM("IBCE VIEW LOC P RINT") ; L ist Manage r, new one for sort =2 ; D END Q ;STORE( IB364,IBBD A,IBDTX,IB TYP) ; Che ck and sto re transmi ssion data ; Paramet ers ; IB36 4 - ien to file 364 (claim tra nsmission ien) ; IBB DA - ien t o file 364 .1 (batch ien) ; IBD TX - fm tr ansmit dat e (no time ) (either from 364.1 or 361.41 ) ; IBTYP - 1 = tran smission d ata from f ile 364 (f ield .07 i s live) ; 2 = transm ission dat a from fil e 364 (fie ld .07 is test) ; 3 = transmis sion data from file 361.41 (te st always) ; Note: ; Variables IBFORM, I BCRIT, IBP TCCAN, IBR CBFPC, and IBSORT ar e ; assume d to exist here in t his proced ure. ; NEW IBIFN,IB0 ,IBFT,IBCU RI,INCLUDE ,EDI,PROF, INST,IBBDA 0,IBS1,IBS 2 ; S IBIF N=+$G(^IBA (364,IB364 ,0)) S IB0 =$G(^DGCR( 399,IBIFN, 0)) S IBFT =$$FT^IBCE F(IBIFN) ; form type of claim ;JWS;IB*2. 0*592 US11 08 - Denta l EDI 837D / form J4 30D I IBFO RM'="A",$S (IBFT=3:IB FORM'="U", IBFT=2:IBF ORM'="C",I BFT=7:IBFO RM'="D",1: 1) G STORE X S IBCURI =$$CURR^IB CEF2(IBIFN ) I 'IBCUR I G STOREX ; curre nt ins ien S EDI=$$U P^XLFSTR($ G(^DIC(36, IBCURI,3)) ) ; 3 node EDI data S PROF=$P( EDI,U,2),I NST=$P(EDI ,U,4) ; pa yer IDs ; ; screen f or user se lected ins urance com panies/pay ers I +$G( ^TMP("IB_P REV_CLAIM_ INS",$J)) D I 'INCL UDE G STOR EX . S INC LUDE=0 . I $D(^TMP(" IB_PREV_CL AIM_INS",$ J,1,IBCURI )) S INCLU DE=1 Q . I '$D(^TMP( "IB_PREV_C LAIM_INS", $J,2)) Q . I PROF'=" ",$D(^TMP( "IB_PREV_C LAIM_INS", $J,2,PROF) ) S INCLUD E=1 Q . I INST'="",$ D(^TMP("IB _PREV_CLAI M_INS",$J, 2,INST)) S INCLUDE=1 Q . Q ; I IBCRIT=1, '$$MRASEC^ IBCEF4(IBI FN) G STOR EX I IBCRI T=2,($$COB N^IBCEF(IB IFN)>1) G STOREX I I BCRIT=3,($ $COBN^IBCE F(IBIFN)=1 ) G STOREX I IBCRIT= 4,'$P($G(^ DGCR(399,I BIFN,"TX") ),U,7) G S TOREX ; ; skip cance lled claim s conditio nally I $P (IB0,U,13) =7,'IBPTCC AN G STORE X ; ; skip claims fo rced to pr int at cle aringhouse (claim ch eck) I $P( $G(^DGCR(3 99,IBIFN," TX")),U,8) =2,'IBRCBF PC G STORE X ; ; skip claims fo rced to pr int at cle aringhouse (payer ch eck) I IBF T=2,PROF[" PRNT",'IBR CBFPC G ST OREX ; 1500, prof payer ID I IBFT=3,I NST["PRNT" ,'IBRCBFPC G STOREX ; ub, i nst payer ID ; S IBB DA0=$G(^IB A(364.1,+I BBDA,0)) ; 0 node of batch ; S IBS1=$S(I BSORT=1:(9 9999999-IB DTX)_U_$P( IBBDA0,U)_ U_$P(IBBDA 0,U,14)_U_ +$P(IBBDA0 ,U,5),1:$P ($G(^DIC(3 6,+IBCURI, 0)),U)_U_+ IBCURI) S IBS2=$S(IB SORT=1:$P( IB0,U,1),1 :99999999- IBDTX) ; ; Meets all selection criteria - extract to sort gl obal S:IBS 1="" IBS1= " " S:IBS2 ="" IBS2=" " I '$D(^ TMP("IB_PR EV_CLAIM", $J,IBS1)) S ^TMP("IB _PREV_CLAI M",$J,IBS1 )=$S(IBSOR T=1:$$FMTE ^XLFDT(IBD TX,"1"),1: IBIFN) S ^ TMP("IB_PR EV_CLAIM", $J,IBS1,IB S2,IB364)= IBTYP ;STO REX ; Q ; | |
| 2497 | ||
| 2498 | ||
| 2499 | Routines | |
| 2500 | Activities | |
| 2501 | Routine Na me | |
| 2502 | IBCEPTC2 | |
| 2503 | Enhancemen t Category | |
| 2504 | New | |
| 2505 | Modify | |
| 2506 | Delete | |
| 2507 | No Change | |
| 2508 | RTM | |
| 2509 | ||
| 2510 | Related Op tions | |
| 2511 | None | |
| 2512 | Related Ro utines | |
| 2513 | Routines “ Called By” | |
| 2514 | Routines “ Called” | |
| 2515 | ||
| 2516 | ||
| 2517 | ||
| 2518 | ||
| 2519 | Data Dicti onary (DD) Reference s | |
| 2520 | ||
| 2521 | Related Pr otocols | |
| 2522 | None | |
| 2523 | Related In tegration Control Re gistration s (ICRs) | |
| 2524 | None | |
| 2525 | Data Passi ng | |
| 2526 | Input | |
| 2527 | Output Re ference | |
| 2528 | Both | |
| 2529 | Global Re ference | |
| 2530 | Local | |
| 2531 | Input Attr ibute Name and Defin ition | |
| 2532 | Name: | |
| 2533 | Definition : | |
| 2534 | Output Att ribute Nam e and Defi nition | |
| 2535 | Name: | |
| 2536 | Definition : | |
| 2537 | Current Lo gic | |
| 2538 | IBCEPTC2 ; ALB/TMK - EDI PREVIO USLY TRANS MITTED CLA IMS LIST M GR ;01/20/ 05 ;;2.0;I NTEGRATED BILLING;** 296,320,34 8,349,547* *;21-MAR-9 4;Build 11 9 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; IA 3 337 for fi le 430.3 ; IB*2.0*54 7 Variable IBLOC is pre-define d (in IBCE PTC) ;HDR ; K VALMHD R I IBLOC S VALMHDR( 1)="Claims Selected: "_+$G(^TM P("IB_PREV _CLAIM_SEL ECT",$J))_ " (marked with *)" Q S VALMHDR (1)="** A claim may appear mul tiple time s if trans mitted mor e than onc e. **" ; I $G(IBSORT )=1 D . S VALMHDR(2) ="Claims S elected: " _+$G(^TMP( "IB_PREV_C LAIM_SELEC T",$J))_" (marked wi th *)" . Q ; I $G(IB SORT)=2 D . S VALMHD R(2)="** T = Test Cl aim ** R = Batch Rej ected" . S VALMHDR(3 )="Claims Selected: "_+$G(^TMP ("IB_PREV_ CLAIM_SELE CT",$J))_" (marked w ith *)" . Q ; Q ;INI T ; S VALM CNT=0,VALM BG=1 D BLD Q ;BLD ; Build disp lay lines N IBDA,IBS 1,IBS2,IBI FN,IB0,IBX ,IBCNT,IBL EV1,IBBDA K ^TMP("IB _PREV_CLAI M_LIST",$J ),^TMP("IB _PREV_CLAI M_SELECT", $J),^TMP(" IB_PREV_CL AIM_BATCH" ,$J) S IBC NT=0 I $O( ^TMP("IB_P REV_CLAIM" ,$J,""))=" " D G BLD Q . S IBX= " ** NO PR EVIOUSLY " _$S(IBLOC: "PRINTED", 1:"TRANSMI TTED")_" C LAIMS EXIS T FOR SEAR CH CRITERI A SELECTED **" . D W RT(IBX,"", 0,0,"","S" ,"",.IBCNT ,0) ; S IB S1="" F S IBS1=$O(^ TMP("IB_PR EV_CLAIM", $J,IBS1)) Q:IBS1="" D . ; Fir st level s ort . ; fo r sort by batch, dis play batch ID and tr ansmit dat e . I IBSO RT=1 D .. S IBLEV1=" Batch: "_ $P(IBS1,U, 2)_" Last Transmitte d: "_$G(^T MP("IB_PRE V_CLAIM",$ J,IBS1)) . . S IBBDA= +$O(^IBA(3 64.1,"B",$ P(IBS1,U,2 ),0)) .. I $P(IBS1,U ,3) S IBLE V1=IBLEV1_ " ** Test" .. I $P(I BS1,U,4) S IBLEV1=IB LEV1_" ** Rejected" .. Q . ; . ; for sor t by payer , display ins co nam e and paye r address . I IBSORT =2 D .. S IBLEV1=" " _$P(IBS1,U )_" "_$$CU RRINS(+$G( ^TMP("IB_P REV_CLAIM" ,$J,IBS1)) ,0) .. Q . ; . ; out put sort h eader line . D WRT(I BLEV1,"",0 ,0,IBSORT, "S","",IBC NT,0) ; Ad d header l ine . ; . I IBSORT=1 ,IBBDA S ^ TMP("IB_PR EV_CLAIM_B ATCH",$J,I BBDA)=VALM CNT . S IB S2="" F S IBS2=$O(^ TMP("IB_PR EV_CLAIM", $J,IBS1,IB S2)) Q:IBS 2="" S IB DA=0 F S IBDA=$O(^T MP("IB_PRE V_CLAIM",$ J,IBS1,IBS 2,IBDA)) Q :'IBDA D .. N IBX,I BTEST .. ; S IBIFN=+$ G(^IBA(364 ,+IBDA,0)) ,IB0=$G(^D GCR(399,IB IFN,0)) .. S IBIFN=$ S(IBLOC:+I BDA,1:+$G( ^IBA(364,+ IBDA,0))), IB0=$G(^DG CR(399,IBI FN,0)) .. S IBX=$P(^ TMP("IB_PR EV_CLAIM", $J,IBS1,IB S2,IBDA),U ,1) .. I I BX=1 S IBT EST=0 ; li ve 364 tra nsmission .. I IBX=2 S IBTEST= 1 ; test 3 64 transmi ssion .. I IBX=3 S I BTEST=1 ; test 361.4 transmiss ion .. D W RT(IBS1,IB S2,IBDA,IB IFN,IBSORT ,"S","",.I BCNT,0,IBT EST) .. I IBSORT=1,I BBDA S ^TM P("IB_PREV _CLAIM_BAT CH",$J,IBB DA,VALMCNT )=IBIFN_U_ IBCNT .. Q . Q ;BLDQ Q ;EXIT ; Clean up code ; K ^ TMP("IB_PR EV_CLAIM_L IST",$J) K ^TMP("IB_ PREV_CLAIM _SELECT",$ J) K ^TMP( "IB_PREV_C LAIM_LIST_ DX",$J) K ^TMP("IB_P REV_CLAIM_ BATCH",$J) D CLEAR^V ALM1 Q ;WR T(IBS1,IBS 2,IBDA,IBI FN,IBSORT, IBREP,IBHD R,IBPAGE,I BSTOP,IBTE ST) ; Wrt/ output ; N IBX,IB0,Z ,IBCNT,ARS TAT S IBCN T=IBPAGE ; I 'IBIFN D G WRTQ . ; . ; fo r report o utput . I IBREP="R" D Q .. S Z="",$P(Z, "=",133)=" " .. D SET (Z,1,IBDA, IBREP,IBHD R,1,0,.IBP AGE,.IBSTO P) .. D SE T(IBS1,2,I BDA,IBREP, IBHDR,1,0, .IBPAGE,.I BSTOP) .. Q . ; . ; for ListMa n screen o utput . D SET(IBS1,0 ,IBDA,IBRE P,IBHDR,IB CNT+1,.VAL MCNT,.IBPA GE,.IBSTOP ) . Q ; S IB0=$G(^DG CR(399,IBI FN,0)) S I BX=$$FO^IB CNEUT1($P( IB0,U,1),8 ) ; claim# S IBX=IBX _$S(IBSORT =2&$G(IBTE ST):"T",1: " ")_" " S IBX=IBX_$ S($P(IB0,U ,19)=2:"15 00",1:"UB0 4")_" " S Z=$$INPAT^ IBCEF(IBIF N) S IBX=I BX_$S(Z:"I NPT ",1:"O UTPT") S I BX=IBX_$J( $P(IB0,U,2 1),3)_" " S Z=$$EXTE RNAL^DILFD (399,.13," ",$P(IB0,U ,13)) S IB X=IBX_$$FO ^IBCNEUT1( Z,11)_" " ; claim status S A RSTAT=+$P( $$BILL^RCJ IBFN2(IBIF N),U,2) ; ien S ARST AT=$P($G(^ PRCA(430.3 ,ARSTAT,0) ),U,2) ; a bbreviatio n S IBX=IB X_$$FO^IBC NEUT1(ARST AT,4) ; a/ r status d isplay ; I IBSORT=1 D ; sort by batch . N Z,IBZ,IBX DATA . ; P rint curre nt payer, payer addr ess, other payers, p at name . D F^IBCEF( "N-CURR IN SURANCE CO MPANY NAME ","IBZ",,I BIFN) . S IBX=IBX_$$ FO^IBCNEUT 1(IBZ,25)_ " " ; ins co name . S IBX=IBX_ $$FO^IBCNE UT1($$CURR INS(IBIFN, 1),29)_" " ; ad dress . K IBZ D F^IB CEF("N-OTH INSURANCE CO. NAME" ,"IBZ",,IB IFN) . S I BX=IBX_$$F O^IBCNEUT1 ($P($G(IBZ (1)),U,1), 15)_" " ; other payer . S Z=$P($G(^ DPT(+$P(IB 0,U,2),0)) ,U,1) . S IBX=IBX_$E (Z,1,18) ; patient n ame . ; . ; set line into list . S IBCNT =IBCNT+1 . D SET(.IB X,1,IBDA,I BREP,IBHDR ,IBCNT,.VA LMCNT,.IBP AGE,.IBSTO P) . S IBX ="" . ; . I $G(IBZ(2 ))'="" D ; other payer #2 i f it exist s .. S IBX =$J("",98) _$E($P(IBZ (2),U,1),1 ,15) .. D SET(.IBX,1 ,IBDA,IBRE P,IBHDR,IB CNT,.VALMC NT,.IBPAGE ,.IBSTOP) .. Q . Q ; I IBSORT= 2 D ; sort by payer . N Z,IBZ . S IBX=IBX _" " . ; P rint other payers, p atient nam e, date la st trans, batch #, r eject flag . D F^IBC EF("N-OTH INSURANCE CO. NAME", "IBZ",,IBI FN) . S IB X=IBX_$$FO ^IBCNEUT1( $P($G(IBZ( 1)),U,1),1 8)_" " ; oth payer #1 . S Z=$ P($G(^DPT( +$P(IB0,U, 2),0)),U,1 ) . S IBX= IBX_$$FO^I BCNEUT1(Z, 18)_" " ; pat ient name . ; . S Z= +$P($G(^IB A(364,+IBD A,0)),U,2) ; Batch p tr . S:IBL OC IBX=IBX _$$FO^IBCN EUT1($$FMT E^XLFDT($P ($G(^DGCR( 399,IBIFN, "S")),U,14 ),"1"),17) ; date la st printed *547* . S :'IBLOC IB X=IBX_$$FO ^IBCNEUT1( $$FMTE^XLF DT($P($G(^ IBA(364.1, +Z,1)),U,3 )\1,"1"),1 7) ; date last trans mitted . S :'IBLOC IB X=IBX_$$FO ^IBCNEUT1( $P($G(^IBA (364.1,Z,0 )),U,1),10 ) ; batch# . S:IBLOC IBX=IBX_" " ; no bat ch# . S IB X=IBX_$S($ P($G(^IBA( 364.1,Z,0) ),U,5):" R ",1:"") ; batch reje cted flag . ; . ; se t line int o list . S IBCNT=IBC NT+1 . D S ET(.IBX,1, IBDA,IBREP ,IBHDR,IBC NT,.VALMCN T,.IBPAGE, .IBSTOP) . S IBX="" . ; . I $G (IBZ(2))'= "" D ; other p ayer#2 if it exists .. S IBX=$ J("",44)_$ E($P(IBZ(2 ),U),1,18) .. D SET( .IBX,1,IBD A,IBREP,IB HDR,IBCNT, .VALMCNT,. IBPAGE,.IB STOP) .. Q . Q ;WRTQ I IBREP=" S" S IBPAG E=IBCNT Q ;SET(IBX,I BLINE,IBDA ,IBREP,IBH DR,IBCNT,V ALMCNT,IBP AGE,IBSTOP ) ; N Q,Z, IBZ S IBZ= IBX,IBX="" I IBREP=" R" D Q . D:($Y+5)>I OSL!'IBPAG E HDR^IBCE PTC1(IBHDR ,IBSORT,.I BPAGE,.IBS TOP) D . I IBLINE F Z=1:1:IBLI NE W ! . W :'IBSTOP I BZ . Q ; ; only disp lay the co unter if w e have a l ine with t he claim# S VALMCNT= VALMCNT+1 I IBDA,$TR ($E(IBZ,1, 8)," ")'=" " S IBZ=$$ FO^IBCNEUT 1($J(IBCNT ,3),6)_IBZ I IBDA,$T R($E(IBZ,1 ,8)," ")=" " S IBZ=" "_IBZ ; S ^TMP("IB_P REV_CLAIM_ LIST",$J,V ALMCNT,0)= IBZ S ^TMP ("IB_PREV_ CLAIM_LIST ",$J,"IDX" ,VALMCNT,I BCNT)="" I IBDA,$TR( $E(IBZ,1,8 )," ")'="" S ^TMP("I B_PREV_CLA IM_LIST_DX ",$J,IBCNT )=VALMCNT_ U_IBDA Q ; CURRINS(IB IFN,TRUNC) ; Returns Current i nsurance a ddress for given cla im ; TRUNC = truncat e flag; 1 to truncat e the addr ess and ci ty N IBX,I BZ,L1,CITY ,ST D F^IB CEF("N-CUR R INS CO F ULL ADDRES S","IBZ",, IBIFN) S L 1=$G(IBZ(1 )) I +$G(T RUNC) S L1 =$E(L1,1,1 5) S CITY= $G(IBZ(4)) I +$G(TRU NC) S CITY =$E(CITY,1 ,10) S ST= $G(IBZ(5)) I ST S ST =$P($G(^DI C(5,ST,0)) ,U,2) S IB X=L1_" "_C ITY I CITY '="",ST'=" " S IBX=IB X_","_ST E S IBX=IB X_" "_ST Q IBX ; | |
| 2539 | Modified L ogic (Chan ges are in bold) | |
| 2540 | IBCEPTC2 ; ALB/TMK - EDI PREVIO USLY TRANS MITTED CLA IMS LIST M GR ;01/20/ 05 ;;2.0;I NTEGRATED BILLING;** 296,320,34 8,349,547, 592**;21-M AR-94;Buil d 119 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ; IA 3337 fo r file 430 .3 ; IB*2. 0*547 Vari able IBLOC is pre-de fined (in IBCEPTC) ; HDR ; K VA LMHDR I IB LOC S VALM HDR(1)="Cl aims Selec ted: "_+$G (^TMP("IB_ PREV_CLAIM _SELECT",$ J))_" (mar ked with * )" Q S VAL MHDR(1)="* * A claim may appear multiple times if t ransmitted more than once. **" ; I $G(IB SORT)=1 D . S VALMHD R(2)="Clai ms Selecte d: "_+$G(^ TMP("IB_PR EV_CLAIM_S ELECT",$J) )_" (marke d with *)" . Q ; I $ G(IBSORT)= 2 D . S VA LMHDR(2)=" ** T = Tes t Claim ** R = Batch Rejected" . S VALMH DR(3)="Cla ims Select ed: "_+$G( ^TMP("IB_P REV_CLAIM_ SELECT",$J ))_" (mark ed with *) " . Q ; Q ;INIT ; S VALMCNT=0, VALMBG=1 D BLD Q ;BL D ; Build display li nes N IBDA ,IBS1,IBS2 ,IBIFN,IB0 ,IBX,IBCNT ,IBLEV1,IB BDA K ^TMP ("IB_PREV_ CLAIM_LIST ",$J),^TMP ("IB_PREV_ CLAIM_SELE CT",$J),^T MP("IB_PRE V_CLAIM_BA TCH",$J) S IBCNT=0 I $O(^TMP(" IB_PREV_CL AIM",$J,"" ))="" D G BLDQ . S IBX=" ** N O PREVIOUS LY "_$S(IB LOC:"PRINT ED",1:"TRA NSMITTED") _" CLAIMS EXIST FOR SEARCH CRI TERIA SELE CTED **" . D WRT(IBX ,"",0,0,"" ,"S","",.I BCNT,0) ; S IBS1="" F S IBS1= $O(^TMP("I B_PREV_CLA IM",$J,IBS 1)) Q:IBS1 ="" D . ; First lev el sort . ; for sort by batch, display b atch ID an d transmit date . I IBSORT=1 D .. S IBLE V1=" Batch : "_$P(IBS 1,U,2)_" L ast Transm itted: "_$ G(^TMP("IB _PREV_CLAI M",$J,IBS1 )) .. S IB BDA=+$O(^I BA(364.1," B",$P(IBS1 ,U,2),0)) .. I $P(IB S1,U,3) S IBLEV1=IBL EV1_" ** T est" .. I $P(IBS1,U, 4) S IBLEV 1=IBLEV1_" ** Reject ed" .. Q . ; . ; for sort by p ayer, disp lay ins co name and payer addr ess . I IB SORT=2 D . . S IBLEV1 =" "_$P(IB S1,U)_" "_ $$CURRINS( +$G(^TMP(" IB_PREV_CL AIM",$J,IB S1)),0) .. Q . ; . ; output so rt header line . D W RT(IBLEV1, "",0,0,IBS ORT,"S","" ,IBCNT,0) ; Add head er line . ; . I IBSO RT=1,IBBDA S ^TMP("I B_PREV_CLA IM_BATCH", $J,IBBDA)= VALMCNT . S IBS2="" F S IBS2= $O(^TMP("I B_PREV_CLA IM",$J,IBS 1,IBS2)) Q :IBS2="" S IBDA=0 F S IBDA=$ O(^TMP("IB _PREV_CLAI M",$J,IBS1 ,IBS2,IBDA )) Q:'IBDA D .. N I BX,IBTEST .. ;S IBIF N=+$G(^IBA (364,+IBDA ,0)),IB0=$ G(^DGCR(39 9,IBIFN,0) ) .. S IBI FN=$S(IBLO C:+IBDA,1: +$G(^IBA(3 64,+IBDA,0 ))),IB0=$G (^DGCR(399 ,IBIFN,0)) .. S IBX= $P(^TMP("I B_PREV_CLA IM",$J,IBS 1,IBS2,IBD A),U,1) .. I IBX=1 S IBTEST=0 ; live 364 transmiss ion .. I I BX=2 S IBT EST=1 ; te st 364 tra nsmission .. I IBX=3 S IBTEST= 1 ; test 3 61.4 trans mission .. D WRT(IBS 1,IBS2,IBD A,IBIFN,IB SORT,"S"," ",.IBCNT,0 ,IBTEST) . . I IBSORT =1,IBBDA S ^TMP("IB_ PREV_CLAIM _BATCH",$J ,IBBDA,VAL MCNT)=IBIF N_U_IBCNT .. Q . Q ; BLDQ Q ;EX IT ; Clean up code ; K ^TMP("I B_PREV_CLA IM_LIST",$ J) K ^TMP( "IB_PREV_C LAIM_SELEC T",$J) K ^ TMP("IB_PR EV_CLAIM_L IST_DX",$J ) K ^TMP(" IB_PREV_CL AIM_BATCH" ,$J) D CLE AR^VALM1 Q ;WRT(IBS1 ,IBS2,IBDA ,IBIFN,IBS ORT,IBREP, IBHDR,IBPA GE,IBSTOP, IBTEST) ; Wrt/output ; N IBX,I B0,Z,IBCNT ,ARSTAT S IBCNT=IBPA GE ; I 'IB IFN D G W RTQ . ; . ; for repo rt output . I IBREP= "R" D Q . . S Z="",$ P(Z,"=",13 3)="" .. D SET(Z,1,I BDA,IBREP, IBHDR,1,0, .IBPAGE,.I BSTOP) .. D SET(IBS1 ,2,IBDA,IB REP,IBHDR, 1,0,.IBPAG E,.IBSTOP) .. Q . ; . ; for Li stMan scre en output . D SET(IB S1,0,IBDA, IBREP,IBHD R,IBCNT+1, .VALMCNT,. IBPAGE,.IB STOP) . Q ; S IB0=$G (^DGCR(399 ,IBIFN,0)) S IBX=$$F O^IBCNEUT1 ($P(IB0,U, 1),8) ; cl aim# S IBX =IBX_$S(IB SORT=2&$G( IBTEST):"T ",1:" ")_" " ;JWS;IB *2.0*592 U S1108 - De ntal EDI 8 37D / form J430D S I BX=IBX_$S( $P(IB0,U,1 9)=2:"1500 ",$P(IB0,U ,19)=7:"J4 30D",1:"UB 04")_" " S Z=$$INPAT ^IBCEF(IBI FN) S IBX= IBX_$S(Z:" INPT ",1:" OUTPT") S IBX=IBX_$J ($P(IB0,U, 21),3)_" " S Z=$$EXT ERNAL^DILF D(399,.13, "",$P(IB0, U,13)) S I BX=IBX_$$F O^IBCNEUT1 (Z,11)_" " ; claim status S ARSTAT=+$P ($$BILL^RC JIBFN2(IBI FN),U,2) ; ien S ARS TAT=$P($G( ^PRCA(430. 3,ARSTAT,0 )),U,2) ; abbreviati on S IBX=I BX_$$FO^IB CNEUT1(ARS TAT,4) ; a /r status display ; I IBSORT=1 D ; sort b y batch . N Z,IBZ,IB XDATA . ; Print curr ent payer, payer add ress, othe r payers, pat name . D F^IBCEF ("N-CURR I NSURANCE C OMPANY NAM E","IBZ",, IBIFN) . S IBX=IBX_$ $FO^IBCNEU T1(IBZ,25) _" " ; ins co name . S IBX=IBX _$$FO^IBCN EUT1($$CUR RINS(IBIFN ,1),29)_" " ; a ddress . K IBZ D F^I BCEF("N-OT H INSURANC E CO. NAME ","IBZ",,I BIFN) . S IBX=IBX_$$ FO^IBCNEUT 1($P($G(IB Z(1)),U,1) ,15)_" " ; othe r payer . S Z=$P($G( ^DPT(+$P(I B0,U,2),0) ),U,1) . S IBX=IBX_$ E(Z,1,18) ; patient name . ; . ; set lin e into lis t . S IBCN T=IBCNT+1 . D SET(.I BX,1,IBDA, IBREP,IBHD R,IBCNT,.V ALMCNT,.IB PAGE,.IBST OP) . S IB X="" . ; . I $G(IBZ( 2))'="" D ; other payer #2 if it exis ts .. S IB X=$J("",98 )_$E($P(IB Z(2),U,1), 1,15) .. D SET(.IBX, 1,IBDA,IBR EP,IBHDR,I BCNT,.VALM CNT,.IBPAG E,.IBSTOP) .. Q . Q ; I IBSORT =2 D ; sort by payer . N Z,IBZ . S IBX=IB X_" " . ; Print othe r payers, patient na me, date l ast trans, batch #, reject fla g . D F^IB CEF("N-OTH INSURANCE CO. NAME" ,"IBZ",,IB IFN) . S I BX=IBX_$$F O^IBCNEUT1 ($P($G(IBZ (1)),U,1), 18)_" " ; oth paye r#1 . S Z= $P($G(^DPT (+$P(IB0,U ,2),0)),U, 1) . S IBX =IBX_$$FO^ IBCNEUT1(Z ,18)_" " ; pa tient name . ; . S Z =+$P($G(^I BA(364,+IB DA,0)),U,2 ) ; Batch ptr . S:IB LOC IBX=IB X_$$FO^IBC NEUT1($$FM TE^XLFDT($ P($G(^DGCR (399,IBIFN ,"S")),U,1 4),"1"),17 ) ; date l ast printe d *547* . S:'IBLOC I BX=IBX_$$F O^IBCNEUT1 ($$FMTE^XL FDT($P($G( ^IBA(364.1 ,+Z,1)),U, 3)\1,"1"), 17) ; date last tran smitted . S:'IBLOC I BX=IBX_$$F O^IBCNEUT1 ($P($G(^IB A(364.1,Z, 0)),U,1),1 0) ; batch # . S:IBLO C IBX=IBX_ "" ; no ba tch# . S I BX=IBX_$S( $P($G(^IBA (364.1,Z,0 )),U,5):" R",1:"") ; batch rej ected flag . ; . ; s et line in to list . S IBCNT=IB CNT+1 . D SET(.IBX,1 ,IBDA,IBRE P,IBHDR,IB CNT,.VALMC NT,.IBPAGE ,.IBSTOP) . S IBX="" . ; . I $ G(IBZ(2))' ="" D ; other payer#2 if it exists .. S IBX= $J("",44)_ $E($P(IBZ( 2),U),1,18 ) .. D SET (.IBX,1,IB DA,IBREP,I BHDR,IBCNT ,.VALMCNT, .IBPAGE,.I BSTOP) .. Q . Q ;WRT Q I IBREP= "S" S IBPA GE=IBCNT Q ;SET(IBX, IBLINE,IBD A,IBREP,IB HDR,IBCNT, VALMCNT,IB PAGE,IBSTO P) ; N Q,Z ,IBZ S IBZ =IBX,IBX=" " I IBREP= "R" D Q . D:($Y+5)> IOSL!'IBPA GE HDR^IBC EPTC1(IBHD R,IBSORT,. IBPAGE,.IB STOP) D . I IBLINE F Z=1:1:IBL INE W ! . W:'IBSTOP IBZ . Q ; ; only dis play the c ounter if we have a line with the claim# S VALMCNT =VALMCNT+1 I IBDA,$T R($E(IBZ,1 ,8)," ")'= "" S IBZ=$ $FO^IBCNEU T1($J(IBCN T,3),6)_IB Z I IBDA,$ TR($E(IBZ, 1,8)," ")= "" S IBZ=" "_IBZ ; S ^TMP("IB_ PREV_CLAIM _LIST",$J, VALMCNT,0) =IBZ S ^TM P("IB_PREV _CLAIM_LIS T",$J,"IDX ",VALMCNT, IBCNT)="" I IBDA,$TR ($E(IBZ,1, 8)," ")'=" " S ^TMP(" IB_PREV_CL AIM_LIST_D X",$J,IBCN T)=VALMCNT _U_IBDA Q ;CURRINS(I BIFN,TRUNC ) ; Return s Current insurance address fo r given cl aim ; TRUN C = trunca te flag; 1 to trunca te the add ress and c ity N IBX, IBZ,L1,CIT Y,ST D F^I BCEF("N-CU RR INS CO FULL ADDRE SS","IBZ", ,IBIFN) S L1=$G(IBZ( 1)) I +$G( TRUNC) S L 1=$E(L1,1, 15) S CITY =$G(IBZ(4) ) I +$G(TR UNC) S CIT Y=$E(CITY, 1,10) S ST =$G(IBZ(5) ) I ST S S T=$P($G(^D IC(5,ST,0) ),U,2) S I BX=L1_" "_ CITY I CIT Y'="",ST'= "" S IBX=I BX_","_ST E S IBX=I BX_" "_ST Q IBX ; | |
| 2541 | ||
| 2542 | ||
| 2543 | Routines | |
| 2544 | Activities | |
| 2545 | Routine Na me | |
| 2546 | IBCEPTR | |
| 2547 | Enhancemen t Category | |
| 2548 | New | |
| 2549 | Modify | |
| 2550 | Delete | |
| 2551 | No Change | |
| 2552 | RTM | |
| 2553 | ||
| 2554 | Related Op tions | |
| 2555 | None | |
| 2556 | Related Ro utines | |
| 2557 | Routines “ Called By” | |
| 2558 | Routines “ Called” | |
| 2559 | ||
| 2560 | ||
| 2561 | ||
| 2562 | ||
| 2563 | Data Dicti onary (DD) Reference s | |
| 2564 | ||
| 2565 | Related Pr otocols | |
| 2566 | None | |
| 2567 | Related In tegration Control Re gistration s (ICRs) | |
| 2568 | None | |
| 2569 | Data Passi ng | |
| 2570 | Input | |
| 2571 | Output Re ference | |
| 2572 | Both | |
| 2573 | Global Re ference | |
| 2574 | Local | |
| 2575 | Input Attr ibute Name and Defin ition | |
| 2576 | Name: | |
| 2577 | Definition : | |
| 2578 | Output Att ribute Nam e and Defi nition | |
| 2579 | Name: | |
| 2580 | Definition : | |
| 2581 | Current Lo gic | |
| 2582 | IBCEPTR ;A LB/ESG - T est Claim Messages R eport ;28- JAN-2005 ; ;2.0;INTEG RATED BILL ING;**296, 320,348,34 9**;21-MAR -94;Build 46 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; ; eClaim s Plus ; R eport on T est Claim Transmissi ons and St atus Messa ges ;EN ; Entry Poin t NEW STOP ,IBRMETH,I BRDATA D S ELECT I ST OP G EXIT D DEVICEEX IT ; Exit Point Q ;S ELECT ; De termine wh ich claim# 's or batc h#'s to re port on NE W DIC,DIR, X,Y,DIRUT, DTOUT,DUOU T,DIROUT,D S STOP=0 W @IOF W ! !?23,"Test Claim EDI Transmiss ion Report " W !!?7," This repor t will dis play EDI t ransmissio n data and returned status" W !?7,"messa ge data fo r selected test clai ms. You ma y select t est claims " W !?7,"b y claim nu mber or by batch num ber or you may searc h for clai ms that" W !?7,"were transmitt ed within a date ran ge.",! S D IR(0)="SO^ C:Claim;B: Batch;D:Da te Range ( Date Trans mitted)" S DIR("A")= "Selection Method",D IR("B")="D " D ^DIR K DIR I $D( DIRUT) S S TOP=1 G SE LECTX S IB RMETH=Y I IBRMETH'=" C",IBRMETH '="B",IBRM ETH'="D" S STOP=1 G SELECTX ; K IBRDATA I IBRMETH= "C" D . F D Q:Y'>0 .. W ! .. S DIC("A" )="Test Cl aim: " .. I $O(IBRDA TA("")) S DIC("A")=" Another Te st Claim: " .. S DIC ("W")="D C LMLST^IBCE PTR(Y)" .. S DIC=361 .4,DIC(0)= "AEMQ",D=" B" D MIX^D IC1 .. Q:Y '>0 .. S I BRDATA(+Y) ="" .. Q . Q ; I IBR METH="B" D . F D Q :Y'>0 .. W ! .. S DI C("A")="Te st Batch: " .. I $O( IBRDATA("" )) S DIC(" A")="Anoth er Test Ba tch: " .. S DIC("S") ="I $P(^(0 ),U,14),$O (^IBM(361. 4,""C"",+Y ,0))" .. S DIC=364.1 ,DIC(0)="A EMQ",D="B^ C" D MIX^D IC1 .. Q:Y '>0 .. S I BRDATA(+Y) ="" .. Q . Q ; I IBR METH="D" D . W ! . S DIR(0)="D AO^:"_DT_" :AEX",DIR( "A")=" Ear liest Date Claims Tr ansmitted: " . D ^DI R K DIR . I $D(DIRUT )!'Y Q . S IBRDATA(1 )=Y . W ! . S DIR(0) ="DAO^"_Y_ ":"_DT_":A EX",DIR("A ")=" Lates t Date Cla ims Transm itted: ",D IR("B")="T oday" . D ^DIR K DIR . I $D(DI RUT)!'Y Q . S IBRDAT A(2)=Y . Q ; I '$O(I BRDATA("") ) S STOP=1 G SELECTX I IBRMETH ="D",'$G(I BRDATA(1)) S STOP=1 G SELECTX I IBRMETH= "D",'$G(IB RDATA(2)) S STOP=1 G SELECTX ; SELECTX ; Q ;DEVICE ; standard device se lection NE W ZTRTN,ZT DESC,ZTSAV E,POP W !! !,"This re port is 80 character s wide.",! S ZTRTN=" COMPILE^IB CEPTR" S Z TDESC="Tes t Claim ED I Transmis sion Repor t" S ZTSAV E("IBRMETH ")="" S ZT SAVE("IBRD ATA")="" D EN^XUTMDE VQ(ZTRTN,Z TDESC,.ZTS AVE,"QM")D EVX ; Q ;C OMPILE ; c ompile the data into a scratch global NE W RTN,EXTB CH,IBIFN,B CHIEN,TXDA TM S RTN=" IBCEPTR" K ILL ^TMP($ J,RTN) ; i nit scratc h global ; I IBRMETH ="C" D ; claim se arch . S E XTBCH=0 . S IBIFN=0 . F S IBI FN=$O(IBRD ATA(IBIFN) ) Q:'IBIFN D STORE( IBIFN) . Q ; I IBRME TH="B" D ; batch search . S BCHIEN=0 . F S BCH IEN=$O(IBR DATA(BCHIE N)) Q:'BCH IEN D .. S EXTBCH=$ P($G(^IBA( 364.1,BCHI EN,0)),U,1 ) .. I EXT BCH="" S E XTBCH="~un known" .. S IBIFN=0 .. F S IB IFN=$O(^IB M(361.4,"C ",BCHIEN,I BIFN)) Q:' IBIFN D S TORE(IBIFN ) .. Q . Q ; I IBRME TH="D" D ; date r ange searc h . S EXTB CH=0 . S T XDATM=$O(^ IBM(361.4, "ATD",IBRD ATA(1)),-1 ) . F S T XDATM=$O(^ IBM(361.4, "ATD",TXDA TM)) Q:'TX DATM Q:(T XDATM\1)>I BRDATA(2) D .. S IBI FN=0 .. F S IBIFN=$ O(^IBM(361 .4,"ATD",T XDATM,IBIF N)) Q:'IBI FN D STOR E(IBIFN) . . Q . Q ; D PRINT ; prin t the repo rt D ^%ZIS C ; close the device KILL ^TMP ($J,RTN) ; clean up scratch gl obal I $D( ZTQUEUED) S ZTREQ="@ " ; purge the task reco rdCOMPX ; Q ;STORE(I BIFN) ; In put = inte rnal bill# ; continue compilati on NEW IB0 ,CLAIM,IBR TXD0,TXIEN ,SMIEN,DAT A,TXDTM S IB0=$G(^DG CR(399,IBI FN,0)) S C LAIM=$P(IB 0,U,1) ; e xternal cl aim# I CLA IM="" S CL AIM="~unkn own" S IBR TXD0=99999 999 ; init ial value for earlie st transmi ssion date ; I IBRME TH="C" D ; claim s earch for transmissi on data (a ll) . S TX IEN=0 . F S TXIEN=$ O(^IBM(361 .4,IBIFN,1 ,TXIEN)) Q :'TXIEN D STORETX(I BIFN,TXIEN ) . Q ; I IBRMETH="B " D ; ba tch search for trans mission da ta ("C" x- ref) . S T XIEN=0 . F S TXIEN= $O(^IBM(36 1.4,"C",BC HIEN,IBIFN ,TXIEN)) Q :'TXIEN D STORETX(I BIFN,TXIEN ) . Q ; I IBRMETH="D " D ; da te range s earch for transmissi on data (" ATD" xref) . S TXIEN =0 . F S TXIEN=$O(^ IBM(361.4, "ATD",TXDA TM,IBIFN,T XIEN)) Q:' TXIEN D S TORETX(IBI FN,TXIEN) . Q ; ; lo op thru al l returned messages for claim S SMIEN=0 F S SMIEN =$O(^IBM(3 61.4,IBIFN ,2,SMIEN)) Q:'SMIEN D . S DAT A=$G(^IBM( 361.4,IBIF N,2,SMIEN, 0)) Q:DATA ="" ; re ceived msg data . S TXDTM=$P(D ATA,U,1) Q :'TXDTM ; msg rec 'd date/ti me . ; . ; Batch onl y: if this status me ssage was received b efore the . ; earlie st transmi ssion for this batch , then don 't include it . I IB RMETH="B", TXDTM'>IBR TXD0 Q . ; . ; Date range sear ch only: m ake sure t he date/ti me the sta tus messag e . ; was received i s inside t he user sp ecified da te range f or this re port . I I BRMETH="D" ,(TXDTM\1) <IBRDATA(1 ) Q ; r ec'd too e arly . I I BRMETH="D" ,(TXDTM\1) >IBRDATA(2 ) Q ; r ec'd too l ate . ; . ; store it . M ^TMP( $J,RTN,EXT BCH,CLAIM, TXDTM,2,SM IEN)=^IBM( 361.4,IBIF N,2,SMIEN) . QSTOREX ; Q ;STOR ETX(IBIFN, TXIEN) ; s tore trans mission in fo NEW DAT A,TXDTM S DATA=$G(^I BM(361.4,I BIFN,1,TXI EN,0)) I D ATA="" G S TTXXX S TX DTM=$P(DAT A,U,1) ; t ransmit da te/time I 'TXDTM G S TTXXX I TX DTM<IBRTXD 0 S IBRTXD 0=TXDTM ; ; store it M ^TMP($J ,RTN,EXTBC H,CLAIM,TX DTM,1,TXIE N)=^IBM(36 1.4,IBIFN, 1,TXIEN)ST TXXX ; Q ; PRINT ; pr int the re port to th e specifie d device N EW MAXCNT, CRT,PAGECN T,STOP,DIR ,X,Y,DIRUT ,DUOUT,DTO UT,DIROUT NEW BATCH, CLAIM,IBIF N,CLMD,TXD ,TYPE,IEN I IOST["C- " S MAXCNT =IOSL-3,CR T=1 E S M AXCNT=IOSL -6,CRT=0 S PAGECNT=0 ,STOP=0 ; I '$D(^TMP ($J,RTN)) D HEADER W !!!?5,"No Data Foun d" ; S BAT CH="" F S BATCH=$O( ^TMP($J,RT N,BATCH)) Q:BATCH="" D Q:STO P . D HEAD ER Q:STOP . I BATCH' =0 W !!,"B atch#: ",B ATCH . S C LAIM="" . F S CLAIM =$O(^TMP($ J,RTN,BATC H,CLAIM)) Q:CLAIM="" D Q:STO P .. I $Y+ 2>MAXCNT!' PAGECNT D HEADER Q:S TOP .. I B ATCH=0 W ! .. W !,"C laim#: ",C LAIM .. S IBIFN=+$O( ^DGCR(399, "B",CLAIM, "")) .. I IBIFN S CL MD=$$BT(IB IFN) W ?18 ,$E($P(CLM D,U,3),1,2 0),?40,"(" ,$P(CLMD,U ,1),")" .. W !,$$RJ^ XLFSTR("", 80,"-") .. ; .. S TX D=0 .. F S TXD=$O(^ TMP($J,RTN ,BATCH,CLA IM,TXD)) Q :'TXD!STOP S TYPE=0 F S TYPE =$O(^TMP($ J,RTN,BATC H,CLAIM,TX D,TYPE)) Q :'TYPE!STO P S IEN=0 F S IEN= $O(^TMP($J ,RTN,BATCH ,CLAIM,TXD ,TYPE,IEN) ) Q:'IEN!S TOP D Q: STOP ... I TYPE=1 D TXPRT ... I TYPE=2 D SMPRT ... Q .. Q . Q ; I STOP G PRINTX I $Y+2>MAX CNT!'PAGEC NT D HEADE R I STOP G PRINTX W !!?5,"*** End of Rep ort ***" I CRT,'$D(Z TQUEUED) S DIR(0)="E " D ^DIR K DIRPRINTX ; Q ;TXPR T ; print transmissi on informa tion NEW D ATA,TXDTM, EXTBCH,TXB Y,INSIEN,P AYER,PSEQ, INZ S DATA =$G(^TMP($ J,RTN,BATC H,CLAIM,TX D,TYPE,IEN ,0)) I DAT A="" G TXP RTX S TXDT M=$$FMTE^X LFDT($P(DA TA,U,1),"5 Z") S EXTB CH=$$EXTER NAL^DILFD( 361.41,.02 ,,$P(DATA, U,2)) ; ba tch S TXBY =$$EXTERNA L^DILFD(36 1.41,.03,, $P(DATA,U, 3)) ; who tx S INSIE N=+$$FINDI NS^IBCEF1( IBIFN,$P(D ATA,U,4)) ; insuranc e S INZ=$$ INSADD^IBC NSC02(INSI EN) ; ins name/addr S PAYER=$P (INZ,U,1) ; ins name S PSEQ=$T R($P(DATA, U,4),"123" ,"PST") ; payer seq ; I $Y+2>M AXCNT!'PAG ECNT D HEA DER I STOP G TXPRTX W !,"Trans mission In formation" W !?1,TXD TM,?22,"Bc h#",+$E(EX TBCH,4,99) ,?33,$E(TX BY,1,15),? 50,$E(PAYE R,1,20)," (",PSEQ,") " ; displa y address info if no t Medicare I '$$MCRW NR^IBEFUNC (INSIEN) W !?50,$E($ P(INZ,U,2) ,1,15),"," ,$E($P(INZ ,U,3),1,11 ),",",$E($ P(INZ,U,4) ,1,2) W !T XPRTX ; Q ;SMPRT ; p rint retur ned status message i nformation NEW DATA, TXDTM,SEVE RITY,Z S D ATA=$G(^TM P($J,RTN,B ATCH,CLAIM ,TXD,TYPE, IEN,0)) I DATA="" G SMPRTX S T XDTM=$$FMT E^XLFDT($P (DATA,U,1) ,"5Z") S S EVERITY=$$ EXTERNAL^D ILFD(361.4 2,.02,,$P( DATA,U,2)) ; msg sev erity ; I $Y+2>MAXCN T!'PAGECNT D HEADER I STOP G S MPRTX W !, "Status Me ssage Info rmation" W !?1,TXDTM ,?22,SEVER ITY,?65,"M sg#",$P(DA TA,U,3) S Z=0 F S Z =$O(^TMP($ J,RTN,BATC H,CLAIM,TX D,TYPE,IEN ,1,Z)) Q:' Z D Q:ST OP . I $Y+ 1>MAXCNT!' PAGECNT D HEADER Q:S TOP . W !? 2,$G(^TMP( $J,RTN,BAT CH,CLAIM,T XD,TYPE,IE N,1,Z,0)) . Q W !SMP RTX ; Q ;H EADER ; pa ge break a nd header NEW LIN,HD R,TAB S ST OP=0 I CRT ,PAGECNT>0 ,'$D(ZTQUE UED) D I STOP G HEA DX . I MAX CNT<51 F L IN=1:1:(MA XCNT-$Y) W ! . S DIR (0)="E" D ^DIR K DIR . I 'Y S STOP=1 Q . Q ; S PAG ECNT=PAGEC NT+1 W @IO F,! ; W "T est Claim EDI Transm ission Rep ort" S HDR ="Page: "_ PAGECNT,TA B=80-$L(HD R)-1 W ?TA B,HDR W !, "Selected ",$S(IBRME TH="B":"Ba tches",IBR METH="C":" Claims",1: "Date Rang e") S HDR= $$FMTE^XLF DT($$NOW^X LFDT,"1Z") ,TAB=80-$L (HDR)-1 W ?TAB,HDR W !,$$RJ^XL FSTR("",80 ,"=") ; ; check for a stop req uest I $D( ZTQUEUED), $$S^%ZTLOA D() D G H EADX . S ( ZTSTOP,STO P)=1 . W ! !!?5,"*** Report Hal ted by Tas kManager R equest *** " . Q ;HEA DX ; Q ;BT (IBIFN) ; bill type and info ; [1] TYPE (form type , charge t ype, inp/o utp) ; [2] claim# ; [3] patien t name NEW TYPE,IB0, F,C,S S TY PE="" S IB 0=$G(^DGCR (399,+$G(I BIFN),0)) I IB0="" Q "" S F=$P (IB0,U,19) ,F=$S(F=2: "1500",1:" UB04") S C =$P(IB0,U, 27),C=$S(C =1:"Inst", 1:"Prof") S S=$$INPA T^IBCEF(IB IFN),S=$S( S=1:"Inpat ",1:"Outpa t") S TYPE =F_", "_C_ ", "_S Q T YPE_U_$P(I B0,U,1)_U_ $P($G(^DPT (+$P(IB0,U ,2),0)),U, 1) ;CLMLST (IBIFN) ; DIC lister NEW TYPE, LTD,N1,N2 S TYPE=$P( $$BT(IBIFN ),U,1) S L TD=$$FMTE^ XLFDT($P($ G(^IBM(361 .4,IBIFN,0 )),U,2),"2 Z") S N1=+ $P($G(^IBM (361.4,IBI FN,1,0)),U ,4) ; # tr ansmission s S N2=+$P ($G(^IBM(3 61.4,IBIFN ,2,0)),U,4 ) ; # retu rn message s W " ",TY PE,?34," " ,LTD,?45," ",N1," Tr ansmission ",$S(N1'=1 :"s",1:"") W ?63," " ,N2," Mess age",$S(N2 '=1:"s",1: "")CLMLSTX ; Q ; | |
| 2583 | Modified L ogic (Chan ges are in bold) | |
| 2584 | IBCEPTR ;A LB/ESG - T est Claim Messages R eport ;28- JAN-2005 ; ;2.0;INTEG RATED BILL ING;**296, 320,348,34 9,592**;21 -MAR-94;Bu ild 46 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ; ; eC laims Plus ; Report on Test Cl aim Transm issions an d Status M essages ;E N ; Entry Point NEW STOP,IBRME TH,IBRDATA D SELECT I STOP G E XIT D DEVI CEEXIT ; E xit Point Q ;SELECT ; Determin e which cl aim#'s or batch#'s t o report o n NEW DIC, DIR,X,Y,DI RUT,DTOUT, DUOUT,DIRO UT,D S STO P=0 W @IOF W !!?23," Test Claim EDI Trans mission Re port" W !! ?7,"This r eport will display E DI transmi ssion data and retur ned status " W !?7,"m essage dat a for sele cted test claims. Yo u may sele ct test cl aims" W !? 7,"by clai m number o r by batch number or you may s earch for claims tha t" W !?7," were trans mitted wit hin a date range.",! S DIR(0)= "SO^C:Clai m;B:Batch; D:Date Ran ge (Date T ransmitted )" S DIR(" A")="Selec tion Metho d",DIR("B" )="D" D ^D IR K DIR I $D(DIRUT) S STOP=1 G SELECTX S IBRMETH= Y I IBRMET H'="C",IBR METH'="B", IBRMETH'=" D" S STOP= 1 G SELECT X ; K IBRD ATA I IBRM ETH="C" D . F D Q: Y'>0 .. W ! .. S DIC ("A")="Tes t Claim: " .. I $O(I BRDATA("") ) S DIC("A ")="Anothe r Test Cla im: " .. S DIC("W")= "D CLMLST^ IBCEPTR(Y) " .. S DIC =361.4,DIC (0)="AEMQ" ,D="B" D M IX^DIC1 .. Q:Y'>0 .. S IBRDATA (+Y)="" .. Q . Q ; I IBRMETH=" B" D . F D Q:Y'>0 .. W ! .. S DIC("A") ="Test Bat ch: " .. I $O(IBRDAT A("")) S D IC("A")="A nother Tes t Batch: " .. S DIC( "S")="I $P (^(0),U,14 ),$O(^IBM( 361.4,""C" ",+Y,0))" .. S DIC=3 64.1,DIC(0 )="AEMQ",D ="B^C" D M IX^DIC1 .. Q:Y'>0 .. S IBRDATA (+Y)="" .. Q . Q ; I IBRMETH=" D" D . W ! . S DIR(0 )="DAO^:"_ DT_":AEX", DIR("A")=" Earliest Date Claim s Transmit ted: " . D ^DIR K DI R . I $D(D IRUT)!'Y Q . S IBRDA TA(1)=Y . W ! . S DI R(0)="DAO^ "_Y_":"_DT _":AEX",DI R("A")=" L atest Date Claims Tr ansmitted: ",DIR("B" )="Today" . D ^DIR K DIR . I $ D(DIRUT)!' Y Q . S IB RDATA(2)=Y . Q ; I ' $O(IBRDATA ("")) S ST OP=1 G SEL ECTX I IBR METH="D",' $G(IBRDATA (1)) S STO P=1 G SELE CTX I IBRM ETH="D",'$ G(IBRDATA( 2)) S STOP =1 G SELEC TX ;SELECT X ; Q ;DEV ICE ; stan dard devic e selectio n NEW ZTRT N,ZTDESC,Z TSAVE,POP W !!!,"Thi s report i s 80 chara cters wide .",! S ZTR TN="COMPIL E^IBCEPTR" S ZTDESC= "Test Clai m EDI Tran smission R eport" S Z TSAVE("IBR METH")="" S ZTSAVE(" IBRDATA")= "" D EN^XU TMDEVQ(ZTR TN,ZTDESC, .ZTSAVE,"Q M")DEVX ; Q ;COMPILE ; compile the data into a scr atch globa l NEW RTN, EXTBCH,IBI FN,BCHIEN, TXDATM S R TN="IBCEPT R" KILL ^T MP($J,RTN) ; init sc ratch glob al ; I IBR METH="C" D ; clai m search . S EXTBCH= 0 . S IBIF N=0 . F S IBIFN=$O( IBRDATA(IB IFN)) Q:'I BIFN D ST ORE(IBIFN) . Q ; I I BRMETH="B" D ; ba tch search . S BCHIE N=0 . F S BCHIEN=$O (IBRDATA(B CHIEN)) Q: 'BCHIEN D .. S EXTB CH=$P($G(^ IBA(364.1, BCHIEN,0)) ,U,1) .. I EXTBCH="" S EXTBCH= "~unknown" .. S IBIF N=0 .. F S IBIFN=$O (^IBM(361. 4,"C",BCHI EN,IBIFN)) Q:'IBIFN D STORE(I BIFN) .. Q . Q ; I I BRMETH="D" D ; da te range s earch . S EXTBCH=0 . S TXDATM= $O(^IBM(36 1.4,"ATD", IBRDATA(1) ),-1) . F S TXDATM= $O(^IBM(36 1.4,"ATD", TXDATM)) Q :'TXDATM Q:(TXDATM\ 1)>IBRDATA (2) D .. S IBIFN=0 . . F S IBI FN=$O(^IBM (361.4,"AT D",TXDATM, IBIFN)) Q: 'IBIFN D STORE(IBIF N) .. Q . Q ; D PRIN T ; print the report D ^ %ZISC ; cl ose the de vice KILL ^TMP($J,RT N) ; clean up scratc h global I $D(ZTQUEU ED) S ZTRE Q="@" ; purge the task recordCOMP X ; Q ;STO RE(IBIFN) ; Input = internal b ill#; cont inue compi lation NEW IB0,CLAIM ,IBRTXD0,T XIEN,SMIEN ,DATA,TXDT M S IB0=$G (^DGCR(399 ,IBIFN,0)) S CLAIM=$ P(IB0,U,1) ; externa l claim# I CLAIM="" S CLAIM="~ unknown" S IBRTXD0=9 9999999 ; initial va lue for ea rliest tra nsmission date ; I I BRMETH="C" D ; cla im search for transm ission dat a (all) . S TXIEN=0 . F S TXI EN=$O(^IBM (361.4,IBI FN,1,TXIEN )) Q:'TXIE N D STORE TX(IBIFN,T XIEN) . Q ; I IBRMET H="B" D ; batch se arch for t ransmissio n data ("C " x-ref) . S TXIEN=0 . F S TX IEN=$O(^IB M(361.4,"C ",BCHIEN,I BIFN,TXIEN )) Q:'TXIE N D STORE TX(IBIFN,T XIEN) . Q ; I IBRMET H="D" D ; date ran ge search for transm ission dat a ("ATD" x ref) . S T XIEN=0 . F S TXIEN= $O(^IBM(36 1.4,"ATD", TXDATM,IBI FN,TXIEN)) Q:'TXIEN D STORETX (IBIFN,TXI EN) . Q ; ; loop thr u all retu rned messa ges for cl aim S SMIE N=0 F S S MIEN=$O(^I BM(361.4,I BIFN,2,SMI EN)) Q:'SM IEN D . S DATA=$G(^ IBM(361.4, IBIFN,2,SM IEN,0)) Q: DATA="" ; received msg data . S TXDTM= $P(DATA,U, 1) Q:'TXDT M ; msg rec'd dat e/time . ; . ; Batch only: if this statu s message was receiv ed before the . ; ea rliest tra nsmission for this b atch, then don't inc lude it . I IBRMETH= "B",TXDTM' >IBRTXD0 Q . ; . ; D ate range search onl y: make su re the dat e/time the status me ssage . ; was receiv ed is insi de the use r specifie d date ran ge for thi s report . I IBRMETH ="D",(TXDT M\1)<IBRDA TA(1) Q ; rec'd t oo early . I IBRMETH ="D",(TXDT M\1)>IBRDA TA(2) Q ; rec'd t oo late . ; . ; stor e it . M ^ TMP($J,RTN ,EXTBCH,CL AIM,TXDTM, 2,SMIEN)=^ IBM(361.4, IBIFN,2,SM IEN) . QST OREX ; Q ; STORETX(IB IFN,TXIEN) ; store t ransmissio n info NEW DATA,TXDT M S DATA=$ G(^IBM(361 .4,IBIFN,1 ,TXIEN,0)) I DATA="" G STTXXX S TXDTM=$P (DATA,U,1) ; transmi t date/tim e I 'TXDTM G STTXXX I TXDTM<IB RTXD0 S IB RTXD0=TXDT M ; ; stor e it M ^TM P($J,RTN,E XTBCH,CLAI M,TXDTM,1, TXIEN)=^IB M(361.4,IB IFN,1,TXIE N)STTXXX ; Q ;PRINT ; print th e report t o the spec ified devi ce NEW MAX CNT,CRT,PA GECNT,STOP ,DIR,X,Y,D IRUT,DUOUT ,DTOUT,DIR OUT NEW BA TCH,CLAIM, IBIFN,CLMD ,TXD,TYPE, IEN I IOST ["C-" S MA XCNT=IOSL- 3,CRT=1 E S MAXCNT= IOSL-6,CRT =0 S PAGEC NT=0,STOP= 0 ; I '$D( ^TMP($J,RT N)) D HEAD ER W !!!?5 ,"No Data Found" ; S BATCH="" F S BATCH =$O(^TMP($ J,RTN,BATC H)) Q:BATC H="" D Q :STOP . D HEADER Q:S TOP . I BA TCH'=0 W ! !,"Batch#: ",BATCH . S CLAIM=" " . F S C LAIM=$O(^T MP($J,RTN, BATCH,CLAI M)) Q:CLAI M="" D Q :STOP .. I $Y+2>MAXC NT!'PAGECN T D HEADER Q:STOP .. I BATCH=0 W ! .. W !,"Claim#: ",CLAIM . . S IBIFN= +$O(^DGCR( 399,"B",CL AIM,"")) . . I IBIFN S CLMD=$$B T(IBIFN) W ?18,$E($P (CLMD,U,3) ,1,20),?40 ,"(",$P(CL MD,U,1),") " .. W !,$ $RJ^XLFSTR ("",80,"-" ) .. ; .. S TXD=0 .. F S TXD= $O(^TMP($J ,RTN,BATCH ,CLAIM,TXD )) Q:'TXD! STOP S TY PE=0 F S TYPE=$O(^T MP($J,RTN, BATCH,CLAI M,TXD,TYPE )) Q:'TYPE !STOP S I EN=0 F S IEN=$O(^TM P($J,RTN,B ATCH,CLAIM ,TXD,TYPE, IEN)) Q:'I EN!STOP D Q:STOP . .. I TYPE= 1 D TXPRT ... I TYPE =2 D SMPRT ... Q .. Q . Q ; I STOP G PRI NTX I $Y+2 >MAXCNT!'P AGECNT D H EADER I ST OP G PRINT X W !!?5," *** End of Report ** *" I CRT,' $D(ZTQUEUE D) S DIR(0 )="E" D ^D IR K DIRPR INTX ; Q ; TXPRT ; pr int transm ission inf ormation N EW DATA,TX DTM,EXTBCH ,TXBY,INSI EN,PAYER,P SEQ,INZ S DATA=$G(^T MP($J,RTN, BATCH,CLAI M,TXD,TYPE ,IEN,0)) I DATA="" G TXPRTX S TXDTM=$$FM TE^XLFDT($ P(DATA,U,1 ),"5Z") S EXTBCH=$$E XTERNAL^DI LFD(361.41 ,.02,,$P(D ATA,U,2)) ; batch S TXBY=$$EXT ERNAL^DILF D(361.41,. 03,,$P(DAT A,U,3)) ; who tx S I NSIEN=+$$F INDINS^IBC EF1(IBIFN, $P(DATA,U, 4)) ; insu rance S IN Z=$$INSADD ^IBCNSC02( INSIEN) ; ins name/a ddr S PAYE R=$P(INZ,U ,1) ; ins name S PSE Q=$TR($P(D ATA,U,4)," 123","PST" ) ; payer seq ; I $Y +2>MAXCNT! 'PAGECNT D HEADER I STOP G TXP RTX W !,"T ransmissio n Informat ion" W !?1 ,TXDTM,?22 ,"Bch#",+$ E(EXTBCH,4 ,99),?33,$ E(TXBY,1,1 5),?50,$E( PAYER,1,20 )," (",PSE Q,")" ; di splay addr ess info i f not Medi care I '$$ MCRWNR^IBE FUNC(INSIE N) W !?50, $E($P(INZ, U,2),1,15) ,",",$E($P (INZ,U,3), 1,11),",", $E($P(INZ, U,4),1,2) W !TXPRTX ; Q ;SMPRT ; print r eturned st atus messa ge informa tion NEW D ATA,TXDTM, SEVERITY,Z S DATA=$G (^TMP($J,R TN,BATCH,C LAIM,TXD,T YPE,IEN,0) ) I DATA=" " G SMPRTX S TXDTM=$ $FMTE^XLFD T($P(DATA, U,1),"5Z") S SEVERIT Y=$$EXTERN AL^DILFD(3 61.42,.02, ,$P(DATA,U ,2)) ; msg severity ; I $Y+2>M AXCNT!'PAG ECNT D HEA DER I STOP G SMPRTX W !,"Statu s Message Informatio n" W !?1,T XDTM,?22,S EVERITY,?6 5,"Msg#",$ P(DATA,U,3 ) S Z=0 F S Z=$O(^T MP($J,RTN, BATCH,CLAI M,TXD,TYPE ,IEN,1,Z)) Q:'Z D Q:STOP . I $Y+1>MAXC NT!'PAGECN T D HEADER Q:STOP . W !?2,$G(^ TMP($J,RTN ,BATCH,CLA IM,TXD,TYP E,IEN,1,Z, 0)) . Q W !SMPRTX ; Q ;HEADER ; page bre ak and hea der NEW LI N,HDR,TAB S STOP=0 I CRT,PAGEC NT>0,'$D(Z TQUEUED) D I STOP G HEADX . I MAXCNT<51 F LIN=1:1 :(MAXCNT-$ Y) W ! . S DIR(0)="E " D ^DIR K DIR . I ' Y S STOP=1 Q . Q ; S PAGECNT=P AGECNT+1 W @IOF,! ; W "Test Cl aim EDI Tr ansmission Report" S HDR="Page : "_PAGECN T,TAB=80-$ L(HDR)-1 W ?TAB,HDR W !,"Selec ted ",$S(I BRMETH="B" :"Batches" ,IBRMETH=" C":"Claims ",1:"Date Range") S HDR=$$FMTE ^XLFDT($$N OW^XLFDT," 1Z"),TAB=8 0-$L(HDR)- 1 W ?TAB,H DR W !,$$R J^XLFSTR(" ",80,"=") ; ; check for a stop request I $D(ZTQUEU ED),$$S^%Z TLOAD() D G HEADX . S (ZTSTOP ,STOP)=1 . W !!!?5," *** Report Halted by TaskManag er Request ***" . Q ;HEADX ; Q ;BT(IBIFN ) ; bill t ype and in fo ; [1] T YPE (form type, char ge type, i np/outp) ; [2] claim # ; [3] pa tient name NEW TYPE, IB0,F,C,S S TYPE="" S IB0=$G(^ DGCR(399,+ $G(IBIFN), 0)) I IB0= "" Q "" ;S F=$P(IB0, U,19),F=$S (F=2:"1500 ",1:"UB04" )) ;JRA IB *2.0*592 ' ;' S F=$P( IB0,U,19), F=$S(F=2:" 1500",F=7: "J430D",1: "UB04") ;J RA IB*2.0* 592 Add De ntal Form 'J430D' S C=$P(IB0,U ,27),C=$S( C=1:"Inst" ,1:"Prof") S S=$$INP AT^IBCEF(I BIFN),S=$S (S=1:"Inpa t",1:"Outp at") S TYP E=F_", "_C _", "_S Q TYPE_U_$P( IB0,U,1)_U _$P($G(^DP T(+$P(IB0, U,2),0)),U ,1) ;CLMLS T(IBIFN) ; DIC liste r NEW TYPE ,LTD,N1,N2 S TYPE=$P ($$BT(IBIF N),U,1) S LTD=$$FMTE ^XLFDT($P( $G(^IBM(36 1.4,IBIFN, 0)),U,2)," 2Z") S N1= +$P($G(^IB M(361.4,IB IFN,1,0)), U,4) ; # t ransmissio ns S N2=+$ P($G(^IBM( 361.4,IBIF N,2,0)),U, 4) ; # ret urn messag es W " ",T YPE,?34," ",LTD,?45, " ",N1," T ransmissio n",$S(N1'= 1:"s",1:"" ) W ?63," ",N2," Mes sage",$S(N 2'=1:"s",1 :"")CLMLST X ; Q ; | |
| 2585 | ||
| 2586 | ||
| 2587 | Routines | |
| 2588 | Activities | |
| 2589 | Routine Na me | |
| 2590 | IBCEQ1 | |
| 2591 | Enhancemen t Category | |
| 2592 | New | |
| 2593 | Modify | |
| 2594 | Delete | |
| 2595 | No Change | |
| 2596 | RTM | |
| 2597 | ||
| 2598 | Related Op tions | |
| 2599 | None | |
| 2600 | Related Ro utines | |
| 2601 | Routines “ Called By” | |
| 2602 | Routines “ Called” | |
| 2603 | ||
| 2604 | ||
| 2605 | ||
| 2606 | ||
| 2607 | Data Dicti onary (DD) Reference s | |
| 2608 | ||
| 2609 | Related Pr otocols | |
| 2610 | None | |
| 2611 | Related In tegration Control Re gistration s (ICRs) | |
| 2612 | None | |
| 2613 | Data Passi ng | |
| 2614 | Input | |
| 2615 | Output Re ference | |
| 2616 | Both | |
| 2617 | Global Re ference | |
| 2618 | Local | |
| 2619 | Input Attr ibute Name and Defin ition | |
| 2620 | Name: | |
| 2621 | Definition : | |
| 2622 | Output Att ribute Nam e and Defi nition | |
| 2623 | Name: | |
| 2624 | Definition : | |
| 2625 | Current Lo gic | |
| 2626 | IBCEQ1 ;BS L,ALB/TMK - PROVIDER ID QUERY ;25-AUG-03 ;;2.0;INT EGRATED BI LLING;**23 2,356,349* *;21-MAR-9 4;Build 46 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ; ;QUERY TOO L HELPS ID ENTIFY PLA NS THAT AR E LACKING PROVIDER I D ;INFO OR HAVE BAD PROVIDER I D DATA FOR E-BILLING ; ;CONDIT IONS TO ID ENTIFY: ;1 -BLUE CROS S LINKED T O 1500 ONL Y (1) HARD ERROR ;2- BLUE SHIEL D LINKED T O UB-04 ON LY (2) WAR NING ;3-BL UE CROSS I D APPLIED TO BOTH FO RMS (0) WA RNING ;4-B LUE CROSS OR BLUE SH IELD IDs E XIST FOR A N INS CO, BUT ONE OR ; MORE OF THE INSUR ANCE COMPA NY'S PLANS DOES NOT HAVE AN ; ELECTRONIC PLAN TYPE OF 'BL' ; 5-NON BLUE CROSS/SHI ELD ID FOR AN INS CO MPANY WITH BLUE PLAN (S) ;6-VAD 000 as an ID but not flagged a s a UPIN ; EN ; N POP ,%ZIS,ZTSK ,ZTRTN,ZTD ESC,IBREBL D,IBSENDM, IBTO,DIR,X ,Y,DUOUT,D TOUT,Z S I BREBLD=$S( '$D(^XTMP( "IB_PLAN23 2")):1,1:0 ) I $D(^XT MP("IB_PLA N232")) D . S DIR("? ")="IF YOU ANSWER NO , REPORT W ILL BE RUN FROM THE EXISTING Q UERY DATA" ,DIR("?",1 )="IF YOU ANSWER YES , A NEW QU ERY WILL B E RUN" . S DIR(0)="Y A",DIR("A" ,1)="THE E XTRACT GLO BAL FOR TH IS QUERY A LREADY EXI STS",DIR(" A")="DO YO U WANT TO DELETE IT AND RERUN THE QUERY? : ",DIR("B ")="NO" W ! D ^DIR K DIR . Q:$ D(DUOUT)!$ D(DTOUT)!' Y . S IBRE BLD=1 ; N XMINSTR,Z, ZTSAVE K ^ TMP("XMY", $J),^TMP(" XMY0",$J) S XMINSTR( "ADDR FLAG S")="R" D TOWHOM^XMX APIU(DUZ," ","S",.XMI NSTR) S Z= "" F S Z= $O(^TMP("X MY",$J,Z)) Q:Z="" S IBTO(Z)=" " K ^TMP(" XMY",$J),^ TMP("XMY0" ,$J) ; S % ZIS="QM" D ^%ZIS G:P OP EN1Q I $D(IO("Q") ) D G EN1 Q . S ZTRT N="ENT^IBC EQ1("_IBRE BLD_",.IBT O)",ZTDESC ="IB - HIP AA ENHANCE MENTS PROV ID QUERY" ,ZTSAVE("I BTO(")="" . D ^%ZTLO AD . W !!, $S($D(ZTSK ):"Task # "_ZTSK_" h as been qu eued.",1:" Unable to queue this job.") . K ZTSK,IO( "Q") D HOM E^%ZIS U I O D ENT(IB REBLD,.IBT O)EN1Q Q ; ENT(IBREBL D,IBTO) ; Queued job enter her e ; N LOOP ,Z K ^TMP( $J,"SENDMS G") S ^TMP ($J,"SENDM SG")=$S(IB REBLD:1,1: 0) S Z="" F S Z=$O( IBTO(Z)) Q :Z="" S ^ TMP($J,"SE NDMSG",0,Z )="" I $G( IBREBLD) D . ; Rebld query . K ^XTMP("IB _PLAN232") . S ^XTMP ("IB_PLAN2 32")="",^X TMP("IB_PL AN232",0)= $$FMADD^XL FDT(DT,45) _U_DT_"^IB PATCH 232 PROV ID Q UERY" . ; . ; loop t hru 355.91 (IB INSUR ANCE CO LE VEL BILLIN G PROV ID) . ; then 355.9 (IB BILLING PR ACTITIONER ID) . F L OOP=355.91 ,355.9 D L P . ; ; D RPTOUT^IBC EQ1A K ^TM P($J,"SEND MSG") Q ;L P ; Loop t hrough ids N IB,PTYP ,PAYER,PLA NIEN,FTA,I EPLAN,IPRO V,PPROV,ED II,EDIP,PA YERP,TYPCO V,IBPMBPID ,PTYPNM,IB I3,IBI0,SE Q,BLUE,TOT ,NBLUE,DIR ,DTOUT,DUO UT,X,Z,Z0, Z1,BL,UPIN ,BCR,BSH S (SEQ,X,TO T,NBLUE,BL UE)=0,(BCR ,BSH,UPIN) ="" S Z="" F S Z=$O (^IBE(355. 97,Z)) Q:' Z S Z0=$G (^(Z,0)) D . I $P(Z, U)["BLUE C ROSS" S BC R=Z Q . I $P(Z,U)["B LUE SHIELD " S BSH=Z Q . I $P(Z ,U)["UPIN" S UPIN=Z Q S:UPIN=" " UPIN=22 S:BCR="" B CR=1 S:BSH ="" BSH=2 F S X=$O( ^IBA(LOOP, X)) Q:+X=0 D . S (PA YER,FTA,PL ANIEN,IEPL AN,IPROV,P PROV,EDII, EDIP,PAYER P,TYPCOV,I BPMBPID,PT YPNM)="" . S SEQ=SEQ +1 . S IB= $G(^IBA(LO OP,X,0)) . S PTYP=$P (IB,U,6) ; prov id t ype ien . Q:PTYP="" ; no prov type . S PTYPNM=$P( $G(^IBE(35 5.97,PTYP, 0)),U) ; p rov id typ e desc . S PAYERP=$S (LOOP[".91 ":+IB,1:+$ P(IB,U,2)) ;ins co i en . S IBI 0=$G(^DIC( 36,PAYERP, 0)),IBI3=$ G(^(3)),PA YER=$P(IBI 0,U) . Q:$ P(IBI0,U,5 )!(IBI0="" ) ; ins co inactive/ deleted . S EDIP=$P( IBI3,U,2) ; edi id# prof . S E DII=$P(IBI 3,U,4) ; e di id# ins t . S IEPL AN=$P(IBI3 ,U,9) ; el ec ins typ e ?1N . S PPROV=$P(I BI0,U,17) ; prof. pr ov# . S IP ROV=$P(IBI 0,U,11) ; hosp. prov # . S TYPC OV=$P(IBI0 ,U,13) ; t ype of cov ien;file 355.2 . S FTA=$P(IB, U,4) ; for m type app lied; 0:bo th, 1:ub, 2:1500 . S IBPMBPID= X_";"_LOOP . I $P(IB ,U,7)="VAD 000",PTYP' =UPIN D SE T(6) . ; . I PTYP'=B CR&(PTYP'= BSH) D Q ; not B C/BS .. ; Only do fo llowing ch eck once p er insuran ce co .. Q :$D(^XTMP( "IB_PLAN23 2",3,PAYER P)) .. S ^ XTMP("IB_P LAN232",3, PAYERP)="" .. ; Chec k if BC/BS ids exist at all fo r ins co . . Q:$O(^IB A(355.9,"A C",1,PAYER P,0))!$O(^ IBA(355.9, "AC",2,PAY ERP,0))!$O (^IBA(355. 91,"AC",PA YERP,1,0)) !$O(^IBA(3 55.91,"AC" ,PAYERP,2, 0)) .. S B L=0 .. S Z 1=0 F S Z 1=$O(^IBA( 355.3,"B", PAYERP,Z1) ) Q:'Z1 D ... I '$P ($G(^IBA(3 55.3,Z1,0) ),U,11),$P ($G(^(0)), U,15)="BL" S PLANIEN =Z1,BL=1 D SET(5) .. S:BL NBLU E=NBLUE+1 . ; . S BL UE=BLUE+1 . ; ERROR - FORM TYP E=2:1500 A ND PTYP=1: BC . I PTY P=1&(FTA=2 ) D SET(1) Q . ; . I PTYP=2&(F TA=1) D SE T(2) Q ; BS applied to just U B . I FTA= 0&(PTYP=1) D SET(3) Q ; BC ap plied to b oth forms . ; . ; On ly do foll owing chec k once per insurance co . I '$ D(^XTMP("I B_PLAN232" ,2,PAYERP) ) D ; Che cks plans not BL .. S Z1=0,^XT MP("IB_PLA N232",2,PA YERP)="" . . F S Z1= $O(^IBA(35 5.3,"B",PA YERP,Z1)) Q:'Z1 D . .. I $P($G (^IBA(355. 3,Z1,0)),U ,15)'="BL" ,'$P(^(0), U,11) S PL ANIEN=Z1 D SET(4) Q ; ; 3RD PC XTMP(IB_P LAN232)=TO TAL BLUES WITH NO BL UE IDS S $ P(^XTMP("I B_PLAN232" ),U,3)=$P( $G(^XTMP(" IB_PLAN232 ")),U,3)+N BLUE ; ; 4 TH PC XTMP (IB_PLAN23 2)=TOT NUM BER SCANNE D S $P(^XT MP("IB_PLA N232"),U,4 )=$P($G(^X TMP("IB_PL AN232")),U ,4)+SEQ ; ; 5TH PC X TMP(IB_PLA N232)=TOT BLUES IDS FOUND S $P (^XTMP("IB _PLAN232") ,U,5)=$P($ G(^XTMP("I B_PLAN232" )),U,5)+BL UE ; ; 6TH PC XTMP(I B_PLAN232) =TOTAL ERR ORS FOUND S $P(^XTMP ("IB_PLAN2 32"),U,6)= $P($G(^XTM P("IB_PLAN 232")),U,6 )+TOT Q ;S ET(Z) ;SET VALUES IN TO SAVE GL OBAL ; Z=R EASON WHY WE'RE SETT ING IT ; 1 . PAYER-in s co name (36) ; 2. PLAN-grp n ame (355.3 ) ; 3. GRO UP-grp # ( 355.3) ; 4 . FTA-form typ (355. 9) ; 5. EP LAN-"BL" ( 355.3) ; 6 . IEPLAN-e lec ins ty p (36) ; 7 . IPROV-ho sp prov# ( 36) ; 8. P PROV-prof prov# (36) ; 9. EDII -inst edi id# (36) ; 10. EDIP-p rof edi id # (36) ;11 . PAYERP-i ns co ien (36) ;12. TYPCOV-typ e of cov i en (36) ;1 3. PLANIEN -ien of fi le (355.3) ;14. IBPM BPID-355.9 or 355.91 ;ien of fi le ;15. PT YPNM-prov id type de sc (355.9) ;16. Z-re ason ; N A ,DUP ; S A =$O(^XTMP( "IB_PLAN23 2",1," "), -1)+1,TOT= TOT+1 S ^X TMP("IB_PL AN232",1,A ,0)=PAYER_ U_""_U_""_ U_FTA_U_"" _U_IEPLAN_ U_""_U_""_ U_""_U_""_ U_PAYERP_U _TYPCOV_U_ PLANIEN_U_ IBPMBPID_U _PTYPNM_U_ Z Q ; | |
| 2627 | Modified L ogic (Chan ges are in bold) | |
| 2628 | IBCEQ1 ;BS L,ALB/TMK - PROVIDER ID QUERY ;25-AUG-03 ;;2.0;INT EGRATED BI LLING;**23 2,356,349, 592**;21-M AR-94;Buil d 46 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . ; ;QUERY TOOL HELP S IDENTIFY PLANS THA T ARE LACK ING PROVID ER ID ;INF O OR HAVE BAD PROVID ER ID DATA FOR E-BIL LING ; ;CO NDITIONS T O IDENTIFY : ;1-BLUE CROSS LINK ED TO 1500 ONLY (1) HARD ERROR ;2-BLUE S HIELD LINK ED TO UB-0 4 ONLY (2) WARNING ; 3-BLUE CRO SS ID APPL IED TO BOT H FORMS (0 ) WARNING ;4-BLUE CR OSS OR BLU E SHIELD I Ds EXIST F OR AN INS CO, BUT ON E OR ; MOR E OF THE I NSURANCE C OMPANY'S P LANS DOES NOT HAVE A N ; ELECTR ONIC PLAN TYPE OF 'B L' ;5-NON BLUE CROSS /SHIELD ID FOR AN IN S COMPANY WITH BLUE PLAN(S) ;6 -VAD000 as an ID but not flagg ed as a UP IN ;EN ; N POP,%ZIS, ZTSK,ZTRTN ,ZTDESC,IB REBLD,IBSE NDM,IBTO,D IR,X,Y,DUO UT,DTOUT,Z S IBREBLD =$S('$D(^X TMP("IB_PL AN232")):1 ,1:0) I $D (^XTMP("IB _PLAN232") ) D . S DI R("?")="IF YOU ANSWE R NO, REPO RT WILL BE RUN FROM THE EXISTI NG QUERY D ATA",DIR(" ?",1)="IF YOU ANSWER YES, A NE W QUERY WI LL BE RUN" . S DIR(0 )="YA",DIR ("A",1)="T HE EXTRACT GLOBAL FO R THIS QUE RY ALREADY EXISTS",D IR("A")="D O YOU WANT TO DELETE IT AND RE RUN THE QU ERY?: ",DI R("B")="NO " W ! D ^D IR K DIR . Q:$D(DUOU T)!$D(DTOU T)!'Y . S IBREBLD=1 ; N XMINST R,Z,ZTSAVE K ^TMP("X MY",$J),^T MP("XMY0", $J) S XMIN STR("ADDR FLAGS")="R " D TOWHOM ^XMXAPIU(D UZ,"","S", .XMINSTR) S Z="" F S Z=$O(^TM P("XMY",$J ,Z)) Q:Z=" " S IBTO( Z)="" K ^T MP("XMY",$ J),^TMP("X MY0",$J) ; S %ZIS="Q M" D ^%ZIS G:POP EN1 Q I $D(IO( "Q")) D G EN1Q . S ZTRTN="ENT ^IBCEQ1("_ IBREBLD_", .IBTO)",ZT DESC="IB - HIPAA ENH ANCEMENTS PROV ID QU ERY",ZTSAV E("IBTO(") ="" . D ^% ZTLOAD . W !!,$S($D( ZTSK):"Tas k # "_ZTSK _" has bee n queued." ,1:"Unable to queue this job." ) . K ZTSK ,IO("Q") D HOME^%ZIS U IO D EN T(IBREBLD, .IBTO)EN1Q Q ;ENT(IB REBLD,IBTO ) ; Queued job enter here ; N LOOP,Z K ^ TMP($J,"SE NDMSG") S ^TMP($J,"S ENDMSG")=$ S(IBREBLD: 1,1:0) S Z ="" F S Z =$O(IBTO(Z )) Q:Z="" S ^TMP($J ,"SENDMSG" ,0,Z)="" I $G(IBREBL D) D . ; R ebld query . K ^XTMP ("IB_PLAN2 32") . S ^ XTMP("IB_P LAN232")=" ",^XTMP("I B_PLAN232" ,0)=$$FMAD D^XLFDT(DT ,45)_U_DT_ "^IB PATCH 232 PROV ID QUERY" . ; . ; lo op thru 35 5.91 (IB I NSURANCE C O LEVEL BI LLING PROV ID) . ; t hen 355.9 (IB BILLIN G PRACTITI ONER ID) . F LOOP=35 5.91,355.9 D LP . ; ; D RPTOUT ^IBCEQ1A K ^TMP($J," SENDMSG") Q ;LP ; Lo op through ids N IB, PTYP,PAYER ,PLANIEN,F TA,IEPLAN, IPROV,PPRO V,EDII,EDI P,PAYERP,T YPCOV,IBPM BPID,PTYPN M,IBI3,IBI 0,SEQ,BLUE ,TOT,NBLUE ,DIR,DTOUT ,DUOUT,X,Z ,Z0,Z1,BL, UPIN,BCR,B SH S (SEQ, X,TOT,NBLU E,BLUE)=0, (BCR,BSH,U PIN)="" S Z="" F S Z=$O(^IBE( 355.97,Z)) Q:'Z S Z 0=$G(^(Z,0 )) D . I $ P(Z,U)["BL UE CROSS" S BCR=Z Q . I $P(Z,U )["BLUE SH IELD" S BS H=Z Q . I $P(Z,U)["U PIN" S UPI N=Z Q S:UP IN="" UPIN =22 S:BCR= "" BCR=1 S :BSH="" BS H=2 F S X =$O(^IBA(L OOP,X)) Q: +X=0 D . S (PAYER,FT A,PLANIEN, IEPLAN,IPR OV,PPROV,E DII,EDIP,P AYERP,TYPC OV,IBPMBPI D,PTYPNM)= "" . S SEQ =SEQ+1 . S IB=$G(^IB A(LOOP,X,0 )) . S PTY P=$P(IB,U, 6) ; prov id type ie n . Q:PTYP ="" ; no prov type . S PTYPNM =$P($G(^IB E(355.97,P TYP,0)),U) ; prov id type desc . S PAYER P=$S(LOOP[ ".91":+IB, 1:+$P(IB,U ,2)) ;ins co ien . S IBI0=$G(^ DIC(36,PAY ERP,0)),IB I3=$G(^(3) ),PAYER=$P (IBI0,U) . Q:$P(IBI0 ,U,5)!(IBI 0="") ; in s co inact ive/delete d . S EDIP =$P(IBI3,U ,2) ; edi id# prof . S EDII=$P (IBI3,U,4) ; edi id# inst . S IEPLAN=$P( IBI3,U,9) ; elec ins type ?1N . S PPROV= $P(IBI0,U, 17) ; prof . prov# . S IPROV=$P (IBI0,U,11 ) ; hosp. prov# . S TYPCOV=$P( IBI0,U,13) ; type of cov ien;f ile 355.2 . ; JWS;IB *2.0*592: Dental for m type J43 0D . S FTA =$P(IB,U,4 ) ; form t ype applie d; 0:both, 1:ub, 2:1 500&J430D . S IBPMBP ID=X_";"_L OOP . I $P (IB,U,7)=" VAD000",PT YP'=UPIN D SET(6) . I PTYP'=BC R&(PTYP'=B SH) D Q ; not BC /BS .. ; O nly do fol lowing che ck once pe r insuranc e co .. Q: $D(^XTMP(" IB_PLAN232 ",3,PAYERP )) .. S ^X TMP("IB_PL AN232",3,P AYERP)="" .. ; Check if BC/BS ids exist at all for ins co .. Q:$O(^IBA (355.9,"AC ",1,PAYERP ,0))!$O(^I BA(355.9," AC",2,PAYE RP,0))!$O( ^IBA(355.9 1,"AC",PAY ERP,1,0))! $O(^IBA(35 5.91,"AC", PAYERP,2,0 )) .. S BL =0 .. S Z1 =0 F S Z1 =$O(^IBA(3 55.3,"B",P AYERP,Z1)) Q:'Z1 D ... I '$P( $G(^IBA(35 5.3,Z1,0)) ,U,11),$P( $G(^(0)),U ,15)="BL" S PLANIEN= Z1,BL=1 D SET(5) .. S:BL NBLUE =NBLUE+1 . ; . S BLU E=BLUE+1 . ; JWS;IB* 2.0*592: D ental form type J430 D . ; ERRO R - FORM T YPE=2:1500 &J430D AND PTYP=1:BC . I PTYP= 1&(FTA=2) D SET(1) Q . I PTYP= 2&(FTA=1) D SET(2) Q ; BS app lied to ju st UB . I FTA=0&(PTY P=1) D SET (3) Q ; B C applied to both fo rms . ; . ; Only do following check once per insur ance co . I '$D(^XTM P("IB_PLAN 232",2,PAY ERP)) D ; Checks pl ans not BL .. S Z1=0 ,^XTMP("IB _PLAN232", 2,PAYERP)= "" .. F S Z1=$O(^IB A(355.3,"B ",PAYERP,Z 1)) Q:'Z1 D ... I $ P($G(^IBA( 355.3,Z1,0 )),U,15)'= "BL",'$P(^ (0),U,11) S PLANIEN= Z1 D SET(4 ) Q ; ; 3R D PC XTMP( IB_PLAN232 )=TOTAL BL UES WITH N O BLUE IDS S $P(^XTM P("IB_PLAN 232"),U,3) =$P($G(^XT MP("IB_PLA N232")),U, 3)+NBLUE ; ; 4TH PC XTMP(IB_PL AN232)=TOT NUMBER SC ANNED S $P (^XTMP("IB _PLAN232") ,U,4)=$P($ G(^XTMP("I B_PLAN232" )),U,4)+SE Q ; ; 5TH PC XTMP(IB _PLAN232)= TOT BLUES IDS FOUND S $P(^XTMP ("IB_PLAN2 32"),U,5)= $P($G(^XTM P("IB_PLAN 232")),U,5 )+BLUE ; ; 6TH PC XT MP(IB_PLAN 232)=TOTAL ERRORS FO UND S $P(^ XTMP("IB_P LAN232"),U ,6)=$P($G( ^XTMP("IB_ PLAN232")) ,U,6)+TOT Q ;SET(Z) ;SET VALUE S INTO SAV E GLOBAL ; Z=REASON WHY WE'RE SETTING IT ; 1. PAYE R-ins co n ame (36) ; 2. PLAN-g rp name (3 55.3) ; 3. GROUP-grp # (355.3) ; 4. FTA- form typ ( 355.9) ; 5 . EPLAN-"B L" (355.3) ; 6. IEPL AN-elec in s typ (36) ; 7. IPRO V-hosp pro v# (36) ; 8. PPROV-p rof prov# (36) ; 9. EDII-inst edi id# (3 6) ;10. ED IP-prof ed i id# (36) ;11. PAYE RP-ins co ien (36) ; 12. TYPCOV -type of c ov ien (36 ) ;13. PLA NIEN-ien o f file (35 5.3) ;14. IBPMBPID-3 55.9 or 35 5.91;ien o f file ;15 . PTYPNM-p rov id typ e desc (35 5.9) ;16. Z-reason ; N A,DUP ; S A=$O(^X TMP("IB_PL AN232",1," "),-1)+1, TOT=TOT+1 S ^XTMP("I B_PLAN232" ,1,A,0)=PA YER_U_""_U _""_U_FTA_ U_""_U_IEP LAN_U_""_U _""_U_""_U _""_U_PAYE RP_U_TYPCO V_U_PLANIE N_U_IBPMBP ID_U_PTYPN M_U_Z Q ; | |
| 2629 | ||
| 2630 | ||
| 2631 | Routines | |
| 2632 | Activities | |
| 2633 | Routine Na me | |
| 2634 | IBCEQ1A | |
| 2635 | Enhancemen t Category | |
| 2636 | New | |
| 2637 | Modify | |
| 2638 | Delete | |
| 2639 | No Change | |
| 2640 | RTM | |
| 2641 | ||
| 2642 | Related Op tions | |
| 2643 | None | |
| 2644 | Related Ro utines | |
| 2645 | Routines “ Called By” | |
| 2646 | Routines “ Called” | |
| 2647 | ||
| 2648 | ||
| 2649 | ||
| 2650 | ||
| 2651 | Data Dicti onary (DD) Reference s | |
| 2652 | ||
| 2653 | Related Pr otocols | |
| 2654 | None | |
| 2655 | Related In tegration Control Re gistration s (ICRs) | |
| 2656 | None | |
| 2657 | Data Passi ng | |
| 2658 | Input | |
| 2659 | Output Re ference | |
| 2660 | Both | |
| 2661 | Global Re ference | |
| 2662 | Local | |
| 2663 | Input Attr ibute Name and Defin ition | |
| 2664 | Name: | |
| 2665 | Definition : | |
| 2666 | Output Att ribute Nam e and Defi nition | |
| 2667 | Name: | |
| 2668 | Definition : | |
| 2669 | Current Lo gic | |
| 2670 | IBCEQ1A ;A LB/BSL,TMK - PROVIDE R ID QUERY REPORT ;2 5-AUG-03 ; ;2.0;INTEG RATED BILL ING;**232, 348,349,51 6**;21-MAR -94;Build 123 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ;RPT OUT ; Prin t from dat a in ^XTMP N IBP,IBA ,IBI,IBIN, IBPNM,IBPN UM,IBSTOP, IBX,IBZ,IB PG,IBICONT ,Z K ^TMP( $J,"IBZ232 ") F Z=1:1 :6 S ^TMP( $J,"IBZ232 ",Z)="" S (IBPG,IBST OP)=0 S IB A=0 F S I BA=$O(^XTM P("IB_PLAN 232",1,IBA )) Q:'IBA D . S IBX =$G(^XTMP( "IB_PLAN23 2",1,IBA,0 )) . ; Sor t by err t ype, ins c o ien . S ^TMP($J,"I BZ232",+$P (IBX,U,16) ,+$P(IBX,U ,11),IBA)= IBX ; S IB Z=0 F S I BZ=$O(^TMP ($J,"IBZ23 2",IBZ)) Q :'IBZ!IBST OP!(IBZ>6) D HDR1(.I BPG,.IBSTO P,IBZ,0) S IBI=0 F S IBI=$O(^ TMP($J,"IB Z232",IBZ, IBI)) Q:'I BI!IBSTOP D . S IBI N=$P($G(^D IC(36,+IBI ,0)),U)_" ("_$S(+$G( ^(3))=1:"" ,1:"NOT ") _"SET TO T RANSMIT LI VE)" . D I NSHDR(.IBP G,.IBSTOP, IBIN,IBZ,0 ) S IBICON T=0 . S IB A=0 F S I BA=$O(^TMP ($J,"IBZ23 2",IBZ,IBI ,IBA)) Q:' IBA!IBSTOP S IBX=$G (^(IBA)) D .. I ($Y+ 5)>IOSL D INSHDR(.IB PG,.IBSTOP ,IBIN,IBZ, IBICONT) Q :IBSTOP .. ; .. I IB Z'=4,IBZ'= 5 D ... S IBP=+$P(IB X,U,14) .. . I $P(IBX ,U,14)[".9 1" S IBPNM ="ALL PROV IDERS" ... I $P(IBX, U,14)'[".9 1" D .... N Z .... S Z=$P($G(^ IBA(355.9, IBP,0)),U) .... S IB PNM=$S(Z[" VA(200":"" ,1:"#")_$$ EXTERNAL^D ILFD(355.9 ,.01,"",Z) ... S IBP NUM=$P($G( ^IBA(+$P($ P(IBX,U,14 ),";",2),I BP,0)),U,7 ) ... D WR T(1," "_$E ($P("BOTH^ UB-04^CMS- 1500",U,$P (IBX,U,4)+ 1)_$J("",9 ),1,9)_" " _$E($P(IBX ,U,15)_$J( "",23),1,2 3)_" "_$E( IBPNM_$J(" ",28),1,28 )_" "_$E(I BPNUM,1,11 )) .. ; .. I IBZ=4!( IBZ=5) D . .. ;IB*516 /TAZ - Cha nge Group Name from piece 3 to field 2.0 1, and gro up Number from piece 4 to fiel d 2.02 ... ;N Z ... N GNUM,GNA M,EPTYP .. . ;S Z=$G( ^IBA(355.3 ,+$P(IBX,U ,13),0)) . .. ;D WRT( 1," "_$E($ P(Z,U,3)_$ J("",20),1 ,20)_" "_$ E($P(Z,U,4 )_$J("",17 ),1,17)_" "_$$EXTERN AL^DILFD(3 55.3,.15," ",$P(Z,U,1 5))) ... S GNUM=$$GE T1^DIQ(355 .3,+$P(IBX ,U,13)_"," ,2.02) ;Gr oup Number ... S GNA M=$$GET1^D IQ(355.3,+ $P(IBX,U,1 3)_",",2.0 1) ;Group Name ... S EPTYP=$$G ET1^DIQ(35 5.3,+$P(IB X,U,13)_", ",.15) ;El ectronic P lan Type . .. D WRT(1 ," "_$E(GN UM_$J("",2 0),1,20)_" "_$E(GNAM _$J("",17) ,1,17)_" " _EPTYP) .. S:'IBICON T IBICONT= 1 ; I 'IBS TOP D ;To tals . N Z . S Z=$G( ^XTMP("IB_ PLAN232")) . I ($Y+1 0)>IOSL!'I BPG D HDR( .IBPG,.IBS TOP,"") Q: IBSTOP . D WRT(2,$J( "",25)_"TO TAL # OF I Ds CHECKED : "_+$P(Z, U,4)) . D WRT(1,$J(" ",14)_"TOT # BLUE CR OSS/SHIELD IDS FOUND : "_+$P(Z, U,5)) . D WRT(1,"TOT AL # OF IN S CO. W/BL UE PLANS A ND NO BLUE IDS: "_+$ P(Z,U,3)) . D WRT(1, $J("",21)_ "TOTAL # O F ERRORS/W ARNINGS: " _+$P(Z,U,6 )) ; I '$D (ZTQUEUED) D ^%ZISC I 'IBSTOP, IBPG D ASK () I $D(ZT QUEUED),'I BSTOP S ZT REQ="@" I $G(^TMP($J ,"SENDMSG" )),'IBSTOP D . N XMD UZ,XMSUBJ, XMBODY,XMT O,XMZ . S XMDUZ=DUZ, XMSUBJ=$E( "PROVIDER ID QUERY F ROM "_$P($ G(^DIC(4,+ $P($G(^IBE (350.9,1,0 )),U,2),0) ),U),1,65) ,XMBODY="^ TMP($J,""S ENDMSG"",1 )" . M XMT O=^TMP($J, "SENDMSG", 0) . S Z=" " F S Z=$ O(^TMP($J, "SENDMSG", 0,Z)) Q:Z= "" S XMZ( Z)="" . D SENDMSG^XM XAPI(XMDUZ ,XMSUBJ,XM BODY,.XMTO ,"",.XMZ) K ^TMP($J, "IBZ232"), ^TMP($J,"S ENDMSG") Q ;HDR(IBPG ,IBSTOP,IB Z,FF) ; Ma in hdr ; F F = 0 if c ontinuatio n pg so it writes it to report , but not mail msg N Z,IBT Q:$ G(IBSTOP) I $D(ZTQUE UED),$$S^% ZTLOAD S ( IBSTOP,ZTS TOP)=1 K Z TREQ I +$G (IBPG) D W RT(2,"***T ASK STOPPE D BY USER* **") Q I I BPG&($E(IO ST,1,2)="C -") D ASK( .IBSTOP) Q :IBSTOP S IBT=$S(IBP G:1,1:0) S IBPG=IBPG +1 S Z="PR OVIDER ID VERIFICATI ON QUERY R EPORT" S Z =$$SETSTR^ VALM1($J(" ",80-$L(Z) \2)_Z,"",1 ,79) S Z=$ $SETSTR^VA LM1("Page: "_IBPG,Z, 70,10) D W RT(0,"@IOF ",$G(FF)) D WRT(1,Z, $G(FF)) S Z="RUN DAT E: "_$$FMT E^XLFDT(DT ,2),Z=$J(" ",80-$L(Z) \2)_Z D WR T(1,Z,$G(F F)) I IBZ' ="",IBZ'=4 ,IBZ'=5 D . D WRT(2, " FORM TYP E PROV ID TYPE"_$J(" ",12)_"PRO VIDER NAME (#=Non-VA )"_$J("",6 )_"PROV ID ",$G(FF)) I IBZ=4!(I BZ=5) D . D WRT(2," GROUP NAME "_$J("",12 )_"GROUP N UMBER"_$J( "",7)_"ELE CTRONIC PL AN TYPE",$ G(FF)) D W RT(1,$TR($ J("",IOM-1 )," ","-") ,$G(FF)) Q ;HDR1(IBP G,IBSTOP,I BZ,IBCONT) ; Hdr err typ N Z,Z 0,Z1 D HDR (.IBPG,.IB STOP,IBZ,I BCONT) Q:I BSTOP S Z= "",$P(Z,"* ",80)="" D WRT(1,Z,I BCONT) S Z 0="* "_$S( IBZ>1:"WAR NING: ",1: "ERROR: ") ; I IBZ'= 4,IBZ'=5 D . N X . S X="BLUE C ROSS ID FO UND FOR A 1500 FORM TYPE ONLY^ BLUE SHIEL D ID FOUND FOR A UB- 04 FORM TY PE ONLY^BL UE CROSS I D FOUND FO R BOTH FOR M TYPES^BL CROSS/BL SHIELD IDs FOUND FOR PLANS NOT HAVING 'B L' ELECTRO NIC PLAN T YPE" . S Z 0=Z0_$S(IB Z<6:$P(X,U ,IBZ),IBZ= 6:"""VAD00 0"" PROVID ER ID FOUN D NOT SET UP AS A UP IN PROVIDE R ID TYPE" ,1:"") I I BZ=4 D . S Z0=Z0_"BL CROSS/BL SHIELD IDs FOUND FOR PLANS NOT HAVING 'B L' ELECTRO NIC" D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) . S Z 0="*"_$J(" ",10)_"PLA N TYPE" ; I IBZ=5 D . S Z0=Z0_ "INSURANCE CO HAS BL CROSS/SHI ELD PLANS, BUT NO BL CROSS/SHI ELD IDs" ; S Z0=Z0_$ S(IBCONT:" (CONT)",1 :"") D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) ; I ' IBCONT D . I IBZ=1 D .. D WRT( 1,"*"_$J(" ",77)_"*", IBCONT) .. S Z0="* S OLUTION: T HIS ID WIL L NEVER BE USED ELEC TRONICALLY ." D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) .. S Z0 ="*"_$J("" ,11)_"CHAN GE PROVIDE R ID TYPE TO BLUE SH IELD IF TH IS ID SHOU LD BE" D W RT(1,Z0_$J ("",78-$L( Z0))_"*",I BCONT) .. S Z0="*"_$ J("",11)_" TRANSMITTE D ON A 150 0." D WRT( 1,Z0_$J("" ,78-$L(Z0) )_"*",IBCO NT) . ; . I IBZ=2 D .. D WRT(1 ,"*"_$J("" ,77)_"*",I BCONT) .. S Z0="* SU GGESTION: VISTA WILL TRANSMIT THIS ID EL ECTRONICAL LY, BUT IT IS OPTIMA L" D WRT( 1,Z0_$J("" ,78-$L(Z0) )_"*",IBCO NT) .. S Z 0="*"_$J(" ",13)_"TO HAVE THIS ID SET UP AS BLUE CR OSS." D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) . ; . I IBZ=3 D .. D WRT (1,"*"_$J( "",77)_"*" ,IBCONT) . . S Z0="* SUGGESTION : A BLUE C ROSS ID CA N ONLY BE APPLIED TO A UB-04 F ORM TYPE." D WRT(1,Z 0_$J("",78 -$L(Z0))_" *",IBCONT) .. S Z0=" *"_$J("",1 3)_"EDIT T HE 'APPLIE D TO FORM TYPE' FOR THE ID TO BE UB-04 O NLY." D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) .. S Z0="*"_$J ("",13)_"I F YOU NEED THIS ID O N A 1500, SET IT UP AS A BLUE SHIELD ID" D WRT(1,Z 0_$J("",78 -$L(Z0))_" *",IBCONT) .. S Z0=" *"_$J("",1 3)_"APPLIE D TO A CMS -1500 FORM TYPE." D WRT(1,Z0_$ J("",78-$L (Z0))_"*", IBCONT) . ; . I IBZ= 4 D .. D W RT(1,"*"_$ J("",77)_" *",IBCONT) .. S Z0=" * SUGGESTI ON: A BLUE CROSS OR BLUE SHIEL D ID IS DE FINED FOR THE INSURA NCE" D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) .. S Z0="*"_$J( "",13)_"CO MPANY, BUT THE ELECT RONIC PLAN TYPE FOR ONE OR MOR E OF THE" D WRT(1,Z0 _$J("",78- $L(Z0))_"* ",IBCONT) .. S Z0="* "_$J("",13 )_"COMPANY 'S PLANS I S NOT SET TO 'BL' (B LUE CROSS/ BLUE SHIEL D)." D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) .. S Z0="*"_$J( "",13)_"IF BLUE CROS S/BLUE SHI ELD IDs AR E NEEDED T O PRINT FO R ANY" D W RT(1,Z0_$J ("",78-$L( Z0))_"*",I BCONT) .. S Z0="*"_$ J("",13)_" OF THESE P LANS, ITS ELECTRONIC PLAN TYPE MUST BE C HANGED TO BL." D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) . ; . I IBZ=5 D .. D WRT( 1,"*"_$J(" ",77)_"*", IBCONT) .. S Z0="* S UGGESTION: A BLUE CR OSS OR BLU E SHIELD P LAN IS DEF INED FOR T HE INSURAN CE" D WRT( 1,Z0_$J("" ,78-$L(Z0) )_"*",IBCO NT) .. S Z 0="*"_$J(" ",13)_"COM PANY, BUT YOU HAVE O NLY NON-BL UE CROSS/S HIELD IDS SET UP." D WRT(1,Z0_ $J("",78-$ L(Z0))_"*" ,IBCONT) . . S Z0="*" _$J("",13) _"YOU MUST SET UP TH E APPROPRI ATE BLUE C ROSS/BLUE SHIELD IDs " D WRT(1, Z0_$J("",7 8-$L(Z0))_ "*",IBCONT ) .. S Z0= "*"_$J("", 13)_"FOR T HE INSURAN CE COMPANY ." D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) . ; . I IBZ=6 D . . D WRT(1, "*"_$J("", 77)_"*",IB CONT) .. S Z0="* SUG GESTION: C HANGE PROV IDER ID TY PE TO UPIN ." .. D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) .. S Z0="*"_$J ("",13)_"O NCE ALL PA YERS FULLY IMPLEMENT HIPAA EDI TS, YOU" . . D WRT(1, Z0_$J("",7 8-$L(Z0))_ "*",IBCONT ) .. S Z0= "*"_$J("", 13)_"MUST USE THE CO RRECT ID T YPE FOR TH E ID ENTER ED." .. D WRT(1,Z0_$ J("",78-$L (Z0))_"*", IBCONT) . ; . D WRT( 1,"*"_$J(" ",77)_"*", IBCONT) . S Z1="*"_$ J("",$S(IB Z'=1:13,1: 11))_"VIST A OPTION T O USE: " . I IBZ'=4 D .. S Z0= Z1_"PROVID ER ID MAIN TENANCE" . I IBZ=4 D .. S Z0=Z 1_"INSURAN CE COMPANY ENTRY/EDI T" . D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) ; D W RT(1,Z,IBC ONT) ; I ' $O(^TMP($J ,"IBZ232", IBZ,0)) D WRT(2,"*** ** NOTHING FOUND FOR THIS ERRO R/WARNING *****",IBC ONT) Q ;IN SHDR(IBPG, IBSTOP,IBI NM,IBZ,IBI CONT) ; In s Co info I ($Y+7)>I OSL D HDR1 (.IBPG,.IB STOP,IBZ,1 ) Q:IBSTOP D WRT(2," INSURANCE CO NAME: " _IBINM_$S( $G(IBICONT ):" (Conti nued)",1:" "),IBICONT ) Q ;ASK(I BSTOP) ; A sk continu e ; If pas sed by ref , IBSTOP r eturned = 1 if print aborted I $E(IOST,1 ,2)'["C-" Q N DIR,DI ROUT,DIRUT ,DTOUT,DUO UT S DIR(0 )="E" W ! D ^DIR I ( $D(DIRUT)) !($D(DUOUT )) S IBSTO P=1 Q Q ;W RT(FF,TEXT ,NOT) ; Wr t/store li ne N Z,A S A=+$O(^TM P($J,"SEND MSG",1,"") ,-1),NOT=$ G(NOT) I F F F Z=1:1: FF W ! I $ G(^TMP($J, "SENDMSG") ),'NOT,Z>1 S A=A+1,^ TMP($J,"SE NDMSG",1,A )=" " ; I TEXT="@IOF " D Q . W @IOF . I $G(^TMP($J ,"SENDMSG" )),'NOT,IB PG>1 D .. S A=A+1,^T MP($J,"SEN DMSG",1,A) =" " .. F Z=1:1:2 S A=A+1,^TMP ($J,"SENDM SG",1,A)=" *** TOP OF NEW PAGE ***" .. S A=A+1,^TMP ($J,"SENDM SG",1,A)=" " ; W TEX T I $G(^TM P($J,"SEND MSG")),'NO T S A=A+1, ^TMP($J,"S ENDMSG",1, A)=TEXT Q ; | |
| 2671 | Modified L ogic (Chan ges are in bold) | |
| 2672 | IBCEQ1A ;A LB/BSL,TMK - PROVIDE R ID QUERY REPORT ;2 5-AUG-03 ; ;2.0;INTEG RATED BILL ING;**232, 348,349,51 6,592**;21 -MAR-94;Bu ild 123 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ;RPTOUT ; Print from data in ^ XTMP N IBP ,IBA,IBI,I BIN,IBPNM, IBPNUM,IBS TOP,IBX,IB Z,IBPG,IBI CONT,Z K ^ TMP($J,"IB Z232") F Z =1:1:6 S ^ TMP($J,"IB Z232",Z)=" " S (IBPG, IBSTOP)=0 S IBA=0 F S IBA=$O( ^XTMP("IB_ PLAN232",1 ,IBA)) Q:' IBA D . S IBX=$G(^X TMP("IB_PL AN232",1,I BA,0)) . ; Sort by e rr type, i ns co ien . S ^TMP($ J,"IBZ232" ,+$P(IBX,U ,16),+$P(I BX,U,11),I BA)=IBX ; S IBZ=0 F S IBZ=$O( ^TMP($J,"I BZ232",IBZ )) Q:'IBZ! IBSTOP!(IB Z>6) D HDR 1(.IBPG,.I BSTOP,IBZ, 0) S IBI=0 F S IBI= $O(^TMP($J ,"IBZ232", IBZ,IBI)) Q:'IBI!IBS TOP D . S IBIN=$P($ G(^DIC(36, +IBI,0)),U )_" ("_$S( +$G(^(3))= 1:"",1:"NO T ")_"SET TO TRANSMI T LIVE)" . D INSHDR( .IBPG,.IBS TOP,IBIN,I BZ,0) S IB ICONT=0 . S IBA=0 F S IBA=$O( ^TMP($J,"I BZ232",IBZ ,IBI,IBA)) Q:'IBA!IB STOP S IB X=$G(^(IBA )) D .. I ($Y+5)>IOS L D INSHDR (.IBPG,.IB STOP,IBIN, IBZ,IBICON T) Q:IBSTO P .. ; .. I IBZ'=4,I BZ'=5 D .. . S IBP=+$ P(IBX,U,14 ) ... I $P (IBX,U,14) [".91" S I BPNM="ALL PROVIDERS" ... I $P( IBX,U,14)' [".91" D . ... N Z .. .. S Z=$P( $G(^IBA(35 5.9,IBP,0) ),U) .... S IBPNM=$S (Z["VA(200 ":"",1:"#" )_$$EXTERN AL^DILFD(3 55.9,.01," ",Z) ... S IBPNUM=$P ($G(^IBA(+ $P($P(IBX, U,14),";", 2),IBP,0)) ,U,7) ... ; JWS;IB*2 .0*592: De ntal form type J430D , handle s ame as CMS -1500 ... D WRT(1," "_$E($P("A LL^UB-04^C MS-1500&J4 30D",U,$P( IBX,U,4)+1 )_$J("",9) ,1,9)_" "_ $E($P(IBX, U,15)_$J(" ",23),1,23 )_" "_$E(I BPNM_$J("" ,28),1,28) _" "_$E(IB PNUM,1,11) ) .. ; .. I IBZ=4!(I BZ=5) D .. . ;IB*516/ TAZ - Chan ge Group N ame from p iece 3 to field 2.01 , and grou p Number f rom piece 4 to field 2.02 ... ;N Z ... N GNUM,GNAM ,EPTYP ... ;S Z=$G(^ IBA(355.3, +$P(IBX,U, 13),0)) .. . ;D WRT(1 ," "_$E($P (Z,U,3)_$J ("",20),1, 20)_" "_$E ($P(Z,U,4) _$J("",17) ,1,17)_" " _$$EXTERNA L^DILFD(35 5.3,.15,"" ,$P(Z,U,15 ))) ... S GNUM=$$GET 1^DIQ(355. 3,+$P(IBX, U,13)_",", 2.02) ;Gro up Number ... S GNAM =$$GET1^DI Q(355.3,+$ P(IBX,U,13 )_",",2.01 ) ;Group N ame ... S EPTYP=$$GE T1^DIQ(355 .3,+$P(IBX ,U,13)_"," ,.15) ;Ele ctronic Pl an Type .. . D WRT(1, " "_$E(GNU M_$J("",20 ),1,20)_" "_$E(GNAM_ $J("",17), 1,17)_" "_ EPTYP) .. S:'IBICONT IBICONT=1 ; I 'IBST OP D ;Tot als . N Z . S Z=$G(^ XTMP("IB_P LAN232")) . I ($Y+10 )>IOSL!'IB PG D HDR(. IBPG,.IBST OP,"") Q:I BSTOP . D WRT(2,$J(" ",25)_"TOT AL # OF ID s CHECKED: "_+$P(Z,U ,4)) . D W RT(1,$J("" ,14)_"TOT # BLUE CRO SS/SHIELD IDS FOUND: "_+$P(Z,U ,5)) . D W RT(1,"TOTA L # OF INS CO. W/BLU E PLANS AN D NO BLUE IDS: "_+$P (Z,U,3)) . D WRT(1,$ J("",21)_" TOTAL # OF ERRORS/WA RNINGS: "_ +$P(Z,U,6) ) ; I '$D( ZTQUEUED) D ^%ZISC I 'IBSTOP,I BPG D ASK( ) I $D(ZTQ UEUED),'IB STOP S ZTR EQ="@" I $ G(^TMP($J, "SENDMSG") ),'IBSTOP D . N XMDU Z,XMSUBJ,X MBODY,XMTO ,XMZ . S X MDUZ=DUZ,X MSUBJ=$E(" PROVIDER I D QUERY FR OM "_$P($G (^DIC(4,+$ P($G(^IBE( 350.9,1,0) ),U,2),0)) ,U),1,65), XMBODY="^T MP($J,""SE NDMSG"",1) " . M XMTO =^TMP($J," SENDMSG",0 ) . S Z="" F S Z=$O (^TMP($J," SENDMSG",0 ,Z)) Q:Z=" " S XMZ(Z )="" . D S ENDMSG^XMX API(XMDUZ, XMSUBJ,XMB ODY,.XMTO, "",.XMZ) K ^TMP($J," IBZ232"),^ TMP($J,"SE NDMSG") Q ;HDR(IBPG, IBSTOP,IBZ ,FF) ; Mai n hdr ; FF = 0 if co ntinuation pg so it writes it to report, but not m ail msg N Z,IBT Q:$G (IBSTOP) I $D(ZTQUEU ED),$$S^%Z TLOAD S (I BSTOP,ZTST OP)=1 K ZT REQ I +$G( IBPG) D WR T(2,"***TA SK STOPPED BY USER** *") Q I IB PG&($E(IOS T,1,2)="C- ") D ASK(. IBSTOP) Q: IBSTOP S I BT=$S(IBPG :1,1:0) S IBPG=IBPG+ 1 S Z="PRO VIDER ID V ERIFICATIO N QUERY RE PORT" S Z= $$SETSTR^V ALM1($J("" ,80-$L(Z)\ 2)_Z,"",1, 79) S Z=$$ SETSTR^VAL M1("Page: "_IBPG,Z,7 0,10) D WR T(0,"@IOF" ,$G(FF)) D WRT(1,Z,$ G(FF)) S Z ="RUN DATE : "_$$FMTE ^XLFDT(DT, 2),Z=$J("" ,80-$L(Z)\ 2)_Z D WRT (1,Z,$G(FF )) I IBZ'= "",IBZ'=4, IBZ'=5 D . D WRT(2," FORM TYPE PROV ID T YPE"_$J("" ,12)_"PROV IDER NAME (#=Non-VA) "_$J("",6) _"PROV ID" ,$G(FF)) I IBZ=4!(IB Z=5) D . D WRT(2," G ROUP NAME" _$J("",12) _"GROUP NU MBER"_$J(" ",7)_"ELEC TRONIC PLA N TYPE",$G (FF)) D WR T(1,$TR($J ("",IOM-1) ," ","-"), $G(FF)) Q ;HDR1(IBPG ,IBSTOP,IB Z,IBCONT) ; Hdr err typ N Z,Z0 ,Z1 D HDR( .IBPG,.IBS TOP,IBZ,IB CONT) Q:IB STOP S Z=" ",$P(Z,"*" ,80)="" D WRT(1,Z,IB CONT) S Z0 ="* "_$S(I BZ>1:"WARN ING: ",1:" ERROR: ") ; I IBZ'=4 ,IBZ'=5 D . N X . ;J WS;IB*2.0* 592: Denta l form typ e J430D . S X="BLUE CROSS ID F OUND FOR A 1500&J430 D FORM TYP ES ONLY^BL UE SHIELD ID FOUND F OR A UB-04 FORM TYPE ONLY^BLUE CROSS ID FOUND FOR ALL FORM T YPES^BL CR OSS/BL SHI ELD IDs FO UND FOR PL ANS NOT HA VING 'BL' ELECTRONIC PLAN TYPE " . S Z0=Z 0_$S(IBZ<6 :$P(X,U,IB Z),IBZ=6:" ""VAD000"" PROVIDER ID FOUND N OT SET UP AS A UPIN PROVIDER I D TYPE",1: "") I IBZ= 4 D . S Z0 =Z0_"BL CR OSS/BL SHI ELD IDs FO UND FOR PL ANS NOT HA VING 'BL' ELECTRONIC " D WRT(1, Z0_$J("",7 8-$L(Z0))_ "*",IBCONT ) . S Z0=" *"_$J("",1 0)_"PLAN T YPE" ; I I BZ=5 D . S Z0=Z0_"IN SURANCE CO HAS BL CR OSS/SHIELD PLANS, BU T NO BL CR OSS/SHIELD IDs" ; S Z0=Z0_$S(I BCONT:" (C ONT)",1:"" ) D WRT(1, Z0_$J("",7 8-$L(Z0))_ "*",IBCONT ) ; I 'IBC ONT D . I IBZ=1 D .. D WRT(1," *"_$J("",7 7)_"*",IBC ONT) .. S Z0="* SOLU TION: THIS ID WILL N EVER BE US ED ELECTRO NICALLY." D WRT(1,Z0 _$J("",78- $L(Z0))_"* ",IBCONT) .. S Z0="* "_$J("",11 )_"CHANGE PROVIDER I D TYPE TO BLUE SHIEL D IF THIS ID SHOULD BE" D WRT( 1,Z0_$J("" ,78-$L(Z0) )_"*",IBCO NT) .. ;JW S;IB*2.0*5 92: Dental form type J430D .. S Z0="*"_$ J("",11)_" TRANSMITTE D ON A 150 0 or J430D ." D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) . ; . I IBZ=2 D . . D WRT(1, "*"_$J("", 77)_"*",IB CONT) .. S Z0="* SUG GESTION: V ISTA WILL TRANSMIT T HIS ID ELE CTRONICALL Y, BUT IT IS OPTIMAL " D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) .. S Z0 ="*"_$J("" ,13)_"TO H AVE THIS I D SET UP A S BLUE CRO SS." D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) . ; . I IBZ=3 D .. D WRT( 1,"*"_$J(" ",77)_"*", IBCONT) .. S Z0="* S UGGESTION: A BLUE CR OSS ID CAN ONLY BE A PPLIED TO A UB-04 FO RM TYPE." D WRT(1,Z0 _$J("",78- $L(Z0))_"* ",IBCONT) .. S Z0="* "_$J("",13 )_"EDIT TH E 'APPLIED TO FORM T YPE' FOR T HE ID TO B E UB-04 ON LY." D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) .. ;J WS;IB*2.0* 592: Denta l form typ e J430D .. S Z0="*"_ $J("",13)_ "IF YOU NE ED THIS ID ON A 1500 or J430D, SET IT UP AS A BLUE SHIELD ID " D WRT(1, Z0_$J("",7 8-$L(Z0))_ "*",IBCONT ) .. S Z0= "*"_$J("", 13)_"APPLI ED TO A CM S-1500 and J430D FOR M TYPE." D WRT(1,Z0_ $J("",78-$ L(Z0))_"*" ,IBCONT) . ; . I IBZ =4 D .. D WRT(1,"*"_ $J("",77)_ "*",IBCONT ) .. S Z0= "* SUGGEST ION: A BLU E CROSS OR BLUE SHIE LD ID IS D EFINED FOR THE INSUR ANCE" D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) .. S Z0="*"_$J ("",13)_"C OMPANY, BU T THE ELEC TRONIC PLA N TYPE FOR ONE OR MO RE OF THE" D WRT(1,Z 0_$J("",78 -$L(Z0))_" *",IBCONT) .. S Z0=" *"_$J("",1 3)_"COMPAN Y'S PLANS IS NOT SET TO 'BL' ( BLUE CROSS /BLUE SHIE LD)." D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) .. S Z0="*"_$J ("",13)_"I F BLUE CRO SS/BLUE SH IELD IDs A RE NEEDED TO PRINT F OR ANY" D WRT(1,Z0_$ J("",78-$L (Z0))_"*", IBCONT) .. S Z0="*"_ $J("",13)_ "OF THESE PLANS, ITS ELECTRONI C PLAN TYP E MUST BE CHANGED TO BL." D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) . ; . I IBZ=5 D .. D WRT (1,"*"_$J( "",77)_"*" ,IBCONT) . . S Z0="* SUGGESTION : A BLUE C ROSS OR BL UE SHIELD PLAN IS DE FINED FOR THE INSURA NCE" D WRT (1,Z0_$J(" ",78-$L(Z0 ))_"*",IBC ONT) .. S Z0="*"_$J( "",13)_"CO MPANY, BUT YOU HAVE ONLY NON-B LUE CROSS/ SHIELD IDS SET UP." D WRT(1,Z0 _$J("",78- $L(Z0))_"* ",IBCONT) .. S Z0="* "_$J("",13 )_"YOU MUS T SET UP T HE APPROPR IATE BLUE CROSS/BLUE SHIELD ID s" D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) .. S Z0 ="*"_$J("" ,13)_"FOR THE INSURA NCE COMPAN Y." D WRT( 1,Z0_$J("" ,78-$L(Z0) )_"*",IBCO NT) . ; . I IBZ=6 D .. D WRT(1 ,"*"_$J("" ,77)_"*",I BCONT) .. S Z0="* SU GGESTION: CHANGE PRO VIDER ID T YPE TO UPI N." .. D W RT(1,Z0_$J ("",78-$L( Z0))_"*",I BCONT) .. S Z0="*"_$ J("",13)_" ONCE ALL P AYERS FULL Y IMPLEMEN T HIPAA ED ITS, YOU" .. D WRT(1 ,Z0_$J("", 78-$L(Z0)) _"*",IBCON T) .. S Z0 ="*"_$J("" ,13)_"MUST USE THE C ORRECT ID TYPE FOR T HE ID ENTE RED." .. D WRT(1,Z0_ $J("",78-$ L(Z0))_"*" ,IBCONT) . ; . D WRT (1,"*"_$J( "",77)_"*" ,IBCONT) . S Z1="*"_ $J("",$S(I BZ'=1:13,1 :11))_"VIS TA OPTION TO USE: " . I IBZ'=4 D .. S Z0 =Z1_"PROVI DER ID MAI NTENANCE" . I IBZ=4 D .. S Z0= Z1_"INSURA NCE COMPAN Y ENTRY/ED IT" . D WR T(1,Z0_$J( "",78-$L(Z 0))_"*",IB CONT) ; D WRT(1,Z,IB CONT) ; I '$O(^TMP($ J,"IBZ232" ,IBZ,0)) D WRT(2,"** *** NOTHIN G FOUND FO R THIS ERR OR/WARNING *****",IB CONT) Q ;I NSHDR(IBPG ,IBSTOP,IB INM,IBZ,IB ICONT) ; I ns Co info I ($Y+7)> IOSL D HDR 1(.IBPG,.I BSTOP,IBZ, 1) Q:IBSTO P D WRT(2, "INSURANCE CO NAME: "_IBINM_$S ($G(IBICON T):" (Cont inued)",1: ""),IBICON T) Q ;ASK( IBSTOP) ; Ask contin ue ; If pa ssed by re f, IBSTOP returned = 1 if prin t aborted I $E(IOST, 1,2)'["C-" Q N DIR,D IROUT,DIRU T,DTOUT,DU OUT S DIR( 0)="E" W ! D ^DIR I ($D(DIRUT) )!($D(DUOU T)) S IBST OP=1 Q Q ; WRT(FF,TEX T,NOT) ; W rt/store l ine N Z,A S A=+$O(^T MP($J,"SEN DMSG",1,"" ),-1),NOT= $G(NOT) I FF F Z=1:1 :FF W ! I $G(^TMP($J ,"SENDMSG" )),'NOT,Z> 1 S A=A+1, ^TMP($J,"S ENDMSG",1, A)=" " ; I TEXT="@IO F" D Q . W @IOF . I $G(^TMP($ J,"SENDMSG ")),'NOT,I BPG>1 D .. S A=A+1,^ TMP($J,"SE NDMSG",1,A )=" " .. F Z=1:1:2 S A=A+1,^TM P($J,"SEND MSG",1,A)= "*** TOP O F NEW PAGE ***" .. S A=A+1,^TM P($J,"SEND MSG",1,A)= " " ; W TE XT I $G(^T MP($J,"SEN DMSG")),'N OT S A=A+1 ,^TMP($J," SENDMSG",1 ,A)=TEXT Q ; | |
| 2673 | ||
| 2674 | ||
| 2675 | Routines | |
| 2676 | Activities | |
| 2677 | Routine Na me | |
| 2678 | IBCERP6 | |
| 2679 | Enhancemen t Category | |
| 2680 | New | |
| 2681 | Modify | |
| 2682 | Delete | |
| 2683 | No Change | |
| 2684 | RTM | |
| 2685 | ||
| 2686 | Related Op tions | |
| 2687 | None | |
| 2688 | Related Ro utines | |
| 2689 | Routines “ Called By” | |
| 2690 | Routines “ Called” | |
| 2691 | ||
| 2692 | ||
| 2693 | ||
| 2694 | ||
| 2695 | Data Dicti onary (DD) Reference s | |
| 2696 | ||
| 2697 | Related Pr otocols | |
| 2698 | None | |
| 2699 | Related In tegration Control Re gistration s (ICRs) | |
| 2700 | None | |
| 2701 | Data Passi ng | |
| 2702 | Input | |
| 2703 | Output Re ference | |
| 2704 | Both | |
| 2705 | Global Re ference | |
| 2706 | Local | |
| 2707 | Input Attr ibute Name and Defin ition | |
| 2708 | Name: | |
| 2709 | Definition : | |
| 2710 | Output Att ribute Nam e and Defi nition | |
| 2711 | Name: | |
| 2712 | Definition : | |
| 2713 | Current Lo gic | |
| 2714 | IBCERP6 ;A LB/JEH - M RA/EDI CLA IMS READY FOR EXTRAC T ;12/10/9 9 ;;2.0;IN TEGRATED B ILLING;**1 37,211,155 ,348,349** ;21-MAR-94 ;Build 46 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ;EN ;Entry po int from o ption W !! ,"This rep ort provid es a list of claims held in a" W !,"Read y for Extr act status . Users ca n select a ll bills" W !,"in a Ready for extract st atus or on ly those t rapped due to" W !," the EDI/MR A Paramete rs being t urned off. " ; S IBQU IT=0 D SEL ECT I IBQU IT G ENQ1 S IBQUIT=0 D PARAM I IBQUIT G ENQ1 ; W ! !,"This re port requi res a 132 column pri nter.",!! ; - Ask de vice N %ZI S,ZTRTN,ZT SAVE,ZTDES C S %ZIS=" QM" D ^%ZI S G:POP EN Q1 I $D(IO ("Q")) D G ENQ1 .S ZTRTN="BLD ^IBCERP6", ZTDESC="IB - EDI/MRA Claims in Waiting T ransmissio n Status" .S ZTSAVE( "IB*")="" .D ^%ZTLOA D .W !!,$S ($D(ZTSK): "Your task number"_Z TSK_" has been queue d.",1:"Una ble to que ue this jo b.") .K ZT SK,IO("Q") D HOME^%Z IS U IO ;B LD ; - Tas ked entry point ; N IBSTAT,IBI LL,IBREC,I BIFN,IBSTA T,IBVSIT,I BCAT,IBI,I BINS,IBPRE C,IBEVDT,I BTYP,IBPG, IBCHK K ^T MP("IBCERP 6",$J) S ( IBI,IBIFN) =0 F S IB I=$O(^IBA( 364,"ASTAT ","X",IBI) ) Q:'IBI S IBIFN=+$ G(^IBA(364 ,IBI,0)) D .S IBQUIT =0 .S IBST AT=$$WNRBI LL^IBEFUNC (IBIFN) .I IBSEL=2 D I IBQUIT Q ..I 'IB STAT,13[IB PARAM S IB QUIT=1 Q . .I IBSTAT, 23[IBPARAM S IBQUIT= 1 Q .S IBS TAT=$S(IBS TAT:"MRA", 1:"EDI") . S IBREC=$G (^DGCR(399 ,+IBIFN,0) ) .S IBVSI T=$S($$INP AT^IBCEF(I BIFN,1)=1: "INP",1:"O PT") .S IB CAT=$S($$F T^IBCEF(IB IFN)=3:"UB 04",1:"150 0") .S IBI LL=$$BN1^P RCAFN(IBIF N) .S IBIN S=$P($G(^D IC(36,+$$C URR^IBCEF2 (IBIFN),0) ),U) .S IB PREC=$$PT^ IBEFUNC(+$ P(IBREC,U, 2)) .S IBE VDT=$P($G( ^DGCR(399, IBIFN,"U") ),U) ;Stat ement from date .;S IBTYP=$P(I BREC,U,24) _U_$P($G(^ DGCR(399.1 ,+$P(IBREC ,U,25),0)) ,U)_U_$P(I BREC,U,26) .S IBTYP= $$GET1^DIQ (399,IBIFN ,.24)_U_$$ GET1^DIQ(3 99,IBIFN,. 25)_U_$$GE T1^DIQ(399 ,IBIFN,.26 ) .S ^TMP( "IBCERP6", $J,IBSTAT, IBILL)=IBI LL_U_IBVSI T_U_IBCAT_ U_$P(IBPRE C,U)_U_$E( $P(IBPREC, U,2),8,11) _U_IBEVDT_ U_IBTYP_U_ IBINS ;PRI NT ;Prints report S (IBQUIT,IB PG,IBEDI,I BMRA,IBTOT )=0 D HDR I '$D(^TMP ("IBCERP6" ,$J)) W !! ,"There ar e no "_$S( IBPARAM=1: "EDI",IBPA RAM=2:"MRA ",1:"EDI/M RA")_" rec ords"_$S(I BSEL=2:" t rapped",1: "")_" in a ready for extract s tatus" G E NQ1 S IBST AT="" F S IBSTAT=$O (^TMP("IBC ERP6",$J,I BSTAT)) Q: IBSTAT=""! (IBQUIT=1) D .S IBIL L="" F S IBILL=$O(^ TMP("IBCER P6",$J,IBS TAT,IBILL) ) Q:IBILL= ""!(IBQUIT =1) S IBRE C=^(IBILL) D ..I ($Y +5)>IOSL D I IBQUIT Q ...D AS K I IBQUIT Q ...D HD R ..; ..W !,?2,$P(IB REC,U),?15 ,$P(IBREC, U,2),?22,$ P(IBREC,U, 3) ..W ?28 ,$E($P(IBR EC,U,4),1, 20),?50,$P (IBREC,U,5 ) ..W ?57, $$FMTE^XLF DT($P(IBRE C,U,6)),?7 3,$E($P(IB REC,U,7),1 ,8)_", "_$ E($P(IBREC ,U,8),1,3) _", "_$E($ P(IBREC,U, 9),1,16),? 110,$E($P( IBREC,U,10 ),1,20) .. I IBSTAT=" EDI" S IBE DI=IBEDI+1 ..E S IB MRA=IBMRA+ 1 ..S IBTO T=IBTOT+1 W !! I IBE DI>0 W !,? 3,"Total E DI Bills " ,IBEDI I I BMRA>0 W ! ,?3,"Total MRA Bills ",IBMRA W !!,?3,"To tal bills ",IBTOT K ^TMP("IBCE RP6",$J) I $D(ZTQUEU ED) S ZTRE Q="@" I '$ D(ZTQUEUED ) D ^%ZISC ENQ1 K IBP ARAM,IBQUI T,IBSEL,Y, IBEDI,IBMR A,IBTOT Q ;PARAM ; S IBPARAM=$ P($G(^IBE( 350.9,1,8) ),U,10) ;G et MRA/EDI site para meter sett ing I IBPA RAM="" D . W !!,"Your EDI/MRA s ite parame ter settin g is incom plete." .W !,"Please contact y our coordi nator.",! .S IBQUIT= 1 ; I IBSE L=2,IBPARA M=3 D .W ! !,"Your si te paramet ers are se t to allow both EDI and MRA" . W !,"trans missions. There is n o need to run this r eport.",! .S IBQUIT= 1 Q ;HDR ; Prints rep ort headin g ; IB*2.0 *211 ;I $E (IOST,1,2) ="C-" W @I OF,*13 I $ S(IBPG:1,1 :$E(IOST,1 ,2)="C-") W @IOF,*13 S IBPG=IB PG+1 W !!, ?45,$S(IBS EL=2:"Trap ped ",1:"" )_" Claims Ready for Extract", ?90,$$FMTE ^XLFDT(DT) ,?110,"Pag e: ",IBPG W !!,?15," Inpt/",?23 ,"Inst/",! ,?4,"Bill #",?15,"Op t",?23,"Pr of",?32,"N ame" W ?51 ,"SSN",?57 ,"Statemen t Date",?8 9,"Type",? 110,"Insur ance Co." W !,$TR($J ("",IOM)," ","=") Q ;ASK ; I $ E(IOST,1,2 )'["C-" Q N DIR,DIRO UT,DIRUT,D TOUT,DUOUT S DIR(0)= "E" D ^DIR I ($D(DIR UT))!($D(D UOUT)) S I BQUIT=1 Q Q ;SELECT ;Report se lection N DIR,DIROUT ,DTOUT,DUO UT,DTOUT S IBSEL=0 W !! S DIR( "A",1)="Do you want to print a list of:" S DIR("A" ,2)="" S D IR("A",3)= " 1 - All bills in R eady for E xtract sta tus" S DIR ("A",4)=" 2 - Bills trapped du e to EDI/M RA paramet er being t urned off" S DIR("A" ,5)="" S D IR(0)="SAX B^1:All bi lls;2:Trap ped bills" W ! S DIR ("A")="Sel ect Number : ",DIR("B ")=1 D ^DI R I +Y'>0 S IBQUIT=1 Q S IBSEL =+Y Q | |
| 2715 | Modified L ogic (Chan ges are in bold) | |
| 2716 | IBCERP6 ;A LB/JEH - M RA/EDI CLA IMS READY FOR EXTRAC T ;12/10/9 9 ;;2.0;IN TEGRATED B ILLING;**1 37,211,155 ,348,349,5 92**;21-MA R-94;Build 46 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ;EN ;Entr y point fr om option W !!,"This report pr ovides a l ist of cla ims held i n a" W !," Ready for Extract st atus. User s can sele ct all bil ls" W !,"i n a Ready for extrac t status o r only tho se trapped due to" W !,"the ED I/MRA Para meters bei ng turned off." ; S IBQUIT=0 D SELECT I IBQUIT G E NQ1 S IBQU IT=0 D PAR AM I IBQUI T G ENQ1 ; W !!,"Thi s report r equires a 132 column printer." ,!! ; - As k device N %ZIS,ZTRT N,ZTSAVE,Z TDESC S %Z IS="QM" D ^%ZIS G:PO P ENQ1 I $ D(IO("Q")) D G ENQ1 .S ZTRTN= "BLD^IBCER P6",ZTDESC ="IB - EDI /MRA Claim s in Waiti ng Transmi ssion Stat us" .S ZTS AVE("IB*") ="" .D ^%Z TLOAD .W ! !,$S($D(ZT SK):"Your task numbe r"_ZTSK_" has been q ueued.",1: "Unable to queue thi s job.") . K ZTSK,IO( "Q") D HOM E^%ZIS U I O ;BLD ; - Tasked en try point ; N IBSTAT ,IBILL,IBR EC,IBIFN,I BSTAT,IBVS IT,IBCAT,I BI,IBINS,I BPREC,IBEV DT,IBTYP,I BPG,IBCHK K ^TMP("IB CERP6",$J) S (IBI,IB IFN)=0 F S IBI=$O(^ IBA(364,"A STAT","X", IBI)) Q:'I BI S IBIF N=+$G(^IBA (364,IBI,0 )) D .S IB QUIT=0 .S IBSTAT=$$W NRBILL^IBE FUNC(IBIFN ) .I IBSEL =2 D I IB QUIT Q ..I 'IBSTAT,1 3[IBPARAM S IBQUIT=1 Q ..I IBS TAT,23[IBP ARAM S IBQ UIT=1 Q .S IBSTAT=$S (IBSTAT:"M RA",1:"EDI ") .S IBRE C=$G(^DGCR (399,+IBIF N,0)) .S I BVSIT=$S($ $INPAT^IBC EF(IBIFN,1 )=1:"INP", 1:"OPT") . ;JWS;IB*2. 0*592:Dent al form 7 .S IBCAT=$ S($$FT^IBC EF(IBIFN)= 3:"UB04",$ $FT^IBCEF( IBIFN)=7:" J430D",1:" 1500") .S IBILL=$$BN 1^PRCAFN(I BIFN) .S I BINS=$P($G (^DIC(36,+ $$CURR^IBC EF2(IBIFN) ,0)),U) .S IBPREC=$$ PT^IBEFUNC (+$P(IBREC ,U,2)) .S IBEVDT=$P( $G(^DGCR(3 99,IBIFN," U")),U) ;S tatement f rom date . ;S IBTYP=$ P(IBREC,U, 24)_U_$P($ G(^DGCR(39 9.1,+$P(IB REC,U,25), 0)),U)_U_$ P(IBREC,U, 26) .S IBT YP=$$GET1^ DIQ(399,IB IFN,.24)_U _$$GET1^DI Q(399,IBIF N,.25)_U_$ $GET1^DIQ( 399,IBIFN, .26) .S ^T MP("IBCERP 6",$J,IBST AT,IBILL)= IBILL_U_IB VSIT_U_IBC AT_U_$P(IB PREC,U)_U_ $E($P(IBPR EC,U,2),8, 11)_U_IBEV DT_U_IBTYP _U_IBINS ; PRINT ;Pri nts report S (IBQUIT ,IBPG,IBED I,IBMRA,IB TOT)=0 D H DR I '$D(^ TMP("IBCER P6",$J)) W !!,"There are no "_ $S(IBPARAM =1:"EDI",I BPARAM=2:" MRA",1:"ED I/MRA")_" records"_$ S(IBSEL=2: " trapped" ,1:"")_" i n a ready for extrac t status" G ENQ1 S I BSTAT="" F S IBSTAT =$O(^TMP(" IBCERP6",$ J,IBSTAT)) Q:IBSTAT= ""!(IBQUIT =1) D .S I BILL="" F S IBILL=$ O(^TMP("IB CERP6",$J, IBSTAT,IBI LL)) Q:IBI LL=""!(IBQ UIT=1) S I BREC=^(IBI LL) D ..I ($Y+5)>IOS L D I IBQ UIT Q ...D ASK I IBQ UIT Q ...D HDR ..; . .W !,?2,$P (IBREC,U), ?15,$P(IBR EC,U,2),?2 2,$P(IBREC ,U,3) ..W ?28,$E($P( IBREC,U,4) ,1,20),?50 ,$P(IBREC, U,5) ..W ? 57,$$FMTE^ XLFDT($P(I BREC,U,6)) ,?73,$E($P (IBREC,U,7 ),1,8)_", "_$E($P(IB REC,U,8),1 ,3)_", "_$ E($P(IBREC ,U,9),1,16 ),?110,$E( $P(IBREC,U ,10),1,20) ..I IBSTA T="EDI" S IBEDI=IBED I+1 ..E S IBMRA=IBM RA+1 ..S I BTOT=IBTOT +1 W !! I IBEDI>0 W !,?3,"Tota l EDI Bill s ",IBEDI I IBMRA>0 W !,?3,"To tal MRA Bi lls ",IBMR A W !!,?3, "Total bil ls ",IBTOT K ^TMP("I BCERP6",$J ) I $D(ZTQ UEUED) S Z TREQ="@" I '$D(ZTQUE UED) D ^%Z ISCENQ1 K IBPARAM,IB QUIT,IBSEL ,Y,IBEDI,I BMRA,IBTOT Q ;PARAM ; S IBPARA M=$P($G(^I BE(350.9,1 ,8)),U,10) ;Get MRA/ EDI site p arameter s etting I I BPARAM="" D .W !!,"Y our EDI/MR A site par ameter set ting is in complete." .W !,"Ple ase contac t your coo rdinator." ,! .S IBQU IT=1 ; I I BSEL=2,IBP ARAM=3 D . W !!,"Your site para meters are set to al low both E DI and MRA " .W !,"tr ansmission s. There i s no need to run thi s report." ,! .S IBQU IT=1 Q ;HD R ;Prints report hea ding ; IB* 2.0*211 ;I $E(IOST,1 ,2)="C-" W @IOF,*13 I $S(IBPG: 1,1:$E(IOS T,1,2)="C- ") W @IOF, *13 S IBPG =IBPG+1 W !!,?45,$S( IBSEL=2:"T rapped ",1 :"")_" Cla ims Ready for Extrac t",?90,$$F MTE^XLFDT( DT),?110," Page: ",IB PG W !!,?1 5,"Inpt/", ?23,"Inst/ ",!,?4,"Bi ll #",?15, "Opt",?23, "Prof",?32 ,"Name" W ?51,"SSN", ?57,"State ment Date" ,?89,"Type ",?110,"In surance Co ." W !,$TR ($J("",IOM )," ","=") Q ;ASK ; I $E(IOST, 1,2)'["C-" Q N DIR,D IROUT,DIRU T,DTOUT,DU OUT S DIR( 0)="E" D ^ DIR I ($D( DIRUT))!($ D(DUOUT)) S IBQUIT=1 Q Q ;SELE CT ;Report selection N DIR,DIR OUT,DTOUT, DUOUT,DTOU T S IBSEL= 0 W !! S D IR("A",1)= "Do you wa nt to prin t a list o f:" S DIR( "A",2)="" S DIR("A", 3)=" 1 - A ll bills i n Ready fo r Extract status" S DIR("A",4) =" 2 - Bil ls trapped due to ED I/MRA para meter bein g turned o ff" S DIR( "A",5)="" S DIR(0)=" SAXB^1:All bills;2:T rapped bil ls" W ! S DIR("A")=" Select Num ber: ",DIR ("B")=1 D ^DIR I +Y' >0 S IBQUI T=1 Q S IB SEL=+Y Q | |
| 2717 | ||
| 2718 | ||
| 2719 | Routines | |
| 2720 | Activities | |
| 2721 | Routine Na me | |
| 2722 | IBCEST | |
| 2723 | Enhancemen t Category | |
| 2724 | New | |
| 2725 | Modify | |
| 2726 | Delete | |
| 2727 | No Change | |
| 2728 | RTM | |
| 2729 | ||
| 2730 | Related Op tions | |
| 2731 | None | |
| 2732 | Related Ro utines | |
| 2733 | Routines “ Called By” | |
| 2734 | Routines “ Called” | |
| 2735 | ||
| 2736 | ||
| 2737 | ||
| 2738 | ||
| 2739 | Data Dicti onary (DD) Reference s | |
| 2740 | ||
| 2741 | Related Pr otocols | |
| 2742 | None | |
| 2743 | Related In tegration Control Re gistration s (ICRs) | |
| 2744 | None | |
| 2745 | Data Passi ng | |
| 2746 | Input | |
| 2747 | Output Re ference | |
| 2748 | Both | |
| 2749 | Global Re ference | |
| 2750 | Local | |
| 2751 | Input Attr ibute Name and Defin ition | |
| 2752 | Name: | |
| 2753 | Definition : | |
| 2754 | Output Att ribute Nam e and Defi nition | |
| 2755 | Name: | |
| 2756 | Definition : | |
| 2757 | Current Lo gic | |
| 2758 | IBCEST ;AL B/TMP - 83 7 EDI STAT US MESSAGE PROCESSIN G ;17-APR- 96 ;;2.0;I NTEGRATED BILLING;** 137,189,19 7,135,283, 320,368,39 7,407**;21 -MAR-94;Bu ild 29 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ; IA 4 043 for ca ll to AUDI TX^PRCAUDT Q ;UPD361 (IBTDA) ; Update IB BILL STATU S MESSAGES file ; IB TDA = ien of return message in file 364. 2 ; N IB,I B0,IBSEQ,I B00,IBBILL ,IBBTCH,IB MNUM ; I ' $$LOCK^IBC EM(IBTDA) G UPDQ ;Lo ck message in file 3 64.2 ; S I B0=$G(^IBA (364.2,IBT DA,0)) S I BMNUM=$P(I B0,U) ; Me ssage numb er S IB00= $G(^IBA(36 4,+$P(IB0, U,5),0)) ; Transmit bill entry S IBBILL= +IB00 ; Ac tual bill ien in fil e 399 S IB BTCH=$P(IB 0,U,4) ; B atch # ; ; Auto-audi t bills ba sed on sta tus code o n '10' rec ord of sta tus msg ; flat file I IBBILL,$ P($T(PRCAU DT+1^PRCAU DT),"**",2 )[",173" D . N Z,Z0, Z1,OK . Q: +$$STA^PRC AFN(IBBILL )'=104 . S (Z,OK)=0 . F S Z=$ O(^IBA(364 .2,IBTDA,2 ,Z)) Q:'Z S Z0=$P($ G(^(Z,0)), "##RAW DAT A: ",2) I +Z0=10 S Z 0=$P(Z0,U, 5) D Q:OK .. ; Stri p leading spaces .. S Z0=$$TRI M^XLFSTR(Z 0) .. Q:Z0 ="" .. I $ $SCODE^IBC EST1(Z0),$ P($G(^DGCR (399.3,+$P ($G(^DGCR( 399,IBBILL ,0)),U,7), 0)),U,11) D AUDITX^P RCAUDT(IBB ILL) S OK= 1 ; IA 404 3 ; I $S(I BMNUM="":1 ,1:'IBBILL &(IBBTCH=" ")) D DELM SG^IBCESRV 2(IBTDA) G UPDQ ; ; Individual bill I IB BILL D G UPDQ . N I BA1,IBMSG0 ,IBPID . S IBPID="", IBA1=0 . F S IBA1=$ O(^IBA(364 .2,IBTDA,2 ,IBA1)) Q: 'IBA1 S I BMSG0=$P($ G(^(IBA1,0 )),"##RAW DATA: ",2) I +IBMSG0 =277,$P(IB MSG0,U,5)= "N" S IBPI D=$P(IBMSG 0,U,11) Q . S IBSEQ= $P(IB00,U, 8) S:IBSEQ ="" IBSEQ= "P" . D ST ORE(IB0,IB BTCH,IBMNU M,IBTDA,IB BILL,IBSEQ ,IBPID,1) ; ; Batch - update e ach bill s eparately S IBBILL=" " F S IBB ILL=$O(^IB A(364,"ABA BI",+IBBTC H,IBBILL)) Q:'IBBILL D . Q:$D (^TMP("IBC ONF",$J,IB BILL)) ;Bi ll was rej ected . S IB=$O(^IBA (364,"ABAB I",+IBBTCH ,IBBILL,0) ) Q:'IB . S IBSEQ=$P ($G(^IBA(3 64,IB,0)), U,8) S:IBS EQ="" IBSE Q="P" . D STORE(IB0, IBBTCH,IBM NUM,IBTDA, IBBILL,IBS EQ,"",0) ; Q ;STORE( IB0,IBBTCH ,IBMNUM,IB TDA,IBBILL ,IBSEQ,IBP ID,IB1) ; ; ; IB0 = 0-node of message in file 364. 2 ; IBBTCH = ien of batch in f ile 364.1 ; IBMNUM = actual me ssage numb er ; IBTDA = ien of message in file 364. 2 ; IBBILL = ien of bill in 39 9 ; IBSEQ = P/S/T/ f or COB seq uence rela ted to mes sage ; IBP ID = the p ayer id re turned fro m clearing house for the claim ; IB1 = fl ag that sa ys if the message wa s for a si ngle bill or a batch . ; Batch statuses h ave an add itional st andard tex t entry. ; 1 = singl e bill 0 = batch ; N DA,DIK,D IE,DIC,X,Y ,DR,DO,DD, DLAYGO,Z,Z 0,Z1,Z2,Z3 ,IBT,IBDUP ,IBFLDS,IB Y,IBAUTO,I BLN ; S X= IBBILL,IBD UP=0 ; S I BFLDS=".02 ////"_$P(I B0,U,3) S IBFLDS=IBF LDS_";.03/ ///"_$S($$ EXTERNAL^D ILFD(364.2 ,.02,"U",$ P(IB0,U,2) )["REJ":"R ",1:"I")_" ;.05////"_ IBBTCH_";. 06////"_IB MNUM_";.04 ////"_+$P( IB0,U,8)_" ;.07////"_ IBSEQ_$S($ P(IB0,U,5) :";.11//// "_$P(IB0,U ,5),1:"") S IBFLDS=I BFLDS_";.1 2////"_$P( IB0,U,10)_ ";.09////0 " S IBFLDS =IBFLDS_"; .15////"_$ $CHKSUM^IB CEST1("^IB A(364.2,"_ IBTDA_",2) ") I IBPID '="" D . S IBPID("TY PE")=$S($$ FT^IBCEF(I BBILL)=2:" P",1:"I") . D UPDINS (.IBPID,$$ POLICY^IBC EF(IBBILL, 1,$TR(IBSE Q,"PST","1 23")),IBBI LL) ; I IB DUP D I $ D(Y) G UPD Q . ; Stuf f fields i nto existi ng entry . ; (may be needed fo r reproces sing of ab orted upda tes) . S D IE="^IBM(3 61,",DA=IB DUP,DR=IBF LDS_";1/// @" . D ^DI E . I $D(Y ) S IBY=-1 Q ;Updat e not succ essful . S IBY=IBDUP ; K IBT I 'IBDUP D ; Create new entry and stuff fields . S DIC(0)="L ",DIC="^IB M(361,",DL AYGO=361 . S DIC("DR ")=IBFLDS . D FILE^D ICN . K DO ,DD,DLAYGO ,DIC . S I BY=+Y . Q: IBY'>0 . ; . ; IB*2* 320 - Chec k for dupl icate stat us message . NEW IBN EW,IBOLD,P CE,Z,DIK,D A . S IBNE W="" . F P CE=3,4,5,7 ,8,11,15 S IBNEW=IBN EW_$P($G(^ IBM(361,IB Y,0)),U,PC E)_U . S Z =0 . F S Z=$O(^IBM( 361,"B",IB BILL,Z)) Q :'Z I Z'= IBY D Q:I BY'>0 .. S IBOLD="" .. F PCE=3 ,4,5,7,8,1 1,15 S IBO LD=IBOLD_$ P($G(^IBM( 361,Z,0)), U,PCE)_U . . I IBNEW' =IBOLD Q ; no dupl icate so g et the nex t one .. S DIK="^IBM (361,",DA= IBY,IBY=-1 D ^DIK D DELMSG^IBC ESRV2(IBTD A) .. Q . Q ; I IBY> 0 D ;Move text over . K IBT . ; . D BLD MSG(IB1,IB TDA,.IBT,. IBAUTO) . ; . ; IB*2 *368 - ymg - 2Q,RE,R P messages will be f iled as in formationa l . ; Z0 i s the flag for 2Q co de . ; Z1 is the fla g for RE c ode . ; Z2 is the fl ag for RP code . ; Z 3 is the f lag for au tofiling t he message . I $P($G (^IBM(361, +IBY,0)),U ,3)="R" D .. S Z="", (Z0,Z1,Z2, Z3)=0 F S Z=$O(IBT( Z)) Q:Z="" !(Z3=1) D ... S IBLN =$$UP^XLFS TR($G(IBT( Z))) ... I (Z0!Z1!Z2 )=0 D .... S:IBLN?.E 1"CODE:".P 1"2Q".E Z0 =1 .... S: IBLN?.E1"C ODE:".P1"R E".E Z1=1 .... S:IBL N?.E1"CODE :".P1"RP". E Z2=1 ... I Z0=1 S: IBLN?.P1"C LAIM".P1"R EJECTED".P 1"BY".P1"C LEARINGHOU SE".E Z3=1 ... I Z1= 1 S:IBLN?. P1"ELECTRO NIC".P1"CL AIM".P1"RE JECTED".P1 "BY".P1"EM DEON".E Z3 =1 ... I Z 2=1 S:IBLN ?.P1"PAPER ".P1"CLAIM ".P1"REJEC TED".P1"BY ".P1"EMDEO N".E Z3=1 .. I Z3=1 S IBAUTO=1 ,DIE=361,D A=+IBY,DR= ".03////I" D ^DIE .. Q . ; . ; if info m sg, ck for no review needed ba sed on fir st line of text . I $G(IBAUTO) ,$P($G(^IB M(361,+IBY ,0)),U,3)= "I" D .. S DIE="^IBM (361,",DR= ".09////2; .14////1;. 1////F",DA =+IBY D ^D IE .. I IB 1,$P($G(^I BM(361,+IB Y,0)),U,11 ) S Z="",Z 0=0 F S Z =$O(IBT(Z) ) Q:Z=""!( Z0=1) D .. . S Z0=$$P RINTUPD^IB CEU0($$UP^ XLFSTR($G( IBT(Z))),$ P($G(^IBM( 361,+IBY,0 )),U,11)) . ; . D MS GLNSZ(.IBT ) ; Conver t Message Lines in I BT to be n o longer t han 70 cha rs . D WP^ DIE(361,+I BY_",",1," A","IBT") ; file mes sage text . ; . ; De lete messa ge after i t successf ully updat es the dat abase. . D DELMSG^IB CESRV2(IBT DA) . Q ;U PDQ L -^IB A(364.2,IB TDA,0) Q ; BLDMSG(IB1 ,IBTDA,IBT ,IBAUTO) ; Builds me ssage text ; IB1 = f lag for ba tch messag e ; IBTDA = ien of e ntry in fi le 364.2 ; IBT = arr ay returne d with mes sage text ; IBAUTO = if passed by refere nce, retur ns 1 if te xt indicat es review ; not need ed N IBDAT A,IBCK,IBZ ,IBZ0,IBZ1 ,Z S (IBZ, IBZ0,IBDAT A,IBAUTO,I BCK)=0 I ' IB1 S IBT( 1)="Status message r eceived fo r batch "_ $P($G(^IBA (364.1,IBB TCH,0)),U) _" dated " _$$FMTE^XL FDT($P($G( ^IBA(364.2 ,IBTDA,0)) ,U,10),2), IBZ0=1 ; D on't move the raw da ta over, j ust move t he text of the messa ge F S IB Z=$O(^IBA( 364.2,IBTD A,2,IBZ)) Q:'IBZ S IBZ1=$G(^( IBZ,0)) S IBDATA=($E (IBZ1,1,2) ="##") Q:I BDATA S I BZ0=IBZ0+1 ,IBT(IBZ0) =IBZ1 I 'I BCK S Z=$$ CKREVU^IBC EM4(IBZ1,, ,.IBCK),IB AUTO=$S(IB CK:0,Z:1,1 :IBAUTO) Q ;UPDINS(I BPID,IBINS ,IBIFN) ; Update the insurance id or the bill prin ted at ; t he EDI con tractor's print shop and maile d to the i ns co. ; I BPID = the id return ed from th e EDI cont ractor for the ins c o ; ("TYPE ") = P if profession al id or I if instit utional id ; IBINS = the ien o f the insu rance co i t was sent to (file 36) ; IBIF N = the ie n of the c laim (file 399) ; N IBID,IBIDF LD,IBPRT,I BLOOK,DA,D R,DIE,X,Y, Z ; Q:'$G( IBINS)!($G (IBPID)="" ) ; ; Stri p spaces o ff the end of data S IBLOOK="" I $L(IBPI D) F Z=$L( IBPID):-1: 1 I $E(IBP ID,Z)'=" " S IBLOOK= $E(IBPID,1 ,Z) Q ; S IBPRT=($E( IBLOOK,2,5 )="PRNT") I IBPRT D ; Set pri nted via E DI field o n bill . S DA=IBIFN, DIE="^DGCR (399,",DR= "26////1" D ^DIE ; S IBLOOK=$E ($S('IBPRT :$P(IBLOOK ,"PAYID=", 2),1:""),1 ,5) Q:IBLO OK=""!($E( IBLOOK,2,5 )="PRNT") S IBIDFLD= "3.0"_$S($ G(IBPID("T YPE"))="I" :4,1:2) S IBID=$P($G (^DIC(36,+ IBINS,3)), U,IBIDFLD* 100#100) Q :IBID=IBLO OK I IBID= "" D G UP DINSQ ; Up date insur ance co el ectronic i d # if bla nk . S DIE ="^DIC(36, ",DR=IBIDF LD_"////"_ IBLOOK,DA= IBINS D ^D IE I IBID' ="",IBLOOK '="" D ; Bulletin t hat the id on file a nd id retu rned . ; a re differe nt . N XMT O,XMDUZ,XM BODY,IBXM, XMSUBJ,XMZ . S XMTO( "I:G.IB ED I")="" . S XMDUZ="", XMBODY="IB XM",XMSUBJ ="PAYER ID RETURNED IS DIFFERE NT THAN PA YER ID ON FILE" . S IBXM(1)="B ILL # : "_ $P($G(^DGC R(399,IBIF N,0)),U) . S IBXM(2) ="PAYER : "_$P($G(^D IC(36,+IBI NS,0)),U) . S IBXM(3 )="BILL TY PE : "_$S( $G(IBPID(" TYPE"))="I ":"INSTITU T",1:"PROF ESS")_"ION AL" . S IB XM(4)="ID ON FILE : "_IBID . S IBXM(5)=" ID RETURNE D: "_IBLOO K . S IBXM (6)=" ",IB XM(7)=" Pl ease deter mine which id number is correc t and corr ect the id in the",I BXM(8)="in surance fi le for thi s payer, i f needed" . D SENDMS G^XMXAPI(X MDUZ,XMSUB J,XMBODY,. XMTO,,.XMZ ) ;UPDINSQ Q ;MSGLNS Z(MSG) ; C hange Inpu t Message Lines to b e no more than 70 ch aracters l ong each ; ; Input/O utput: MSG - array o f Input Me ssage Line s; this is also the Output Mes sage ; whi ch is an a rray of Co nverted Me ssage Line s (with li nes no mor e than 70 chars each ) ; N LN,X ARY,XARYLN ,CNT,OUTMS G,TMPMSG,L DNGSP,LDNG SPN S LN=" ",CNT=0 F S LN=$O(M SG(LN)) Q: LN="" D ; . ; Find any leadi ng spaces in origina l message line, . ; to be use d if line got split below . S TMPMSG=$$T RIM^XLFSTR (MSG(LN)," L"," ") ;T rim Leadin g Spaces . S LDNGSP= $P(MSG(LN) ,TMPMSG,1) ;get lead ing spaces if any . S LDNGSPN= $L(LDNGSP) S:LDNGSPN >30 LDNGSP =$E(LDNGSP ,1,30) ;ma ke sure th ere are no more than 30 leadin g spaces . ; Conver ts a singl e line to multiple l ines with a maximum width of 7 0 each . ; If line i s 70 chars or less, this call returns th e exact li ne . K XAR Y D FSTRNG ^IBJU1(TMP MSG,70-LDN GSPN,.XARY ) . ; Scan lines and merge the m into the final out put array (OUTMSG) . ; On line s 2 and hi gher, add Leading Sp aces found above, if any. . S XARYLN="" F S XARYL N=$O(XARY( XARYLN)) Q :XARYLN="" S CNT=CN T+1,OUTMSG (CNT)=LDNG SP_XARY(XA RYLN) ; ; Move the f inal Messa ge Lines ( OUTMSG) in to MSG arr ay to be r eturned K MSG M MSG= OUTMSG Q ; | |
| 2759 | Modified L ogic (Chan ges are in bold) | |
| 2760 | IBCEST ;AL B/TMP - 83 7 EDI STAT US MESSAGE PROCESSIN G ;17-APR- 96 ;;2.0;I NTEGRATED BILLING;** 137,189,19 7,135,283, 320,368,39 7,407,577, 592**;21-M AR-94;Buil d 1 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ; IA 4043 for call to AU DITX^PRCAU DT Q ;UPD3 61(IBTDA) ; Update I B BILL STA TUS MESSAG ES file ; IBTDA = ie n of retur n message in file 36 4.2 ; N IB ,IB0,IBSEQ ,IB00,IBBI LL,IBBTCH, IBMNUM,IBD ATE,IBTYP ; I '$$LOC K^IBCEM(IB TDA) G UPD Q ;Lock me ssage in f ile 364.2 ; S IB0=$G (^IBA(364. 2,IBTDA,0) ) S IBMNUM =$P(IB0,U) ; Message number S IB00=$G(^I BA(364,+$P (IB0,U,5), 0)) ; Tran smit bill entry S IB BILL=+IB00 ; Actual bill ien i n file 399 S IBBTCH= $P(IB0,U,4 ) ; Batch # ; ; Auto -audit bil ls based o n status c ode on '10 ' record o f status m sg ; flat file I IBB ILL,$P($T( PRCAUDT+1^ PRCAUDT)," **",2)[",1 73" D . N Z,Z0,Z1,OK . Q:+$$ST A^PRCAFN(I BBILL)'=10 4 . S (Z,O K)=0 . F S Z=$O(^IB A(364.2,IB TDA,2,Z)) Q:'Z S Z0 =$P($G(^(Z ,0)),"##RA W DATA: ", 2) I +Z0=1 0 S Z0=$P( Z0,U,5) D Q:OK .. ; Strip lea ding space s .. S Z0= $$TRIM^XLF STR(Z0) .. Q:Z0="" . . I $$SCOD E^IBCEST1( Z0),$P($G( ^DGCR(399. 3,+$P($G(^ DGCR(399,I BBILL,0)), U,7),0)),U ,11) D AUD ITX^PRCAUD T(IBBILL) S OK=1 ; I A 4043 ; I $S(IBMNUM ="":1,1:'I BBILL&(IBB TCH="")) D DELMSG^IB CESRV2(IBT DA) G UPDQ ; ; Indiv idual bill ; KDM US1 29 IB*2*57 7 rework I ndividual vs. Batch to Correct Storage o f Payer ID I IBBILL D UPDTBILL () G UPDQ ; ; Batch - update e ach bill s eparately S IBBILL=" " F S IBB ILL=$O(^IB A(364,"ABA BI",+IBBTC H,IBBILL)) Q:'IBBILL D . Q:$D (^TMP("IBC ONF",$J,IB BILL)) ;Bi ll was rej ected . S IB=$O(^IBA (364,"ABAB I",+IBBTCH ,IBBILL,0) ) . Q:'IB . D UPDTBI LL() ;KDM US129 IB*2 *577 Corre ct Storage of PAYER ID ; Q ;UP DTBILL() ; KDM US129 IB*2*577 N ew section to Correc t Storage of PAYER I D N IBA1,I BMSG0,IBPI D S IBPID= "",IBA1=0 ; F S IBA 1=$O(^IBA( 364.2,IBTD A,2,IBA1)) Q:'IBA1 D Q:IBPID ]"" . S IB MSG0=$P($G (^(IBA1,0) ),"##RAW D ATA: ",2) . I +IBMSG 0=277,$P(I BMSG0,U,5) ="N" S IBP ID=$P(IBMS G0,U,11) ; S IBSEQ=$ P(IB00,U,8 ) S:IBSEQ= "" IBSEQ=" P" D STORE (IB0,IBBTC H,IBMNUM,I BTDA,IBBIL L,IBSEQ,IB PID,1) Q ; STORE(IB0, IBBTCH,IBM NUM,IBTDA, IBBILL,IBS EQ,IBPID,I B1) ; ; ; IB0 = 0-no de of mess age in fil e 364.2 ; IBBTCH = i en of batc h in file 364.1 ; IB MNUM = act ual messag e number ; IBTDA = i en of mess age in fil e 364.2 ; IBBILL = i en of bill in 399 ; IBSEQ = P/ S/T/ for C OB sequenc e related to message ; IBPID = the payer id return ed from cl earinghous e for the claim ; IB 1 = flag t hat says i f the mess age was fo r a single bill or a batch. ; Batch stat uses have an additio nal standa rd text en try. ; 1 = single bi ll 0 = bat ch ; N DA ,DIK,DIE,D IC,X,Y,DR, DO,DD,DLAY GO,Z,Z0,Z1 ,Z2,Z3,IBT ,IBDUP,IBF LDS,IBY,IB AUTO,IBLN ; S X=IBBI LL,IBDUP=0 ; S IBFLD S=".02//// "_$P(IB0,U ,3) S IBFL DS=IBFLDS_ ";.03////" _$S($$EXTE RNAL^DILFD (364.2,.02 ,"U",$P(IB 0,U,2))["R EJ":"R",1: "I")_";.05 ////"_IBBT CH_";.06// //"_IBMNUM _";.04//// "_+$P(IB0, U,8)_";.07 ////"_IBSE Q_$S($P(IB 0,U,5):";. 11////"_$P (IB0,U,5), 1:"") S IB FLDS=IBFLD S_";.12/// /"_$P(IB0, U,10)_";.0 9////0" S IBFLDS=IBF LDS_";.15/ ///"_$$CHK SUM^IBCEST 1("^IBA(36 4.2,"_IBTD A_",2)") I IBPID'="" D . ;JWS; IB*2.0*592 ;Dental Fo rm 7 . S I BPID("TYPE ")=$S($$FT ^IBCEF(IBB ILL)=2:"P" ,$$FT^IBCE F(IBBILL)= 7:"P",1:"I ") . D UPD INS(.IBPID ,$$POLICY^ IBCEF(IBBI LL,1,$TR(I BSEQ,"PST" ,"123")),I BBILL,IBTD A) ;KDM US 129 IB*2*5 77 ; I IBD UP D I $D (Y) G UPDQ . ; Stuff fields in to existin g entry . ; (may be needed for reprocess ing of abo rted updat es) . S DI E="^IBM(36 1,",DA=IBD UP,DR=IBFL DS_";1///@ " . D ^DIE . I $D(Y) S IBY=-1 Q ;Update not succe ssful . S IBY=IBDUP ; K IBT I 'IBDUP D ; Create n ew entry a nd stuff f ields . S DIC(0)="L" ,DIC="^IBM (361,",DLA YGO=361 . S DIC("DR" )=IBFLDS . D FILE^DI CN . K DO, DD,DLAYGO, DIC . S IB Y=+Y . Q:I BY'>0 . ; . ; IB*2*3 20 - Check for dupli cate statu s message . NEW IBNE W,IBOLD,PC E,Z,DIK,DA . S IBNEW ="" . F PC E=3,4,5,7, 8,11,15 S IBNEW=IBNE W_$P($G(^I BM(361,IBY ,0)),U,PCE )_U . S Z= 0 . F S Z =$O(^IBM(3 61,"B",IBB ILL,Z)) Q: 'Z I Z'=I BY D Q:IB Y'>0 .. S IBOLD="" . . F PCE=3, 4,5,7,8,11 ,15 S IBOL D=IBOLD_$P ($G(^IBM(3 61,Z,0)),U ,PCE)_U .. I IBNEW'= IBOLD Q ; no dupli cate so ge t the next one .. S DIK="^IBM( 361,",DA=I BY,IBY=-1 D ^DIK D D ELMSG^IBCE SRV2(IBTDA ) .. Q . Q ; I IBY>0 D ;Move text over . K IBT . ; . D BLDM SG(IB1,IBT DA,.IBT,.I BAUTO) . ; . ; IB*2* 368 - ymg - 2Q,RE,RP messages will be fi led as inf ormational . ; Z0 is the flag for 2Q cod e . ; Z1 i s the flag for RE co de . ; Z2 is the fla g for RP c ode . ; Z3 is the fl ag for aut ofiling th e message . I $P($G( ^IBM(361,+ IBY,0)),U, 3)="R" D . . S Z="",( Z0,Z1,Z2,Z 3)=0 F S Z=$O(IBT(Z )) Q:Z=""! (Z3=1) D . .. S IBLN= $$UP^XLFST R($G(IBT(Z ))) ... I (Z0!Z1!Z2) =0 D .... S:IBLN?.E1 "CODE:".P1 "2Q".E Z0= 1 .... S:I BLN?.E1"CO DE:".P1"RE ".E Z1=1 . ... S:IBLN ?.E1"CODE: ".P1"RP".E Z2=1 ... I Z0=1 S:I BLN?.P1"CL AIM".P1"RE JECTED".P1 "BY".P1"CL EARINGHOUS E".E Z3=1 ... I Z1=1 S:IBLN?.P 1"ELECTRON IC".P1"CLA IM".P1"REJ ECTED".P1" BY".P1"EMD EON".E Z3= 1 ... I Z2 =1 S:IBLN? .P1"PAPER" .P1"CLAIM" .P1"REJECT ED".P1"BY" .P1"EMDEON ".E Z3=1 . . I Z3=1 S IBAUTO=1, DIE=361,DA =+IBY,DR=" .03////I" D ^DIE .. Q . ; . ; if info ms g, ck for no review needed bas ed on firs t line of text . I $ G(IBAUTO), $P($G(^IBM (361,+IBY, 0)),U,3)=" I" D .. S DIE="^IBM( 361,",DR=" .09////2;. 14////1;.1 ////F",DA= +IBY D ^DI E .. I IB1 ,$P($G(^IB M(361,+IBY ,0)),U,11) S Z="",Z0 =0 F S Z= $O(IBT(Z)) Q:Z=""!(Z 0=1) D ... S Z0=$$PR INTUPD^IBC EU0($$UP^X LFSTR($G(I BT(Z))),$P ($G(^IBM(3 61,+IBY,0) ),U,11)) . ; . D MSG LNSZ(.IBT) ; Convert Message L ines in IB T to be no longer th an 70 char s . D WP^D IE(361,+IB Y_",",1,"A ","IBT") ; file mess age text . ; . ; Del ete messag e after it successfu lly update s the data base. . D DELMSG^IBC ESRV2(IBTD A) . Q ;UP DQ L -^IBA (364.2,IBT DA,0) Q ;B LDMSG(IB1, IBTDA,IBT, IBAUTO) ; Builds mes sage text ; IB1 = fl ag for bat ch message ; IBTDA = ien of en try in fil e 364.2 ; IBT = arra y returned with mess age text ; IBAUTO = if passed by referen ce, return s 1 if tex t indicate s review ; not neede d N IBDATA ,IBCK,IBZ, IBZ0,IBZ1, Z S (IBZ,I BZ0,IBDATA ,IBAUTO,IB CK)=0 I 'I B1 S IBT(1 )="Status message re ceived for batch "_$ P($G(^IBA( 364.1,IBBT CH,0)),U)_ " dated "_ $$FMTE^XLF DT($P($G(^ IBA(364.2, IBTDA,0)), U,10),2),I BZ0=1 ; Do n't move t he raw dat a over, ju st move th e text of the messag e F S IBZ =$O(^IBA(3 64.2,IBTDA ,2,IBZ)) Q :'IBZ S I BZ1=$G(^(I BZ,0)) S I BDATA=($E( IBZ1,1,2)= "##") Q:IB DATA S IB Z0=IBZ0+1, IBT(IBZ0)= IBZ1 I 'IB CK S Z=$$C KREVU^IBCE M4(IBZ1,,, .IBCK),IBA UTO=$S(IBC K:0,Z:1,1: IBAUTO) Q ;UPDINS(IB PID,IBINS, IBIFN,IBTD A) ;KDM US 129 IB*2*5 77 ; Updat e the insu rance id o r the bill printed a t ; the ED I contract or's print shop and mailed to the ins co . ; IBPID = the id r eturned fr om the EDI contracto r for the ins co ; ( "TYPE") = P if profe ssional id or I if i nstitution al id ; IB INS = the ien of the insurance co it was sent to ( file 36) ; IBIFN = t he ien of the claim (file 399) ; IBTDA = ien of en try in fil e 364.2 ;K DM US129 I B*2*577 ; N IBID,IBI DFLD,IBPRT ,IBLOOK,DA ,DR,DIE,X, Y,Z,UPD ;KDM US1 29 IB*2*57 7 ; Q:'$G( IBINS)!($G (IBPID)="" ) ; ; Stri p spaces o ff the end of data S IBLOOK="" I $L(IBPI D) F Z=$L( IBPID):-1: 1 I $E(IBP ID,Z)'=" " S IBLOOK= $E(IBPID,1 ,Z) Q ; S IBPRT=($E( IBLOOK,2,5 )="PRNT") I IBPRT D ; Set pri nted via E DI field o n bill . S DA=IBIFN, DIE="^DGCR (399,",DR= "26////1" D ^DIE ; ; KDM US129 IB*2*577 correct pa yer ID sto rage ;S IB LOOK=$E($S ('IBPRT:$P (IBLOOK,"P AYID=",2), 1:""),1,5) ;Q:IBLOOK =""!($E(IB LOOK,2,5)= "PRNT") I IBPRT Q I IBLOOK'["P AYID=",IBL OOK'["COBI D=" Q ;KDM US129 IB*2*577 S IBLOOK=$ E($P(IBLOO K,"ID=",2) ,1,5) Q:IB LOOK="" ; S IBIDFLD= "3.0"_$S($ G(IBPID("T YPE"))="I" :4,1:2) S IBID=$P($G (^DIC(36,+ IBINS,3)), U,IBIDFLD* 100#100) Q :IBID=IBLO OK S IBDAT E=DT,IBTYP =$G(IBPID( "TYPE")) ; KDM US129 IB*2*577 I IBID="" D G UPDINS Q ; Update insurance co electr onic id # if blank . S DIE="^D IC(36,",DR =IBIDFLD_" ////"_IBLO OK,DA=IBIN S D ^DIE . D UPDLOG( 1,IBDATE,I BINS,IBLOO K,IBTYP,IB ID) ;KDM U S129 IB*2* 577 I IBID '="",IBLOO K'="" D ; Bulletin that the i d on file and id ret urned . ; are differ ent . N XM TO,XMDUZ,X MBODY,IBXM ,XMSUBJ,XM Z . S XMTO ("I:G.IB E DI")="" . S XMDUZ="" ,XMBODY="I BXM",XMSUB J="PAYER I D RETURNED IS DIFFER ENT THAN P AYER ID ON FILE" . S IBXM(1)=" BILL # : " _$P($G(^DG CR(399,IBI FN,0)),U) . S IBXM(2 )="PAYER : "_$P($G(^ DIC(36,+IB INS,0)),U) . S IBXM( 3)="BILL T YPE : "_$S ($G(IBPID( "TYPE"))=" I":"INSTIT UT",1:"PRO FESS")_"IO NAL" . S I BXM(4)="ID ON FILE : "_IBID . S IBXM(5)= "ID RETURN ED: "_IBLO OK . S IBX M(6)=" ",I BXM(7)=" P lease dete rmine whic h id numbe r is corre ct and cor rect the i d in the", IBXM(8)="i nsurance f ile for th is payer, if needed" . D SENDM SG^XMXAPI( XMDUZ,XMSU BJ,XMBODY, .XMTO,,.XM Z) . D UPD LOG(0,IBDA TE,IBINS,I BLOOK,IBTY P,IBID) ;K DM US129, US976 IB*2 *577 ;UPDI NSQ Q ;UPD LOG(UPD,IB DATE,IBINS ,IBLOOK,IB TYP,IBID) ;KDM US129 , US976 IB *2*577 New section f or New Pay er Report ; store f lds for re porting pu rposes whe n updating or attemp ting to up date Payer informati on (US129) ; ^DIC(36 -17.0 277 EDI ID Num ber ; 17.0 1 277EDI I D Number ; 17.02 277 Date EDI I D Number ; 17.03 277 EDI Type ( P)ROF or ( I)nst ; 17 .04 277EDI ID NUMBER ON FILE ; if blank i t was an u pdate othe rwise it w as an atte mpted upda te. ; Q:( ($D(^DIC(3 6,"AEDIX", IBDATE,IBI NS,IBLOOK, IBTYP)))&( UPD=0)) ;s tore only one attemp t a day N ERROR,IBFD A,LEV S LE V="+2,"_IB INS_"," S IBFDA(36.0 17,LEV,.01 )=IBLOOK ;New Va lue from 2 77STAT S I BFDA(36.01 7,LEV,.02) =IBDATE ;Date tr ansaction is process ed S IBFDA (36.017,LE V,.03)=IBT YP ;" P" or "I" S IBFDA(36 .017,LEV,. 04)=$G(IBI D) ;Value already on file- if blank it w as an upda te, otherw ise attemp ted update D UPDATE^ DIE("","IB FDA","","E RROR") Q ; MSGLNSZ(MS G) ; Chang e Input Me ssage Line s to be no more than 70 charac ters long each ; ; I nput/Outpu t: MSG - a rray of In put Messag e Lines; t his is als o the Outp ut Message ; which i s an array of Conver ted Messag e Lines (w ith lines no more th an 70 char s each) ; N LN,XARY, XARYLN,CNT ,OUTMSG,TM PMSG,LDNGS P,LDNGSPN S LN="",CN T=0 F S L N=$O(MSG(L N)) Q:LN=" " D ; . ; Find any leading s paces in o riginal me ssage line , . ; to be used if line got split belo w . S TMPM SG=$$TRIM^ XLFSTR(MSG (LN),"L"," ") ;Trim Leading Sp aces . S L DNGSP=$P(M SG(LN),TMP MSG,1) ;ge t leading spaces if any . S LD NGSPN=$L(L DNGSP) S:L DNGSPN>30 LDNGSP=$E( LDNGSP,1,3 0) ;make s ure there are no mor e than 30 leading sp aces . ; Converts a single li ne to mult iple lines with a ma ximum widt h of 70 ea ch . ; If line is 70 chars or less, this call retu rns the ex act line . K XARY D FSTRNG^IBJ U1(TMPMSG, 70-LDNGSPN ,.XARY) . ; Scan lin es and mer ge them in to the fin al output array (OUT MSG) . ; O n lines 2 and higher , add Lead ing Spaces found abo ve, if any . . S XARY LN="" F S XARYLN=$O (XARY(XARY LN)) Q:XAR YLN="" S CNT=CNT+1, OUTMSG(CNT )=LDNGSP_X ARY(XARYLN ) ; ; Move the final Message L ines (OUTM SG) into M SG array t o be retur ned K MSG M MSG=OUTM SG Q ; | |
| 2761 | ||
| 2762 | ||
| 2763 | Routines | |
| 2764 | Activities | |
| 2765 | Routine Na me | |
| 2766 | IBCEU | |
| 2767 | Enhancemen t Category | |
| 2768 | New | |
| 2769 | Modify | |
| 2770 | Delete | |
| 2771 | No Change | |
| 2772 | RTM | |
| 2773 | ||
| 2774 | Related Op tions | |
| 2775 | None | |
| 2776 | Related Ro utines | |
| 2777 | Routines “ Called By” | |
| 2778 | Routines “ Called” | |
| 2779 | ||
| 2780 | ||
| 2781 | ||
| 2782 | ||
| 2783 | Data Dicti onary (DD) Reference s | |
| 2784 | ||
| 2785 | Related Pr otocols | |
| 2786 | None | |
| 2787 | Related In tegration Control Re gistration s (ICRs) | |
| 2788 | None | |
| 2789 | Data Passi ng | |
| 2790 | Input | |
| 2791 | Output Re ference | |
| 2792 | Both | |
| 2793 | Global Re ference | |
| 2794 | Local | |
| 2795 | Input Attr ibute Name and Defin ition | |
| 2796 | Name: | |
| 2797 | Definition : | |
| 2798 | Output Att ribute Nam e and Defi nition | |
| 2799 | Name: | |
| 2800 | Definition : | |
| 2801 | Current Lo gic | |
| 2802 | IBCEU ;ALB /TMP - EDI UTILITIES ;02-OCT-9 6 ;;2.0;IN TEGRATED B ILLING;**5 1,137,207, 232,349,43 2**;21-MAR -94;Build 192 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ; DBIA SU PPORTED RE F: GET^XUA 4A72 = 162 5 ; DBIA S UPPORTED R EF: $$ESBL OCK^XUSESI G1 = 1557 Q ;TESTPT( DFN) ; Det ermine if pt is test pt ; Retu rns 1 if a test pt, 0 if not Q $E($P($G( ^DPT(+DFN, 0)),U,9),1 ,5)="00000 " ;MAINPRV (IBIFN) ; Returns na me^id^ien^ type code of 'main' prov on bi ll IBIFN N IBPRV,IBC OB,IBQ,Z D GETPRV(IB IFN,"3,4", .IBPRV) S IBQ="",IBC OB=$$COBN^ IBCEF(IBIF N) F Z=3,4 I $G(IBPR V(Z,1))'=" " D Q . S IBQ=IBPRV (Z,1),$P(I BQ,U,4)=Z . I $G(IBP RV(Z,1,IBC OB))'="" S $P(IBQ,U, 2)=IBPRV(Z ,1,IBCOB) Q IBQ ;PRV OK(VAL,IBI FN) ; Chec k bill for m & prov f unction ag ree ; VAL = internal value of prov funct ion ; N OK ,IBBT S OK =0 Q:VAL=" " OK Q:'IB IFN OK S I BBT=$$FT^I BCEF(IBIFN ) ; 2 If C MS-1500, 3 If UB-04 I IBBT=2 D . I VAL=1 S OK=1 Q ; CMS-15 00, REFERR ING . I VA L=3 S OK=1 Q ; CMS -1500, REN DERING . I VAL=5 S O K=1 Q ; CMS-1500, SUPERVISIN G I 'OK,IB BT=3 D . I VAL=1 S O K=1 Q ; UB-04, REF ERRING . I VAL=2 S O K=1 Q ; UB-04, OPE RATING . I VAL=3 S O K=1 Q ; UB-04, REN DERING . I VAL=4 S O K=1 Q ; UB-04, ATT ENDING . I VAL=9 S O K=1 Q ; UB-04, OTH ER ; Q OK ;PRVOK1(VA L,IBIFN) ; Check for both atte nding and rendering on bill N OK S OK=1 Q:$$FT^IBC EF(IBIFN)= 3 1 ; both are allow ed on UB I $S("34"'[ VAL:0,1:$D (^DGCR(399 ,IBIFN,"PR V","B",$S( VAL=3:4,1: 3)))) D EN ^DDIOL($S( VAL=3:"ATT ENDING",1: "RENDERING ")_" ALREA DY EXISTS - CAN'T HA VE BOTH ON ONE BILL" ) S OK=0 Q OK ;SPEC( IBPRV,IBDT ) ; Return s spec cod e for vp i en IBPRV f rom file 3 55.9 ; (fo r new pers on entries , as of da te in IBDT ) ; DBIA 1 625 N IBSP EC S:'$G(I BDT) IBDT= DT I IBPRV '["IBA(355 .93" S IBS PEC=$S(IBP RV:$P($$GE T^XUA4A72( +IBPRV,IBD T),U,8),1: "") ; VA I IBPRV["IB A(355.93" S IBSPEC=$ P($G(^IBA( 355.93,+IB PRV,0)),U, 4) ; Non-V A Q IBSPEC ;CRED(IBP RV,IBIFN,I BPIEN,IBTY P) ; Retur ns prov cr edentials ; IBPRV = vp of prov ider for f ile 200 or 355.93 ; IBIFN = bi ll ien in file 399 ( optional) ; IBPIEN = prov ien - file 399 .0222 (opt ional) ; D EM;432 - p rov ien ca n be from file 399.0 404 ; as w ell (optio nal). ; IB TYP = the prov type ; N IBCRED S IBCRED= "" ; ; DEM ;432 - Pro vider can come from either fil e 399.0222 , or ; fil e 399.0404 . Variable IBLNPRV i s the flag ; that in dicates we want prov ien from file 399.0 404. ; I ' $G(IBLNPRV ),$G(IBIFN ),'$D(^DGC R(399,IBIF N,"PRV",0) ) G CREDQ ; ; DEM;43 2 - Next l ine if for line leve l provider . Variable IBPROCP, ; if it ex ist, is th e procedur e ien. Fil e 399.0404 is a ; mu ltiple of the Proced ure File 3 99.0304. ; I $G(IBLN PRV),$G(IB IFN),$G(IB PROCP),'$D (^DGCR(399 ,IBIFN,"CP ",IBPROCP, "LNPRV",0) ) G CREDQ I '$G(IBLN PRV),$G(IB IFN),($G(I BPIEN)!$G( IBTYP)) D . I '$G(IB PIEN) S IB PIEN=+$O(^ DGCR(399,I BIFN,"PRV" ,"B",IBTYP ,0)) . S I BCRED=$P($ G(^DGCR(39 9,IBIFN,"P RV",IBPIEN ,0)),U,3) ; I $G(IBL NPRV),$G(I BIFN),$G(I BPROCP),($ G(IBPIEN)! $G(IBTYP)) D ; DEM; 432 - Line Provider File 399.0 404. . I ' $G(IBPIEN) S IBPIEN= +$O(^DGCR( 399,IBIFN, "CP",IBPRO CP,"B",IBT YP,0)) . S IBCRED=$P ($G(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,IBPIEN,0) ),U,3) ;CR EDQ ; I $G (IBPRV),IB CRED="" D . I IBPRV' ["IBA(355. 93" S IBCR ED=$P($$ES BLOCK^XUSE SIG1(+IBPR V),U,2) . I IBPRV["I BA(355.93" S IBCRED= $P($G(^IBA (355.93,+I BPRV,0)),U ,3) Q IBCR ED ;GETPRV (IBIFN,IBT YP,IBPRV) ; Returns prov(s) of type(s) I BTYP for ; bill ien IBIFN. ; I BTYP = pro v types ne eded, sepa rated by ' ,' or ALL ; ; OUTPU T: ; IBPRV array: IB PRV(type)= 1 if prov is from o ld prov fl ds ; IBPRV (type,ct)= name^curre nt COB id^ vp provide r ien^cred ; IBPRV(t ype,ct,seq )=COB seq specific i d ; IBPRV( type)=defa ult nm^def id ; IBPR V(type,"NO TOPT")= de fined if a required prov type ; N IB,IBC T,IBD,IBY, IBZ,IBMRAN D,IBID,IBW NR,IBPNM,Z ;,IBZFID ;S IBZFID= "" D F^IBC EF("N-CURR ENT INS PO LICY TYPE" ,"IBZ",,IB IFN) ;I IB Z="CI" D F ^IBCEF("N- FEDERAL TA X ID","IBZ FID",,IBIF N) S IBZFI D=$TR(IBZF ID,"-") S IBPRV=U_$G (IBZ),IBY= 0 S IBMRAN D=$$MCRONB IL^IBEFUNC (IBIFN) ;W CJ;IB*2.0* 432;Remove Default I IBMRAND D .; F Z=1: 1:3,5,6,7, 8,9 S:Z=3& ($$FT^IBCE F(IBIFN)=3 ) Z=4 S IB PRV(Z)=$S( Z=3!(Z=4): "DEPT VETE RANS AFFAI RS",1:"")_ "^VAD000" . F Z=1:1: 9 S IBPRV( Z)="^VAD00 0" . I '$$ INPAT^IBCE F(IBIFN,1) ,$$FT^IBCE F(IBIFN)=3 S IBPRV(4 ,1)="^SLF0 00" ;WCJ;I B*2.0*432; End change s ; ; For backwards compatabil ity (befor e the clai m level pr ovider mul itple) I ' $D(^DGCR(3 99,+IBIFN, "PRV",0)) D G GETQ . N IBALL . S IBALL= (IBTYP="AL L") . I IB TYP[4!IBAL L S:$P($G( ^DGCR(399, +IBIFN,"U1 ")),U,13)' ="" IBPRV( 4,1)=$P(^( "U1"),U,13 ),IBPRV(4) =1 Q:IBTYP =4 . I IBT YP[3!IBALL S:$P($G(^ DGCR(399,+ IBIFN,"UF2 ")),U)'="" IBPRV(3,1 )=$P(^("UF 2"),U),IBP RV(3)=1 Q: IBTYP=3 . I IBTYP[9! IBALL S:$P ($G(^DGCR( 399,+IBIFN ,"U1")),U, 14)'="" IB PRV(9,1)=$ P(^("U1"), U,14),IBPR V(9)=1 ; S IBID=4+$$ COBN^IBCEF (IBIFN),IB WNR=$$WNRB ILL^IBEFUN C(IBIFN) F IBZ=1:1:$ S(IBTYP="A LL":99,1:$ L(IBTYP,", ")) S (IBC T,IB)=0,IB Y=$S(IBTYP '="ALL":$P (IBTYP,"," ,IBZ),1:$O (^DGCR(399 ,+IBIFN,"P RV","B",IB Y))) Q:IBY ="" F S IB=$O(^DGC R(399,+IBI FN,"PRV"," B",IBY,IB) ) Q:'IB D . S IBCT= IBCT+1 . S IBD=$G(^D GCR(399,+I BIFN,"PRV" ,IB,0)) . Q:'$P(IBD, U,2) . S I BPNM=$$EXP AND^IBTRE( 399.0222,. 02,$P(IBD, U,2)) . I IBWNR Q:'$ D(IBPRV(IB Y)) S $P(I BD,U,IBID) =$P(IBPRV( IBY),U,2) . S IBPRV( IBY,IBCT)= IBPNM_U_$S ($P(IBD,U, IBID)'="": $P(IBD,U,I BID),$P($G (IBPRV(IBY )),U,2)'=" ":$P(IBPRV (IBY),U,2) ,1:$P($$DE FID^IBCEF7 4(IBIFN,IB ),U,IBID-4 ))_U_$P(IB D,U,2) . S $P(IBPRV( IBY,IBCT), U,4)=$$CRE D($P(IBPRV (IBY,IBCT) ,U,3),IBIF N,$S($P(IB D,U,3)'="" !'$P(IBPRV (IBY,IBCT) ,U,3):IB,1 :"")) . F Z=1:1:3 D .. ;I IBZF ID'="",'$$ INPAT^IBCE F(IBIFN,1) ,$P(IBPRV( IBY,IBCT), U,2)="SLF0 00" S IBZF ID="" .. ; I $S(Z=1:1 ,1:$D(^DGC R(399,IBIF N,"I"_Z))) S IBPRV(I BY,IBCT,Z) =$S($G(IBZ FID)'="":I BZFID,$P(I BD,U,Z+4)' ="":$P(IBD ,U,Z+4),1: "") .. I $ S(Z=1:1,1: $D(^DGCR(3 99,IBIFN," I"_Z))) S IBPRV(IBY, IBCT,Z)=$S ($P(IBD,U, Z+4)'="":$ P(IBD,U,Z+ 4),1:$P($$ DEFID^IBCE F74(IBIFN, IB),U,Z))G ETQ D NEED PRV(IBIFN, IBTYP,.IBP RV) Q ;NEE DPRV(IBIFN ,IBTYP,IBP RV) ; Chec k for need ed prov ; If needed, not enter ed, insert defaults for MCR on ly N IB0,I BINP,IBFT, IBMRAND,IB TOB S IB0= $G(^DGCR(3 99,+IBIFN, 0)) S IBFT =($$FT^IBC EF(IBIFN)= 3),IBINP=$ $INPAT^IBC EF(IBIFN,1 ),IBTOB=$$ TOB^IBCBB( IB0) ; Onl y allow de faults for MCR S IBM RAND=$$WNR BILL^IBEFU NC(IBIFN) ;$$MCRONBI L^IBEFUNC( IBIFN) ; I IBTYP="AL L"!((IBTYP _",")["1," ) D . ; DE M;432 - UB -04 or CMS -1500 SITU ATIONAL . S IBPRV(1, "SITUATION AL")=1 . Q ; I IBTYP ="ALL"!((I BTYP_",")[ "2,") D:IB FT . ; onl y for bill type inpt - 11X, ou tpt - 83X . S IBPRV( 2,"SITUATI ONAL")=1 ; DEM;432 - Default t o "SITUATI ONAL". If conditions below are met, then IBPRV(2," SITUATIONA L") is KIL LED and IB RPV is SET according to condit ions. . Q: $S(IBINP:$ E(IBTOB,1, 2)'="11",1 :$E(IBTOB, 1,2)'="83" ) . ; UB-0 4 bill inc ludes HCPC S procs - operating phys situa tional . N Z . S Z=0 F S Z=$O (^DGCR(399 ,IBIFN,"CP ",Z)) Q:'Z I $P($G( ^(Z,0)),U) ["ICP" D Q .. K IBP RV(2,"SITU ATIONAL") ; DEM;432 - We have met one of the condt ions, so K ILL IBPRV( 2,"SITUATI ONAL"). . . I IBINP S IBPRV(2, "SITUATION AL")=1 Q ; DEM;432 - If UB-04 (inpatien t), then o perating p rovider si tuational. .. I 'IBI NP S IBPRV (2,"NOTOPT ")=1 ; DEM ;432 - If UB-04 (out patient), then opera ting provi der requir ed. .. Q:' IBMRAND .. I '$O(IBP RV(2,0)) S IBPRV(2," REQ")=1,IB PRV(2,1)=$ G(IBPRV(2) ) ; I IBTY P="ALL"!(( IBTYP_",") ["3,") D . ; if a CM S-1500 bil l, renderi ng is requ ired . I ' IBFT S IBP RV(3,"NOTO PT")=1 . ; DEM;432 - if UB-04, rendering is situat ional. . I IBFT S IB PRV(3,"SIT UATIONAL") =1 Q . Q:' IBMRAND . I '$O(IBPR V(3,0)) S IBPRV(3,1) =$G(IBPRV( 3)),IBPRV( 3,"REQ")=1 ; I IBTYP ="ALL"!((I BTYP_",")[ "4,") D:IB FT . ; if a UB-04, a ttending r equired . S IBPRV(4, "NOTOPT")= 1 . Q:'IBM RAND . I ' $O(IBPRV(4 ,0)) S IBP RV(4,1)=$G (IBPRV(4)) ,IBPRV(4," REQ")=1 Q ;CKPROV(IB IFN,IBTYP, IBVAL) ; C hecks if p rov of typ e IBTYP in 'PRV' nod e ; of bil l IBIFN ; If IBVAL = 1, skips the check for an exi sting prov ider, just looks ; f or existen ce of the function i tself N OK ,IBFT,Z,R S OK=0,IBF T=$$FT^IBC EF(IBIFN) S Z=+$O(^D GCR(399,IB IFN,"PRV", "B",+IBTYP ,0)) I $G( ^DGCR(399, IBIFN,"PRV ",Z,0))'=" " D . ; On ly outpt U B-04 can h ave SLF000 as prov I D with no name . I I BFT=3,'$$I NPAT^IBCEF (IBIFN,1), $P(^DGCR(3 99,IBIFN," PRV",Z,0), U,2)="",$P (^(0),U,5) ="SLF000" S OK=1 Q . I '$G(IBV AL) Q:$P(^ DGCR(399,I BIFN,"PRV" ,Z,0),U,2) ="" . S OK =1 Q OK ;X FER(IBQ) ; Transfer DILIST ; I BQ = # of entries al ready foun d N Z,IBZ S (Z,IBZ)= 0 F S Z=$ O(^TMP("DI LIST",$J,1 ,Z)) Q:'Z S IBZ=IBZ +1,^TMP("I BLIST",$J, 1,IBZ+IBQ) =^TMP("DIL IST",$J,1, Z),^TMP("I BLIST",$J, 2,IBZ+IBQ) =^TMP("DIL IST",$J,2, Z) M ^TMP( "IBLIST",$ J,"ID",IBZ +IBQ)=^TMP ("DILIST", $J,"ID",Z) ; I $D(^T MP("DILIST ",$J,0)) S ^TMP("IBL IST",$J,0) =^TMP("DIL IST",$J,0) S $P(^TMP ("IBLIST", $J,0),U)=I BQ+IBZ Q ; DATE(X) ; Convert da te X in YY YYMMDD or YYMMDD to FM format ; FP = fla g to indic ate if pas t or futur e dates ar e expected N %DT,Y I $L(X)=8,$ E(X,1,4)<2 100,$E(X,5 ,6)<13,$E( X,7,8)<32 S X=$E(X,1 ,4)-1700_$ E(X,5,8) G DTQ I $L( X)=6,$E(X, 3,4)<13,$E (X,5,6)<32 S X=$E(X, 3,4)_"/"_$ E(X,5,6)_" /"_$E(X,1, 2),%DT="N" D ^%DT I Y>0 S X=YD TQ Q X ;BC LASS(IBIFN ) ; Return s actual b ill classi f. code fr om ptr fld ; .25 in file 399 f or bill ie n IBIFN Q $P($G(^DGC R(399.1,+$ P($G(^DGCR (399,IBIFN ,0)),U,25) ,0)),U,2) ;ADMHR(IBI FN,IBDTTM) ; Extract admit hr from admit dt/tm ; D efault 00 if no time and bill is 11X or 18X N TM S TM=$P(IBD TTM,".",2) I TM=""," 18"[$$BCLA SS(IBIFN), $P($G(^DGC R(399,IBIF N,0)),U,24 )=1 S TM=" 00" I TM'= "",TM'="00 " S TM=$E( TM_"0000", 1,4) Q TM ;OLAB(IBIF N) ; Retur ns 1 if bi ll IBIFN i s outside lab N IBL, IBLAB S IB L=0 S IBLA B=$P($G(^D GCR(399,IB IFN,"U2")) ,U,11) I I BLAB,"24"[ IBLAB S IB L=1 Q IBL ;PSRV(IBIF N) ; Retur ns 1 if bi ll IBIFN h as any pur ch service s N IBZ,IB XDATA,IBXS AVE,Z S IB Z=0 D F^IB CEF("N-HCF A 1500 PRO CEDURES",, ,IBIFN) S Z=0 F S Z =$O(IBXSAV E("BOX24", Z)) Q:'Z I $P(IBXSA VE("BOX24" ,Z),U,11) S IBZ=1 Q Q IBZ ;SEQ BILL(IBIFN ) ; Return s the ien' s of all b ills in CO B sequence for bill IBIFN ; Re turn value is "^" de limited: p rimary ien ^secondary ien^terti ary ien N IBSEQ,Z S IBSEQ=$P($ G(^DGCR(39 9,IBIFN,"M 1")),U,5,7 ) S Z=$$CO BN^IBCEF(I BIFN) I $P (IBSEQ,U,Z )="" S $P( IBSEQ,U,Z) =IBIFN Q I BSEQ ; ;IB *2.0*432/T AZ Added t o take int o account the line l evel provi ders.GETPR V1(IBIFN,I BTYP,IBPRV ) ; Return s prov(s) of type(s) IBTYP for ; bill ie n IBIFN fo r TPJI dis play ; IBT YP = prov types need ed, separa ted by ',' or ALL ; ; OUTPUT: ; IBPRV a rray: IBPR V(level,ty pe,ct)=nam e^current COB id^vp provider i en^cred ; N IB,IBCT, IBD,IBY,IB Z,IBMRAND, IBID,IBWNR ,IBPNM,Z,I BPRTYP D F ^IBCEF("N- CURRENT IN S POLICY T YPE","IBZ" ,,IBIFN) S IBPRV=U_$ G(IBZ),IBY =0 D ALLID S^IBCEFP(I BIFN,.IBXS AVE) S IBC T=0 F S I BCT=$O(IBX SAVE("PROV INF",IBIFN ,"C",IBCT) ) Q:'IBCT D . S IBP RTYP="" . F S IBPRT YP=$O(IBXS AVE("PROVI NF",IBIFN, "C",IBCT,I BPRTYP)) Q :'IBPRTYP D .. I IB TYP'="ALL" ,IBTYP'[IB PRTYP Q ; Screen out unwanted providers .. N IBPRI EN,OBPRNM, IBCOBID .. S IBPRIEN =$P(IBXSAV E("PROVINF ",IBIFN,"C ",IBCT,IBP RTYP),U) . . S $P(IBP RV(1,IBCT, IBPRTYP),U ,1)=$$EXPA ND^IBTRE(3 99.0222,.0 2,IBPRIEN) .. S $P(I BPRV(1,IBC T,IBPRTYP) ,U,2)=IBXS AVE("PROVI NF",IBIFN, "C",IBCT,I BPRTYP,"CO BID") .. S $P(IBPRV( 1,IBCT,IBP RTYP),U,3) =IBPRIEN . . S $P(IBP RV(1,IBCT, IBPRTYP),U ,4)=$P(IBX SAVE("PROV INF",IBIFN ,"C",IBCT, IBPRTYP,"N AME"),U,4) S IBCT=0 F S IBCT= $O(IBXSAVE ("L-PROV", IBIFN,IBCT )) Q:'IBCT D . S IB PRTYP="" . F S IBPR TYP=$O(IBX SAVE("L-PR OV",IBIFN, IBCT,"C",1 ,IBPRTYP)) Q:'IBPRTY P D .. I IBTYP'="AL L",IBTYP'[ IBPRTYP Q ;Screen o ut unwante d provider s .. N IBP RIEN .. S IBPRIEN=$P (IBXSAVE(" L-PROV",IB IFN,IBCT," C",1,IBPRT YP),U) .. S IBPRV(2, IBCT,IBPRT YP)=$$EXPA ND^IBTRE(3 99.0222,.0 2,IBPRIEN) .. S $P(I BPRV(2,IBC T,IBPRTYP) ,U,2)=IBXS AVE("L-PRO V",IBIFN,I BCT,"C",1, IBPRTYP,"C OBID") .. S $P(IBPRV (2,IBCT,IB PRTYP),U,3 )=IBPRIEN .. S $P(IB PRV(2,IBCT ,IBPRTYP), U,4)=$P(IB XSAVE("L-P ROV",IBIFN ,IBCT,"C", 1,IBPRTYP, "NAME"),U, 4) Q | |
| 2803 | Modified L ogic (Chan ges are in bold) | |
| 2804 | IBCEU ;ALB /TMP - EDI UTILITIES ;02-OCT-9 6 ;;2.0;IN TEGRATED B ILLING;**5 1,137,207, 232,349,43 2,592**;21 -MAR-94;Bu ild 192 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ; DBI A SUPPORTE D REF: GET ^XUA4A72 = 1625 ; DB IA SUPPORT ED REF: $$ ESBLOCK^XU SESIG1 = 1 557 Q ;TES TPT(DFN) ; Determine if pt is test pt ; Returns 1 if a test pt, 0 if n ot Q $E($P ($G(^DPT(+ DFN,0)),U, 9),1,5)="0 0000" ;MAI NPRV(IBIFN ) ; Return s name^id^ ien^type c ode of 'ma in' prov o n bill IBI FN N IBPRV ,IBCOB,IBQ ,Z D GETPR V(IBIFN,"3 ,4",.IBPRV ) S IBQ="" ,IBCOB=$$C OBN^IBCEF( IBIFN) F Z =3,4 I $G( IBPRV(Z,1) )'="" D Q . S IBQ=I BPRV(Z,1), $P(IBQ,U,4 )=Z . I $G (IBPRV(Z,1 ,IBCOB))'= "" S $P(IB Q,U,2)=IBP RV(Z,1,IBC OB) Q IBQ ;PRVOK(VAL ,IBIFN) ; Check bill form & pr ov functio n agree ; VAL = inte rnal value of prov f unction ; N OK,IBBT S OK=0 Q:V AL="" OK Q :'IBIFN OK ; JWS;IB* 2.0*592 US 1108 - add Dental fo rm (7) che ck S IBBT= $$FT^IBCEF (IBIFN) ; 2 If CMS-1 500, 3 If UB-04, 7 i f J430D De ntal I IBB T=2!(IBBT= 7) D . I V AL=1 S OK= 1 Q ; CM S-1500, RE FERRING . I VAL=3 S OK=1 Q ; CMS-1500, RENDERING . I VAL=5 S OK=1 Q ; CMS-15 00, SUPERV ISING . I IBBT=7,VAL =6 S OK=1 Q ;J430D, ASSISTANT SURGEON ; JWS;IB*2. 0*592 US11 08 - end I 'OK,IBBT= 3 D . I VA L=1 S OK=1 Q ; UB- 04, REFERR ING . I VA L=2 S OK=1 Q ; UB- 04, OPERAT ING . I VA L=3 S OK=1 Q ; UB- 04, RENDER ING . I VA L=4 S OK=1 Q ; UB- 04, ATTEND ING . I VA L=9 S OK=1 Q ; UB- 04, OTHER ; Q OK ;PR VOK1(VAL,I BIFN) ; Ch eck for bo th attendi ng and ren dering on bill N OK S OK=1 Q:$ $FT^IBCEF( IBIFN)=3 1 ; both ar e allowed on UB I $S ("34"'[VAL :0,1:$D(^D GCR(399,IB IFN,"PRV", "B",$S(VAL =3:4,1:3)) )) D EN^DD IOL($S(VAL =3:"ATTEND ING",1:"RE NDERING")_ " ALREADY EXISTS - C AN'T HAVE BOTH ON ON E BILL") S OK=0 Q OK ;SPEC(IBP RV,IBDT) ; Returns s pec code f or vp ien IBPRV from file 355. 9 ; (for n ew person entries, a s of date in IBDT) ; DBIA 1625 N IBSPEC S:'$G(IBDT ) IBDT=DT I IBPRV'[" IBA(355.93 " S IBSPEC =$S(IBPRV: $P($$GET^X UA4A72(+IB PRV,IBDT), U,8),1:"") ; VA I IB PRV["IBA(3 55.93" S I BSPEC=$P($ G(^IBA(355 .93,+IBPRV ,0)),U,4) ; Non-VA Q IBSPEC ;C RED(IBPRV, IBIFN,IBPI EN,IBTYP) ; Returns prov crede ntials ; I BPRV = vp of provide r for file 200 or 35 5.93 ; IBI FN = bill ien in fil e 399 (opt ional) ; I BPIEN = pr ov ien - f ile 399.02 22 (option al) ; DEM; 432 - prov ien can b e from fil e 399.0404 ; as well (optional ). ; IBTYP = the pro v type ; N IBCRED S IBCRED="" ; ; DEM;43 2 - Provid er can com e from eit her file 3 99.0222, o r ; file 3 99.0404. V ariable IB LNPRV is t he flag ; that indic ates we wa nt prov ie n from fil e 399.0404 . ; I '$G( IBLNPRV),$ G(IBIFN),' $D(^DGCR(3 99,IBIFN," PRV",0)) G CREDQ ; ; DEM;432 - Next line if for li ne level p rovider. V ariable IB PROCP, ; i f it exist , is the p rocedure i en. File 3 99.0404 is a ; multi ple of the Procedure File 399. 0304. ; I $G(IBLNPRV ),$G(IBIFN ),$G(IBPRO CP),'$D(^D GCR(399,IB IFN,"CP",I BPROCP,"LN PRV",0)) G CREDQ I ' $G(IBLNPRV ),$G(IBIFN ),($G(IBPI EN)!$G(IBT YP)) D . I '$G(IBPIE N) S IBPIE N=+$O(^DGC R(399,IBIF N,"PRV","B ",IBTYP,0) ) . S IBCR ED=$P($G(^ DGCR(399,I BIFN,"PRV" ,IBPIEN,0) ),U,3) ; I $G(IBLNPR V),$G(IBIF N),$G(IBPR OCP),($G(I BPIEN)!$G( IBTYP)) D ; DEM;432 - Line Pr ovider Fil e 399.0404 . . I '$G( IBPIEN) S IBPIEN=+$O (^DGCR(399 ,IBIFN,"CP ",IBPROCP, "B",IBTYP, 0)) . S IB CRED=$P($G (^DGCR(399 ,IBIFN,"CP ",IBPROCP, "LNPRV",IB PIEN,0)),U ,3) ;CREDQ ; I $G(IB PRV),IBCRE D="" D . I IBPRV'["I BA(355.93" S IBCRED= $P($$ESBLO CK^XUSESIG 1(+IBPRV), U,2) . I I BPRV["IBA( 355.93" S IBCRED=$P( $G(^IBA(35 5.93,+IBPR V,0)),U,3) Q IBCRED ;GETPRV(IB IFN,IBTYP, IBPRV) ; R eturns pro v(s) of ty pe(s) IBTY P for ; bi ll ien IBI FN. ; IBTY P = prov t ypes neede d, separat ed by ',' or ALL ; ; OUTPUT: ; IBPRV ar ray: IBPRV (type)= 1 if prov is from old prov flds ; IBPRV(ty pe,ct)=nam e^current COB id^vp provider i en^cred ; IBPRV(type ,ct,seq)=C OB seq spe cific id ; IBPRV(typ e)=default nm^def id ; IBPRV(t ype,"NOTOP T")= defin ed if a re quired pro v type ; N IB,IBCT,I BD,IBY,IBZ ,IBMRAND,I BID,IBWNR, IBPNM,Z ;, IBZFID ;S IBZFID="" D F^IBCEF( "N-CURRENT INS POLIC Y TYPE","I BZ",,IBIFN ) ;I IBZ=" CI" D F^IB CEF("N-FED ERAL TAX I D","IBZFID ",,IBIFN) S IBZFID=$ TR(IBZFID, "-") S IBP RV=U_$G(IB Z),IBY=0 S IBMRAND=$ $MCRONBIL^ IBEFUNC(IB IFN) ;WCJ; IB*2.0*432 ;Remove De fault I IB MRAND D . ; F Z=1:1: 3,5,6,7,8, 9 S:Z=3&($ $FT^IBCEF( IBIFN)=3) Z=4 S IBPR V(Z)=$S(Z= 3!(Z=4):"D EPT VETERA NS AFFAIRS ",1:"")_"^ VAD000" . F Z=1:1:9 S IBPRV(Z) ="^VAD000" . I '$$IN PAT^IBCEF( IBIFN,1),$ $FT^IBCEF( IBIFN)=3 S IBPRV(4,1 )="^SLF000 " ;WCJ;IB* 2.0*432;En d changes ; ; For ba ckwards co mpatabilit y (before the claim level prov ider mulit ple) I '$D (^DGCR(399 ,+IBIFN,"P RV",0)) D G GETQ . N IBALL . S IBALL=(I BTYP="ALL" ) . I IBTY P[4!IBALL S:$P($G(^D GCR(399,+I BIFN,"U1") ),U,13)'=" " IBPRV(4, 1)=$P(^("U 1"),U,13), IBPRV(4)=1 Q:IBTYP=4 . I IBTYP [3!IBALL S :$P($G(^DG CR(399,+IB IFN,"UF2") ),U)'="" I BPRV(3,1)= $P(^("UF2" ),U),IBPRV (3)=1 Q:IB TYP=3 . I IBTYP[9!IB ALL S:$P($ G(^DGCR(39 9,+IBIFN," U1")),U,14 )'="" IBPR V(9,1)=$P( ^("U1"),U, 14),IBPRV( 9)=1 ; S I BID=4+$$CO BN^IBCEF(I BIFN),IBWN R=$$WNRBIL L^IBEFUNC( IBIFN) F I BZ=1:1:$S( IBTYP="ALL ":99,1:$L( IBTYP,",") ) S (IBCT, IB)=0,IBY= $S(IBTYP'= "ALL":$P(I BTYP,",",I BZ),1:$O(^ DGCR(399,+ IBIFN,"PRV ","B",IBY) )) Q:IBY=" " F S IB =$O(^DGCR( 399,+IBIFN ,"PRV","B" ,IBY,IB)) Q:'IB D . S IBCT=IB CT+1 . S I BD=$G(^DGC R(399,+IBI FN,"PRV",I B,0)) . Q: '$P(IBD,U, 2) . S IBP NM=$$EXPAN D^IBTRE(39 9.0222,.02 ,$P(IBD,U, 2)) . I IB WNR Q:'$D( IBPRV(IBY) ) S $P(IBD ,U,IBID)=$ P(IBPRV(IB Y),U,2) . S IBPRV(IB Y,IBCT)=IB PNM_U_$S($ P(IBD,U,IB ID)'="":$P (IBD,U,IBI D),$P($G(I BPRV(IBY)) ,U,2)'="": $P(IBPRV(I BY),U,2),1 :$P($$DEFI D^IBCEF74( IBIFN,IB), U,IBID-4)) _U_$P(IBD, U,2) . S $ P(IBPRV(IB Y,IBCT),U, 4)=$$CRED( $P(IBPRV(I BY,IBCT),U ,3),IBIFN, $S($P(IBD, U,3)'=""!' $P(IBPRV(I BY,IBCT),U ,3):IB,1:" ")) . F Z= 1:1:3 D .. ;I IBZFID '="",'$$IN PAT^IBCEF( IBIFN,1),$ P(IBPRV(IB Y,IBCT),U, 2)="SLF000 " S IBZFID ="" .. ;I $S(Z=1:1,1 :$D(^DGCR( 399,IBIFN, "I"_Z))) S IBPRV(IBY ,IBCT,Z)=$ S($G(IBZFI D)'="":IBZ FID,$P(IBD ,U,Z+4)'=" ":$P(IBD,U ,Z+4),1:"" ) .. I $S( Z=1:1,1:$D (^DGCR(399 ,IBIFN,"I" _Z))) S IB PRV(IBY,IB CT,Z)=$S($ P(IBD,U,Z+ 4)'="":$P( IBD,U,Z+4) ,1:$P($$DE FID^IBCEF7 4(IBIFN,IB ),U,Z))GET Q D NEEDPR V(IBIFN,IB TYP,.IBPRV ) Q ;NEEDP RV(IBIFN,I BTYP,IBPRV ) ; Check for needed prov ; If needed, n ot entered , insert d efaults fo r MCR only N IB0,IBI NP,IBFT,IB MRAND,IBTO B S IB0=$G (^DGCR(399 ,+IBIFN,0) ) S IBFT=( $$FT^IBCEF (IBIFN)=3) ,IBINP=$$I NPAT^IBCEF (IBIFN,1), IBTOB=$$TO B^IBCBB(IB 0) ; Only allow defa ults for M CR S IBMRA ND=$$WNRBI LL^IBEFUNC (IBIFN) ;$ $MCRONBIL^ IBEFUNC(IB IFN) ; I I BTYP="ALL" !((IBTYP_" ,")["1,") D . ; DEM; 432 - UB-0 4 or CMS-1 500 SITUAT IONAL . S IBPRV(1,"S ITUATIONAL ")=1 . Q ; I IBTYP=" ALL"!((IBT YP_",")["2 ,") D:IBFT . ; only for bill t ype inpt - 11X, outp t - 83X . S IBPRV(2, "SITUATION AL")=1 ; D EM;432 - D efault to "SITUATION AL". If co nditions b elow are m et, then I BPRV(2,"SI TUATIONAL" ) is KILLE D and IBRP V is SET a ccording t o conditio ns. . Q:$S (IBINP:$E( IBTOB,1,2) '="11",1:$ E(IBTOB,1, 2)'="83") . ; UB-04 bill inclu des HCPCS procs - op erating ph ys situati onal . N Z . S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z I $P($G(^( Z,0)),U)[" ICP" D Q .. K IBPRV (2,"SITUAT IONAL") ; DEM;432 - We have me t one of t he condtio ns, so KIL L IBPRV(2, "SITUATION AL"). .. I IBINP S IBPRV(2,"S ITUATIONAL ")=1 Q ; DEM;432 - If UB-04 ( inpatient) , then ope rating pro vider situ ational. . . I 'IBINP S IBPRV(2 ,"NOTOPT") =1 ; DEM;4 32 - If UB -04 (outpa tient), th en operati ng provide r required . .. Q:'IB MRAND .. I '$O(IBPRV (2,0)) S I BPRV(2,"RE Q")=1,IBPR V(2,1)=$G( IBPRV(2)) ; I IBTYP= "ALL"!((IB TYP_",")[" 3,") D . ; if a CMS- 1500 bill, rendering is requir ed . ; JWS ;IB*2.0*59 2 US1108 - exclude d ental form . I 'IBFT ,$$FT^IBCE F(IBIFN)'= 7 S IBPRV( 3,"NOTOPT" )=1 . ; DE M;432 - if UB-04, re ndering is situation al. . ; JW S;IB*2.0*5 92 US1108 - dental f orm check . I IBFT!( $$FT^IBCEF (IBIFN)=7) S IBPRV(3 ,"SITUATIO NAL")=1 Q . Q:'IBMRA ND . I '$O (IBPRV(3,0 )) S IBPRV (3,1)=$G(I BPRV(3)),I BPRV(3,"RE Q")=1 ; I IBTYP="ALL "!((IBTYP_ ",")["4,") D:IBFT . ; if a UB- 04, attend ing requir ed . S IBP RV(4,"NOTO PT")=1 . Q :'IBMRAND . I '$O(IB PRV(4,0)) S IBPRV(4, 1)=$G(IBPR V(4)),IBPR V(4,"REQ") =1 Q ;CKPR OV(IBIFN,I BTYP,IBVAL ) ; Checks if prov o f type IBT YP in 'PRV ' node ; o f bill IBI FN ; If IB VAL = 1, s kips the c heck for a n existing provider, just look s ; for ex istence of the funct ion itself N OK,IBFT ,Z,R S OK= 0,IBFT=$$F T^IBCEF(IB IFN) S Z=+ $O(^DGCR(3 99,IBIFN," PRV","B",+ IBTYP,0)) I $G(^DGCR (399,IBIFN ,"PRV",Z,0 ))'="" D . ; Only ou tpt UB-04 can have S LF000 as p rov ID wit h no name . I IBFT=3 ,'$$INPAT^ IBCEF(IBIF N,1),$P(^D GCR(399,IB IFN,"PRV", Z,0),U,2)= "",$P(^(0) ,U,5)="SLF 000" S OK= 1 Q . I '$ G(IBVAL) Q :$P(^DGCR( 399,IBIFN, "PRV",Z,0) ,U,2)="" . S OK=1 Q OK ;XFER(I BQ) ; Tran sfer DILIS T ; IBQ = # of entri es already found N Z ,IBZ S (Z, IBZ)=0 F S Z=$O(^TM P("DILIST" ,$J,1,Z)) Q:'Z S IB Z=IBZ+1,^T MP("IBLIST ",$J,1,IBZ +IBQ)=^TMP ("DILIST", $J,1,Z),^T MP("IBLIST ",$J,2,IBZ +IBQ)=^TMP ("DILIST", $J,2,Z) M ^TMP("IBLI ST",$J,"ID ",IBZ+IBQ) =^TMP("DIL IST",$J,"I D",Z) ; I $D(^TMP("D ILIST",$J, 0)) S ^TMP ("IBLIST", $J,0)=^TMP ("DILIST", $J,0) S $P (^TMP("IBL IST",$J,0) ,U)=IBQ+IB Z Q ;DATE( X) ; Conve rt date X in YYYYMMD D or YYMMD D to FM fo rmat ; FP = flag to indicate i f past or future dat es are exp ected N %D T,Y I $L(X )=8,$E(X,1 ,4)<2100,$ E(X,5,6)<1 3,$E(X,7,8 )<32 S X=$ E(X,1,4)-1 700_$E(X,5 ,8) G DTQ I $L(X)=6, $E(X,3,4)< 13,$E(X,5, 6)<32 S X= $E(X,3,4)_ "/"_$E(X,5 ,6)_"/"_$E (X,1,2),%D T="N" D ^% DT I Y>0 S X=YDTQ Q X ;BCLASS( IBIFN) ; R eturns act ual bill c lassif. co de from pt r fld ; .2 5 in file 399 for bi ll ien IBI FN Q $P($G (^DGCR(399 .1,+$P($G( ^DGCR(399, IBIFN,0)), U,25),0)), U,2) ;ADMH R(IBIFN,IB DTTM) ; Ex tract admi t hr from admit dt/t m ; Defaul t 00 if no time and bill is 11 X or 18X N TM S TM=$ P(IBDTTM," .",2) I TM ="","18"[$ $BCLASS(IB IFN),$P($G (^DGCR(399 ,IBIFN,0)) ,U,24)=1 S TM="00" I TM'="",TM '="00" S T M=$E(TM_"0 000",1,4) Q TM ;OLAB (IBIFN) ; Returns 1 if bill IB IFN is out side lab N IBL,IBLAB S IBL=0 S IBLAB=$P( $G(^DGCR(3 99,IBIFN," U2")),U,11 ) I IBLAB, "24"[IBLAB S IBL=1 Q IBL ;PSRV (IBIFN) ; Returns 1 if bill IB IFN has an y purch se rvices N I BZ,IBXDATA ,IBXSAVE,Z S IBZ=0 D F^IBCEF(" N-HCFA 150 0 PROCEDUR ES",,,IBIF N) S Z=0 F S Z=$O(I BXSAVE("BO X24",Z)) Q :'Z I $P( IBXSAVE("B OX24",Z),U ,11) S IBZ =1 Q Q IBZ ;SEQBILL( IBIFN) ; R eturns the ien's of all bills in COB seq uence for bill IBIFN ; Return value is " ^" delimit ed: primar y ien^seco ndary ien^ tertiary i en N IBSEQ ,Z S IBSEQ =$P($G(^DG CR(399,IBI FN,"M1")), U,5,7) S Z =$$COBN^IB CEF(IBIFN) I $P(IBSE Q,U,Z)="" S $P(IBSEQ ,U,Z)=IBIF N Q IBSEQ ; ;IB*2.0* 432/TAZ Ad ded to tak e into acc ount the l ine level providers. GETPRV1(IB IFN,IBTYP, IBPRV) ; R eturns pro v(s) of ty pe(s) IBTY P for ; bi ll ien IBI FN for TPJ I display ; IBTYP = prov types needed, s eparated b y ',' or A LL ; ; OU TPUT: ; IB PRV array: IBPRV(lev el,type,ct )=name^cur rent COB i d^vp provi der ien^cr ed ; N IB, IBCT,IBD,I BY,IBZ,IBM RAND,IBID, IBWNR,IBPN M,Z,IBPRTY P D F^IBCE F("N-CURRE NT INS POL ICY TYPE", "IBZ",,IBI FN) S IBPR V=U_$G(IBZ ),IBY=0 D ALLIDS^IBC EFP(IBIFN, .IBXSAVE) S IBCT=0 F S IBCT=$ O(IBXSAVE( "PROVINF", IBIFN,"C", IBCT)) Q:' IBCT D . S IBPRTYP= "" . F S IBPRTYP=$O (IBXSAVE(" PROVINF",I BIFN,"C",I BCT,IBPRTY P)) Q:'IBP RTYP D .. I IBTYP'= "ALL",IBTY P'[IBPRTYP Q ;Scree n out unwa nted provi ders .. N IBPRIEN,OB PRNM,IBCOB ID .. S IB PRIEN=$P(I BXSAVE("PR OVINF",IBI FN,"C",IBC T,IBPRTYP) ,U) .. S $ P(IBPRV(1, IBCT,IBPRT YP),U,1)=$ $EXPAND^IB TRE(399.02 22,.02,IBP RIEN) .. S $P(IBPRV( 1,IBCT,IBP RTYP),U,2) =IBXSAVE(" PROVINF",I BIFN,"C",I BCT,IBPRTY P,"COBID") .. S $P(I BPRV(1,IBC T,IBPRTYP) ,U,3)=IBPR IEN .. S $ P(IBPRV(1, IBCT,IBPRT YP),U,4)=$ P(IBXSAVE( "PROVINF", IBIFN,"C", IBCT,IBPRT YP,"NAME") ,U,4) S IB CT=0 F S IBCT=$O(IB XSAVE("L-P ROV",IBIFN ,IBCT)) Q: 'IBCT D . S IBPRTYP ="" . F S IBPRTYP=$ O(IBXSAVE( "L-PROV",I BIFN,IBCT, "C",1,IBPR TYP)) Q:'I BPRTYP D .. I IBTYP '="ALL",IB TYP'[IBPRT YP Q ;Scr een out un wanted pro viders .. N IBPRIEN .. S IBPRI EN=$P(IBXS AVE("L-PRO V",IBIFN,I BCT,"C",1, IBPRTYP),U ) .. S IBP RV(2,IBCT, IBPRTYP)=$ $EXPAND^IB TRE(399.02 22,.02,IBP RIEN) .. S $P(IBPRV( 2,IBCT,IBP RTYP),U,2) =IBXSAVE(" L-PROV",IB IFN,IBCT," C",1,IBPRT YP,"COBID" ) .. S $P( IBPRV(2,IB CT,IBPRTYP ),U,3)=IBP RIEN .. S $P(IBPRV(2 ,IBCT,IBPR TYP),U,4)= $P(IBXSAVE ("L-PROV", IBIFN,IBCT ,"C",1,IBP RTYP,"NAME "),U,4) Q ;/IB*2.0*5 92RTYPOK(V AL,IBIFN) ;sceen for field 399 ,285 Attac hment Repo rt Type - Check for a valid Re port Type depending on Claim T ype ; VAL = internal value of report typ e file#353 .3 ; IBIFN = file 39 9 ien ; N OK,IBBT S OK=0 Q:VAL ="" OK Q:' IBIFN OK S IBBT=$$FT ^IBCEF(IBI FN) ;2 if CMS-1500, 3 if UB-04 , 7 if J43 0D Dental I IBBT'=7 S:VAL'="P6 " OK=1 Q O K ;not a Dental Cla im, period ontal char ts not app licable ; following for Dental claims I "^B4^DA^DG ^EB^OZ^P6^ RB^RR^"[(U _VAL_U) S OK=1 Q OK ; IB*2.0*5 92 end ; | |
| 2805 | ||
| 2806 | ||
| 2807 | Routines | |
| 2808 | Activities | |
| 2809 | Routine Na me | |
| 2810 | IBCEU0 | |
| 2811 | Enhancemen t Category | |
| 2812 | New | |
| 2813 | Modify | |
| 2814 | Delete | |
| 2815 | No Change | |
| 2816 | RTM | |
| 2817 | ||
| 2818 | Related Op tions | |
| 2819 | None | |
| 2820 | Related Ro utines | |
| 2821 | Routines “ Called By” | |
| 2822 | Routines “ Called” | |
| 2823 | ||
| 2824 | ||
| 2825 | ||
| 2826 | ||
| 2827 | Data Dicti onary (DD) Reference s | |
| 2828 | ||
| 2829 | Related Pr otocols | |
| 2830 | None | |
| 2831 | Related In tegration Control Re gistration s (ICRs) | |
| 2832 | None | |
| 2833 | Data Passi ng | |
| 2834 | Input | |
| 2835 | Output Re ference | |
| 2836 | Both | |
| 2837 | Global Re ference | |
| 2838 | Local | |
| 2839 | Input Attr ibute Name and Defin ition | |
| 2840 | Name: | |
| 2841 | Definition : | |
| 2842 | Output Att ribute Nam e and Defi nition | |
| 2843 | Name: | |
| 2844 | Definition : | |
| 2845 | Current Lo gic | |
| 2846 | IBCEU0 ;AL B/TMP - ED I UTILITIE S ;02-OCT- 96 ;;2.0;I NTEGRATED BILLING;** 137,197,15 5,296,349, 417,432**; 21-MAR-94; Build 192 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ;NO TECHG(IBDA ,IBNTEXT) ; Enter wh o/when rev iew stat c hange was entered ; IBDA = ien of entry in file 36 1.1 ; IBNT EXT = arra y containi ng the lin es of text to store if not usi ng the ; d efault tex t IBNTEXT = # of lin es IBNTEXT (#)=line t ext N IBIE N,IBTEXT,D A,X,Y,DIC, DO,DLAYGO, DD S DA(1) =IBDA,DIC= "^IBM(361. 1,"_DA(1)_ ",2,",DIC( 0)="L",DLA YGO=361.12 1 S X=$$NO W^XLFDT D FILE^DICN K DIC,DD,D O,DLAYGO Q :Y'>0 S DA (2)=DA(1), DA(1)=+Y,I BIEN=DA(1) _","_DA(2) _"," I $G( IBNTEXT) D . M IBTEX T=IBNTEXT E D . S I BTEXT(1)=" REVIEW STA TUS CHANGE D TO '"_$$ EXTERNAL^D ILFD(361.1 ,.2,,$P(^I BM(361.1,D A(2),0),U, 20))_"' BY : "_$$EXTE RNAL^DILFD (361.121,. 02,,+$G(DU Z)) D WP^D IE(361.121 ,IBIEN,.03 ,,"IBTEXT" ) K ^TMP(" DIERR",$J) Q ;LOCK(I BFILE,IBRE C) ; Lock record # I BREC in fi le #IBFILE (361 or 3 61.1) N OK S OK=0 L +^IBM(IBFI LE,IBREC): 3 I $T S O K=1 I 'OK D . W !,"A nother use r has lock ed this re cord - try again lat er" . D PA USE^VALM1 Q OK ;UNLO CK(IBFILE, IBREC) ; U nlock reco rd # IBREC in file # IBFILE I $ G(IBREC) L -^IBM(IBF ILE,IBREC) Q ;MSTAT ; Enter re viewed by selected r ange N IBD AX,IBA,IBC LOSE,IBLOO K,IBOK,IBS TOP,IBREBL D,IBCLOK,D A,DIR,X,Y, DIE,DR D F ULL^VALM1 D SEL^IBCE CSA4(.IBDA X) S IBREB LD=0 I $O( IBDAX("")) ="" G MSTA TQ S DIR(" ?,1")="ONL Y SELECT T O CLOSE TH E TRANSMIT RECORDS I F YOU KNOW THESE ARE THE FINAL ",DIR("?", 2)=" ELECT RONIC MESS AGES YOU W ILL RECEIV E FOR ALL THE BILLS REFERENCED BY",DIR(" ?")=" THES E MESSAGES " S DIR(0) ="YA",DIR( "A",1)="DO YOU WANT TO AUTOMAT ICALLY CLO SE THE TRA NSMIT RECO RDS FOR AN Y MESSAGES ",DIR("A") =" THAT AR EN'T REJEC TS?: ",DIR ("B")="NO" W ! D ^DI R K DIR W ! G:$D(DIR UT) MSTATQ S IBCLOSE =(Y=1) S D IR(0)="YA" ,DIR("A")= "DO YOU WA NT TO SEE EACH MESSA GE BEFORE MARKING IT REVIEWED? : ",DIR("B ")="NO" S DIR("?",1) ="IF YOU O PT TO SEE EACH MESSA GE, YOU CA N CONTROL WHETHER OR NOT THE M ESSAGE",DI R("?",2)=" IS MARKED AS REVIEW ED" I 'IBC LOSE S DIR ("?")=DIR( "?",2) K D IR("?",2) I IBCLOSE S DIR("?", 2)=DIR("?" ,2)_" AND, FOR NON-R EJECTS, WH ETHER OR N OT TO CLOS E THE",DIR ("?")=" TR ANSMIT REC ORD FOR TH E BILL" W ! D ^DIR K DIR W ! G :$D(DIRUT) MSTATQ S IBLOOK=(Y= 1) S IBDAX =0,IBSTOP= 0 F S IBD AX=+$O(IBD AX(IBDAX)) Q:'IBDAX D Q:IBST OP . S IBA =$G(IBDAX( IBDAX)) . S DIE="^IB M(361,",DA =$P(IBA,U, 2),DR="" . I DA D .. S IBOK=1 .. S IBCLO K=$S(IBCLO SE:1,1:0) .. I IBLOO K D Q:'IB OK ... S D IC="^IBM(3 61," D EN^ DIQ ... I '$$LOCK(36 1,DA) W ! S IBOK=0 Q ... S DIR (0)="YA",D IR("A")="O K TO MARK REVIEWED?: ",DIR("B" )="YES",DI R("?",1)=" IF YOU ENT ER YES, TH IS MESSAGE WILL BE M ARKED REVI EWED" ... S DIR("?", 2)="IF YOU ENTER NO, THIS MESS AGE WILL N OT BE ALTE RED",DIR(" ?",3)="IF YOU ENTER AN ^, THIS MESSAGE W ILL NOT BE ALTERED & NONE OF T HE",DIR("? ")=" REMAI NING MESSA GES WILL B E PROCESSE D" D ^DIR K DIR ... I Y'>0 S I BOK=0 S:$D (DIRUT) IB STOP=1 Q . .. I 'IBCL OSE D .... S DIR(0)= "YA",DIR(" A")="OK TO CLOSE THI S BILL'S T RANSMIT RE CORD?: ",D IR("B")="N O" .... S DIR("?",1) ="If you r espond YES to this p rompt, the transmit status of this bill will",DIR( "?",2)=" b e set to C LOSED. No further el ectronic p rocessing of this bi ll will be " .... S D IR("?",3)= " allowed. If you re spond NO t o this pro mpt, this electronic message w ill",DIR(" ?",4)=" be filed as reviewed, but the bi ll's trans mit status will not be changed ." .... S DIR("?",5) =" You may wish to p eriodicall y print a list of bi lls with a non-final ",DIR("?", 6)=" (clos ed/cancell ed/etc) st atus to en sure the e lectronic processing of all" . ... S DIR( "?",7)=" b ills has b een comple ted. Closi ng the tra nsmit bill record he re will",D IR("?")=" eliminate the bill f rom this l ist." .... W ! D ^DI R K DIR W ! .... I Y '=1 S IBCL OK=0 .. I 'IBLOOK,$P ($G(^IBM(3 61,DA,0)), U,3)="R" D Q:'IBOK ... S DR=" 1",DIC="^I BM(361," D EN^DIQ W !,"Bill Nu mber: ",$$ EXPAND^IBT RE(361,.01 ,+^IBM(361 ,DA,0)) .. . S DIR(0) ="YA",DIR( "A")="THIS IS A REJE CTION ... ARE YOU SU RE YOU WAN T TO MARK IT REVIEWE D?: ",DIR( "B")="NO" ... S DIR( "?",1)="IF YOU ENTER YES, THIS MESSAGE W ILL BE MAR KED REVIEW ED" ... S DIR("?",2) ="IF YOU E NTER NO, T HIS MESSAG E WILL NOT BE ALTERE D",DIR("?" ,3)="IF YO U ENTER AN ^, THIS M ESSAGE WIL L NOT BE A LTERED & N ONE OF THE ",DIR("?") =" MESSAGE S FOLLOWIN G THIS ONE WILL BE P ROCESSED" D ^DIR K D IR ... I Y '=1 S IBOK =0 S:$D(DI RUT) IBSTO P=1 .. S:' IBREBLD IB REBLD=1 .. S DR=".09 ////2;.1// //F" D ^DI E .. N IBU PD .. S IB UPD=0 .. I $$PRINTUP D($G(^IBM( 361,DA,1,1 ,0)),+$P(^ IBM(361,DA ,0),U,11)) S IBUPD=1 .. I $G(^ IBM(361,DA ,1,1,0))[" CLAIM SENT TO PAYER" D UPDTX^I BCECSA2(+$ P(^IBM(361 ,DA,0),U,1 1),$S(IBCL OK:"Z",1:" A2")) S IB UPD=1 .. I $G(^IBM(3 61,DA,1,1, 0))["CLAIM REJECTED" D UPDTX^I BCECSA2(+$ P(^IBM(361 ,DA,0),U,1 1),"E") S IBUPD=1 .. I IBCLOK, 'IBUPD D U PDTX^IBCEC SA2(+$P(^I BM(361,DA, 0),U,11)," Z") .. I ' IBLOOK D . .. W !,"Se q #: ",IBD AX," Bill number: ", $$EXPAND^I BTRE(361,. 01,+^IBM(3 61,DA,0)), ?45,"REVIE WED" .. D NOTECHG^IB CECSA2(DA, 1) .. D UN LOCK(361,D A) W !!,"L AST SELECT ION PROCES SED",! D P AUSE^VALM1 MSTATQ S V ALMBCK="R" I IBREBLD D BLD^IBC ECSA1 Q ;P RPAY(IBIFN ,IBMCR) ; Returns to tal amount of prior payments a pplied to ; bill ien IBIFN ; I BMCR = fla g passed i n as 1 if MRA total should be included ; N IBTOT,I BZ,IBSEQ S IBSEQ=$$C OBN^IBCEF( IBIFN) I I BSEQ'>1 S IBTOT=0 G PRPAYQ D F ^IBCEF("N- PRIOR PAYM ENTS","IBZ ",,IBIFN) S IBTOT=IB Z I $G(IBM CR),$$MCRO NBIL^IBEFU NC(IBIFN)= 1 D ; MCR on bill b efore curr ins . N Z ,Z0,Z2,Q . F Z=1:1:I BSEQ-1 I $ $WNRBILL^I BEFUNC(IBI FN,Z) D .. S IBTOT=+ $$MCRPAY(I BIFN)PRPAY Q Q IBTOT ;PRINTUPD( IBTEXT,IBD A) ; If th e status m essage ind icates cla im was pri nted ; or the claim record in file 399 s ays it was , update t he transmi t ; messag e status t o closed ; IBTEXT = the first line text of the sta tus messag e (optiona l) ; IBDA = the ien of the tra nsmission record in file 364 ; ; FUNCTIO N returns 1 if messa ge status changed ; N IBP,IBP1 S IBP=0,I BP1=$P($G( ^DGCR(399, +$G(^IBA(3 64,+$G(IBD A),0)),"TX ")),U,7) I $G(IBTEXT )["CLAIM R ECEIVED, P RINTED AND MAILED BY PRINT CEN TER"!IBP1 D . N Z . S Z=$E($P( $G(^IBA(36 4,IBDA,0)) ,U,3),1) . I "AP"'[Z Q ; Only change if status is pending o r received /accepted . D UPDTX^ IBCECSA2(I BDA,"Z") S IBP=1 Q I BP ;MCRPAY (IBIFN) ; Calculate MRA total for the bi ll IBIFN N IBPAY,Q,Z 0 S IBPAY= 0 ;include eligible bill for p rocess ; 4 32 - added MRA flag to IBCEU1 to not alw ays screen out non-M RA's S Q=0 F S Q=$O (^IBM(361. 1,"B",IBIF N,Q)) Q:'Q I $$EOBE LIG^IBCEU1 (Q,1) S IB PAY=IBPAY+ $P($G(^IBM (361.1,Q,1 )),U,1) Q IBPAY ;PRE OBTOT(IBIF N,IBMRANOT ) ; Functi on - Calcu lates Pati ent Respon sibility A mount ; In put: IBIFN - ien of Bill Numbe r (ien of file 399) ; IBMRANOT - flag to indicate that this is NOT and MRA ; Out put Functi on returns : Patient Responsibi lity Amoun t for all EOB's for bill ; N F RMTYP,IBPT RES S IBPT RES=0 ; Fo rm Type 2= CMS-1500; 3=UB-04 S FRMTYP=$$F T^IBCEF(IB IFN) ; ; F or bills w /CMS-1500 Form Type, total up Pt Resp am ount from top ; leve l of EOB ( field 1.02 ) for All MRA type E OB's on fi le for tha t ; bill ( IBIFN) ; I FRMTYP=2 D Q IBPT RES . N IB EOB,EOBREC ,EOBREC1,I BPRTOT . S (IBEOB,IB PRTOT,IBPT RES)=0 . F S IBEOB= $O(^IBM(36 1.1,"B",IB IFN,IBEOB) ) Q:'IBEOB D ; . . S EOBREC= $G(^IBM(36 1.1,IBEOB, 0)),EOBREC 1=$G(^(1)) .. ; IB*2 .0*432 all ow for non -MRA's . . I $G(IBMR ANOT)'=1,$ P(EOBREC,U ,4)'=1 Q ;make sure it's an M RA . . Q:$ D(^IBM(361 .1,IBEOB," ERR")) ;no filing er ror . . ; Total up P t Resp Amo unts on al l valid MR A's . . S IBPTRES=IB PTRES+$P(E OBREC1,U,2 ) ; ; For bills w/UB -04 Form T ype, loop through al l EOB's an d sum up a mounts ; o n both Lin e level an d on Claim level N E OBADJ,IBEO B,LNLVL S IBEOB=0 F S IBEOB=$ O(^IBM(361 .1,"B",IBI FN,IBEOB)) Q:'IBEOB D ; . ; IB*2.0*432 allow for non-MRA's . I $G(IB MRANOT)'=1 ,$P($G(^IB M(361.1,IB EOB,0)),U, 4)'=1 Q ; must be an MRA . Q:$D(^IBM( 361.1,IBEO B,"ERR")) ; no filin g error . ; get clai m level ad justments . K EOBADJ M EOBADJ= ^IBM(361.1 ,IBEOB,10) . S IBPTR ES=IBPTRES +$$CALCPR( .EOBADJ) . ; . ; get line leve l adjustme nts . S LN LVL=0 . F S LNLVL=$ O(^IBM(361 .1,IBEOB,1 5,LNLVL)) Q:'LNLVL D ; . . K EOBADJ M EOBADJ=^IB M(361.1,IB EOB,15,LNL VL,1) . . S IBPTRES= IBPTRES+$$ CALCPR(.EO BADJ) Q IB PTRES ;CAL CPR(EOBADJ ) ; Functi on - Calcu late Patie nt Respons ibilty Amo unt ; For Group Code PR; Ignor e the PR-A AA kludge ; Input - EOBADJ = A rray of Gr oup Codes & Reason C odes from either the Claim ; L evel (10) or Service Line Leve l (15) of EOB file ( #361.1) ; Output - F unction re turns Pati ent Respon sibility A mount ; N GRPLVL,RSN CD,RSNAMT, PTRESP S ( GRPLVL,PTR ESP)=0 F S GRPLVL=$ O(EOBADJ(G RPLVL)) Q: 'GRPLVL D . I $P($G (EOBADJ(GR PLVL,0)),U )'="PR" Q ;grp code must be P R . S RSNC D=0 . F S RSNCD=$O( EOBADJ(GRP LVL,1,RSNC D)) Q:'RSN CD D . . I $P($G(EO BADJ(GRPLV L,1,RSNCD, 0)),U,1)=" AAA" Q ; ignore PR -AAA . . S RSNAMT=$P ($G(EOBADJ (GRPLVL,1, RSNCD,0)), U,2) . . S PTRESP=PT RESP+RSNAM T Q PTRESP ;COBMOD(I BXSAVE,IBX DATA,SEQ) ; output t he modifie rs from th e COB ; SE Q is which modifier we're extr acting (1- 4) ; Build IBXDATA(l ine#)=Modi fier# SEQ NEW LN,N,Z ,MOD,LNSEQ KILL IBXD ATA I '$G( SEQ) Q S ( LN,LNSEQ)= 0 F S LN= $O(IBXSAVE ("LCOB",LN )) Q:'LN D . S LNSE Q=LNSEQ+1 . S (N,Z)= 0 . F S Z =$O(IBXSAV E("LCOB",L N,"COBMOD" ,Z)) Q:'Z D .. S N= N+1 .. S M OD(LNSEQ,N )=$P($G(IB XSAVE("LCO B",LN,"COB MOD",Z,0)) ,U,1) .. Q . S MOD=$ G(MOD(LNSE Q,SEQ)) . I MOD'="" S IBXDATA( LNSEQ)=MOD . Q Q ; | |
| 2847 | Modified L ogic (Chan ges are in bold) | |
| 2848 | IBCEU0 ;AL B/TMP - ED I UTILITIE S ;02-OCT- 96 ;;2.0;I NTEGRATED BILLING;** 137,197,15 5,296,349, 417,432,59 2**;21-MAR -94;Build 192 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ;NOTECHG( IBDA,IBNTE XT) ; Ente r who/when review st at change was entere d ; IBDA = ien of en try in fil e 361.1 ; IBNTEXT = array cont aining the lines of text to st ore if not using the ; default text IBNT EXT = # of lines IBN TEXT(#)=li ne text N IBIEN,IBTE XT,DA,X,Y, DIC,DO,DLA YGO,DD S D A(1)=IBDA, DIC="^IBM( 361.1,"_DA (1)_",2,", DIC(0)="L" ,DLAYGO=36 1.121 S X= $$NOW^XLFD T D FILE^D ICN K DIC, DD,DO,DLAY GO Q:Y'>0 S DA(2)=DA (1),DA(1)= +Y,IBIEN=D A(1)_","_D A(2)_"," I $G(IBNTEX T) D . M I BTEXT=IBNT EXT E D . S IBTEXT( 1)="REVIEW STATUS CH ANGED TO ' "_$$EXTERN AL^DILFD(3 61.1,.2,,$ P(^IBM(361 .1,DA(2),0 ),U,20))_" ' BY: "_$$ EXTERNAL^D ILFD(361.1 21,.02,,+$ G(DUZ)) D WP^DIE(361 .121,IBIEN ,.03,,"IBT EXT") K ^T MP("DIERR" ,$J) Q ;LO CK(IBFILE, IBREC) ; L ock record # IBREC i n file #IB FILE (361 or 361.1) N OK S OK= 0 L +^IBM( IBFILE,IBR EC):3 I $T S OK=1 I 'OK D . W !,"Another user has locked thi s record - try again later" . D PAUSE^VA LM1 Q OK ; UNLOCK(IBF ILE,IBREC) ; Unlock record # I BREC in fi le #IBFILE I $G(IBRE C) L -^IBM (IBFILE,IB REC) Q ;MS TAT ; Ente r reviewed by select ed range N IBDAX,IBA ,IBCLOSE,I BLOOK,IBOK ,IBSTOP,IB REBLD,IBCL OK,DA,DIR, X,Y,DIE,DR D FULL^VA LM1 D SEL^ IBCECSA4(. IBDAX) S I BREBLD=0 I $O(IBDAX( ""))="" G MSTATQ S D IR("?,1")= "ONLY SELE CT TO CLOS E THE TRAN SMIT RECOR DS IF YOU KNOW THESE ARE THE F INAL",DIR( "?",2)=" E LECTRONIC MESSAGES Y OU WILL RE CEIVE FOR ALL THE BI LLS REFERE NCED BY",D IR("?")=" THESE MESS AGES" S DI R(0)="YA", DIR("A",1) ="DO YOU W ANT TO AUT OMATICALLY CLOSE THE TRANSMIT RECORDS FO R ANY MESS AGES",DIR( "A")=" THA T AREN'T R EJECTS?: " ,DIR("B")= "NO" W ! D ^DIR K DI R W ! G:$D (DIRUT) MS TATQ S IBC LOSE=(Y=1) S DIR(0)= "YA",DIR(" A")="DO YO U WANT TO SEE EACH M ESSAGE BEF ORE MARKIN G IT REVIE WED?: ",DI R("B")="NO " S DIR("? ",1)="IF Y OU OPT TO SEE EACH M ESSAGE, YO U CAN CONT ROL WHETHE R OR NOT T HE MESSAGE ",DIR("?", 2)=" IS MA RKED AS RE VIEWED" I 'IBCLOSE S DIR("?")= DIR("?",2) K DIR("?" ,2) I IBCL OSE S DIR( "?",2)=DIR ("?",2)_" AND, FOR N ON-REJECTS , WHETHER OR NOT TO CLOSE THE" ,DIR("?")= " TRANSMIT RECORD FO R THE BILL " W ! D ^D IR K DIR W ! G:$D(DI RUT) MSTAT Q S IBLOOK =(Y=1) S I BDAX=0,IBS TOP=0 F S IBDAX=+$O (IBDAX(IBD AX)) Q:'IB DAX D Q: IBSTOP . S IBA=$G(IB DAX(IBDAX) ) . S DIE= "^IBM(361, ",DA=$P(IB A,U,2),DR= "" . I DA D .. S IBO K=1 .. S I BCLOK=$S(I BCLOSE:1,1 :0) .. I I BLOOK D Q :'IBOK ... S DIC="^I BM(361," D EN^DIQ .. . I '$$LOC K(361,DA) W ! S IBOK =0 Q ... S DIR(0)="Y A",DIR("A" )="OK TO M ARK REVIEW ED?: ",DIR ("B")="YES ",DIR("?", 1)="IF YOU ENTER YES , THIS MES SAGE WILL BE MARKED REVIEWED" ... S DIR( "?",2)="IF YOU ENTER NO, THIS MESSAGE WI LL NOT BE ALTERED",D IR("?",3)= "IF YOU EN TER AN ^, THIS MESSA GE WILL NO T BE ALTER ED & NONE OF THE",DI R("?")=" R EMAINING M ESSAGES WI LL BE PROC ESSED" D ^ DIR K DIR ... I Y'>0 S IBOK=0 S:$D(DIRUT ) IBSTOP=1 Q ... I ' IBCLOSE D .... S DIR (0)="YA",D IR("A")="O K TO CLOSE THIS BILL 'S TRANSMI T RECORD?: ",DIR("B" )="NO" ... . S DIR("? ",1)="If y ou respond YES to th is prompt, the trans mit status of this b ill will", DIR("?",2) =" be set to CLOSED. No furthe r electron ic process ing of thi s bill wil l be" .... S DIR("?" ,3)=" allo wed. If yo u respond NO to this prompt, t his electr onic messa ge will",D IR("?",4)= " be filed as review ed, but th e bill's t ransmit st atus will not be cha nged." ... . S DIR("? ",5)=" You may wish to periodi cally prin t a list o f bills wi th a non-f inal",DIR( "?",6)=" ( closed/can celled/etc ) status t o ensure t he electro nic proces sing of al l" .... S DIR("?",7) =" bills h as been co mpleted. C losing the transmit bill recor d here wil l",DIR("?" )=" elimin ate the bi ll from th is list." .... W ! D ^DIR K DI R W ! .... I Y'=1 S IBCLOK=0 . . I 'IBLOO K,$P($G(^I BM(361,DA, 0)),U,3)=" R" D Q:'I BOK ... S DR="1",DIC ="^IBM(361 ," D EN^DI Q W !,"Bil l Number: ",$$EXPAND ^IBTRE(361 ,.01,+^IBM (361,DA,0) ) ... S DI R(0)="YA", DIR("A")=" THIS IS A REJECTION ... ARE YO U SURE YOU WANT TO M ARK IT REV IEWED?: ", DIR("B")=" NO" ... S DIR("?",1) ="IF YOU E NTER YES, THIS MESSA GE WILL BE MARKED RE VIEWED" .. . S DIR("? ",2)="IF Y OU ENTER N O, THIS ME SSAGE WILL NOT BE AL TERED",DIR ("?",3)="I F YOU ENTE R AN ^, TH IS MESSAGE WILL NOT BE ALTERED & NONE OF THE",DIR( "?")=" MES SAGES FOLL OWING THIS ONE WILL BE PROCESS ED" D ^DIR K DIR ... I Y'=1 S IBOK=0 S:$ D(DIRUT) I BSTOP=1 .. S:'IBREBL D IBREBLD= 1 .. S DR= ".09////2; .1////F" D ^DIE .. N IBUPD .. S IBUPD=0 .. I $$PRI NTUPD($G(^ IBM(361,DA ,1,1,0)),+ $P(^IBM(36 1,DA,0),U, 11)) S IBU PD=1 .. I $G(^IBM(36 1,DA,1,1,0 ))["CLAIM SENT TO PA YER" D UPD TX^IBCECSA 2(+$P(^IBM (361,DA,0) ,U,11),$S( IBCLOK:"Z" ,1:"A2")) S IBUPD=1 .. I $G(^I BM(361,DA, 1,1,0))["C LAIM REJEC TED" D UPD TX^IBCECSA 2(+$P(^IBM (361,DA,0) ,U,11),"E" ) S IBUPD= 1 .. I IBC LOK,'IBUPD D UPDTX^I BCECSA2(+$ P(^IBM(361 ,DA,0),U,1 1),"Z") .. I 'IBLOOK D ... W ! ,"Seq #: " ,IBDAX," B ill number : ",$$EXPA ND^IBTRE(3 61,.01,+^I BM(361,DA, 0)),?45,"R EVIEWED" . . D NOTECH G^IBCECSA2 (DA,1) .. D UNLOCK(3 61,DA) W ! !,"LAST SE LECTION PR OCESSED",! D PAUSE^V ALM1MSTATQ S VALMBCK ="R" I IBR EBLD D BLD ^IBCECSA1 Q ;PRPAY(I BIFN,IBMCR ) ; Return s total am ount of pr ior paymen ts applied to ; bill ien IBIFN ; IBMCR = flag pass ed in as 1 if MRA to tal should be includ ed ; N IBT OT,IBZ,IBS EQ S IBSEQ =$$COBN^IB CEF(IBIFN) I IBSEQ'> 1 S IBTOT= 0 G PRPAYQ D F^IBCEF ("N-PRIOR PAYMENTS", "IBZ",,IBI FN) S IBTO T=IBZ I $G (IBMCR),$$ MCRONBIL^I BEFUNC(IBI FN)=1 D ; MCR on bi ll before curr ins . N Z,Z0,Z2 ,Q . F Z=1 :1:IBSEQ-1 I $$WNRBI LL^IBEFUNC (IBIFN,Z) D .. S IBT OT=+$$MCRP AY(IBIFN)P RPAYQ Q IB TOT ;PRINT UPD(IBTEXT ,IBDA) ; I f the stat us message indicates claim was printed ; or the cl aim record in file 3 99 says it was, upda te the tra nsmit ; me ssage stat us to clos ed ; IBTEX T = the fi rst line t ext of the status me ssage (opt ional) ; I BDA = the ien of the transmiss ion record in file 3 64 ; ; FUN CTION retu rns 1 if m essage sta tus change d ; N IBP, IBP1 S IBP =0,IBP1=$P ($G(^DGCR( 399,+$G(^I BA(364,+$G (IBDA),0)) ,"TX")),U, 7) I $G(IB TEXT)["CLA IM RECEIVE D, PRINTED AND MAILE D BY PRINT CENTER"!I BP1 D . N Z . S Z=$E ($P($G(^IB A(364,IBDA ,0)),U,3), 1) . I "AP "'[Z Q ; Only chang e if statu s is pendi ng or rece ived/accep ted . D UP DTX^IBCECS A2(IBDA,"Z ") S IBP=1 Q IBP ;MC RPAY(IBIFN ) ; Calcul ate MRA to tal for th e bill IBI FN N IBPAY ,Q,Z0 S IB PAY=0 ;inc lude eligi ble bill f or process ; 432 - a dded MRA f lag to IBC EU1 to not always sc reen out n on-MRA's S Q=0 F S Q=$O(^IBM( 361.1,"B", IBIFN,Q)) Q:'Q I $$ EOBELIG^IB CEU1(Q,1) S IBPAY=IB PAY+$P($G( ^IBM(361.1 ,Q,1)),U,1 ) Q IBPAY ;PREOBTOT( IBIFN,IBMR ANOT) ; Fu nction - C alculates Patient Re sponsibili ty Amount ; Input: I BIFN - ien of Bill N umber (ien of file 3 99) ; IBMR ANOT - fla g to indic ate that t his is NOT and MRA ; Output Fu nction ret urns: Pati ent Respon sibility A mount for all EOB's for bill ; N FRMTYP, IBPTRES S IBPTRES=0 ;JWS;IB*2. 0*592: Den tal form 7 ; Form Ty pe 2=CMS-1 500; 3=UB- 04; 7=J430 D Dental S FRMTYP=$$ FT^IBCEF(I BIFN) ; ; For bills w/CMS-1500 Form Type , total up Pt Resp a mount from top ; lev el of EOB (field 1.0 2) for All MRA type EOB's on f ile for th at ; bill (IBIFN) ; ;JWS;IB*2 .0*592: De ntal form 7 I FRMTYP =2!(FRMTYP =7) D Q I BPTRES . N IBEOB,EOB REC,EOBREC 1,IBPRTOT . S (IBEOB ,IBPRTOT,I BPTRES)=0 . F S IBE OB=$O(^IBM (361.1,"B" ,IBIFN,IBE OB)) Q:'IB EOB D ; . . S EOBR EC=$G(^IBM (361.1,IBE OB,0)),EOB REC1=$G(^( 1)) .. ; I B*2.0*432 allow for non-MRA's . . I $G(I BMRANOT)'= 1,$P(EOBRE C,U,4)'=1 Q ;make s ure it's a n MRA . . Q:$D(^IBM( 361.1,IBEO B,"ERR")) ;no filing error . . ; Total u p Pt Resp Amounts on all valid MRA's . . S IBPTRES =IBPTRES+$ P(EOBREC1, U,2) ; ; F or bills w /UB-04 For m Type, lo op through all EOB's and sum u p amounts ; on both Line level and on Cl aim level N EOBADJ,I BEOB,LNLVL S IBEOB=0 F S IBEO B=$O(^IBM( 361.1,"B", IBIFN,IBEO B)) Q:'IBE OB D ; . ; IB*2.0* 432 allow for non-MR A's . I $G (IBMRANOT) '=1,$P($G( ^IBM(361.1 ,IBEOB,0)) ,U,4)'=1 Q ; must be an MRA . Q:$D(^I BM(361.1,I BEOB,"ERR" )) ; no fi ling error . ; get c laim level adjustmen ts . K EOB ADJ M EOBA DJ=^IBM(36 1.1,IBEOB, 10) . S IB PTRES=IBPT RES+$$CALC PR(.EOBADJ ) . ; . ; get line l evel adjus tments . S LNLVL=0 . F S LNLV L=$O(^IBM( 361.1,IBEO B,15,LNLVL )) Q:'LNLV L D ; . . K EOBADJ M EOBADJ= ^IBM(361.1 ,IBEOB,15, LNLVL,1) . . S IBPTR ES=IBPTRES +$$CALCPR( .EOBADJ) Q IBPTRES ; CALCPR(EOB ADJ) ; Fun ction - Ca lculate Pa tient Resp onsibilty Amount ; F or Group C ode PR; Ig nore the P R-AAA klud ge ; Input - EOBADJ = Array of Group Cod es & Reaso n Codes fr om either the Claim ; Level (1 0) or Serv ice Line L evel (15) of EOB fil e (#361.1) ; Output - Function returns P atient Res ponsibilit y Amount ; N GRPLVL, RSNCD,RSNA MT,PTRESP S (GRPLVL, PTRESP)=0 F S GRPLV L=$O(EOBAD J(GRPLVL)) Q:'GRPLVL D . I $P ($G(EOBADJ (GRPLVL,0) ),U)'="PR" Q ;grp c ode must b e PR . S R SNCD=0 . F S RSNCD= $O(EOBADJ( GRPLVL,1,R SNCD)) Q:' RSNCD D . . I $P($G (EOBADJ(GR PLVL,1,RSN CD,0)),U,1 )="AAA" Q ; ignore PR-AAA . . S RSNAMT =$P($G(EOB ADJ(GRPLVL ,1,RSNCD,0 )),U,2) . . S PTRESP =PTRESP+RS NAMT Q PTR ESP ;COBMO D(IBXSAVE, IBXDATA,SE Q) ; outpu t the modi fiers from the COB ; SEQ is wh ich modifi er we're e xtracting (1-4) ; Bu ild IBXDAT A(line#)=M odifier# S EQ NEW LN, N,Z,MOD,LN SEQ KILL I BXDATA I ' $G(SEQ) Q S (LN,LNSE Q)=0 F S LN=$O(IBXS AVE("LCOB" ,LN)) Q:'L N D . S L NSEQ=LNSEQ +1 . S (N, Z)=0 . F S Z=$O(IBX SAVE("LCOB ",LN,"COBM OD",Z)) Q: 'Z D .. S N=N+1 .. S MOD(LNSE Q,N)=$P($G (IBXSAVE(" LCOB",LN," COBMOD",Z, 0)),U,1) . . Q . S MO D=$G(MOD(L NSEQ,SEQ)) . I MOD'= "" S IBXDA TA(LNSEQ)= MOD . Q Q ; | |
| 2849 | ||
| 2850 | ||
| 2851 | Routines | |
| 2852 | Activities | |
| 2853 | Routine Na me | |
| 2854 | IBCEU3 | |
| 2855 | Enhancemen t Category | |
| 2856 | New | |
| 2857 | Modify | |
| 2858 | Delete | |
| 2859 | No Change | |
| 2860 | RTM | |
| 2861 | ||
| 2862 | Related Op tions | |
| 2863 | None | |
| 2864 | Related Ro utines | |
| 2865 | Routines “ Called By” | |
| 2866 | Routines “ Called” | |
| 2867 | ||
| 2868 | ||
| 2869 | ||
| 2870 | ||
| 2871 | Data Dicti onary (DD) Reference s | |
| 2872 | ||
| 2873 | Related Pr otocols | |
| 2874 | None | |
| 2875 | Related In tegration Control Re gistration s (ICRs) | |
| 2876 | None | |
| 2877 | Data Passi ng | |
| 2878 | Input | |
| 2879 | Output Re ference | |
| 2880 | Both | |
| 2881 | Global Re ference | |
| 2882 | Local | |
| 2883 | Input Attr ibute Name and Defin ition | |
| 2884 | Name: | |
| 2885 | Definition : | |
| 2886 | Output Att ribute Nam e and Defi nition | |
| 2887 | Name: | |
| 2888 | Definition : | |
| 2889 | Current Lo gic | |
| 2890 | IBCEU3 ;AL B/TMP - ED I UTILITIE S FOR 1500 CLAIM FOR M ;12/29/0 5 9:58am ; ;2.0;INTEG RATED BILL ING;**51,1 37,155,323 ,348,371,4 00,432,488 ,519**;21- MAR-94;Bui ld 56 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ;B OX19(IBIFN ) ; New Bo x 19 added for patch 488. This is for wo rkman's co mp? ; This returns t he Paperwo rk Attachm ent ; Inf ormation i n the foll owing form at: ; PWKN NFX1234890 7CHEY<3 Sp aces>Next set if mor e than one on claim ; PWK is t he qualifi er for dat a, followe d by the a ppropriate Report Ty pe ;Code, the appro priate Tra nsmission Type Code, then the Attachment Control ;Number. D o not ente r spaces b etween qua lifiers an d data. ; ; This inf ormation c an be at e ither the Line Level or the Cl aim Level. ; Check a ll Lines f irst and p rint as ma ny as poss ible - 71 characters ; maximu m. Then ch eck the Cl aim Level N IBRTP,LN ,U8,IBBX19 ,IB19,DATA ,I,DEL S I B19="",DEL =" ",LN=0 ; Get rate type S IB RTP=$P($G( ^DGCR(399, IBIFN,0)), U,7) ; Get data ente red for bo x 19 S IBB X19=$P($G( ^DGCR(399, IBIFN,"UF3 1")),U,3) ; check th e line Lev el first I IBRTP=11 D .F S LN =$O(^DGCR( 399,IBIFN, "CP",LN)) Q:LN="" Q :LN'?.N D ..S DATA= $G(^DGCR(3 99,IBIFN," CP",LN,1)) ..I $P(DA TA,U,2)'=" " S IB19=I B19_$S(IB1 9="":"",1: DEL)_$$FOR MAT(DATA) .; check t he Claim L evel next .S DATA="" .S DATA=$ G(^DGCR(39 9,IBIFN,"U 8")) .I DA TA'="" S I B19=IB19_$ S(IB19="": "",1:DEL)_ $$FORMAT(D ATA) ; If any room l eft add us er entered box 19 in fo I IBBX1 9'="",IB19 '="",$L(IB 19)<84 D . F I=1:1:$L (IBBX19,DE L) S DATA= $P(IBBX19, DEL,I) I D ATA'="" D ..I $L(IB1 9_DEL_DATA )<84 S IB1 9=IB19_$S( IB19="":"" ,1:DEL)_DA TA I IB19= "",IBBX19' ="" S IB19 =IBBX19 ; Q IB19 ;FO RMAT(DATA) ; format data for o uput N ART ,OUT S ART =$P(DATA,U ,2) S ART= $P(^IBE(35 3.3,ART,0) ,U,1) S OU T="PWK"_AR T_$P(DATA, U,3)_$P(DA TA,U,1) Q OUT ; ; BE LOW NO LON GER USED - > BAA *488 *OBOX19(IB IFN) ; THI S IS NOLON GER USED. IT WAS REP LACE WITH ABOVE. ; R eturns the text that should pr int in box 19 of the CMS-1500 ; for bill ien IBIFN ; Data is derived f rom a comb o of data throughout ; the sys tem and is limited t o 80 chara cters. The hierarchy for ; inc luding dat a is as fo llows (unt il 80 char acters hav e been use d): ; DATE LAST SEEN and REFER RING PHYSI CIAN ID# ( physical t herapy) ; specialty codes = 02 5,065,073, 067,048 ; LAST X-RAY DATE (chi ropractic) specialty code = 35 ; HOMEBOU ND INDICAT OR (indepe ndent lab renders an EKG or ob tains ; a specimen f rom a home bound pati ent) ; NO ASSIGNMENT OF BENEFI TS (if no assignment of benefi ts indicat ed) ; Hear ing aid te sting (if applicable ) ; ATTEND ING PHYSIC IAN NOT HO SPICE EMPL OYEE (if a pplicable) ; SPECIAL PROGRAM i ndicator i f Medicare demonstra tion proje ct for ; l ung volume reduction surgery s tudy is se t ; COMMEN TS FOUND I N BOX 19 D ATA FIELD FOR THE CL AIM ; REMA RKS FOUND IN BILL CO MMENT FOR THE CLAIM, INCLUDING PROSTHETI CS ; DETAI L ; N IBGO ,IBHOSP,IB ID,IBLSDT, IBXDATA,IB 19,IBHAID, IBXRAY,IBS PEC,Z,Z0,I BSUB,IBPRT ,IBREM,IBS PI S IB19= "",IBGO=1 S IBSUB=$S ('$G(^TMP( "IBTX",$J, IBIFN)):"B OX24",1:"O UTPT") I $ D(IBXSAVE( IBSUB)) N IBXSAVE S IBPRT=(IBS UB["24") ; S IBSPEC= $$BILLSPEC (IBIFN) G: 'IBPRT NPR T ; Check for chirop ractic ser vices I $P ($G(^DGCR( 399,IBIFN, "U3")),U,5 )'="" S:$P ($G(^DGCR( 399,IBIFN, "U3")),U,4 )'="" IBGO =$$LENOK(" Last X-ray : "_$TR($$ DATE^IBCF2 ($P(^DGCR( 399,IBIFN, "U3"),U,4) )," ","/") ,.IB19) G: 'IBGO BOX1 9Q ; I "^2 5^65^73^67 ^48^"[(U_I BSPEC_U) D . K IBXDA TA D F^IBC EF("N-DATE LAST SEEN ",,,IBIFN) . I IBXDA TA'="" S I BID="",IBL SDT=$$DATE ^IBCF2(IBX DATA,0,1) D I IBLSD T'="" S IB GO=$$LENOK ("Date Las t Seen:"_I BLSDT_IBID ,.IB19) .. ; Only pr int if spe cialty is OT or PT o r proc for routine f oot care . . D F^IBCE F("N-REFER RING PROVI DER ID",,, IBIFN) I I BXDATA'="" S IBID=" By:"_IBXDA TA ; G:'IB GO BOX19Q K IBXDATA D F^IBCEF( "N-HOMEBOU ND",,,IBIF N) I IBXDA TA G:'$$LE NOK("Homeb ound",.IB1 9) BOX19Q ; K IBXDAT A D F^IBCE F("N-ASSIG N OF BENEF ITS INDICA TOR",,,IBI FN) I "Nn0 "[IBXDATA& (IBXDATA'= "") G:'$$L ENOK("Pati ent refuse s to assig n benefits ",.IB19) B OX19Q ; I '$D(IBXSAV E(IBSUB)) D B24^IBCE F3(.IBXSAV E,IBIFN,$S ($G(IBNOSH OW)=0:0,1: 1)) ; S (I BHAID,IBHO SP,IBXRAY) =0 ; S Z=0 F S Z=$O (IBXSAVE(I BSUB,Z)) Q :'Z D G: 'IBGO BOX1 9Q . I $D( IBXSAVE(IB SUB,Z,"RX" )),$P(IBXS AVE(IBSUB, Z,"RX"),U, 3)="" S IB GO=$$LENOK ("NOC Drug :"_$P(IBXS AVE(IBSUB, Z,"RX"),U, 2)_" Units :"_+$P(IBX SAVE(IBSUB ,Z,"RX"),U ,6),.IB19) . ; . Q:' IBGO . I ' IBHAID,$P( IBXSAVE(IB SUB,Z),U,5 )="V5010", $$COBCT^IB CEF(IBIFN) >1 D Q .. S IBHAID= 1,IBGO=$$L ENOK("Test ing for he aring aid" ,.IB19) Q . ; . Q:'I BGO . I 'I BHOSP,$P($ G(IBXSAVE( IBSUB,Z,"A UX")),U,3) S IBHOSP= 1,IBGO=$$L ENOK("Atte nding phys ician,not hospice em ployee",.I B19) Q G:' IBGO BOX19 Q K IBXDAT A D F^IBCE F("N-SPECI AL PROGRAM ",,,IBIFN) I IBXDATA =30 G:'$$L ENOK("Medi care demon stration p roject for lung volu me reducti on surgery study",.I B19) BOX19 Q ; ; SPEC IAL PROGRA M INDICATO R field co de. S IBSP I=$$GET1^D IQ(399,IBI FN_",",238 ,"E") I IB SPI'="" S IBGO=$$LEN OK(IBSPI,. IB19) ; G: 'IBGO BOX1 9QNPRT K I BXDATA D F ^IBCEF("N- HCFA 1500 BOX 19 RAW DATA",,,I BIFN) S IB REM=0 I IB XDATA'="" G:'$$LENOK ("Remarks: "_IBXDATA, .IB19) BOX 19Q S IBRE M=1 K IBXD ATA D F^IB CEF("N-BIL L REMARKS" ,,,IBIFN) I IBXDATA' ="" G:'$$L ENOK($S('I BREM:"Rema rks:",1:"" )_IBXDATA, .IB19) BOX 19Q ;BOX19 Q Q IB19 ; ALL OF TH E ABOVE TO OBOX19 IS NO LONGER USED *488 * ;LENOK(I BDATA,IB19 ) ; Add te xt IBDATA to box 19 string (IB 19 passed by ref) ; Check leng th of box 19 data - truncate a t 71 (max length) ; Returns 0 if max len gth reache d or excee ded, other wise, 1 ; Changed 96 to 71 for new 1500 form N OK S OK=1 S I B19=IB19_$ S(IB19'="" :" ",1:"") _$G(IBDATA ) I $L(IB1 9)'<83 S O K=0,IB19=$ E(IB19,1,7 1) G LENOK QLENOKQ Q OK ;ASK19( IBIFN) ; A sk to disp lay CMS-15 00 box 19 data for c urrent IBI FN ; chang ed to 71 l ength. N D IR,DIC,X,Y ,DIE,DR,Z S DIR(0)=" YA",DIR("B ")="NO",DI R("A")="DI SPLAY THE FULL CMS-1 500 BOX 19 ?: " D ^DI R K DIR("B ") I Y=1 D .S Z=$$BO X19(IBIFN) W !!,?4," 19",?45,$E (Z,1,23) W :$L(Z)>23 !,?4,$E(Z, 24,71),! . S DIR(0)=" E",DIR("A" )="Enter < RET> to Co ntinue " W ! D ^DIR K DIR Q ;O NLAB(IBIFN ) ; Functi ons return s 1 if the bill IBIF N is outsi de non-lab N IBP,IBP UR S IBP=0 S IBPUR=$ P($G(^DGCR (399,IBIFN ,"U2")),U, 11) I IBPU R,"13"[IBP UR S IBP=1 Q IBP ;TE XT24(FLD,I BXSAVE,IBX DATA,IBSUB ) ; Format the text line of bo x 24 by fl d ; INPUT: ; FLD = t he letter of the fie ld in box 24 (A-J) ; IBXSAVE = passed by reference = extract ed data fo r the box 24 lines ; IBSUB = t he subscri pt of the IBXSAVE ar ray to use . ; If nul l, use "BO X24" ; OUT PUT: ; IBX DATA = pas sed by ref erence, se t to the c orrect par t of the ; text that will prin t in the f ield's pos itions ; ; esg - 8/1 4/06 - mod ified for the new cm s-1500 for m - IB*2*3 48 ; N Z,I BLINE,IBVA L,IBS,IBE, IBTEXT,IBA UX,IBDAT,I BZ,IBREN,I BRENQ,IBRE NNPI,IBREN SID K IBXD ATA S (IBL INE,Z)=0 S :$G(IBSUB) ="" IBSUB= "BOX24" ; I FLD="I"! (FLD="J") D ; extr act the Re ndering pr ovider dat a . I '$G( IBXIEN) Q ; as sume that the claim# exists . S IBREN=$$ CFIDS^IBCE F77(IBXIEN ) . S IBRE NQ=$P(IBRE N,U,1) ; q ual . S IB RENSID=$P( IBREN,U,2) ; id . S IBRENNPI=$ P(IBREN,U, 3) ; npi . Q ; F S Z=$O(IBXSA VE(IBSUB,Z )) Q:'Z D . S IBDAT =$G(IBXSAV E(IBSUB,Z) ) . S IBAU X=$G(IBXSA VE(IBSUB,Z ,"AUX")) . S IBTEXT= $G(IBXSAVE (IBSUB,Z," TEXT")) . S IBZ=$P(I BAUX,U,9) . I IBZ="" S IBZ=" " . S IBTEX T=IBZ_IBTE XT . ; . I $S($G(IBA C)=4:$S($D (IBXSAVE(I BSUB,Z,"AR X")):1,1:$ D(IBXSAVE( IBSUB,Z,"A "))),$D(IB XSAVE(IBSU B,Z,"RX")) :0,1:$G(IB NOSHOW)) S IBTEXT="" . ; . I F LD="AF" S IBVAL=$P(I BDAT,U),IB S=1,IBE=9 D ; From date of s ervice .. S IBVAL=$E (IBVAL,1,2 )_" "_$E(I BVAL,3,4)_ " "_$E(IBV AL,7,8) .. Q . ; . I FLD="AT" S IBVAL=$S ($P(IBDAT, U,2):$P(IB DAT,U,2),1 :$P(IBDAT, U)),IBS=10 ,IBE=18 D ; To da te of serv ice .. S I BVAL=$E(IB VAL,1,2)_" "_$E(IBVA L,3,4)_" " _$E(IBVAL, 7,8) .. Q . ; . I FL D="B" S IB VAL=$P(IBD AT,U,3),IB S=19,IBE=2 1 ; place of service . I FLD=" C" S IBVAL =$S($P(IBD AT,U,13)=1 :"Y",1:"") ,IBS=22,IB E=24 ; eme rgency ind icator . I FLD="D" S IBVAL=$P( IBDAT,U,5) ,IBS=25,IB E=44 D ; procedure s and modi fiers .. N M S M=$$M ODLST^IBEF UNC($P(IBD AT,U,10)) ; modifier list .. S IBVAL=$$F O^IBCNEUT1 (IBVAL,6)_ " " ; pro cedure cod e .. S IBV AL=IBVAL_$ $FO^IBCNEU T1($P(M,", ",1),3) ; mod#1 .. S IBVAL=IBV AL_$$FO^IB CNEUT1($P( M,",",2),3 ) ; mod#2 .. S IBVAL =IBVAL_$$F O^IBCNEUT1 ($P(M,",", 3),3) ; mo d#3 .. S I BVAL=IBVAL _$$FO^IBCN EUT1($P(M, ",",4),3) ; mod#4 .. Q . ; . I FLD="E" D .. N NUM, IN,OUT,LET .. S IN=" 1,2,3,4,5, 6,7,8,9" . . S OUT="A ,B,C,D,E,F ,G,H,I" .. S IBVAL=$ P(IBDAT,U, 7) .. F I= 1:1:4 S NU M=$P(IBVAL ,",",I) D ... I NUM< 10 S $P(LE T,",",I)=$ TR(NUM,IN, OUT) ... I NUM=10 S $P(LET,"," ,I)="J" .. . I NUM=11 S $P(LET, ",",I)="K" ... I NUM =12 S $P(L ET,",",I)= "L" .. S I BVAL=$TR(L ET,","),IB S=45,IBE=4 8 ; diagno sis pointe r . I FLD= "F" S IBVA L=$P(IBDAT ,U,8)*$P(I BDAT,U,9), IBS=49,IBE =57 D .. ; total cha rges **519 returned field leng th back to 8, 9 is t oo long fo r BOX24F . . S IBVAL= $$DOL^IBCE F77(IBVAL, 8) .. I $L (IBVAL)>8 S IBVAL=$E (IBVAL,$L( IBVAL)-7,$ L(IBVAL)) .. Q . ; . I FLD="G" S IBVAL=$ S($P(IBDAT ,U,12):$P( IBDAT,U,12 ),1:$P(IBD AT,U,9)),I BS=58,IBE= 61 D .. ; days or un its or ane sthesia mi nutes .. S IBVAL=$J( +IBVAL,4) .. Q . ; . ; columns H,I,J don 't have an y free tex t suppleme ntal infor mation . ; . I FLD=" H" D ; epsdt fam ily plan . . S IBVAL= $P(IBAUX,U ,7),IBS=0, IBE=0,IBTE XT="" ; line 1 bla nk .. I IB VAL S IBVA L="Y" .. Q . I FLD=" I" D ; ID qualif ier for re ndering pr ovider .. S IBVAL="" ,IBS=1,IBE =2 ; line 2 blank .. S IBTEXT= $G(IBRENQ) ; qualifi er on line 1 .. Q . I FLD="J" D ; re ndering pr ovider ID and NPI .. S IBTEXT= $G(IBRENSI D),IBS=1,I BE=11 ; se condary ID line 1 .. S IBVAL=$ G(IBRENNPI ) ; NPI# l ine 2 .. Q . ; . S I BLINE=IBLI NE+1 ; top line . S IBXDATA(IB LINE)=$E(I BTEXT,IBS, IBE) ; tex t in shade d area (to p) . S IBL INE=IBLINE +1 ; botto m line . S IBXDATA(I BLINE)=IBV AL ; field val ue in unsh aded area (bottom) . Q ; Q ;LI NSPEC(IBIF N) ; Check s the spec ialities o f line and claim lev el provide rs ; calle d from IBC BB2 to che ck for Chi ro codes & IBCBB9 to check for 99's on M edicare ; Default = 99 if no v alid SPEC code found for line and claim level prov ider ; Get rendering for profe ssional, a ttending f or institu tional ; I f multiple lines w/ rendering or attendi ng, return s a string of spec c odes N Z,I BSPEC,IBIN S,IBDT,IBC P,IBSPC S IBSPC="" S IBDT=$P($ G(^DGCR(39 9,+IBIFN," U")),U,1) ; use stat ement from date S IB INS=($$FT^ IBCEF(IBIF N)=3) D GE TPRV^IBCEU (IBIFN,"AL L",.IBPRV) S Z=$S('I BINS:3,1:4 ) ; check claim leve l I $G(IBP RV(Z,1))'= "" D . I $ P(IBPRV(Z, 1),U,3) S IBSPEC=$$S PEC^IBCEU( $P($G(IBPR V(Z,1)),U, 3),IBDT) I IBSPEC'=" " S IBSPC= IBSPC_U_IB SPEC Q . S Z0=+$O(^D GCR(399,IB IFN,"PRV", "B",Z,0)) . I Z0 S I BSPEC=$P($ G(^DGCR(39 9,IBIFN,"P RV",Z0,0)) ,U,8) S:IB SPEC="" IB SPEC=99 S IBSPC=IBSP C_U_IBSPEC ; Check l ine level S IBCP=0 F S IBCP=$ O(^DGCR(39 9,IBIFN,"C P",IBCP)) Q:'IBCP D .S Z0=+$O (^DGCR(399 ,IBIFN,"CP ",IBCP,"LN PRV","B",Z ,0)) .I Z0 S IBSPEC= $P($G(^DGC R(399,IBIF N,"CP",IBC P,"LNPRV", Z0,0)),U,8 ) S:IBSPEC ="" IBSPEC ="99" S IB SPC=IBSPC_ U_IBSPEC S :IBSPC="" IBSPC=99 Q IBSPC ;BI LLSPEC(IBI FN,IBPRV) ; Returns the specia lty of the provider on bill IB IFN ; If I BPRV is su pplied, re turns the data for t hat provid er, otherw ise, ; ret urns the s pecialty o f the 'mai n/required ' provider on the bi ll. ; Defa ult = 99 i f no valid code foun d ; IBPRV = vp of pr ovider (fi le 200 or 355.93) N Z,IBSPEC,I BINS,IBDT S IBSPEC=" ",IBPRV=$G (IBPRV) S IBDT=$P($G (^DGCR(399 ,+IBIFN,"U ")),U,1) ; use state ment from date ; I $ G(IBPRV) D G SPECQ . S IBSPEC =$$SPEC^IB CEU(IBPRV, IBDT) ; ;G et renderi ng for pro fessional, attending for insti tutional, S IBINS=($ $FT^IBCEF( IBIFN)=3) D GETPRV^I BCEU(IBIFN ,"ALL",.IB PRV) S Z=$ S('IBINS:3 ,1:4) I $G (IBPRV(Z,1 ))'="" D . I $P(IBPR V(Z,1),U,3 ) S IBSPEC =$$SPEC^IB CEU($P($G( IBPRV(Z,1) ),U,3),IBD T) Q:IBSPE C'="" . S Z0=+$O(^DG CR(399,IBI FN,"PRV"," B",Z,0)) . I Z0,$P($ G(^DGCR(39 9,IBIFN,"P RV",Z0,0)) ,U,8)'="" S IBSPEC=$ P(^(0),U,8 ) ;SPECQ I IBSPEC="" S IBSPEC= "99" Q IBS PEC ;CHAMP VA(IBIFN) ; Returns 1 if the b ill IBIFN has a CHAM PVA rate t ype Q $E($ P($G(^DGCR (399.3,+$P ($G(^DGCR( 399,IBIFN, 0)),U,7),0 )),U),1,7) ="CHAMPVA" ;FAC(IBIF N) ; Obsol ete functi on. Used b y old outp ut formatt er field a nd data el ement N-RE NDERING IN STITUTION Q "" ;MCR2 4K(IBIFN,I BPRV) ;Fun ction retu rns MEDICA RE id# for professio nal (CMS-1 500) box 2 4k for bil l IBIFN if appropria te ;*432/T AZ - Added IBPRV to allow circ umvent the call to F ^IBCEF("N- SPECIALTY CODE","IBZ ",,IBIFN) in MCRSPEC ^IBCEU4 Q $S($$FT^IB CEF(IBIFN) =2&$$MCRON BIL^IBEFUN C(IBIFN):" V"_$$MCRSP EC^IBCEU4( IBIFN,1,$G (IBPRV))_$ P($$SITE^V ASITE,U,3) ,1:"") | |
| 2891 | Modified L ogic (Chan ges are in bold) | |
| 2892 | IBCEU3 ;AL B/TMP - ED I UTILITIE S FOR 1500 CLAIM FOR M ;12/29/0 5 9:58am ; ;2.0;INTEG RATED BILL ING;**51,1 37,155,323 ,348,371,4 00,432,488 ,519,592** ;21-MAR-94 ;Build 56 ;;Per VA D irective 6 402, this routine sh ould not b e modified . ;BOX19(I BIFN) ; Ne w Box 19 a dded for p atch 488. This is fo r workman' s comp? ; This retur ns the Pap erwork Att achment ; Informati on in the following format: ; PWKNNFX123 48907CHEY< 3 Spaces>N ext set if more than one on cl aim ; PWK is the qua lifier for data, fol lowed by t he appropr iate Repor t Type ;C ode, the a ppropriate Transmiss ion Type C ode, then the Attach ment Contr ol ;Numbe r. Do not enter spac es between qualifier s and data . ; ; This informati on can be at either the Line L evel or th e Claim Le vel. ; Che ck all Lin es first a nd print a s many as possible - 71 charac ters ; ma ximum. The n check th e Claim Le vel N IBRT P,LN,U8,IB BX19,IB19, DATA,I,DEL S IB19="" ,DEL=" ",L N=0 ; Get rate type S IBRTP=$P ($G(^DGCR( 399,IBIFN, 0)),U,7) ; Get data entered fo r box 19 S IBBX19=$P ($G(^DGCR( 399,IBIFN, "UF31")),U ,3) ; chec k the line Level fir st I IBRTP =11 D .F S LN=$O(^D GCR(399,IB IFN,"CP",L N)) Q:LN=" " Q:LN'?. N D ..S D ATA=$G(^DG CR(399,IBI FN,"CP",LN ,1)) ..I $ P(DATA,U,2 )'="" S IB 19=IB19_$S (IB19="":" ",1:DEL)_$ $FORMAT(DA TA) .; che ck the Cla im Level n ext .S DAT A="" .S DA TA=$G(^DGC R(399,IBIF N,"U8")) . I DATA'="" S IB19=IB 19_$S(IB19 ="":"",1:D EL)_$$FORM AT(DATA) ; If any ro om left ad d user ent ered box 1 9 info I I BBX19'="", IB19'="",$ L(IB19)<84 D .F I=1: 1:$L(IBBX1 9,DEL) S D ATA=$P(IBB X19,DEL,I) I DATA'=" " D ..I $L (IB19_DEL_ DATA)<84 S IB19=IB19 _$S(IB19=" ":"",1:DEL )_DATA I I B19="",IBB X19'="" S IB19=IBBX1 9 ; Q IB19 ;FORMAT(D ATA) ; for mat data f or ouput N ART,OUT S ART=$P(DA TA,U,2) S ART=$P(^IB E(353.3,AR T,0),U,1) S OUT="PWK "_ART_$P(D ATA,U,3)_$ P(DATA,U,1 ) Q OUT ; ; BELOW NO LONGER US ED -> BAA *488*OBOX1 9(IBIFN) ; THIS IS N OLONGER US ED. IT WAS REPLACE W ITH ABOVE. ; Returns the text that shoul d print in box 19 of the CMS-1 500 ; for bill ien I BIFN ; Dat a is deriv ed from a combo of d ata throug hout ; the system an d is limit ed to 80 c haracters. The hiera rchy for ; including data is a s follows (until 80 characters have been used): ; DATE LAST SEEN and R EFERRING P HYSICIAN I D# (physic al therapy ) ; specia lty codes = 025,065, 073,067,04 8 ; LAST X -RAY DATE (chiroprac tic) speci alty code = 35 ; HOM EBOUND IND ICATOR (in dependent lab render s an EKG o r obtains ; a specim en from a homebound patient) ; NO ASSIGN MENT OF BE NEFITS (if no assign ment of be nefits ind icated) ; Hearing ai d testing (if applic able) ; AT TENDING PH YSICIAN NO T HOSPICE EMPLOYEE ( if applica ble) ; SPE CIAL PROGR AM indicat or if Medi care demon stration p roject for ; lung vo lume reduc tion surge ry study i s set ; CO MMENTS FOU ND IN BOX 19 DATA FI ELD FOR TH E CLAIM ; REMARKS FO UND IN BIL L COMMENT FOR THE CL AIM, INCLU DING PROST HETICS ; D ETAIL ; N IBGO,IBHOS P,IBID,IBL SDT,IBXDAT A,IB19,IBH AID,IBXRAY ,IBSPEC,Z, Z0,IBSUB,I BPRT,IBREM ,IBSPI S I B19="",IBG O=1 S IBSU B=$S('$G(^ TMP("IBTX" ,$J,IBIFN) ):"BOX24", 1:"OUTPT") I $D(IBXS AVE(IBSUB) ) N IBXSAV E S IBPRT= (IBSUB["24 ") ; S IBS PEC=$$BILL SPEC(IBIFN ) G:'IBPRT NPRT ; Ch eck for ch iropractic services I $P($G(^D GCR(399,IB IFN,"U3")) ,U,5)'="" S:$P($G(^D GCR(399,IB IFN,"U3")) ,U,4)'="" IBGO=$$LEN OK("Last X -ray: "_$T R($$DATE^I BCF2($P(^D GCR(399,IB IFN,"U3"), U,4))," ", "/"),.IB19 ) G:'IBGO BOX19Q ; I "^25^65^7 3^67^48^"[ (U_IBSPEC_ U) D . K I BXDATA D F ^IBCEF("N- DATE LAST SEEN",,,IB IFN) . I I BXDATA'="" S IBID="" ,IBLSDT=$$ DATE^IBCF2 (IBXDATA,0 ,1) D I I BLSDT'="" S IBGO=$$L ENOK("Date Last Seen :"_IBLSDT_ IBID,.IB19 ) .. ; Onl y print if specialty is OT or PT or proc for routi ne foot ca re .. D F^ IBCEF("N-R EFERRING P ROVIDER ID ",,,IBIFN) I IBXDATA '="" S IBI D=" By:"_I BXDATA ; G :'IBGO BOX 19Q K IBXD ATA D F^IB CEF("N-HOM EBOUND",,, IBIFN) I I BXDATA G:' $$LENOK("H omebound", .IB19) BOX 19Q ; K IB XDATA D F^ IBCEF("N-A SSIGN OF B ENEFITS IN DICATOR",, ,IBIFN) I "Nn0"[IBXD ATA&(IBXDA TA'="") G: '$$LENOK(" Patient re fuses to a ssign bene fits",.IB1 9) BOX19Q ; I '$D(IB XSAVE(IBSU B)) D B24^ IBCEF3(.IB XSAVE,IBIF N,$S($G(IB NOSHOW)=0: 0,1:1)) ; S (IBHAID, IBHOSP,IBX RAY)=0 ; S Z=0 F S Z=$O(IBXSA VE(IBSUB,Z )) Q:'Z D G:'IBGO BOX19Q . I $D(IBXSAV E(IBSUB,Z, "RX")),$P( IBXSAVE(IB SUB,Z,"RX" ),U,3)="" S IBGO=$$L ENOK("NOC Drug:"_$P( IBXSAVE(IB SUB,Z,"RX" ),U,2)_" U nits:"_+$P (IBXSAVE(I BSUB,Z,"RX "),U,6),.I B19) . ; . Q:'IBGO . I 'IBHAID ,$P(IBXSAV E(IBSUB,Z) ,U,5)="V50 10",$$COBC T^IBCEF(IB IFN)>1 D Q .. S IBH AID=1,IBGO =$$LENOK(" Testing fo r hearing aid",.IB19 ) Q . ; . Q:'IBGO . I 'IBHOSP, $P($G(IBXS AVE(IBSUB, Z,"AUX")), U,3) S IBH OSP=1,IBGO =$$LENOK(" Attending physician, not hospic e employee ",.IB19) Q G:'IBGO B OX19Q K IB XDATA D F^ IBCEF("N-S PECIAL PRO GRAM",,,IB IFN) I IBX DATA=30 G: '$$LENOK(" Medicare d emonstrati on project for lung volume red uction sur gery study ",.IB19) B OX19Q ; ; SPECIAL PR OGRAM INDI CATOR fiel d code. S IBSPI=$$GE T1^DIQ(399 ,IBIFN_"," ,238,"E") I IBSPI'=" " S IBGO=$ $LENOK(IBS PI,.IB19) ; G:'IBGO BOX19QNPRT K IBXDATA D F^IBCEF ("N-HCFA 1 500 BOX 19 RAW DATA" ,,,IBIFN) S IBREM=0 I IBXDATA' ="" G:'$$L ENOK("Rema rks:"_IBXD ATA,.IB19) BOX19Q S IBREM=1 K IBXDATA D F^IBCEF("N -BILL REMA RKS",,,IBI FN) I IBXD ATA'="" G: '$$LENOK($ S('IBREM:" Remarks:", 1:"")_IBXD ATA,.IB19) BOX19Q ;B OX19Q Q IB 19 ; ALL O F THE ABOV E TO OBOX1 9 IS NO LO NGER USED *488* ;LEN OK(IBDATA, IB19) ; Ad d text IBD ATA to box 19 string (IB19 pas sed by ref ) ; Check length of box 19 dat a - trunca te at 71 ( max length ) ; Return s 0 if max length re ached or e xceeded, o therwise, 1 ; Change d 96 to 71 for new 1 500 form N OK S OK=1 S IB19=IB 19_$S(IB19 '="":" ",1 :"")_$G(IB DATA) I $L (IB19)'<83 S OK=0,IB 19=$E(IB19 ,1,71) G L ENOKQLENOK Q Q OK ;AS K19(IBIFN) ; Ask to display CM S-1500 box 19 data f or current IBIFN ; c hanged to 71 length. N DIR,DIC ,X,Y,DIE,D R,Z S DIR( 0)="YA",DI R("B")="NO ",DIR("A") ="DISPLAY THE FULL C MS-1500 BO X 19?: " D ^DIR K DI R("B") I Y =1 D .S Z= $$BOX19(IB IFN) W !!, ?4,"19",?4 5,$E(Z,1,2 3) W:$L(Z) >23 !,?4,$ E(Z,24,71) ,! .S DIR( 0)="E",DIR ("A")="Ent er <RET> t o Continue " W ! D ^ DIR K DIR Q ;ONLAB(I BIFN) ; Fu nctions re turns 1 if the bill IBIFN is o utside non -lab N IBP ,IBPUR S I BP=0 S IBP UR=$P($G(^ DGCR(399,I BIFN,"U2") ),U,11) I IBPUR,"13" [IBPUR S I BP=1 Q IBP ;TEXT24(F LD,IBXSAVE ,IBXDATA,I BSUB) ; Fo rmat the t ext line o f box 24 b y fld ; IN PUT: ; FLD = the let ter of the field in box 24 (A- J) ; IBXSA VE = passe d by refer ence = ext racted dat a for the box 24 lin es ; IBSUB = the sub script of the IBXSAV E array to use. ; If null, use "BOX24" ; OUTPUT: ; IBXDATA = passed by reference , set to t he correct part of t he ; text that will print in t he field's positions ; ; esg - 8/14/06 - modified for the ne w cms-1500 form - IB *2*348 ; N Z,IBLINE, IBVAL,IBS, IBE,IBTEXT ,IBAUX,IBD AT,IBZ,IBR EN,IBRENQ, IBRENNPI,I BRENSID K IBXDATA S (IBLINE,Z) =0 S:$G(IB SUB)="" IB SUB="BOX24 " ; I FLD= "I"!(FLD=" J") D ; extract th e Renderin g provider data . I '$G(IBXIEN ) Q ; assume t hat the cl aim# exist s . S IBRE N=$$CFIDS^ IBCEF77(IB XIEN) . S IBRENQ=$P( IBREN,U,1) ; qual . S IBRENSID =$P(IBREN, U,2) ; id . S IBRENN PI=$P(IBRE N,U,3) ; n pi . Q ; F S Z=$O(I BXSAVE(IBS UB,Z)) Q:' Z D . S I BDAT=$G(IB XSAVE(IBSU B,Z)) . S IBAUX=$G(I BXSAVE(IBS UB,Z,"AUX" )) . S IBT EXT=$G(IBX SAVE(IBSUB ,Z,"TEXT") ) . S IBZ= $P(IBAUX,U ,9) . I IB Z="" S IBZ =" " . S I BTEXT=IBZ_ IBTEXT . ; . I $S($G (IBAC)=4:$ S($D(IBXSA VE(IBSUB,Z ,"ARX")):1 ,1:$D(IBXS AVE(IBSUB, Z,"A"))),$ D(IBXSAVE( IBSUB,Z,"R X")):0,1:$ G(IBNOSHOW )) S IBTEX T="" . ; . I FLD="AF " S IBVAL= $P(IBDAT,U ),IBS=1,IB E=9 D ; From date of service .. S IBVA L=$E(IBVAL ,1,2)_" "_ $E(IBVAL,3 ,4)_" "_$E (IBVAL,7,8 ) .. Q . ; . I FLD=" AT" S IBVA L=$S($P(IB DAT,U,2):$ P(IBDAT,U, 2),1:$P(IB DAT,U)),IB S=10,IBE=1 8 D ; T o date of service .. S IBVAL=$ E(IBVAL,1, 2)_" "_$E( IBVAL,3,4) _" "_$E(IB VAL,7,8) . . Q . ; . I FLD="B" S IBVAL=$P (IBDAT,U,3 ),IBS=19,I BE=21 ; pl ace of ser vice . I F LD="C" S I BVAL=$S($P (IBDAT,U,1 3)=1:"Y",1 :""),IBS=2 2,IBE=24 ; emergency indicator . I FLD=" D" S IBVAL =$P(IBDAT, U,5),IBS=2 5,IBE=44 D ; proce dures and modifiers .. N M S M =$$MODLST^ IBEFUNC($P (IBDAT,U,1 0)) ; modi fier list .. S IBVAL =$$FO^IBCN EUT1(IBVAL ,6)_" " ; procedure code .. S IBVAL=IBV AL_$$FO^IB CNEUT1($P( M,",",1),3 ) ; mod#1 .. S IBVAL =IBVAL_$$F O^IBCNEUT1 ($P(M,",", 2),3) ; mo d#2 .. S I BVAL=IBVAL _$$FO^IBCN EUT1($P(M, ",",3),3) ; mod#3 .. S IBVAL=I BVAL_$$FO^ IBCNEUT1($ P(M,",",4) ,3) ; mod# 4 .. Q . ; . I FLD=" E" D .. N NUM,IN,OUT ,LET .. S IN="1,2,3, 4,5,6,7,8, 9" .. S OU T="A,B,C,D ,E,F,G,H,I " .. S IBV AL=$P(IBDA T,U,7) .. F I=1:1:4 S NUM=$P(I BVAL,",",I ) D ... I NUM<10 S $ P(LET,",", I)=$TR(NUM ,IN,OUT) . .. I NUM=1 0 S $P(LET ,",",I)="J " ... I NU M=11 S $P( LET,",",I) ="K" ... I NUM=12 S $P(LET,"," ,I)="L" .. S IBVAL=$ TR(LET,"," ),IBS=45,I BE=48 ; di agnosis po inter . I FLD="F" S IBVAL=$P(I BDAT,U,8)* $P(IBDAT,U ,9),IBS=49 ,IBE=57 D .. ; total charges * *519 retur ned field length bac k to 8, 9 is too lon g for BOX2 4F .. S IB VAL=$$DOL^ IBCEF77(IB VAL,8) .. I $L(IBVAL )>8 S IBVA L=$E(IBVAL ,$L(IBVAL) -7,$L(IBVA L)) .. Q . ; . I FLD ="G" S IBV AL=$S($P(I BDAT,U,12) :$P(IBDAT, U,12),1:$P (IBDAT,U,9 )),IBS=58, IBE=61 D . . ; days o r units or anesthesi a minutes .. S IBVAL =$J(+IBVAL ,4) .. Q . ; . ; col umns H,I,J don't hav e any free text supp lemental i nformation . ; . I F LD="H" D ; epsdt family pl an .. S IB VAL=$P(IBA UX,U,7),IB S=0,IBE=0, IBTEXT="" ; line 1 blank .. I IBVAL S IBVAL="Y" .. Q . I F LD="I" D ; ID qu alifier fo r renderin g provider .. S IBVA L="",IBS=1 ,IBE=2 ; l ine 2 blan k .. S IBT EXT=$G(IBR ENQ) ; qua lifier on line 1 .. Q . I FLD= "J" D ; renderin g provider ID and NP I .. S IBT EXT=$G(IBR ENSID),IBS =1,IBE=11 ; secondar y ID line 1 .. S IBV AL=$G(IBRE NNPI) ; NP I# line 2 .. Q . ; . S IBLINE= IBLINE+1 ; top line . S IBXDAT A(IBLINE)= $E(IBTEXT, IBS,IBE) ; text in s haded area (top) . S IBLINE=IB LINE+1 ; b ottom line . S IBXDA TA(IBLINE) =IBVAL ; field value in unshaded a rea (botto m) . Q ; Q ;LINSPEC( IBIFN) ; C hecks the specialiti es of line and claim level pro viders ; c alled from IBCBB2 to check for Chiro cod es & IBCBB 9 to check for 99's on Medicar e ; Defaul t = 99 if no valid S PEC code f ound for l ine and cl aim level provider ; Get rende ring for p rofessiona l, attendi ng for ins titutional ; If mult iple lines w/ render ing or att ending, re turns a st ring of sp ec codes N Z,IBSPEC, IBINS,IBDT ,IBCP,IBSP C S IBSPC= "" S IBDT= $P($G(^DGC R(399,+IBI FN,"U")),U ,1) ; use statement from date S IBINS=($ $FT^IBCEF( IBIFN)=3) D GETPRV^I BCEU(IBIFN ,"ALL",.IB PRV) S Z=$ S('IBINS:3 ,1:4) ; ch eck claim level I $G (IBPRV(Z,1 ))'="" D . I $P(IBPR V(Z,1),U,3 ) S IBSPEC =$$SPEC^IB CEU($P($G( IBPRV(Z,1) ),U,3),IBD T) I IBSPE C'="" S IB SPC=IBSPC_ U_IBSPEC Q . S Z0=+$ O(^DGCR(39 9,IBIFN,"P RV","B",Z, 0)) . I Z0 S IBSPEC= $P($G(^DGC R(399,IBIF N,"PRV",Z0 ,0)),U,8) S:IBSPEC=" " IBSPEC=9 9 S IBSPC= IBSPC_U_IB SPEC ; Che ck line le vel S IBCP =0 F S IB CP=$O(^DGC R(399,IBIF N,"CP",IBC P)) Q:'IBC P D .S Z0 =+$O(^DGCR (399,IBIFN ,"CP",IBCP ,"LNPRV"," B",Z,0)) . I Z0 S IBS PEC=$P($G( ^DGCR(399, IBIFN,"CP" ,IBCP,"LNP RV",Z0,0)) ,U,8) S:IB SPEC="" IB SPEC="99" S IBSPC=IB SPC_U_IBSP EC S:IBSPC ="" IBSPC= 99 Q IBSPC ;BILLSPEC (IBIFN,IBP RV) ; Retu rns the sp ecialty of the provi der on bil l IBIFN ; If IBPRV i s supplied , returns the data f or that pr ovider, ot herwise, ; returns t he special ty of the 'main/requ ired' prov ider on th e bill. ; Default = 99 if no v alid code found ; IB PRV = vp o f provider (file 200 or 355.93 ) N Z,IBSP EC,IBINS,I BDT S IBSP EC="",IBPR V=$G(IBPRV ) S IBDT=$ P($G(^DGCR (399,+IBIF N,"U")),U, 1) ; use s tatement f rom date ; I $G(IBPR V) D G SP ECQ . S IB SPEC=$$SPE C^IBCEU(IB PRV,IBDT) ; ;Get ren dering for professio nal, atten ding for i nstitution al, S IBIN S=($$FT^IB CEF(IBIFN) =3) D GETP RV^IBCEU(I BIFN,"ALL" ,.IBPRV) S Z=$S('IBI NS:3,1:4) I $G(IBPRV (Z,1))'="" D . I $P( IBPRV(Z,1) ,U,3) S IB SPEC=$$SPE C^IBCEU($P ($G(IBPRV( Z,1)),U,3) ,IBDT) Q:I BSPEC'="" . S Z0=+$O (^DGCR(399 ,IBIFN,"PR V","B",Z,0 )) . I Z0, $P($G(^DGC R(399,IBIF N,"PRV",Z0 ,0)),U,8)' ="" S IBSP EC=$P(^(0) ,U,8) ;SPE CQ I IBSPE C="" S IBS PEC="99" Q IBSPEC ;C HAMPVA(IBI FN) ; Retu rns 1 if t he bill IB IFN has a CHAMPVA ra te type Q $E($P($G(^ DGCR(399.3 ,+$P($G(^D GCR(399,IB IFN,0)),U, 7),0)),U), 1,7)="CHAM PVA" ;FAC( IBIFN) ; O bsolete fu nction. Us ed by old output for matter fie ld and dat a element N-RENDERIN G INSTITUT ION Q "" ; MCR24K(IBI FN,IBPRV) ;Function returns ME DICARE id# for profe ssional (C MS-1500) b ox 24k for bill IBIF N if appro priate ;*4 32/TAZ - A dded IBPRV to allow circumvent the call to F^IBCEF ("N-SPECIA LTY CODE", "IBZ",,IBI FN) in MCR SPEC^IBCEU 4 ;JWS;IB* 2.0*592:Ad ded dental form to c heck for c ompatibili ty Q $S(($ $FT^IBCEF( IBIFN)=2!$ $FT^IBCEF( IBIFN)=7)& $$MCRONBIL ^IBEFUNC(I BIFN):"V"_ $$MCRSPEC^ IBCEU4(IBI FN,1,$G(IB PRV))_$P($ $SITE^VASI TE,U,3),1: "") | |
| 2893 | ||
| 2894 | ||
| 2895 | Routines | |
| 2896 | Activities | |
| 2897 | Routine Na me | |
| 2898 | IBCEU5 | |
| 2899 | Enhancemen t Category | |
| 2900 | New | |
| 2901 | Modify | |
| 2902 | Delete | |
| 2903 | No Change | |
| 2904 | RTM | |
| 2905 | ||
| 2906 | Related Op tions | |
| 2907 | None | |
| 2908 | Related Ro utines | |
| 2909 | Routines “ Called By” | |
| 2910 | Routines “ Called” | |
| 2911 | ||
| 2912 | ||
| 2913 | ||
| 2914 | ||
| 2915 | Data Dicti onary (DD) Reference s | |
| 2916 | ||
| 2917 | Related Pr otocols | |
| 2918 | None | |
| 2919 | Related In tegration Control Re gistration s (ICRs) | |
| 2920 | None | |
| 2921 | Data Passi ng | |
| 2922 | Input | |
| 2923 | Output Re ference | |
| 2924 | Both | |
| 2925 | Global Re ference | |
| 2926 | Local | |
| 2927 | Input Attr ibute Name and Defin ition | |
| 2928 | Name: | |
| 2929 | Definition : | |
| 2930 | Output Att ribute Nam e and Defi nition | |
| 2931 | Name: | |
| 2932 | Definition : | |
| 2933 | Current Lo gic | |
| 2934 | IBCEU5 ;AL B/TMP - ED I UTILITIE S (continu ed) FOR CM S-1500 ;13 -DEC-99 ;; 2.0;INTEGR ATED BILLI NG;**51,13 7,232,348, 349,432**; 21-MAR-94; Build 192 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. Q ; EXTCR(IBPR V) ; Calle d by trigg er on fiel d .02 of f ile 399.02 22 ; Also called by trigger on field .02 of file 3 99.0404 (D EM;432). ; Function returns th e first 3 digits of the provid er's degre e if ; a V A provider or the cr edentials in file 35 5.9 if non -VA provid er ; IBPRV = vp to f ile 200 or 355.93 Q $E($$CRED^ IBCEU(IBPR V),1,3) ; FTPRV(IBIF N,NOASK) ; If form t ype change s from UB- 04 to CMS- 1500 or vi ce ; versa , ask to c hange prov ider funct ion to app ropriate f unction fo r ; form t ype (ATTEN DING = UB- 04, RENDER ING = CMS- 1500) ; IB IFN = ien of bill in file 399 ; NOASK (f lag) = 1 i f change s hould happ en without asking fi rst N ATT, REN,FT S F T=$$FT^IBC EF(IBIFN) S REN=$$CK PROV^IBCEU (IBIFN,3,1 ) S ATT=$$ CKPROV^IBC EU(IBIFN,4 ,1) I $S(F T=2:'REN&A TT,FT=3:'A TT&REN,1:0 ) D . I '$ G(NOASK) D TXFERPRV( IBIFN,FT) Q . D PRVC HG(IBIFN,F T) D CLEAN UP(IBIFN,F T) Q ;TXFE RPRV(IBIFN ,FT) ; Ask to change the funct ion of the main prov ider on ; bill IBIFN to the fu nction app ropriate t o the form type FT ; N DIR,X, Y,Z,DIE,DA ,DR,HAVE,N EED,IBZ ; DEM;432 - Changed th e prompt f rom upperc ase to mix ed case. W ! S DIR(" A")=" Chan ge the Cla im Level " _$S(FT=3:" Rendering" ,1:"Attend ing")_" pr ovider's f unction to "_$S(FT=3 :"Attendin g",1:"Rend ering")_"? : " S DIR( 0)="YA",DI R("B")="NO ",DIR("?", 1)="If you answer YE S here, yo u will mak e the clai m level pr ovider fun ctions",DI R("?")=" c onsistent with the f orm type o f the bill " D ^DIR K DIR I Y'= 1 Q D PRVC HG(IBIFN,F T) Q ;PRVC HG(IBIFN,I BFT) ; Cha nge provid er type to type cons istent wit h current ; data on bill N Z,I BZ,HAVE,NE ED,DIE,DA, X,Y S HAVE =$S(IBFT=3 :3,1:4) S NEED=$S(IB FT=3:4,1:3 ) S Z=$O(^ DGCR(399,I BIFN,"PRV" ,"B",HAVE, 0)) I Z D . S DA(1)= IBIFN,DA=+ Z . D FDA^ DILF(399.0 222,.DA,.0 1,,NEED,"I BZ") . D F ILE^DIE(," IBZ") ;I Z S DA(1)=I BIFN,DIE=" ^DGCR(399, "_DA(1)_", ""PRV"",", DA=+Z,DR=" .01////"_N EED D FILE ^DIE(,DIE Q ;CLEANUP (IBIFN,FT) ; If form type chan ges remove any extra provider FUNCTIONS. N X,PRV,C LEAN,DA,DI E ; ; (3) If form ty pe changes from CMS- 1500 to UB -04, remov e any extr a provider FUNCTIONS . I FT=3 F X=5 D ; 5-SUPERVI SING .I $D (^DGCR(399 ,IBIFN,"PR V","B",X)) D .. S PR V=0 F S P RV=$O(^DGC R(399,IBIF N,"PRV","B ",X,PRV)) Q:+PRV=0 D ... S DA( 1)=IBIFN,D A=PRV D FD A^DILF(399 .0222,.DA, .01,,"@"," CLEAN") ; ; (2) If f orm type c hanges fro m UB-04 to CMS-1500, remove an y extra pr ovider FUN CTIONS. I FT=2 F X= 2,4,9 D ; 2-OPERATI NG, 4-ATTE NDING, 9-O THER .I $D (^DGCR(399 ,IBIFN,"PR V","B",X)) D .. S PR V=0 F S P RV=$O(^DGC R(399,IBIF N,"PRV","B ",X,PRV)) Q:+PRV=0 D ... S DA( 1)=IBIFN,D A=PRV D FD A^DILF(399 .0222,.DA, .01,,"@"," CLEAN") ; I $D(CLEAN ) D FILE^D IE(,"CLEAN ") Q ;PRVH ELP ; Text for the p rovider fu nction hel p Q:$G(X)' ="??" N IB Z,IBQUIT,I B,IB1,DIR, Z S IBQUIT =0 S Z="" I '$D(IOSL )!'$D(IOST ) D HOME^% ZIS Q:IOST '["C-" D:$ G(D0) SPEC IFIC(D0) N DIR,X,Y S DIR(0)="E " D ^DIR K DIR W @IO F S:$G(D0) Z=$$FT^IB CEF(D0) S IB=IOSL,IB 1=1 F IBZ= 1:1 S:$P($ T(HLPTXT+I BZ),";;",2 )="" IBQUI T=1 Q:IBQU IT S IB1= 1 D . I $Y >(IB-3) N DIR,X,Y S IB1=0,DIR( 0)="E" D ^ DIR K DIR S IB=IB+IO SL I Y'=1 S IBQUIT=1 Q . W !,$ P($T(HLPTX T+IBZ),";; ",2) I IB1 D . N DIR ,X,Y S DIR (0)="E" D ^DIR K DIR W @IOF Q ;SPECIFIC( IBIFN) ; D isplay spe cific prov ider requi rements fo r the bill IBIFN N I BFT,IBPRV, IBR,ONBILL ,Z,IBZ S I BFT=$$FT^I BCEF(IBIFN ) D GETPRV ^IBCEU(IBI FN,"ALL",. IBPRV) ;Re turns need ed provide rs W !,"Th is bill is ",$S(IBFT =3:"UB-04" ,1:"CMS-15 00"),"/",$ S($$INPAT^ IBCEF(IBIF N):"Inpati ent",1:"Ou tpatient") W !!,"The valid pro vider func tions for this bill are:" F IB Z=1:1:5,9 I $$PRVOK^ IBCEU(IBZ, IBIFN) D . S ONBILL= $$CKPROV^I BCEU(IBIFN ,IBZ) . S IBR=$S($G( IBPRV(IBZ, "NOTOPT")) :1,$G(IBPR V(IBZ,"SIT UATIONAL") ):2,1:0) ; DEM;432 a dded "SITU ATIONAL" c heck. . ; ib2.0*432 . ; W !,IB Z," ",$$EX PAND^IBTRE (399.0222, .01,IBZ),? 18,$S(IBR& 'ONBILL:"* *",1:""),? 20,$S(IBR: "REQUIRED" ,1:"OPTION AL"),$S(ON BILL:" - A LREADY ON BILL",1:" - NOT ON B ILL") . W !,IBZ," ", $$EXPAND^I BTRE(399.0 222,.01,IB Z),?18,$S( IBR&'ONBIL L:"**",1:" "),?20,$S( IBR=1:"REQ UIRED",IBR =2:"SITUAT IONAL",1:" OPTIONAL") W ! Q ;HL PTXT ; Hel ptext for provider f unction ;; ;;PROVID ER FUNCTIO N requirem ents: ;; ;;RENDERIN G: UB-04 S ituational or CMS-15 00 REQUIRE D (CMS-150 0) ;; This is the pr ovider who performed a service . ;; ;;AT TENDING: U B-04 REQUI RED ;; The physician who has p rimary res ponsibilit y ;; for t he patient 's medical care and treatment. ;; ;;OP ERATING: U B-04 SITUA TIONAL ;; The provi der who pe rformed th e principa l procedur e(s) ;; be ing billed . ;; UB-04 (inpatien t): Situat ional IF t ype of bil l has firs t 2 ;; dig its of 11, and there is a prin cipal ;; p rocedure t hat will p rint in Fo rm ;; Loca tor 74 of the claim, there mus t be ;; an Operating or Render ing Provid er. ;; UB- 04 (outpat ient):REQU IRED IF ty pe of bill has first 2 ;; digi ts of 83, and there is a princ ipal ;; pr ocedure th at will pr int in For m ;; Locat or 74 of t he claim. ;; ;;REFE RRING: UB- 04 or CMS- 1500 SITUA TIONAL ;; The provid er who ref erred the patient fo r the serv ices being billed. ;; ;;SUPE RVISING: C MS-1500 OP TIONAL ;; Required w hen the re ndering pr ovider is supervised ;; by ano ther provi der. Data will not b e printed. ;; ;;OTH ER OPERATI NG: UB-04 SITUATIONA L ;; Used to report another Op erating Ph ysician. T here must ;; also be an Operat ing Physic ian on the claim. ;; ;; There are provi ders who p erformed s pecific fu nctions fo r ;; the s ervices on this bill . These pr oviders ar e needed t o ;; enabl e the V.A. to collec t reimburs ement when more than ;; one pr ovider fun ction is i nvolved in the billa ble episod e ;; (like an operat ing physic ian or ref erring pro vider). ; ; ;; This data iden tifies the type of f unction th at was per formed ;; by a provi der. ;; ;L INKRX(IBIF N,IBREV) ; Ask for r evenue cod e's RX if not alread y there N DIR,X,Y,IB Z,IBRX,Z,Z 0,DA Q:$P( $G(^DGCR(3 99,IBIFN," RC",IBREV, 0)),U,11)! ($P($G(^(0 )),U,10)'= 3) S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"RC", Z)) Q:'Z I Z'=IBREV S Z0=$G(^ (Z,0)) I $ P(Z0,U,10) =3,$P(Z0,U ,11) S IBR X(+$P(Z0,U ,11))="" S DIR(0)="P AO^IBA(362 .4,:AEMQ", DIR("S")=" I $P(^(0), U,2)=IBIFN ,'$D(IBRX( +Y))" S DI R("A")="Se lect Rx fo r this cha rge: " S D IR("?",1)= "Enter an Rx# for th is revenue code" S D IR("?")=" The Rx mus t not alre ady have a n associat ed revenue code" D ^ DIR K DIR I Y>0 D . S DA(1)=IB IFN,DA=IBR EV,IBZ="" . D FDA^DI LF(399.042 ,.DA,.11," R",+Y,"IBZ ") . D FIL E^DIE(,"IB Z") Q ;LIN KCPT(IBIFN ,IBREV) ; Ask for re venue code 's CPT N D IR,X,Y,IBZ ,IBCP,Z,Z0 ,Z1,DA,IBR C,IBP S IB RC=$G(^DGC R(399,IBIF N,"RC",IBR EV,0)) Q:$ P(IBRC,U,8 )!($P(IBRC ,U,10)'=4) S IBP=+$P (IBRC,U,6) I $P(IBRC ,U,11) W ! ,"PROCEDUR E #"_$P(IB RC,U,11)_" HAS BEEN ASSOCIATED WITH THIS MANUAL CH ARGE" I '$ P(IBRC,U,1 1) D Q:IB RC="" . S DIR("?",1) ="Respond YES if thi s revenue code charg e specific ally refer ences the data for" . S DIR("? ",2)=" a p articular procedure that was m anually en tered on t he previou s screen." . S DIR(" ?",3)=" Fo r outpatie nt UB-04 b ills, asso ciating a manual rev enue code charge wit h",DIR("?" )=" a proc edure is t he only wa y to print a modifie r in box 4 4" . S DIR (0)="YA",D IR("A")="S HOULD A PR OCEDURE EN TRY BE ASS OCIATED WI TH THIS CH ARGE?: ",D IR("B")=$S (IBP:"YES" ,1:"NO") W ! D ^DIR K DIR W ! . I Y'=1 S IBRC="" Q I $P(IBRC ,U,11) D . S DIR("?" ,1)="Respo nd YES if you no lon ger want t his revenu e code cha rge to ref erence a", DIR("?")=" specific manually e ntered pro cedure" . S DIR(0)=" YA",DIR("A ")="DELETE THE EXIST ING PROCED URE ASSOCI ATION?: ", DIR("B")=" NO" W ! D ^DIR K DIR . I Y=1 D UPDPTR(IB IFN,IBREV, "") S $P(I BRC,U,11)= "" S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"RC", Z)) Q:'Z S Z0=$G(^( Z,0)) I IB REV'=Z,$P( Z0,U,11) D . ; Don't allow to link to 'u sed' proc . I $P(Z0, U,10)=4 S IBCP($P(Z0 ,U,11))="" Q . I $P( Z0,U,10)=3 ,$P(Z0,U,1 5) S IBCP( $P(Z0,U,15 ))="" S DI R(0)="PAO^ DGCR(399," _IBIFN_"," "CP"",:AEM Q",DIR("S" )="I '$D(I BCP(+Y)),$ P(^(0),U)[ ""CPT"",+^ (0)="_+$P( $G(^DGCR(3 99,IBIFN," RC",IBREV, 0)),U,6) S DIR("A")= "SELECT A PROCEDURE ENTRY: "_$ S($P(IBRC, U,11):"#"_ $P(IBRC,U, 11)_" - "_ $$EXPAND^I BTRE(399.0 304,.01,$P ($G(^DGCR( 399,IBIFN, "CP",$P(IB RC,U,11),0 )),U))_"// ",1:"") S DIR("?")= "Enter a m anually-ad ded CPT pr ocedure to associate with this charge" S DA(1)=IBI FN D ^DIR K DIR W ! I Y>0 D UP DPTR(IBIFN ,IBREV,+Y) Q ;UPDPTR (IBIFN,IBR EV,Y) ; N IBZ,DA S D A(1)=IBIFN ,DA=IBREV, IBZ="" D F DA^DILF(39 9.042,.DA, .11,"R",$S (Y:+Y,1:"" ),"IBZ") D FILE^DIE( ,"IBZ") Q ;INSFT(IBI FN) ; Retu rns 1 if f orm type i s UB-04, 0 if CMS-15 00 Q ($$FT ^IBCEF(IBI FN)=3) | |
| 2935 | Modified L ogic (Chan ges are in bold) | |
| 2936 | IBCEU5 ;AL B/TMP - ED I UTILITIE S (continu ed) FOR CM S-1500 ;13 -DEC-99 ;; 2.0;INTEGR ATED BILLI NG;**51,13 7,232,348, 349,432,59 2**;21-MAR -94;Build 192 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. Q ;EXTCR( IBPRV) ; C alled by t rigger on field .02 of file 39 9.0222 ; A lso called by trigge r on field .02 of fi le 399.040 4 (DEM;432 ). ; Funct ion return s the firs t 3 digits of the pr ovider's d egree if ; a VA prov ider or th e credenti als in fil e 355.9 if non-VA pr ovider ; I BPRV = vp to file 20 0 or 355.9 3 Q $E($$C RED^IBCEU( IBPRV),1,3 ) ; FTPRV( IBIFN,NOAS K) ; If fo rm type ch anges from UB-04 to CMS-1500 o r vice ; v ersa, ask to change provider f unction to appropria te functio n for ; fo rm type (A TTENDING = UB-04, RE NDERING = CMS-1500) ; IBIFN = ien of bil l in file 399 ; NOAS K (flag) = 1 if chan ge should happen wit hout askin g first N ATT,REN,FT S FT=$$FT ^IBCEF(IBI FN) S REN= $$CKPROV^I BCEU(IBIFN ,3,1) S AT T=$$CKPROV ^IBCEU(IBI FN,4,1) ;J WS;IB*2.0* 592;add De ntal form check I $ S(FT=2:'RE N&ATT,FT=3 :'ATT&REN, FT=7:'REN& ATT,1:0) D . I '$G(N OASK) D TX FERPRV(IBI FN,FT) Q . D PRVCHG( IBIFN,FT) D CLEANUP( IBIFN,FT) Q ;TXFERPR V(IBIFN,FT ) ; Ask to change th e function of the ma in provide r on ; bil l IBIFN to the funct ion approp riate to t he form ty pe FT ; N DIR,X,Y,Z ,DIE,DA,DR ,HAVE,NEED ,IBZ ; DEM ;432 - Cha nged the p rompt from uppercase to mixed case. W ! S DIR("A") =" Change the Claim Level "_$S (FT=3:"Ren dering",1: "Attending ")_" provi der's func tion to "_ $S(FT=3:"A ttending", 1:"Renderi ng")_"?: " S DIR(0)= "YA",DIR(" B")="NO",D IR("?",1)= "If you an swer YES h ere, you w ill make t he claim l evel provi der functi ons",DIR(" ?")=" cons istent wit h the form type of t he bill" D ^DIR K DI R I Y'=1 Q D PRVCHG( IBIFN,FT) Q ;PRVCHG( IBIFN,IBFT ) ; Change provider type to ty pe consist ent with c urrent ; d ata on bil l N Z,IBZ, HAVE,NEED, DIE,DA,X,Y S HAVE=$S (IBFT=3:3, 1:4) S NEE D=$S(IBFT= 3:4,1:3) S Z=$O(^DGC R(399,IBIF N,"PRV","B ",HAVE,0)) I Z D . S DA(1)=IBI FN,DA=+Z . D FDA^DIL F(399.0222 ,.DA,.01,, NEED,"IBZ" ) . D FILE ^DIE(,"IBZ ") ;I Z S DA(1)=IBIF N,DIE="^DG CR(399,"_D A(1)_",""P RV"",",DA= +Z,DR=".01 ////"_NEED D FILE^DI E(,DIE Q ; CLEANUP(IB IFN,FT) ; If form ty pe changes remove an y extra pr ovider FUN CTIONS. N X,PRV,CLEA N,DA,DIE ; ;JWS;IB*2 .0*592 US1 108 - If f orm type c hanges to (7) J430D - Dental, default Bi ll Charge Type I FT= 7 S CLEAN( 399,IBIFN_ ",",.27)=2 ; (3) If form type changes fr om CMS-150 0 to UB-04 , remove a ny extra p rovider FU NCTIONS. ;JWS;IB*2. 0*592 US11 08 - added 6-ASSISTA NT SURGEON I FT=3 F X=5,6 D ; 5-SUPERVI SING, 6-AS SISTANT SU RGEON . I $D(^DGCR(3 99,IBIFN," PRV","B",X )) D .. S PRV=0 F S PRV=$O(^D GCR(399,IB IFN,"PRV", "B",X,PRV) ) Q:+PRV=0 D ... S D A(1)=IBIFN ,DA=PRV D FDA^DILF(3 99.0222,.D A,.01,,"@" ,"CLEAN") ; ; (2) If form type changes f rom UB-04 to CMS-150 0, remove any extra provider F UNCTIONS. ;JWS;IB*2 .0*592 US1 108 - adde d 6-ASSIST ANT SURGEO N I FT=2 F X=2,4,6,9 D ; 2-OP ERATING, 4 -ATTENDING , 6-ASSIST ANT SURGEO N, 9-OTHER . I $D(^D GCR(399,IB IFN,"PRV", "B",X)) D .. S PRV=0 F S PRV= $O(^DGCR(3 99,IBIFN," PRV","B",X ,PRV)) Q:+ PRV=0 D .. . S DA(1)= IBIFN,DA=P RV D FDA^D ILF(399.02 22,.DA,.01 ,,"@","CLE AN") ; I $ D(CLEAN) D FILE^DIE( ,"CLEAN") Q ;PRVHELP ; Text fo r the prov ider funct ion help Q :$G(X)'="? ?" N IBZ,I BQUIT,IB,I B1,DIR,Z S IBQUIT=0 S Z="" I ' $D(IOSL)!' $D(IOST) D HOME^%ZIS Q:IOST'[" C-" D:$G(D 0) SPECIFI C(D0) N DI R,X,Y S DI R(0)="E" D ^DIR K DI R W @IOF S :$G(D0) Z= $$FT^IBCEF (D0) S IB= IOSL,IB1=1 F IBZ=1:1 S:$P($T(H LPTXT+IBZ) ,";;",2)=" " IBQUIT=1 Q:IBQUIT S IB1=1 D . I $Y>(I B-3) N DIR ,X,Y S IB1 =0,DIR(0)= "E" D ^DIR K DIR S I B=IB+IOSL I Y'=1 S I BQUIT=1 Q . W !,$P($ T(HLPTXT+I BZ),";;",2 ) I IB1 D . N DIR,X, Y S DIR(0) ="E" D ^DI R K DIR W @IOF Q ;SP ECIFIC(IBI FN) ; Disp lay specif ic provide r requirem ents for t he bill IB IFN N IBFT ,IBPRV,IBR ,ONBILL,Z, IBZ S IBFT =$$FT^IBCE F(IBIFN) D GETPRV^IB CEU(IBIFN, "ALL",.IBP RV) ;Retur ns needed providers ;JWS;IB*2. 0*592 US11 08 - added Dental fo rm #7 W !, "This bill is ",$S(I BFT=7:"J43 0D",IBFT=3 :"UB-04",1 :"CMS-1500 "),"/",$S( $$INPAT^IB CEF(IBIFN) :"Inpatien t",1:"Outp atient") W !!,"The v alid provi der functi ons for th is bill ar e:" ;JWS;I B*2.0*592 US1108 - c hanged loo p from :5 to :6 for Assistant Surgeon F IBZ=1:1:6, 9 I $$PRVO K^IBCEU(IB Z,IBIFN) D . S ONBIL L=$$CKPROV ^IBCEU(IBI FN,IBZ) . S IBR=$S($ G(IBPRV(IB Z,"NOTOPT" )):1,$G(IB PRV(IBZ,"S ITUATIONAL ")):2,1:0) ; DEM;432 added "SI TUATIONAL" check. . ;JWS;IB*2. 0*592 US11 08 - denta l form#7 . I IBFT=7 S IBR=2 . ; ib2.0*43 2 . ; W !, IBZ," ",$$ EXPAND^IBT RE(399.022 2,.01,IBZ) ,?18,$S(IB R&'ONBILL: "**",1:"") ,?20,$S(IB R:"REQUIRE D",1:"OPTI ONAL"),$S( ONBILL:" - ALREADY O N BILL",1: " - NOT ON BILL") . W !,IBZ," ",$$EXPAND ^IBTRE(399 .0222,.01, IBZ),?18,$ S(IBR&'ONB ILL:"**",1 :""),?23,$ S(IBR=1:"R EQUIRED",I BR=2:"SITU ATIONAL",1 :"OPTIONAL ") W ! Q ; HLPTXT ; H elptext fo r provider function ;; ;;PROV IDER FUNCT ION requir ements: ;; ;;RENDER ING: UB-04 Situation al, CMS-15 00 REQUIRE D (CMS-150 0), or J43 0D Situati onal ;; Th is is the provider w ho perform ed a servi ce. ;; ;; ATTENDING: UB-04 REQ UIRED ;; T he physici an who has primary r esponsibil ity ;; for the patie nt's medic al care an d treatmen t. ;; ;; OPERATING: UB-04 SIT UATIONAL ;; The pro vider who performed the princi pal proced ure(s) ;; being bill ed. ;; UB- 04 (inpati ent): Situ ational IF type of b ill has fi rst 2 ;; d igits of 1 1, and the re is a pr incipal ;; procedure that will print in Form ;; Lo cator 74 o f the clai m, there m ust be ;; an Operati ng or Rend ering Prov ider. ;; U B-04 (outp atient):RE QUIRED IF type of bi ll has fir st 2 ;; di gits of 83 , and ther e is a pri ncipal ;; procedure that will print in F orm ;; Loc ator 74 of the claim . ;; ;;RE FERRING: U B-04, CMS- 1500, or J 430D SITUA TIONAL ;; The provid er who ref erred the patient fo r the serv ices being billed. ;; ;;SUPE RVISING: C MS-1500 OP TIONAL or J430D SITU ATIONAL ;; Required when the r endering p rovider is supervise d ;; by an other prov ider. Data will not be printed . ;; ;;OT HER OPERAT ING: UB-04 SITUATION AL ;; Used to report another O perating P hysician. There must ;; also b e an Opera ting Physi cian on th e claim. ; ; ;;ASSIST ANT SURGEO N: J430D S ITUATIONAL ;; User w hen the Re ndering Pr ovider pro vided thes e services in the ro le ;; of t he Assisti ng Surgeon . ;; ;; T here are p roviders w ho perform ed specifi c function s for ;; t he service s on this bill. Thes e provider s are need ed to ;; e nable the V.A. to co llect reim bursement when more than ;; on e provider function is involve d in the b illable ep isode ;; ( like an op erating ph ysician or referring provider) . ;; ;; This data identifies the type of functio n that was performed ;; by a p rovider. ; ; ;LINKRX( IBIFN,IBRE V) ; Ask f or revenue code's RX if not al ready ther e N DIR,X, Y,IBZ,IBRX ,Z,Z0,DA Q :$P($G(^DG CR(399,IBI FN,"RC",IB REV,0)),U, 11)!($P($G (^(0)),U,1 0)'=3) S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," RC",Z)) Q: 'Z I Z'=I BREV S Z0= $G(^(Z,0)) I $P(Z0,U ,10)=3,$P( Z0,U,11) S IBRX(+$P( Z0,U,11))= "" S DIR(0 )="PAO^IBA (362.4,:AE MQ",DIR("S ")="I $P(^ (0),U,2)=I BIFN,'$D(I BRX(+Y))" S DIR("A") ="Select R x for this charge: " S DIR("?" ,1)="Enter an Rx# fo r this rev enue code" S DIR("?" )=" The Rx must not already ha ve an asso ciated rev enue code" D ^DIR K DIR I Y>0 D . S DA(1 )=IBIFN,DA =IBREV,IBZ ="" . D FD A^DILF(399 .042,.DA,. 11,"R",+Y, "IBZ") . D FILE^DIE( ,"IBZ") Q ;LINKCPT(I BIFN,IBREV ) ; Ask fo r revenue code's CPT N DIR,X,Y ,IBZ,IBCP, Z,Z0,Z1,DA ,IBRC,IBP S IBRC=$G( ^DGCR(399, IBIFN,"RC" ,IBREV,0)) Q:$P(IBRC ,U,8)!($P( IBRC,U,10) '=4) S IBP =+$P(IBRC, U,6) I $P( IBRC,U,11) W !,"PROC EDURE #"_$ P(IBRC,U,1 1)_" HAS B EEN ASSOCI ATED WITH THIS MANUA L CHARGE" I '$P(IBRC ,U,11) D Q:IBRC="" . S DIR("? ",1)="Resp ond YES if this reve nue code c harge spec ifically r eferences the data f or" . S DI R("?",2)=" a particu lar proced ure that w as manuall y entered on the pre vious scre en." . S D IR("?",3)= " For outp atient UB- 04 bills, associatin g a manual revenue c ode charge with",DIR ("?")=" a procedure is the onl y way to p rint a mod ifier in b ox 44" . S DIR(0)="Y A",DIR("A" )="SHOULD A PROCEDUR E ENTRY BE ASSOCIATE D WITH THI S CHARGE?: ",DIR("B" )=$S(IBP:" YES",1:"NO ") W ! D ^ DIR K DIR W ! . I Y' =1 S IBRC= "" Q I $P( IBRC,U,11) D . S DIR ("?",1)="R espond YES if you no longer wa nt this re venue code charge to reference a",DIR("? ")=" speci fic manual ly entered procedure " . S DIR( 0)="YA",DI R("A")="DE LETE THE E XISTING PR OCEDURE AS SOCIATION? : ",DIR("B ")="NO" W ! D ^DIR K DIR . I Y =1 D UPDPT R(IBIFN,IB REV,"") S $P(IBRC,U, 11)="" S Z =0 F S Z= $O(^DGCR(3 99,IBIFN," RC",Z)) Q: 'Z S Z0=$ G(^(Z,0)) I IBREV'=Z ,$P(Z0,U,1 1) D . ; D on't allow to link t o 'used' p roc . I $P (Z0,U,10)= 4 S IBCP($ P(Z0,U,11) )="" Q . I $P(Z0,U,1 0)=3,$P(Z0 ,U,15) S I BCP($P(Z0, U,15))="" S DIR(0)=" PAO^DGCR(3 99,"_IBIFN _",""CP"", :AEMQ",DIR ("S")="I ' $D(IBCP(+Y )),$P(^(0) ,U)[""CPT" ",+^(0)="_ +$P($G(^DG CR(399,IBI FN,"RC",IB REV,0)),U, 6) S DIR(" A")="SELEC T A PROCED URE ENTRY: "_$S($P(I BRC,U,11): "#"_$P(IBR C,U,11)_" - "_$$EXPA ND^IBTRE(3 99.0304,.0 1,$P($G(^D GCR(399,IB IFN,"CP",$ P(IBRC,U,1 1),0)),U)) _"// ",1:" ") S DIR(" ?")="Enter a manuall y-added CP T procedur e to assoc iate with this charg e" S DA(1) =IBIFN D ^ DIR K DIR W ! I Y>0 D UPDPTR(I BIFN,IBREV ,+Y) Q ;UP DPTR(IBIFN ,IBREV,Y) ; N IBZ,DA S DA(1)=I BIFN,DA=IB REV,IBZ="" D FDA^DIL F(399.042, .DA,.11,"R ",$S(Y:+Y, 1:""),"IBZ ") D FILE^ DIE(,"IBZ" ) Q ;INSFT (IBIFN) ; Returns 1 if form ty pe is UB-0 4, 0 if CM S-1500 or J430D Q ($ $FT^IBCEF( IBIFN)=3) | |
| 2937 | ||
| 2938 | ||
| 2939 | Routines | |
| 2940 | Activities | |
| 2941 | Routine Na me | |
| 2942 | IBCEU7 | |
| 2943 | Enhancemen t Category | |
| 2944 | New | |
| 2945 | Modify | |
| 2946 | Delete | |
| 2947 | No Change | |
| 2948 | RTM | |
| 2949 | ||
| 2950 | Related Op tions | |
| 2951 | None | |
| 2952 | Related Ro utines | |
| 2953 | Routines “ Called By” | |
| 2954 | Routines “ Called” | |
| 2955 | ||
| 2956 | ||
| 2957 | ||
| 2958 | ||
| 2959 | Data Dicti onary (DD) Reference s | |
| 2960 | ||
| 2961 | Related Pr otocols | |
| 2962 | None | |
| 2963 | Related In tegration Control Re gistration s (ICRs) | |
| 2964 | None | |
| 2965 | Data Passi ng | |
| 2966 | Input | |
| 2967 | Output Re ference | |
| 2968 | Both | |
| 2969 | Global Re ference | |
| 2970 | Local | |
| 2971 | Input Attr ibute Name and Defin ition | |
| 2972 | Name: | |
| 2973 | Definition : | |
| 2974 | Output Att ribute Nam e and Defi nition | |
| 2975 | Name: | |
| 2976 | Definition : | |
| 2977 | Current Lo gic | |
| 2978 | IBCEU7 ;AL B/DEM - ED I UTILITIE S ;26-SEP- 2010 ;;2.0 ;INTEGRATE D BILLING; **432**;21 -MAR-94;Bu ild 192 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. Q ;LN PRVOK(VAL, IBIFN) ; C heck bill form & lin e prov fun ction agre e ; DEM;43 2 - New ro utine for Claim Line Provider. ; VAL = i nternal va lue of pro v function ; ; Allow able line provider f unctions f or UB04 (F ORM TYPE = 3) ; Inpa tient and UB04 Outpa tient: ; - Rendering Provider( 3). ; - Re ferring Pr ovider(1). ; - Opera ting Physi cian(2). ; - Other O perating P hysician(9 ). ; ; All owable lin e provider functions for CMS 1 500 (FORM TYPE = 2) ; Inpatien t and CMS 1500 Outpa tient: ; - Rendering Provider( 3). ; - Re ferring Pr ovider(1). ; - Super vising Pro vider(5). ; N OK,IBU B S VAL=$$ UP^XLFSTR( VAL) S OK= $S(VAL'="" :1,1:0) G: 'OK!'$G(IB IFN) PRVQ ; S IBUB=( $$FT^IBCEF (IBIFN)=3) ; 1 if UB -04 ; 0 if CMS-1500 ; ; S OK=0 S:(IBUB)& ("1239"[VA L) OK=1 ; UB-04 S:(' IBUB)&("13 5"[VAL) OK =1 ; CMS-1 500 ;PRVQ Q OK ;LNPR VHLP ;Help text for l ine provid er functio n. ; N IBZ ,IBQUIT,VA LUE,FORMAT F IBZ=1:1 S:$P($T(H LPTXT+IBZ) ,";;",2)=" END" IBQUI T=1 Q:$G(I BQUIT) D . S VALUE=$ P($T(HLPTX T+IBZ),";; ",2) . S F ORMAT=$S(V ALUE="":"! ",1:"") . D EN^DDIOL (VALUE,"", FORMAT) . Q Q ;HLPTX T ; Helpte xt for lin e provider function. ;; ;;Ente r the name of the li ne level p rovider wh o provided this serv ice. ;;Lin e level pr oviders ar e optional and shoul d only be entered if ;;differe nt from th e claim le vel provid er. ;; ;; ;;END ;HLP TXT2 ; *** Currently, not activ ated*** - Helptext f or line pr ovider fun ction. ;; ;;LINE PRO VIDER FUNC TION requi rements: ; ; ;;Allowa ble line p rovider fu nctions fo r UB04 Inp atient and Outpatien t: ;; ;; - Rendering Provider( 3). ;; - R eferring P rovider(1) . ;; - Ope rating Phy sician(2). ;; - Othe r Operatin g Physicia n(9). ;; ; ;Allowable line prov ider funct ions for C MS 1500 In patient an d Outpatie nt: ;; ;; - Renderin g Provider (3). ;; - Referring Provider(1 ). ;; - Su pervising Provider(5 ). ;; ;;EN D Q ;LNPRV FT(IBFT,IB LNPRV) ; D EM;432 - F ield Index "AK" (#30 1) on FORM TYPE fiel d (399,.19 ). ; ; Des cription: ; ; This f unction is called by the FORM TYPE (399, .19) "AK" field inde x. ; In th e case whe n the FORM TYPE fiel d is chang ed, then t he line ; provider t ypes are c hecked to see if any , or all, line provi ders ; nee d to be de leted from the claim . ; ; Inpu t: ; ; IBF T = FORM T YPE = 2 = (CMS-1500) , or FORM TYPE = 3 = (UB-04). ; Must be either FOR M TYPE 2, or FORM TY PE 3 to co ntinue. ; See allowa ble line p rovider fu nctions by FORM TYPE below. ; IBLNPRV = Array pass ed by refe rence. ; ; Output: ; ; OK = 1 = line pro viders to delete, OK = 0 = no line provi ders to de lete. ; IB LNPRV Arra y = If lin e provider s to delet e, then ar ray contai ns ; these line prov iders - IB LNPRV(399. 0404,"IENS ",.01)="@" ; ; Allow able line provider f unctions f or UB04 (F ORM TYPE = 3) ; Inpa tient and UB04 Outpa tient: ; - Rendering Provider( VAL=3). ; - Referrin g Provider (VAL=1). ; - Operati ng Physici an(VAL=2). ; - Other Operating Physician (VAL=9). ; ; Allowab le line pr ovider fun ctions for CMS 1500 (FORM TYPE = 2) ; In patient an d CMS 1500 Outpatien t: ; - Ren dering Pro vider(VAL= 3). ; - Re ferring Pr ovider(VAL =1). ; - S upervising Provider( VAL=5). ; Q:'$G(IBIF N) 0 ; QUI T 0 if no claim numb er. Q:'$G( IBFT) 0 ; QUIT 0 if no FORM TY PE. Q:(IBF T'=2)&(IBF T'=3) 0 ; QUIT 0 - M ust be CMS -1500 (2) or UB-04 ( 3) FORM TY PE. ; N IB PRVFUN,OK S:IBFT=3 I BPRVFUN("V AL",IBFT)= "1239" ; Allowable LINE PROVI DER FUNCTI ONs for UB -04. S:IBF T=2 IBPRVF UN("VAL",I BFT)="135" ; Allowa ble LINE P ROVIDER FU NCTIONs fo r CMS-1500 . ; S OK=0 ; Initial ize OK=0. ; N IBPROC P,IBLPIEN, IBLNPROV,D A S IBPROC P=0 F S I BPROCP=$O( ^DGCR(399, IBIFN,"CP" ,IBPROCP)) Q:'IBPROC P D ; Lo op on PROC EDURES mul tiple. . Q :'($D(^DGC R(399,IBIF N,"CP",IBP ROCP,0))#1 0) ; No ze ro node fo r procedur e. . S IBP RVFUN=0 F S IBPRVFU N=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP,"LNPRV ","B",IBPR VFUN)) Q:' IBPRVFUN D:IBPRVFUN ("VAL",IBF T)'[IBPRVF UN . . S I BLPIEN=0 F S IBLPIE N=$O(^DGCR (399,IBIFN ,"CP",IBPR OCP,"LNPRV ","B",IBPR VFUN,IBLPI EN)) Q:'IB LPIEN D . . . Q:'($ D(^DGCR(39 9,IBIFN,"C P",IBPROCP ,"LNPRV",I BLPIEN,0)) #10) ; No zero node for line l evel provi der. . . . S IBLNPRO V=$P(^DGCR (399,IBIFN ,"CP",IBPR OCP,"LNPRV ",IBLPIEN, 0),U,2) . . . Q:'IBL NPROV ; N o line pro vider for this line provider f unction. . . . S OK= 1,IBLNPRV( 399.0404,I BLPIEN_"," _IBPROCP_" ,"_IBIFN_" ,",.01)="@ " ; We ha ve at leas t one line provider to delete from claim . . . . Q . . Q . Q ; Q OK ;RE MOVE(IBIFN ,IBFT) ; T his will b e used to remove all line leve l provider s and all line level attachmen ts from in patient UB claims ; ; Input IB IFN - Clai m Number ; Q:IBFT'=3 ; Only wo rried abou t UBs N IB INPAT S IB INPAT=$$IN PAT^IBCEF( IBIFN) Q:' IBINPAT ; Quit if it's not a n inpatien t ; ; If w e got here , we have an inpatie nt UB ; In which cas e, we shou ld not hav e any line level pro viders or line level attachmen t control numbers ; If we do, then let's remove th em ; N CPI EN,LNPRVIE N,FDA,ERR S CPIEN=0 F S CPIEN =$O(^DGCR( 399,IBIFN, "CP",CPIEN )) Q:'+CPI EN D . ; . ; Remove the Line level atta chments . S FDA(399. 0304,CPIEN _","_IBIFN _",",70)=" @" . S FDA (399.0304, CPIEN_","_ IBIFN_",", 71)="@" . S FDA(399. 0304,CPIEN _","_IBIFN _",",72)=" @" . D FIL E^DIE("E", "FDA") . ; . K FDA . S LNPRVIE N=0 F S L NPRVIEN=$O (^DGCR(399 ,IBIFN,"CP ",CPIEN,"L NPRV",LNPR VIEN)) Q:' +LNPRVIEN D .. ; .. ;Remove t he line le vel provid ers .. S F DA(399.040 4,LNPRVIEN _","_CPIEN _","_IBIFN _",",.01)= "@" . I $D (FDA) D FI LE^DIE("E" ,"FDA") Q | |
| 2979 | Modified L ogic (Chan ges are in bold) | |
| 2980 | IBCEU7 ;AL B/DEM - ED I UTILITIE S ;26-SEP- 2010 ;;2.0 ;INTEGRATE D BILLING; **432,592* *;21-MAR-9 4;Build 19 2 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. Q ;LNPRVOK( VAL,IBIFN) ; Check b ill form & line prov function agree ; DE M;432 - Ne w routine for Claim Line Provi der. ; VAL = interna l value of prov func tion ; ; A llowable l ine provid er functio ns for UB0 4 (FORM TY PE = 3) ; Inpatient and UB04 O utpatient: ; - Rende ring Provi der(3). ; - Referrin g Provider (1). ; - O perating P hysician(2 ). ; - Oth er Operati ng Physici an(9). ; ; Allowable line prov ider funct ions for C MS 1500 (F ORM TYPE = 2) ; Inpa tient and CMS 1500 O utpatient: ; - Rende ring Provi der(3). ; - Referrin g Provider (1). ; - S upervising Provider( 5). ; ;JWS ;IB*2.0*59 2 US1108 ; Allowable line prov ider funct ions for J 430D Denta l (FORM TY PE = 7) ; Inpatient and CMS 15 00 Outpati ent: ; - R endering P rovider(3) . ; - Refe rring Prov ider(1). ; - Supervi sing Provi der(5). ; - Assistan t Surgeon (6). ; N O K,IBUB S V AL=$$UP^XL FSTR(VAL) S OK=$S(VA L'="":1,1: 0) G:'OK!' $G(IBIFN) PRVQ ; ;JW S;IB*2.0*5 92 US1108 - 2 for fo rm#7 Denta l S IBUB=$ S($$FT^IBC EF(IBIFN)= 7:2,1:($$F T^IBCEF(IB IFN)=3)) ; 1 if UB-0 4 ; 0 if C MS-1500 ; 2 if J430D Dental fo rm ; S OK= 0 I IBUB=1 ,"1239"[VA L S OK=1 ; UB-04 I ' IBUB,"135" [VAL S OK= 1 ; CMS-15 00 ;JWS;IB *2.0*592 U S1108 J430 D Dental I IBUB=2,"1 356"[VAL S OK=1 ;PRV Q Q OK ;LN PRVHLP ;He lptext for line prov ider funct ion. ; N I BZ,IBQUIT, VALUE,FORM AT F IBZ=1 :1 S:$P($T (HLPTXT+IB Z),";;",2) ="END" IBQ UIT=1 Q:$G (IBQUIT) D . S VALUE =$P($T(HLP TXT+IBZ)," ;;",2) . S FORMAT=$S (VALUE="": "!",1:"") . D EN^DDI OL(VALUE," ",FORMAT) . Q Q ;HLP TXT ; Help text for l ine provid er functio n. ;; ;;En ter the na me of the line level provider who provid ed this se rvice. ;;L ine level providers are option al and sho uld only b e entered if ;;diffe rent from the claim level prov ider. ;; ; ; ;;END ;H LPTXT2 ; * **Currentl y, not act ivated*** - Helptext for line provider f unction. ; ; ;;LINE P ROVIDER FU NCTION req uirements: ;; ;;Allo wable line provider functions for UB04 I npatient a nd Outpati ent: ;; ;; - Renderi ng Provide r(3). ;; - Referring Provider( 1). ;; - O perating P hysician(2 ). ;; - Ot her Operat ing Physic ian(9). ;; ;;Allowab le line pr ovider fun ctions for CMS 1500 Inpatient and Outpat ient: ;; ; ; - Render ing Provid er(3). ;; - Referrin g Provider (1). ;; - Supervisin g Provider (5). ;; ;; Allowable line prov ider funct ions for J 430D Denta l (FORM TY PE = 7) ;; Inpatient and CMS 1 500 Outpat ient: ;; - Rendering Provider( 3). ;; - R eferring P rovider(1) . ;; - Sup ervising P rovider(5) . ;; - Ass istant Sur geon (6). ;; ;;END Q ;LNPRVFT( IBFT,IBLNP RV) ; DEM; 432 - Fiel d Index "A K" (#301) on FORM TY PE field ( 399,.19). ; ; Descri ption: ; ; This func tion is ca lled by th e FORM TYP E (399,.19 ) "AK" fie ld index. ; In the c ase when t he FORM TY PE field i s changed, then the line ; pro vider type s are chec ked to see if any, o r all, lin e provider s ; need t o be delet ed from th e claim. ; ; Input: ; ; IBFT = FORM TYPE = 2 = (CM S-1500), o r FORM TYP E = 3 = (U B-04). ; M ust be eit her FORM T YPE 2, or FORM TYPE 3 to conti nue. ; See allowable line prov ider funct ions by FO RM TYPE be low. ; IBL NPRV = Arr ay passed by referen ce. ; ; Ou tput: ; ; OK = 1 = l ine provid ers to del ete, OK = 0 = no lin e provider s to delet e. ; IBLNP RV Array = If line p roviders t o delete, then array contains ; these li ne provide rs - IBLNP RV(399.040 4,"IENS",. 01)="@" ; ; Allowabl e line pro vider func tions for UB04 (FORM TYPE = 3) ; Inpatie nt and UB0 4 Outpatie nt: ; - Re ndering Pr ovider(VAL =3). ; - R eferring P rovider(VA L=1). ; - Operating Physician( VAL=2). ; - Other Op erating Ph ysician(VA L=9). ; ; Allowable line provi der functi ons for CM S 1500 (FO RM TYPE = 2) ; Inpat ient and C MS 1500 Ou tpatient: ; - Render ing Provid er(VAL=3). ; - Refer ring Provi der(VAL=1) . ; - Supe rvising Pr ovider(VAL =5). ; ; A llowable l ine provid er functio ns for J43 0D (FORM T YPE = 7) ; Dental: ; - Renderi ng Provide r(VAL=3). ; - Referr ing Provid er(VAL=1). ; - Super vising Pro vider(VAL= 5). ; - As sistant Su rgeon(VAL= 6). ; Q:'$ G(IBIFN) 0 ; QUIT 0 if no clai m number. Q:'$G(IBFT ) 0 ; QUIT 0 if no F ORM TYPE. ;JWS;IB*2. 0*592 US11 08 Q:(IBFT '=2)&(IBFT '=3)&(IBFT '=7) 0 ; Q UIT 0 - Mu st be CMS- 1500 (2) o r UB-04 (3 ) or J430D (7) FORM TYPE. ; N IBPRVFUN,O K S:IBFT=3 IBPRVFUN( "VAL",IBFT )="1239" ; Allowabl e LINE PRO VIDER FUNC TIONs for UB-04. S:I BFT=2 IBPR VFUN("VAL" ,IBFT)="13 5" ; Allo wable LINE PROVIDER FUNCTIONs for CMS-15 00. ;JWS;I B*2.0*592 US1108 S:I BFT=7 IBPR VFUN("VAL" ,IBFT)="13 56" ;Allo wable LINE PROVIDER FUNCTIONs for J430D. ; S OK=0 ; Initiali ze OK=0. ; N IBPROCP ,IBLPIEN,I BLNPROV,DA S IBPROCP =0 F S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP)) Q:'IBPROCP D ; Loo p on PROCE DURES mult iple. . Q: '($D(^DGCR (399,IBIFN ,"CP",IBPR OCP,0))#10 ) ; No zer o node for procedure . . S IBPR VFUN=0 F S IBPRVFUN =$O(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,"B",IBPRV FUN)) Q:'I BPRVFUN D :IBPRVFUN( "VAL",IBFT )'[IBPRVFU N . . S IB LPIEN=0 F S IBLPIEN =$O(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,"B",IBPRV FUN,IBLPIE N)) Q:'IBL PIEN D . . . Q:'($D (^DGCR(399 ,IBIFN,"CP ",IBPROCP, "LNPRV",IB LPIEN,0))# 10) ; No z ero node f or line le vel provid er. . . . S IBLNPROV =$P(^DGCR( 399,IBIFN, "CP",IBPRO CP,"LNPRV" ,IBLPIEN,0 ),U,2) . . . Q:'IBLN PROV ; No line prov ider for t his line p rovider fu nction. . . . S OK=1 ,IBLNPRV(3 99.0404,IB LPIEN_","_ IBPROCP_", "_IBIFN_", ",.01)="@" ; We hav e at lease t one line provider to delete from claim . . . . Q . . Q . Q ; Q OK ;RE MOVE(IBIFN ,IBFT) ; T his will b e used to remove all line leve l provider s and all line level attachmen ts from in patient UB claims ; ; Input IB IFN - Clai m Number ; Q:IBFT'=3 ; Only wo rried abou t UBs N IB INPAT S IB INPAT=$$IN PAT^IBCEF( IBIFN) Q:' IBINPAT ; Quit if it's not a n inpatien t ; ; If w e got here , we have an inpatie nt UB ; In which cas e, we shou ld not hav e any line level pro viders or line level attachmen t control numbers ; If we do, then let's remove th em ; N CPI EN,LNPRVIE N,FDA,ERR S CPIEN=0 F S CPIEN =$O(^DGCR( 399,IBIFN, "CP",CPIEN )) Q:'+CPI EN D . ; . ; Remove the Line level atta chments . S FDA(399. 0304,CPIEN _","_IBIFN _",",70)=" @" . S FDA (399.0304, CPIEN_","_ IBIFN_",", 71)="@" . S FDA(399. 0304,CPIEN _","_IBIFN _",",72)=" @" . D FIL E^DIE("E", "FDA") . ; . K FDA . S LNPRVIE N=0 F S L NPRVIEN=$O (^DGCR(399 ,IBIFN,"CP ",CPIEN,"L NPRV",LNPR VIEN)) Q:' +LNPRVIEN D .. ; .. ;Remove t he line le vel provid ers .. S F DA(399.040 4,LNPRVIEN _","_CPIEN _","_IBIFN _",",.01)= "@" . I $D (FDA) D FI LE^DIE("E" ,"FDA") Q | |
| 2981 | ||
| 2982 | Routines | |
| 2983 | Activities | |
| 2984 | Routine Na me | |
| 2985 | IBCEXTRP | |
| 2986 | Enhancemen t Category | |
| 2987 | New | |
| 2988 | Modify | |
| 2989 | Delete | |
| 2990 | No Change | |
| 2991 | RTM | |
| 2992 | ||
| 2993 | Related Op tions | |
| 2994 | None | |
| 2995 | Related Ro utines | |
| 2996 | Routines “ Called By” | |
| 2997 | Routines “ Called” | |
| 2998 | ||
| 2999 | ||
| 3000 | ||
| 3001 | ||
| 3002 | Data Dicti onary (DD) Reference s | |
| 3003 | ||
| 3004 | Related Pr otocols | |
| 3005 | None | |
| 3006 | Related In tegration Control Re gistration s (ICRs) | |
| 3007 | None | |
| 3008 | Data Passi ng | |
| 3009 | Input | |
| 3010 | Output Re ference | |
| 3011 | Both | |
| 3012 | Global Re ference | |
| 3013 | Local | |
| 3014 | Input Attr ibute Name and Defin ition | |
| 3015 | Name: | |
| 3016 | Definition : | |
| 3017 | Output Att ribute Nam e and Defi nition | |
| 3018 | Name: | |
| 3019 | Definition : | |
| 3020 | Current Lo gic | |
| 3021 | IBCEXTRP ; ALB/JEH - VIEW/PRINT EDI EXTRA CT DATA ;4 /22/03 9:5 9am ;;2.0; INTEGRATED BILLING;* *137,197,2 11,348,349 ,377**;21- MAR-94;Bui ld 23 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ;EN ;IN IT ; W !!, "This opti on will di splay the EDI extrac t data for a bill.", ! N IBREC1 ,IBIEN,IBI NC,DIC,X,Y ,DIR,IB364 IEN,IBVNUM ,IBSEG,STO P,POP,DTOU T,DUOUT ; N DPTNOFZY S DPTNOFZ Y=1 ; Supp ress PATIE NT file fu zzy lookup s S DIC="^ DGCR(399," ,DIC(0)="A EMQ",DIC(" S")="I 234 [$P(^(0),U ,13)" D ^D IC I Y<1 G EXITQ S I BIEN=+Y,IB REC1=$G(^D GCR(399,IB IEN,0)) S IB364IEN=$ $LAST364^I BCEF4(IBIE N) I +$G(I B364IEN)=0 D G EXIT Q . W !,"T here is no entry in the EDI Tr ansmit Bil l file for this bill number." S IBVNUM=$ P($G(^IBA( 364,IB364I EN,0)),U,2 ) I +$G(IB VNUM)=0 D G EXITQ . W !!,"The re is no b atch # for this bill . It has n ot been tr ansmitted. " S IBVNUM =$P($G(^IB A(364.1,IB VNUM,0)),U ) S DIR("A ")="Includ e Fields W ith No Dat a?: ",DIR( "B")="NO", DIR(0)="YA " W ! D ^D IR K DIR I $D(DTOUT) !$D(DUOUT) G EXITQ S IBINC=+Y ; ; IB*2*3 77 - esg - Ask for s pecific ED I segments to view ; W ! S DIR (0)="SA^A: All EDI Se gments;S:S elected ED I Segments " S DIR("A ")="Includ e (A)ll or (S)electe d EDI Segm ents?: " S DIR("B")= "All EDI S egments" D ^DIR K DI R I $D(DTO UT)!$D(DUO UT) G EXIT Q I Y="A" G DEV ; all segments, skip to d evice prom pt ; W ! K IBSEG S S TOP=0 F D Q:STOP . S DIR(0)= "FO^3:4" . S DIR("A" )=" Select EDI Segme nt" . I $D (IBSEG) S DIR("A")=" Another ED I Segment" . S DIR(" ?")="Enter the name of the EDI segment t o include. " . D ^DIR K DIR . I $D(DTOUT) !$D(DUOUT) S STOP=1 Q . S Y=$$ UP^XLFSTR( Y),Y=$$TRI M^XLFSTR(Y ) ; upperc ase/trim s paces . I Y="" S STO P=1 Q . S IBSEG(Y)=" " . Q I $D (DTOUT)!$D (DUOUT) G EXITQ ;DEV ; - Selec t device N %ZIS,ZTRT N,ZTSAVE,Z TDESC W ! S %ZIS="QM " D ^%ZIS G:POP EXIT Q I $D(IO( "Q")) D G EXITQ . S ZTRTN="LI ST^IBCEXTR P",ZTDESC= "Transmitt ed Bill Ex tract Data " . S ZTSA VE("IB*")= "" . D ^%Z TLOAD . W !!,$S($D(Z TSK):"Your task numb er "_ZTSK_ " has been queued.", 1:"Unable to queue t his job.") .K ZTSK,I O("Q") D H OME^%ZIS U IO ;LIST ; - set up array and print dat a N IBPG,I BSEQ,IBPC, IBDA,IBREC ,IBQUIT,IB ILL,IBLINE ,IBXDATA,I BERR,IBXER R,Z,Z0,Z1 D EXTRACT( IBIEN,IBVN UM,8,1) S (IBPG,IBQU IT,IBSEQ,I BPC,IBDA,I BLINE)=0 K ^TMP($J," IBLINES") ;IB*2.0*21 1 - rely o n form typ e instead of bill ch arge type N IBFMTYP S IBFMTYP= $$FT^IBCEF (IBIEN) S IBFMTYP=$S (IBFMTYP=2 :"CMS-1500 ",IBFMTYP= 3:"UB-04", 1:"OTHER"_ "("_IBFMTY P_")") S I BILL=$S($$ INPAT^IBCE F(IBIEN,1) :"Inpt",1: "Oupt")_"/ "_IBFMTYP ; I $D(^TM P("IBXERR" ,$J)) D G EXITQ . S IBERR=0 F S IBERR= $O(^TMP("I BXERR",$J, IBERR)) Q: 'IBERR W !,$G(^TMP( "IBXERR",$ J,IBERR)) . Q ; F S IBSEQ=$O( ^IBA(364.6 ,"ASEQ",8, IBSEQ)) Q: 'IBSEQ I $$INCLUDE( IBSEQ) F S IBPC=$O( ^IBA(364.6 ,"ASEQ",8, IBSEQ,1,IB PC)) Q:'IB PC F S I BDA=$O(^IB A(364.6,"A SEQ",8,IBS EQ,1,IBPC, IBDA)) Q:' IBDA D . N IBOK,Z,I BMULT,DSP, IBDATA,PCD ,SN . S IB REC=$G(^IB A(364.6,IB DA,0)) . I $P(IBREC, U,11)=1 Q ; calc ulate only field . ; . ; proce ssing for piece 1 of this EDI segment to see if th ere is any . ; other data that exists in this segm ent . I IB PC=1 S IBO K=0 D .. S Z=1 F S Z=$O(^TMP( "IBXDATA", $J,1,IBSEQ ,1,Z)) Q:' Z I $G(^( Z))'="" S IBOK=1 Q . . I IBOK Q ; data exists so include se gment norm ally .. S SN=$P($G(^ TMP("IBXDA TA",$J,1,I BSEQ,1,1)) ,U,1) ; se gment name .. I SN=" " S SN=$P( $P(IBREC,U ,10),"'",2 ) .. S SN= SN_" (No D ata - Reco rd Not Sen t)" .. S $ P(^TMP("IB XDATA",$J, 1,IBSEQ,1, 1),U,1)=SN .. Q . ; . ; loop t hru all mu ltiple occ urrences o f this seg ment . S I BMULT=0 F S IBMULT= $O(^TMP("I BXDATA",$J ,1,IBSEQ,I BMULT)) Q: 'IBMULT D .. ; .. ; field wi th no data ; check us er prefere nce .. I ' $G(IBINC), $P($G(^TMP ("IBXDATA" ,$J,1,IBSE Q,IBMULT,I BPC)),U,1) ="" Q .. ; .. ; buil d display data .. S PCD="["_IB PC_"] " ; piece # .. S DSP =$P(IBREC, U,10) ; sh ort descri ption fiel d .. S IBD ATA=$P($G( ^TMP("IBXD ATA",$J,1, IBSEQ,IBMU LT,IBPC)), U,1) ; dat a .. S DSP =$J(PCD,5) _$$FO^IBCN EUT1(DSP,4 0)_": "_IB DATA .. S ^TMP($J,"I BLINES",IB SEQ,IBMULT ,IBPC)=DSP .. Q . Q ; S IBQUIT =0 W:$E(IO ST,1,2)["C -" @IOF ; initial fo rm feed fo r screen p rint N IBF MTYP S IBF MTYP=$$FT^ IBCEF(IBIE N) S IBFMT YP=$S(IBFM TYP=2:"CMS -1500",IBF MTYP=3:"UB -04",1:"OT HER"_"("_I BFMTYP_")" ) S IBILL= $S($$INPAT ^IBCEF(IBI EN,1):"Inp t",1:"Oupt ")_"/"_IBF MTYP D HDR S Z=0 F S Z=$O(^TM P($J,"IBLI NES",Z)) Q :'Z!IBQUIT S Z0=0 F S Z0=$O( ^TMP($J,"I BLINES",Z, Z0)) Q:'Z0 !IBQUIT S Z1=0 F S Z1=$O(^TM P($J,"IBLI NES",Z,Z0, Z1)) Q:'Z1 !IBQUIT D Q:IBQUIT . I IBLIN E>(IOSL-3) D HDR Q:I BQUIT . W !,^TMP($J, "IBLINES", Z,Z0,Z1) . S IBLINE= IBLINE+1 . I IBLINE> (IOSL-3) D HDR Q:IBQ UIT . ; . ; end of s egment add an extra line feed . I '$O(^T MP($J,"IBL INES",Z,Z0 ,Z1)) W ! S IBLINE=I BLINE+1 . Q ; K ^TMP ($J,"IBLIN ES") G EXI TQ ; ;HDR ; - Report header N DIR,Y I IB PG D Q:IB QUIT . I $ E(IOST,1,2 )["C-" K D IR S DIR(0 )="E" D ^D IR K DIR S IBQUIT=(' Y) Q:IBQUI T . W @IOF ; S IBPG= IBPG+1 W ! ,?25,"EDI Transmitte d Bill Ext ract Data" ,!,"Bill # ",?11,"Typ e",?27,"Pa tient Name ",?52,"SSN ",?57,$$FM TE^XLFDT(D T),?71,"Pa ge: "_IBPG W !,$TR($ J("",IOM), " ","=") W !,$P(IBRE C1,U)_" "_ "("_IBILL_ ")",?27,$P ($G(^DPT(+ $P(IBREC1, U,2),0)),U ),?52,$P($ G(^DPT($P( IBREC1,U,2 ),0)),U,9) ,! S IBLIN E=6 Q ;EXI TQ ; - cle an up and exit I $E( IOST,1,2)[ "C-",'$G(I BQUIT) K D IR S DIR(0 )="E" W ! D ^DIR K D IR K ^TMP( "IBXERR",$ J),^TMP("I BXDATA",$J ),IBXERR D CLEAN^DIL F Q ;EXTRA CT(IBIFN,I BBATCH,IBF ORM,IBLOCA L) ; Extra cts transm itted form data into global ; ^TMP("IBXD ATA",$J). Errors are in ^TMP(" IBXERR",$J ,err_num)= text. ; IB BATCH = Ba tch # of b ill (if kn own), othe rwise, set to 1. Thi s ; variab le must be > 0 to pr event a ne w batch fr om being a dded ; IBF ORM = the ien of the form in f ile 353 ; IBLOCAL = 1 if OK to use local form, 0 i f not N IB VNUM,IBL,I BINC,IBSEG D FORMPRE ^IBCFP1 S IBVNUM=$G( IBBATCH) S IBL=$S('$ G(IBLOCAL) :IBFORM,1: "") ; No l ocal form ... set = main form ; Get loca l form ass ociated wi th parent, if any I IBL="" S I BL=$S($P($ G(^IBE(353 ,+IBFORM,2 )),U,8):$P (^(2),U,8) ,1:IBFORM) D SETUP^I BCE837(1) D ROUT^IBC FP1(IBFORM ,1,IBIFN,0 ,IBL) Q ;I NCLUDE(IBS EQ) ; Func tion to de termine if segment s hould be i ncluded or not N OK, LZ,SEGNAME S OK=1 ; default is to includ e it I '$D (IBSEG) G INCLX ; if nothi ng in arra y, then in clude all I '$D(^TMP ("IBXDATA" ,$J,1,IBSE Q)) S OK=0 G INCLX ; no data ther e S LZ=+$O (^TMP("IBX DATA",$J,1 ,IBSEQ,"") ) ; first line# foun d in data S SEGNAME= $P($G(^TMP ("IBXDATA" ,$J,1,IBSE Q,LZ,1)),U ,1) ; piec e 1 S SEGN AME=$$TRIM ^XLFSTR(SE GNAME) I S EGNAME'="" ,'$D(IBSEG (SEGNAME)) S OK=0 ; don't incl udeINCLX ; Q OK ; | |
| 3022 | Modified L ogic (Chan ges are in bold) | |
| 3023 | IBCEXTRP ; ALB/JEH - VIEW/PRINT EDI EXTRA CT DATA ;4 /22/03 9:5 9am ;;2.0; INTEGRATED BILLING;* *137,197,2 11,348,349 ,377,592** ;21-MAR-94 ;Build 23 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ;EN ;INIT ; W !!,"This option wil l display the EDI ex tract data for a bil l.",! N IB REC1,IBIEN ,IBINC,DIC ,X,Y,DIR,I B364IEN,IB VNUM,IBSEG ,STOP,POP, DTOUT,DUOU T ; N DPTN OFZY S DPT NOFZY=1 ; Suppress P ATIENT fil e fuzzy lo okups S DI C="^DGCR(3 99,",DIC(0 )="AEMQ",D IC("S")="I 234[$P(^( 0),U,13)" D ^DIC I Y <1 G EXITQ S IBIEN=+ Y,IBREC1=$ G(^DGCR(39 9,IBIEN,0) ) S IB364I EN=$$LAST3 64^IBCEF4( IBIEN) I + $G(IB364IE N)=0 D G EXITQ . W !,"There i s no entry in the ED I Transmit Bill file for this bill numbe r." S IBVN UM=$P($G(^ IBA(364,IB 364IEN,0)) ,U,2) I +$ G(IBVNUM)= 0 D G EXI TQ . W !!, "There is no batch # for this bill. It h as not bee n transmit ted." S IB VNUM=$P($G (^IBA(364. 1,IBVNUM,0 )),U) S DI R("A")="In clude Fiel ds With No Data?: ", DIR("B")=" NO",DIR(0) ="YA" W ! D ^DIR K D IR I $D(DT OUT)!$D(DU OUT) G EXI TQ S IBINC =+Y ; ; IB *2*377 - e sg - Ask f or specifi c EDI segm ents to vi ew ; W ! S DIR(0)="S A^A:All ED I Segments ;S:Selecte d EDI Segm ents" S DI R("A")="In clude (A)l l or (S)el ected EDI Segments?: " S DIR(" B")="All E DI Segment s" D ^DIR K DIR I $D (DTOUT)!$D (DUOUT) G EXITQ I Y= "A" G DEV ; all segme nts, skip to device prompt ; W ! K IBSEG S STOP=0 F D Q:ST OP . S DIR (0)="FO^3: 4" . S DIR ("A")=" Se lect EDI S egment" . I $D(IBSEG ) S DIR("A ")="Anothe r EDI Segm ent" . S D IR("?")="E nter the n ame of the EDI segme nt to incl ude." . D ^DIR K DIR . I $D(DT OUT)!$D(DU OUT) S STO P=1 Q . S Y=$$UP^XLF STR(Y),Y=$ $TRIM^XLFS TR(Y) ; up percase/tr im spaces . I Y="" S STOP=1 Q . S IBSEG( Y)="" . Q I $D(DTOUT )!$D(DUOUT ) G EXITQ ;DEV ; - S elect devi ce N %ZIS, ZTRTN,ZTSA VE,ZTDESC W ! S %ZIS ="QM" D ^% ZIS G:POP EXITQ I $D (IO("Q")) D G EXITQ . S ZTRTN ="LIST^IBC EXTRP",ZTD ESC="Trans mitted Bil l Extract Data" . S ZTSAVE("IB *")="" . D ^%ZTLOAD . W !!,$S( $D(ZTSK):" Your task number "_Z TSK_" has been queue d.",1:"Una ble to que ue this jo b.") .K ZT SK,IO("Q") D HOME^%Z IS U IO ;L IST ; - se t up array and print data N IB PG,IBSEQ,I BPC,IBDA,I BREC,IBQUI T,IBILL,IB LINE,IBXDA TA,IBERR,I BXERR,Z,Z0 ,Z1 D EXTR ACT(IBIEN, IBVNUM,8,1 ) S (IBPG, IBQUIT,IBS EQ,IBPC,IB DA,IBLINE) =0 K ^TMP( $J,"IBLINE S") ;IB*2. 0*211 - re ly on form type inst ead of bil l charge t ype N IBFM TYP S IBFM TYP=$$FT^I BCEF(IBIEN ) ;JWS;IB* 2.0*592 - Dental for m 7 (J430D ) S IBFMTY P=$S(IBFMT YP=2:"CMS- 1500",IBFM TYP=3:"UB- 04",IBFMTY P=7:"J430D ",1:"OTHER "_"("_IBFM TYP_")") S IBILL=$S( $$INPAT^IB CEF(IBIEN, 1):"Inpt", 1:"Oupt")_ "/"_IBFMTY P ; I $D(^ TMP("IBXER R",$J)) D G EXITQ . S IBERR=0 F S IBER R=$O(^TMP( "IBXERR",$ J,IBERR)) Q:'IBERR W !,$G(^TM P("IBXERR" ,$J,IBERR) ) . Q ; F S IBSEQ=$ O(^IBA(364 .6,"ASEQ", 8,IBSEQ)) Q:'IBSEQ I $$INCLUD E(IBSEQ) F S IBPC=$ O(^IBA(364 .6,"ASEQ", 8,IBSEQ,1, IBPC)) Q:' IBPC F S IBDA=$O(^ IBA(364.6, "ASEQ",8,I BSEQ,1,IBP C,IBDA)) Q :'IBDA D . N IBOK,Z ,IBMULT,DS P,IBDATA,P CD,SN . S IBREC=$G(^ IBA(364.6, IBDA,0)) . I $P(IBRE C,U,11)=1 Q ; ca lculate on ly field . ; . ; pro cessing fo r piece 1 of this ED I segment to see if there is a ny . ; oth er data th at exists in this se gment . I IBPC=1 S I BOK=0 D .. S Z=1 F S Z=$O(^TM P("IBXDATA ",$J,1,IBS EQ,1,Z)) Q :'Z I $G( ^(Z))'="" S IBOK=1 Q .. I IBOK Q ; dat a exists s o include segment no rmally .. S SN=$P($G (^TMP("IBX DATA",$J,1 ,IBSEQ,1,1 )),U,1) ; segment na me .. I SN ="" S SN=$ P($P(IBREC ,U,10),"'" ,2) .. S S N=SN_" (No Data - Re cord Not S ent)" .. S $P(^TMP(" IBXDATA",$ J,1,IBSEQ, 1,1),U,1)= SN .. Q . ; . ; loop thru all multiple o ccurrences of this s egment . S IBMULT=0 F S IBMUL T=$O(^TMP( "IBXDATA", $J,1,IBSEQ ,IBMULT)) Q:'IBMULT D .. ; . . ; field with no da ta; check user prefe rence .. I '$G(IBINC ),$P($G(^T MP("IBXDAT A",$J,1,IB SEQ,IBMULT ,IBPC)),U, 1)="" Q .. ; .. ; bu ild displa y data .. S PCD="["_ IBPC_"] " ; pie ce# .. S D SP=$P(IBRE C,U,10) ; short desc ription fi eld .. S I BDATA=$P($ G(^TMP("IB XDATA",$J, 1,IBSEQ,IB MULT,IBPC) ),U,1) ; d ata .. S D SP=$J(PCD, 5)_$$FO^IB CNEUT1(DSP ,40)_": "_ IBDATA .. S ^TMP($J, "IBLINES", IBSEQ,IBMU LT,IBPC)=D SP .. Q . Q ; S IBQU IT=0 W:$E( IOST,1,2)[ "C-" @IOF ; initial form feed for screen print N I BFMTYP S I BFMTYP=$$F T^IBCEF(IB IEN) ;JWS; IB*2.0*592 - Dental form 7 (J4 30D) S IBF MTYP=$S(IB FMTYP=2:"C MS-1500",I BFMTYP=3:" UB-04",IBF MTYP=7:"J4 30D",1:"OT HER"_"("_I BFMTYP_")" ) S IBILL= $S($$INPAT ^IBCEF(IBI EN,1):"Inp t",1:"Oupt ")_"/"_IBF MTYP D HDR S Z=0 F S Z=$O(^TM P($J,"IBLI NES",Z)) Q :'Z!IBQUIT S Z0=0 F S Z0=$O( ^TMP($J,"I BLINES",Z, Z0)) Q:'Z0 !IBQUIT S Z1=0 F S Z1=$O(^TM P($J,"IBLI NES",Z,Z0, Z1)) Q:'Z1 !IBQUIT D Q:IBQUIT . I IBLIN E>(IOSL-3) D HDR Q:I BQUIT . W !,^TMP($J, "IBLINES", Z,Z0,Z1) . S IBLINE= IBLINE+1 . I IBLINE> (IOSL-3) D HDR Q:IBQ UIT . ; . ; end of s egment add an extra line feed . I '$O(^T MP($J,"IBL INES",Z,Z0 ,Z1)) W ! S IBLINE=I BLINE+1 . Q ; K ^TMP ($J,"IBLIN ES") G EXI TQ ; ;HDR ; - Report header N DIR,Y I IB PG D Q:IB QUIT . I $ E(IOST,1,2 )["C-" K D IR S DIR(0 )="E" D ^D IR K DIR S IBQUIT=(' Y) Q:IBQUI T . W @IOF ; S IBPG= IBPG+1 W ! ,?25,"EDI Transmitte d Bill Ext ract Data" ,!,"Bill # ",?11,"Typ e",?27,"Pa tient Name ",?52,"SSN ",?57,$$FM TE^XLFDT(D T),?71,"Pa ge: "_IBPG W !,$TR($ J("",IOM), " ","=") W !,$P(IBRE C1,U)_" "_ "("_IBILL_ ")",?27,$P ($G(^DPT(+ $P(IBREC1, U,2),0)),U ),?52,$P($ G(^DPT($P( IBREC1,U,2 ),0)),U,9) ,! S IBLIN E=6 Q ;EXI TQ ; - cle an up and exit I $E( IOST,1,2)[ "C-",'$G(I BQUIT) K D IR S DIR(0 )="E" W ! D ^DIR K D IR K ^TMP( "IBXERR",$ J),^TMP("I BXDATA",$J ),IBXERR D CLEAN^DIL F Q ;EXTRA CT(IBIFN,I BBATCH,IBF ORM,IBLOCA L) ; Extra cts transm itted form data into global ; ^TMP("IBXD ATA",$J). Errors are in ^TMP(" IBXERR",$J ,err_num)= text. ; IB BATCH = Ba tch # of b ill (if kn own), othe rwise, set to 1. Thi s ; variab le must be > 0 to pr event a ne w batch fr om being a dded ; IBF ORM = the ien of the form in f ile 353 ; IBLOCAL = 1 if OK to use local form, 0 i f not N IB VNUM,IBL,I BINC,IBSEG D FORMPRE ^IBCFP1 S IBVNUM=$G( IBBATCH) S IBL=$S('$ G(IBLOCAL) :IBFORM,1: "") ; No l ocal form ... set = main form ; Get loca l form ass ociated wi th parent, if any I IBL="" S I BL=$S($P($ G(^IBE(353 ,+IBFORM,2 )),U,8):$P (^(2),U,8) ,1:IBFORM) D SETUP^I BCE837(1) D ROUT^IBC FP1(IBFORM ,1,IBIFN,0 ,IBL) Q ;I NCLUDE(IBS EQ) ; Func tion to de termine if segment s hould be i ncluded or not N OK, LZ,SEGNAME S OK=1 ; default is to includ e it I '$D (IBSEG) G INCLX ; if nothi ng in arra y, then in clude all I '$D(^TMP ("IBXDATA" ,$J,1,IBSE Q)) S OK=0 G INCLX ; no data ther e S LZ=+$O (^TMP("IBX DATA",$J,1 ,IBSEQ,"") ) ; first line# foun d in data S SEGNAME= $P($G(^TMP ("IBXDATA" ,$J,1,IBSE Q,LZ,1)),U ,1) ; piec e 1 S SEGN AME=$$TRIM ^XLFSTR(SE GNAME) I S EGNAME'="" ,'$D(IBSEG (SEGNAME)) S OK=0 ; don't incl udeINCLX ; Q OK ; | |
| 3024 | ||
| 3025 | Routines | |
| 3026 | Activities | |
| 3027 | Routine Na me | |
| 3028 | IBCNADD | |
| 3029 | Enhancemen t Category | |
| 3030 | New | |
| 3031 | Modify | |
| 3032 | Delete | |
| 3033 | No Change | |
| 3034 | RTM | |
| 3035 | ||
| 3036 | Related Op tions | |
| 3037 | None | |
| 3038 | Related Ro utines | |
| 3039 | Routines “ Called By” | |
| 3040 | Routines “ Called” | |
| 3041 | ||
| 3042 | ||
| 3043 | ||
| 3044 | ||
| 3045 | Data Dicti onary (DD) Reference s | |
| 3046 | ||
| 3047 | Related Pr otocols | |
| 3048 | None | |
| 3049 | Related In tegration Control Re gistration s (ICRs) | |
| 3050 | None | |
| 3051 | Data Passi ng | |
| 3052 | Input | |
| 3053 | Output Re ference | |
| 3054 | Both | |
| 3055 | Global Re ference | |
| 3056 | Local | |
| 3057 | Input Attr ibute Name and Defin ition | |
| 3058 | Name: | |
| 3059 | Definition : | |
| 3060 | Output Att ribute Nam e and Defi nition | |
| 3061 | Name: | |
| 3062 | Definition : | |
| 3063 | Current Lo gic | |
| 3064 | IBCNADD ;A LB/AAS - A DDRESS RET RIEVAL ENG INE FOR FI LE 399 ; 2 9-AUG-93 ; ;2.0;INTEG RATED BILL ING;**52,8 0,377**;21 -MAR-94;Bu ild 23 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ;ADD(D A,IBCOB) ; -- Retrie ve correct billing a ddress for a bill, m ailing add ress of Bi ll Payer ; assumes t hat new po licy field points to valid ins . policy ; DA = ien to file 39 9 ; IBCOB = payer se quence PST or 123 (o ptional) ; N X,Y,I,J ,IB01,IB02 ,IBTYP,DFN ,IBCNS,IBC DFN,IBCNT, IBAGAIN,IB FND,IBBILL TY,IBCHRGT Y S IB02=" " S DFN=$P ($G(^DGCR( 399,DA,0)) ,"^",2) S IBBILLTY=$ P($G(^DGCR (399,DA,0) ),"^",5),I BCHRGTY=$P ($$CHGTYPE ^IBCU(DA), "^;",1) ; S IBCNS=+$ P($G(^DGCR (399,DA,"M P")),U,1) S IBCDFN=$ P($G(^DGCR (399,DA,"M P")),U,2) ; ; If a s pecific pa yer sequen ce was pas sed in, ge t the ins. company a nd the pol icy ptr ; No address returned for Medica re I $G(IB COB)'="" D I $$MCRW NR^IBEFUNC (IBCNS) G MAINQ . S IBCOB=$TR( IBCOB,"PST ","123") . S IBCNS=+ $P($G(^DGC R(399,DA," I"_IBCOB)) ,U,1) . S IBCDFN=+$P ($G(^DGCR( 399,DA,"M" )),U,IBCOB +11) . Q ; I 'IBCNS G MAINQ I IBCDFN S I BCNS=+$G(^ DPT(+DFN,. 312,+IBCDF N,0)) I '$ D(^DIC(36, +IBCNS,0)) G MAINQ ; ; -- if s end bill t o employer and state is filled in use th is I +$G(^ DPT(DFN,.3 12,+IBCDFN ,2)),+$P(^ (2),"^",6) S IB02=$P (^(2),"^", 2,99) G MA INQ ;MAIN ; -- deter mine addre ss for com pany for t ype bill ; ; -- get main addre ss S IB02= $S($D(^DIC (36,+IBCNS ,.11)):^(. 11),1:"") S IBCNT=$G (IBCNT)+1 ; ; -- if process th e same co. more than once you are in an infinite l oop I $D(I BCNT(IBCNS )) G MAINQ ;already processed this compa ny use mai n add S IB CNT(IBCNS) ="" ; ; -- type of c harges: Rx charges - if ins co mpany has an rx addr ess use it , otherwis e use opt address I IBCHRGTY=3 S IBTYP=" R" D @IBTY P G:$D(IBF ND) MAINQ I $D(IBAGA IN) K IBAG AIN G MAIN ; ; -- ty pe of bill : inpatien t<3, outpa tient>2 S IBTYP=$S(I BBILLTY<3: "I",1:"O") D @IBTYP I $D(IBAGA IN) K IBAG AIN G MAIN ; ; -- re turn addre ssMAINQ Q IB02 ;I ; -- see if there is a n inpatien t address ; -- use i f state is there I $ P($G(^DIC( 36,+IBCNS, .12)),"^", 5) S IB02= $P($G(^(.1 2)),"^",1, 6) ; ; -- if other c ompany pro cesses cla ims start again I $P ($G(^DIC(3 6,+IBCNS,. 12)),"^",7 ) S IBCNS= $P($G(^DIC (36,+IBCNS ,.12)),"^" ,7) S IBAG AIN=1 Q ;O ; -- see if there i s an outpa tient addr ess ; -- u se if stat e is there I $P($G(^ DIC(36,+IB CNS,.16)), "^",5) S I B02=$P($G( ^(.16)),"^ ",1,6) ; ; -- if oth er company processes claims st art again I $P($G(^D IC(36,+IBC NS,.16))," ^",7) S IB CNS=$P($G( ^DIC(36,+I BCNS,.16)) ,"^",7) S IBAGAIN=1 Q ;R ; -- see if the re is an R x address ; -- use i f state is there I $ P($G(^DIC( 36,+IBCNS, .18)),"^", 5) S IB02= $P($G(^(.1 8)),"^",1, 6) S IBFND =1 ; ; -- if other c ompany pro cesses cla ims start again I $P ($G(^DIC(3 6,+IBCNS,. 18)),"^",7 ) S IBCNS= $P($G(^DIC (36,+IBCNS ,.18)),"^" ,7) S IBAG AIN=1 K IB FND Q | |
| 3065 | Modified L ogic (Chan ges are in bold) | |
| 3066 | IBCNADD ;A LB/AAS - A DDRESS RET RIEVAL ENG INE FOR FI LE 399 ; 2 9-AUG-93 ; ;2.0;INTEG RATED BILL ING;**52,8 0,377,592* *;21-MAR-9 4;Build 23 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;A DD(DA,IBCO B) ; -- Re trieve cor rect billi ng address for a bil l, mailing address o f Bill Pay er ; assum es that ne w policy f ield point s to valid ins. poli cy ; DA = ien to fil e 399 ; IB COB = paye r sequence PST or 12 3 (optiona l) ; N X,Y ,I,J,IB01, IB02,IBTYP ,DFN,IBCNS ,IBCDFN,IB CNT,IBAGAI N,IBFND,IB BILLTY,IBC HRGTY S IB 02="" S DF N=$P($G(^D GCR(399,DA ,0)),"^",2 ) S IBBILL TY=$P($G(^ DGCR(399,D A,0)),"^", 5),IBCHRGT Y=$P($$CHG TYPE^IBCU( DA),"^;",1 ) ; S IBCN S=+$P($G(^ DGCR(399,D A,"MP")),U ,1) S IBCD FN=$P($G(^ DGCR(399,D A,"MP")),U ,2) ; ; If a specifi c payer se quence was passed in , get the ins. compa ny and the policy pt r ; No add ress retur ned for Me dicare I $ G(IBCOB)'= "" D I $$ MCRWNR^IBE FUNC(IBCNS ) G MAINQ . S IBCOB= $TR(IBCOB, "PST","123 ") . S IBC NS=+$P($G( ^DGCR(399, DA,"I"_IBC OB)),U,1) . S IBCDFN =+$P($G(^D GCR(399,DA ,"M")),U,I BCOB+11) . Q ; I 'IB CNS G MAIN Q I IBCDFN S IBCNS=+ $G(^DPT(+D FN,.312,+I BCDFN,0)) I '$D(^DIC (36,+IBCNS ,0)) G MAI NQ ; ; -- if send bi ll to empl oyer and s tate is fi lled in us e this I + $G(^DPT(DF N,.312,+IB CDFN,2)),+ $P(^(2),"^ ",6) S IB0 2=$P(^(2), "^",2,99) G MAINQ ;M AIN ; -- d etermine a ddress for company f or type bi ll ; ; -- get main a ddress S I B02=$S($D( ^DIC(36,+I BCNS,.11)) :^(.11),1: "") S IBCN T=$G(IBCNT )+1 ; ; -- if proces s the same co. more than once you are in an infini te loop I $D(IBCNT(I BCNS)) G M AINQ ;alre ady proces sed this c ompany use main add S IBCNT(IB CNS)="" ; ; -- type of charges : Rx charg es - if in s company has an rx address us e it, othe rwise use opt addres s I IBCHRG TY=3 S IBT YP="R" D @ IBTYP G:$D (IBFND) MA INQ I $D(I BAGAIN) K IBAGAIN G MAIN ; ; - - type of bill: inpa tient<3, o utpatient> 2 S IBTYP= $S(IBBILLT Y<3:"I",1: "O") D @IB TYP I $D(I BAGAIN) K IBAGAIN G MAIN ; ; - - return a ddressMAIN Q Q IB02 ; I ; -- see if there is an inpa tient addr ess ; -- u se if stat e is there I $P($G(^ DIC(36,+IB CNS,.12)), "^",5) S I B02=$P($G( ^(.12)),"^ ",1,6) ; ; -- if oth er company processes claims st art again I $P($G(^D IC(36,+IBC NS,.12))," ^",7) S IB CNS=$P($G( ^DIC(36,+I BCNS,.12)) ,"^",7) S IBAGAIN=1 Q ;O ; -- see if the re is an o utpatient address ; -- use if state is t here ;JWS; IB*2.0*592 ;Dental In surance ma iling addr ess I $$FT ^IBCEF(DA) =7 D Q . I $P($G(^D IC(36,+IBC NS,.19))," ^",5) S IB 02=$P(^(.1 9),"^",1,6 ) . I $P($ G(^DIC(36, +IBCNS,.19 )),"^",7) S IBCNS=$P (^(.19),"^ ",7) S IBA GAIN=1 ; I $P($G(^DI C(36,+IBCN S,.16)),"^ ",5) S IB0 2=$P($G(^( .16)),"^", 1,6) ; ; - - if other company p rocesses c laims star t again I $P($G(^DIC (36,+IBCNS ,.16)),"^" ,7) S IBCN S=$P($G(^D IC(36,+IBC NS,.16))," ^",7) S IB AGAIN=1 Q ;R ; -- se e if there is an Rx address ; -- use if state is t here I $P( $G(^DIC(36 ,+IBCNS,.1 8)),"^",5) S IB02=$P ($G(^(.18) ),"^",1,6) S IBFND=1 ; ; -- if other com pany proce sses claim s start ag ain I $P($ G(^DIC(36, +IBCNS,.18 )),"^",7) S IBCNS=$P ($G(^DIC(3 6,+IBCNS,. 18)),"^",7 ) S IBAGAI N=1 K IBFN D Q | |
| 3067 | ||
| 3068 | Routines | |
| 3069 | Activities | |
| 3070 | Routine Na me | |
| 3071 | IBCSC10 | |
| 3072 | Enhancemen t Category | |
| 3073 | New | |
| 3074 | Modify | |
| 3075 | Delete | |
| 3076 | No Change | |
| 3077 | RTM | |
| 3078 | ||
| 3079 | Related Op tions | |
| 3080 | None | |
| 3081 | Related Ro utines | |
| 3082 | Routines “ Called By” | |
| 3083 | Routines “ Called” | |
| 3084 | ||
| 3085 | ||
| 3086 | ||
| 3087 | ||
| 3088 | Data Dicti onary (DD) Reference s | |
| 3089 | ||
| 3090 | Related Pr otocols | |
| 3091 | None | |
| 3092 | Related In tegration Control Re gistration s (ICRs) | |
| 3093 | None | |
| 3094 | Data Passi ng | |
| 3095 | Input | |
| 3096 | Output Re ference | |
| 3097 | Both | |
| 3098 | Global Re ference | |
| 3099 | Local | |
| 3100 | Input Attr ibute Name and Defin ition | |
| 3101 | Name: | |
| 3102 | Definition : | |
| 3103 | Output Att ribute Nam e and Defi nition | |
| 3104 | Name: | |
| 3105 | Definition : | |
| 3106 | Current Lo gic | |
| 3107 | IBCSC10 ;A LB/MJB - M CCR SCREEN 10 (UB-82 BILL SPEC IFIC INFO) ;27 MAY 8 8 10:20 ;; 2.0;INTEGR ATED BILLI NG;**432,5 47,574**;2 1-MAR-94;B uild 12 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ; ;MAP TO DGCRSC8 ; ; DEM;432 - Moved IB CSC8* bill ing screen routines to IBCSC10 * billing screen ; r outines an d created a new bill ing screen 8 routine IBCSC8. ; EN S IBCUB FT=$$FT^IB CU3(IBIFN) I IBCUBFT =2!(IBCUBF T=7) K IBC UBFT G ^IB CSC10H ; h cfa 1500 I IBCUBFT=3 K IBCUBFT G ^IBCSC1 02 ; ub-92 ;I $P(^DG CR(399,IBI FN,0),"^", 19)=2 G ^I BCSC10H ;h cfa 1500 D ^IBCSCU S IBSR=10,I BSR1="",IB V1="000000 000" S:IBV IBV1="111 111111" F I="U","U1" ,0 S IB(I) =$S($D(^DG CR(399,IBI FN,I)):^(I ),1:"") D H^IBCSCU S Z=1,IBW=1 X IBWW W " Bill Rem ark : ",$S ($P(IB("U1 "),U,8)]"" :$P(IB("U1 "),U,8),1: IBUN) S IB X="^^^2^9^ 27^45" F I =4:1:7 S Z =(I-2),IBW =1 X IBWW W " Form L ocator ",$ P(IBX,U,I) ,$S($E($P( IBX,U,I),2 )="":" : " ,1:": "),$ S($P(IB("U 1"),U,I)]" ":$P(IB("U 1"),U,I),1 :IBUN) S I BX=91 F I= 13,14 S Z= (I-7),IBW= 1,IBX=IBX+ 1 X IBWW W " Form Lo cator ",IB X,": ",$S( $P(IB("U1" ),U,I)]"": $P(IB("U1" ),U,I),1:I BUN) S Z=8 ,IBW=1 X I BWW W " Tx Auth. Cod e : ",$S($ P(IB("U"), U,13)]"":$ P(IB("U"), U,13),1:IB UN) G ^IBC SCPQ Q ; ; WCJ;IB*2.0 *547ACINTE L(IBINSDAT ,IBNEXT) ; build som e intellig ence in th is Alterna te ID bran ching logi c called f rom both s creen 10 t emplates. ; ; Input: ; IBINSDA T - INS DA TA node ; IBNEXT -wh ere to bra nch if not correct p lan ; ; Re turns - wh ere to bra nch to ; N IBPLAN,IB EPT,IBINSP RF S IBPLA N=$P(IBINS DAT,U,18) I IBPLAN=" " Q IBNEX T S IBPLAN =$G(^IBA(3 55.3,+IBPL AN,0)) I I BPLAN="" Q IBNEXT S IBEPT=$P(I BPLAN,U,15 ) I IBEPT= "" Q IBNEX T I IBEPT= "MX" Q:'$D (^IBE(350. 9,1,81,"B" )) IBNEXT ; no Medi care set u p in site parameters I IBEPT'= "MX" Q:'$D (^IBE(350. 9,1,82,"B" )) IBNEXT ; no com mercial se t up in si te paramet ers ; Use form type not charge type 09/0 7/2016 ;S IBINSPRF=$ $INSPRF^IB CEF(IBIFN) S IBINSPR F=$$FT^IBC EF(+IBIFN) =3 ; set I BINST flag =1 if it i s institut ional,0 fo r professi onal. ; ; Institutio nal I IBIN SPRF=1 Q:' $D(^DIC(36 ,+IBINSDAT ,15,"B")) IBNEXT ; this insu rance comp any has no instituti onal set u p ; ; Prof essional I IBINSPRF= 0 Q:'$D(^D IC(36,+IBI NSDAT,16," B")) IBNEX T ; this insurance company ha s no profe ssional se t up ; ; n ow it gets complicat ed :) ; th ere needs to be one set up for this form type in t he ins com p file ; a nd also se t up for M edicare/co mmercial i n the site parameter file N IB TMPINS,IBT MPSP,IBLOO P,IBFOUND M IBTMPINS =^DIC(36,+ IBINSDAT,$ S(IBINSPRF =1:15,1:16 ),"B") M I BTMPSP=^IB E(350.9,1, $S(IBEPT=" MX":81,1:8 2),"B") S IBLOOP="", IBFOUND=0 F S IBLOO P=$O(IBTMP INS(IBLOOP )) Q:IBLOO P="" D Q :IBFOUND . Q:'$D(IBT MPSP(IBLOO P)) . S IB FOUND=1 I IBFOUND Q "" Q IBNEX T ;IBCSC10 | |
| 3108 | Modified L ogic (Chan ges are in bold) | |
| 3109 | IBCSC10 ;A LB/MJB - M CCR SCREEN 10 (UB-82 BILL SPEC IFIC INFO) ;27 MAY 8 8 10:20 ;; 2.0;INTEGR ATED BILLI NG;**432,5 47,574,592 **;21-MAR- 94;Build 1 2 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; ;MAP TO DGCRSC 8 ; ; DEM; 432 - Move d IBCSC8* billing sc reen routi nes to IBC SC10* bill ing screen ; routine s and crea ted a new billing sc reen 8 rou tine IBCSC 8. ; ;JWS; IB*2.0*592 US1108 - Dental for m 7EN S IB CUBFT=$$FT ^IBCU3(IBI FN) I IBCU BFT=2!(IBC UBFT=7) K IBCUBFT G ^IBCSC10H ; hcfa 150 0 ;JWS 3/6 /17 Dental Form I IB CUBFT=3 K IBCUBFT G ^IBCSC102 ; ub-92 ;I $P(^DGCR( 399,IBIFN, 0),"^",19) =2 G ^IBCS C10H ;hcfa 1500 D ^I BCSCU S IB SR=10,IBSR 1="",IBV1= "000000000 " S:IBV IB V1="111111 111" F I=" U","U1",0 S IB(I)=$S ($D(^DGCR( 399,IBIFN, I)):^(I),1 :"") D H^I BCSCU S Z= 1,IBW=1 X IBWW W " B ill Remark : ",$S($P (IB("U1"), U,8)]"":$P (IB("U1"), U,8),1:IBU N) S IBX=" ^^^2^9^27^ 45" F I=4: 1:7 S Z=(I -2),IBW=1 X IBWW W " Form Loca tor ",$P(I BX,U,I),$S ($E($P(IBX ,U,I),2)=" ":" : ",1: ": "),$S($ P(IB("U1") ,U,I)]"":$ P(IB("U1") ,U,I),1:IB UN) S IBX= 91 F I=13, 14 S Z=(I- 7),IBW=1,I BX=IBX+1 X IBWW W " Form Locat or ",IBX," : ",$S($P( IB("U1"),U ,I)]"":$P( IB("U1"),U ,I),1:IBUN ) S Z=8,IB W=1 X IBWW W " Tx Au th. Code : ",$S($P(I B("U"),U,1 3)]"":$P(I B("U"),U,1 3),1:IBUN) G ^IBCSCP Q Q ; ;WCJ ;IB*2.0*54 7ACINTEL(I BINSDAT,IB NEXT) ; bu ild some i ntelligenc e in this Alternate ID branchi ng logic c alled from both scre en 10 temp lates. ; ; Input: ; IBINSDAT - INS DATA node ; IBN EXT -where to branch if not co rrect plan ; ; Retur ns - where to branch to ; N IB PLAN,IBEPT ,IBINSPRF S IBPLAN=$ P(IBINSDAT ,U,18) I I BPLAN="" Q IBNEXT S IBPLAN=$G (^IBA(355. 3,+IBPLAN, 0)) I IBPL AN="" Q IB NEXT S IBE PT=$P(IBPL AN,U,15) I IBEPT="" Q IBNEXT I IBEPT="MX " Q:'$D(^I BE(350.9,1 ,81,"B")) IBNEXT ; no medicar e set up i n site par ameters I IBEPT'="MX " Q:'$D(^I BE(350.9,1 ,82,"B")) IBNEXT ; no commer cial set u p in site parameters ; Use for m type not charge ty pe 09/07/2 016 ;S IBI NSPRF=$$IN SPRF^IBCEF (IBIFN) S IBINSPRF=$ $FT^IBCEF( +IBIFN)=3 ; set IBIN ST flag=1 if it is i nstitution al,0 for p rofessiona l. ; ; Ins titutional I IBINSPR F=1 Q:'$D( ^DIC(36,+I BINSDAT,15 ,"B")) IBN EXT ; th is insuran ce company has no in stitutiona l set up ; ; Profess ional I IB INSPRF=0 Q :'$D(^DIC( 36,+IBINSD AT,16,"B") ) IBNEXT ; this ins urance com pany has n o professi onal set u p ; ; now it gets co mplicated :) ; there needs to be one set up for th is form ty pe in the ins comp f ile ; and also set u p for medi care/comme rcial in t he site pa rameter fi le N IBTMP INS,IBTMPS P,IBLOOP,I BFOUND M I BTMPINS=^D IC(36,+IBI NSDAT,$S(I BINSPRF=1: 15,1:16)," B") M IBTM PSP=^IBE(3 50.9,1,$S( IBEPT="MX" :81,1:82), "B") S IBL OOP="",IBF OUND=0 F S IBLOOP=$ O(IBTMPINS (IBLOOP)) Q:IBLOOP=" " D Q:IB FOUND . Q: '$D(IBTMPS P(IBLOOP)) . S IBFOU ND=1 I IBF OUND Q "" Q IBNEXT ; IBCSC10 | |
| 3110 | ||
| 3111 | Routines | |
| 3112 | Activities | |
| 3113 | Routine Na me | |
| 3114 | IBCSC10H | |
| 3115 | Enhancemen t Category | |
| 3116 | New | |
| 3117 | Modify | |
| 3118 | Delete | |
| 3119 | No Change | |
| 3120 | RTM | |
| 3121 | ||
| 3122 | Related Op tions | |
| 3123 | None | |
| 3124 | Related Ro utines | |
| 3125 | Routines “ Called By” | |
| 3126 | Routines “ Called” | |
| 3127 | ||
| 3128 | ||
| 3129 | ||
| 3130 | ||
| 3131 | Data Dicti onary (DD) Reference s | |
| 3132 | ||
| 3133 | Related Pr otocols | |
| 3134 | None | |
| 3135 | Related In tegration Control Re gistration s (ICRs) | |
| 3136 | None | |
| 3137 | Data Passi ng | |
| 3138 | Input | |
| 3139 | Output Re ference | |
| 3140 | Both | |
| 3141 | Global Re ference | |
| 3142 | Local | |
| 3143 | Input Attr ibute Name and Defin ition | |
| 3144 | Name: | |
| 3145 | Definition : | |
| 3146 | Output Att ribute Nam e and Defi nition | |
| 3147 | Name: | |
| 3148 | Definition : | |
| 3149 | Current Lo gic | |
| 3150 | IBCSC10H ; ALB/ARH - MCCR SCREE N 10 (BILL SPECIFIC INFO) CMS- 1500 ;4/21 /92 ;;2.0; INTEGRATED BILLING;* *432,488,5 47**;21-MA R-94;Build 119 ;;Per VA Direct ive 6402, this routi ne should not be mod ified. ; C MS-1500 sc reen 10 ; ; MAP TO D GCRSC8H ; ; DEM;432 - Moved IB CSC8* bill ing screen routines to IBCSC10 * billing screen ; r outines an d created a new bill ing screen 8 routine IBCSC8. ; EN ; N I,I B,Y,Z D ^I BCSCU ; ;W CJ;IB*2.0* 547 ;S IBS R=10,IBSR1 ="H",IBV1= "000000000 " S:IBV IB V1="111111 111" S IBS R=10,IBSR1 ="H",IBV1= "000000000 0" S:IBV I BV1="11111 11111" ;F I="U","U1" ,"UF2","UF 3","UF32", "U2","M"," TX",0,"U3" S IB(I)=$ G(^DGCR(39 9,IBIFN,I) ) F I="U", "U1","UF2" ,"UF3","UF 32","U2"," M","M2","T X",0,"U3" S IB(I)=$G (^DGCR(399 ,IBIFN,I)) ; N IBZ,I BPRV,IBDAT E,IBREQ,IB MRASEC,IBZ 1,IBZCNT ; S IBDATE= $$BDATE^IB ACSV(IBIFN ) ; Date o f service for the bi ll S IBPRV ="" D GETP RV^IBCEU(I BIFN,"ALL" ,.IBPRV) K IB("PRV") S IBZ=0 F S IBZ=$O (IBPRV(IBZ )) Q:'IBZ I $O(IBPR V(IBZ,0))! $D(IBPRV(I BZ,"NOTOPT ")) M IB(" PRV",IBZ)= IBPRV(IBZ) ; D H^IBC SCU ; ; Se ction 1 S Z=1,IBW=1 X IBWW W " Unable To Work From : " S Y=$P (IB("U"),U ,16) X ^DD ("DD") W $ S(Y'="":Y, 1:IBUN) W !?4,"Unabl e To Work To : " S Y =$P(IB("U" ),U,17) X ^DD("DD") W $S(Y'="" :Y,1:IBUN) ; ; Secti on 2 S Z=2 ,IBW=1 X I BWW I $$IN PAT^IBCEF( IBIFN) W " Admitting Dx : " S IBZ=$$ICD9 ^IBACSV(+I B("U2"),IB DATE) W $S (IBZ'="":$ P(IBZ,U)_" - "_$P(IB Z,U,3),1:I BUN),! S I BZCNT=0,IB Z(IBZCNT)= "" I $P(IB ("UF3"),U, 4)]"" S IB Z(IBZCNT)= "P: "_$P(I B("UF3"),U ,4),IBZCNT =IBZCNT+1 I $P(IB("U F3"),U,5)] "" S IBZ(I BZCNT)="S: "_$P(IB(" UF3"),U,5) ,IBZCNT=IB ZCNT+1 I $ P(IB("UF3" ),U,6)]"" S IBZ(IBZC NT)="T: "_ $P(IB("UF3 "),U,6) S: IBZ(0)="" IBZ(0)=IBU N W ?4,"IC N/DCN(s) : ",IBZ(0) F IBZCNT=1 :1 Q:'$D(I BZ(IBZCNT) ) W !?25,I BZ(IBZCNT) K IBZ S I BZ=$$CKPRO V^IBCEU(IB IFN,3) S I BZCNT=0,IB Z(IBZCNT)= "" I $P(IB ("U"),U,13 )]"" S IBZ (IBZCNT)=" P: "_$P(IB ("U"),U,13 ),IBZCNT=I BZCNT+1 I $P(IB("U2" ),U,8)'="" S IBZ(IBZ CNT)="S: " _$P(IB("U2 "),U,8),IB ZCNT=IBZCN T+1 I $P(I B("U2"),U, 9)'="" S I BZ(IBZCNT) ="T: "_$P( IB("U2"),U ,9),IBZCNT =IBZCNT+1 I $P(IB("U F32"),U,1) '="" S IBZ (IBZCNT)=" P: "_$P(IB ("UF32"),U ,1),IBZCNT =IBZCNT+1 I $P(IB("U F32"),U,2) '="" S IBZ (IBZCNT)=" S: "_$P(IB ("UF32"),U ,2),IBZCNT =IBZCNT+1 I $P(IB("U F32"),U,3) '="" S IBZ (IBZCNT)=" T: "_$P(IB ("UF32"),U ,3) S:IBZ( 0)="" IBZ( 0)=IBUN W !,?3," Aut h/Referral : ",IBZ(0 ) F IBZCNT =1:1 Q:'$D (IBZ(IBZCN T)) W !?25 ,IBZ(IBZCN T) K IBZ S IBZ="" ; ; Section 3 S Z=3,IB W=1 X IBWW W " Provi ders : ",$ S('$O(IB(" PRV",0)):I BU,1:"") I $D(IB("PR V")) D ; at least 1 provider found . N IBQ,A,A1,I BARR,IBTAX ,IBNOTAX,I BSPEC,IBNO SPEC . S I BZ=0 . D D EFSEC^IBCE F74(IBIFN, .IBARR) . ; PRXM/KJH - Add Tax onomy code to displa y for patc h 343. Mov ed seconda ry IDs sli ghtly (bel ow). . S I BTAX=$$PRO VTAX^IBCEF 73A(IBIFN, .IBNOTAX) . S IBSPEC =$$SPECTAX ^IBCEF73A( IBIFN,.IBN OSPEC) . F S IBZ=$O (IB("PRV", IBZ)) Q:'I BZ D .. S IBQ="" .. W !,?5,"- " .. S A= $$EXPAND^I BTRE(399.0 222,.01,IB Z) .. I $P ($G(IB("PR V",IBZ,1)) ,U,4)'="" S A1=" ("_ $E($P(IB(" PRV",IBZ,1 ),U,4),1,3 )_")",A=$E (A,1,16-$L (A1))_A1 . . W $E(A_$ J("",16),1 ,16),": " .. I '$P($ G(IB("PRV" ,IBZ,1)),U ,3),$P($G( IB("PRV",I BZ,1)),U)= "" W IBU Q .. I $P($ G(IB("PRV" ,IBZ,1)),U )'="" W:'$ G(IB("PRV" ,IBZ)) $E( $P(IB("PRV ",IBZ,1),U )_$J("",16 ),1,16) W: $G(IB("PRV ",IBZ)) "( OLD BOX 31 DATA) "_$ P(IB("PRV" ,IBZ,1),U) .. I $P($ G(IB("PRV" ,IBZ,1)),U )="",$P($G (IB("PRV", IBZ)),U)'= "" W $E($P (IB("PRV", IBZ),U)_$J ("",16),1, 16) .. W " Taxonomy: ",$S($P(I BTAX,U,IBZ )'="":$P(I BTAX,U,IBZ ),1:IBU),$ S($P(IBSPE C,U,IBZ)'= "":" ("_$P (IBSPEC,U, IBZ)_")",1 :"") .. F A=1:1:3 I $G(IBARR(I BZ,A))'="" S IBQ=IBQ _"["_$E("P ST",A)_"]" _IBARR(IBZ ,A)_" " .. I $L(IBQ) W !,?30,$ E(IBQ,1,49 ) ; K IB(" PRV") ; ; Section 4 S Z=4,IBW= 1 X IBWW W " Other F acility (V A/non): " S IBZ=$$EX PAND^IBTRE (399,232,+ $P(IB("U2" ),U,10)) W $S(IBZ'=" ":$E(IBZ,1 ,23),$$PSR V^IBCEU(IB IFN):IBU,1 :IBUN) I I BZ'="" D . ; PRXM/KJ H - Add Ta xonomy cod e to displ ay for pat ch 343. . W ?53,"Tax onomy: " . S IBZ=$$G ET1^DIQ(89 32.1,+$P(I B("U3"),U, 3),"X12 CO DE") W $S( IBZ'="":IB Z,1:IBU) . S IBZ=$$G ET1^DIQ(89 32.1,+$P(I B("U3"),U, 3),"SPECIA LTY CODE") W $S(IBZ' ="":" ("_I BZ_")",1:" ") . Q ; ; clia# dis play - IB patch 320 S (IBZ,IBZ 1)=$P(IB(" U2"),U,13) ; retriev e CLIA# fr om databas e ; I IBZ= "" D . NEW CLIAREQ,D EFCLIA,DIE ,DA,DR . S CLIAREQ=$ $CLIAREQ^I BCEP8A(IBI FN) . I 'C LIAREQ S I BZ1=IBUN Q ; clia# no t needed . S DEFCLIA =$$CLIA^IB CEP8A(IBIF N) ; defau lt clia# f or claim . I DEFCLIA ="" S IBZ1 =IBU Q ; no default fo und . I $G (IBMDOTCN) K IBMDOTC N S IBZ1=I BU Q ; user @-de leted clia # . S IBZ1 =DEFCLIA ; display an d stuff de fault clia # . S DIE= 399,DA=IBI FN,DR="235 ///"_DEFCL IA D ^DIE ; stuff in default . Q ; W !,? 4,"Lab CLI A # : ",IB Z1 ; ; Mam mo# displa y IB patch 320 S (IB Z,IBZ1)=$P (IB("U3"), U,1) ; ret rieve mamm o# from da tabase ; ; If mammo# is there, but shoul d not be, then blank it out I IBZ'="",'$ $XRAY^IBCE P8A(IBIFN) D . NEW D IE,DA,DR . S IBZ1=IB UN ; mammo# n ot needed . S DIE=39 9,DA=IBIFN ,DR="242// //@" D ^DI E . Q ; I IBZ="" S I BZ1=IBUN W !?4,"Mamm ography Ce rt # : ",I BZ1 ; ; Se ction 5 S Z=5,IBW=1 X IBWW W " Chiroprac tic Data : " S Y=$P( IB("U3"),U ,5) X ^DD( "DD") W $S (Y'="":"IN ITIAL TREA TMENT ON " _Y,1:IBUN) ; ; Secti on 6 -> ch anged prom pt for *48 8* : baa S Z=6,IBW=1 X IBWW W " CMS-1500 Box 19 : " S IBZ=$P ($G(^DGCR( 399,IBIFN, "UF31")),U ,3) W $S(I BZ'="":IBZ ,1:IBUN) ; / Beginnin g of IB*2. 0*488 - Mo ved the fo llowing li nes of cod e to IBCSC 8 (vd) ;I $P(IB("U2" ),U,14)'=" " W !,?4," Homebound : ",$$EXPA ND^IBTRE(3 99,236,$P( IB("U2"),U ,14)) ;I $ P(IB("U2") ,U,15)'="" W !,?4,"D ate Last S een : ",$$ EXPAND^IBT RE(399,237 ,$P(IB("U2 "),U,15)) ;I $P(IB(" U2"),U,16) '="" W !,? 4,"Spec Pr og Indicat or: " S IB Z=$$EXPAND ^IBTRE(399 ,238,$P(IB ("U2"),U,1 6)) W $S(I BZ'="":IBZ ,$$WNRBILL ^IBEFUNC(I BIFN):"31" ,1:"") ;/ End of IB* 2.0*488 (v d) ; ; Sec tion 7 S Z =7,IBW=1 X IBWW W " Billing Pr ovider : " K IBZ D G ETBP^IBCEF 79(IBIFN," ",+$$B^IBC EF79(IBIFN ),"CMS-150 0 SCREEN 8 ",.IBZ) S IBZ=$G(IBZ ("CMS-1500 SCREEN 8" ,"NAME")) W $S(IBZ'= "":IBZ,1:I BU) ; bill ing provid er name W !?3," Taxo nomy Code : " S IBZ= $$GET1^DIQ (8932.1,+$ P(IB("U3") ,U,11),"X1 2 CODE") W $S(IBZ'=" ":IBZ,1:IB U) S IBZ=$ $GET1^DIQ( 8932.1,+$P (IB("U3"), U,11),"SPE CIALTY COD E") W $S(I BZ'="":" ( "_IBZ_")", 1:"") ; ; Section 8 ;WCJ;IB*2. 0*547 ;Add ing ALT PR IMARY IDS and moving sections down to ma ke room S Z=8,IBW=1 X IBWW W " Alt Prim Payer ID : " K IBZ S IBZCNT=0 I $P(IB("M 2"),U,2)]" " S IBZCNT =IBZCNT+1, IBZ(IBZCNT )="P: "_$P (IB("M2"), U,2) I $P( IB("M2"),U ,4)]"" S I BZCNT=IBZC NT+1,IBZ(I BZCNT)="S: "_$P(IB(" M2"),U,4) I $P(IB("M 2"),U,6)]" " S IBZCNT =IBZCNT+1, IBZ(IBZCNT )="T: "_$P (IB("M2"), U,6) I 'IB ZCNT W ?23 ,IBUN I IB ZCNT F IBZ 1=1:1:IBZC NT W ?23,I BZ(IBZ1) W :(IBZ1'=IB ZCNT) ! K IBZ ; ; Se ction 9 S Z=9,IBW=1 X IBWW S I BREQ=+$$RE QMRA^IBEFU NC(IBIFN) S:IBREQ IB REQ=1 S IB MRASEC=$$M RASEC^IBCE F4(IBIFN) W " ",$S(' IBREQ:"For ce To Prin t? : ",1:" Force MRA Sec Prt? : ") S IBZ= $$EXTERNAL ^DILFD(399 ,27+IBREQ, ,+$P(IB("T X"),U,8+IB REQ)) I IB MRASEC,'$P (IB("TX"), U,8),$P(IB ("TX"),U,9 ) S IBZ="F ORCED TO P RINT BY MR A PRIMARY" ,$P(IB("TX "),U,8)=0 W $S(IBZ'= ""&($P(IB( "TX"),U,8+ IBREQ)'="" ):IBZ,'$$T XMT^IBCEF4 (IBIFN):"[ NOT APPLIC ABLE - NOT TRANSMITT ABLE]",IBR EQ:"NO FOR CED PRINT" ,1:IBZ) ; ; Section 10 S Z=10, IBW=1 X IB WW W " Pro vider ID M aint : (Ed it Provide r ID infor mation)",! G ^IBCSCP Q Q ;WRT1( IBCRED) ; Write cred entials mi smatch W ! ,*7," **Wa rning** Cr edentials differ fro m those fo und in NEW PERSON or IB NON VA ",!,$J("", 14),"BILLI NG PROVIDE R file (", $S(IBCRED= "":"none", 1:IBCRED), ")" W !,$J ("",14),"C hanges wil l print lo cal, but o nly creden tials on f ile transm it" Q ;NSA ME(DA) ; R eturns 1 i f div on b ill is not the defau lt billing facility Q ($P($G(^ IBE(350.9, 1,0)),U,2) '=$P($G(^D G(40.8,+$P (^DGCR(399 ,DA,0),U,2 2),0)),U,7 )) ; ;IBCS C10H | |
| 3151 | Modified L ogic (Chan ges are in bold) | |
| 3152 | IBCSC10H ; ALB/ARH - MCCR SCREE N 10 (BILL SPECIFIC INFO) CMS- 1500 ;4/21 /92 ;;2.0; INTEGRATED BILLING;* *432,488,5 47,592**;2 1-MAR-94;B uild 119 ; ;Per VA Di rective 64 02, this r outine sho uld not be modified. ; CMS-150 0 screen 1 0 ; ; MAP TO DGCRSC8 H ; ; DEM; 432 - Move d IBCSC8* billing sc reen routi nes to IBC SC10* bill ing screen ; routine s and crea ted a new billing sc reen 8 rou tine IBCSC 8. ;EN ; N I,IB,Y,Z D ^IBCSCU ; ;WCJ;IB* 2.0*547 ;S IBSR=10,I BSR1="H",I BV1="00000 0000" S:IB V IBV1="11 1111111" S IBSR=10,I BSR1="H",I BV1="00000 00000" S:I BV IBV1="1 111111111" ;JWS;IB*2 .0*592 US1 108 - Dent al form 7 I $$FT^IBC U3(IBIFN)= 7 S IBV1=" 1000100010 " S:IBV IB V1="111111 11" ;F I=" U","U1","U F2","UF3", "UF32","U2 ","M","TX" ,0,"U3" S IB(I)=$G(^ DGCR(399,I BIFN,I)) F I="U","U1 ","UF2","U F3","UF32" ,"U2","M", "M2","TX", 0,"U3" S I B(I)=$G(^D GCR(399,IB IFN,I)) ; N IBZ,IBPR V,IBDATE,I BREQ,IBMRA SEC,IBZ1,I BZCNT ; S IBDATE=$$B DATE^IBACS V(IBIFN) ; Date of s ervice for the bill S IBPRV="" D GETPRV^ IBCEU(IBIF N,"ALL",.I BPRV) K IB ("PRV") S IBZ=0 F S IBZ=$O(IB PRV(IBZ)) Q:'IBZ I $O(IBPRV(I BZ,0))!$D( IBPRV(IBZ, "NOTOPT")) M IB("PRV ",IBZ)=IBP RV(IBZ) ; D H^IBCSCU ; ; Secti on 1 S Z=1 ,IBW=1 X I BWW W " Un able To Wo rk From: " S Y=$P(IB ("U"),U,16 ) X ^DD("D D") W $S(Y '="":Y,1:I BUN) W !?4 ,"Unable T o Work To : " S Y=$P (IB("U"),U ,17) X ^DD ("DD") W $ S(Y'="":Y, 1:IBUN) ; ; Section 2 S Z=2,IB W=1 X IBWW I $$INPAT ^IBCEF(IBI FN) W " Ad mitting Dx : " S IBZ =$$ICD9^IB ACSV(+IB(" U2"),IBDAT E) W $S(IB Z'="":$P(I BZ,U)_" - "_$P(IBZ,U ,3),1:IBUN ),! S IBZC NT=0,IBZ(I BZCNT)="" I $P(IB("U F3"),U,4)] "" S IBZ(I BZCNT)="P: "_$P(IB(" UF3"),U,4) ,IBZCNT=IB ZCNT+1 I $ P(IB("UF3" ),U,5)]"" S IBZ(IBZC NT)="S: "_ $P(IB("UF3 "),U,5),IB ZCNT=IBZCN T+1 I $P(I B("UF3"),U ,6)]"" S I BZ(IBZCNT) ="T: "_$P( IB("UF3"), U,6) S:IBZ (0)="" IBZ (0)=IBUN W ?4,"ICN/D CN(s) : ", IBZ(0) F I BZCNT=1:1 Q:'$D(IBZ( IBZCNT)) W !?25,IBZ( IBZCNT) K IBZ S IBZ= $$CKPROV^I BCEU(IBIFN ,3) S IBZC NT=0,IBZ(I BZCNT)="" I $P(IB("U "),U,13)]" " S IBZ(IB ZCNT)="P: "_$P(IB("U "),U,13),I BZCNT=IBZC NT+1 I $P( IB("U2"),U ,8)'="" S IBZ(IBZCNT )="S: "_$P (IB("U2"), U,8),IBZCN T=IBZCNT+1 I $P(IB(" U2"),U,9)' ="" S IBZ( IBZCNT)="T : "_$P(IB( "U2"),U,9) ,IBZCNT=IB ZCNT+1 I $ P(IB("UF32 "),U,1)'=" " S IBZ(IB ZCNT)="P: "_$P(IB("U F32"),U,1) ,IBZCNT=IB ZCNT+1 I $ P(IB("UF32 "),U,2)'=" " S IBZ(IB ZCNT)="S: "_$P(IB("U F32"),U,2) ,IBZCNT=IB ZCNT+1 I $ P(IB("UF32 "),U,3)'=" " S IBZ(IB ZCNT)="T: "_$P(IB("U F32"),U,3) S:IBZ(0)= "" IBZ(0)= IBUN W !,? 3," Auth/R eferral : ",IBZ(0) F IBZCNT=1: 1 Q:'$D(IB Z(IBZCNT)) W !?25,IB Z(IBZCNT) K IBZ S IB Z="" ; ; S ection 3 S Z=3,IBW=1 X IBWW W " Provider s : ",$S(' $O(IB("PRV ",0)):IBU, 1:"") I $D (IB("PRV") ) D ; at least 1 pr ovider fou nd . N IBQ ,A,A1,IBAR R,IBTAX,IB NOTAX,IBSP EC,IBNOSPE C . S IBZ= 0 . D DEFS EC^IBCEF74 (IBIFN,.IB ARR) . ; P RXM/KJH - Add Taxono my code to display f or patch 3 43. Moved secondary IDs slight ly (below) . . S IBTA X=$$PROVTA X^IBCEF73A (IBIFN,.IB NOTAX) . S IBSPEC=$$ SPECTAX^IB CEF73A(IBI FN,.IBNOSP EC) . F S IBZ=$O(IB ("PRV",IBZ )) Q:'IBZ D .. S IB Q="" .. W !,?5,"- " .. S A=$$E XPAND^IBTR E(399.0222 ,.01,IBZ) .. I $P($G (IB("PRV", IBZ,1)),U, 4)'="" S A 1=" ("_$E( $P(IB("PRV ",IBZ,1),U ,4),1,3)_" )",A=$E(A, 1,16-$L(A1 ))_A1 .. W $E(A_$J(" ",16),1,16 ),": " .. I '$P($G(I B("PRV",IB Z,1)),U,3) ,$P($G(IB( "PRV",IBZ, 1)),U)="" W IBU Q .. I $P($G(I B("PRV",IB Z,1)),U)'= "" W:'$G(I B("PRV",IB Z)) $E($P( IB("PRV",I BZ,1),U)_$ J("",16),1 ,16) W:$G( IB("PRV",I BZ)) "(OLD BOX 31 DA TA) "_$P(I B("PRV",IB Z,1),U) .. I $P($G(I B("PRV",IB Z,1)),U)=" ",$P($G(IB ("PRV",IBZ )),U)'="" W $E($P(IB ("PRV",IBZ ),U)_$J("" ,16),1,16) .. W " Ta xonomy: ", $S($P(IBTA X,U,IBZ)'= "":$P(IBTA X,U,IBZ),1 :IBU),$S($ P(IBSPEC,U ,IBZ)'="": " ("_$P(IB SPEC,U,IBZ )_")",1:"" ) .. F A=1 :1:3 I $G( IBARR(IBZ, A))'="" S IBQ=IBQ_"[ "_$E("PST" ,A)_"]"_IB ARR(IBZ,A) _" " .. I $L(IBQ) W !,?30,$E(I BQ,1,49) ; K IB("PRV ") ; ; Sec tion 4 S Z =4,IBW=1 X IBWW W " Other Faci lity (VA/n on): " S I BZ=$$EXPAN D^IBTRE(39 9,232,+$P( IB("U2"),U ,10)) W $S (IBZ'="":$ E(IBZ,1,23 ),$$PSRV^I BCEU(IBIFN ):IBU,1:IB UN) I IBZ' ="" D . ; PRXM/KJH - Add Taxon omy code t o display for patch 343. . W ? 53,"Taxono my: " . S IBZ=$$GET1 ^DIQ(8932. 1,+$P(IB(" U3"),U,3), "X12 CODE" ) W $S(IBZ '="":IBZ,1 :IBU) . S IBZ=$$GET1 ^DIQ(8932. 1,+$P(IB(" U3"),U,3), "SPECIALTY CODE") W $S(IBZ'="" :" ("_IBZ_ ")",1:"") . Q ; ; cl ia# displa y - IB pat ch 320 S ( IBZ,IBZ1)= $P(IB("U2" ),U,13) ; retrieve C LIA# from database ; I IBZ="" D . NEW CL IAREQ,DEFC LIA,DIE,DA ,DR . S CL IAREQ=$$CL IAREQ^IBCE P8A(IBIFN) . I 'CLIA REQ S IBZ1 =IBUN Q ; c lia# not n eeded . S DEFCLIA=$$ CLIA^IBCEP 8A(IBIFN) ; default clia# for claim . I DEFCLIA="" S IBZ1=IB U Q ; no def ault found . I $G(IB MDOTCN) K IBMDOTCN S IBZ1=IBU Q ; us er @-delet ed clia# . S IBZ1=DE FCLIA ; dis play and s tuff defau lt clia# . S DIE=399 ,DA=IBIFN, DR="235/// "_DEFCLIA D ^DIE ; s tuff in de fault . Q ; W !,?4," Lab CLIA # : ",IBZ1 ; ; Mammo# display I B patch 32 0 S (IBZ,I BZ1)=$P(IB ("U3"),U,1 ) ; retrie ve mammo# from datab ase ; ; If mammo# is there, bu t should n ot be, the n blank it out I IBZ '="",'$$XR AY^IBCEP8A (IBIFN) D . NEW DIE, DA,DR . S IBZ1=IBUN ; m ammo# not needed . S DIE=399,D A=IBIFN,DR ="242////@ " D ^DIE . Q ; I IBZ ="" S IBZ1 =IBUN W !? 4,"Mammogr aphy Cert # : ",IBZ1 ; ; Secti on 5 S Z=5 ,IBW=1 X I BWW W " Ch iropractic Data : " S Y=$P(IB( "U3"),U,5) X ^DD("DD ") W $S(Y' ="":"INITI AL TREATME NT ON "_Y, 1:IBUN) ; ; Section 6 -> chang ed prompt for *488* : baa S Z= 6,IBW=1 X IBWW ;JWS; IB*2.0*592 US1108 - Dental I $ $FT^IBCU3( IBIFN)'=7 W " CMS-15 00 Box 19 : " S IBZ= $P($G(^DGC R(399,IBIF N,"UF31")) ,U,3) W $S (IBZ'="":I BZ,1:IBUN) E W " De ntal Claim Note : " S IBZ=$$GE T1^DIQ(399 ,IBIFN_"," ,97) W $S( IBZ'="":IB Z,1:IBUN) ;end - JWS ;IB*2.0*59 2 US1108 - Dental ;/ Beginning of IB*2.0 *488 - Mov ed the fol lowing lin es of code to IBCSC8 (vd) ;I $ P(IB("U2") ,U,14)'="" W !,?4,"H omebound : ",$$EXPAN D^IBTRE(39 9,236,$P(I B("U2"),U, 14)) ;I $P (IB("U2"), U,15)'="" W !,?4,"Da te Last Se en : ",$$E XPAND^IBTR E(399,237, $P(IB("U2" ),U,15)) ; I $P(IB("U 2"),U,16)' ="" W !,?4 ,"Spec Pro g Indicato r: " S IBZ =$$EXPAND^ IBTRE(399, 238,$P(IB( "U2"),U,16 )) W $S(IB Z'="":IBZ, $$WNRBILL^ IBEFUNC(IB IFN):"31", 1:"") ;/ E nd of IB*2 .0*488 (vd ) ; ; Sect ion 7 S Z= 7,IBW=1 X IBWW W " B illing Pro vider : " K IBZ D GE TBP^IBCEF7 9(IBIFN,"" ,+$$B^IBCE F79(IBIFN) ,"CMS-1500 SCREEN 8" ,.IBZ) S I BZ=$G(IBZ( "CMS-1500 SCREEN 8", "NAME")) W $S(IBZ'=" ":IBZ,1:IB U) ; billi ng provide r name W ! ?3," Taxon omy Code : " S IBZ=$ $GET1^DIQ( 8932.1,+$P (IB("U3"), U,11),"X12 CODE") W $S(IBZ'="" :IBZ,1:IBU ) S IBZ=$$ GET1^DIQ(8 932.1,+$P( IB("U3"),U ,11),"SPEC IALTY CODE ") W $S(IB Z'="":" (" _IBZ_")",1 :"") ; ; S ection 8 ; WCJ;IB*2.0 *5471 ;Add ing ALT PR IMARY IDS and moving sections down to ma ke room S Z=8,IBW=1 X IBWW W " Alt Prim Payer ID : " K IBZ S IBZCNT=0 I $P(IB("M 2"),U,2)]" " S IBZCNT =IBZCNT+1, IBZ(IBZCNT )="P: "_$P (IB("M2"), U,2) I $P( IB("M2"),U ,4)]"" S I BZCNT=IBZC NT+1,IBZ(I BZCNT)="S: "_$P(IB(" M2"),U,4) I $P(IB("M 2"),U,6)]" " S IBZCNT =IBZCNT+1, IBZ(IBZCNT )="T: "_$P (IB("M2"), U,6) I 'IB ZCNT W ?23 ,IBUN I IB ZCNT F IBZ 1=1:1:IBZC NT W ?23,I BZ(IBZ1) W :(IBZ1'=IB ZCNT) ! K IBZ ; ; Se ction 9 S Z=9,IBW=1 X IBWW S I BREQ=+$$RE QMRA^IBEFU NC(IBIFN) S:IBREQ IB REQ=1 S IB MRASEC=$$M RASEC^IBCE F4(IBIFN) W " ",$S(' IBREQ:"For ce To Prin t? : ",1:" Force MRA Sec Prt? : ") S IBZ= $$EXTERNAL ^DILFD(399 ,27+IBREQ, ,+$P(IB("T X"),U,8+IB REQ)) I IB MRASEC,'$P (IB("TX"), U,8),$P(IB ("TX"),U,9 ) S IBZ="F ORCED TO P RINT BY MR A PRIMARY" ,$P(IB("TX "),U,8)=0 W $S(IBZ'= ""&($P(IB( "TX"),U,8+ IBREQ)'="" ):IBZ,'$$T XMT^IBCEF4 (IBIFN):"[ NOT APPLIC ABLE - NOT TRANSMITT ABLE]",IBR EQ:"NO FOR CED PRINT" ,1:IBZ) ; ; Section 10 S Z=10, IBW=1 X IB WW W " Pro vider ID M aint : (Ed it Provide r ID infor mation)",! G ^IBCSCP Q Q ;WRT1( IBCRED) ; Write cred entials mi smatch W ! ,*7," **Wa rning** Cr edentials differ fro m those fo und in NEW PERSON or IB NON VA ",!,$J("", 14),"BILLI NG PROVIDE R file (", $S(IBCRED= "":"none", 1:IBCRED), ")" W !,$J ("",14),"C hanges wil l print lo cal, but o nly creden tials on f ile transm it" Q ;NSA ME(DA) ; R eturns 1 i f div on b ill is not the defau lt billing facility Q ($P($G(^ IBE(350.9, 1,0)),U,2) '=$P($G(^D G(40.8,+$P (^DGCR(399 ,DA,0),U,2 2),0)),U,7 )) ; ;IBCS C10H | |
| 3153 | ||
| 3154 | Routines | |
| 3155 | Activities | |
| 3156 | Routine Na me | |
| 3157 | IBCSC3 | |
| 3158 | Enhancemen t Category | |
| 3159 | New | |
| 3160 | Modify | |
| 3161 | Delete | |
| 3162 | No Change | |
| 3163 | RTM | |
| 3164 | ||
| 3165 | Related Op tions | |
| 3166 | None | |
| 3167 | Related Ro utines | |
| 3168 | Routines “ Called By” | |
| 3169 | Routines “ Called” | |
| 3170 | ||
| 3171 | ||
| 3172 | ||
| 3173 | ||
| 3174 | Data Dicti onary (DD) Reference s | |
| 3175 | ||
| 3176 | Related Pr otocols | |
| 3177 | None | |
| 3178 | Related In tegration Control Re gistration s (ICRs) | |
| 3179 | None | |
| 3180 | Data Passi ng | |
| 3181 | Input | |
| 3182 | Output Re ference | |
| 3183 | Both | |
| 3184 | Global Re ference | |
| 3185 | Local | |
| 3186 | Input Attr ibute Name and Defin ition | |
| 3187 | Name: | |
| 3188 | Definition : | |
| 3189 | Output Att ribute Nam e and Defi nition | |
| 3190 | Name: | |
| 3191 | Definition : | |
| 3192 | Current Lo gic | |
| 3193 | IBCSC3 ;AL B/MJB - MC CR SCREEN 3 (PAYER/M AILING ADD RESS) ;27 MAY 88 10: 15 ;;2.0;I NTEGRATED BILLING;** 8,43,52,80 ,82,51,137 ,232,320,3 77,516**;2 1-MAR-94;B uild 123 ; ;Per VA Di rective 64 02, this r outine sho uld not be modified. ; ;MAP TO DGCRSC3 ; EN N IB,IB X,IBINS,Y, Z I $D(DGR VRCAL) D ^ IBCU6 K DG RVRCAL D ^ IBCSCU S I BSR=3,IBSR 1="",IBV1= "000" I IB V S IBV1=" 111" D H^I BCSCU D:$D (^DGCR(399 ,IBIFN,"AI C")) 3^IBC VA0 D:'$D( ^DGCR(399, IBIFN,"AIC ")) 123^IB CVA D POL^ IBCNSU41(D FN) F I=0, "M","M1"," U","U2" S IB(I)=$S($ D(^DGCR(39 9,IBIFN,I) ):(^(I)),1 :"") S IBO UTP=2,IBIN DT=$S(+$G( IB("U")):+ IB("U"),1: DT) ; S X= " Rate Typ e : "_$S($ P(IB(0),U, 7)']"":IBU ,$D(^DGCR( 399.3,$P(I B(0),U,7), 0)):$P(^(0 ),U),1:IBU N) S Z=1,I BW=1 X IBW W W X I +$ P($G(^IBE( 350.9,1,1) ),U,22) W $J("",(42- $L(X))),"F orm Type: ",$P($G(^I BE(353,+$P (IB(0),U,1 9),0)),U,1 ) W !?4,"R esponsible : ",$S($P( IB(0),U,11 )']"":IBU, $P(IB(0),U ,11)="p":" PATIENT",$ P(IB(0),U, 11)="i":"I NSURER",1: "OTHER") W ?45,"Paye r Sequence : " S IBX= $P(IB(0),U ,21) W $S( IBX="P":"P rimary",IB X="S":"Sec ondary",IB X="T":"Ter tiary",IBX ="A":"Pati ent",1:"") I $P(IB(0 ),U,11)="i " D . W !? 4,"Bill Pa yer : " S X=$G(^DGCR (399,IBIFN ,"MP")) . W $S(+X:$P ($G(^DIC(3 6,+X,0)),U ,1),$$MCRW NR^IBEFUNC ($$CURR^IB CEF2(IBIFN )):"MRA NE EDED FROM MEDICARE", 1:IBU) . W ?45,"Tran smit: " S Z=0,X=$$TX MT^IBCEF4( IBIFN,.Z) . W $S(X:" Yes",1:"No -"_$S(Z=1: "Forced to print loc al",Z=2&($ $WNRBILL^I BEFUNC(IBI FN)):"MRA not active ",Z=2:"EDI not activ e",Z=3:"Ra te typ tra nsmit off" ,Z=4:"Ins. co transm it off",Z= 5:"Failed RULE #"_$G (Z(0)),Z=6 :"Invalid NDC code t ype",1:"?? ")) I $P(I B(0),U,11) ']"" G MAI L I $P(IB( 0),U,11)=" p" G MAIL I $P(IB(0) ,U,11)="o" W !?4,"In st. Name : ",$S($P(I B("M"),U,1 1)']"":IBU ,$D(^DIC(4 ,$P(IB("M" ),U,11),0) ):$P(^(0), U,1),1:"UN KNOWN INST ITUTION") G MAIL I $ P(IB(0),U, 11)="i" I $D(IBDD)>1 ,$D(^DGCR( 399,IBIFN, "AIC")) G SHW D UP G LST:$D(IB DD)>1 W !? 4,"Insuran ce : NO RE IMBURSABLE INSURANCE INFORMATI ON ON FILE ",!?17,"[A dd Insuran ce Informa tion by en tering '1' at the pr ompt below ]" G MAIL ;LST N IBD TIN,IBICT S IBDTIN=+ $G(IB("U") ),IBICT=0 W ! D HDR^ IBCNS S I= 0 F S I=$ O(IBDD("S" ,I)) Q:'I D Q:IBIC T'<5 .S IB X=0 F S I BX=$O(IBDD ("S",I,IBX )) Q:'IBX S IBINS=$ G(IBDD(IBX ,0)) I IBI NS'="" S I BICT=IBICT +1 D:IBICT <5 D1^IBCN S I IBICT' <5 W !,?1, "**Patient has addit ional insu rance - us e ?INS to see the en tire list" Q G MAILL ST1 W !?4, $S($D(^DIC (36,+IBDD( IBX,0),0)) :$E($P(^(0 ),"^",1),1 ,20),1:"UN KNOWN") S X=$P(IBDD( IBX,0),"^" ,6) W ?26, $S(X="v":" VETERAN",X ="s":"SPOU SE",1:"OTH ER") S X=$ P(IBDD(IBX ,0),"^",16 ) S X=$S(+ X=1:"PATIE NT",+X=2:" SPOUSE",+X =3:"CHILD" ,+X=8:"EMP LOYEE",+X= 11:"ORGAN DONOR",+X= 18:"PARENT ",+X=15:"P LANTIFF",1 :"UNKNOWN" ) I X="UNK NOWN" S X1 =$S($D(IBD D(IBX,0)): $P(IBDD(IB X,0),"^",6 ),1:""),X= $S(X1="v": "PATIENT", X1="s":"SP OUSE",1:X) W ?37,X,? 49 S Y=$P( IBDD(IBX,0 ),"^",8) X ^DD("DD") W Y,?64 S Y=$P(IBDD (IBX,0),"^ ",4) X ^DD ("DD") W Y QSHW I $D (IBDD) S I ="" F S I =$O(IBDD(I )) Q:'I D SHW1MAIL I $$BUFFER ^IBCNBU1(D FN) W !!,? 17,"*** Pa tient has Insurance Buffer ent ries ***" ; S IB("M" )=$S($D(^D GCR(399,IB IFN,"M")): ^("M"),1:" "),IB("M1" )=$S($D(^D GCR(399,IB IFN,"M1")) :^("M1"),1 :""),IB(0) =^DGCR(399 ,IBIFN,0) S Z=2,IBW= 1 W ! X IB WW N IBRAM S S IBRAMS =4.06 I $$ FT^IBCEF(I BIFN)=3 S IBRAMS=4.0 8 S IB("RA FLAG",1)=$ S($P(IB("M "),U,1)="" :0,1:$$GET 1^DIQ(36,$ P(IB("M"), U,1),IBRAM S,"I")) S IB("RAFLAG ",2)=$S($P (IB("M"),U ,2)="":0,1 :$$GET1^DI Q(36,$P(IB ("M"),U,2) ,IBRAMS,"I ")) S IB(" RAFLAG",3) =$S($P(IB( "M"),U,3)= "":0,1:$$G ET1^DIQ(36 ,$P(IB("M" ),U,3),IBR AMS,"I")) S X=0 I $P (IB("M1"), U,2)="",'I B("RAFLAG" ,1),$P(IB( "M1"),U,3) ="",'IB("R AFLAG",2), $P(IB("M1" ),U,4)="", 'IB("RAFLA G",3) S X= 1 W " Bill ing Provid er Seconda ry IDs: " I X W IBUN ; no data found, uns pecified n ot require d I 'X D ; data f ound, disp lay below . W !?5,"P rimary Pay er: ",$S($ P(IB("M1") ,U,2)]"":$ P(IB("M1") ,U,2),IB(" RAFLAG",1) :"ATT/REND ID",1:"") . W !?5," Secondary Payer: ",$ S($P(IB("M 1"),U,3)]" ":$P(IB("M 1"),U,3),I B("RAFLAG" ,2):"ATT/R END ID",1: "") . W ?4 6,"Tertiar y Payer: " ,$S($P(IB( "M1"),U,4) ]"":$P(IB( "M1"),U,4) ,IB("RAFLA G",3):"ATT /REND ID", 1:"") . Q ; S Z=3,IB W=1 W ! X IBWW W " M ailing Add ress : " S X=+$G(^DG CR(399,IBI FN,"MP")) I 'X,$$MCR WNR^IBEFUN C(+$$CURR^ IBCEF2(IBI FN)) S X=+ $$CURR^IBC EF2(IBIFN) I X,+$G(^ DIC(36,X,3 )) S I=$P( ^(3),U,$S( $$FT^IBCEF (IBIFN)=2: 2,1:4)) W ?56,"Elect ronic ID: ",$S(I'="" :I,1:"<NON E>") S X=" " I IB("M" )]"" F I=4 :1:9 Q:X]" " S X=$P( IB("M"),"^ ",I) I X'] "" W !?4," NO MAILING ADDRESS H AS BEEN SP ECIFIED!", ?45,$$UP1, !?4,"Send Bill to PA YER listed above." G ENDSCR S X=IB("M") W !,?4,$S( $P(X,"^",4 )]"":$P(X, "^",4),1:" 'MAIL TO' PERSON/PLA CE UNSPECI FIED"),?45 ,$$UP1 W ! ?4,$S($P(X ,"^",5)]"" :$P(X,"^", 5),1:"STRE ET ADDRESS UNSPECIFI ED") W:$P( X,"^",6)]" " ", ",$P( X,"^",6) W ! W:$P(IB ("M1"),"^" ,1)]"" ?4, $P(IB("M1" ),"^",1)," , " W ?4,$ S($P(X,"^" ,7)]"":$P( X,"^",7),1 :"CITY UNS PECIFIED") ,", ",$S($ D(^DIC(5,+ $P(X,"^",8 ),0)):$P(^ (0),"^",2) ,1:"STATE UNSPECIFIE D")," ",$S ($P(X,"^", 9)]"":$P(X ,"^",9),1: "ZIP UNSPE CIFIED") ; ENDSCR K I BADI,IBDD, IBOUTP,IBI NDT,I,X,X1 G ^IBCSCP ;SHW1 ; D isplay inf ormation f or insuran ce I. ; MR D;IB*2.0*5 16 - Rearr anged some fields to allow mor e characte rs ; to be displayed for Group #, Group Name, Poli cy #, Insu red. S X=I BDD(I,0),Z =$G(^DIC(3 6,+X,0)) W !!?4,"Ins ",I,": " W $E($S($P (Z,U,1)'=" ":$P(Z,U,1 ),1:IBU),1 ,16) I $P( Z,U,2)="N" W ?30,"WI LL NOT REI MBURSE" W ?51,"Whose : ",$S($P( X,"^",6)=" v":"VETERA N",$P(X,"^ ",6)="s":" SPOUSE",1: "OTHER") W !?4,"Poli cy #: ",$E ($S($P(X," ^",2)]"":$ P(X,"^",2) ,1:IBU),1, 34) W ?51, "Rel to In sd: ",$E(I BIR(I),1,1 5) W !?4," Insured: " ,$E($P(X," ^",17),1,3 5) W ?51," Insd Sex: ",$S($D(IB ISEX(I)):I BISEX(I),1 :IBU) W !? 4,"Grp #: ",$E($S($P (X,"^",3)] "":$P(X,"^ ",3),1:IBU ),1,67) W !?4,"Grp N m: ",$E($S ($P(X,"^", 15)]"":$P( X,"^",15), 1:IBU),1,6 6) Q ;UP K IBDD D AL L^IBCNS1(D FN,"IBDD", 2,IBINDT,1 ) I $D(IBD D("S",.5)) D ; At l east 1 MCR WNR insur ance polic y exists . ;try to p ut correct part (A f or institu tion and B for facil ity) . N Z ,IBAB . S IBAB=$S($$ FT^IBCEF(I BIFN)=3:"A ",1:"B") . S Z=0 F S Z=$O(IBD D("S",.5,Z )) Q:'Z D .. I $P($ G(IBDD(Z,3 55.3)),U,1 4)=IBAB S IBDD("S",. 1,Z,0)="" K IBDD("S" ,.5,Z) Q ; UP1() ;che ck if pati ent has me dicare so can print a flag for the user N IBDD,IBX ,IBY S IBY ="" D ALL^ IBCNS1(DFN ,"IBDD",2, IBINDT) S IBX=0 F S IBX=$O(IB DD(IBX)) Q :'IBX I $ P($G(IBDD( IBX,355.3) ),U,9)=33 S IBY="(Pa tient has Medicare)" Q IBY ;IB CSC3 | |
| 3194 | Modified L ogic (Chan ges are in bold) | |
| 3195 | IBCSC3 ;AL B/MJB - MC CR SCREEN 3 (PAYER/M AILING ADD RESS) ;27 MAY 88 10: 15 ;;2.0;I NTEGRATED BILLING;** 8,43,52,80 ,82,51,137 ,232,320,3 77,516,592 **;21-MAR- 94;Build 1 23 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ; ;MA P TO DGCRS C3 ;EN N I B,IBX,IBIN S,Y,Z I $D (DGRVRCAL) D ^IBCU6 K DGRVRCAL D ^IBCSCU S IBSR=3, IBSR1="",I BV1="000" I IBV S IB V1="111" D H^IBCSCU D:$D(^DGCR (399,IBIFN ,"AIC")) 3 ^IBCVA0 D: '$D(^DGCR( 399,IBIFN, "AIC")) 12 3^IBCVA D POL^IBCNSU 41(DFN) F I=0,"M","M 1","U","U2 " S IB(I)= $S($D(^DGC R(399,IBIF N,I)):(^(I )),1:"") S IBOUTP=2, IBINDT=$S( +$G(IB("U" )):+IB("U" ),1:DT) ; S X=" Rate Type : "_ $S($P(IB(0 ),U,7)']"" :IBU,$D(^D GCR(399.3, $P(IB(0),U ,7),0)):$P (^(0),U),1 :IBUN) S Z =1,IBW=1 X IBWW W X I +$P($G(^ IBE(350.9, 1,1)),U,22 ) W $J("", (42-$L(X)) ),"Form Ty pe: ",$P($ G(^IBE(353 ,+$P(IB(0) ,U,19),0)) ,U,1) W !? 4,"Respons ible: ",$S ($P(IB(0), U,11)']"": IBU,$P(IB( 0),U,11)=" p":"PATIEN T",$P(IB(0 ),U,11)="i ":"INSURER ",1:"OTHER ") W ?45," Payer Sequ ence: " S IBX=$P(IB( 0),U,21) W $S(IBX="P ":"Primary ",IBX="S": "Secondary ",IBX="T": "Tertiary" ,IBX="A":" Patient",1 :"") I $P( IB(0),U,11 )="i" D . W !?4,"Bil l Payer : " S X=$G(^ DGCR(399,I BIFN,"MP") ) . W $S(+ X:$P($G(^D IC(36,+X,0 )),U,1),$$ MCRWNR^IBE FUNC($$CUR R^IBCEF2(I BIFN)):"MR A NEEDED F ROM MEDICA RE",1:IBU) . W ?45," Transmit: " S Z=0,X= $$TXMT^IBC EF4(IBIFN, .Z) . W $S (X:"Yes",1 :"No-"_$S( Z=1:"Force d to print local",Z= 2&($$WNRBI LL^IBEFUNC (IBIFN)):" MRA not ac tive",Z=2: "EDI not a ctive",Z=3 :"Rate typ transmit off",Z=4:" Ins. co tr ansmit off ",Z=5:"Fai led RULE # "_$G(Z(0)) ,Z=6:"Inva lid NDC co de type",1 :"??")) I $P(IB(0),U ,11)']"" G MAIL I $P (IB(0),U,1 1)="p" G M AIL I $P(I B(0),U,11) ="o" W !?4 ,"Inst. Na me : ",$S( $P(IB("M") ,U,11)']"" :IBU,$D(^D IC(4,$P(IB ("M"),U,11 ),0)):$P(^ (0),U,1),1 :"UNKNOWN INSTITUTIO N") G MAIL I $P(IB(0 ),U,11)="i " I $D(IBD D)>1,$D(^D GCR(399,IB IFN,"AIC") ) G SHW D UP G LST:$ D(IBDD)>1 W !?4,"Ins urance : N O REIMBURS ABLE INSUR ANCE INFOR MATION ON FILE",!?17 ,"[Add Ins urance Inf ormation b y entering '1' at th e prompt b elow]" G M AIL ;LST N IBDTIN,IB ICT S IBDT IN=+$G(IB( "U")),IBIC T=0 W ! D HDR^IBCNS S I=0 F S I=$O(IBDD ("S",I)) Q :'I D Q: IBICT'<5 . S IBX=0 F S IBX=$O( IBDD("S",I ,IBX)) Q:' IBX S IBI NS=$G(IBDD (IBX,0)) I IBINS'="" S IBICT=I BICT+1 D:I BICT<5 D1^ IBCNS I IB ICT'<5 W ! ,?1,"**Pat ient has a dditional insurance - use ?INS to see th e entire l ist" Q G M AILLST1 W !?4,$S($D( ^DIC(36,+I BDD(IBX,0) ,0)):$E($P (^(0),"^", 1),1,20),1 :"UNKNOWN" ) S X=$P(I BDD(IBX,0) ,"^",6) W ?26,$S(X=" v":"VETERA N",X="s":" SPOUSE",1: "OTHER") S X=$P(IBDD (IBX,0),"^ ",16) S X= $S(+X=1:"P ATIENT",+X =2:"SPOUSE ",+X=3:"CH ILD",+X=8: "EMPLOYEE" ,+X=11:"OR GAN DONOR" ,+X=18:"PA RENT",+X=1 5:"PLANTIF F",1:"UNKN OWN") I X= "UNKNOWN" S X1=$S($D (IBDD(IBX, 0)):$P(IBD D(IBX,0)," ^",6),1:"" ),X=$S(X1= "v":"PATIE NT",X1="s" :"SPOUSE", 1:X) W ?37 ,X,?49 S Y =$P(IBDD(I BX,0),"^", 8) X ^DD(" DD") W Y,? 64 S Y=$P( IBDD(IBX,0 ),"^",4) X ^DD("DD") W Y QSHW I $D(IBDD) S I="" F S I=$O(IB DD(I)) Q:' I D SHW1M AIL I $$BU FFER^IBCNB U1(DFN) W !!,?17,"** * Patient has Insura nce Buffer entries * **" ; S IB ("M")=$S($ D(^DGCR(39 9,IBIFN,"M ")):^("M") ,1:""),IB( "M1")=$S($ D(^DGCR(39 9,IBIFN,"M 1")):^("M1 "),1:""),I B(0)=^DGCR (399,IBIFN ,0) S Z=2, IBW=1 W ! X IBWW N I BRAMS S IB RAMS=4.06 I $$FT^IBC EF(IBIFN)= 3 S IBRAMS =4.08 S IB ("RAFLAG", 1)=$S($P(I B("M"),U,1 )="":0,1:$ $GET1^DIQ( 36,$P(IB(" M"),U,1),I BRAMS,"I") ) S IB("RA FLAG",2)=$ S($P(IB("M "),U,2)="" :0,1:$$GET 1^DIQ(36,$ P(IB("M"), U,2),IBRAM S,"I")) S IB("RAFLAG ",3)=$S($P (IB("M"),U ,3)="":0,1 :$$GET1^DI Q(36,$P(IB ("M"),U,3) ,IBRAMS,"I ")) S X=0 I $P(IB("M 1"),U,2)=" ",'IB("RAF LAG",1),$P (IB("M1"), U,3)="",'I B("RAFLAG" ,2),$P(IB( "M1"),U,4) ="",'IB("R AFLAG",3) S X=1 W " Billing Pr ovider Sec ondary IDs : " I X W IBUN ; no d ata found, unspecifi ed not req uired I 'X D ; da ta found, display be low . W !? 5,"Primary Payer: ", $S($P(IB(" M1"),U,2)] "":$P(IB(" M1"),U,2), IB("RAFLAG ",1):"ATT/ REND ID",1 :"") . W ! ?5,"Second ary Payer: ",$S($P(I B("M1"),U, 3)]"":$P(I B("M1"),U, 3),IB("RAF LAG",2):"A TT/REND ID ",1:"") . W ?46,"Ter tiary Paye r: ",$S($P (IB("M1"), U,4)]"":$P (IB("M1"), U,4),IB("R AFLAG",3): "ATT/REND ID",1:"") . Q ; S Z= 3,IBW=1 W ! X IBWW W " Mailing Address : " S X=+$G (^DGCR(399 ,IBIFN,"MP ")) I 'X,$ $MCRWNR^IB EFUNC(+$$C URR^IBCEF2 (IBIFN)) S X=+$$CURR ^IBCEF2(IB IFN) ;JWS; IB*2.0*592 US1108 - Dental for m #7 I X,+ $G(^DIC(36 ,X,3)) S I =$P(^(3),U ,$S($$FT^I BCEF(IBIFN )=2:2,$$FT ^IBCEF(IBI FN)=7:15,1 :4)) W ?56 ,"Electron ic ID: ",$ S(I'="":I, 1:"<NONE>" ) S X="" I IB("M")]" " F I=4:1: 9 Q:X]"" S X=$P(IB( "M"),"^",I ) I X']"" W !?4,"NO MAILING AD DRESS HAS BEEN SPECI FIED!",?45 ,$$UP1,!?4 ,"Send Bil l to PAYER listed ab ove." G EN DSCR S X=I B("M") W ! ,?4,$S($P( X,"^",4)]" ":$P(X,"^" ,4),1:"'MA IL TO' PER SON/PLACE UNSPECIFIE D"),?45,$$ UP1 W !?4, $S($P(X,"^ ",5)]"":$P (X,"^",5), 1:"STREET ADDRESS UN SPECIFIED" ) W:$P(X," ^",6)]"" " , ",$P(X," ^",6) W ! W:$P(IB("M 1"),"^",1) ]"" ?4,$P( IB("M1")," ^",1),", " W ?4,$S($ P(X,"^",7) ]"":$P(X," ^",7),1:"C ITY UNSPEC IFIED"),", ",$S($D(^ DIC(5,+$P( X,"^",8),0 )):$P(^(0) ,"^",2),1: "STATE UNS PECIFIED") ," ",$S($P (X,"^",9)] "":$P(X,"^ ",9),1:"ZI P UNSPECIF IED") ;END SCR K IBAD I,IBDD,IBO UTP,IBINDT ,I,X,X1 G ^IBCSCP ;S HW1 ; Disp lay inform ation for insurance I. ; MRD;I B*2.0*516 - Rearrang ed some fi elds to al low more c haracters ; to be di splayed fo r Group #, Group Nam e, Policy #, Insured . S X=IBDD (I,0),Z=$G (^DIC(36,+ X,0)) W !! ?4,"Ins ", I,": " W $ E($S($P(Z, U,1)'="":$ P(Z,U,1),1 :IBU),1,16 ) I $P(Z,U ,2)="N" W ?30,"WILL NOT REIMBU RSE" W ?51 ,"Whose: " ,$S($P(X," ^",6)="v": "VETERAN", $P(X,"^",6 )="s":"SPO USE",1:"OT HER") W !? 4,"Policy #: ",$E($S ($P(X,"^", 2)]"":$P(X ,"^",2),1: IBU),1,34) W ?51,"Re l to Insd: ",$E(IBIR (I),1,15) W !?4,"Ins ured: ",$E ($P(X,"^", 17),1,35) W ?51,"Ins d Sex: ",$ S($D(IBISE X(I)):IBIS EX(I),1:IB U) W !?4," Grp #: ",$ E($S($P(X, "^",3)]"": $P(X,"^",3 ),1:IBU),1 ,67) W !?4 ,"Grp Nm: ",$E($S($P (X,"^",15) ]"":$P(X," ^",15),1:I BU),1,66) Q ;UP K IB DD D ALL^I BCNS1(DFN, "IBDD",2,I BINDT,1) I $D(IBDD(" S",.5)) D ; At leas t 1 MCR WN R insuranc e policy e xists . ;t ry to put correct pa rt (A for institutio n and B fo r facility ) . N Z,IB AB . S IBA B=$S($$FT^ IBCEF(IBIF N)=3:"A",1 :"B") . S Z=0 F S Z =$O(IBDD(" S",.5,Z)) Q:'Z D .. I $P($G(I BDD(Z,355. 3)),U,14)= IBAB S IBD D("S",.1,Z ,0)="" K I BDD("S",.5 ,Z) Q ;UP1 () ;check if patient has medic are so can print a f lag for th e user N I BDD,IBX,IB Y S IBY="" D ALL^IBC NS1(DFN,"I BDD",2,IBI NDT) S IBX =0 F S IB X=$O(IBDD( IBX)) Q:'I BX I $P($ G(IBDD(IBX ,355.3)),U ,9)=33 S I BY="(Patie nt has Med icare)" Q IBY ;IBCSC 3 | |
| 3196 | ||
| 3197 | ||
| 3198 | Routines | |
| 3199 | Activities | |
| 3200 | Routine Na me | |
| 3201 | IBCSC5 | |
| 3202 | Enhancemen t Category | |
| 3203 | New | |
| 3204 | Modify | |
| 3205 | Delete | |
| 3206 | No Change | |
| 3207 | RTM | |
| 3208 | ||
| 3209 | Related Op tions | |
| 3210 | None | |
| 3211 | Related Ro utines | |
| 3212 | Routines “ Called By” | |
| 3213 | Routines “ Called” | |
| 3214 | ||
| 3215 | ||
| 3216 | ||
| 3217 | ||
| 3218 | Data Dicti onary (DD) Reference s | |
| 3219 | ||
| 3220 | Related Pr otocols | |
| 3221 | None | |
| 3222 | Related In tegration Control Re gistration s (ICRs) | |
| 3223 | None | |
| 3224 | Data Passi ng | |
| 3225 | Input | |
| 3226 | Output Re ference | |
| 3227 | Both | |
| 3228 | Global Re ference | |
| 3229 | Local | |
| 3230 | Input Attr ibute Name and Defin ition | |
| 3231 | Name: | |
| 3232 | Definition : | |
| 3233 | Output Att ribute Nam e and Defi nition | |
| 3234 | Name: | |
| 3235 | Definition : | |
| 3236 | Current Lo gic | |
| 3237 | IBCSC5 ;AL B/MJB - MC CR SCREEN 5 (OPT. EO C) ;27 MAY 88 10:15 ;;2.0;INTE GRATED BIL LING;**52, 125,51,210 ,266,288,2 87,309,389 ,447,461** ;21-MAR-94 ;Build 58 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ; ; MAP TO DGC RSC5 ;EN I $$INPAT^I BCEF(IBIFN ) G ^IBCSC 4 I $D(IBA SKCOD) K I BASKCOD D CODMUL^IBC U7 I $$BIL LCPT^IBCRU 4(IBIFN) D ASK^IBCU7 A(IBIFN) S DGRVRCAL= 1 I $D(DGR VRCAL) D ^ IBCU6 K DG RVRCAL L ^ DGCR(399,I BIFN):1 D ^IBCSCU S IBSR=5,IBS R1="",IBV1 ="10000000 "_$S($$FT^ IBCEF(IBIF N)'=2:0,1: 1) F I="U" ,0 S IB(I) =$S($D(^DG CR(399,IBI FN,I)):^(I ),1:"") S: IBV IBV1=" 111111111" D H^IBCSC U S IBPTF= $P(IB(0),U ,8),IBBT=$ P(IB(0),"^ ",4)_$P(IB (0),"^",5) _$P(IB(0), "^",6) D E N4^IBCVA1 S Z=1,IBW= 1 X IBWW W " Event D ate : " S Y=$P(IB(0) ,U,3) D DT ^DIQ N IBP OARR,IBDAT E D SET^IB CSC4D(IBIF N,"",.IBPO ARR) S IBD ATE=$$BDAT E^IBACSV(I BIFN) ; St atement To date S Z= 2,IBW=1 X IBWW W " P rin. Diag. : " S Y=$$ DX^IBCSC4( 0,IBDATE) W $S(Y'="" :$E($P(Y,U ,4),1,47)_ " - "_$P(Y ,U,2),$$DX REQ^IBCSC4 (IBIFN):IB U,1:IBUN) F I=1:1:4 S Y=$$DX^I BCSC4(+Y,I BDATE) Q:Y ="" W !?4 ,"Other Di ag.: ",$E( $P(Y,U,4), 1,47)_" - "_$P(Y,U,2 ) I +Y S Y =$$DX^IBCS C4(+Y,IBDA TE) I +Y W !?4,"***T here are m ore diagno ses associ ated with this bill. ***"OP S Z =3,IBW=1 X IBWW W " OP Visits : " F I=0: 0 S I=$O(^ DGCR(399,I BIFN,"OP", I)) Q:'I S Y=I X ^D D("DD") W: $X>67 !?17 W Y_", " S:$D(^DGCR (399,"OP") ) DGOPV=1 I '$O(^DGC R(399,IBIF N,"OP",0)) W IBU W ! ,?4,"Type : ",$$GET1 ^DIQ(399,I BIFN_",",1 58) ; Adde d with IB* 2.0*447 BI S Z=4,IBW =1 X IBWW W " Cod. M ethod: ",$ S($P(IB(0) ,U,9)="":I BUN,$P(IB( 0),U,9)=9: "ICD",$P(I B(0),U,9)= 4:"CPT-4", 1:"HCPCS") D WRT:$D( IBPROC) S Z=5,IBW=1 X IBWW W " Rx. Refil ls: " S Y= $$RX I 'Y W IBUNOCC G OCC^IBCS C4 W !?4," Opt. Code : ",IBUN G OCC^IBCSC 4 QMORE W !?4,*7,"** *There are more proc edures ass ociated wi th this bi ll.***" S I=0 QWRT ; -write ou t procedur es codes o n screen N IBDATE S J=0 F I=1: 1 S J=$O(I BPROC(J)) Q:'J D I I>6 D MOR E Q .S IBD ATE=$P(IBP ROC(J),U,2 ) I 'IBDAT E S IBDATE =$$BDATE^I BACSV($G(I BIFN)) .S X=$$PRCD^I BCEF1($P(I BPROC(J),U ),1,IBDATE ) .I IBPRO C(J)["ICD" W !?4,"IC D Code : " ,$E($P(X,U ,3),1,28)_ " - "_$P(X ,U,2) .I I BPROC(J)[" CPT" W !?4 ,"CPT Code : " D .. N Z .. S Z =$P(X,"^", 3)_" "_$P( X,"^",2)_$ S($P(IBPRO C(J),U,15) :"-"_$$MOD LST^IBEFUN C2($P(IBPR OC(J),U,15 )),1:"") . . I $L(Z)> 40 S Z=" " _$P(X,"^", 2)_$S($P(I BPROC(J),U ,15):"-"_$ $MODLST^IB EFUNC2($P( IBPROC(J), U,15)),1:" "),Z=$E($P (X,U,3),1, 40-$L(Z))_ Z .. W Z . I $P(IB(0) ,U,19)=2 S Y=+$P(IBP ROC(J),U,1 1) S:+Y Y= +$G(^IBA(3 62.3,+Y,0) ) W ?58,$P ($$ICD9^IB ACSV(Y,IBD ATE),U) S Y=$P(IBPRO C(J),U,2) D D^DIQ W ?67,Y Q .S Y=$P(IBPR OC(J),"^", 2) D D^DIQ W ?67,Y Q ;MOD(IBM, PUNC) ; Re turns modi fier list from comma delimited ien's in string IBM ; PUNC = Punctuatio n to use a s first ch aracter of output N IBMOD,Q S IBMOD="" F Q=1:1:$L( IBM,",") I $P(IBM,", ",Q)'="" S IBMOD=IBM OD_$S(IBMO D'="":",", 1:"")_$P($ $MOD^ICPTM OD($P(IBM, ",",Q),"I" ),U,2) I I BMOD'="" S IBMOD=$G( PUNC)_IBMO D Q IBMOD ;PD() ;pri nts prosth etic devic e in exter nal form, returns 0 if there a re none N IBX,IBY,IB Z,IBN,X S X=0 S IBX= 0 F S IBX =$O(^IBA(3 62.5,"AIFN "_IBIFN,IB X)) Q:'IBX D Q:X>5 . S IBY=0 F S IBY= $O(^IBA(36 2.5,"AIFN" _IBIFN,IBX ,IBY)) Q:' IBY S IBZ =$G(^IBA(3 62.5,IBY,0 )) I IBZ'= "" D Q:X> 5 .. S X=X +1 I X>5 W !,?17,"** * There ar e more Pro s. Items a ssociated with this bill.***" Q .. W:X'= 1 ! W ?17, $E($P(IBZ, U,5),1,40) ,?67,$$FMT E^XLFDT(+I BZ) Q X ;R X() ;print s RX REFIL LS in exte rnal form, returns 0 if there are none N IBX,IBY,I BZ,IBN,X S X=0 S IBX ="" F S I BX=$O(^IBA (362.4,"AI FN"_IBIFN, IBX)) Q:IB X="" D Q :X>5 . S I BY=0 F S IBY=$O(^IB A(362.4,"A IFN"_IBIFN ,IBX,IBY)) Q:'IBY S IBZ=$G(^I BA(362.4,I BY,0)) I I BZ'="" D Q:X>5 .. S X=X+1 I X >5 W !,?17 ,"*** Ther e are more Rx. Refil ls associa ted with t his bill.* **" Q ..D ZERO^IBRXU TL(+$P(IBZ ,U,4)) .. S IBN=$G(^ TMP($J,"IB DRUG",+$P( IBZ,U,4),. 01)) W:X'= 1 ! W ?17, IBN,?65,$$ FMTE^XLFDT (+$P(IBZ,U ,3)) K ^TM P($J,"IBDR UG") Q X ; ;IBCSC5 | |
| 3238 | Modified L ogic (Chan ges are in bold) | |
| 3239 | IBCSC5 ;AL B/MJB - MC CR SCREEN 5 (OPT. EO C) ;27 MAY 88 10:15 ;;2.0;INTE GRATED BIL LING;**52, 125,51,210 ,266,288,2 87,309,389 ,447,461,5 92**;21-MA R-94;Build 58 ;;Per VHA Direct ive 2004-0 38, this r outine sho uld not be modified. ; ;MAP TO DGCRSC5 ; EN I $$INP AT^IBCEF(I BIFN) G ^I BCSC4 I $D (IBASKCOD) K IBASKCO D D CODMUL ^IBCU7 I $ $BILLCPT^I BCRU4(IBIF N) D ASK^I BCU7A(IBIF N) S DGRVR CAL=1 I $D (DGRVRCAL) D ^IBCU6 K DGRVRCAL L ^DGCR(3 99,IBIFN): 1 D ^IBCSC U S IBSR=5 ,IBSR1="", IBV1="1000 0000"_$S($ $FT^IBCEF( IBIFN)'=2: 0,1:1) ;JW S;IB*2.0*5 92 US1108 - Dental I $$FT^IBCE F(IBIFN)=7 S IBV1=10 00 F I="U" ,0 S IB(I) =$S($D(^DG CR(399,IBI FN,I)):^(I ),1:"") S: IBV IBV1=" 111111111" D H^IBCSC U S IBPTF= $P(IB(0),U ,8),IBBT=$ P(IB(0),"^ ",4)_$P(IB (0),"^",5) _$P(IB(0), "^",6) D E N4^IBCVA1 S Z=1,IBW= 1 X IBWW W " Event D ate : " S Y=$P(IB(0) ,U,3) D DT ^DIQ N IBP OARR,IBDAT E D SET^IB CSC4D(IBIF N,"",.IBPO ARR) S IBD ATE=$$BDAT E^IBACSV(I BIFN) ; St atement To date S Z= 2,IBW=1 X IBWW W " P rin. Diag. : " S Y=$$ DX^IBCSC4( 0,IBDATE) W $S(Y'="" :$E($P(Y,U ,4),1,47)_ " - "_$P(Y ,U,2),$$DX REQ^IBCSC4 (IBIFN):IB U,1:IBUN) F I=1:1:4 S Y=$$DX^I BCSC4(+Y,I BDATE) Q:Y ="" W !?4 ,"Other Di ag.: ",$E( $P(Y,U,4), 1,47)_" - "_$P(Y,U,2 ) I +Y S Y =$$DX^IBCS C4(+Y,IBDA TE) I +Y W !?4,"***T here are m ore diagno ses associ ated with this bill. ***"OP S Z =3,IBW=1 X IBWW W " OP Visits : " F I=0: 0 S I=$O(^ DGCR(399,I BIFN,"OP", I)) Q:'I S Y=I X ^D D("DD") W: $X>67 !?17 W Y_", " S:$D(^DGCR (399,"OP") ) DGOPV=1 I '$O(^DGC R(399,IBIF N,"OP",0)) W IBU W ! ,?4,"Type : ",$$GET1 ^DIQ(399,I BIFN_",",1 58) ; Adde d with IB* 2.0*447 BI S Z=4,IBW =1 X IBWW W " Cod. M ethod: ",$ S($P(IB(0) ,U,9)="":I BUN,$P(IB( 0),U,9)=9: "ICD",$P(I B(0),U,9)= 4:"CPT-4", 1:"HCPCS") D WRT:$D( IBPROC) ;J WS;IB*2.0* 592 US1108 - Dental I $$FT^IBC EF(IBIFN)= 7 D Q^IBCS C4B G ^IBC SCP S Z=5, IBW=1 X IB WW W " Rx. Refills: " S Y=$$RX I 'Y W IB UNOCC G OC C^IBCSC4 W !?4,"Opt. Code : ", IBUN G OCC ^IBCSC4 QM ORE W !?4, *7,"***The re are mor e procedur es associa ted with t his bill.* **" S I=0 QWRT ; -wr ite out pr ocedures c odes on sc reen N IBD ATE S J=0 F I=1:1 S J=$O(IBPRO C(J)) Q:'J D I I>6 D MORE Q .S IBDATE= $P(IBPROC( J),U,2) I 'IBDATE S IBDATE=$$B DATE^IBACS V($G(IBIFN )) .S X=$$ PRCD^IBCEF 1($P(IBPRO C(J),U),1, IBDATE) .I IBPROC(J) ["ICD" W ! ?4,"ICD Co de : ",$E( $P(X,U,3), 1,28)_" - "_$P(X,U,2 ) .I IBPRO C(J)["CPT" W !?4,"CP T Code : " D .. N Z .. S Z=$P( X,"^",3)_" "_$P(X,"^ ",2)_$S($P (IBPROC(J) ,U,15):"-" _$$MODLST^ IBEFUNC2($ P(IBPROC(J ),U,15)),1 :"") .. I $L(Z)>40 S Z=" "_$P( X,"^",2)_$ S($P(IBPRO C(J),U,15) :"-"_$$MOD LST^IBEFUN C2($P(IBPR OC(J),U,15 )),1:""),Z =$E($P(X,U ,3),1,40-$ L(Z))_Z .. W Z .;JWS ;IB*2.0*59 2 US1108 - Dental fo rm #7 .I $ P(IB(0),U, 19)=2!($P( IB(0),U,19 )=7) S Y=+ $P(IBPROC( J),U,11) S :+Y Y=+$G( ^IBA(362.3 ,+Y,0)) W ?58,$P($$I CD9^IBACSV (Y,IBDATE) ,U) S Y=$P (IBPROC(J) ,U,2) D D^ DIQ W ?67, Y Q .S Y=$ P(IBPROC(J ),"^",2) D D^DIQ W ? 67,Y Q ;MO D(IBM,PUNC ) ; Return s modifier list from comma del imited ien 's in stri ng IBM ; P UNC = Punc tuation to use as fi rst charac ter of out put N IBMO D,Q S IBMO D="" F Q=1 :1:$L(IBM, ",") I $P( IBM,",",Q) '="" S IBM OD=IBMOD_$ S(IBMOD'=" ":",",1:"" )_$P($$MOD ^ICPTMOD($ P(IBM,",", Q),"I"),U, 2) I IBMOD '="" S IBM OD=$G(PUNC )_IBMOD Q IBMOD ;PD( ) ;prints prosthetic device in external form, retu rns 0 if t here are n one N IBX, IBY,IBZ,IB N,X S X=0 S IBX=0 F S IBX=$O( ^IBA(362.5 ,"AIFN"_IB IFN,IBX)) Q:'IBX D Q:X>5 . S IBY=0 F S IBY=$O(^ IBA(362.5, "AIFN"_IBI FN,IBX,IBY )) Q:'IBY S IBZ=$G( ^IBA(362.5 ,IBY,0)) I IBZ'="" D Q:X>5 .. S X=X+1 I X>5 W !,? 17,"*** Th ere are mo re Pros. I tems assoc iated with this bill .***" Q .. W:X'=1 ! W ?17,$E($ P(IBZ,U,5) ,1,40),?67 ,$$FMTE^XL FDT(+IBZ) Q X ;RX() ;prints RX REFILLS i n external form, ret urns 0 if there are none N IBX ,IBY,IBZ,I BN,X S X=0 S IBX="" F S IBX=$ O(^IBA(362 .4,"AIFN"_ IBIFN,IBX) ) Q:IBX="" D Q:X>5 . S IBY=0 F S IBY= $O(^IBA(36 2.4,"AIFN" _IBIFN,IBX ,IBY)) Q:' IBY S IBZ =$G(^IBA(3 62.4,IBY,0 )) I IBZ'= "" D Q:X> 5 .. S X=X +1 I X>5 W !,?17,"** * There ar e more Rx. Refills a ssociated with this bill.***" Q ..D ZERO ^IBRXUTL(+ $P(IBZ,U,4 )) .. S IB N=$G(^TMP( $J,"IBDRUG ",+$P(IBZ, U,4),.01)) W:X'=1 ! W ?17,IBN, ?65,$$FMTE ^XLFDT(+$P (IBZ,U,3)) K ^TMP($J ,"IBDRUG") Q X ; ;IB CSC5 | |
| 3240 | ||
| 3241 | Routines | |
| 3242 | Activities | |
| 3243 | Routine Na me | |
| 3244 | IBCSC8 | |
| 3245 | Enhancemen t Category | |
| 3246 | New | |
| 3247 | Modify | |
| 3248 | Delete | |
| 3249 | No Change | |
| 3250 | RTM | |
| 3251 | ||
| 3252 | Related Op tions | |
| 3253 | None | |
| 3254 | Related Ro utines | |
| 3255 | Routines “ Called By” | |
| 3256 | Routines “ Called” | |
| 3257 | ||
| 3258 | ||
| 3259 | ||
| 3260 | ||
| 3261 | Data Dicti onary (DD) Reference s | |
| 3262 | ||
| 3263 | Related Pr otocols | |
| 3264 | None | |
| 3265 | Related In tegration Control Re gistration s (ICRs) | |
| 3266 | None | |
| 3267 | Data Passi ng | |
| 3268 | Input | |
| 3269 | Output Re ference | |
| 3270 | Both | |
| 3271 | Global Re ference | |
| 3272 | Local | |
| 3273 | Input Attr ibute Name and Defin ition | |
| 3274 | Name: | |
| 3275 | Definition : | |
| 3276 | Output Att ribute Nam e and Defi nition | |
| 3277 | Name: | |
| 3278 | Definition : | |
| 3279 | Current Lo gic | |
| 3280 | IBCSC8 ;AL B/MJB/AAS - MCCR SCR EEN 8 (BIL LING - CLA IM INFORMA TION SCREE N) ;27 MAY 88 10:15 ;;2.0;INTE GRATED BIL LING;**432 ,447,488** ;21-MAR-94 ;Build 184 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ; ;EN D ^IBC SCU S IBSR =8,IBSR1=" " S IB("U2 ")=$G(^DGC R(399,IBIF N,"U2")),I B("U4")=$G (^DGCR(399 ,IBIFN,"U4 ")),IB("U5 ")=$G(^DGC R(399,IBIF N,"U5")),I B("U6")=$G (^DGCR(399 ,IBIFN,"U6 ")),IB("U8 ")=$G(^DGC R(399,IBIF N,"U8")) D H^IBCSCU ; DEM - IB V is set i n EDI^IBCB => S IBAC =1,IBV=0 D EN G Q:'I BAC1,EDI ; IBV=0, or IBV=1 as a flag if field on s creen is r equired ; or not. <F ield #> in dicates fi eld is not required. ; [Field #] ; Make some secti ons NOT av ailable fo r UB04 for m S IBT=$P ($G(^DGCR( 399,IBIFN, 0)),U,19) ;S IBV1=$S (IBT=3:"00 1011",IBV: "111111",1 :"000000") S IBV1=$S (IBT=3:"00 1011111",I BV:"111111 111",1:"00 0000000") ; IB*2.0*4 88 (vd) ; S Z=1,IBW= 1 X IBWW W " COB Non -Covered C harge Amt: " S X=$P( IB("U4"),U ),X2="2$" I X'="" D COMMA^%DTC W X S Z=2 X IBWW W " Property Casualty Informatio n" W !,?4, "Claim Num ber: ",$P( IB("U4"),U ,2),?41,"C ontact Nam e: ",$P(IB ("U4"),U,9 ) W !,?4," Date of 1s t Contact: ",$$FMTE^ XLFDT($P(I B("U4"),U, 3)),?41,"C ontact Pho ne: ",$P(I B("U4"),U, 10)," ",$P (IB("U4"), U,11) ; St art IB*2.0 *447 BI ;S Z=3 X IBW W W " Ambu lance Info rmation" ; W !,?41,"D /O Locatio n: ",$P(IB ("U6"),U) ;W !,?4,"P /U Address 1: ",$P(IB ("U5"),U,2 ),?41,"D/O Address1: ",$P(IB(" U6"),U,2) ;W !,?4,"P /U Address 2: ",$P(IB ("U5"),U,3 ),?41,"D/O Address2: ",$P(IB(" U6"),U,3) ;W !,?4,"P /U City: " ,$P(IB("U5 "),U,4),?4 1,"D/O Cit y: ",$P(IB ("U6"),U,4 ) ;W !,?4, "P/U State /Zip: " W: $P(IB("U5" ),U,5)'="" $P($G(^DI C(5,$P(IB( "U5"),U,5) ,0)),U,2) ;W:$P(IB(" U5"),U,6)] "" "/"_$P( IB("U5"),U ,6) ;W ?41 ,"D/O Stat e/Zip: " W :$P(IB("U6 "),U,5)'=" " $P($G(^D IC(5,$P(IB ("U6"),U,5 ),0)),U,2) ;W:$P(IB( "U6"),U,6) ]"" "/"_$P (IB("U6"), U,6) ;;W ! ,?4,"P/U C ountry/Sub Div: ",$P( IB("U5"),U ),?41,"D/O Country/S ubDiv: " S Z=3 X IBW W W " Surg ical Codes for Anest hesia Clai ms" W !,?4 ,"Primary Code: " W: $P(IB("U4" ),U,7)'="" $P($G(^IC PT($P(IB(" U4"),U,7), 0)),U) W ? 41,"Second ary Code: " W:$P(IB( "U4"),U,8) '="" $P($G (^ICPT($P( IB("U4"),U ,8),0)),U) S Z=4 X I BWW W " Pa perwork At tachment I nformation " W !,?4," Report Typ e: " W:$P( IB("U8"),U ,2)'="" $P ($G(^IBE(3 53.3,$P(IB ("U8"),U,2 ),0)),U) W ?41,"Tran smission M ethod: ",$ P(IB("U8") ,U,3) W !, ?4,"Attach ment Contr ol #: ",$P (IB("U8"), U) S Z=5 X IBWW W " Disability Start Dat e: ",$$FMT E^XLFDT($P (IB("U4"), U,4)),?41, "Disabilit y End Date : ",$$FMTE ^XLFDT($P( IB("U4"),U ,5)) S Z=6 X IBWW W " Assumed Care Date: ",$$FMTE^ XLFDT($P(I B("U4"),U, 13)),?41," Relinquish ed Care Da te: ",$$FM TE^XLFDT($ P(IB("U4") ,U,14)) ; End IB*2.0 *447 BI ; ;/ Beginni ng of IB*2 .0*488 - c ode moved from IBCSC 10H (vd) S Z=7 X IBW W W " Spec ial Progra m: " I $P( IB("U2"),U ,16)'="" S IBZ=$$EXP AND^IBTRE( 399,238,$P (IB("U2"), U,16)) W $ S(IBZ'="": IBZ,$$WNRB ILL^IBEFUN C(IBIFN):" 31",1:"") S Z=8 X IB WW W " Hom ebound: ", $$EXPAND^I BTRE(399,2 36,$P(IB(" U2"),U,14) ) S Z=9 X IBWW W " D ate Last S een: ",$$E XPAND^IBTR E(399,237, $P(IB("U2" ),U,15)) ; / End of I B*2.0*488 (vd)REV G ^IBCSCP ;I BCSC8 | |
| 3281 | Modified L ogic (Chan ges are in bold) | |
| 3282 | IBCSC8 ;AL B/MJB/AAS - MCCR SCR EEN 8 (BIL LING - CLA IM INFORMA TION SCREE N) ;27 MAY 88 10:15 ;;2.0;INTE GRATED BIL LING;**432 ,447,488,5 77,592**;2 1-MAR-94;B uild 1 ;;P er VHA Dir ective 200 4-038, thi s routine should not be modifi ed. ; ;EN D ^IBCSCU S IBSR=8,I BSR1="" S IB("U2")=$ G(^DGCR(39 9,IBIFN,"U 2")),IB("U 4")=$G(^DG CR(399,IBI FN,"U4")), IB("U5")=$ G(^DGCR(39 9,IBIFN,"U 5")),IB("U 6")=$G(^DG CR(399,IBI FN,"U6")), IB("U8")=$ G(^DGCR(39 9,IBIFN,"U 8")) D H^I BCSCU ; DE M - IBV is set in ED I^IBCB => S IBAC=1,I BV=0 D EN G Q:'IBAC1 ,EDI ; IBV =0, or IBV =1 as a fl ag if fiel d on scree n is requi red ; or n ot. <Field #> indica tes field is not req uired. ; [ Field #] ; Make some sections NOT availa ble for UB 04 form S IBT=$P($G( ^DGCR(399, IBIFN,0)), U,19) ;S I BV1=$S(IBT =3:"001011 ",IBV:"111 111",1:"00 0000") ;JW S;IB*2.0*5 92 US1108 - Dental S IBV1=$S(I BT=3:"0010 11111",IBT =7:"000",I BV:"111111 111",1:"00 0000000") ; IB*2.0*4 88 (vd) I IBT=7 D IB TEETH,DENT AL K IBTEE TH G REV ; JWS;IB*2.0 *592 -end ; S Z=1,IB W=1 X IBWW W " COB N on-Covered Charge Am t: " S X=$ P(IB("U4") ,U),X2="2$ " I X'="" D COMMA^%D TC W X S Z =2 X IBWW W " Proper ty Casualt y Informat ion" ;W !, ?4,"Claim Number: ", $P(IB("U4" ),U,2),?41 ,"Contact Name: ",$P (IB("U4"), U,9) ;JRA IB*2.0*577 ';' W !,? 4,"Claim N umber: ",$ P(IB("U4") ,U,2) ;JRA IB*2.0*57 7 W !,?4," Contact Na me: ",$P(I B("U4"),U, 9) ;JRA IB *2.0*577 W !,?4,"Dat e of 1st C ontact: ", $$FMTE^XLF DT($P(IB(" U4"),U,3)) ,?41,"Cont act Phone: ",$P(IB(" U4"),U,10) ," ",$P(IB ("U4"),U,1 1) ; Start IB*2.0*44 7 BI ;S Z= 3 X IBWW W " Ambulan ce Informa tion" ;W ! ,?41,"D/O Location: ",$P(IB("U 6"),U) ;W !,?4,"P/U Address1: ",$P(IB("U 5"),U,2),? 41,"D/O Ad dress1: ", $P(IB("U6" ),U,2) ;W !,?4,"P/U Address2: ",$P(IB("U 5"),U,3),? 41,"D/O Ad dress2: ", $P(IB("U6" ),U,3) ;W !,?4,"P/U City: ",$P (IB("U5"), U,4),?41," D/O City: ",$P(IB("U 6"),U,4) ; W !,?4,"P/ U State/Zi p: " W:$P( IB("U5"),U ,5)'="" $P ($G(^DIC(5 ,$P(IB("U5 "),U,5),0) ),U,2) ;W: $P(IB("U5" ),U,6)]"" "/"_$P(IB( "U5"),U,6) ;W ?41,"D /O State/Z ip: " W:$P (IB("U6"), U,5)'="" $ P($G(^DIC( 5,$P(IB("U 6"),U,5),0 )),U,2) ;W :$P(IB("U6 "),U,6)]"" "/"_$P(IB ("U6"),U,6 ) ;;W !,?4 ,"P/U Coun try/SubDiv : ",$P(IB( "U5"),U),? 41,"D/O Co untry/SubD iv: " S Z= 3 X IBWW W " Surgica l Codes fo r Anesthes ia Claims" W !,?4,"P rimary Cod e: " W:$P( IB("U4"),U ,7)'="" $P ($G(^ICPT( $P(IB("U4" ),U,7),0)) ,U) W ?41, "Secondary Code: " W :$P(IB("U4 "),U,8)'=" " $P($G(^I CPT($P(IB( "U4"),U,8) ,0)),U) S Z=4 X IBWW W " Paper work Attac hment Info rmation" W !,?4,"Rep ort Type: " W:$P(IB( "U8"),U,2) '="" $P($G (^IBE(353. 3,$P(IB("U 8"),U,2),0 )),U) W ?4 1,"Transmi ssion Meth od: ",$P(I B("U8"),U, 3) W !,?4, "Attachmen t Control #: ",$P(IB ("U8"),U) S Z=5 X IB WW W " Dis ability St art Date: ",$$FMTE^X LFDT($P(IB ("U4"),U,4 )),?41,"Di sability E nd Date: " ,$$FMTE^XL FDT($P(IB( "U4"),U,5) ) S Z=6 X IBWW W " A ssumed Car e Date: ", $$FMTE^XLF DT($P(IB(" U4"),U,13) ),?41,"Rel inquished Care Date: ",$$FMTE^ XLFDT($P(I B("U4"),U, 14)) ; End IB*2.0*44 7 BI ; ;/ Beginning of IB*2.0* 488 - code moved fro m IBCSC10H (vd) S Z= 7 X IBWW W " Special Program: " I $P(IB( "U2"),U,16 )'="" S IB Z=$$EXPAND ^IBTRE(399 ,238,$P(IB ("U2"),U,1 6)) W $S(I BZ'="":IBZ ,$$WNRBILL ^IBEFUNC(I BIFN):"31" ,1:"") S Z =8 X IBWW W " Homebo und: ",$$E XPAND^IBTR E(399,236, $P(IB("U2" ),U,14)) S Z=9 X IBW W W " Date Last Seen : ",$$EXPA ND^IBTRE(3 99,237,$P( IB("U2"),U ,15)) ;/ E nd of IB*2 .0*488 (vd )REV G ^IB CSCP ;JWS; IB*2.0*592 US1108 - DentalIBTE ETH ;Creat e array of teeth sta tus N TH K IBTEETH S IBTEETH=0 S IBTEETH (0)=+$P($G (^DGCR(399 ,IBIFN,"DE N1",0)),U, 4) S TH=0 F S TH=$O (^DGCR(399 ,IBIFN,"DE N1",TH)) Q :'TH S IB TEETH(TH)= $G(^DGCR(3 99,IBIFN," DEN1",TH,0 )) Q ;DENT AL ;Dental Informati on for For m Type 7(J 430D) S IB ("DEN")=$G (^DGCR(399 ,IBIFN,"DE N")) S Z=1 ,IBW=1 X I BWW W "Too th Status" D WRT:$D( IBTEETH) S Z=2,IBW=1 X IBWW W "Orthodont ic Informa tion" W !? 4,"Banding Date: " I $P(IB("DE N"),U)'="" W $$FMTE^ XLFDT($P(I B("DEN"),U ),2) W !?4 ,"Treatmen t Indicato r: ",$$GET 1^DIQ(399, IBIFN_",", 95,"E") W !?4,"Treat ment Month s Count: " ,$P(IB("DE N"),U,2) W !?4,"Trea tment Mont hs Remaini ng Count: ",$P(IB("D EN"),U,3) S Z=3,IBW= 1 X IBWW W "Dental P aperwork A ttachment" W !?4,"Re port Type: " I $P(IB ("U8"),U,2 )'="" W $$ GET1^DIQ(3 53.3,$P(IB ("U8"),U,2 )_",",.01) ," (",$E($ $GET1^DIQ( 353.3,$P(I B("U8"),U, 2)_",",1), 1,18),")" W ?41,"Att achment Co ntrol #: " ,$P(IB("U8 "),U) Q ;W RT ;write out teeth status on screen N I ,J S J=0 F I=1:1 S J =$O(IBTEET H(J)) Q:'J D I I>1 0 D MORE Q . W !?4," Tooth Numb er: ",$P(I BTEETH(J), U),?41,"St atus Code: ",$$GET1^ DIQ(399.09 6,J_","_IB IFN_",",.0 2) Q ;MORE ; W !?4," ***There a re more te eth status es associa ted with t his bill.* **" S I=0 Q ;end - J WS;IB*2.0* 592 US1108 - Dental ;IBCSC8 | |
| 3283 | ||
| 3284 | IB,PATIENT MRA CM XX-XX-XXXX BILL#: K101XXX - Outpat/J43 0D SCREEN <8> | |
| 3285 | ========== ========== ========== ========== ========== ========== ========== ========== | |
| 3286 | DENTAL - C LAIM INFOR MATION | |
| 3287 | [1] Tooth Status Lo op may rep eat 35 tim es | |
| 3288 | Tooth Number:Sta tus Code:? ? | |
| 3289 | ||
| 3290 | This cod e indicate s whether a tooth wi ll be extr acted or i s missing. | |
| 3291 | ||
| 3292 | Select f rom: | |
| 3293 | E To Be Extract ed | |
| 3294 | M Mis sing | |
| 3295 | ||
| 3296 | [2] Orthod ontic Info rmation | |
| 3297 | Bandin g Date: | |
| 3298 | Treatm ent Indica tor: | |
| 3299 | Treatm ent Months Count: | |
| 3300 | Treatm ent Months Remaining Count: | |
| 3301 | ||
| 3302 | [3] Dental Paperwork Attachmen t Paperwor k | |
| 3303 | Report Type: ?? Transmiss ion Method : | |
| 3304 | Attach ment Contr ol #: | |
| 3305 | ||
| 3306 | ||
| 3307 | <RET> to C ONTINUE, 1 -3 to EDIT , '^N' for screen N, or '^' to QUIT:3 | |
| 3308 | ||
| 3309 | Report Typ e: ?? | |
| 3310 | Th is is a Re port Type to describ e the type of docume ntation th at | |
| 3311 | wi ll provide additiona l informat ion for th is claim. This | |
| 3312 | ap plies to t he entire claim. | |
| 3313 | ||
| 3314 | ||
| 3315 | Choose from: Dif ferent cod e set than regular c laims | |
| 3316 | B4 Referra l Form | |
| 3317 | DA Dental Models | |
| 3318 | DG Diagnos tic Report | |
| 3319 | EB EOB (CO B or Medic are Second ary Payor) | |
| 3320 | OZ Support data for Claim | |
| 3321 | P6 Periodo ntal Chart s | |
| 3322 | RB Radiolo gy Films | |
| 3323 | RR Radiolo gy Reports | |
| 3324 | ||
| 3325 | ||
| 3326 | Report Typ e: DA | |
| 3327 | Transmissi on Method: | |
| 3328 | Attachment Control # : | |
| 3329 | ||
| 3330 | Routines | |
| 3331 | Activities | |
| 3332 | Routine Na me | |
| 3333 | IBCSC9 | |
| 3334 | Enhancemen t Category | |
| 3335 | New | |
| 3336 | Modify | |
| 3337 | Delete | |
| 3338 | No Change | |
| 3339 | RTM | |
| 3340 | ||
| 3341 | Related Op tions | |
| 3342 | None | |
| 3343 | Related Ro utines | |
| 3344 | Routines “ Called By” | |
| 3345 | Routines “ Called” | |
| 3346 | ||
| 3347 | ||
| 3348 | ||
| 3349 | ||
| 3350 | Data Dicti onary (DD) Reference s | |
| 3351 | ||
| 3352 | Related Pr otocols | |
| 3353 | None | |
| 3354 | Related In tegration Control Re gistration s (ICRs) | |
| 3355 | None | |
| 3356 | Data Passi ng | |
| 3357 | Input | |
| 3358 | Output Re ference | |
| 3359 | Both | |
| 3360 | Global Re ference | |
| 3361 | Local | |
| 3362 | Input Attr ibute Name and Defin ition | |
| 3363 | Name: | |
| 3364 | Definition : | |
| 3365 | Output Att ribute Nam e and Defi nition | |
| 3366 | Name: | |
| 3367 | Definition : | |
| 3368 | Current Lo gic | |
| 3369 | IBCSC9 ;AL B/BI - MCC R SCREEN 9 (AMBULANC E INFO) ;1 1 MAY 2011 10:20 ;;2 .0;INTEGRA TED BILLIN G;**52,51, 447,473**; 11-MAY-201 1;Build 29 ;;Per VHA Directive 2004-038, this rout ine should not be mo dified. ;E N ; Main E ntry Point N IBACI,I BACIX,IB,I BT D ^IBCS CU S IBT=$ P($G(^DGCR (399,IBIFN ,0)),U,19) S IBSR=9, IBSR1="",I BV1=$S(IBT =3:"11",IB V:"11",1:" 00") S IB( "U")=$G(^D GCR(399,IB IFN,"U")) S IB("U1") =$G(^DGCR( 399,IBIFN, "U1")) S I B("U4")=$G (^DGCR(399 ,IBIFN,"U4 ")) S IB(" U5")=$G(^D GCR(399,IB IFN,"U5")) S IB("U6" )=$G(^DGCR (399,IBIFN ,"U6")) S IB("U7")=$ G(^DGCR(39 9,IBIFN,"U 7")) S IB( "U8")=$G(^ DGCR(399,I BIFN,"U8") ) M IB("U9 ")=^DGCR(3 99,IBIFN," U9") D H^I BCSCU S Z= 1,IBW=1 X IBWW W " A mbulance T ransport D ata" W !,? 41,"D/O Lo cation: ", $P(IB("U6" ),U) W !,? 4,"P/U Add ress1: ",$ P(IB("U5") ,U,2),?41, "D/O Addre ss1: ",$P( IB("U6"),U ,2) W !,?4 ,"P/U Addr ess2: ",$P (IB("U5"), U,3),?41," D/O Addres s2: ",$P(I B("U6"),U, 3) W !,?4, "P/U City: ",$P(IB(" U5"),U,4), ?41,"D/O C ity: ",$P( IB("U6"),U ,4) W !,?4 ,"P/U Stat e/Zip: " W :$P(IB("U5 "),U,5)'=" " $P($G(^D IC(5,$P(IB ("U5"),U,5 ),0)),U,2) W:$P(IB(" U5"),U,6)] "" "/"_$P( IB("U5"),U ,6) W ?41, "D/O State /Zip: " W: $P(IB("U6" ),U,5)'="" $P($G(^DI C(5,$P(IB( "U6"),U,5) ,0)),U,2) W:$P(IB("U 6"),U,6)]" " "/"_$P(I B("U6"),U, 6) W !,?4, "Patient W eight: ",$ P(IB("U7") ,U,1),?41, "Transport Distance: ",$P(IB(" U7"),U,3) W !,?4,"Tr ansport Re ason: " I $P(IB("U7" ),U,2)'="" D IBWP($$ GET1^DIQ(3 53.4,$P(IB ("U7"),U,2 )_",",.02) ,22,55) W !,?4,"R/T Purpose: " D IBWP($P (IB("U7"), U,4),17,60 ) W !,?4," Stretcher Purpose: " D IBWP($P (IB("U7"), U,5),23,54 ) S Z=2,IB W=2 X IBWW W " Ambul ance Certi fication D ata" W !,? 4,"Conditi on Indicat or:" S IBA CIX=0 F S IBACIX=$O (IB("U9",I BACIX)) Q: +IBACIX=0 D . S IBAC I=IB("U9", IBACIX,0) . W ?25,$$ GET1^DIQ(3 53.5,IBACI _",",.01), " - ",$$GE T1^DIQ(353 .5,IBACI_" ,",.02),! K IB("U9") W ! G ^IB CSCP Q ;IB WP(IBX,IBL M,IBRM) ; K ^UTILITY ($J,"W") N X,Y,DIWF, DIWL,DIWR S X=IBX S DIWL=1,DIW R=IBRM,DIW F="" D ^DI WP I $D(^U TILITY($J, "W")) S Y= 0 F S Y=$ O(^UTILITY ($J,"W",1, Y)) Q:'Y W:Y>1 !,?( IBLM) W $G (^UTILITY( $J,"W",1,Y ,0)) K ^UT ILITY($J," W") Q ;SCR EEN1(DA1) ; N A,RESP ONSE S RES PONSE=0 I +$P($G(^DG CR(399,DA1 ,"U9",0)), U,4)<5 S R ESPONSE=1 Q RESPONSE S A(1,"F" )="!?35",A (1)="Maxim um of 5 Co ndition In dicators a llowed" D EN^DDIOL(. A) Q RESPO NSE ;IBCSC 9 | |
| 3370 | Modified L ogic (Chan ges are in bold) | |
| 3371 | IBCSC9 ;AL B/BI - MCC R SCREEN 9 (AMBULANC E INFO) ;1 1 MAY 2011 10:20 ;;2 .0;INTEGRA TED BILLIN G;**52,51, 447,473,57 7,592**;11 -MAY-2011; Build 1 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. ;EN ; Main Entr y Point ;J WS;IB*2.0* 592;skip s creen 9 fo r Dental I $$FT^IBCE F(IBIFN)=7 G EN^IBCS C10 N IBAC I,IBACIX,I B,IBT D ^I BCSCU S IB T=$P($G(^D GCR(399,IB IFN,0)),U, 19) S IBSR =9,IBSR1=" ",IBV1=$S( IBT=3:"11" ,IBV:"11", 1:"00") S IB("U")=$G (^DGCR(399 ,IBIFN,"U" )) S IB("U 1")=$G(^DG CR(399,IBI FN,"U1")) S IB("U4") =$G(^DGCR( 399,IBIFN, "U4")) S I B("U5")=$G (^DGCR(399 ,IBIFN,"U5 ")) S IB(" U6")=$G(^D GCR(399,IB IFN,"U6")) S IB("U7" )=$G(^DGCR (399,IBIFN ,"U7")) S IB("U8")=$ G(^DGCR(39 9,IBIFN,"U 8")) M IB( "U9")=^DGC R(399,IBIF N,"U9") D H^IBCSCU S Z=1,IBW=1 X IBWW W " Ambulanc e Transpor t Data" ;J RA IB*2.0* 577 Rearra nge Field order so t hat expand ed 55 char PU/DO Add ress1 & PU /DO Addres s2 can be displayed ;W !,?41," D/O Locati on: ",$P(I B("U6"),U) ;JRA ';' IB*2.0*577 ;W !,?4," P/U Addres s1: ",$P(I B("U5"),U, 2),?41,"D/ O Address1 : ",$P(IB( "U6"),U,2) ;JRA IB*2 .0*577 ';' ;W !,?4," P/U Addres s2: ",$P(I B("U5"),U, 3),?41,"D/ O Address2 : ",$P(IB( "U6"),U,3) ;JRA IB*2 .0*577 ';' ;W !,?4," P/U City: ",$P(IB("U 5"),U,4),? 41,"D/O Ci ty: ",$P(I B("U6"),U, 4) ;JRA IB *2.0*577 ' ;' ;W !,?4 ,"P/U Stat e/Zip: " W :$P(IB("U5 "),U,5)'=" " $P($G(^D IC(5,$P(IB ("U5"),U,5 ),0)),U,2) ;JRA IB*2 .0*577 ';' ;W:$P(IB( "U5"),U,6) ]"" "/"_$P (IB("U5"), U,6) ;JRA IB*2.0*577 ';' ;W ?4 1,"D/O Sta te/Zip: " W:$P(IB("U 6"),U,5)'= "" $P($G(^ DIC(5,$P(I B("U6"),U, 5),0)),U,2 ) ;JRA IB* 2.0*577 '; ' W !,?4," P/U Addres s1: ",$P(I B("U5"),U, 2) ;JRA IB *2.0*577 W !,?4,"P/U Address2: ",$P(IB(" U5"),U,3) ;JRA IB*2. 0*577 W !, ?4,"P/U Ci ty: ",$P(I B("U5"),U, 4) ;JRA IB *2.0*577 W ?41,"P/U State/Zip: " W:$P(IB ("U5"),U,5 )'="" $P($ G(^DIC(5,$ P(IB("U5") ,U,5),0)), U,2) ;JRA IB*2.0*577 W:$P(IB(" U5"),U,6)] "" "/"_$P( IB("U5"),U ,6) ;JRA I B*2.0*577 W !,?4,"D/ O Location : ",$P(IB( "U6"),U) ; JRA IB*2.0 *577 W !,? 4,"D/O Add ress1: ",$ P(IB("U6") ,U,2) ;JRA IB*2.0*57 7 W !,?4," D/O Addres s2: ",$P(I B("U6"),U, 3) ;JRA IB *2.0*577 W !,?4,"D/O City: ",$ P(IB("U6") ,U,4) ;JRA IB*2.0*57 7 W ?41,"D /O State/Z ip: " W:$P (IB("U6"), U,5)'="" $ P($G(^DIC( 5,$P(IB("U 6"),U,5),0 )),U,2) ;J RA IB*2.0* 577 W:$P(I B("U6"),U, 6)]"" "/"_ $P(IB("U6" ),U,6) W ! ,?4,"Patie nt Weight: ",$P(IB(" U7"),U,1), ?41,"Trans port Dista nce: ",$P( IB("U7"),U ,3) W !,?4 ,"Transpor t Reason: " I $P(IB( "U7"),U,2) '="" D IBW P($$GET1^D IQ(353.4,$ P(IB("U7") ,U,2)_",", .02),22,55 ) W !,?4," R/T Purpos e: " D IBW P($P(IB("U 7"),U,4),1 7,60) W !, ?4,"Stretc her Purpos e: " D IBW P($P(IB("U 7"),U,5),2 3,54) S Z= 2,IBW=2 X IBWW W " A mbulance C ertificati on Data" W !,?4,"Con dition Ind icator:" S IBACIX=0 F S IBACI X=$O(IB("U 9",IBACIX) ) Q:+IBACI X=0 D . S IBACI=IB(" U9",IBACIX ,0) . W ?2 5,$$GET1^D IQ(353.5,I BACI_",",. 01)," - ", $$GET1^DIQ (353.5,IBA CI_",",.02 ),! K IB(" U9") W ! G ^IBCSCP Q ;IBWP(IBX ,IBLM,IBRM ) ; K ^UTI LITY($J,"W ") N X,Y,D IWF,DIWL,D IWR S X=IB X S DIWL=1 ,DIWR=IBRM ,DIWF="" D ^DIWP I $ D(^UTILITY ($J,"W")) S Y=0 F S Y=$O(^UTI LITY($J,"W ",1,Y)) Q: 'Y W:Y>1 !,?(IBLM) W $G(^UTIL ITY($J,"W" ,1,Y,0)) K ^UTILITY( $J,"W") Q ;SCREEN1(D A1) ; N A, RESPONSE S RESPONSE= 0 I +$P($G (^DGCR(399 ,DA1,"U9", 0)),U,4)<5 S RESPONS E=1 Q RESP ONSE S A(1 ,"F")="!?3 5",A(1)="M aximum of 5 Conditio n Indicato rs allowed " D EN^DDI OL(.A) Q R ESPONSE ;I BCSC9 | |
| 3372 | ||
| 3373 | ||
| 3374 | Routines | |
| 3375 | Activities | |
| 3376 | Routine Na me | |
| 3377 | IBCSCE | |
| 3378 | Enhancemen t Category | |
| 3379 | New | |
| 3380 | Modify | |
| 3381 | Delete | |
| 3382 | No Change | |
| 3383 | RTM | |
| 3384 | ||
| 3385 | Related Op tions | |
| 3386 | None | |
| 3387 | Related Ro utines | |
| 3388 | Routines “ Called By” | |
| 3389 | Routines “ Called” | |
| 3390 | ||
| 3391 | ||
| 3392 | ||
| 3393 | ||
| 3394 | Data Dicti onary (DD) Reference s | |
| 3395 | ||
| 3396 | Related Pr otocols | |
| 3397 | None | |
| 3398 | Related In tegration Control Re gistration s (ICRs) | |
| 3399 | None | |
| 3400 | Data Passi ng | |
| 3401 | Input | |
| 3402 | Output Re ference | |
| 3403 | Both | |
| 3404 | Global Re ference | |
| 3405 | Local | |
| 3406 | Input Attr ibute Name and Defin ition | |
| 3407 | Name: | |
| 3408 | Definition : | |
| 3409 | Output Att ribute Nam e and Defi nition | |
| 3410 | Name: | |
| 3411 | Definition : | |
| 3412 | Current Lo gic | |
| 3413 | IBCSCE ;AL B/MRL,MJB - MCCR SCR EEN EDITS ;07 JUN 88 14:35 ;;2 .0;INTEGRA TED BILLIN G;**52,80, 91,106,51, 137,236,24 5,287,349, 371,400,43 2,447,547* *;21-MAR-9 4;Build 11 9 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ; ;MAP TO DGCRSC E ; always do proced ures last because th ey are edi ted upon r eturn to s creen rout ine I IBDR 20["54," S IBDR20=$P (IBDR20,"5 4,",1)_$P( IBDR20,"54 ,",2)_"54, " I IBDR20 ["44," S I BDR20=$P(I BDR20,"44, ",1)_$P(IB DR20,"44," ,2)_"44,"L OOP N IBDR LP,IBDRL S IBDRLP=IB DR20 F IBD RL=1:1 S I BDR20=$P(I BDRLP,",", IBDRL) Q:I BDR20="" D EDIT QED IT N IBQUE RY I (IBDR 20["31") D MCCR^IBCN SP2 G ENQ I (IBDR20[ "43")!(IBD R20["52") D ^IBCSC4D G ENQ I ( IBDR20["74 ")!(IBDR20 ["53") K D R N I D ^I BCOPV S (D A,Y)=IBIFN G TMPL I (IBDR20["5 4"),$P($G( ^IBE(350.9 ,1,1)),"^" ,17) K DR N I D EN1^ IBCCPT(.IB QUERY) D C LOSE^IBSDU (.IBQUERY) G TMPL ; I (IBDR20[ "55") D ^I BCSC5A G E NQ I (IBDR 20["45")!( IBDR20["56 ") D ^IBCS C5B G ENQ I (IBDR20[ "66")!(IBD R20["76") D EDIT^IBC RBE(IBIFN) D ASKCMB^ IBCU65(IBI FN) G ENQ I IBDR20[" 102",$$FT^ IBCEF(IBIF N)=3 D EN^ IBCSC10B G ENQ ; U B-04 patie nt reason for visit (screen 10 , section 2) I IBDR2 0["105",$$ FT^IBCEF(I BIFN)=2 D ^IBCSC10A G ENQ ; cms-1500 chiroprac tic data ( screen 10, section 5 ) ; ;WCJ;I B*2.0*547 ;I IBDR20[ "107",$$FT ^IBCEF(IBI FN)=3 D EN 1^IBCEP6 G ENQ ; UB- 04 provide r ID maint enance (sc reen 10, s ection 7) I IBDR20[" 108",$$FT^ IBCEF(IBIF N)=3 D EN1 ^IBCEP6 G ENQ ; UB -04 provid er ID main tenance (s creen 10, section 8) ; ;WCJ;IB *2.0*547 ; I IBDR20[" 109",$$FT^ IBCEF(IBIF N)=2 D EN1 ^IBCEP6 G ENQ ; cms- 1500 provi der ID mai ntenance ( screen 10, section 9 ) I IBDR20 ["110",$$F T^IBCEF(IB IFN)=2 D E N1^IBCEP6 G ENQ ; cms-1500 p rovider ID maintenan ce (screen 10, secti on 10); no t a mispri nt it is s creen *10 +section w hich is 11 0 ; F Q=1: 1:9 I IBDR 20[("11"_Q ) D EDIT^I BCSC11 G E NQ ; I B*2.0*447 BITMPL N I BFLIAE S I BFLIAE=1 ; to invoke EN^DGREGAE D from [IB SCREEN1] S DR="[IB SCREEN"_IB SR_IBSR1_" ]",(DA,Y)= IBIFN,DIE= "^DGCR(399 ," D ^DIE K DIE,DR,D LAYGO I (I BDR20["61" )!(IBDR20[ "71") I +$ G(DGRVRCAL ) D PROC^I BCU7A(IBIF N,1) ;ENQ ; K DIE,DR ,IBDR1,IBD R20,DGDRD, DGDRS,DGDR S1,DA Q ; ;called by screen 3 (input tem plate)UPDT F IBDD=0: 0 S IBDD=$ O(^DPT(DFN ,.312,IBDD )) Q:IBDD' >0 S IBI1= ^DPT(DFN,. 312,IBDD,0 ) I $D(^DI C(36,+IBI1 ,0)),$P(^( 0),"^",2)' ="N" S IBD D(+IBI1)=I BI1 F IBAI C=0:0 S IB AIC=$O(^DG CR(399,IBI FN,"AIC",I BAIC)) Q:I BAIC'>0 I $D(IBDD(IB AIC)) F IB I1="I1","I 2","I3" I $D(^DGCR(3 99,IBIFN,I BI1)),+^(I BI1)=IBAIC ,^(IBI1)'= IBDD(IBAIC ) S ^DGCR( 399,IBIFN, IBI1)=IBDD (IBAIC) K IBAIC,IBDD ,IBI1 Q ; ;Edit pati ent's addr ess using DGREGAED A PIEDADDR(I BDFN) ; I $G(IBFLIAE )'=1!(IBDF N=0) Q 0 N IBFL S IB FL(1)=1 N X,Y,DIE,DA ,DR,DIDEL, DIW,DIEDA, DG,DICR D EN^DGREGAE D(IBDFN,.I BFL) Q 1 ; IBCSCE | |
| 3414 | Modified L ogic (Chan ges are in bold) | |
| 3415 | IBCSCE ;AL B/MRL,MJB - MCCR SCR EEN EDITS ;07 JUN 88 14:35 ;;2 .0;INTEGRA TED BILLIN G;**52,80, 91,106,51, 137,236,24 5,287,349, 371,400,43 2,447,547, 592**;21-M AR-94;Buil d 119 ;;Pe r VA Direc tive 6402, this rout ine should not be mo dified. ; ;MAP TO DG CRSCE ; al ways do pr ocedures l ast becaus e they are edited up on return to screen routine I IBDR20["54 ," S IBDR2 0=$P(IBDR2 0,"54,",1) _$P(IBDR20 ,"54,",2)_ "54," I IB DR20["44," S IBDR20= $P(IBDR20, "44,",1)_$ P(IBDR20," 44,",2)_"4 4,"LOOP N IBDRLP,IBD RL S IBDRL P=IBDR20 F IBDRL=1:1 S IBDR20= $P(IBDRLP, ",",IBDRL) Q:IBDR20= "" D EDIT QEDIT N I BQUERY I ( IBDR20["31 ") D MCCR^ IBCNSP2 G ENQ I (IBD R20["43")! (IBDR20["5 2") D ^IBC SC4D G ENQ I (IBDR20 ["74")!(IB DR20["53") K DR N I D ^IBCOPV S (DA,Y)=I BIFN G TMP L I (IBDR2 0["54"),$P ($G(^IBE(3 50.9,1,1)) ,"^",17) K DR N I D EN1^IBCCPT (.IBQUERY) D CLOSE^I BSDU(.IBQU ERY) G TMP L ; I (IBD R20["55") D ^IBCSC5A G ENQ I ( IBDR20["45 ")!(IBDR20 ["56") D ^ IBCSC5B G ENQ I (IBD R20["66")! (IBDR20["7 6") D EDIT ^IBCRBE(IB IFN) D ASK CMB^IBCU65 (IBIFN) G ENQ I IBDR 20["102",$ $FT^IBCEF( IBIFN)=3 D EN^IBCSC1 0B G ENQ ; UB-04 p atient rea son for vi sit (scree n 10, sect ion 2) I I BDR20["105 ",$$FT^IBC EF(IBIFN)= 2 D ^IBCSC 10A G ENQ ; cms- 1500 chiro practic da ta (screen 10, secti on 5) ; ;W CJ;IB*2.0* 547 ;I IBD R20["107", $$FT^IBCEF (IBIFN)=3 D EN1^IBCE P6 G ENQ ; UB-04 pro vider ID m aintenance (screen 1 0, section 7) I IBDR 20["108",$ $FT^IBCEF( IBIFN)=3 D EN1^IBCEP 6 G ENQ ; UB-04 pr ovider ID maintenanc e (screen 10, sectio n 8) ; ;WC J;IB*2.0*5 47 ;I IBDR 20["109",$ $FT^IBCEF( IBIFN)=2 D EN1^IBCEP 6 G ENQ ; cms-1500 p rovider ID maintenan ce (screen 10, secti on 9) ;JWS ;IB*2.0*59 2 US1108 - Dental fo rm 7 I IBD R20["110", $$FT^IBCEF (IBIFN)=2! ($$FT^IBCE F(IBIFN)=7 ) D EN1^IB CEP6 G ENQ ; cms-1 500 provid er ID main tenance (s creen 10, section 10 ); not a m isprint it is screen *10 +sect ion which is 110 ; F Q=1:1:9 I IBDR20[(" 11"_Q) D E DIT^IBCSC1 1 G ENQ ; IB*2.0 *447 BITMP L N IBFLIA E S IBFLIA E=1 ;to in voke EN^DG REGAED fro m [IB SCRE EN1] S DR= "[IB SCREE N"_IBSR_IB SR1_"]",(D A,Y)=IBIFN ,DIE="^DGC R(399," D ^DIE K DIE ,DR,DLAYGO I (IBDR20 ["61")!(IB DR20["71") I +$G(DGR VRCAL) D P ROC^IBCU7A (IBIFN,1) ;ENQ ; K D IE,DR,IBDR 1,IBDR20,D GDRD,DGDRS ,DGDRS1,DA Q ; ;call ed by scre en 3 (inpu t template )UPDT F IB DD=0:0 S I BDD=$O(^DP T(DFN,.312 ,IBDD)) Q: IBDD'>0 S IBI1=^DPT( DFN,.312,I BDD,0) I $ D(^DIC(36, +IBI1,0)), $P(^(0),"^ ",2)'="N" S IBDD(+IB I1)=IBI1 F IBAIC=0:0 S IBAIC=$ O(^DGCR(39 9,IBIFN,"A IC",IBAIC) ) Q:IBAIC' >0 I $D(IB DD(IBAIC)) F IBI1="I 1","I2","I 3" I $D(^D GCR(399,IB IFN,IBI1)) ,+^(IBI1)= IBAIC,^(IB I1)'=IBDD( IBAIC) S ^ DGCR(399,I BIFN,IBI1) =IBDD(IBAI C) K IBAIC ,IBDD,IBI1 Q ; ;Edit patient's address u sing DGREG AED APIEDA DDR(IBDFN) ; I $G(IB FLIAE)'=1! (IBDFN=0) Q 0 N IBFL S IBFL(1) =1 N X,Y,D IE,DA,DR,D IDEL,DIW,D IEDA,DG,DI CR D EN^DG REGAED(IBD FN,.IBFL) Q 1 ;IBCSC E | |
| 3416 | ||
| 3417 | ||
| 3418 | Routines | |
| 3419 | Activities | |
| 3420 | Routine Na me | |
| 3421 | IBCSCU | |
| 3422 | Enhancemen t Category | |
| 3423 | New | |
| 3424 | Modify | |
| 3425 | Delete | |
| 3426 | No Change | |
| 3427 | RTM | |
| 3428 | ||
| 3429 | Related Op tions | |
| 3430 | None | |
| 3431 | Related Ro utines | |
| 3432 | Routines “ Called By” | |
| 3433 | Routines “ Called” | |
| 3434 | ||
| 3435 | ||
| 3436 | ||
| 3437 | ||
| 3438 | Data Dicti onary (DD) Reference s | |
| 3439 | ||
| 3440 | Related Pr otocols | |
| 3441 | None | |
| 3442 | Related In tegration Control Re gistration s (ICRs) | |
| 3443 | None | |
| 3444 | Data Passi ng | |
| 3445 | Input | |
| 3446 | Output Re ference | |
| 3447 | Both | |
| 3448 | Global Re ference | |
| 3449 | Local | |
| 3450 | Input Attr ibute Name and Defin ition | |
| 3451 | Name: | |
| 3452 | Definition : | |
| 3453 | Output Att ribute Nam e and Defi nition | |
| 3454 | Name: | |
| 3455 | Definition : | |
| 3456 | Current Lo gic | |
| 3457 | IBCSCU ;AL B/MJB - MC CR SCREEN UTILITY RO UTINE ;27 MAY 88 11: 09 ;;2.0;I NTEGRATED BILLING;** 52,51,348, 432,447**; 21-MAR-94; Build 80 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ; ;M AP TO DGCR SCU ; S IB W=1,IBU="U NSPECIFIED ",IBUN=IBU _" [NOT RE QUIRED]",I BV=$S($D(I BV):IBV,1: 1) D HOME^ %ZIS ;S IB WW1="X ""F Z2=1:1:(Z 1-$L(Z)) S Z=Z_"""" """""" W Z Q" S (IBV O,IBVI)="" I $S('$D( IOST(0)):1 ,'$D(^DG(4 3,1,0)):1, '$P(^DG(43 ,1,0),"^", 36):1,$D(^ DG(43,1,"T ERM",IOST( 0))):1,1:0 ) G M ; I $D(IOST(0) ) S X="IOI NHI;IOINLO W;IOINORM" D ENDR^%Z ISS I $L(I OINHI),$L( IOINLOW) S IBVI=IOIN HI,IBVO=$S (IOINORM]" ":IOINORM, 1:IBINLOW) D KILL^%Z ISS ;I $D( ^%ZIS(2,IO ST(0),7)) S I=^(7) I $L($P(I," ^",1)),$L( $P(I,"^",2 )) S IBVI= $P(I,"^",1 ),IBVO=$S( $P(I,"^",3 )]"":$P(I, "^",3),1:$ P(I,"^",2) ) ;M ;I $L (IBVI_IBVO )>4 S X=80 X ^%ZOSF( "RM") S IB WW="W:IBW ! S Z=$S(I BV:""<""_Z _"">"",$E( IBV1,Z):"" <""_Z_"">" ",1:""[""_ Z_""]"") W :$E(Z)=""[ "" IBVI,Z, IBVO W:$E( Z)'=""["" Z Q" ;S IB WW="W:IBW ! S Z=$S(I OST=""C-QU ME""&($L(I BVI)'=2):Z ,IBV:""<"" _Z_"">"",$ E(IBV1,Z): ""<""_Z_"" >"",1:""[" "_Z_""]"") W:$E(Z)=" "["" @IBVI ,Z,@IBVO W :$E(Z)'="" ["" Z Q" I $D(IBPAR) S IBV=0,I BVV="00000 " Q S IBBN O=$P(^DGCR (399,IBIFN ,0),"^",1) S IBVV=$S ('$$INPAT^ IBCEF(IBIF N):"000101 00001",1:" 0000101000 1"),X="632 66556" ; IB*2.0 *447 BI I $P($G(^IBE (353,+$P($ G(^DGCR(39 9,IBIFN,0) ),U,19),2) ),U,9)'="" ,$S($D(^DG CR(399,IBI FN,"I1")): 1,1:$P($G( ^DGCR(399, IBIFN,"M") ),U,11)) S $E(IBVV,1 1)="0" Q ; H ;Screen Header S L ="",$P(L," =",81)="" I $D(IBH(" HELP")) S X="HELP SC REEN" W @I OF,!?(40-( $L(X)\2)), IBVI,X,IBV O,!,L G HQ ; IB*2.0* 447 BI Sta rt S X=$P( "DEMOGRAPH IC^EMPLOYM ENT^PAYER^ EVENT - IN PATIENT^EV ENT - OUTP ATIENT^BIL LING - GEN ERAL^BILLI NG - GENER AL^BILLING - CLAIM^A MBULANCE^B ILLING - S PECIFIC^LO CALLY DEFI NED","^",I BSR)_" INF ORMATION", X1="SCREEN <"_+IBSR_ ">" ; IB*2 .0*447 BI End N IB0, IBT S IB0= $G(^DGCR(3 99,IBIFN,0 )),IBT=$P( IB0,U,19), DGINPT=$S( $$INPAT^IB CEF(IBIFN) :"Inpat",1 :"Outpat") ; W @IOF ; clear s creen W !, VADM(1) ; name W " " ,$P(VADM(2 ),"^",2) ; ssn W " B ILL#: ",IB BNO_" - "_ DGINPT,"/" ; claim# - type I I BT=2 W "15 00" ; for m type 2 I IBT=3 W $ TR($P($G(^ IBE(353,3, 0)),U,1)," -") ; form type 3 W ?(80-$L(X1 )),X1 ; sc reen# W !, L ; sepa rator line W !?(40-( $L(X)\2)), IBVI,X,IBV O ; screen de scriptionH Q ; K L,DG INPT Q ;A ;Format Ad dress(es) N Y F I=IB A1:1:IBA1+ 2 I $P(IB( IBAD),U,I) ]"" S IBA( IBA2)=$P(I B(IBAD),U, I),IBA2=IB A2+2 I IBA 2=1 S IBA( 1)="STREET ADDRESS U NKNOWN",IB A2=IBA2+2 S J=$S($D( ^DIC(5,+$P (IB(IBAD), U,IBA1+4), 0)):$P(^(0 ),U,2),1:" "),J(1)=$P (IB(IBAD), U,IBA1+3), J(2)=$P(IB (IBAD),U,I BA1+11),IB A(IBA2)=$S (J(1)]""&( J]""):J(1) _", "_J,J( 1)]"":J(1) ,J]"":J,1: "CITY/STAT E UNKNOWN" ) S Y=$S(I BAD=.11!(I BAD=.121): $P(IB(IBAD ),U,IBA1+1 1),IBAD=.2 5:$P($G(^D PT(+$G(DFN ),.22)),U, 6),IBAD=.3 11:$P($G(^ DPT(+$G(DF N),.22)),U ,5),1:"") D ZIPOUT^V AFADDR S I BA(IBA2)=I BA(IBA2)_" "_Y F I=0 :0 S I=$O( IBA(I)) Q: I="" S IB A(I)=$E(IB A(I),1,25) K IBA1,I, J Q | |
| 3458 | Modified L ogic (Chan ges are in bold) | |
| 3459 | IBCSCU ;AL B/MJB - MC CR SCREEN UTILITY RO UTINE ;27 MAY 88 11: 09 ;;2.0;I NTEGRATED BILLING;** 52,51,348, 432,447,59 2**;21-MAR -94;Build 80 ;;Per V HA Directi ve 2004-03 8, this ro utine shou ld not be modified. ; ;MAP TO DGCRSCU ; S IBW=1,IB U="UNSPECI FIED",IBUN =IBU_" [NO T REQUIRED ]",IBV=$S( $D(IBV):IB V,1:1) D H OME^%ZIS ; S IBWW1="X ""F Z2=1: 1:(Z1-$L(Z )) S Z=Z_" """ """""" W Z Q" S (IBVO,IBVI )="" I $S( '$D(IOST(0 )):1,'$D(^ DG(43,1,0) ):1,'$P(^D G(43,1,0), "^",36):1, $D(^DG(43, 1,"TERM",I OST(0))):1 ,1:0) G M ; I $D(IOS T(0)) S X= "IOINHI;IO INLOW;IOIN ORM" D END R^%ZISS I $L(IOINHI) ,$L(IOINLO W) S IBVI= IOINHI,IBV O=$S(IOINO RM]"":IOIN ORM,1:IBIN LOW) D KIL L^%ZISS ;I $D(^%ZIS( 2,IOST(0), 7)) S I=^( 7) I $L($P (I,"^",1)) ,$L($P(I," ^",2)) S I BVI=$P(I," ^",1),IBVO =$S($P(I," ^",3)]"":$ P(I,"^",3) ,1:$P(I,"^ ",2)) ;M ; I $L(IBVI_ IBVO)>4 S X=80 X ^%Z OSF("RM") S IBWW="W: IBW ! S Z= $S(IBV:""< ""_Z_"">"" ,$E(IBV1,Z ):""<""_Z_ "">"",1:"" [""_Z_""]" ") W:$E(Z) =""["" IBV I,Z,IBVO W :$E(Z)'="" ["" Z Q" ; S IBWW="W: IBW ! S Z= $S(IOST="" C-QUME""&( $L(IBVI)'= 2):Z,IBV:" "<""_Z_""> "",$E(IBV1 ,Z):""<""_ Z_"">"",1: ""[""_Z_"" ]"") W:$E( Z)=""["" @ IBVI,Z,@IB VO W:$E(Z) '=""["" Z Q" I $D(IB PAR) S IBV =0,IBVV="0 0000" Q S IBBNO=$P(^ DGCR(399,I BIFN,0),"^ ",1) S IBV V=$S('$$IN PAT^IBCEF( IBIFN):"00 010100001" ,1:"000010 10001"),X= "63266556" ; IB *2.0*447 B I ;JWS;IB* 2.0*592;sk ip screen 9 for Dent al I $$FT^ IBCEF(IBIF N)=7 S IBV V="0001010 0101" I $P ($G(^IBE(3 53,+$P($G( ^DGCR(399, IBIFN,0)), U,19),2)), U,9)'="",$ S($D(^DGCR (399,IBIFN ,"I1")):1, 1:$P($G(^D GCR(399,IB IFN,"M")), U,11)) S $ E(IBVV,11) ="0" Q ;H ;Screen He ader S L=" ",$P(L,"=" ,81)="" I $D(IBH("HE LP")) S X= "HELP SCRE EN" W @IOF ,!?(40-($L (X)\2)),IB VI,X,IBVO, !,L G HQ ; IB*2.0*44 7 BI Start S X=$P("D EMOGRAPHIC ^EMPLOYMEN T^PAYER^EV ENT - INPA TIENT^EVEN T - OUTPAT IENT^BILLI NG - GENER AL^BILLING - GENERAL ^BILLING - CLAIM^AMB ULANCE^BIL LING - SPE CIFIC^LOCA LLY DEFINE D","^",IBS R)_" INFOR MATION",X1 ="SCREEN < "_+IBSR_"> " ;JWS;IB* 2.0*592; D ental I $$ FT^IBCEF(I BIFN)=7,IB SR=8 S X=" DENTAL - C LAIM INFOR MATION" ; IB*2.0*447 BI End N IB0,IBT S IB0=$G(^DG CR(399,IBI FN,0)),IBT =$P(IB0,U, 19),DGINPT =$S($$INPA T^IBCEF(IB IFN):"Inpa t",1:"Outp at") ; W @ IOF ; cle ar screen W !,VADM(1 ) ; name W " ",$P(VA DM(2),"^", 2) ; ssn W " BILL#: ",IBBNO_" - "_DGINPT ,"/" ; cla im# - type I IBT=2 W "1500" ; form type 2 I IBT=3 W $TR($P( $G(^IBE(35 3,3,0)),U, 1),"-") ; form type 3 ;JWS;IB* 2.0*592 US 1108 - Den tal form 7 I IBT=7 W $$GET1^DI Q(353,"7," ,.01) ; fo rm type 7 - dental W ?(80-$L(X 1)),X1 ; s creen# W ! ,L ; sep arator lin e W !?(40- ($L(X)\2)) ,IBVI,X,IB VO ; screen d escription HQ ; K L,D GINPT Q ;A ;Format A ddress(es) N Y F I=I BA1:1:IBA1 +2 I $P(IB (IBAD),U,I )]"" S IBA (IBA2)=$P( IB(IBAD),U ,I),IBA2=I BA2+2 I IB A2=1 S IBA (1)="STREE T ADDRESS UNKNOWN",I BA2=IBA2+2 S J=$S($D (^DIC(5,+$ P(IB(IBAD) ,U,IBA1+4) ,0)):$P(^( 0),U,2),1: ""),J(1)=$ P(IB(IBAD) ,U,IBA1+3) ,J(2)=$P(I B(IBAD),U, IBA1+11),I BA(IBA2)=$ S(J(1)]""& (J]""):J(1 )_", "_J,J (1)]"":J(1 ),J]"":J,1 :"CITY/STA TE UNKNOWN ") S Y=$S( IBAD=.11!( IBAD=.121) :$P(IB(IBA D),U,IBA1+ 11),IBAD=. 25:$P($G(^ DPT(+$G(DF N),.22)),U ,6),IBAD=. 311:$P($G( ^DPT(+$G(D FN),.22)), U,5),1:"") D ZIPOUT^ VAFADDR S IBA(IBA2)= IBA(IBA2)_ " "_Y F I= 0:0 S I=$O (IBA(I)) Q :I="" S I BA(I)=$E(I BA(I),1,25 ) K IBA1,I ,J Q | |
| 3460 | ||
| 3461 | ||
| 3462 | Routines | |
| 3463 | Activities | |
| 3464 | Routine Na me | |
| 3465 | IBCU7 | |
| 3466 | Enhancemen t Category | |
| 3467 | New | |
| 3468 | Modify | |
| 3469 | Delete | |
| 3470 | No Change | |
| 3471 | RTM | |
| 3472 | ||
| 3473 | Related Op tions | |
| 3474 | None | |
| 3475 | Related Ro utines | |
| 3476 | Routines “ Called By” | |
| 3477 | Routines “ Called” | |
| 3478 | ||
| 3479 | ||
| 3480 | ||
| 3481 | ||
| 3482 | Data Dicti onary (DD) Reference s | |
| 3483 | ||
| 3484 | Related Pr otocols | |
| 3485 | None | |
| 3486 | Related In tegration Control Re gistration s (ICRs) | |
| 3487 | None | |
| 3488 | Data Passi ng | |
| 3489 | Input | |
| 3490 | Output Re ference | |
| 3491 | Both | |
| 3492 | Global Re ference | |
| 3493 | Local | |
| 3494 | Input Attr ibute Name and Defin ition | |
| 3495 | Name: | |
| 3496 | Definition : | |
| 3497 | Output Att ribute Nam e and Defi nition | |
| 3498 | Name: | |
| 3499 | Definition : | |
| 3500 | Current Lo gic | |
| 3501 | IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT OF PROCEDU RE CODES ; 29-OCT-91 ;;2.0;INTE GRATED BIL LING;**62, 52,106,125 ,51,137,21 0,245,228, 260,348,37 1,432,447, 488,461,51 6,522**;21 -MAR-94;Bu ild 11 ;;P er VA Dire ctive 6402 , this rou tine shoul d not be m odified. ; ;MAP TO D GCRU7 ;CHK X ; -inter ception of input x f rom Additi onal Proce dure input G:X=" " C HKXQ I $$I NPAT^IBCEF (DA(1)),'$ P($G(^IBE( 350.9,1,1) ),"^",15), X'?1A1.2N D G CHKXQ . K X . D EN^DDIOL( "Site para m does not allow ent ry of non- PTF proced ures") ;Fi leman erro r here wil l be: The previous e rror occur red when p erforming an action specified in a Pre-l ookup tran sform (7.5 node). G: '$D(^UTILI TY($J,"IB" )) CHKXQ ; S M=($A($E (X,1))-64) ,S=+$E(X,2 ) Q:'$G(^U TILITY($J, "IB",M,S)) S X="`"_+ ^(S) S M=0 I X?1A1.2 N S N=$G(^ UTILITY($J ,"IB","B", X)) S M=+N ,S=+$P(N,U ,2),P=X S S=$G(^UTIL ITY($J,"IB ",M,S)) I +S S X="`" _+S I $P(N ,U,3)="N" S X=""""_X _"""" S $P (^UTILITY( $J,"IB","B ",P),U,3)= "Y" I +M,$ D(DGPROCDT ),DGPROCDT '=$P($G(^U TILITY($J, "IB",M,1)) ,"^",2) S DGPROCDT=$ P(^(1),"^" ,2) W !!," Procedure Date: " S Y=DGPROCDT X ^DD("DD ") W Y,!CH KXQ Q ;COD MUL ;Date oriented e ntry of pr ocedureDEL ASK I $D(I BZ20),IBZ2 0,IBZ20'=$ P(^DGCR(39 9,IBIFN,0) ,U,9) S %= 2 W !,"SIN CE THE PRO CEDURE COD ING METHOD HAS BEEN CHANGED, D O YOU WANT TO DELETE ALL",!,"P ROCEDURE C ODES IN TH IS BILL" I D YN^DIC N Q:%=-1 D :%=1 DELAD D I %Y?1." ?" W !!,"I f you answ er 'Yes', all proced ure codes will be DE LETED from this bill .",! G DEL ASK K %,%Y ,DA,IBZ20, DIK ;W !," Procedure Entry:" ;C ODDT I $D( IBIFN),$D( ^DGCR(399, IBIFN,0)), $P(^(0),U, 9) S DIC(" V")=$S($P( ^(0),U,9)= 9:"I +Y(0) =80.1",$P( ^(0),U,9)= 4!($P(^(0) ,U,9)=5):" I +Y(0)=81 ",1:"") I $P($G(^DGC R(399,IBIF N,0)),"^", 5)<3 S IBZ TYPE=1 I $ P($G(^UTIL ITY($J,"IB ",1,1)),"^ ",2) S DGP ROCDT=$P(^ (1),"^",2) D ASKCOD S X=$$PRCD IV^IBCU71( IBIFN) I + X W !!,$P( X,U,2),! N Z,Z0 S Z= $G(^DGCR(3 99,IBIFN," U")),Z0=$$ FMTE^XLFDT ($P(Z,U)," 2D")_"-"_$ $FMTE^XLFD T($P(Z,U,2 ),"2D") W !,"Select PROCEDURE DATE"_$S($ TR(Z0,"-") '="":" ("_ Z0_")",1:" ")_": " R X:DTIME G: '$T!("^"[X ) CODQ D:X ["?" CODHL P S IBEX=0 D ; Get procedure date . I X =" ",$D(DG PROCDT),DG PROCDT?7N S Y=DGPROC DT D D^DIQ W " (",Y, ")" Q . I X=" ",+$P( $G(^DGCR(3 99,IBIFN," OP",0)),"^ ",4) S (DG PROCDT,Y)= $O(^DGCR(3 99,IBIFN," OP",0)) D D^DIQ W " (",Y,")" Q . S %DT=" EXP",%DT(0 )=-DT D ^% DT K %DT I Y<1 S IBE X=1 Q . I '$$OPV2^IB CU41(Y,IBI FN,1) S IB EX=1 Q . S :'$G(IBZTY PE) X=$$OP V^IBCU41(Y ,IBIFN) S DGPROCDT=Y I 'IBEX D ASKCOD,AD DCPT^IBCU7 1:$D(DGCPT ) K IBEX G CODDT ;AS KCOD N Z,Z 0,DA,IBACT ,IBQUIT,IB LNPRV ;WC J;2.0*432 N IBPOPOUT S IBPOPO UT=0 ; IB* 2.0*447 BI K DGCPT S DGCPT=0,D GCPTUP=$P( $G(^IBE(35 0.9,1,1)), "^",19),DG ADDVST=0,I BFT=$P($G( ^DGCR(399, IBIFN,0)), "^",19) I '$D(^DGCR( 399,IBIFN, "CP",0)) S ^DGCR(399 ,IBIFN,"CP ",0)=U_$$G ETSPEC^IBE FUNC(399,3 04) ; F S IBQUIT=0 D Q:IBQUI T . S IBPO POUT=0 . D DICV ; re strict cod e type to PCM . S DI C("A")=" S elect PROC EDURE: " . S DIC="^D GCR(399,"_ IBIFN_","" CP""," . S DIC(0)="A EQMNL" . S DIC("S")= "I '$D(DIV (""S""))&( $P(^(0),U, 2)=DGPROCD T)" . S DI C("DR")="1 ///^S X=DG PROCDT" . S DA(1)=IB IFN,DLAYGO =399 . W ! D ^DIC I Y<1 S IBQU IT=1 Q . S IBPROCP=+ Y . ; If w e just add ed inactiv e code - i t must be deleted. . S IBACT=0 ; Active flag . I Y ["ICD0" S IBACT=$$IC D0ACT^IBAC SV(+$P(Y,U ,2),$$BDAT E^IBACSV(I BIFN)) . I Y["ICPT" S IBACT=$$ CPTACT^IBA CSV(+$P(Y, U,2),DGPRO CDT) . S D GCPTNEW=$P (Y,"^",3); Was the p rocedure j ust added? . I DGCPT NEW,'IBACT D DELPROC Q . I 'IB ACT W !,*7 ,"Warning: Procedure code is i nactive on this date ",! . I DG CPTNEW,$D( ^UTILITY($ J,"IB")),$ $INPAT^IBC EF(IBIFN), Y["ICPT(" D DATA^IBC U74(Y,.IBL NPRV) . S DGADDVST=$ S(DGCPTNEW :1,$D(DGAD DVST):DGAD DVST,1:0) . N IBPRV, IBPRVO,IBP RVN . ; . ; Line lev el provide r function by form t ype. . ; C MS-1500 (F ORM TYPE=2 ) . ; REND ERING PROV IDER, REFE RRING PROV IDER, . ; and SUPERV ISING PROV IDER. . ; UB-04 (FOR M TYPE=3) . ; RENDER ING PROVID ER, REFERR ING PROVID ER, . ; OP ERATING PR OVIDER, an d OTHER OP ERATING . ; PROVIDER . . ; . ; Removed: C all to $$M AINPRV^IBC EU(IBIFN) is for cla im . ; lev el provide r defaults . . ; 1. F or new lin e level pr oviders we don't nee d . ; or w ant defaul t claim le vel provid er . ; (re quirement) . . ; 2. W e don't wa nt to defa ult claim level to . ; line le vel provid er (requir ement). . ; . K DIC( "V") ; DEM ;432 - KIL L DIC("V") because t his was fo r previous variable pointer us e. . ; . N IBPROCSV ; DEM;432 - Variabl e IBPROCSV is variab le to pres erve value of 'Y', w hich is pr ocedure co de info re turned by call to ^D IC. . S IB PROCSV=Y ; DEM;432 - Preserve value of Y for afte r calls to FileMan ( Y = proced ure code i nfo return ed by call to ^DIC). . K DR ;WCJ;IB*2. 0*432 . ; . I IBPROC SV["ICD0" S DR=".01" ,DIE=DIC,( IBPROCP,DA )=+Y D ^DI E Q:'$D(DA )!($D(Y)) K DR ; IB* 2.0*461 . I IBPROCSV ["ICPT" S DR=".01;16 ",DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($D(Y)) K DR ; IB *2.0*447 B I . ; . S DR="" . ; . ; MRD;IB *2.0*516 - Added lin e level PR OCEDURE DE SCRIPTION field, . ; asked onl y if the p rocedure i s an "NOC" . . I IBPR OCSV["ICPT ",$$NOCPRO C(IBPROCSV ) D . . S DA=$P(IBPR OCSV,"^") ; The line # on the b ill/claim. . . S DR= 51 ; Field # for PROC EDURE DESC RIPTION . . D ^DIE . . Q . ; . D EN^IBCU 7B ; DEM;4 32 - Call to line le vel provid er user in put. . S Y =IBPROCSV ; DEM;432 - Restore value of Y after ca lls to Fil eMan . K I BPROCSV . K DR ;WC J;IB*2.0*4 32 . I IBP OPOUT Q ; IB*2.0*4 47 BI . S DR="" I Y[ "ICPT" S D R="6;5//"_ $$DEFDIV(I BIFN)_";" . S DR=DR_ $S(IBFT=2: "8;9;17//N O;",1:"")_ 3,DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($E($G( Y))=U) . K DR ;WCJ ;IB*2.0*43 2 . ; . ; MRD;IB*2.0 *516 - All ow user to add an ND C and Unit s. Ask onl y if . ; c oding syst em is not ICD and th is is not a prescrip tion claim . If . ; a n NDC is e ntered, pr ompt for U nits. . I $P($G(^DGC R(399,IBIF N,0)),U,9) '=9,'$$RXL INK^IBCSC5 C(IBIFN,IB PROCP) D . . K DA . . S DA=IBP ROCP,DA(1) =IBIFN,DIE ="^DGCR(39 9,"_IBIFN_ ",""CP""," . . S DR= "53NDC NUM BER;I X="" "" S Y=""" ";54//1" . . D ^DIE . . Q . ; . I IBFT=3 D:'$$INPA T^IBCEF(IB IFN) ATTAC H ; DEM;4 32 - Promp t for Atta chment Con trol Numbe r. . ; DEM ;432 - Add Additiona l OB Minut es to DR s tring for call to DI E. . S DR= $$SPCUNIT( IBIFN,IBPR OCP) S:DR[ "15;" DR=D R_"74Addit ional OB M inutes" D ^DIE ; mil es/minutes /hours . ; . I IBFT= 2 D .. D D X^IBCU72(I BIFN,IBPRO CP) .. S X =$$ADDTNL( IBIFN,.DA) . Q:$$INP AT^IBCEF(I BIFN) ;onl y outpatie nt bills . ;add proc edures to array for download t o PCE: dgc pt(assoc c linic,cpt, 'provider^ first dx^m odifiers', cnt)="" . S DGPROC=$ G(^DGCR(39 9,IBIFN,"C P",+DA,0)) . S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15) . I 'DGCPTN EW,$P(DGPR OC,"^",7)= "" S DGCPT NEW=2 . I DGCPTUP,DG CPTNEW S D GCPT=DGCPT +1 I $P(DG PROC,"^",7 ) S DGCPT( $P(DGPROC, "^",7),+DG PROC,X,DGC PT)="" . ; add visit date to b ill . I DG ADDVST S ( X,DINUM)=D GPROCDT D VFILE1^IBC OPV1 K DIN UM,X,DGNOA DD,DGADDVS T ; Delete modifiers with only a sequenc e #, no co de S Z=0 F S Z=$O(^ DGCR(399,I BIFN,"CP", Z)) Q:'Z S Z0=0 F S Z0=$O(^D GCR(399,IB IFN,"CP",Z ,"MOD",Z0) ) Q:'Z0 I $P($G(^(Z 0,0)),U,2) ="" S DA(2 )=IBIFN,DA (1)=Z,DA=Z 0,DIK="^DG CR(399,"_D A(2)_",""C P"","_DA(1 )_",""MOD" "," D ^DIK QCODQ K % DT,DGPROC, DIC,DIE,DR ,DGPROCDT, IBPROCP,DL AYGO K IBF T,DGNOADD, DGADDVST,D GCPT,DGCPT UP,IBZTYPE ,DGCPTNEW Q ;DELPROC ; Remove the select ed procedu re, becaus e of inact ive status (cancel s election) W !!,*7,"T he Procedu re code is inactive on ",$$DAT 1^IBOUTL(D GPROCDT)," ." W !,"Pl ease selec t another Procedure. " S DA(1)= IBIFN,DA=+ Y,DIK="^DG CR(399,"_I BIFN_",""C P""," D ^D IK Q ;DELA DD N Z,Z0, DA,DIK,X,Y S DA(1)=I BIFN ;Dele te referen ces to pro c on rev c odes S Z=0 F S Z=$O (^DGCR(399 ,IBIFN,"RC ",Z)) Q:'Z S Z0=$G( ^(Z,0)) I Z0'="",$P( Z0,U,15)!$ S($P(Z0,U, 10)=3:$P(Z 0,U,11),1: 0) S DIE=" ^DGCR(399, "_DA(1)_", ""RC"",",D A=Z,DR=".1 1///@;.15/ //@"_$S($P (Z0,U,8):" ",1:";.08/ ///1") D ^ DIE S DIK= "^DGCR(399 ,"_DA(1)_" ,""CP""," F DA=0:0 S DA=$O(^DG CR(399,DA( 1),"CP",DA )) Q:'DA D ^DIK S D GRVRCAL=1 Q ;DTMES ; Message if procedure date not in date ra nge Q:'$D( IBIFN) Q:' $D(^DGCR(3 99,IBIFN," U")) S DGN ODUU=^("U" ) G:X'<$P( DGNODUU,"^ ")&(X'>$P( DGNODUU,"^ ",2)) DTME SQ W *7,!! ?3,"Date m ust be wit hin STATEM ENT COVERS FROM and STATEMENT COVERS TO period." S Y=$P(DGNO DUU,"^") X ^DD("DD") W !?3,"En ter a date between " ,Y," and " S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,! K X,YDTME SQ K DGNOD UU Q ;CODH LP ;Displa y Addition al Procedu re codes N I,J,Y,IBM OD I '$O(^ DGCR(399,I BIFN,"CP", 0)) W !!?5 ,"No Codes Entered!" ,! Q W ! F I=0:0 S I =$O(^DGCR( 399,IBIFN, "CP",I)) Q :'I S Y=$ G(^(I,0)) S Z=$$PRCN M^IBCSCH1( $P(Y,"^",1 ),$P(Y,"^" ,2)) W !?5 ,$E($P(Z," ^",2),1,33 ),?40,"- " ,$P(Z,"^") D . N IBY . S IBY=$ P(Y,U,2) . S IBMOD=$ $GETMOD^IB EFUNC(IBIF N,I,1) . I IBMOD'="" S IBMOD=" /"_IBMOD W IBMOD . W ?60,"Date : " S Y=IB Y D DT^DIQ W ! ; K Z Q ;DICV I $D(IBIFN) ,$D(^DGCR( 399,IBIFN, 0)),$P(^(0 ),U,9) S D IC("V")=$S ($P(^(0),U ,9)=9:"I + Y(0)=80.1" ,$P(^(0),U ,9)=4!($P( ^(0),U,9)= 5):"I +Y(0 )=81",1:"" ) Q ;DEFDI V(IBIFN) ; Find defa ult divisi on for bil l IBIFN Q $P($G(^DG( 40.8,+$P($ G(^DGCR(39 9,IBIFN,0) ),U,22),0) ),U) ;ADDT NL(IBIFN,D A) ; N DR, IBOK,X,Y,D IR S IBOK= 1 S DR="19 T;50.09T;5 0.08T" D ^ DIE ; WCJ; IB*2.0*488 Added Ts ;I '($$FT^ IBCEF(IBIF N)'=3&($$I NPAT^IBCEF (IBIFN))) D ATTACH ; DEM;432 - Prompt fo r Attachme nt Control Number. I '($$FT^IB CEF(IBIFN) =3&($$INPA T^IBCEF(IB IFN))) D A TTACH ; D EM;432 - P rompt for Attachment Control N umber. I $ D(Y) S IBO K=0 G ADDT NLQ ;/Begi nning of I B*2.0*488 (vd) ;S DI R("B")="NO ",DIR("A") ="EDIT CMS -1500 SPEC IAL PROGRA M FIELDS a nd BOX 19? : ",DIR("A ",1)=" ",D IR(0)="YA" ;S DIR("? ",1)="Resp ond YES on ly if you need to ad d/edit dat a for chir opractic v isits," ;S DIR("?")= "EPSDT car e, or if b illing for HOSPICE a nd attendi ng is not a hospice employee." ;D ^DIR K DIR ;I Y' =1 S IBOK= 0 G ADDTNL Q ;S DR="W !,"" <<EP SDT>>"";50 .07;W !!," " <<HOSPIC E>>"";50.0 3" S DR="5 0.07T;50.0 3T" ;WCJ ;IB*2.0*48 8 added Ts ;/End of IB*2.0*488 (vd) D ^D IE W !ADDT NLQ Q IBOK ;XTRA1(Y) ; K Y Q ; SPCUNIT(IB IFN,DA) ; return fie lds for sp ecial unit s if appli cable, in DR form N IB0,IBCPT, IBDR,IBCT, IBFT,DFN S IBDR="" S IB0=$G(^D GCR(399,+$ G(IBIFN),0 )),IBCT=$P (IB0,U,27) ,IBFT=$P(I B0,U,19),D FN=$P(IB0, U,2) S IBC PT=$G(^DGC R(399,+$G( IBIFN),"CP ",+$G(DA), 0)) I IBCP T'["ICPT" G SPCUNTQ I +$$ITMUN IT^IBCRU4( +IBCPT,5,I BCT) S IBD R="15;" D SROMIN^IBC U74(IBIFN, DA) G SPCU NTQ ; minu tes I +$$I TMUNIT^IBC RU4(+IBCPT ,4,IBCT) S IBDR="21; " G SPCUNT Q ; miles I +$$ITMUN IT^IBCRU4( +IBCPT,6,I BCT) S IBD R="22//"_$ $OBSHOUR^I BCU74(DFN, $P(IBCPT,U ,2))_";" G SPCUNTQ ; hours I + IBFT=2,$P( $G(^IBE(35 3.2,+$P(IB CPT,U,10), 0)),U,2)=" ANESTHESIA " S IBDR=" 15;" ; min utesSPCUNT Q Q IBDR ; ATTACH ; D EM;432 - A ttachment control nu mber. ; As k if user wants to e nter Attac hment Cont rol Number . N DIR,X, Y,DA,DIE,D R S DIR("A ")="Enter Attachment Control N umber" S D IR(0)="Y", DIR("B")=" NO" D ^DIR Q:'Y ; Us er chose t o enter At tachment C ontrol Num ber. ; Use r enters A ttachment Control fi elds. S DA (1)=IBIFN, DA=IBPROCP S DIE="^D GCR(399,"_ DA(1)_","" CP""," S D R="71Repor t Type;72R eport Tran smission M ethod;70At tachment C ontrol Num ber" D ^DI E Q ;NOCPR OC(IBPROCS V) ; MRD;I B*2.0*516 - Function to determ ine if pro cedure is an ; "NOC" . Returns '1' if "NO C" procedu re, otherw ise '0'. ; N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX S IBNOC=0 I $G(IBPRO CSV)="" G NOCPROCQ S IBPROCIN= $P($P(IBPR OCSV,U,2), ";") I IBP ROCIN="" G NOCPROCQ ; ; If pro cedure cod e ends in '99', quit with a '1 '. ; S IBP ROCEX=$P($ G(^ICPT(IB PROCIN,0)) ,U,1) I $E (IBPROCEX, $L(IBPROCE X)-1,$L(IB PROCEX))=9 9 S IBNOC= 1 G NOCPRO CQ ; ; Pul l procedur e name, th en check t o see if i t contains one of th e ; specif ied string s. ; S IBP ROCNM=$P($ G(^ICPT(IB PROCIN,0)) ,U,2) I IB PROCNM'="" ,$$NOC(IBP ROCNM) S I BNOC=1 G N OCPROCQ ; S IBX=0 F S IBX=$O( ^ICPT(IBPR OCIN,"D",I BX)) Q:'IB X D I IB NOC=1 Q . S IBTEXT=$ G(^ICPT(IB PROCIN,"D" ,IBX,0)) . I $G(^ICP T(IBPROCIN ,"D",IBX+1 ,0))'="" S IBTEXT=IB TEXT_" "_$ G(^ICPT(IB PROCIN,"D" ,IBX+1,0)) . S IBNOC =$$NOC(IBT EXT) . Q ; NOCPROCQ ; Quit out. Q IBNOC ; NOC(IBTEXT ) ; Quit w ith '1' if IBTEXT co ntains one of the sp ecified st rings. ; S IBTEXT=$T R(IBTEXT," abcdefghij klmnopqrst uvwxyz","A BCDEFGHIJK LMNOPQRSTU VWXYZ") ; I IBTEXT[" NOT OTHERW ISE" Q 1 I IBTEXT["N OT ELSEWHE RE" Q 1 I IBTEXT["NO T LISTED" Q 1 I IBTE XT["UNLIST ED" Q 1 I IBTEXT["UN SPECIFIED" Q 1 I IBT EXT["UNCLA SSIFIED" Q 1 I IBTEX T["NON-SPE CIFIED" Q 1 I IBTEXT ["NOS " Q 1 I IBTEXT ["NOS;" Q 1 I IBTEXT ["NOS." Q 1 I IBTEXT ["NOS," Q 1 I IBTEXT ["NOS/" Q 1 I IBTEXT ["(NOS)" Q 1 I IBTEX T["NOC " Q 1 I IBTEX T["NOC;" Q 1 I IBTEX T["NOC." Q 1 I IBTEX T["NOC," Q 1 I IBTEX T["NOC/" Q 1 I IBTEX T["(NOC)" Q 1 ; ; Ch eck if las t three ch aracters a re 'NOC' o r 'NOS'. ; S IBTEXT= $E(IBTEXT, $L(IBTEXT) -2,$L(IBTE XT)) I IBT EXT="NOC" Q 1 I IBTE XT="NOS" Q 1 ; Q 0 ; | |
| 3502 | Modified L ogic (Chan ges are in bold) | |
| 3503 | IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT OF PROCEDU RE CODES ; 29-OCT-91 ;;2.0;INTE GRATED BIL LING;**62, 52,106,125 ,51,137,21 0,245,228, 260,348,37 1,432,447, 488,461,51 6,522,577, 592**;21-M AR-94;Buil d 1 ;;Per VA Directi ve 6402, t his routin e should n ot be modi fied. ; ;M AP TO DGCR U7 ;CHKX ; -intercep tion of in put x from Additiona l Procedur e input G: X=" " CHKX Q I $$INPA T^IBCEF(DA (1)),'$P($ G(^IBE(350 .9,1,1))," ^",15),X'? 1A1.2N D G CHKXQ . K X . D EN ^DDIOL("Si te param d oes not al low entry of non-PTF procedure s") ;Filem an error h ere will b e: The pre vious erro r occurred when perf orming an action spe cified in a Pre-look up transfo rm (7.5 no de). G:'$D (^UTILITY( $J,"IB")) CHKXQ ;S M =($A($E(X, 1))-64),S= +$E(X,2) Q :'$G(^UTIL ITY($J,"IB ",M,S)) S X="`"_+^(S ) S M=0 I X?1A1.2N S N=$G(^UTI LITY($J,"I B","B",X)) S M=+N,S= +$P(N,U,2) ,P=X S S=$ G(^UTILITY ($J,"IB",M ,S)) I +S S X="`"_+S I $P(N,U, 3)="N" S X =""""_X_"" "" S $P(^U TILITY($J, "IB","B",P ),U,3)="Y" I +M,$D(D GPROCDT),D GPROCDT'=$ P($G(^UTIL ITY($J,"IB ",M,1)),"^ ",2) S DGP ROCDT=$P(^ (1),"^",2) W !!,"Pro cedure Dat e: " S Y=D GPROCDT X ^DD("DD") W Y,!CHKXQ Q ;CODMUL ;Date ori ented entr y of proce dureDELASK I $D(IBZ2 0),IBZ20,I BZ20'=$P(^ DGCR(399,I BIFN,0),U, 9) S %=2 W !,"SINCE THE PROCED URE CODING METHOD HA S BEEN CHA NGED, DO Y OU WANT TO DELETE AL L",!,"PROC EDURE CODE S IN THIS BILL" I D YN^DICN Q :%=-1 D:%= 1 DELADD I %Y?1."?" W !!,"If y ou answer 'Yes', all procedure codes wil l be DELET ED from th is bill.", ! G DELASK K %,%Y,DA ,IBZ20,DIK ;W !,"Pro cedure Ent ry:" ;CODD T I $D(IBI FN),$D(^DG CR(399,IBI FN,0)),$P( ^(0),U,9) S DIC("V") =$S($P(^(0 ),U,9)=9:" I +Y(0)=80 .1",$P(^(0 ),U,9)=4!( $P(^(0),U, 9)=5):"I + Y(0)=81",1 :"") I $P( $G(^DGCR(3 99,IBIFN,0 )),"^",5)< 3 S IBZTYP E=1 I $P($ G(^UTILITY ($J,"IB",1 ,1)),"^",2 ) S DGPROC DT=$P(^(1) ,"^",2) D ASKCOD S X =$$PRCDIV^ IBCU71(IBI FN) I +X W !!,$P(X,U ,2),! N Z, Z0 S Z=$G( ^DGCR(399, IBIFN,"U") ),Z0=$$FMT E^XLFDT($P (Z,U),"2D" )_"-"_$$FM TE^XLFDT($ P(Z,U,2)," 2D") W !," Select PRO CEDURE DAT E"_$S($TR( Z0,"-")'=" ":" ("_Z0_ ")",1:"")_ ": " R X:D TIME G:'$T !("^"[X) C ODQ D:X["? " CODHLP S IBEX=0 D ; Get pro cedure dat e . I X=" ",$D(DGPRO CDT),DGPRO CDT?7N S Y =DGPROCDT D D^DIQ W " (",Y,")" Q . I X=" ",+$P($G( ^DGCR(399, IBIFN,"OP" ,0)),"^",4 ) S (DGPRO CDT,Y)=$O( ^DGCR(399, IBIFN,"OP" ,0)) D D^D IQ W " (", Y,")" Q . S %DT="EXP ",%DT(0)=- DT D ^%DT K %DT I Y< 1 S IBEX=1 Q . I '$$ OPV2^IBCU4 1(Y,IBIFN, 1) S IBEX= 1 Q . S:'$ G(IBZTYPE) X=$$OPV^I BCU41(Y,IB IFN) S DGP ROCDT=Y I 'IBEX D AS KCOD,ADDCP T^IBCU71:$ D(DGCPT) K IBEX G CO DDT ;ASKCO D N Z,Z0,D A,IBACT,IB QUIT,IBLNP RV ;WCJ;2 .0*432 N I BPOPOUT S IBPOPOUT= 0 ; IB*2.0 *447 BI K DGCPT S DG CPT=0,DGCP TUP=$P($G( ^IBE(350.9 ,1,1)),"^" ,19),DGADD VST=0,IBFT =$P($G(^DG CR(399,IBI FN,0)),"^" ,19) I '$D (^DGCR(399 ,IBIFN,"CP ",0)) S ^D GCR(399,IB IFN,"CP",0 )=U_$$GETS PEC^IBEFUN C(399,304) ; F S IB QUIT=0 D Q:IBQUIT . S IBPOPOU T=0 . D DI CV ; restr ict code t ype to PCM . S DIC(" A")=" Sele ct PROCEDU RE: " . S DIC="^DGCR (399,"_IBI FN_",""CP" "," . S DI C(0)="AEQM NL" . S DI C("S")="I '$D(DIV("" S""))&($P( ^(0),U,2)= DGPROCDT)" . S DIC(" DR")="1/// ^S X=DGPRO CDT" . S D A(1)=IBIFN ,DLAYGO=39 9 . W ! D ^DIC I Y<1 S IBQUIT= 1 Q . S IB PROCP=+Y . ; If we j ust added inactive c ode - it m ust be del eted. . S IBACT=0 ; Active fla g . I Y["I CD0" S IBA CT=$$ICD0A CT^IBACSV( +$P(Y,U,2) ,$$BDATE^I BACSV(IBIF N)) . I Y[ "ICPT" S I BACT=$$CPT ACT^IBACSV (+$P(Y,U,2 ),DGPROCDT ) . S DGCP TNEW=$P(Y, "^",3) ;Wa s the proc edure just added? . I DGCPTNEW ,'IBACT D DELPROC Q . I 'IBACT W !,*7,"W arning: Pr ocedure co de is inac tive on th is date",! . I DGCPT NEW,$D(^UT ILITY($J," IB")),$$IN PAT^IBCEF( IBIFN),Y[" ICPT(" D D ATA^IBCU74 (Y,.IBLNPR V) . S DGA DDVST=$S(D GCPTNEW:1, $D(DGADDVS T):DGADDVS T,1:0) . N IBPRV,IBP RVO,IBPRVN . ; . ; L ine level provider f unction by form type . . ; CMS- 1500 (FORM TYPE=2) . ; RENDERI NG PROVIDE R, REFERRI NG PROVIDE R, . ; and SUPERVISI NG PROVIDE R. . ; UB- 04 (FORM T YPE=3) . ; RENDERING PROVIDER, REFERRING PROVIDER, . ; OPERA TING PROVI DER, and O THER OPERA TING . ; P ROVIDER. . ; . ; Rem oved: Call to $$MAIN PRV^IBCEU( IBIFN) is for claim . ; level provider d efaults. . ; 1. For new line l evel provi ders we do n't need . ; or want default c laim level provider . ; (requi rement). . ; 2. We d on't want to default claim lev el to . ; line level provider (requireme nt). . ; . K DIC("V" ) ; DEM;43 2 - KILL D IC("V") be cause this was for p revious va riable poi nter use. . ; . N IB PROCSV ; DEM;432 - Variable I BPROCSV is variable to preserv e value of 'Y', whic h is proce dure code info retur ned by cal l to ^DIC. . S IBPRO CSV=Y ; D EM;432 - P reserve va lue of Y f or after c alls to Fi leMan (Y = procedure code info returned by call to ^DIC). . K DR ;WC J;IB*2.0*4 32 . ; . I IBPROCSV[ "ICD0" S D R=".01",DI E=DIC,(IBP ROCP,DA)=+ Y D ^DIE Q :'$D(DA)!( $D(Y)) K D R ; IB*2.0 *461 . I I BPROCSV["I CPT" S DR= ".01;16",D IE=DIC,(IB PROCP,DA)= +Y D ^DIE Q:'$D(DA)! ($D(Y)) K DR ; IB*2. 0*447 BI . ; . S DR= "" . ; . ; MRD;IB*2. 0*516 - Ad ded line l evel PROCE DURE DESCR IPTION fie ld, . ; as ked only i f the proc edure is a n "NOC". . I IBPROCS V["ICPT",$ $NOCPROC(I BPROCSV) D . . S DA= $P(IBPROCS V,"^") ; T he line# o n the bill /claim. . . S DR=51 ; Field# f or PROCEDU RE DESCRIP TION . . D ^DIE . . Q . ; . D EN^IBCU7B ; DEM;432 - Call to line level provider user input . . S Y=IB PROCSV ; DEM;432 - Restore va lue of Y a fter calls to FileMa n . K IBPR OCSV . K D R ;WCJ;I B*2.0*432 . I IBPOPO UT Q ; I B*2.0*447 BI . S DR= "" I Y["IC PT" S DR=" 6;5//"_$$D EFDIV(IBIF N)_";" . ; JWS;IB*2.0 *592 US110 8 - Dental . S DR=DR _$S(IBFT=7 :"8;9//;", IBFT=2:"8; 9;17//NO;" ,1:"")_3,D IE=DIC,(IB PROCP,DA)= +Y D ^DIE Q:'$D(DA)! ($E($G(Y)) =U) . K DR ;WCJ;IB *2.0*432 . ; . ; MRD ;IB*2.0*51 6 - Allow user to ad d an NDC a nd Units. Ask only i f . ; codi ng system is not ICD and this is not a p rescriptio n claim. I f . ; an N DC is ente red, promp t for Unit s. . I $P( $G(^DGCR(3 99,IBIFN,0 )),U,9)'=9 ,'$$RXLINK ^IBCSC5C(I BIFN,IBPRO CP) D . . ;JWS;IB*2. 0*592 US11 08 - Denta l . . I IB FT=7 Q . . K DA . . S DA=IBPRO CP,DA(1)=I BIFN,DIE=" ^DGCR(399, "_IBIFN_", ""CP""," . . ; vd/Be ginning IB *2*577 - A dded the p rompt for Unit/Basis of Measur ement. . . ; S DR="5 3NDC NUMBE R;I X="""" S Y=""""; 54//1" . . S DR="53N DC NUMBER; I X="""" S Y="""";52 //UN;54QUA NTITY//1" ;Prompt f or NDC, UN & amt. . . ; vd/End ing IB*2*5 77 . . D ^ DIE . . Q . ; . I IB FT=3 D:'$$ INPAT^IBCE F(IBIFN) A TTACH ; D EM;432 - P rompt for Attachment Control N umber. . ; DEM;432 - Add Addit ional OB M inutes to DR string for call t o DIE. . S DR=$$SPCU NIT(IBIFN, IBPROCP) S :DR["15;" DR=DR_"74A dditional OB Minutes " D ^DIE ; miles/min utes/hours . ;JWS;IB *2.0*592 U S1108 - De ntal . I I BFT=2!(IBF T=7) D .. D DX^IBCU7 2(IBIFN,IB PROCP) .. ;JWS;IB*2. 0*592 US11 08 - Denta l .. I IBF T'=7 S X=$ $ADDTNL(IB IFN,.DA) . Q:$$INPAT ^IBCEF(IBI FN) ;only outpatient bills . ; JWS;IB*2.0 *592 US110 8 - Dental input fie lds . I $$ FT^IBCEF(I BIFN)=7 D ORAL^IBCU7 2 . ;add p rocedures to array f or downloa d to PCE: dgcpt(asso c clinic,c pt,'provid er^first d x^modifier s',cnt)="" . S DGPRO C=$G(^DGCR (399,IBIFN ,"CP",+DA, 0)) . S X= $P(DGPROC, U,18)_U_+$ G(^IBA(362 .3,+$P(DGP ROC,U,11), 0))_U_$P(D GPROC,U,15 ) . I 'DGC PTNEW,$P(D GPROC,"^", 7)="" S DG CPTNEW=2 . I DGCPTUP ,DGCPTNEW S DGCPT=DG CPT+1 I $P (DGPROC,"^ ",7) S DGC PT($P(DGPR OC,"^",7), +DGPROC,X, DGCPT)="" . ; add vi sit date t o bill . I DGADDVST S (X,DINUM )=DGPROCDT D VFILE1^ IBCOPV1 K DINUM,X,DG NOADD,DGAD DVST ; Del ete modifi ers with o nly a sequ ence #, no code S Z= 0 F S Z=$ O(^DGCR(39 9,IBIFN,"C P",Z)) Q:' Z S Z0=0 F S Z0=$O (^DGCR(399 ,IBIFN,"CP ",Z,"MOD", Z0)) Q:'Z0 I $P($G( ^(Z0,0)),U ,2)="" S D A(2)=IBIFN ,DA(1)=Z,D A=Z0,DIK=" ^DGCR(399, "_DA(2)_", ""CP"","_D A(1)_",""M OD""," D ^ DIK QCODQ K %DT,DGPR OC,DIC,DIE ,DR,DGPROC DT,IBPROCP ,DLAYGO K IBFT,DGNOA DD,DGADDVS T,DGCPT,DG CPTUP,IBZT YPE,DGCPTN EW Q ;DELP ROC ; Remo ve the sel ected proc edure, bec ause of in active sta tus (cance l selectio n) W !!,*7 ,"The Proc edure code is inacti ve on ",$$ DAT1^IBOUT L(DGPROCDT ),"." W !, "Please se lect anoth er Procedu re." S DA( 1)=IBIFN,D A=+Y,DIK=" ^DGCR(399, "_IBIFN_", ""CP""," D ^DIK Q ;D ELADD N Z, Z0,DA,DIK, X,Y S DA(1 )=IBIFN ;D elete refe rences to proc on re v codes S Z=0 F S Z =$O(^DGCR( 399,IBIFN, "RC",Z)) Q :'Z S Z0= $G(^(Z,0)) I Z0'="", $P(Z0,U,15 )!$S($P(Z0 ,U,10)=3:$ P(Z0,U,11) ,1:0) S DI E="^DGCR(3 99,"_DA(1) _",""RC"", ",DA=Z,DR= ".11///@;. 15///@"_$S ($P(Z0,U,8 ):"",1:";. 08////1") D ^DIE S D IK="^DGCR( 399,"_DA(1 )_",""CP"" ," F DA=0: 0 S DA=$O( ^DGCR(399, DA(1),"CP" ,DA)) Q:'D A D ^DIK S DGRVRCAL =1 Q ;DTME S ;Message if proced ure date n ot in date range Q:' $D(IBIFN) Q:'$D(^DGC R(399,IBIF N,"U")) S DGNODUU=^( "U") G:X'< $P(DGNODUU ,"^")&(X'> $P(DGNODUU ,"^",2)) D TMESQ W *7 ,!!?3,"Dat e must be within STA TEMENT COV ERS FROM a nd STATEME NT COVERS TO period. " S Y=$P(D GNODUU,"^" ) X ^DD("D D") W !?3, "Enter a d ate betwee n ",Y," an d " S Y=$P (DGNODUU," ^",2) X ^D D("DD") W Y,! K X,YD TMESQ K DG NODUU Q ;C ODHLP ;Dis play Addit ional Proc edure code s N I,J,Y, IBMOD I '$ O(^DGCR(39 9,IBIFN,"C P",0)) W ! !?5,"No Co des Entere d!",! Q W ! F I=0:0 S I=$O(^DG CR(399,IBI FN,"CP",I) ) Q:'I S Y=$G(^(I,0 )) S Z=$$P RCNM^IBCSC H1($P(Y,"^ ",1),$P(Y, "^",2)) W !?5,$E($P( Z,"^",2),1 ,33),?40," - ",$P(Z," ^") D . N IBY . S IB Y=$P(Y,U,2 ) . S IBMO D=$$GETMOD ^IBEFUNC(I BIFN,I,1) . I IBMOD' ="" S IBMO D="/"_IBMO D W IBMOD . W ?60,"D ate: " S Y =IBY D DT^ DIQ W ! ; K Z Q ;DIC V I $D(IBI FN),$D(^DG CR(399,IBI FN,0)),$P( ^(0),U,9) S DIC("V") =$S($P(^(0 ),U,9)=9:" I +Y(0)=80 .1",$P(^(0 ),U,9)=4!( $P(^(0),U, 9)=5):"I + Y(0)=81",1 :"") Q ;DE FDIV(IBIFN ) ; Find d efault div ision for bill IBIFN Q $P($G(^ DG(40.8,+$ P($G(^DGCR (399,IBIFN ,0)),U,22) ,0)),U) ;A DDTNL(IBIF N,DA) ; N DR,IBOK,X, Y,DIR S IB OK=1 S DR= "19T;50.09 T;50.08T" D ^DIE ; W CJ;IB*2.0* 488 Added Ts ;I '($$ FT^IBCEF(I BIFN)'=3&( $$INPAT^IB CEF(IBIFN) )) D ATTAC H ; DEM;43 2 - Prompt for Attac hment Cont rol Number . I '($$FT ^IBCEF(IBI FN)=3&($$I NPAT^IBCEF (IBIFN))) D ATTACH ; DEM;432 - Prompt f or Attachm ent Contro l Number. I $D(Y) S IBOK=0 G A DDTNLQ ;/B eginning o f IB*2.0*4 88 (vd) ;S DIR("B")= "NO",DIR(" A")="EDIT CMS-1500 S PECIAL PRO GRAM FIELD S and BOX 19?: ",DIR ("A",1)=" ",DIR(0)=" YA" ;S DIR ("?",1)="R espond YES only if y ou need to add/edit data for c hiropracti c visits," ;S DIR("? ")="EPSDT care, or i f billing for HOSPIC E and atte nding is n ot a hospi ce employe e." ;D ^DI R K DIR ;I Y'=1 S IB OK=0 G ADD TNLQ ;S DR ="W !,"" < <EPSDT>>"" ;50.07;W ! !,"" <<HOS PICE>>"";5 0.03" S DR ="50.07T;5 0.03T" ; WCJ;IB*2.0 *488 added Ts ;/End of IB*2.0* 488 (vd) D ^DIE W !A DDTNLQ Q I BOK ;XTRA1 (Y) ; K Y Q ;SPCUNIT (IBIFN,DA) ; return fields for special u nits if ap plicable, in DR form N IB0,IBC PT,IBDR,IB CT,IBFT,DF N S IBDR=" " S IB0=$G (^DGCR(399 ,+$G(IBIFN ),0)),IBCT =$P(IB0,U, 27),IBFT=$ P(IB0,U,19 ),DFN=$P(I B0,U,2) S IBCPT=$G(^ DGCR(399,+ $G(IBIFN), "CP",+$G(D A),0)) I I BCPT'["ICP T" G SPCUN TQ I +$$IT MUNIT^IBCR U4(+IBCPT, 5,IBCT) S IBDR="15;" D SROMIN^ IBCU74(IBI FN,DA) G S PCUNTQ ; m inutes I + $$ITMUNIT^ IBCRU4(+IB CPT,4,IBCT ) S IBDR=" 21;" G SPC UNTQ ; mil es I +$$IT MUNIT^IBCR U4(+IBCPT, 6,IBCT) S IBDR="22// "_$$OBSHOU R^IBCU74(D FN,$P(IBCP T,U,2))_"; " G SPCUNT Q ; hours I +IBFT=2, $P($G(^IBE (353.2,+$P (IBCPT,U,1 0),0)),U,2 )="ANESTHE SIA" S IBD R="15;" ; minutesSPC UNTQ Q IBD R ;ATTACH ; DEM;432 - Attachme nt control number. ; Ask if us er wants t o enter At tachment C ontrol Num ber. N DIR ,X,Y,DA,DI E,DR S DIR ("A")="Ent er Attachm ent Contro l Number" S DIR(0)=" Y",DIR("B" )="NO" D ^ DIR Q:'Y ; User chos e to enter Attachmen t Control Number. ; User enter s Attachme nt Control fields. S DA(1)=IBI FN,DA=IBPR OCP S DIE= "^DGCR(399 ,"_DA(1)_" ,""CP""," S DR="71Re port Type; 72Report T ransmissio n Method;7 0Attachmen t Control Number" D ^DIE Q ;NO CPROC(IBPR OCSV) ; MR D;IB*2.0*5 16 - Funct ion to det ermine if procedure is an ; "N OC". Retur ns '1' if "NOC" proc edure, oth erwise '0' . ; N IBNO C,IBPROCEX ,IBPROCIN, IBPROCNM,I BX S IBNOC =0 I $G(IB PROCSV)="" G NOCPROC Q S IBPROC IN=$P($P(I BPROCSV,U, 2),";") I IBPROCIN=" " G NOCPRO CQ ; ; If procedure code ends in '99', q uit with a '1'. ; S IBPROCEX=$ P($G(^ICPT (IBPROCIN, 0)),U,1) I $E(IBPROC EX,$L(IBPR OCEX)-1,$L (IBPROCEX) )=99 S IBN OC=1 G NOC PROCQ ; ; Pull proce dure name, then chec k to see i f it conta ins one of the ; spe cified str ings. ; S IBPROCNM=$ P($G(^ICPT (IBPROCIN, 0)),U,2) I IBPROCNM' ="",$$NOC( IBPROCNM) S IBNOC=1 G NOCPROCQ ; S IBX=0 F S IBX= $O(^ICPT(I BPROCIN,"D ",IBX)) Q: 'IBX D I IBNOC=1 Q . S IBTEX T=$G(^ICPT (IBPROCIN, "D",IBX,0) ) . I $G(^ ICPT(IBPRO CIN,"D",IB X+1,0))'=" " S IBTEXT =IBTEXT_" "_$G(^ICPT (IBPROCIN, "D",IBX+1, 0)) . S IB NOC=$$NOC( IBTEXT) . Q ;NOCPROC Q ; Quit o ut. Q IBNO C ;NOC(IBT EXT) ; Qui t with '1' if IBTEXT contains one of the specified strings. ; S IBTEXT =$TR(IBTEX T,"abcdefg hijklmnopq rstuvwxyz" ,"ABCDEFGH IJKLMNOPQR STUVWXYZ") ; I IBTEX T["NOT OTH ERWISE" Q 1 I IBTEXT ["NOT ELSE WHERE" Q 1 I IBTEXT[ "NOT LISTE D" Q 1 I I BTEXT["UNL ISTED" Q 1 I IBTEXT[ "UNSPECIFI ED" Q 1 I IBTEXT["UN CLASSIFIED " Q 1 I IB TEXT["NON- SPECIFIED" Q 1 I IBT EXT["NOS " Q 1 I IBT EXT["NOS;" Q 1 I IBT EXT["NOS." Q 1 I IBT EXT["NOS," Q 1 I IBT EXT["NOS/" Q 1 I IBT EXT["(NOS) " Q 1 I IB TEXT["NOC " Q 1 I IB TEXT["NOC; " Q 1 I IB TEXT["NOC. " Q 1 I IB TEXT["NOC, " Q 1 I IB TEXT["NOC/ " Q 1 I IB TEXT["(NOC )" Q 1 ; ; Check if last three charcters are 'NOC' or 'NOS'. ; S IBTEX T=$E(IBTEX T,$L(IBTEX T)-2,$L(IB TEXT)) I I BTEXT="NOC " Q 1 I IB TEXT="NOS" Q 1 ; Q 0 ;ORALCAV( FLD) ;EP ; Dictionar y Screen f unction ca lled from Procedures Oral Cavi ty Fields: ; 399.030 4.90.01, 3 99.0304.90 .02, 399.0 304.90.03, 399.0304. 90.04, 399 .0304.90.0 5 ; Preve nts the sa me Oral Ca vity from being sele cted more than once. ; Input: FLD - Fiel d # of the field bei ng checked ; DA - IE N of the S ervice Lin e Multiple being edi ted ; DA(1 ) - IEN of the 356.2 2 entry be ing edited ; Y - Int ernal Valu e of the u ser respon se ; Retur ns: 1 - Da ta input b y the user is valid, 0 otherwi se N NDE,R TN S NDE=$ G(^DGCR(39 9,DA(1),"C P",DA,"DEN ")) S RTN= 1 ; Assume Valid Inp ut Q:Y="" 1 ; No val ue entered ; ; Make sure there are no du plicates I FLD=90.01 D Q RTN . I $P(NDE ,"^",2)=Y S RTN=0 Q . I $P(NDE ,"^",3)=Y S RTN=0 Q . I $P(NDE ,"^",4)=Y S RTN=0 Q . I $P(NDE ,"^",5)=Y S RTN=0 Q I FLD=90.0 2 D Q RTN . I $P(ND E,"^",1)=Y S RTN=0 Q . I $P(ND E,"^",3)=Y S RTN=0 Q . I $P(ND E,"^",4)=Y S RTN=0 Q . I $P(ND E,"^",5)=Y S RTN=0 Q I FLD=90. 03 D Q RT N . I $P(N DE,"^",1)= Y S RTN=0 Q . I $P(N DE,"^",2)= Y S RTN=0 Q . I $P(N DE,"^",4)= Y S RTN=0 Q . I $P(N DE,"^",5)= Y S RTN=0 Q I FLD=90 .04 D Q R TN . I $P( NDE,"^",1) =Y S RTN=0 Q . I $P( NDE,"^",2) =Y S RTN=0 Q . I $P( NDE,"^",3) =Y S RTN=0 Q . I $P( NDE,"^",5) =Y S RTN=0 Q I FLD=9 0.05 D Q RTN . I $P (NDE,"^",1 )=Y S RTN= 0 Q . I $P (NDE,"^",2 )=Y S RTN= 0 Q . I $P (NDE,"^",3 )=Y S RTN= 0 Q . I $P (NDE,"^",4 )=Y S RTN= 0 Q Q RTN ;TOOTHS(FL D) ;EP ; D ictionary Screen fun ction call ed from De ntal Servi ce Line To oth fields : ; 399,91 ,.02, 399, 91,.03, 39 9,91,.04, 399,91,.05 , 399,91,. 06. Preven ts the ; same Tooth Surface f rom being selected m ore than o nce. ; Inp ut: FLD - Field # of the field being che cked ; DA - Tooth Su rface mult iple IEN ; DA(1) - S ervice Lin e multiple IEN ; DA( 2) - IEN o f the 356. 22 entry b eing edite d ; Y - In ternal Val ue of the user respo nse ; Retu rns: 1 - D ata input by the use r is valid , 0 otherw ise N NDE, RTN S NDE= $G(^DGCR(3 99,DA(2)," CP",DA(1), "DEN1",DA, 0)) S RTN= 1 ; Assume Valid Inp ut Q:Y="" 1 ; No val ue entered ; ; Make sure there are no du plicates I FLD=.02 D Q RTN . I $P(NDE," ^",3)=Y S RTN=0 Q . I $P(NDE," ^",4)=Y S RTN=0 Q . I $P(NDE," ^",5)=Y S RTN=0 Q . I $P(NDE," ^",6)=Y S RTN=0 Q I FLD=.03 D Q RTN . I $P(NDE,"^ ",2)=Y S R TN=0 Q . I $P(NDE,"^ ",4)=Y S R TN=0 Q . I $P(NDE,"^ ",5)=Y S R TN=0 Q . I $P(NDE,"^ ",6)=Y S R TN=0 Q I F LD=.04 D Q RTN . I $P(NDE,"^" ,2)=Y S RT N=0 Q . I $P(NDE,"^" ,3)=Y S RT N=0 Q . I $P(NDE,"^" ,5)=Y S RT N=0 Q . I $P(NDE,"^" ,6)=Y S RT N=0 Q I FL D=.05 D Q RTN . I $ P(NDE,"^", 2)=Y S RTN =0 Q . I $ P(NDE,"^", 3)=Y S RTN =0 Q . I $ P(NDE,"^", 4)=Y S RTN =0 Q . I $ P(NDE,"^", 6)=Y S RTN =0 Q I FLD =.06 D Q RTN . I $P (NDE,"^",2 )=Y S RTN= 0 Q . I $P (NDE,"^",3 )=Y S RTN= 0 Q . I $P (NDE,"^",4 )=Y S RTN= 0 Q . I $P (NDE,"^",5 )=Y S RTN= 0 Q Q RTN ; | |
| 3504 | ||
| 3505 | ||
| 3506 | Routines | |
| 3507 | Activities | |
| 3508 | Routine Na me | |
| 3509 | IBCU7B | |
| 3510 | Enhancemen t Category | |
| 3511 | New | |
| 3512 | Modify | |
| 3513 | Delete | |
| 3514 | No Change | |
| 3515 | RTM | |
| 3516 | ||
| 3517 | Related Op tions | |
| 3518 | None | |
| 3519 | Related Ro utines | |
| 3520 | Routines “ Called By” | |
| 3521 | Routines “ Called” | |
| 3522 | ||
| 3523 | ||
| 3524 | ||
| 3525 | ||
| 3526 | Data Dicti onary (DD) Reference s | |
| 3527 | ||
| 3528 | Related Pr otocols | |
| 3529 | None | |
| 3530 | Related In tegration Control Re gistration s (ICRs) | |
| 3531 | None | |
| 3532 | Data Passi ng | |
| 3533 | Input | |
| 3534 | Output Re ference | |
| 3535 | Both | |
| 3536 | Global Re ference | |
| 3537 | Local | |
| 3538 | Input Attr ibute Name and Defin ition | |
| 3539 | Name: | |
| 3540 | Definition : | |
| 3541 | Output Att ribute Nam e and Defi nition | |
| 3542 | Name: | |
| 3543 | Definition : | |
| 3544 | Current Lo gic | |
| 3545 | IBCU7B ;AL B/DEM - LI NE LEVEL P ROVIDER US ER INPUT ; 27-SEP-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32,447**;2 1-MAR-94;B uild 80 ;; Per VHA Di rective 20 04-038, th is routine should no t be modif ied. Q ;EN ; ; N X,D IC,DIE,DR, DA,DLAYGO, PRVFUN,DIP A,Y,DO,DD, I ; ,IBPO POUT IB*2. 0*447 BI I '$D(IBLNP RV("IBCCPT ")) N IBLN PRV ; DEM ;432 - Com ing from r outine IBC CPT. S:'$G (IBFT) IBF T=$$FT^IBC EF(IBIFN) ;DEM;432 - Form Type for claim . I IBFT=3 ,$$INPAT^I BCEF(IBIFN ) Q ;WCJ *2.0*432 D on't ask l ine level providers if INPAT U B Q:(IBFT' =2)&(IBFT' =3) ;DEM;4 32 - Must be CMS-150 0 (2) or U B-04 (3) F orm Type. S:IBFT=2 P RVFUN(2)=" Rendering, Referring, Supervisin g" ;DEM;4 32 - Allow able provi der functi ons for CM S-1500. S: IBFT=3 PRV FUN(3)="Re ndering,Re ferring,Op erating,Ot her Operat ing" ;DEM ;432 - All owable pro vider func tions for UB-04. ; I B*2.0*447 BI ; F PRV FUN("CNT") =1:1:$L(PR VFUN(IBFT) ,",") S PR VFUN=$P(PR VFUN(IBFT) ,",",PRVFU N("CNT")) D I $G(IBP OPOUT) K I BPOPOUT Q F PRVFUN(" CNT")=1:1: $L(PRVFUN( IBFT),",") S PRVFUN= $P(PRVFUN( IBFT),",", PRVFUN("CN T")) D I $G(IBPOPOU T) Q . S X =$S(PRVFUN ="Renderin g":3,PRVFU N="Referri ng":1,PRVF UN="Superv ising":5,P RVFUN="Ope rating":2, 1:9) ;DEM; 432 - X=Pr ovider Fun ction Code Number. . ;I $D(IBL NPRV("IBCC PT")),X'=3 Q ; DEM;4 32 - Comin g from rou tine IBCCP T, only in terested i n RENDERIN G PROVIDER . . K DA,D O,DD . S D A(2)=IBIFN ,DA(1)=IBP ROCP ;DEM ;432 - Set up DA arr ay for cal l to FILE^ DICN. . S DIC="^DGCR (399,"_DA( 2)_",""CP" ","_DA(1)_ ",""LNPRV" "," ;DEM; 432 - Glob al root of Line Prov ider multi ple. . S D IC(0)="L" . S DIC("D R")=".01// //"_X ;DE M;432 - St uff X (pro vider func tion) into new entry . . I '$D( ^DGCR(399, DA(2),"CP" ,DA(1),"LN PRV","B",X )) D FILE^ DICN ; DEM ;432 - Add new entry . . S DA=+ $O(^DGCR(3 99,DA(2)," CP",DA(1), "LNPRV","B ",X,0)) ;D EM;432 - G et DA of l ine provid er entry. . S DIPA(" RF")=X ;D EM;432 - S ave provid er functio n in DIPA( "RF") for later use in call to DIE. . S DIE=DIC . K DIC,DO,D D,DR,X,Y . D DRARRY ;DEM;432 - Set up D R array fo r call to DIE. . ; . ; DEM;432 - Variabl e IBLNPRV is a flag for called code . ; that we ar e coming f rom line l evel provi der . ; us er input ( example, E XTCR^IBCEU 5). . ; . S IBLNPRV= 1 . ; pres erve DA va lues . S I BLNPRV("LN PRVIEN")=D A ;DEM;43 2 - DA of line provi der entry to edit. . S IBLNPRV ("PROCIEN" )=DA(1) ;D EM;432 - D A(1) is pr ocedure co de multipl e IEN. . S DLAYGO=39 9 ;DEM;432 - Set DLA YGO. . D ^ DIE . ; IB *2.0*447 B I Changed to correct for empty provider types in g lobal. . ; I ($G(Y)=" ^")!($G(Y) =-1) S IBP OPOUT=1 Q ; User ent ered caret ("^"), so exit line provider entry. . I ($D(Y)) S IBPOPOUT= 1 ; User e ntered car et ("^"), so exit li ne provide r entry. . ; DEM;432 - If line provider zero node exist, and no provid er, then d elete entr y. Reset D A . S DA=I BLNPRV("LN PRVIEN"),D A(1)=IBLNP RV("PROCIE N") . I $D (^DGCR(399 ,IBIFN,"CP ",IBLNPRV( "PROCIEN") ,"LNPRV",I BLNPRV("LN PRVIEN"),0 ))#10,'$P( ^DGCR(399, IBIFN,"CP" ,IBLNPRV(" PROCIEN"), "LNPRV",IB LNPRV("LNP RVIEN"),0) ,U,2) S DR =".01///@" D ^DIE . K DIC,DIE, DR,DA,X,Y, DO,DD,DLAY GO,DIPA ; DEM;432 - Clean up. . Q ; K IB LNPRV,PRVF UN ;END ; Q ;DRARRY ; Set of D R array fo r user inp ut. ; ; DE M;432 - DI E uses DR to execute individua l DR array elements, so ; need to leave DR(1,399.0 404) undef ined for D IE to move ; DR stri ng into DR (1,399.040 4). ; ; No te: 'B' li ne tags re present DR string br anching. ; ; 399.040 4,.01 LINE FUNCTION. ; Stuff v alue from FILE^DICN add above (DIPA("RF" )) into .0 1 field. ; Also, nee d to set u p DIPA("I# ") array f rom claim level for later refe rence in D R array. S DR=".01// /^S X=DIPA (""RF"");K DIPA S DI PA(""RF"") =X,DIPA("" I1"")=$D(^ DGCR(399,D A(2),""I1" ")),DIPA(" "I2"")=$D( ^(""I2"")) ,DIPA(""I3 "")=$D(^(" "I3""))" ; ; 399.040 4,.02 LINE PERFORMED BY. ; If no provide r entered by user, t hen delete entry (ac complished by ; dele ting .01 f ield, LINE FUNCTION field). ; Branch to end (@499) if no pro vider ente red. ;S:'$ D(IBLNPRV( "IBCCPT")) DR(1,399. 0404,1)=". 02"_PRVFUN _$S(PRVFUN '["Operati ng":" Prov ider",1:" Physician" )_";S:X DI PA(""PRF"" )=X,Y=""@4 "";.01///@ ;S Y=""@49 9""" ;S:$D (IBLNPRV(" IBCCPT")) DR(1,399.0 404,1)=".0 2///"_IBLN PRV("IBCCP T")_";.02R endering;S :X DIPA("" PRF"")=X,Y =""@4"";.0 1///@;S Y= ""@499""" S DR(1,399 .0404,1)=" " S:$D(IBL NPRV("IBCC PT"))&(PRV FUN["Rende ring") DR( 1,399.0404 ,1)=".02// /"_IBLNPRV ("IBCCPT") _";" S DR( 1,399.0404 ,1)=DR(1,3 99.0404,1) _".02"_PRV FUN_$S(PRV FUN'["Oper ating":" P rovider",1 :" Physici an")_";S:X DIPA(""PR F"")=X,Y=" "@4"";.01/ //@;S Y="" @499""" ; Branch to @48 if VA PROVIDER. ; IF Non-V A PROVIDER , then fil e changes to IB NON/ OTHER VA B ILLING PRO VIDER File (#355.93) for user input. ; D R string s yntax ";^3 55.93^IBA( 355.93," a ccomplishe s variable pointer f ile change . ; See DR array DR( 2,355.93) and DR(2,3 55.93,SEQ #) below f or details . ; S DR(1 ,399.0404, 2)="@4;N Z 1 S Z1=$P( $G(^DGCR(3 99,DA(2)," "CP"",DA(1 ),""LNPRV" ",DA,0)),U ,2) S DIPA (""NVA_PRV "")=$S(Z1[ ""IBA(355. 93"":+Z1,1 :0) S X=+X I DIPA("" NVA_PRV"") =0 S Y=""@ 48""" S DR (1,399.040 4,3)="S:$D (^XUSEC("" IB PROVIDE R EDIT"",D UZ)) DLAYG O=355.93;^ 355.93^IBA (355.93," ;NVAPRV ; Start of u ser input into IB NO N/OTHER VA BILLING P ROVIDER Fi le (#355.9 3). ; S DR (2,355.93) ="S DIPA(" "NVA_PRV-0 "")=$G(^IB A(355.93,D IPA(""NVA_ PRV""),0)) " ; ; Bran ch to @42 if PROVIDE R TYPE equ als '1' FO R FACILITY /GROUP. ; Branch to @41 if CRE DENTIALS a re not NUL L. S DR(2, 355.93,1)= "S:$P(DIPA (""NVA_PRV -0""),U,2) =1 Y=""@42 "";S:$P(DI PA(""NVA_P RV-0""),U, 3)'="""" Y =""@41""" ; ; 355.93 ,.03 CREDE NTIALS. S DR(2,355.9 3)="S DIPA (""NVA_PRV -0"")=$G(^ IBA(355.93 ,DIPA(""NV A_PRV""),0 ))" ; ; Br anch to @4 2 if PROVI DER TYPE e quals '1' FOR FACILI TY/GROUP. ; Branch t o @41 if C REDENTIALS are not N ULL. S DR( 2,355.93,1 )="S:$P(DI PA(""NVA_P RV-0""),U, 2)=1 Y=""@ 42"";S:$P( DIPA(""NVA _PRV-0""), U,3)'="""" Y=""@41"" " ; ; 355. 93,.03 CRE DENTIALS. S DR(2,355 .93,2)=".0 3"B41 ; ; 355.93,.04 SPECIALTY . ; Branch to @45 if CREDENTIA LS are not NULL. S D R(2,355.93 ,3)="@41;S :$P(DIPA(" "NVA_PRV-0 ""),U,3)'= """" Y=""@ 45"";.04;S Y=""@45"" "B42 ; ; 3 55.93,.05 STREET ADD RESS. ; 35 5.93,.06 C ITY. ; 355 .93,.07 ST ATE. ; Bra nch to @43 if there is an STRE ET ADDRESS , CITY, an d STATE. S DR(2,355. 93,4)="@42 ;S:$P(DIPA (""NVA_PRV -0""),U,5) '=""""&($P (DIPA(""NV A_PRV-0"") ,U,6)'=""" ")&($P(DIP A(""NVA_PR V-0""),U,7 )'="""") Y =""@43""" ; 355.93,. 05 STREET ADDRESS. ; 355.93,.1 STREET AD DRESS LINE 2. ; 355. 93,.06 CIT Y. ; 355.9 3,.07 STAT E. ; 355.9 3,.08 ZIP CODE. S DR (2,355.93, 5)=".05;.1 ;.06;.07;. 08"B43 ; ; 355.93,.0 9 FACILITY DEFAULT I D NUMBER. ; Branch t o @44 if t here is a FACILITY D EFAULT ID NUMBER. S DR(2,355.9 3,6)="@43; S:$P(DIPA( ""NVA_PRV- 0""),U,9)' ="""" Y="" @44"";.09L AB OR FACI LITY PRIMA RY ID"B44 ; ; 355.93 ,.11 X12 T YPE OF FAC ILITY. ; B ranch to @ 45 if ther e is a X12 TYPE OF F ACILITY. S DR(2,355. 93,7)="@44 ;S:$P(DIPA (""NVA_PRV -0""),U,11 )'="""" Y= ""@45"";.1 1"B45 ; ; 355.93,41. 01 NPI. ; Branch to @46 if the re is an N PI. S DR(2 ,355.93,8) ="@45;S:$P (DIPA(""NV A_PRV-0"") ,U,14)'="" "" Y=""@46 "";D EN2^I BCEP82(DIP A(""NVA_PR V""),4)"B4 6 ; ; 355. 93,42 TAXO NOMY CODE. ; Branch to @47 if there is T AXONOMY da ta. ; 355. 93,42 TAXO NOMY CODE is a multi ple (Sub-F ile 355.93 42). We wa nt 'ALL' ; fields fr om TAXONOM Y CODE Sub -File 355. 9342. Thus , ; DR str ing S DR(4 ,355.9342) =".01:.03" below. S DR(2,355.9 3,9)="@46; S:$D(^IBA( 355.93,DIP A(""NVA_PR V""),""TAX ONOMY""))> 0 Y=""@47" ";42" S DR (3,355.934 2)=".01:.0 3"B47 ; ; End of dat a entry fo r IB NON/O THER VA BI LLING PROV IDER File (#399.53). S DR(2,35 5.93,10)=" @47" ;B48 ; ;LNPRV ; User inpu t into LIN E PROVIDER Sub-File 399.0404. ; S DR(1,3 99.0404,4) ="@48" S D R(1,399.04 04,5)="S D IK=""^DGCR (399,""_DA (2)_"",""" "CP"""","" _DA(1)_"", """"LNPRV" ""","",DIK (1)="".02" " D EN1^DI K K DIK" ; 399.0404, .15 LINE T AXONOMY. S DR(1,399. 0404,6)=". 15Line Lev el Taxonom y" S DR(1, 399.0404,7 )="D DISPT AX^IBCEP81 ($P($G(^DG CR(399,DA( 2),""CP"", DA(1),""LN PRV"",DA,0 )),U,15)," """)" S DR (1,399.040 4,8)="N Z S Z=$$EXPA ND^IBTRE(3 99.0404,.0 8,$P($G(^D GCR(399,DA (2),""CP"" ,DA(1),""L NPRV"",DA, 0)),U,8)) S DIPA(""S PC"")=$S(Z '="""":Z,1 :""UNSPECI FIED"")" S DR(1,399. 0404,9)="W !,"" Prov Specialty On File: "",DIPA("" SPC"")" S DR(1,399.0 404,10)="S DIPA(""CR D"")=$$CRE D^IBCEU($P ($G(^DGCR( 399,DA(2), ""CP"",DA( 1),""LNPRV "",DA,0)), U,2))" ; 3 99.0404,.0 3 LINE CRE DENTIALS S DR(1,399. 0404,11)=" .03;K DIPA (""W1"") S :$G(DIPA(" "CRD""))'= $P($G(^DGC R(399,DA(2 ),""CP"",D A(1),""LNP RV"",DA,0) ),U,3) DIP A(""W1"")= 1" S DR(1, 399.0404,1 2)="I $G(D IPA(""W1"" )) D WRT1^ IBCSC10H($ G(DIPA(""C RD"")))" ; Branch to @405 if F ile #399 P RIMARY NOD E is non n umeric. S DR(1,399.0 404,13)="K DIPA(""W1 "") I '$G( DIPA(""I1" ")) S Y="" @405""" ; Branching based on D IPA("EDIT" ) - DIPA(" EDIT") set in PROVID ^IBCEP2B c all S DR(1 ,399.0404, 14)="D PRO VID^IBCEP2 B(DA(2),DA ,1,.DIPA) S Y=$S(DIP A(""EDIT"" )<0:""@482 "",DIPA("" EDIT"")=1: ""@491"",D IPA(""EDIT "")=2:""@4 71"",1:""" ")"B482 ; ; Branch t o @405 if File #399 SECORDARY NODE is no n numeric. S DR(1,39 9.0404,15) ="@482;I ' $G(DIPA("" I2"")) S Y =""@405""" S DR(1,39 9.0404,16) ="D PROVID ^IBCEP2B(D A(2),DA,2, .DIPA)" ; Branching based on D IPA("EDIT" ) - DIPA(" EDIT") set in PROVID ^IBCEP2B c all. S DR( 1,399.0404 ,17)="S Y= $S(DIPA("" EDIT"")<0: ""@483"",D IPA(""EDIT "")=1:""@4 92"",DIPA( ""EDIT"")= 2:""@472"" ,1:"""")"B 483 ; ; Br anch to @4 05 if File #399 TERT IARY NODE is non num eric. S DR (1,399.040 4,18)="@48 3;I '$G(DI PA(""I3"") ) S Y=""@4 05""" S DR (1,399.040 4,19)="D P ROVID^IBCE P2B(DA(2), DA,3,.DIPA )" ; Branc hing based on DIPA(" EDIT") - D IPA("EDIT" ) set in P ROVID^IBCE P2B call. S DR(1,399 .0404,20)= "S Y=$S(DI PA(""EDIT" ")<0:""@40 5"",DIPA(" "EDIT"")=1 :""@493"", DIPA(""EDI T"")=2:""@ 473"",1:"" "");S Y="" @405"""B49 1 ; ; 399. 0404,.12 L INE PRIM I NS PROVIDE R ID TYPE. ; 399.040 4,.05 LINE PRIMARY I NS CO ID N UMBER. ; B ranch to @ 482. S DR( 1,399.0404 ,21)="@491 ;.12R~T;.0 5T;S Y=""@ 482"""B492 ; ; 399.0 404,.13 LI NE SEC INS PROVIDER ID TYPE. ; 399.0404, .06 LINE S ECONDARY I NS CO ID N UMBER. ; B ranch to @ 483. S DR( 1,399.0404 ,22)="@492 ;.13R~T;.0 6T;S Y=""@ 483"""B493 ; ; 399.0 404,.14 LI NE TERT IN S PROVIDER ID TYPE. ; 399.0404 ,.07 LINE TERTIARY I NS CO ID N UMBER. ; B ranch to @ 405. S DR( 1,399.0404 ,23)="@493 ;.14R~T;.0 7T;S Y=""@ 405"""B471 ; ; 399.0 404,.12 LI NE PRIM IN S PROVIDER ID TYPE. ; 399.0404 ,.05 LINE PRIMARY IN S CO ID NU MBER. ; Br anch to @4 82. S DR(1 ,399.0404, 24)="@471; .12////^S X=DIPA(""P RIDT"");.0 5////^S X= DIPA(""PRI D"");S Y=" "@482"""B4 72 ; ; 399 .0404,.13 LINE SEC I NS PROVIDE R ID TYPE. ; 399.040 4,.06 LINE SECONDARY INS CO ID NUMBER. ; Branch to @483. S D R(1,399.04 04,25)="@4 72;.13//// ^S X=DIPA( ""PRIDT"") ;.06////^S X=DIPA("" PRID"");S Y=""@483"" "B473 ; ; 399.0404,. 14 LINE TE RT INS PRO VIDER ID T YPE. ; 399 .0404,.07 LINE TERTI ARY INS CO ID NUMBER . ; Branch to @405. S DR(1,399 .0404,26)= "@473;.14/ ///^S X=DI PA(""PRIDT "");.07/// /^S X=DIPA (""PRID"") ;S Y=""@40 5"""B405 ; S DR(1,39 9.0404,27) ="@405" ;B 499 ; ; En d of user input @499 and W @IO F. S DR(1, 399.0404,2 8)="@499;W @IOF" Q | |
| 3546 | Modified L ogic (Chan ges are in bold) | |
| 3547 | IBCU7B ;AL B/DEM - LI NE LEVEL P ROVIDER US ER INPUT ; 27-SEP-201 0 ;;2.0;IN TEGRATED B ILLING;**4 32,447,592 **;21-MAR- 94;Build 8 0 ;;Per VH A Directiv e 2004-038 , this rou tine shoul d not be m odified. Q ;EN ; ; N X,DIC,DIE ,DR,DA,DLA YGO,PRVFUN ,DIPA,Y,DO ,DD,I ; , IBPOPOUT I B*2.0*447 BI I '$D(I BLNPRV("IB CCPT")) N IBLNPRV ; DEM;432 - Coming fr om routine IBCCPT. S :'$G(IBFT) IBFT=$$FT ^IBCEF(IBI FN) ;DEM;4 32 - Form Type for c laim. I IB FT=3,$$INP AT^IBCEF(I BIFN) Q ;WCJ*2.0*4 32 Don't a sk line le vel provid ers if INP AT UB ;JWS ;IB*2.0*59 2;Dental f orm 7 Q:(I BFT'=2)&(I BFT'=3)&(I BFT'=7) ;D EM;432 - M ust be CMS -1500 (2) or UB-04 ( 3) Form Ty pe or J430 D Dental S :IBFT=2 PR VFUN(2)="R endering,R eferring,S upervising " ;DEM;43 2 - Allowa ble provid er functio ns for CMS -1500. S:I BFT=3 PRVF UN(3)="Ren dering,Ref erring,Ope rating,Oth er Operati ng" ;DEM; 432 - Allo wable prov ider funct ions for U B-04. ;JWS ;IB*2.0*59 2;Dental f orm 7 S:IB FT=7 PRVFU N(7)="Rend ering,Refe rring,Supe rvising,As sistant Su rgeon" ; I B*2.0*447 BI ; F PRV FUN("CNT") =1:1:$L(PR VFUN(IBFT) ,",") S PR VFUN=$P(PR VFUN(IBFT) ,",",PRVFU N("CNT")) D I $G(IBP OPOUT) K I BPOPOUT Q F PRVFUN(" CNT")=1:1: $L(PRVFUN( IBFT),",") S PRVFUN= $P(PRVFUN( IBFT),",", PRVFUN("CN T")) D I $G(IBPOPOU T) Q . ;JW S;IB*2.0*5 92;Dental form 7 add Assistant Surgeon . S X=$S(PR VFUN="Rend ering":3,P RVFUN="Ref erring":1, PRVFUN="Su pervising" :5,PRVFUN= "Operating ":2,PRVFUN ="Assistan t Surgeon" :6,1:9) ;D EM;432 - X =Provider Function C ode Number . . ;I $D( IBLNPRV("I BCCPT")),X '=3 Q ; DE M;432 - Co ming from routine IB CCPT, only intereste d in RENDE RING PROVI DER. . K D A,DO,DD . S DA(2)=IB IFN,DA(1)= IBPROCP ; DEM;432 - Set up DA array for call to FI LE^DICN. . S DIC="^D GCR(399,"_ DA(2)_","" CP"","_DA( 1)_",""LNP RV""," ;D EM;432 - G lobal root of Line P rovider mu ltiple. . S DIC(0)=" L" . S DIC ("DR")=".0 1////"_X ;DEM;432 - Stuff X ( provider f unction) i nto new en try. . I ' $D(^DGCR(3 99,DA(2)," CP",DA(1), "LNPRV","B ",X)) D FI LE^DICN ; DEM;432 - Add new en try. . S D A=+$O(^DGC R(399,DA(2 ),"CP",DA( 1),"LNPRV" ,"B",X,0)) ;DEM;432 - Get DA o f line pro vider entr y. . S DIP A("RF")=X ;DEM;432 - Save pro vider func tion in DI PA("RF") f or later u se in call to DIE. . S DIE=DIC . K DIC,D O,DD,DR,X, Y . D DRAR RY ;DEM;4 32 - Set u p DR array for call to DIE. . ; . ; DEM; 432 - Vari able IBLNP RV is a fl ag for cal led code . ; that we are comin g from lin e level pr ovider . ; user inpu t (example , EXTCR^IB CEU5). . ; . S IBLNP RV=1 . ; p reserve DA values . S IBLNPRV( "LNPRVIEN" )=DA ;DEM ;432 - DA of line pr ovider ent ry to edit . . S IBLN PRV("PROCI EN")=DA(1) ;DEM;432 - DA(1) is procedure code mult iple IEN. . S DLAYGO =399 ;DEM; 432 - Set DLAYGO. . D ^DIE . ; IB*2.0*44 7 BI Chang ed to corr ect for em pty provid er types i n global. . ;I ($G(Y )="^")!($G (Y)=-1) S IBPOPOUT=1 Q ; User entered ca ret ("^"), so exit l ine provid er entry. . I ($D(Y) ) S IBPOPO UT=1 ; Use r entered caret ("^" ), so exit line prov ider entry . . ; DEM; 432 - If l ine provid er zero no de exist, and no pro vider, the n delete e ntry. Rese t DA . S D A=IBLNPRV( "LNPRVIEN" ),DA(1)=IB LNPRV("PRO CIEN") . I $D(^DGCR( 399,IBIFN, "CP",IBLNP RV("PROCIE N"),"LNPRV ",IBLNPRV( "LNPRVIEN" ),0))#10,' $P(^DGCR(3 99,IBIFN," CP",IBLNPR V("PROCIEN "),"LNPRV" ,IBLNPRV(" LNPRVIEN") ,0),U,2) S DR=".01// /@" D ^DIE . K DIC,D IE,DR,DA,X ,Y,DO,DD,D LAYGO,DIPA ;DEM;432 - Clean u p. . Q ; K IBLNPRV,P RVFUN ;END ; Q ;DRAR RY ; Set o f DR array for user input. ; ; DEM;432 - DIE uses DR to exec ute indivi dual DR ar ray elemen ts, so ; n eed to lea ve DR(1,39 9.0404) un defined fo r DIE to m ove ; DR s tring into DR(1,399. 0404). ; ; Note: 'B' line tags represent DR string branching . ; ; 399. 0404,.01 L INE FUNCTI ON. ; Stuf f value fr om FILE^DI CN add abo ve (DIPA(" RF")) into .01 field . ; Also, need to se t up DIPA( "I#") arra y from cla im level f or later r eference i n DR array . S DR=".0 1///^S X=D IPA(""RF"" );K DIPA S DIPA(""RF "")=X,DIPA (""I1"")=$ D(^DGCR(39 9,DA(2),"" I1"")),DIP A(""I2"")= $D(^(""I2" ")),DIPA(" "I3"")=$D( ^(""I3"")) " ; ; 399. 0404,.02 L INE PERFOR MED BY. ; If no prov ider enter ed by user , then del ete entry (accomplis hed by ; d eleting .0 1 field, L INE FUNCTI ON field). ; Branch to end (@4 99) if no provider e ntered. ;S :'$D(IBLNP RV("IBCCPT ")) DR(1,3 99.0404,1) =".02"_PRV FUN_$S(PRV FUN'["Oper ating":" P rovider",1 :" Physici an")_";S:X DIPA(""PR F"")=X,Y=" "@4"";.01/ //@;S Y="" @499""" ;S :$D(IBLNPR V("IBCCPT" )) DR(1,39 9.0404,1)= ".02///"_I BLNPRV("IB CCPT")_";. 02Renderin g;S:X DIPA (""PRF"")= X,Y=""@4"" ;.01///@;S Y=""@499" "" S DR(1, 399.0404,1 )="" S:$D( IBLNPRV("I BCCPT"))&( PRVFUN["Re ndering") DR(1,399.0 404,1)=".0 2///"_IBLN PRV("IBCCP T")_";" ;J WS;IB*2.0* 592;Dental - added S urgeon for Dental S DR(1,399.0 404,1)=DR( 1,399.0404 ,1)_".02"_ PRVFUN_$S( PRVFUN["Su rgeon":"", PRVFUN'["O perating": " Provider ",1:" Phys ician")_"; S:X DIPA(" "PRF"")=X, Y=""@4"";. 01///@;S Y =""@499""" ; Branch to @48 if VA PROVIDE R. ; IF No n-VA PROVI DER, then file chang es to IB N ON/OTHER V A BILLING PROVIDER F ile (#355. 93) for us er input. ; DR strin g syntax " ;^355.93^I BA(355.93, " accompli shes varia ble pointe r file cha nge. ; See DR array DR(2,355.9 3) and DR( 2,355.93,S EQ #) belo w for deta ils. ; S D R(1,399.04 04,2)="@4; N Z1 S Z1= $P($G(^DGC R(399,DA(2 ),""CP"",D A(1),""LNP RV"",DA,0) ),U,2) S D IPA(""NVA_ PRV"")=$S( Z1[""IBA(3 55.93"":+Z 1,1:0) S X =+X I DIPA (""NVA_PRV "")=0 S Y= ""@48""" S DR(1,399. 0404,3)="S :$D(^XUSEC (""IB PROV IDER EDIT" ",DUZ)) DL AYGO=355.9 3;^355.93^ IBA(355.93 ," ;NVAPRV ; Start o f user inp ut into IB NON/OTHER VA BILLIN G PROVIDER File (#35 5.93). ; S DR(2,355. 93)="S DIP A(""NVA_PR V-0"")=$G( ^IBA(355.9 3,DIPA(""N VA_PRV""), 0))" ; ; B ranch to @ 42 if PROV IDER TYPE equals '1' FOR FACIL ITY/GROUP. ; Branch to @41 if CREDENTIAL S are not NULL. S DR (2,355.93, 1)="S:$P(D IPA(""NVA_ PRV-0""),U ,2)=1 Y="" @42"";S:$P (DIPA(""NV A_PRV-0"") ,U,3)'=""" " Y=""@41" "" ; ; 355 .93,.03 CR EDENTIALS. S DR(2,35 5.93)="S D IPA(""NVA_ PRV-0"")=$ G(^IBA(355 .93,DIPA(" "NVA_PRV"" ),0))" ; ; Branch to @42 if PR OVIDER TYP E equals ' 1' FOR FAC ILITY/GROU P. ; Branc h to @41 i f CREDENTI ALS are no t NULL. S DR(2,355.9 3,1)="S:$P (DIPA(""NV A_PRV-0"") ,U,2)=1 Y= ""@42"";S: $P(DIPA("" NVA_PRV-0" "),U,3)'=" """ Y=""@4 1""" ; ; 3 55.93,.03 CREDENTIAL S. S DR(2, 355.93,2)= ".03"B41 ; ; 355.93, .04 SPECIA LTY. ; Bra nch to @45 if CREDEN TIALS are not NULL. S DR(2,355 .93,3)="@4 1;S:$P(DIP A(""NVA_PR V-0""),U,3 )'="""" Y= ""@45"";.0 4;S Y=""@4 5"""B42 ; ; 355.93,. 05 STREET ADDRESS. ; 355.93,.0 6 CITY. ; 355.93,.07 STATE. ; Branch to @43 if the re is an S TREET ADDR ESS, CITY, and STATE . S DR(2,3 55.93,4)=" @42;S:$P(D IPA(""NVA_ PRV-0""),U ,5)'=""""& ($P(DIPA(" "NVA_PRV-0 ""),U,6)'= """")&($P( DIPA(""NVA _PRV-0""), U,7)'="""" ) Y=""@43" "" ; 355.9 3,.05 STRE ET ADDRESS . ; 355.93 ,.1 STREET ADDRESS L INE 2. ; 3 55.93,.06 CITY. ; 35 5.93,.07 S TATE. ; 35 5.93,.08 Z IP CODE. S DR(2,355. 93,5)=".05 ;.1;.06;.0 7;.08"B43 ; ; 355.93 ,.09 FACIL ITY DEFAUL T ID NUMBE R. ; Branc h to @44 i f there is a FACILIT Y DEFAULT ID NUMBER. S DR(2,35 5.93,6)="@ 43;S:$P(DI PA(""NVA_P RV-0""),U, 9)'="""" Y =""@44"";. 09LAB OR F ACILITY PR IMARY ID"B 44 ; ; 355 .93,.11 X1 2 TYPE OF FACILITY. ; Branch t o @45 if t here is a X12 TYPE O F FACILITY . S DR(2,3 55.93,7)=" @44;S:$P(D IPA(""NVA_ PRV-0""),U ,11)'="""" Y=""@45"" ;.11"B45 ; ; 355.93, 41.01 NPI. ; Branch to @46 if there is a n NPI. S D R(2,355.93 ,8)="@45;S :$P(DIPA(" "NVA_PRV-0 ""),U,14)' ="""" Y="" @46"";D EN 2^IBCEP82( DIPA(""NVA _PRV""),4) "B46 ; ; 3 55.93,42 T AXONOMY CO DE. ; Bran ch to @47 if there i s TAXONOMY data. ; 3 55.93,42 T AXONOMY CO DE is a mu ltiple (Su b-File 355 .9342). We want 'ALL ' ; fields from TAXO NOMY CODE Sub-File 3 55.9342. T hus, ; DR string S D R(4,355.93 42)=".01:. 03" below. S DR(2,35 5.93,9)="@ 46;S:$D(^I BA(355.93, DIPA(""NVA _PRV""),"" TAXONOMY"" ))>0 Y=""@ 47"";42" S DR(3,355. 9342)=".01 :.03"B47 ; ; End of data entry for IB NO N/OTHER VA BILLING P ROVIDER Fi le (#399.5 3). S DR(2 ,355.93,10 )="@47" ;B 48 ; ;LNPR V ; User i nput into LINE PROVI DER Sub-Fi le 399.040 4. ; S DR( 1,399.0404 ,4)="@48" S DR(1,399 .0404,5)=" S DIK=""^D GCR(399,"" _DA(2)_"", """"CP"""" ,""_DA(1)_ "",""""LNP RV"""","", DIK(1)="". 02"" D EN1 ^DIK K DIK " ; 399.04 04,.15 LIN E TAXONOMY . S DR(1,3 99.0404,6) =".15Line Level Taxo nomy" S DR (1,399.040 4,7)="D DI SPTAX^IBCE P81($P($G( ^DGCR(399, DA(2),""CP "",DA(1)," "LNPRV"",D A,0)),U,15 ),"""")" S DR(1,399. 0404,8)="N Z S Z=$$E XPAND^IBTR E(399.0404 ,.08,$P($G (^DGCR(399 ,DA(2),""C P"",DA(1), ""LNPRV"", DA,0)),U,8 )) S DIPA( ""SPC"")=$ S(Z'="""": Z,1:""UNSP ECIFIED"") " S DR(1,3 99.0404,9) ="W !,"" P rov Specia lty On Fil e: "",DIPA (""SPC"")" S DR(1,39 9.0404,10) ="S DIPA(" "CRD"")=$$ CRED^IBCEU ($P($G(^DG CR(399,DA( 2),""CP"", DA(1),""LN PRV"",DA,0 )),U,2))" ; 399.0404 ,.03 LINE CREDENTIAL S S DR(1,3 99.0404,11 )=".03;K D IPA(""W1"" ) S:$G(DIP A(""CRD"") )'=$P($G(^ DGCR(399,D A(2),""CP" ",DA(1),"" LNPRV"",DA ,0)),U,3) DIPA(""W1" ")=1" S DR (1,399.040 4,12)="I $ G(DIPA(""W 1"")) D WR T1^IBCSC10 H($G(DIPA( ""CRD""))) " ; Branch to @405 i f File #39 9 PRIMARY NODE is no n numeric. S DR(1,39 9.0404,13) ="K DIPA(" "W1"") I ' $G(DIPA("" I1"")) S Y =""@405""" ; Branchi ng based o n DIPA("ED IT") - DIP A("EDIT") set in PRO VID^IBCEP2 B call S D R(1,399.04 04,14)="D PROVID^IBC EP2B(DA(2) ,DA,1,.DIP A) S Y=$S( DIPA(""EDI T"")<0:""@ 482"",DIPA (""EDIT"") =1:""@491" ",DIPA(""E DIT"")=2:" "@471"",1: """")"B482 ; ; Branc h to @405 if File #3 99 SECORDA RY NODE is non numer ic. S DR(1 ,399.0404, 15)="@482; I '$G(DIPA (""I2"")) S Y=""@405 """ S DR(1 ,399.0404, 16)="D PRO VID^IBCEP2 B(DA(2),DA ,2,.DIPA)" ; Branchi ng based o n DIPA("ED IT") - DIP A("EDIT") set in PRO VID^IBCEP2 B call. S DR(1,399.0 404,17)="S Y=$S(DIPA (""EDIT"") <0:""@483" ",DIPA(""E DIT"")=1:" "@492"",DI PA(""EDIT" ")=2:""@47 2"",1:"""" )"B483 ; ; Branch to @405 if F ile #399 T ERTIARY NO DE is non numeric. S DR(1,399. 0404,18)=" @483;I '$G (DIPA(""I3 "")) S Y=" "@405""" S DR(1,399. 0404,19)=" D PROVID^I BCEP2B(DA( 2),DA,3,.D IPA)" ; Br anching ba sed on DIP A("EDIT") - DIPA("ED IT") set i n PROVID^I BCEP2B cal l. S DR(1, 399.0404,2 0)="S Y=$S (DIPA(""ED IT"")<0:"" @405"",DIP A(""EDIT"" )=1:""@493 "",DIPA("" EDIT"")=2: ""@473"",1 :"""");S Y =""@405""" B491 ; ; 3 99.0404,.1 2 LINE PRI M INS PROV IDER ID TY PE. ; 399. 0404,.05 L INE PRIMAR Y INS CO I D NUMBER. ; Branch t o @482. S DR(1,399.0 404,21)="@ 491;.12R~T ;.05T;S Y= ""@482"""B 492 ; ; 39 9.0404,.13 LINE SEC INS PROVID ER ID TYPE . ; 399.04 04,.06 LIN E SECONDAR Y INS CO I D NUMBER. ; Branch t o @483. S DR(1,399.0 404,22)="@ 492;.13R~T ;.06T;S Y= ""@483"""B 493 ; ; 39 9.0404,.14 LINE TERT INS PROVI DER ID TYP E. ; 399.0 404,.07 LI NE TERTIAR Y INS CO I D NUMBER. ; Branch t o @405. S DR(1,399.0 404,23)="@ 493;.14R~T ;.07T;S Y= ""@405"""B 471 ; ; 39 9.0404,.12 LINE PRIM INS PROVI DER ID TYP E. ; 399.0 404,.05 LI NE PRIMARY INS CO ID NUMBER. ; Branch to @482. S D R(1,399.04 04,24)="@4 71;.12//// ^S X=DIPA( ""PRIDT"") ;.05////^S X=DIPA("" PRID"");S Y=""@482"" "B472 ; ; 399.0404,. 13 LINE SE C INS PROV IDER ID TY PE. ; 399. 0404,.06 L INE SECOND ARY INS CO ID NUMBER . ; Branch to @483. S DR(1,399 .0404,25)= "@472;.13/ ///^S X=DI PA(""PRIDT "");.06/// /^S X=DIPA (""PRID"") ;S Y=""@48 3"""B473 ; ; 399.040 4,.14 LINE TERT INS PROVIDER I D TYPE. ; 399.0404,. 07 LINE TE RTIARY INS CO ID NUM BER. ; Bra nch to @40 5. S DR(1, 399.0404,2 6)="@473;. 14////^S X =DIPA(""PR IDT"");.07 ////^S X=D IPA(""PRID "");S Y="" @405"""B40 5 ; S DR(1 ,399.0404, 27)="@405" ;B499 ; ; End of us er input @ 499 and W @IOF. S DR (1,399.040 4,28)="@49 9;W @IOF" Q | |
| 3548 | ||
| 3549 | Routines | |
| 3550 | Activities | |
| 3551 | Routine Na me | |
| 3552 | IBCU82 | |
| 3553 | Enhancemen t Category | |
| 3554 | New | |
| 3555 | Modify | |
| 3556 | Delete | |
| 3557 | No Change | |
| 3558 | RTM | |
| 3559 | ||
| 3560 | Related Op tions | |
| 3561 | None | |
| 3562 | Related Ro utines | |
| 3563 | Routines “ Called By” | |
| 3564 | Routines “ Called” | |
| 3565 | ||
| 3566 | ||
| 3567 | ||
| 3568 | ||
| 3569 | Data Dicti onary (DD) Reference s | |
| 3570 | ||
| 3571 | Related Pr otocols | |
| 3572 | None | |
| 3573 | Related In tegration Control Re gistration s (ICRs) | |
| 3574 | None | |
| 3575 | Data Passi ng | |
| 3576 | Input | |
| 3577 | Output Re ference | |
| 3578 | Both | |
| 3579 | Global Re ference | |
| 3580 | Local | |
| 3581 | Input Attr ibute Name and Defin ition | |
| 3582 | Name: | |
| 3583 | Definition : | |
| 3584 | Output Att ribute Nam e and Defi nition | |
| 3585 | Name: | |
| 3586 | Definition : | |
| 3587 | Current Lo gic | |
| 3588 | IBCU82 ;AL B/ARH - TH IRD PARTY BILLING UT ILITIES (A UTOMATED B ILLER) ;02 JUL 93 ;; 2.0;INTEGR ATED BILLI NG;**43,55 ,91,124,16 0,304,347, 432**;21-M AR-94;Buil d 192 ;;Pe r VHA Dire ctive 2004 -038, this routine s hould not be modifie d. ; ;EVNT CHK(IBTRN) ;special checks to determine if event s hould be a uto billed ;checks f or INS, no n-veteran patient, p ossible wo rkers comp and tort feasor, ad mitted for sc cond., outp dent al stop, o ptv while inpt, cate gory cover ed by ins, non-billa ble stop o r clinic ; (assumes t hat Claims Tracking does the S C check fo r Outpatie nts) ;inpu t: IBTRN - claims tr acking eve nt ; DISP - if true then any e rror messa ge will be displayed on exit. ;output: r eturns "1^ error mess age" if on e of the c hecks fail ed, 0 othe rwise ; N X,IBX,IBY, IBZ,IBTRND ,IBCAT,IBC OV,DFN,IBE VDT,VAEL,V ADMVT,VAIN DT S X=0,I BTRND=$G(^ IBT(356,+$ G(IBTRN),0 )) G:IBTRN D="" EVNTC Q I +$P(IB TRND,U,18) =1,'+$P(IB TRND,U,5) S X="1^Cla ims Tracki ng event d oes not ha ve an asso ciated Inp atient Adm ission." G EVNTCQ I +$P(IBTRND ,U,18)=2,' +$P(IBTRND ,U,4) S X= "1^Claims Tracking e vent does not have a n associat ed Outpati ent Visit. " G EVNTCQ I +$P(IBT RND,U,18)= 4,'+$P(IBT RND,U,8) S X="1^Clai ms Trackin g event do es not hav e an assoc iated pres cription i n Pharmacy ." G EVNTC Q I +$P(IB TRND,U,18) =4,$P(IBTR ND,U,10)=" " S X="1^C laims Trac king event does not have an as sociated p rescriptio n refill i n Pharmacy ." G EVNTC Q ; S DFN= +$P(IBTRND ,U,2),IBEV DT=$P(IBTR ND,U,6) I '$$INSURED ^IBCNS1(DF N,IBEVDT) S X="1^Pat ient not i nsured for event dat e." G EVNT CQ ; Check filing ti meframe I '$$PTFTF^I BCNSU31(DF N,IBEVDT) S X="1^Fil ing timefr ame not me t" G EVNTC Q S IBCAT= $S($P(IBTR ND,U,18)=1 !($P(IBTRN D,U,18)=5) :"INPATIEN T",$P(IBTR ND,U,18)=2 :"OUTPATIE NT",$P(IBT RND,U,18)= 4:"PHARMAC Y",1:"") I IBCAT'="" ,'$$PTCOV^ IBCNSU3(DF N,IBEVDT,I BCAT) S X= "1^Patient insurance does not cover "_IB CAT_"." G EVNTCQ D E LIG^VADPT S X=0 I 'V AEL(4) S X ="1^Patien t is not a veteran." G EVNTCQ ; ;check t he last di sposition before the episode t o see if m aybe worke rs comp or tort feas or S IBX=9 999999-(IB EVDT\1+1), IBX=$O(^DP T(+DFN,"DI S",IBX)) I +IBX S IB Y=$$DT(IBX ),IBX=$G(^ DPT(DFN,"D IS",IBX,2) ) D G:+X EVNTCQ . I $P(IBX,U, 1)="Y" S X ="1^Need m ay be rela ted to occ upation, c heck "_IBY _" disposi tion." Q . I $P(IBX, U,4)="Y" S X="1^Need may be re lated to a n accident , check "_ IBY_" disp osition." Q ; I +$P( IBTRND,U,5 ) S IBX=$G (^DGPM(+$P (IBTRND,U, 5),0)) D G EVNTCQ ; inpatient specific . I IBX="" S X="1^In patient ad mission mo vement not found." Q . I +$P(I BX,U,11) S X="1^Admi tted for a n SC condi tion." Q ; I +$P(IBT RND,U,4) S IBX=$$SCE ^IBSDU(+$P (IBTRND,U, 4)) D G E VNTCQ ; ou tpatient s pecific . I IBX="" S X="1^Outp atient Enc ounter not found." Q . S IBY=$ $NBOE^IBCU 81(+$P(IBT RND,U,4),I BX) I +IBY D Q:+X . . ;I +IBY= 1 S X="1^S ervice Con nected vis it." Q .. I +IBY=2 S X="1^Non- billable S top Code." Q .. I +I BY=3 S X=" 1^Non-bill able Clini c." Q .. I +IBY=4 S X="1^Non-b illable St atus: "_$P (IBY,U,2) Q . ; dent al is gene rally bill ed differe ntly . I $ P($G(^DIC( 40.7,+$P(I BX,U,3),0) ),U,1)["DE NTAL" S X= "1^Outpati ent visit contains a dental st op code." Q . ;outpa tient visi t was a di sposition: applicati on without exam is n ot billabl e . I $P(I BX,U,8)=3 D Q:X .. S IBY=$$DI SND^IBSDU( +$P(IBTRND ,U,4),IBX) ; 0-node of "DIS" . . I $P(IBY ,U,2)=2 S X="1^Dispo sition was Applicati on Without Exam." Q .. I $P($G (^DIC(37,+ $P(IBY,U,7 ),0)),U,1) ="CANCEL W ITHOUT EXA M" S X="1^ Dispositio n was Canc el Without Exam." Q . ;can not bill twic e for same day so ig nore outpa tient visi ts if pati ent was an inpatient at end of day (this means tha t outpatie nt visits on the dat e of disch arge will be billed) . I $$ADM ^IBCU64(DF N,IBEVDT) S X="1^Not Billable: Patient w as an inpa tient on t his visit date." ; I +$P(IBTRN D,U,8) S I BX=$$RXZER O^IBRXUTL( +$P(IBTRND ,U,2),+$P( IBTRND,U,8 )) D G EV NTCQ ; rx refills . I IBX="" S X="1^Pres cription n ot found i n Pharmacy ." Q . I + $P(IBTRND, U,10)>0 S IBY=$$ZERO SUB^IBRXUT L(+$P(IBTR ND,U,2),+$ P(IBTRND,U ,8),+$P(IB TRND,U,10) ) I IBY="" S X="1^Pr escription refill no t found in Pharmacy. " Q . S IB Z=$$DBLCHK ^IBTRKR31( IBTRN) I ' IBZ S X="1 ^Can not a uto bill t his refill , check Cl aims Track ing." QEVN TCQ Q X ;D T(X) ;conv ert dispos ition type date/time to extern al format (9999999-d ate) N Y S Y=0 I +X S Y=999999 9-X X ^DD( "DD") Q Y | |
| 3589 | Modified L ogic (Chan ges are in bold) | |
| 3590 | IBCU82 ;AL B/ARH - TH IRD PARTY BILLING UT ILITIES (A UTOMATED B ILLER) ;02 JUL 93 ;; 2.0;INTEGR ATED BILLI NG;**43,55 ,91,124,16 0,304,347, 432,592**; 21-MAR-94; Build 192 ;;Per VHA Directive 2004-038, this routi ne should not be mod ified. ; ; EVNTCHK(IB TRN) ;spec ial checks to determ ine if eve nt should be auto bi lled ;chec ks for INS , non-vete ran patien t, possibl e workers comp and t ort feasor , admitted for sc co nd., outp dental sto p, optv wh ile inpt, category c overed by ins, non-b illable st op or clin ic ;(assum es that Cl aims Track ing does t he SC chec k for Outp atients) ; input: IBT RN - claim s tracking event ; D ISP - if t rue then a ny error m essage wil l be displ ayed on ex it. ;outpu t: returns "1^error message" i f one of t he checks failed, 0 otherwise ; N X,IBX, IBY,IBZ,IB TRND,IBCAT ,IBCOV,DFN ,IBEVDT,VA EL,VADMVT, VAINDT S X =0,IBTRND= $G(^IBT(35 6,+$G(IBTR N),0)) G:I BTRND="" E VNTCQ I +$ P(IBTRND,U ,18)=1,'+$ P(IBTRND,U ,5) S X="1 ^Claims Tr acking eve nt does no t have an associated Inpatient Admission ." G EVNTC Q I +$P(IB TRND,U,18) =2,'+$P(IB TRND,U,4) S X="1^Cla ims Tracki ng event d oes not ha ve an asso ciated Out patient Vi sit." G EV NTCQ I +$P (IBTRND,U, 18)=4,'+$P (IBTRND,U, 8) S X="1^ Claims Tra cking even t does not have an a ssociated prescripti on in Phar macy." G E VNTCQ I +$ P(IBTRND,U ,18)=4,$P( IBTRND,U,1 0)="" S X= "1^Claims Tracking e vent does not have a n associat ed prescri ption refi ll in Phar macy." G E VNTCQ ; S DFN=+$P(IB TRND,U,2), IBEVDT=$P( IBTRND,U,6 ) I '$$INS URED^IBCNS 1(DFN,IBEV DT) S X="1 ^Patient n ot insured for event date." G EVNTCQ ; C heck filin g timefram e I '$$PTF TF^IBCNSU3 1(DFN,IBEV DT) S X="1 ^Filing ti meframe no t met" G E VNTCQ S IB CAT=$S($P( IBTRND,U,1 8)=1!($P(I BTRND,U,18 )=5):"INPA TIENT",$P( IBTRND,U,1 8)=2:"OUTP ATIENT",$P (IBTRND,U, 18)=4:"PHA RMACY",1:" ") I IBCAT '="",'$$PT COV^IBCNSU 3(DFN,IBEV DT,IBCAT) S X="1^Pat ient insur ance does not cover "_IBCAT_". " G EVNTCQ D ELIG^VA DPT S X=0 I 'VAEL(4) S X="1^Pa tient is n ot a veter an." G EVN TCQ ; ;che ck the las t disposit ion before the episo de to see if maybe w orkers com p or tort feasor S I BX=9999999 -(IBEVDT\1 +1),IBX=$O (^DPT(+DFN ,"DIS",IBX )) I +IBX S IBY=$$DT (IBX),IBX= $G(^DPT(DF N,"DIS",IB X,2)) D G :+X EVNTCQ . I $P(IB X,U,1)="Y" S X="1^Ne ed may be related to occupatio n, check " _IBY_" dis position." Q . I $P( IBX,U,4)=" Y" S X="1^ Need may b e related to an acci dent, chec k "_IBY_" dispositio n." Q ; I +$P(IBTRND ,U,5) S IB X=$G(^DGPM (+$P(IBTRN D,U,5),0)) D G EVNT CQ ; inpat ient speci fic . I IB X="" S X=" 1^Inpatien t admissio n movement not found ." Q . I + $P(IBX,U,1 1) S X="1^ Admitted f or an SC c ondition." Q ; I +$P (IBTRND,U, 4) S IBX=$ $SCE^IBSDU (+$P(IBTRN D,U,4)) D G EVNTCQ ; outpatie nt specifi c . I IBX= "" S X="1^ Outpatient Encounter not found ." Q . S I BY=$$NBOE^ IBCU81(+$P (IBTRND,U, 4),IBX) I +IBY D Q: +X .. ;I + IBY=1 S X= "1^Service Connected visit." Q .. I +IBY =2 S X="1^ Non-billab le Stop Co de." Q .. I +IBY=3 S X="1^Non- billable C linic." Q .. I +IBY= 4 S X="1^N on-billabl e Status: "_$P(IBY,U ,2) Q . ; dental is generally billed dif ferently . ;JWS;IB*2 .0*592;US1 109;allow dental eve nts to be processed and billed . . ;;I $P ($G(^DIC(4 0.7,+$P(IB X,U,3),0)) ,U,1)["DEN TAL" S X=" 1^Outpatie nt visit c ontains a dental sto p code." Q . ;JWS;IB *2.0*592;U SXXXX;adde d ability to turn of f Dental C laims proc essing in site param eters . I $P(^IBE(35 0.9,1,8),U ,20)=0 S X ="1^Dental Claims pr ocessing i s disabled in IB Sit e Paramete rs." Q . ; outpatient visit was a disposi tion: appl ication wi thout exam is not bi llable . I $P(IBX,U, 8)=3 D Q: X .. S IBY =$$DISND^I BSDU(+$P(I BTRND,U,4) ,IBX) ; 0- node of "D IS" .. I $ P(IBY,U,2) =2 S X="1^ Dispositio n was Appl ication Wi thout Exam ." Q .. I $P($G(^DIC (37,+$P(IB Y,U,7),0)) ,U,1)="CAN CEL WITHOU T EXAM" S X="1^Dispo sition was Cancel Wi thout Exam ." Q . ;ca n not bill twice for same day so ignore outpatient visits if patient w as an inpa tient at e nd of day (this mean s that out patient vi sits on th e date of discharge will be bi lled) . I $$ADM^IBCU 64(DFN,IBE VDT) S X=" 1^Not Bill able: Pati ent was an inpatient on this v isit date. " ; I +$P( IBTRND,U,8 ) S IBX=$$ RXZERO^IBR XUTL(+$P(I BTRND,U,2) ,+$P(IBTRN D,U,8)) D G EVNTCQ ; rx refil ls . I IBX ="" S X="1 ^Prescript ion not fo und in Pha rmacy." Q . I +$P(IB TRND,U,10) >0 S IBY=$ $ZEROSUB^I BRXUTL(+$P (IBTRND,U, 2),+$P(IBT RND,U,8),+ $P(IBTRND, U,10)) I I BY="" S X= "1^Prescri ption refi ll not fou nd in Phar macy." Q . S IBZ=$$D BLCHK^IBTR KR31(IBTRN ) I 'IBZ S X="1^Can not auto b ill this r efill, che ck Claims Tracking." QEVNTCQ Q X ;DT(X) ;convert d isposition type date /time to e xternal fo rmat (9999 999-date) N Y S Y=0 I +X S Y=9 999999-X X ^DD("DD") Q Y | |
| 3591 | ||
| 3592 | Routines | |
| 3593 | Activities | |
| 3594 | Routine Na me | |
| 3595 | IBCU9 | |
| 3596 | Enhancemen t Category | |
| 3597 | New | |
| 3598 | Modify | |
| 3599 | Delete | |
| 3600 | No Change | |
| 3601 | RTM | |
| 3602 | ||
| 3603 | Related Op tions | |
| 3604 | None | |
| 3605 | Related Ro utines | |
| 3606 | Routines “ Called By” | |
| 3607 | Routines “ Called” | |
| 3608 | ||
| 3609 | ||
| 3610 | ||
| 3611 | ||
| 3612 | Data Dicti onary (DD) Reference s | |
| 3613 | ||
| 3614 | Related Pr otocols | |
| 3615 | None | |
| 3616 | Related In tegration Control Re gistration s (ICRs) | |
| 3617 | None | |
| 3618 | Data Passi ng | |
| 3619 | Input | |
| 3620 | Output Re ference | |
| 3621 | Both | |
| 3622 | Global Re ference | |
| 3623 | Local | |
| 3624 | Input Attr ibute Name and Defin ition | |
| 3625 | Name: | |
| 3626 | Definition : | |
| 3627 | Output Att ribute Nam e and Defi nition | |
| 3628 | Name: | |
| 3629 | Definition : | |
| 3630 | Current Lo gic | |
| 3631 | IBCU9 ;ALB /BI - BILL ING UTILIT Y ROUTINE (CONTINUED ) ;01 JUL 2011 11:13 ;;2.0;INT EGRATED BI LLING;**44 7**;01-JUL -2011;Buil d 80 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . Q ;CMAED ALL(IBIEN) ; Clear a ll manuall y edited f lags for a claim. N IBRCIEN S IBRCIEN=0 F S IBRCI EN=$O(^DGC R(399,IBIE N,"RC",IBR CIEN)) Q:+ IBRCIEN=0 D . D CMAE DIND(IBIEN ,IBRCIEN) Q ;CMAEDIN D(IBIEN,IB RCIEN) ; C lear indiv idual manu ally edite d flags fo r a revenu e code. S $P(^DGCR(3 99,IBIEN," RC",IBRCIE N,0),U,16) ="" Q ;FRO MPROC(IBIE N,IBCPIEN, IBFLG) ; C lear indiv idual manu ally edite d flag if procedures match. I $G(IBIEN)= "" Q I $G( IBCPIEN)=" " Q I $G(I BFLG)="" Q I IBFLG=" E",IBCPIEN =$O(^DGCR( 399,IBIEN, "CP",0)) D CMAEDALL( IBIEN) Q I IBFLG="D" ,IBCPIEN=$ O(^DGCR(39 9,IBIEN,"C P",0)) D P ROC1DEL(IB IEN) Q N I BRC0,IBRCP RSP N IBRC IEN S IBRC IEN=0 F S IBRCIEN=$ O(^DGCR(39 9,IBIEN,"R C",IBRCIEN )) Q:+IBRC IEN=0 D . S IBRC0=$G (^DGCR(399 ,IBIEN,"RC ",IBRCIEN, 0)),IBRCPR SP=$P(IBRC 0,U,11) . I IBRCPRSP =IBCPIEN D CMAEDIND( IBIEN,IBRC IEN) Q ;PR OC1DEL(IBI EN) ; The first proc edure was deleted, d etermine d ivision ch ange. N IB CPIEN1,IBC PIEN2 S IB CPIEN1=$O( ^DGCR(399, IBIEN,"CP" ,0)) I IBC PIEN1="" Q S IBCPIEN 2=$O(^DGCR (399,IBIEN ,"CP",IBCP IEN1)) I I BCPIEN2="" D CMAEDAL L(IBIEN) Q I $P($G(^ DGCR(399,I BIEN,"CP", IBCPIEN1,0 )),U,6)'=$ P($G(^DGCR (399,IBIEN ,"CP",IBCP IEN2,0)),U ,6) D CMAE DALL(IBIEN ) Q | |
| 3632 | Modified L ogic (Chan ges are in bold) | |
| 3633 | IBCU9 ;ALB /BI - BILL ING UTILIT Y ROUTINE (CONTINUED ) ;01 JUL 2011 11:13 ;;2.0;INT EGRATED BI LLING;**44 7,592**;01 -JUL-2011; Build 80 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. Q ;C MAEDALL(IB IEN) ; Cle ar all man ually edit ed flags f or a claim . N IBRCIE N S IBRCIE N=0 F S I BRCIEN=$O( ^DGCR(399, IBIEN,"RC" ,IBRCIEN)) Q:+IBRCIE N=0 D . D CMAEDIND(I BIEN,IBRCI EN) Q ;CMA EDIND(IBIE N,IBRCIEN) ; Clear i ndividual manually e dited flag s for a re venue code . S $P(^DG CR(399,IBI EN,"RC",IB RCIEN,0),U ,16)="" Q ;FROMPROC( IBIEN,IBCP IEN,IBFLG) ; Clear i ndividual manually e dited flag if proced ures match . I $G(IBI EN)="" Q I $G(IBCPIE N)="" Q I $G(IBFLG)= "" Q I IBF LG="E",IBC PIEN=$O(^D GCR(399,IB IEN,"CP",0 )) D CMAED ALL(IBIEN) Q I IBFLG ="D",IBCPI EN=$O(^DGC R(399,IBIE N,"CP",0)) D PROC1DE L(IBIEN) Q N IBRC0,I BRCPRSP N IBRCIEN S IBRCIEN=0 F S IBRCI EN=$O(^DGC R(399,IBIE N,"RC",IBR CIEN)) Q:+ IBRCIEN=0 D . S IBRC 0=$G(^DGCR (399,IBIEN ,"RC",IBRC IEN,0)),IB RCPRSP=$P( IBRC0,U,11 ) . I IBRC PRSP=IBCPI EN D CMAED IND(IBIEN, IBRCIEN) Q ;PROC1DEL (IBIEN) ; The first procedure was delete d, determi ne divisio n change. N IBCPIEN1 ,IBCPIEN2 S IBCPIEN1 =$O(^DGCR( 399,IBIEN, "CP",0)) I IBCPIEN1= "" Q S IBC PIEN2=$O(^ DGCR(399,I BIEN,"CP", IBCPIEN1)) I IBCPIEN 2="" D CMA EDALL(IBIE N) Q I $P( $G(^DGCR(3 99,IBIEN," CP",IBCPIE N1,0)),U,6 )'=$P($G(^ DGCR(399,I BIEN,"CP", IBCPIEN2,0 )),U,6) D CMAEDALL(I BIEN) Q ; ;JWS;IB*2. 0*592;US11 09 DentalF TINPUT(Y) ;SCREEN FO R 399, .19 FORM TYPE N Z I Y=7 ,$P($G(^IB E(350.9,1, 8)),U,20)= 0 Q 0 S Z= $G(^IBE(35 3,Y,2)) I $P(Z,U,2)= "P",$P(Z,U ,4) Q 1 Q 0 ; | |
| 3634 | ||
| 3635 | Routines | |
| 3636 | Activities | |
| 3637 | Routine Na me | |
| 3638 | IBJPS | |
| 3639 | Enhancemen t Category | |
| 3640 | New | |
| 3641 | Modify | |
| 3642 | Delete | |
| 3643 | No Change | |
| 3644 | RTM | |
| 3645 | ||
| 3646 | Related Op tions | |
| 3647 | None | |
| 3648 | Related Ro utines | |
| 3649 | Routines “ Called By” | |
| 3650 | Routines “ Called” | |
| 3651 | ||
| 3652 | ||
| 3653 | ||
| 3654 | ||
| 3655 | Data Dicti onary (DD) Reference s | |
| 3656 | ||
| 3657 | Related Pr otocols | |
| 3658 | None | |
| 3659 | Related In tegration Control Re gistration s (ICRs) | |
| 3660 | None | |
| 3661 | Data Passi ng | |
| 3662 | Input | |
| 3663 | Output Re ference | |
| 3664 | Both | |
| 3665 | Global Re ference | |
| 3666 | Local | |
| 3667 | Input Attr ibute Name and Defin ition | |
| 3668 | Name: | |
| 3669 | Definition : | |
| 3670 | Output Att ribute Nam e and Defi nition | |
| 3671 | Name: | |
| 3672 | Definition : | |
| 3673 | Current Lo gic | |
| 3674 | IBJPS ;ALB /MAF,ARH - IBSP IB S ITE PARAME TER SCREEN ;22-DEC-1 995 ;;2.0; INTEGRATED BILLING;* *39,52,70, 115,143,51 ,137,161,1 55,320,348 ,349,377,3 84,400,432 ,494,461,5 16,547**;2 1-MAR-94;B uild 119 ; ;Per VA Di rective 64 02, this r outine sho uld not be modified. ;EN ; -- main entry point for IBJP IB S ITE PARAME TERS, disp lay IB sit e paramete rs D EN^VA LM("IBJP I B SITE PAR AMETERS") Q ;HDR ; - - header c ode S VALM HDR(1)="On ly authori zed person s may edit this data ." Q ;INIT ; -- init variables and list array K ^T MP("IBJPS" ,$J),^TMP( "IBJPSAX", $J) D BLD^ IBJPS1 Q ; HELP ; -- help code S X="?" D DISP^XQORM 1 W !! Q ; EXIT ; -- exit code K ^TMP("IB JPS",$J),^ TMP("IBJPS AX",$J) D CLEAR^VALM 1 Q ;NXEDI T ; -- IBJ P IB SITE PARAMETER EDIT ACTIO N (EP): Se lect data set to edi t, do edit N VALMY,I BSELN,IBSE T D EN^VAL M2($G(XQOR NOD(0))) I $D(VALMY) S IBSELN= 0 F S IBS ELN=$O(VAL MY(IBSELN) ) Q:'IBSEL N D . S I BSET=$P($G (^TMP("IBJ PSAX",$J,I BSELN)),U, 1) Q:'IBSE T . D EDIT (IBSET) S VALMBCK="R " Q ;EDIT( IBSET) ; e dit IB Sit e Paramete rs D FULL^ VALM1 N DR I IBSET'= "" D . ; M RD;IB*2.0* 516 - Adde d TRICARE Pay-To Pro viders. . ; WCJ;IB*2 .0*547 - s hifted the numbers d own to ins ert a new one . I IB SET=8 D EN ^IBJPS5 Q . I IBSET= 11 D EN^IB JPS3(0) Q . I IBSET= 12 D EN^IB JPS3(1) Q . ;WCJ;IB* 2.0*547 ad ded defaul t Administ rative con tractors f or billing (medicare and comme rcial) . I IBSET=17 D EN^IBJPS 6(1) Q ; medicare . I IBSET= 18 D EN^IB JPS6(2) Q ; commer cial . S D R=$P($T(@I BSET),";;" ,2,999) . Q ; WCJ;IB *2.0*547 - shifted t he number down to in sert a new one I IBS ET=9,$$ICD 9SYS^IBACS V(DT)=30 S $P(DR,";" ,1)=7.05 ; I $G(DR)' ="" S DIE= "^IBE(350. 9,",DA=1 D ^DIE K DA ,DR,DIE,DI C,X,Y D IN IT^IBJPS S VALMBCK=" R" Q ; ;WC J;IB*2.0*5 47 - clear ed the spo t for the new #8, ad ded 17 & 1 8, move 16 to 19. ;g ef;IB*2.0* 547 - adde d 201 ;;.0 9;.13;.142 ;;1.2;.15 ;.11;.12;7 .043 ;;1.0 9;1.07;2.0 74 ;;4.04; 6.25;6.245 ;;.02;1.1 4;1.25;1.0 86 ;;1.23; 1.16;1.22; 1.19;1.15; 1.177 ;;1. 33;1.32;1. 31;1.27;8. 14T;8.15T; 8.16T;8.19 T9 ;;1.29; 1.3;1.18;1 .2810 ;;1. 01;1.02;1. 0513 ;;2.0 8;2.0914 ; ;11.0115 ; ;10.02;10. 03;10.04;1 0.05;D INI T^IBATFILE 16 ;;2.11; 8.01;8.09; 8.03;8.06; 8.04;8.07; 8.02;8.12T ;8.11T;8.1 7T19 ;;50. 01;50.02;5 0.05;50.06 ;50.03;50. 04;50.0720 ;;52.01;5 2.02 ; | |
| 3675 | Modified L ogic (Chan ges are in bold) | |
| 3676 | IBJPS ;ALB /MAF,ARH - IBSP IB S ITE PARAME TER SCREEN ;22-DEC-1 995 ;;2.0; INTEGRATED BILLING;* *39,52,70, 115,143,51 ,137,161,1 55,320,348 ,349,377,3 84,400,432 ,494,461,5 16,547,592 **;21-MAR- 94;Build 1 19 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ;EN ; -- main e ntry point for IBJP IB SITE PA RAMETERS, display IB site para meters D E N^VALM("IB JP IB SITE PARAMETER S") Q ;HDR ; -- head er code S VALMHDR(1) ="Only aut horized pe rsons may edit this data." Q ; INIT ; -- init varia bles and l ist array K ^TMP("IB JPS",$J),^ TMP("IBJPS AX",$J) D BLD^IBJPS1 Q ;HELP ; -- help c ode S X="? " D DISP^X QORM1 W !! Q ;EXIT ; -- exit c ode K ^TMP ("IBJPS",$ J),^TMP("I BJPSAX",$J ) D CLEAR^ VALM1 Q ;N XEDIT ; -- IBJP IB S ITE PARAME TER EDIT A CTION (EP) : Select d ata set to edit, do edit N VAL MY,IBSELN, IBSET D EN ^VALM2($G( XQORNOD(0) )) I $D(VA LMY) S IBS ELN=0 F S IBSELN=$O (VALMY(IBS ELN)) Q:'I BSELN D . S IBSET=$ P($G(^TMP( "IBJPSAX", $J,IBSELN) ),U,1) Q:' IBSET . D EDIT(IBSET ) S VALMBC K="R" Q ;E DIT(IBSET) ; edit IB Site Para meters D F ULL^VALM1 N DR I IBS ET'="" D . ; MRD;IB* 2.0*516 - Added TRIC ARE Pay-To Providers . . ; WCJ; IB*2.0*547 - shifted the numbe rs down to insert a new one . I IBSET=8 D EN^IBJPS 5 Q . I IB SET=11 D E N^IBJPS3(0 ) Q . I IB SET=12 D E N^IBJPS3(1 ) Q . ;WCJ ;IB*2.0*54 7 added de fault Admi nistrative contracto rs for bil ling (medi care and c ommercial) . I IBSET =17 D EN^I BJPS6(1) Q ; medic are . I IB SET=18 D E N^IBJPS6(2 ) Q ; co mmercial . S DR=$P($ T(@IBSET), ";;",2,999 ) . Q ; WC J;IB*2.0*5 47 - shift ed the num ber down t o insert a new one I IBSET=9,$ $ICD9SYS^I BACSV(DT)= 30 S $P(DR ,";",1)=7. 05 ; I $G( DR)'="" S DIE="^IBE( 350.9,",DA =1 D ^DIE K DA,DR,DI E,DIC,X,Y D INIT^IBJ PS S VALMB CK="R" Q ; ;WCJ;IB*2 .0*547 - c leared the spot for the new #8 , added 17 & 18, mov e 16 to 19 . ;gef;IB* 2.0*547 - added 20 ; JWS;IB*2.0 *592 - add ed field 8 .2 to 161 ;;.09;.13; .142 ;;1.2 ;.15;.11;. 12;7.043 ; ;1.09;1.07 ;2.074 ;;4 .04;6.25;6 .245 ;;.02 ;1.14;1.25 ;1.086 ;;1 .23;1.16;1 .22;1.19;1 .15;1.177 ;;1.33;1.3 2;1.31;1.2 7;8.14T;8. 15T;8.16T; 8.19T9 ;;1 .29;1.3;1. 18;1.2810 ;;1.01;1.0 2;1.0513 ; ;2.08;2.09 14 ;;11.01 15 ;;10.02 ;10.03;10. 04;10.05;D INIT^IBAT FILE16 ;;2 .11;8.01;8 .09;8.03;8 .06;8.04;8 .07;8.02;8 .12T;8.11T ;8.17T;8.2 T19 ;;50.0 1;50.02;50 .05;50.06; 50.03;50.0 4;50.0720 ;;52.01;52 .02 ; | |
| 3677 | ||
| 3678 | Routines | |
| 3679 | Activities | |
| 3680 | Routine Na me | |
| 3681 | IBJPS2 | |
| 3682 | Enhancemen t Category | |
| 3683 | New | |
| 3684 | Modify | |
| 3685 | Delete | |
| 3686 | No Change | |
| 3687 | RTM | |
| 3688 | ||
| 3689 | Related Op tions | |
| 3690 | None | |
| 3691 | Related Ro utines | |
| 3692 | Routines “ Called By” | |
| 3693 | Routines “ Called” | |
| 3694 | ||
| 3695 | ||
| 3696 | ||
| 3697 | ||
| 3698 | Data Dicti onary (DD) Reference s | |
| 3699 | ||
| 3700 | Related Pr otocols | |
| 3701 | None | |
| 3702 | Related In tegration Control Re gistration s (ICRs) | |
| 3703 | None | |
| 3704 | Data Passi ng | |
| 3705 | Input | |
| 3706 | Output Re ference | |
| 3707 | Both | |
| 3708 | Global Re ference | |
| 3709 | Local | |
| 3710 | Input Attr ibute Name and Defin ition | |
| 3711 | Name: | |
| 3712 | Definition : | |
| 3713 | Output Att ribute Nam e and Defi nition | |
| 3714 | Name: | |
| 3715 | Definition : | |
| 3716 | Current Lo gic | |
| 3717 | IBJPS2 ;AL B/MAF,ARH - IBSP IB SITE PARAM ETER BUILD (cont) ;2 2-DEC-1995 ;;2.0;INT EGRATED BI LLING;**39 ,52,115,14 3,51,137,1 61,155,320 ,348,349,3 77,384,400 ,432,494,4 61,516,547 **;21-MAR- 94;Build 1 19 ;;Per V A Directiv e 6402, th is routine should no t be modif ied. ;BLD2 ; - conti nue build screen arr ay for IB parameters ; N Z,Z0, PTPSTR,BPZ Z D RIGHT( 1,1,1) ; - facility/ med center (new line for each) S IBLN=$$ SET("Medic al Center" ,$$EXSET^I BJU1($P(IB PD0,U,2),3 50.9,.02), IBLN,IBLR, IBSEL) S I BLN=$$SET( "MAS Servi ce",$$EXSE T^IBJU1($P (IBPD1,U,1 4),350.9,1 .14),IBLN, IBLR,IBSEL ) ; D LEFT (2) S IBLN =$$SET("De fault Divi sion",$$EX SET^IBJU1( $P(IBPD1,U ,25),350.9 ,1.25),IBL N,IBLR,IBS EL) S IBLN =$$SET("Bi lling Supe rvisor",$$ EXSET^IBJU 1($P(IBPD1 ,U,8),350. 9,1.08),IB LN,IBLR,IB SEL) ; D R IGHT(1,1,1 ) S IBLN=$ $SET("Init iator Auth orize",$$Y N(+$P(IBPD 1,U,23)),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Ask HINQ i n MCCR",$$ YN(+$P(IBP D1,U,16)), IBLN,IBLR, IBSEL) S I BLN=$$SET( "Multiple Form Types ",$$YN(+$P (IBPD1,U,2 2)),IBLN,I BLR,IBSEL) ; D LEFT( 2) S IBLN= $$SET("Xfe r Proc to Sched",$$Y N(+$P(IBPD 1,U,19)),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Use Non-PT F Codes",$ $YN(+$P(IB PD1,U,15)) ,IBLN,IBLR ,IBSEL) S IBLN=$$SET ("Use OP C PT screen" ,$$YN(+$P( IBPD1,U,17 )),IBLN,IB LR,IBSEL) ; ; IB pat ch 349 for UB-04 cla im form an d paramete rs D RIGHT (1,1,1) S IBLN=$$SET ("UB-04 Pr int IDs",$ $EXSET^IBJ U1($P(IBPD 1,U,33),35 0.9,1.33), IBLN,IBLR, IBSEL) S I BLN=$$SET( "CMS-1500 Print IDs" ,$$EXSET^I BJU1($P(IB PD1,U,32), 350.9,1.32 ),IBLN,IBL R,IBSEL) S IBLN=$$SE T("CMS-150 0 Auto Prt er",$$EXSE T^IBJU1($P (IBPD8,U,1 4),350.9,8 .14),IBLN, IBLR,IBSEL ) S IBLN=$ $SET("EOB Auto Prter ",$$EXSET^ IBJU1($P(I BPD8,U,16) ,350.9,8.1 6),IBLN,IB LR,IBSEL) ; D LEFT(2 ) S IBLN=$ $SET("UB-0 4 Address Col",$P(IB PD1,U,31), IBLN,IBLR, IBSEL) S I BLN=$$SET( "CMS-1500 Addr Col", $P(IBPD1,U ,27),IBLN, IBLR,IBSEL ) S IBLN=$ $SET("UB-0 4 Auto Prt er",$$EXSE T^IBJU1($P (IBPD8,U,1 5),350.9,8 .15),IBLN, IBLR,IBSEL ) S IBLN=$ $SET("MRA Auto Prter ",$$EXSET^ IBJU1($P(I BPD8,U,19) ,350.9,8.1 9),IBLN,IB LR,IBSEL) ; ; VAD - IB*2.0*547 - inserte d a new se ction 8. O nly count activated codes D RI GHT(3,1,1) S (Z,Z0)= 0 F S Z=$ O(^IBE(350 .9,1,15,"B ",Z)) Q:'Z I $P($G( ^DGCR(399. 2,Z,0)),U, 3)=1 S Z0= Z0+1 S PTP STR=Z0_" A ctivated C odes Defin ed" S IBLN =$$SET("Pr inted Clai ms Rev Cod e Excl",PT PSTR,IBLN, IBLR,IBSEL ) ; D RIGH T(1,1,1) S Z=$$ICD9S YS^IBACSV( DT) I Z=1 S IBLN=$$S ET("Defaul t RX DX Cd ",$$EXSET^ IBJU1($P(I BPD1,U,29) ,350.9,1.2 9)_" (ICD- 9)",IBLN,I BLR,IBSEL) I Z'=1 S IBLN=$$SET ("Default RX DX Cd", $$EXSET^IB JU1($P(IBP D7,U,5),35 0.9,7.05)_ " (ICD-10) ",IBLN,IBL R,IBSEL) S IBLN=$$SE T("Default RX CPT Cd ",$$EXSET^ IBJU1($P(I BPD1,U,30) ,350.9,1.3 0),IBLN,IB LR,IBSEL) ; D LEFT(2 ) S IBLN=$ $SET("Defa ult ASC Re v Cd",$$EX SET^IBJU1( $P(IBPD1,U ,18),350.9 ,1.18),IBL N,IBLR,IBS EL) S IBLN =$$SET("De fault RX R ev Cd",$$E XSET^IBJU1 ($P(IBPD1, U,28),350. 9,1.28),IB LN,IBLR,IB SEL) ; D R IGHT(1,1,1 ) S IBLN=$ $SET("Bill Signer Na me","<No l onger used >",IBLN,IB LR,IBSEL) S IBLN=$$S ET("Bill S igner Titl e","<No lo nger used> ",IBLN,IBL R,IBSEL) ; D LEFT(2) S IBLN=$$ SET("Feder al Tax #", $P(IBPD1,U ,5),IBLN,I BLR,IBSEL) ; D RIGHT (3,1,1) ; - Pay-To P roviders - section 1 1 S (Z,Z0) =0 F S Z= $O(^IBE(35 0.9,1,19,Z )) Q:'Z S :$P($G(^IB E(350.9,1, 19,Z,0)),U ,5)="" Z0= Z0+1 S Z=+ $P($G(^IBE (350.9,1,1 1)),U,3),P TPSTR=Z0_" defined"_ $S(Z>0:", default - "_$P($$PTG ^IBJPS3(Z, 0),U),1:"" ) S IBLN=$ $SET("Pay- To Provide rs",PTPSTR ,IBLN,IBLR ,IBSEL) ; ; MRD;IB*2 .0*516 - A dded TRICA RE Pay-To Providers. D RIGHT(3 ,1,1) ; - TRICARE Pa y-To Provi ders - sec tion 12 S (Z,Z0)=0 F S Z=$O(^ IBE(350.9, 1,29,Z)) Q :'Z S:$P( $G(^IBE(35 0.9,1,29,Z ,0)),U,5)= "" Z0=Z0+1 S Z=+$P($ G(^IBE(350 .9,1,11)), U,4),PTPST R=Z0_" def ined"_$S(Z >0:", defa ult - "_$P ($$PTG^IBJ PS3(Z,1),U ),1:"") S IBLN=$$SET ("TRICARE Pay-To Pro viders",PT PSTR,IBLN, IBLR,IBSEL ) ; D RIGH T(3,1,1) S IBLN=$$SE T("Inpt He alth Summa ry",$$EXSE T^IBJU1($P (IBPD2,U,8 ),350.9,2. 08),IBLN,I BLR,IBSEL) S IBLN=$$ SET("Opt H ealth Summ ary",$$EXS ET^IBJU1($ P(IBPD2,U, 9),350.9,2 .09),IBLN, IBLR,IBSEL ) ; ; ePha rmacy para meters D R IGHT(7,1,1 ) S IBLN=$ $SET("HIPP A NCPDP Ac tive Flag" ,$S($P(IBP D11,U)=1:" Active",1: "Not Activ e"),IBLN,I BLR,IBSEL) ; ; trans fer pricin g D RIGHT( 1,1,1) S I BLN=$$SET( "Inpatient TP Active ",$$YN(+$ P(IBPD10,U ,2)),IBLN, IBLR,IBSEL ) S IBLN=$ $SET("Outp atient TP Active",$$ YN(+$P(IBP D10,U,3)), IBLN,IBLR, IBSEL) S I BLN=$$SET( "Pharmacy TP Active ",$$YN(+$P (IBPD10,U, 4)),IBLN,I BLR,IBSEL) S IBLN=$$ SET("Prost hetic TP A ctive",$$Y N(+$P(IBPD 10,U,5)),I BLN,IBLR,I BSEL) ; ; EDI/MRA pa rameters D RIGHT(7,1 ,1) N IBZ S IBZ=$P(I BPD8,U,3) S IBLN=$$S ET(" EDI/M RA Activat ed",$$EXSE T^IBJU1(+$ P(IBPD8,U, 10),350.9, 8.1),IBLN, IBLR,IBSEL ) S IBLN=$ $SET(" EDI Contact P hone",$P(I BPD2,U,11) ,IBLN,IBLR ,IBSEL) S IBLN=$$SET (" EDI 837 Live Tran smit Queue ",$P(IBPD8 ,U),IBLN,I BLR,IBSEL) S IBLN=$$ SET(" EDI 837 Test T ransmit Qu eue",$P(IB PD8,U,9),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Auto-Txmt Bill Freq uency",$S( IBZ:"Every "_$S(IBZ>1 :" "_$P(IB PD8,U,3),1 :""),1:"") _$S(IBZ:" Day"_$S(IB Z=1:"",1:" s"),1:"Nev er Run"),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Hours To Auto-Trans mit",$P(IB PD8,U,6),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Max # Bil ls Per Bat ch",$P(IBP D8,U,4),IB LN,IBLR,IB SEL) S IBL N=$$SET(" Only Allow 1 Ins Co/ Claim Batc h?",$$EXPA ND^IBTRE(3 50.9,8.07, +$P(IBPD8, U,7)),IBLN ,IBLR,IBSE L) S IBLN= $$SET(" La st Auto-Tx mt Run Dat e",$$DATE^ IBJU1($P(I BPD8,U,5)) ,IBLN,IBLR ,IBSEL) S IBLN=$$SET (" Days To Wait To P urge Msgs" ,$P(IBPD8, U,2),IBLN, IBLR,IBSEL ) S IBLN=$ $SET(" All ow MRA Pro cessing?", $$YN(+$P(I BPD8,U,12) ),IBLN,IBL R,IBSEL) S IBLN=$$SE T(" Enable Automatic MRA Proce ssing?",$$ YN(+$P(IBP D8,U,11)), IBLN,IBLR, IBSEL) S I BLN=$$SET( " Enable A uto Reg EO B Processi ng?",$$YN( +$P(IBPD8, U,17)),IBL N,IBLR,IBS EL) ; ; WC J;IB*2.0*5 47;adminis trative co ntractors medicare D RIGHT(3,1 ,1) S Z=+$ P($G(^IBE( 350.9,1,81 ,0)),U,4)_ " defined" S IBLN=$$ SET("Alt P rim Payer ID Typ-Med icare",Z,I BLN,IBLR,I BSEL) ; ; WCJ;IB*2.0 *547;admin istrative contractor s commerci al D RIGHT (3,1,1) S Z=+$P($G(^ IBE(350.9, 1,82,0)),U ,4)_" defi ned" S IBL N=$$SET("A lt Prim Pa yer ID Typ -Commercia l",Z,IBLN, IBLR,IBSEL ) ; ; Inge nix Claims Manager In formation D RIGHT(9, 1,1) S IBL N=$$SET("A re we usin g ClaimsMa nager?",$$ YN(+$P(IBP D50,U,1)), IBLN,IBLR, IBSEL) S I BLN=$$SET( "Is Claims Manager wo rking OK?" ,$$YN(+$P( IBPD50,U,2 )),IBLN,IB LR,IBSEL) S IBLN=$$S ET("Claims Manager TC P/IP Addre ss",$P(IBP D50,U,5),I BLN,IBLR,I BSEL) S IB CISOCK=$O( ^IBE(350.9 ,1,50.06," B","")) S IBLN=$$SET ("ClaimsMa nager TCP/ IP Ports", IBCISOCK,I BLN,IBLR,I BSEL) F S IBCISOCK= $O(^IBE(35 0.9,1,50.0 6,"B",IBCI SOCK)) Q:I BCISOCK="" D . S IB LN=$$SET(" ",IBCISOCK ,IBLN,IBLR ,IBSEL) . Q S IBLN=$ $SET("Gene ral Error MailGroup" ,$$EXSET^I BJU1($P(IB PD50,U,3), 350.9,50.0 3),IBLN,IB LR,IBSEL) S IBLN=$$S ET("Commun ication Er ror MailGr oup",$$EXS ET^IBJU1($ P(IBPD50,U ,4),350.9, 50.04),IBL N,IBLR,IBS EL) S IBCI MFLG=$$EXT ERNAL^DILF D(350.9,50 .07,"",$P( IBPD50,U,7 )) I IBCIM FLG="" S I BCIMFLG="P RIORITY" S IBLN=$$SE T("MailMan Messages" ,IBCIMFLG, IBLN,IBLR, IBSEL) ; ; Request F or Additio nal Info p atch 547 D RIGHT(9,1 ,1) S Z=$G (^IBE(350. 9,1,52)) S :$P(Z,U)=" " $P(Z,U)= "No Purge" S IBLN=$$ SET("Days to store 2 77RFAI Tra nsactions" ,$P(Z,U),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Days to wa it to purg e entry on RFAI Mana gement Wor klist",$P( Z,U,2),IBL N,IBLR,IBS EL) Q ;SET (TTL,DATA, LN,LR,SEL, HDR) ; N I BY,IBX,IBC S IBC=": " I TTL="" S IBC=" " S IBY=TTL _$J("",(IB TW(LR)-$L( TTL)-2))_$ S('$G(HDR) :IBC_DATA, 1:""),IBX= $G(^TMP("I BJPS",$J,L N,0)) S IB X=$$SETSTR ^VALM1(IBY ,IBX,IBTC( LR),(IBTW( LR)+IBSW(L R))) D SET 1(IBX,LN,S EL) S LN=L N+1 Q LN ; SET1(STR,L N,SEL,HI) ; set up T MP array w ith screen data S ^T MP("IBJPS" ,$J,LN,0)= STR S ^TMP ("IBJPS",$ J,"IDX",LN ,SEL)="" S ^TMP("IBJ PSAX",$J,S EL)=SEL I $G(HI)'="" D CNTRL^V ALM10(LN,1 ,4,IOINHI, IOINORM) ; I $G(RV) D CNTRL^VAL M10(LN,6,1 9,IOUON,IO UOFF) Q ;Y N(X) Q $S( +X:"YES",1 :"NO") ;RI GHT(LR,SEL ,BL) ; - r eset contr ol variabl es for rig ht side of screen S IBLN=$S(IB LN>IBGRPE: IBLN,1:IBG RPE) I $G( BL) S IBLN =$$SET("", "",IBLN,IB LR,IBSEL) S IBLR=$G( LR),IBGRPB =IBLN I +$ G(SEL) S I BSEL=IBSEL +1 D SET1( "["_IBSEL_ "]",IBLN,I BSEL,1) Q ;LEFT(LR) ; - reset control va riables fo r left sid e of scree n S IBLR=$ G(LR),IBGR PE=IBLN,IB LN=IBGRPB Q | |
| 3718 | Modified L ogic (Chan ges are in bold) | |
| 3719 | IBJPS2 ;AL B/MAF,ARH - IBSP IB SITE PARAM ETER BUILD (cont) ;2 2-DEC-1995 ;;2.0;INT EGRATED BI LLING;**39 ,52,115,14 3,51,137,1 61,155,320 ,348,349,3 77,384,400 ,432,494,4 61,516,547 ,592**;21- MAR-94;Bui ld 119 ;;P er VA Dire ctive 6402 , this rou tine shoul d not be m odified. ; BLD2 ; - c ontinue bu ild screen array for IB parame ters ; N Z ,Z0,PTPSTR ,BPZZ D RI GHT(1,1,1) ; - facil ity/med ce nter (new line for e ach) S IBL N=$$SET("M edical Cen ter",$$EXS ET^IBJU1($ P(IBPD0,U, 2),350.9,. 02),IBLN,I BLR,IBSEL) S IBLN=$$ SET("MAS S ervice",$$ EXSET^IBJU 1($P(IBPD1 ,U,14),350 .9,1.14),I BLN,IBLR,I BSEL) ; D LEFT(2) S IBLN=$$SET ("Default Division", $$EXSET^IB JU1($P(IBP D1,U,25),3 50.9,1.25) ,IBLN,IBLR ,IBSEL) S IBLN=$$SET ("Billing Supervisor ",$$EXSET^ IBJU1($P(I BPD1,U,8), 350.9,1.08 ),IBLN,IBL R,IBSEL) ; D RIGHT(1 ,1,1) S IB LN=$$SET(" Initiator Authorize" ,$$YN(+$P( IBPD1,U,23 )),IBLN,IB LR,IBSEL) S IBLN=$$S ET("Ask HI NQ in MCCR ",$$YN(+$P (IBPD1,U,1 6)),IBLN,I BLR,IBSEL) S IBLN=$$ SET("Multi ple Form T ypes",$$YN (+$P(IBPD1 ,U,22)),IB LN,IBLR,IB SEL) ; D L EFT(2) S I BLN=$$SET( "Xfer Proc to Sched" ,$$YN(+$P( IBPD1,U,19 )),IBLN,IB LR,IBSEL) S IBLN=$$S ET("Use No n-PTF Code s",$$YN(+$ P(IBPD1,U, 15)),IBLN, IBLR,IBSEL ) S IBLN=$ $SET("Use OP CPT scr een",$$YN( +$P(IBPD1, U,17)),IBL N,IBLR,IBS EL) ; ; IB patch 349 for UB-04 claim for m and para meters D R IGHT(1,1,1 ) S IBLN=$ $SET("UB-0 4 Print ID s",$$EXSET ^IBJU1($P( IBPD1,U,33 ),350.9,1. 33),IBLN,I BLR,IBSEL) S IBLN=$$ SET("CMS-1 500 Print IDs",$$EXS ET^IBJU1($ P(IBPD1,U, 32),350.9, 1.32),IBLN ,IBLR,IBSE L) S IBLN= $$SET("CMS -1500 Auto Prter",$$ EXSET^IBJU 1($P(IBPD8 ,U,14),350 .9,8.14),I BLN,IBLR,I BSEL) S IB LN=$$SET(" EOB Auto P rter",$$EX SET^IBJU1( $P(IBPD8,U ,16),350.9 ,8.16),IBL N,IBLR,IBS EL) ; D LE FT(2) S IB LN=$$SET(" UB-04 Addr ess Col",$ P(IBPD1,U, 31),IBLN,I BLR,IBSEL) S IBLN=$$ SET("CMS-1 500 Addr C ol",$P(IBP D1,U,27),I BLN,IBLR,I BSEL) S IB LN=$$SET(" UB-04 Auto Prter",$$ EXSET^IBJU 1($P(IBPD8 ,U,15),350 .9,8.15),I BLN,IBLR,I BSEL) S IB LN=$$SET(" MRA Auto P rter",$$EX SET^IBJU1( $P(IBPD8,U ,19),350.9 ,8.19),IBL N,IBLR,IBS EL) ; ; VA D - IB*2.0 *547 - ins erted a ne w section 8. Only co unt activa ted codes D RIGHT(3, 1,1) S (Z, Z0)=0 F S Z=$O(^IBE (350.9,1,1 5,"B",Z)) Q:'Z I $P ($G(^DGCR( 399.2,Z,0) ),U,3)=1 S Z0=Z0+1 S PTPSTR=Z0 _" Activat ed Codes D efined" S IBLN=$$SET ("Printed Claims Rev Code Excl ",PTPSTR,I BLN,IBLR,I BSEL) ; D RIGHT(1,1, 1) S Z=$$I CD9SYS^IBA CSV(DT) I Z=1 S IBLN =$$SET("De fault RX D X Cd",$$EX SET^IBJU1( $P(IBPD1,U ,29),350.9 ,1.29)_" ( ICD-9)",IB LN,IBLR,IB SEL) I Z'= 1 S IBLN=$ $SET("Defa ult RX DX Cd",$$EXSE T^IBJU1($P (IBPD7,U,5 ),350.9,7. 05)_" (ICD -10)",IBLN ,IBLR,IBSE L) S IBLN= $$SET("Def ault RX CP T Cd",$$EX SET^IBJU1( $P(IBPD1,U ,30),350.9 ,1.30),IBL N,IBLR,IBS EL) ; D LE FT(2) S IB LN=$$SET(" Default AS C Rev Cd", $$EXSET^IB JU1($P(IBP D1,U,18),3 50.9,1.18) ,IBLN,IBLR ,IBSEL) S IBLN=$$SET ("Default RX Rev Cd" ,$$EXSET^I BJU1($P(IB PD1,U,28), 350.9,1.28 ),IBLN,IBL R,IBSEL) ; D RIGHT(1 ,1,1) S IB LN=$$SET(" Bill Signe r Name","< No longer used>",IBL N,IBLR,IBS EL) S IBLN =$$SET("Bi ll Signer Title","<N o longer u sed>",IBLN ,IBLR,IBSE L) ; D LEF T(2) S IBL N=$$SET("F ederal Tax #",$P(IBP D1,U,5),IB LN,IBLR,IB SEL) ; D R IGHT(3,1,1 ) ; - Pay- To Provide rs - secti on 11 S (Z ,Z0)=0 F S Z=$O(^IB E(350.9,1, 19,Z)) Q:' Z S:$P($G (^IBE(350. 9,1,19,Z,0 )),U,5)="" Z0=Z0+1 S Z=+$P($G( ^IBE(350.9 ,1,11)),U, 3),PTPSTR= Z0_" defin ed"_$S(Z>0 :", defaul t - "_$P($ $PTG^IBJPS 3(Z,0),U), 1:"") S IB LN=$$SET(" Pay-To Pro viders",PT PSTR,IBLN, IBLR,IBSEL ) ; ; MRD; IB*2.0*516 - Added T RICARE Pay -To Provid ers. D RIG HT(3,1,1) ; - TRICAR E Pay-To P roviders - section 1 2 S (Z,Z0) =0 F S Z= $O(^IBE(35 0.9,1,29,Z )) Q:'Z S :$P($G(^IB E(350.9,1, 29,Z,0)),U ,5)="" Z0= Z0+1 S Z=+ $P($G(^IBE (350.9,1,1 1)),U,4),P TPSTR=Z0_" defined"_ $S(Z>0:", default - "_$P($$PTG ^IBJPS3(Z, 1),U),1:"" ) S IBLN=$ $SET("TRIC ARE Pay-To Providers ",PTPSTR,I BLN,IBLR,I BSEL) ; D RIGHT(3,1, 1) S IBLN= $$SET("Inp t Health S ummary",$$ EXSET^IBJU 1($P(IBPD2 ,U,8),350. 9,2.08),IB LN,IBLR,IB SEL) S IBL N=$$SET("O pt Health Summary",$ $EXSET^IBJ U1($P(IBPD 2,U,9),350 .9,2.09),I BLN,IBLR,I BSEL) ; ; ePharmacy parameters D RIGHT(7 ,1,1) S IB LN=$$SET(" HIPPA NCPD P Active F lag",$S($P (IBPD11,U) =1:"Active ",1:"Not A ctive"),IB LN,IBLR,IB SEL) ; ; t ransfer pr icing D RI GHT(1,1,1) S IBLN=$$ SET("Inpat ient TP Ac tive ",$$Y N(+$P(IBPD 10,U,2)),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Outpatient TP Active ",$$YN(+$P (IBPD10,U, 3)),IBLN,I BLR,IBSEL) S IBLN=$$ SET("Pharm acy TP Act ive ",$$YN (+$P(IBPD1 0,U,4)),IB LN,IBLR,IB SEL) S IBL N=$$SET("P rosthetic TP Active" ,$$YN(+$P( IBPD10,U,5 )),IBLN,IB LR,IBSEL) ; ; EDI/MR A paramete rs D RIGHT (7,1,1) N IBZ S IBZ= $P(IBPD8,U ,3) S IBLN =$$SET(" E DI/MRA Act ivated",$$ EXSET^IBJU 1(+$P(IBPD 8,U,10),35 0.9,8.1),I BLN,IBLR,I BSEL) S IB LN=$$SET(" EDI Conta ct Phone", $P(IBPD2,U ,11),IBLN, IBLR,IBSEL ) S IBLN=$ $SET(" EDI 837 Live Transmit Q ueue",$P(I BPD8,U),IB LN,IBLR,IB SEL) S IBL N=$$SET(" EDI 837 Te st Transmi t Queue",$ P(IBPD8,U, 9),IBLN,IB LR,IBSEL) S IBLN=$$S ET(" Auto- Txmt Bill Frequency" ,$S(IBZ:"E very"_$S(I BZ>1:" "_$ P(IBPD8,U, 3),1:""),1 :"")_$S(IB Z:" Day"_$ S(IBZ=1:"" ,1:"s"),1: "Never Run "),IBLN,IB LR,IBSEL) S IBLN=$$S ET(" Hours To Auto-T ransmit",$ P(IBPD8,U, 6),IBLN,IB LR,IBSEL) S IBLN=$$S ET(" Max # Bills Per Batch",$P (IBPD8,U,4 ),IBLN,IBL R,IBSEL) S IBLN=$$SE T(" Only A llow 1 Ins Co/Claim Batch?",$$ EXPAND^IBT RE(350.9,8 .07,+$P(IB PD8,U,7)), IBLN,IBLR, IBSEL) S I BLN=$$SET( " Last Aut o-Txmt Run Date",$$D ATE^IBJU1( $P(IBPD8,U ,5)),IBLN, IBLR,IBSEL ) S IBLN=$ $SET(" Day s To Wait To Purge M sgs",$P(IB PD8,U,2),I BLN,IBLR,I BSEL) S IB LN=$$SET(" Allow MRA Processin g?",$$YN(+ $P(IBPD8,U ,12)),IBLN ,IBLR,IBSE L) S IBLN= $$SET(" En able Autom atic MRA P rocessing? ",$$YN(+$P (IBPD8,U,1 1)),IBLN,I BLR,IBSEL) S IBLN=$$ SET(" Enab le Auto Re g EOB Proc essing?",$ $YN(+$P(IB PD8,U,17)) ,IBLN,IBLR ,IBSEL) ;J WS;IB*2.0* 592;add on /off for D ental I $P (IBPD8,U,2 0)="" S $P (IBPD8,U,2 0)=1 ;defa ult to yes S IBLN=$$ SET(" Allo w Dental C laim Proce ssing?",$$ YN(+$P(IBP D8,U,20)), IBLN,IBLR, IBSEL) ; ; WCJ;IB*2. 0*547;admi nistrative contracto rs medicar e D RIGHT( 3,1,1) S Z =+$P($G(^I BE(350.9,1 ,81,0)),U, 4)_" defin ed" S IBLN =$$SET("Al t Prim Pay er ID Typ- Medicare", Z,IBLN,IBL R,IBSEL) ; ; WCJ;IB* 2.0*547;ad ministrati ve contrac tors comme rcial D RI GHT(3,1,1) S Z=+$P($ G(^IBE(350 .9,1,82,0) ),U,4)_" d efined" S IBLN=$$SET ("Alt Prim Payer ID Typ-Commer cial",Z,IB LN,IBLR,IB SEL) ; ; I ngenix Cla imsManager Informati on D RIGHT (9,1,1) S IBLN=$$SET ("Are we u sing Claim sManager?" ,$$YN(+$P( IBPD50,U,1 )),IBLN,IB LR,IBSEL) S IBLN=$$S ET("Is Cla imsManager working O K?",$$YN(+ $P(IBPD50, U,2)),IBLN ,IBLR,IBSE L) S IBLN= $$SET("Cla imsManager TCP/IP Ad dress",$P( IBPD50,U,5 ),IBLN,IBL R,IBSEL) S IBCISOCK= $O(^IBE(35 0.9,1,50.0 6,"B","")) S IBLN=$$ SET("Claim sManager T CP/IP Port s",IBCISOC K,IBLN,IBL R,IBSEL) F S IBCISO CK=$O(^IBE (350.9,1,5 0.06,"B",I BCISOCK)) Q:IBCISOCK ="" D . S IBLN=$$SE T("",IBCIS OCK,IBLN,I BLR,IBSEL) . Q S IBL N=$$SET("G eneral Err or MailGro up",$$EXSE T^IBJU1($P (IBPD50,U, 3),350.9,5 0.03),IBLN ,IBLR,IBSE L) S IBLN= $$SET("Com munication Error Mai lGroup",$$ EXSET^IBJU 1($P(IBPD5 0,U,4),350 .9,50.04), IBLN,IBLR, IBSEL) S I BCIMFLG=$$ EXTERNAL^D ILFD(350.9 ,50.07,"", $P(IBPD50, U,7)) I IB CIMFLG="" S IBCIMFLG ="PRIORITY " S IBLN=$ $SET("Mail Man Messag es",IBCIMF LG,IBLN,IB LR,IBSEL) ; ; Reques t For Addi tional Inf o patch 54 7 D RIGHT( 9,1,1) S Z =$G(^IBE(3 50.9,1,52) ) S:$P(Z,U )="" $P(Z, U)="No Pur ge" S IBLN =$$SET("Da ys to stor e 277RFAI Transactio ns",$P(Z,U ),IBLN,IBL R,IBSEL) S IBLN=$$SE T("Days to wait to p urge entry on RFAI M anagement Worklist", $P(Z,U,2), IBLN,IBLR, IBSEL) Q ; SET(TTL,DA TA,LN,LR,S EL,HDR) ; N IBY,IBX, IBC S IBC= ": " I TTL ="" S IBC= " " S IBY= TTL_$J("", (IBTW(LR)- $L(TTL)-2) )_$S('$G(H DR):IBC_DA TA,1:""),I BX=$G(^TMP ("IBJPS",$ J,LN,0)) S IBX=$$SET STR^VALM1( IBY,IBX,IB TC(LR),(IB TW(LR)+IBS W(LR))) D SET1(IBX,L N,SEL) S L N=LN+1 Q L N ;SET1(ST R,LN,SEL,H I) ; set u p TMP arra y with scr een data S ^TMP("IBJ PS",$J,LN, 0)=STR S ^ TMP("IBJPS ",$J,"IDX" ,LN,SEL)=" " S ^TMP(" IBJPSAX",$ J,SEL)=SEL I $G(HI)' ="" D CNTR L^VALM10(L N,1,4,IOIN HI,IOINORM ) ;I $G(RV ) D CNTRL^ VALM10(LN, 6,19,IOUON ,IOUOFF) Q ;YN(X) Q $S(+X:"YES ",1:"NO") ;RIGHT(LR, SEL,BL) ; - reset co ntrol vari ables for right side of screen S IBLN=$S (IBLN>IBGR PE:IBLN,1: IBGRPE) I $G(BL) S I BLN=$$SET( "","",IBLN ,IBLR,IBSE L) S IBLR= $G(LR),IBG RPB=IBLN I +$G(SEL) S IBSEL=IB SEL+1 D SE T1("["_IBS EL_"]",IBL N,IBSEL,1) Q ;LEFT(L R) ; - res et control variables for left side of sc reen S IBL R=$G(LR),I BGRPE=IBLN ,IBLN=IBGR PB Q | |
| 3720 | ||
| 3721 | Routines | |
| 3722 | Activities | |
| 3723 | Routine Na me | |
| 3724 | IBJTBA | |
| 3725 | Enhancemen t Category | |
| 3726 | New | |
| 3727 | Modify | |
| 3728 | Delete | |
| 3729 | No Change | |
| 3730 | RTM | |
| 3731 | ||
| 3732 | Related Op tions | |
| 3733 | None | |
| 3734 | Related Ro utines | |
| 3735 | Routines “ Called By” | |
| 3736 | Routines “ Called” | |
| 3737 | ||
| 3738 | ||
| 3739 | ||
| 3740 | ||
| 3741 | Data Dicti onary (DD) Reference s | |
| 3742 | ||
| 3743 | Related Pr otocols | |
| 3744 | None | |
| 3745 | Related In tegration Control Re gistration s (ICRs) | |
| 3746 | None | |
| 3747 | Data Passi ng | |
| 3748 | Input | |
| 3749 | Output Re ference | |
| 3750 | Both | |
| 3751 | Global Re ference | |
| 3752 | Local | |
| 3753 | Input Attr ibute Name and Defin ition | |
| 3754 | Name: | |
| 3755 | Definition : | |
| 3756 | Output Att ribute Nam e and Defi nition | |
| 3757 | Name: | |
| 3758 | Definition : | |
| 3759 | Current Lo gic | |
| 3760 | IBJTBA ;AL B/ARH - TP I BILL CHA RGE INFO S CREEN ;01- MAR-1995 ; ;2.0;INTEG RATED BILL ING;**39,8 0,51,137,1 35,309,349 ,389**;21- MAR-94;Bui ld 6 ;;Per VHA Direc tive 2004- 038, this routine sh ould not b e modified . ;EN ; -- main entr y point fo r IBJ TP B ILL CHARGE S D EN^VAL M("IBJT BI LL CHARGES ") Q ;HDR ; -- heade r code D H DR^IBJTU1( +IBIFN,+DF N,12) Q ;I NIT ; -- i nit variab les and li st array N IBOK,IBEO BDET K ^TM P("IBJTBA" ,$J) N IBF T I '$G(DF N)!'$G(IBI FN) S VALM QUIT="" G INITQ S IB FT=+$P($G( ^DGCR(399, +IBIFN,0)) ,U,19),IBO K=1 I $D(^ IBM(361.1, "B",IBIFN) )!$D(^IBM( 361.1,"C", IBIFN)) D G:'IBOK I NITQ . S D IR("A")="D O YOU WANT ALL EEOB DETAILS?: ",DIR("B") ="NO",DIR( 0)="YA" . D FULL^VAL M1 W ! D ^ DIR K DIR . I $D(DTO UT)!$D(DUO UT) S IBOK =0 Q . S I BEOBDET=+Y D BLDINIT Q Q ;MRA ; -- mra/eo b N IBI,Z, IBSTR,IBSH EOB,IBCT S IBCT=0 S IBI=0 F S IBI=$O(^I BM(361.1," B",IBIFN,I BI)) Q:'IB I S Z=+$O (^IBM(361. 1,IBI,8,0) ) I '$O(^( Z)) S IBCT =IBCT+1,IB SHEOB(IBI) =0 ; Entir e EOB belo ngs to the bill S IB I=0 F S I BI=$O(^IBM (361.1,"C" ,IBIFN,IBI )) Q:'IBI S IBCT=IB CT+1,IBSHE OB(IBI)=1 ; EOB has been reapp ortioned a t the site I 'IBCT D . S IBSTR =$$SETLN(" No EEOB/MR A Informat ion","",1, 79) . S IB LN=$$SET(I BSTR,IBLN) I IBCT D . S Z=0 . S IBI=0 F S IBI=$O( IBSHEOB(IB I)) Q:'IBI S Z=Z+1 D SHEOB^IB JTBA1(IBI, +IBSHEOB(I BI),Z,IBCT ) ; Q ;HEL P ; -- hel p code S X ="?" D DIS P^XQORM1 W !! Q ;EXI T ; -- exi t code K ^ TMP("IBJTB A",$J) D C LEAR^VALM1 Q ;BLD ; charges, a s they wou ld display on the bi ll N IBXDA TA,IBXSAVE I $P($G(^ DGCR(399,+ IBIFN,0)), U,19)=2 D H1500 Q D UB04 K ^TM P("IBXSAVE ",$J) Q ;H 1500 ; blo ck 24 N X, IBI,IBJ,IB LN,IBX,IBS TR,IBLKLN, IBPFORM,IB LIN K ^TMP ("IBXSAVE" ,$J) S IBL IN=$$BOX24 D^IBCEF11( "",1),IBLK LN=0,IBLN= 1 Q:'$G(IB IFN) K ^TM P("IBXDISP ",$J) S IB PFORM=$S($ P($G(^IBE( 353,2,2)), U,8):$P(^( 2),U,8),1: 2),IBLN=1 S IBX=$$BI LLN^IBCEFG 0(1,"1^99" ,IBLIN,+IB IFN,IBPFOR M) S IBI=$ O(^TMP("IB XDISP",$J, ""),-1) S IBJ="" F S IBJ=$O(^ TMP("IBXDI SP",$J,IBI ,IBJ),-1) Q:$S('IBJ: 1,1:$TR($G (^(IBJ))," ")'="") K ^TMP("IBX DISP",$J,I BI,IBJ) I '$O(^TMP(" IBXDISP",$ J,IBI,0)) S VALMSG=" No charges or proced ures defin ed.",VALMQ UIT="" G H 1500Q S IB I="" F S IBI=$O(^TM P("IBXDISP ",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^ TMP("IBXDI SP",$J,IBI ,IBJ)) Q:' IBJ D . S IBX=$G(^T MP("IBXDIS P",$J,IBI, IBJ)),IBLN =$$SET(IBX ,IBLN) K ^ TMP("IBXDI SP",$J) D COB,MRA I $$ISRX^IBC EF1(IBIFN) D RX I $$ ISPROS^IBC EF1(IBIFN) D PROS S VALMCNT=IB LN-1H1500Q Q ;UB04 ; form locat or 42-49, IBIFN requ ired N X,Y ,DIR,IBI,I BJ,IBX,IBL N,IBLC,IBL IN,IBPFORM ,IBSTATE,I BCBILL,IBI NPAT,IBQ,Z ,Z0 K ^TMP ("IBXSAVE" ,$J) S IBL IN=$$RCBOX ^IBCEF11() S IBQ=0,I BLC=9 Q:'$ G(IBIFN) K ^TMP("IBX DISP",$J) S IBPFORM= $S($P($G(^ IBE(353,3, 2)),U,8):$ P(^(2),U,8 ),1:3) S I BX=$$BILLN ^IBCEFG0(1 ,"1^99",IB LIN,+IBIFN ,IBPFORM) I '$O(^TMP ("IBXDISP" ,$J,0)) S VALMSG="No charges d efined.",V ALMQUIT="" G UB04Q S Z="" F S Z=$O(^TMP ("IBXDISP" ,$J,1,Z),- 1) Q:Z="" S Z0=$G(^ (Z)) Q:$TR (Z0," ")'= "" K ^(Z) S:Z ^TMP( "IBXDISP", $J,1,Z+1)= " " S IBIN PAT=$$INPA T^IBCEF(IB IFN,1) S I BSTATE=$G( ^DGCR(399, IBIFN,"U") ),IBCBILL= $G(^DGCR(3 99,IBIFN,0 )) ; S (VA LMCNT,IBLN )=1,IBLKLN =0 I +IBIN PAT D S I BLN=$$SET( IBSTR,IBLN ) . S IBX= $P(IBSTATE ,U,15),IBS TR=+IBX_" DAY"_$S(IB X'=1:"S",1 :"")_" INP ATIENT CAR E" . S IBX =$$LOS^IBC U64(+IBSTA TE,+$P(IBS TATE,U,2), +$P(IBCBIL L,U,6)),IB X=IBX-$$LO S1^IBCU64( IBIFN) I I BX>0 S IBS TR=IBSTR_$ J("Pass Da ys: "_IBX, 55) ; S IB I="" F S IBI=$O(^TM P("IBXDISP ",$J,IBI)) Q:'IBI S IBJ=0 F S IBJ=$O(^ TMP("IBXDI SP",$J,IBI ,IBJ)) Q:' IBJ D . S IBX=$G(^T MP("IBXDIS P",$J,IBI, IBJ)),IBLN =$$SET(IBX ,IBLN) . I $E(IBX,1, 3)="001" D COB ; K ^ TMP("IBXDI SP",$J) ; D MRA S VA LMCNT=IBLN -1UB04Q Q ;SETLN(STR ,IBX,COL,W D) ; S IBX =$$SETSTR^ VALM1(STR, IBX,COL,WD ) Q IBX ;S ET(STR,LN) ; set up TMP array with scree n data (al lows 2 bla nk lines, if not at end of arr ay) N IBX, IBI I STR? 80" " S IB LKLN=IBLKL N+1 G SETQ F IBI=1:1 :IBLKLN D SET^VALM10 (LN," ") S LN=LN+1 Q :IBI>1 D S ET^VALM10( LN,STR) S LN=LN+1,IB LKLN=0SETQ Q LN ;COB ; if ther e is an of fset or a secondary/ tertiary p ayer add i t to the d isplay, wi th ins co, and prior bill # ; IBIFN and IBLN must exist upon entry, IB LN is upda ted with n ew line co unt N IBM, IBM1,IBI,I BJ,IBD,IBS TR,IBCU2,I BCU1 Q:'$G (IBIFN) S IBM=$G(^DG CR(399,IBI FN,"M")),I BM1=$G(^DG CR(399,IBI FN,"M1")) S IBCU2=$G (^DGCR(399 ,IBIFN,"U2 ")),IBCU1= $G(^DGCR(3 99,IBIFN," U1")) S IB J=$P($G(^D GCR(399,IB IFN,0)),U, 21),IBJ=$S (IBJ="P":3 ,IBJ="S":3 ,IBJ="T":3 ,1:0),IBST R="" I +$P (IBM,U,2)! (+$P(IBM,U ,3)) F IBI =1:1:IBJ I +$P(IBM,U ,IBI) D S IBLN=$$SE T(IBSTR,IB LN) . I IB STR="" S I BLN=$$SET( "",IBLN) . S IBD=$S( IBI=1:"Pri mary",IBI= 2:"Seconda ry",1:"Ter tiary")_": " S IBSTR =$$SETLN(I BD,"",5,11 ) . S IBD= $P($G(^DIC (36,+$P(IB M,U,IBI),0 )),U,1) S IBSTR=$$SE TLN(IBD,IB STR,17,25) . I $P(IB CU2,U,(IBI +3))'="" S IBD=$J(+$ P(IBCU2,U, (IBI+3)),9 ,2) S IBST R=$$SETLN( IBD,IBSTR, 44,11) . I $P(IBM1,U ,(IBI+4))' ="" S IBD= $$BN1^PRCA FN(+$P(IBM 1,U,(IBI+4 ))) S IBST R=$$SETLN( IBD,IBSTR, 60,11) I + $P(IBCU1,U ,2) D S I BLN=$$SET( IBSTR,IBLN ) . I IBST R="" S IBL N=$$SET("" ,IBLN) . S IBD="Offs et: " S IB STR=$$SETL N(IBD,"",5 ,11) . S I BD=$P(IBCU 1,U,3) S I BSTR=$$SET LN(IBD,IBS TR,17,25) . S IBD=$J ($P(IBCU1, U,2),9,2) S IBSTR=$$ SETLN(IBD, IBSTR,44,1 1) . S IBD =$P(IBCU1, U,1)-$P(IB CU1,U,2),I BD="Billed : "_$J(IBD ,0,2) S IB STR=$$SETL N(IBD,IBST R,60,17) Q ;RX ;RX r efill info for CMS-1 500 TPJI d isplay N Z ,Z0,Z1,IBS PC,IBD,IBI ,IBSTR,IBA RRAY,IBRXX S IBLN=IB LN+1 S IBS PC=$J("",5 ) D SET^IB CSC5A(IBIF N,.IBARRAY ) I $D(IBA RRAY) D . S (Z,Z0)=0 F S Z0=$ O(IBARRAY( Z0)) Q:Z0= "" S Z1=0 F S Z1=$ O(IBARRAY( Z0,Z1)) Q: 'Z1 S Z=Z +1 S IBXDA TA(Z)=$$DA T1^IBOUTL( Z1)_U_$G(I BARRAY(Z0, Z1)) S IBD =$$SET("", IBLN) S IB D="PRESCRI PTION REFI LLS: (For TPJI displ ay only)" S IBSTR=$$ SETLN(IBD, "",1,79),I BLN=$$SET( IBSTR,IBLN ) S IBI=0 F S IBI=$ O(IBXDATA( IBI)) Q:IB I="" D . S IBRXX=$G (IBXDATA(I BI)) . D Z ERO^IBRXUT L($P(IBRXX ,U,3)) . S IBD=$J($P (IBRXX,U,7 ),9,2)_IBS PC_$P(IBRX X,U)_IBSPC _$G(^TMP($ J,"IBDRUG" ,+$P(IBRXX ,U,3),.01) ) . K ^TMP ($J,"IBDRU G") . S IB STR=$$SETL N(IBD,"",1 ,79),IBLN= $$SET(IBST R,IBLN) . S IBD="QTY : "_$P(IBR XX,U,5)_" for "_$P(I BRXX,U,4)_ " days sup ply "_"NDC # "_$P(IBR XX,U,6) . S IBSTR=$$ SETLN(IBD, "",23,79), IBLN=$$SET (IBSTR,IBL N) Q ;PROS ;prosthet ic info fo r CMS-1500 TPJI disp lay N Z,Z0 ,Z1,IBARRA Y,IBSPC,IB D,IBI,IBST R S IBSPC= $J("",10), IBLN=IBLN+ 1 D SET^IB CSC5B(IBIF N,.IBARRAY ) I $D(IBA RRAY) D . S (Z,Z0)=0 F S Z0=$ O(IBARRAY( Z0)) Q:Z0= "" S Z1=0 F S Z1=$ O(IBARRAY( Z0,Z1)) Q: 'Z1 S Z=Z +1,IBXDATA (Z)=$$DAT1 ^IBOUTL(Z0 )_U_$E($$P INB^IBCSC5 B(+IBARRAY (Z0,Z1)),1 ,39) S IBD =$$SET("", IBLN) S IB D="PROSTHE TIC REFILL S: (For TP JI display only)" S IBSTR=$$SE TLN(IBD,"" ,1,79),IBL N=$$SET(IB STR,IBLN) S IBI=0 F S IBI=$O( IBXDATA(IB I)) Q:IBI= "" D . S IBD=$P(IBX DATA(IBI), U)_IBSPC_$ P(IBXDATA( IBI),U,2) . S IBSTR= $$SETLN(IB D,"",1,79) ,IBLN=$$SE T(IBSTR,IB LN) Q ; | |
| 3761 | Modified L ogic (Chan ges are in bold) | |
| 3762 | IBJTBA ;AL B/ARH - TP I BILL CHA RGE INFO S CREEN ;01- MAR-1995 ; ;2.0;INTEG RATED BILL ING;**39,8 0,51,137,1 35,309,349 ,389,592** ;21-MAR-94 ;Build 6 ; ;Per VHA D irective 2 004-038, t his routin e should n ot be modi fied. ;EN ; -- main entry poin t for IBJ TP BILL CH ARGES D EN ^VALM("IBJ T BILL CHA RGES") Q ; HDR ; -- h eader code D HDR^IBJ TU1(+IBIFN ,+DFN,12) Q ;INIT ; -- init va riables an d list arr ay N IBOK, IBEOBDET K ^TMP("IBJ TBA",$J) N IBFT I '$ G(DFN)!'$G (IBIFN) S VALMQUIT=" " G INITQ S IBFT=+$P ($G(^DGCR( 399,+IBIFN ,0)),U,19) ,IBOK=1 I $D(^IBM(36 1.1,"B",IB IFN))!$D(^ IBM(361.1, "C",IBIFN) ) D G:'IB OK INITQ . S DIR("A" )="DO YOU WANT ALL E EOB DETAIL S?: ",DIR( "B")="NO", DIR(0)="YA " . D FULL ^VALM1 W ! D ^DIR K DIR . I $D (DTOUT)!$D (DUOUT) S IBOK=0 Q . S IBEOBDE T=+Y D BLD INITQ Q ;M RA ; -- mr a/eob N IB I,Z,IBSTR, IBSHEOB,IB CT S IBCT= 0 S IBI=0 F S IBI=$ O(^IBM(361 .1,"B",IBI FN,IBI)) Q :'IBI S Z =+$O(^IBM( 361.1,IBI, 8,0)) I '$ O(^(Z)) S IBCT=IBCT+ 1,IBSHEOB( IBI)=0 ; E ntire EOB belongs to the bill S IBI=0 F S IBI=$O( ^IBM(361.1 ,"C",IBIFN ,IBI)) Q:' IBI S IBC T=IBCT+1,I BSHEOB(IBI )=1 ; EOB has been r eapportion ed at the site I 'IB CT D . S I BSTR=$$SET LN("No EEO B/MRA Info rmation"," ",1,79) . S IBLN=$$S ET(IBSTR,I BLN) I IBC T D . S Z= 0 . S IBI= 0 F S IBI =$O(IBSHEO B(IBI)) Q: 'IBI S Z= Z+1 D SHEO B^IBJTBA1( IBI,+IBSHE OB(IBI),Z, IBCT) ; Q ;HELP ; -- help code S X="?" D DISP^XQOR M1 W !! Q ;EXIT ; -- exit code K ^TMP("I BJTBA",$J) D CLEAR^V ALM1 Q ;BL D ; charge s, as they would dis play on th e bill N I BXDATA,IBX SAVE ;JWS: IB*2.0*592 :Dental fo rm#7 as pr ofessional I $P($G(^ DGCR(399,+ IBIFN,0)), U,19)=2!($ P($G(^(0)) ,U,19)=7) D H1500 Q D UB04 K ^ TMP("IBXSA VE",$J) Q ;H1500 ; b lock 24 N X,IBI,IBJ, IBLN,IBX,I BSTR,IBLKL N,IBPFORM, IBLIN K ^T MP("IBXSAV E",$J) S I BLIN=$$BOX 24D^IBCEF1 1("",1),IB LKLN=0,IBL N=1 Q:'$G( IBIFN) K ^ TMP("IBXDI SP",$J) S IBPFORM=$S ($P($G(^IB E(353,2,2) ),U,8):$P( ^(2),U,8), 1:2),IBLN= 1 S IBX=$$ BILLN^IBCE FG0(1,"1^9 9",IBLIN,+ IBIFN,IBPF ORM) S IBI =$O(^TMP(" IBXDISP",$ J,""),-1) S IBJ="" F S IBJ=$O (^TMP("IBX DISP",$J,I BI,IBJ),-1 ) Q:$S('IB J:1,1:$TR( $G(^(IBJ)) ," ")'="") K ^TMP("I BXDISP",$J ,IBI,IBJ) I '$O(^TMP ("IBXDISP" ,$J,IBI,0) ) S VALMSG ="No charg es or proc edures def ined.",VAL MQUIT="" G H1500Q S IBI="" F S IBI=$O(^ TMP("IBXDI SP",$J,IBI )) Q:'IBI S IBJ=0 F S IBJ=$O (^TMP("IBX DISP",$J,I BI,IBJ)) Q :'IBJ D . S IBX=$G( ^TMP("IBXD ISP",$J,IB I,IBJ)),IB LN=$$SET(I BX,IBLN) K ^TMP("IBX DISP",$J) D COB,MRA I $$ISRX^I BCEF1(IBIF N) D RX I $$ISPROS^I BCEF1(IBIF N) D PROS S VALMCNT= IBLN-1H150 0Q Q ;UB04 ;form loc ator 42-49 , IBIFN re quired N X ,Y,DIR,IBI ,IBJ,IBX,I BLN,IBLC,I BLIN,IBPFO RM,IBSTATE ,IBCBILL,I BINPAT,IBQ ,Z,Z0 K ^T MP("IBXSAV E",$J) S I BLIN=$$RCB OX^IBCEF11 () S IBQ=0 ,IBLC=9 Q: '$G(IBIFN) K ^TMP("I BXDISP",$J ) S IBPFOR M=$S($P($G (^IBE(353, 3,2)),U,8) :$P(^(2),U ,8),1:3) S IBX=$$BIL LN^IBCEFG0 (1,"1^99", IBLIN,+IBI FN,IBPFORM ) I '$O(^T MP("IBXDIS P",$J,0)) S VALMSG=" No charges defined." ,VALMQUIT= "" G UB04Q S Z="" F S Z=$O(^T MP("IBXDIS P",$J,1,Z) ,-1) Q:Z=" " S Z0=$G (^(Z)) Q:$ TR(Z0," ") '="" K ^( Z) S:Z ^TM P("IBXDISP ",$J,1,Z+1 )=" " S IB INPAT=$$IN PAT^IBCEF( IBIFN,1) S IBSTATE=$ G(^DGCR(39 9,IBIFN,"U ")),IBCBIL L=$G(^DGCR (399,IBIFN ,0)) ; S ( VALMCNT,IB LN)=1,IBLK LN=0 I +IB INPAT D S IBLN=$$SE T(IBSTR,IB LN) . S IB X=$P(IBSTA TE,U,15),I BSTR=+IBX_ " DAY"_$S( IBX'=1:"S" ,1:"")_" I NPATIENT C ARE" . S I BX=$$LOS^I BCU64(+IBS TATE,+$P(I BSTATE,U,2 ),+$P(IBCB ILL,U,6)), IBX=IBX-$$ LOS1^IBCU6 4(IBIFN) I IBX>0 S I BSTR=IBSTR _$J("Pass Days: "_IB X,55) ; S IBI="" F S IBI=$O(^ TMP("IBXDI SP",$J,IBI )) Q:'IBI S IBJ=0 F S IBJ=$O (^TMP("IBX DISP",$J,I BI,IBJ)) Q :'IBJ D . S IBX=$G( ^TMP("IBXD ISP",$J,IB I,IBJ)),IB LN=$$SET(I BX,IBLN) . I $E(IBX, 1,3)="001" D COB ; K ^TMP("IBX DISP",$J) ; D MRA S VALMCNT=IB LN-1UB04Q Q ;SETLN(S TR,IBX,COL ,WD) ; S I BX=$$SETST R^VALM1(ST R,IBX,COL, WD) Q IBX ;SET(STR,L N) ; set u p TMP arra y with scr een data ( allows 2 b lank lines , if not a t end of a rray) N IB X,IBI I ST R?80" " S IBLKLN=IBL KLN+1 G SE TQ F IBI=1 :1:IBLKLN D SET^VALM 10(LN," ") S LN=LN+1 Q:IBI>1 D SET^VALM1 0(LN,STR) S LN=LN+1, IBLKLN=0SE TQ Q LN ;C OB ; if th ere is an offset or a secondar y/tertiary payer add it to the display, with ins c o, and pri or bill # ; IBIFN an d IBLN mus t exist up on entry, IBLN is up dated with new line count N IB M,IBM1,IBI ,IBJ,IBD,I BSTR,IBCU2 ,IBCU1 Q:' $G(IBIFN) S IBM=$G(^ DGCR(399,I BIFN,"M")) ,IBM1=$G(^ DGCR(399,I BIFN,"M1") ) S IBCU2= $G(^DGCR(3 99,IBIFN," U2")),IBCU 1=$G(^DGCR (399,IBIFN ,"U1")) S IBJ=$P($G( ^DGCR(399, IBIFN,0)), U,21),IBJ= $S(IBJ="P" :3,IBJ="S" :3,IBJ="T" :3,1:0),IB STR="" I + $P(IBM,U,2 )!(+$P(IBM ,U,3)) F I BI=1:1:IBJ I +$P(IBM ,U,IBI) D S IBLN=$$ SET(IBSTR, IBLN) . I IBSTR="" S IBLN=$$SE T("",IBLN) . S IBD=$ S(IBI=1:"P rimary",IB I=2:"Secon dary",1:"T ertiary")_ ": " S IBS TR=$$SETLN (IBD,"",5, 11) . S IB D=$P($G(^D IC(36,+$P( IBM,U,IBI) ,0)),U,1) S IBSTR=$$ SETLN(IBD, IBSTR,17,2 5) . I $P( IBCU2,U,(I BI+3))'="" S IBD=$J( +$P(IBCU2, U,(IBI+3)) ,9,2) S IB STR=$$SETL N(IBD,IBST R,44,11) . I $P(IBM1 ,U,(IBI+4) )'="" S IB D=$$BN1^PR CAFN(+$P(I BM1,U,(IBI +4))) S IB STR=$$SETL N(IBD,IBST R,60,11) I +$P(IBCU1 ,U,2) D S IBLN=$$SE T(IBSTR,IB LN) . I IB STR="" S I BLN=$$SET( "",IBLN) . S IBD="Of fset: " S IBSTR=$$SE TLN(IBD,"" ,5,11) . S IBD=$P(IB CU1,U,3) S IBSTR=$$S ETLN(IBD,I BSTR,17,25 ) . S IBD= $J($P(IBCU 1,U,2),9,2 ) S IBSTR= $$SETLN(IB D,IBSTR,44 ,11) . S I BD=$P(IBCU 1,U,1)-$P( IBCU1,U,2) ,IBD="Bill ed: "_$J(I BD,0,2) S IBSTR=$$SE TLN(IBD,IB STR,60,17) Q ;RX ;RX refill in fo for CMS -1500 TPJI display N Z,Z0,Z1,I BSPC,IBD,I BI,IBSTR,I BARRAY,IBR XX S IBLN= IBLN+1 S I BSPC=$J("" ,5) D SET^ IBCSC5A(IB IFN,.IBARR AY) I $D(I BARRAY) D . S (Z,Z0) =0 F S Z0 =$O(IBARRA Y(Z0)) Q:Z 0="" S Z1 =0 F S Z1 =$O(IBARRA Y(Z0,Z1)) Q:'Z1 S Z =Z+1 S IBX DATA(Z)=$$ DAT1^IBOUT L(Z1)_U_$G (IBARRAY(Z 0,Z1)) S I BD=$$SET(" ",IBLN) S IBD="PRESC RIPTION RE FILLS: (Fo r TPJI dis play only) " S IBSTR= $$SETLN(IB D,"",1,79) ,IBLN=$$SE T(IBSTR,IB LN) S IBI= 0 F S IBI =$O(IBXDAT A(IBI)) Q: IBI="" D . S IBRXX= $G(IBXDATA (IBI)) . D ZERO^IBRX UTL($P(IBR XX,U,3)) . S IBD=$J( $P(IBRXX,U ,7),9,2)_I BSPC_$P(IB RXX,U)_IBS PC_$G(^TMP ($J,"IBDRU G",+$P(IBR XX,U,3),.0 1)) . K ^T MP($J,"IBD RUG") . S IBSTR=$$SE TLN(IBD,"" ,1,79),IBL N=$$SET(IB STR,IBLN) . S IBD="Q TY: "_$P(I BRXX,U,5)_ " for "_$P (IBRXX,U,4 )_" days s upply "_"N DC# "_$P(I BRXX,U,6) . S IBSTR= $$SETLN(IB D,"",23,79 ),IBLN=$$S ET(IBSTR,I BLN) Q ;PR OS ;prosth etic info for CMS-15 00 TPJI di splay N Z, Z0,Z1,IBAR RAY,IBSPC, IBD,IBI,IB STR S IBSP C=$J("",10 ),IBLN=IBL N+1 D SET^ IBCSC5B(IB IFN,.IBARR AY) I $D(I BARRAY) D . S (Z,Z0) =0 F S Z0 =$O(IBARRA Y(Z0)) Q:Z 0="" S Z1 =0 F S Z1 =$O(IBARRA Y(Z0,Z1)) Q:'Z1 S Z =Z+1,IBXDA TA(Z)=$$DA T1^IBOUTL( Z0)_U_$E($ $PINB^IBCS C5B(+IBARR AY(Z0,Z1)) ,1,39) S I BD=$$SET(" ",IBLN) S IBD="PROST HETIC REFI LLS: (For TPJI displ ay only)" S IBSTR=$$ SETLN(IBD, "",1,79),I BLN=$$SET( IBSTR,IBLN ) S IBI=0 F S IBI=$ O(IBXDATA( IBI)) Q:IB I="" D . S IBD=$P(I BXDATA(IBI ),U)_IBSPC _$P(IBXDAT A(IBI),U,2 ) . S IBST R=$$SETLN( IBD,"",1,7 9),IBLN=$$ SET(IBSTR, IBLN) Q ; | |
| 3763 | ||
| 3764 | ||
| 3765 | Routines | |
| 3766 | Activities | |
| 3767 | Routine Na me | |
| 3768 | IBTRH5D | |
| 3769 | Enhancemen t Category | |
| 3770 | New | |
| 3771 | Modify | |
| 3772 | Delete | |
| 3773 | No Change | |
| 3774 | RTM | |
| 3775 | ||
| 3776 | Related Op tions | |
| 3777 | None | |
| 3778 | Related Ro utines | |
| 3779 | Routines “ Called By” | |
| 3780 | Routines “ Called” | |
| 3781 | ||
| 3782 | ||
| 3783 | ||
| 3784 | ||
| 3785 | Data Dicti onary (DD) Reference s | |
| 3786 | ||
| 3787 | Related Pr otocols | |
| 3788 | None | |
| 3789 | Related In tegration Control Re gistration s (ICRs) | |
| 3790 | None | |
| 3791 | Data Passi ng | |
| 3792 | Input | |
| 3793 | Output Re ference | |
| 3794 | Both | |
| 3795 | Global Re ference | |
| 3796 | Local | |
| 3797 | Input Attr ibute Name and Defin ition | |
| 3798 | Name: | |
| 3799 | Definition : | |
| 3800 | Output Att ribute Nam e and Defi nition | |
| 3801 | Name: | |
| 3802 | Definition : | |
| 3803 | Current Lo gic | |
| 3804 | IBTRH5D ;A LB/FA - HC SR Create 278 Reques t ;12-AUG- 2014 ;;2.0 ;INTEGRATE D BILLING; **517**;21 -MAR-94;Bu ild 240 ;; Per VA Dir ective 640 2, this ro utine shou ld not be modified. ;; ; Conta ins Functi ons used i n creating a 278 req uest from a ; select ed entry i n the HCSR Response worklist ; ; ------- ---------- --------- Entry Poin ts ------- ---------- ---------- ----- ; SE LAPI - All ows the us er to see a quick vi ew of the currently entered ; Additional Patient I nformation lines and either pi ck one to ; edit, e nter a new one or sk ip. ; SELD X - Allows the user to see a q uick view of the cur rently ent ered ; Dia gnoses and either pi ck one to edit, ente r a new on e or ; ski p. ; SELPD - Allows the user t o see a qu ick view o f the curr ently ente red ; Pati ent Event Provider D ata Lines and either pick one to ; edit , enter a new one or skip. ;-- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ----- ;SEL API(IBTRIE N) ;EP ; C alled from within In put templa te IB CREA TE 278 REQ UEST ; Pro vides the user with a quick vi ew of curr ently ente red Additi onal Patie nt ; Infor mation mul tiples and allows th em to sele ct one to edit or en ter a new ; one. ; Input: IBT RIEN - IEN of the 35 6.22 entry being edi ted ; Retu rns: Value of the .0 1 field of the multi ple to edi t ; "" if creating a new multi ple, -2 to exit temp late ; IBN EW - 1 if creating a new entry N AIDATA, CNT,ENTNUM ,FDA,IEN,H 1,H2,L1,L2 ,MAX,RETIE N,RTYPE,SE CT,X,XX,Y, YY S IBNEW =0,SECT="A dditional Patient In formation" ; ; First check for an empty Additional Patient I nformation Line to d elete D DE LAPI(IBTRI EN) ; ; Ne xt create an array o f all curr ent Additi onal Patie nt Informa tion lines to ; disp lay S XX=+ $P($G(^IBT (356.22,IB TRIEN,11,0 )),"^",4) ; Total # of API Lin es S MAX=$ S(XX<10:"" ,1:"Additi onal Patie nt Informa tion Lines ") S IEN=0 ,CNT=0 F D Q:+IEN= 0 . S IEN= $O(^IBT(35 6.22,IBTRI EN,11,IEN) ) . Q:+IEN =0 . S CNT =CNT+1 . S XX=$$LJ^X LFSTR(CNT, 4) ; Selec tion # . S YY=$$GET1 ^DIQ(356.2 211,IEN_", "_DA_",",. 01) ; Repo rt Type De sc . S YY= $E(YY,1,28 )_" " . S XX=XX_$$LJ ^XLFSTR(YY ,30) . S Y Y=$$GET1^D IQ(356.221 1,IEN_","_ DA_",",.02 ) ; Delive ry Method . S YY=$E( YY,1,20)_" " . S XX= XX_$$LJ^XL FSTR(YY,23 ) . S YY=$ $GET1^DIQ( 356.2211,I EN_","_DA_ ",",.03) ; Attachmen t # . S YY =$E(YY,1,2 2) . S XX= XX_$$LJ^XL FSTR(YY,22 ) . S AIDA TA(CNT)=IE N_"^"_XX ; I 'CNT D Q $S($O(R ETIEN(0)): RETIEN($O( RETIEN(0)) ),1:XX) . W !!,"No A dditional Patient In formation is current ly on file .",! . S X X=$$ASKNEW ("Add Addi tional Pat ient Infor mation","N O") . Q:XX <0 . S RTY PE=$$RTYPE (IBTRIEN) ; Get the .01 value . I RTYPE= "" S XX=-1 Q ; N one entere d . S IBNE W=1,XX=RTY PE . S FDA (356.2211, "+1,"_IBTR IEN_",",.0 1)=RTYPE . D UPDATE^ DIE("","FD A","RETIEN ") ; File the new li ne ; ; Nex t display all of the current A dditional Patient In formation S H1="# Re port Type Delivery M ethod Atta chment Con trol #" S H2="-- --- ---------- ---------- ----- ---- ---------- ------- -- ---------- ---------- " S L1="Th e followin g Addition al Patient Informati on is curr ently on f ile." S L2 ="Enter th e # of an entry to e dit, 'NEW' to add on e or press Return to skip." S XX=$$SELEN T(.AIDATA, H1,H2,L1,L 2,MAX,"",S ECT) I XX? 1"D".N D Q -3 . S ( XX,ENTNUM) =$P(XX,"D" ,2) . S XX =$P(AIDATA (XX),U) . D DELAPI(I BTRIEN,XX) . W !,"En try #",ENT NUM," has been delet ed." I XX< 0 Q XX I X X=0 D Q $ S($O(RETIE N(0)):RETI EN($O(RETI EN(0))),1: XX) . S RT YPE=$$RTYP E(IBTRIEN) ; Get the .01 value . I RTYPE ="" S XX=- 1 Q ; None enter ed . S IBN EW=1 . S X X=RTYPE . S FDA(356. 2211,"+1," _IBTRIEN_" ,",.01)=RT YPE . D UP DATE^DIE(" ","FDA","R ETIEN") ; File the n ew line Q $P(AIDATA( XX),"^",1) ;DELAPI(I BTRIEN,IEN ) ; Checks to see if the user entered 'N EW' to cre ate a new ; Additio nal Patien t Informat ion Line a nd didn't enter any data for i t. Also ; checks to see if use r selected to delete a specifi ed line. I f so, the ; Additio nal Patien t Informat ion line w ith no dat a (or sele cted) is d eleted ; I nput: IBTR IEN - IEN of the 356 .22 entry being edit ed ; IEN - Optional, IEN of th e multiple to be del eted if pa ssed ; def aults to " " ; Output : Empty or selected Additional Patient I nformation line is d eleted (Po tentially) N APIIEN, DA,DIK,X,X X,Y S:'$D( IEN) IEN=" " I IEN'=" " D Q . S DA(1)=IBT RIEN,DA=IE N . S DIK= "^IBT(356. 22,DA(1),1 1," . D ^D IK ; Delet e the mult iple ; S A PIIEN=+$P( $G(^IBT(35 6.22,IBTRI EN,11,0)), "^",3) ; L ast Multip le IEN Q:' APIIEN S X X=$G(^IBT( 356.22,IBT RIEN,11,AP IIEN,0)) S $P(XX,"^" ,1)="" ; Remove . 01 field Q :$TR(XX,"^ ","")'="" ; 0 node d ata exists S DA(1)=I BTRIEN,DA= APIIEN S D IK="^IBT(3 56.22,DA(1 ),11," D ^ DIK ; Dele te the mul tiple Q ;R TYPE(IBTRI EN) ; Prom pts the us er to ente r the .01 (Report Ty pe) field of the ; A dditional Patient In formation multiple ; Input: IB TRIEN - IE N of the 3 56.22 entr y being ed ited ; Ret urns: IEN of the sel ected Repo rt Type or "" of not entered N DA,DIR,DI ROUT,DIRUT ,DTOUT,DUO UT,X,Y S D A(1)=IBTRI EN S DIR(0 )="356.221 1,.01",DIR ("A")=" Re port Type" D ^DIR Q: $D(DIRUT) "" Q $P(Y, "^",1) ;SE LPD(IBTRIE N) ;EP ; C alled from within In put templa te IB CREA TE 278 REQ UEST ; Pro vides the user with a quick vi ew of curr ently ente red Provid er Data ; multiples and allows them to s elect one to edit or enter a n ew one. ; Input: IBT RIEN - IEN of the 35 6.22 entry being edi ted ; IBTR BRF - 1 if this disp lay is bei ng used fr om the bri ef templat e ; 0 or u ndefined o therwise ; Returns: Value of t he .01 fie ld of the multiple t o edit ; " " if creat ing a new multiple, -2 to exit template ; IBNEW=1 when creat ing a new entry N CN T,ENTNUM,F DA,IEN,H1, H2,L1,L2,M AX,PDDATA, PTYPE,RETI EN,SECT,X, XX,Y,YY S IBNEW=0,SE CT="Provid er Data In formation" ; ; First check for an empty Provider D ata Line t o delete D DELPD(IBT RIEN) ; ; Next creat e an array of all cu rrent Prov ider Data Informatio n lines S XX=+$P($G( ^IBT(356.2 2,IBTRIEN, 13,0)),"^" ,4) ; # of Multiples S MAX=$S( XX<14:"",1 :"Provider Data Line s") S IEN= 0,CNT=0 F D Q:+IEN =0 . S IEN =$O(^IBT(3 56.22,IBTR IEN,13,IEN )) . Q:+IE N=0 . S CN T=CNT+1 . S XX=$$LJ^ XLFSTR(CNT ,4) ; Sele ction # . S YY=$$GET 1^DIQ(356. 2213,IEN_" ,"_DA_",", .01) ; Pro v Type Des c . S YY=$ E(YY,1,30) _" " . S X X=XX_$$LJ^ XLFSTR(YY, 32) . ; . ; IBTRBRF is defined in IB CRE ATE 278 RE QUEST SHOR T input te mplate . I $G(IBTRBR F)'=1 D . . S YY=$$G ET1^DIQ(35 6.2213,IEN _","_DA_", ",.02) ; P erson/Non- Person . . S XX=XX_$ $LJ^XLFSTR (YY,12) . S YY=$$GET 1^DIQ(356. 2213,IEN_" ,"_DA_",", .03) . S X X=XX_$$LJ^ XLFSTR(YY, "28T") . S PDDATA(CN T)=IEN_"^" _XX ; I ' CNT D Q $ S($O(RETIE N(0)):RETI EN($O(RETI EN(0))),1: XX) .I $G( IBTRBRF)'= 1 D ..W !! ,"No Provi der Data I nformation is curren tly on fil e.",! ..S XX=$$ASKNE W("Add Pro vider Data Informati on") ..Q . I $G(IBTRB RF)=1 S XX =0 .Q:XX<0 .S PTYPE= $$PTYPE(IB TRIEN) ; G et the .01 value .I PTYPE="" S XX=-1 Q ; None entered .S IBNEW=1,X X=PTYPE .S FDA(356.2 213,"+1,"_ IBTRIEN_", ",.01)=PTY PE .D UPDA TE^DIE("", "FDA","RET IEN") ; Fi le the new line .Q ; ; Next di splay all of the cur rent Provi der Data l ines S H1= "# Provide r Type " I $G(IBTRBR F)'=1 S H1 =H1_" Per/ Non" S H1= H1_" Provi der" S H2= "-- ------ ---------- ---------- ----" I $G (IBTRBRF)' =1 S H2=H2 _" ------- ---" S H2= H2_" ----- ---------- ---------- -----" S L 1="The fol lowing Pro vider Data Informati on is curr ently on f ile." S L2 ="Enter th e # of an entry to e dit, 'NEW' to add on e or press Return to skip." S XX=$$SELEN T(.PDDATA, H1,H2,L1,L 2,MAX,"",S ECT) I XX? 1"D".N D Q -3 . S ( XX,ENTNUM) =$P(XX,"D" ,2) . S XX =$P(PDDATA (XX),U) . D DELPD(IB TRIEN,XX) . W !,"Ent ry #",ENTN UM," has b een delete d." I XX<0 Q XX I XX =0 D Q $S ($O(RETIEN (0)):RETIE N($O(RETIE N(0))),1:X X) . S PTY PE=$$PTYPE (IBTRIEN) ; Get the .01 value . I PTYPE= "" S XX=-1 Q ; N one entere d . S XX=P TYPE . S I BNEW=1 . S FDA(356.2 213,"+1,"_ IBTRIEN_", ",.01)=PTY PE . D UPD ATE^DIE("" ,"FDA","RE TIEN") ; F ile the ne w line Q $ P(PDDATA(X X),"^",1) ;DELPD(IBT RIEN,IEN) ; Checks t o see if t he user en tered 'NEW ' to creat e a new ; Provider Data Line and didn't enter any data for it or sele cted a lin e to ; be deleted. If so, the empty or selected P rovider Da ta line is deleted ; Input: IB TRIEN - IE N of the 3 56.22 entr y being ed ited ; IEN - Optiona l, IEN of the multip le to be d eleted if passed ; d efaults to "" ; Outp ut: Empty or selecte d Provider Data line is delete d (Potenti ally) N PD IEN,DA,DIK ,X,XX,Y S: '$D(IEN) I EN="" I IE N'="" D Q . S DA(1) =IBTRIEN,D A=IEN . S DIK="^IBT( 356.22,DA( 1),13," . D ^DIK ; D elete the multiple ; S PDIEN=+ $P($G(^IBT (356.22,IB TRIEN,13,0 )),"^",3) ; Last Mul tiple IEN Q:'PDIEN S XX=$G(^IB T(356.22,I BTRIEN,13, PDIEN,0)) S $P(XX,"^ ",1)="" ; Remove .01 field Q:$TR(XX," ^","")'="" ; 0 node data exist s S DA(1)= IBTRIEN,DA =PDIEN S D IK="^IBT(3 56.22,DA(1 ),13," D ^ DIK ; Dele te the mul tiple Q ;P TYPE(IBTRI EN) ; Prom pts the us er to ente r the .01 (Provider Type) fiel d of the ; Provider Data multi ple ; Inpu t: IBTRIEN - IEN of the 356.22 entry bei ng edited ; Returns: IEN of th e selected Provider Type or "" of not en tered N DA ,DIR,DIROU T,DIRUT,DT OUT,DUOUT, X,Y S DA(1 )=IBTRIEN S DIR(0)=" 356.2213,. 01",DIR("A ")=" Provi der Type" D ^DIR Q:$ D(DIRUT) " " Q $P(Y," ^",1) ;SEL DX(IBTRIEN ) ;EP ; Ca lled from within Inp ut templat e IB CREAT E 278 REQU EST ; Prov ides the u ser with a quick vie w of curre ntly enter ed Diagnos es and ; a llows them to select one to ed it or ente r a new di agnosis. ; Input: IB TRIEN - IE N of the 3 56.22 entr y being ed ited ; IBT RBRF - 1 i f this dis play is be ing used f rom the br ief templa te ; 0 or undefined other othe rwise ; Re turns: Val ue of the .01 field of the mul tiple to e dit ; "" i f creating a new mul tiple, -2 to exit te mplate ; - 3 if a if a line was deleted ; IBNEW=1 w hen creati ng a new e ntry N CNT ,DXDATA,DX TYPE,ENTNU M,FDA,IEN, H1,H2,L1,L 2,MAX,RETI EN,SECT,X, XX,Y,YY S IBNEW=0,SE CT="Diagno sis Inform ation" ; ; First che ck for an empty Diag nosis Line to delete D DELDX(I BTRIEN) ; ; Next cre ate an arr ay of all current Di agnoses li nes S XX=+ $P($G(^IBT (356.22,IB TRIEN,3,0) ),"^",4) ; Total # o f Dx Lines S MAX=$S( XX<12:"",1 :"Diagnosi s Lines") S IEN=0,CN T=0 F D Q:+IEN=0 . S IEN=$O( ^IBT(356.2 2,IBTRIEN, 3,IEN)) . Q:+IEN=0 . S CNT=CNT +1 . S XX= $$LJ^XLFST R(CNT,4) ; Selection # . S YY= $$GET1^DIQ (356.223,I EN_","_DA_ ",",.01,"I ") ; Diagn osis Type . S YY=$$G ET1^DIQ(35 6.006,YY_" ,",.01) . S XX=XX_$$ LJ^XLFSTR( YY,7) . S YY=$$GET1^ DIQ(356.22 3,IEN_","_ DA_",",.02 ) ; Diagno sis . S XX =XX_$$LJ^X LFSTR(YY,1 1) . I $G( IBTRBRF)'= 1 D . . S YY=$$GET1^ DIQ(356.22 3,IEN_","_ DA_",",.03 ) ; Date K nown . . S XX=XX_$$L J^XLFSTR(Y Y,14) . S DXDATA(CNT )=IEN_"^"_ XX ; ; Cre ating 1st Diagnosis Line? I 'C NT D Q $S ($O(RETIEN (0)):RETIE N($O(RETIE N(0))),1:X X) .I $G(I BTRBRF)'=1 D ..W !!, "No Diagno sis Inform ation is c urrently o n file.",! ..S XX=$$ ASKNEW("Ad d a new Di agnosis") ..Q .I $G( IBTRBRF)=1 S XX=0 .Q :XX<0 .S D XTYPE=$$DX TYPE(IBTRI EN) ; Get the .01 va lue .I DXT YPE="" S X X=-1 Q ; None ent ered .S IB NEW=1,XX=D XTYPE .S F DA(356.223 ,"+1,"_IBT RIEN_",",. 01)=DXTYPE .D UPDATE ^DIE("","F DA","RETIE N") ; File the new l ine .Q ; ; Next disp lay all of the curre nt Diagnos es and let the user select one S H1="# T ype Diagno sis" I $G( IBTRBRF)'= 1 S H1=H1_ " Date DX Known" S H 2="-- ---- - -------- -" I $G(IB TRBRF)'=1 S H2=H2_" ---------- ---" S L1= "The follo wing Diagn oses are c urrently o n file." S L2="Enter the # of a Diagnosi s to edit, 'NEW' to add one or press Ret urn to ski p." S XX=$ $SELENT(.D XDATA,H1,H 2,L1,L2,MA X,"",SECT) I XX?1"D" .N D Q -3 . S (XX,E NTNUM)=$P( XX,"D",2) . S XX=$P( DXDATA(XX) ,U) . D DE LDX(IBTRIE N,XX) . W !,"Entry # ",ENTNUM," has been deleted." I XX<0 Q X X I XX=0 D Q $S($O( RETIEN(0)) :RETIEN($O (RETIEN(0) )),1:XX) . S DXTYPE= $$DXTYPE(I BTRIEN) ; Get the .0 1 value . I DXTYPE=" " S XX=-1 Q ; Non e entered . S XX=DXT YPE . S IB NEW=1 . S FDA(356.22 3,"+1,"_IB TRIEN_",", .01)=DXTYP E . D UPDA TE^DIE("", "FDA","RET IEN") ; Fi le the new line Q $P (DXDATA(XX ),"^",1) ; DXTYPE(IBT RIEN) ; Pr ompts the user to en ter the .0 1 (Diagnos is Type) f ield of ; the diagno sis multip le ; Input : IBTRIEN - IEN of t he 356.22 entry bein g edited ; Returns: IEN of the selected Diagnosis Type or "" of not en tered N DA ,DIR,DIROU T,DIRUT,DT OUT,DUOUT, X,Y S DA(1 )=IBTRIEN, DA=$P($G(^ IBT(356.22 ,IBTRIEN,3 ,0)),"^",3 )+1 S DIR( 0)="356.22 3,.01",DIR ("A")=" Di agnosis Qu alifier" D ^DIR Q:$D (DIRUT) "" Q $P(Y,"^ ",1) ;DELD X(IBTRIEN, IEN) ; Che cks to see if the us er entered 'NEW' to create a n ew ; Diag nosis Line and didn' t enter an y data for it or sel ected a mu ltiple to ; to be de leted. If so, the em pty or sel ected mult iple is de leted ; In put: IBTRI EN - IEN o f the 356. 22 entry b eing edite d ; IEN - Optional, IEN of the multiple to be dele ted if pas sed ; defa ults to "" ; Output: Empty or selected D iagnosis l ine is del eted (Pote ntially) N DA,DIK,DX IEN,X,XX,Y S:'$D(IEN ) IEN="" I IEN'="" D Q . S DA (1)=IBTRIE N,DA=IEN . S DIK="^I BT(356.22, DA(1),3," . D ^DIK ; Delete th e multiple ; S DXIEN =+$P($G(^I BT(356.22, IBTRIEN,3, 0)),"^",3) ; Last Mu ltiple IEN Q:'DXIEN S XX=$G(^I BT(356.22, IBTRIEN,3, DXIEN,0)) S $P(XX,"^ ",1)="" ; Remove .01 field Q:$TR(XX," ^","")'="" ; 0 node data exist s S DA(1)= IBTRIEN,DA =DXIEN S D IK="^IBT(3 56.22,DA(1 ),3," D ^D IK ; Delet e the mult iple Q ;AS KNEW(PROMP T,DEFAULT) ;EP ; Ask if user w ants to cr eate a new entry ; I nput: PROM PT - Yes/N o question to ask th e user ; D EFALT - De fault Answ er ; Optio nal, if no t passed, set to 'YE S' ; Retur ns: 0 - Us er wants t o add a ne w Entry ; -1 - User doesn't wa nt to add a new entr y ; -2 - U ser wants to exit te mplate N D IR,DIROUT, DIRUT,DTOU T,DUOUT,X, XX,Y S:'$D (DEFAULT) DEFAULT="Y ES" S XX=$ P(PROMPT," Add ",2) S DIR("?")= "Select NO to skip t his sectio n. Select YES to ent er "_XX_". " S DIR(0) ="Y",DIR(" A")=PROMPT ,DIR("B")= DEFAULTA1 ; D ^DIR I Y?1"^"1.E D JUMPERR ^IBTRH5H G A1 Q:$D(D UOUT) -2 ; User Pres sed ^ Q:$D (DTOUT) -1 ; User ti med out I Y=0 Q -1 Q 1 ;SELENT (ARRAY,H1, H2,L1,L2,M AX,INDENT, SECT) ; Se lect an en try to add /edit from a list ; Input: ARR AY() - Arr ay of mult iple lines to be dis played ; H 1 - 1st li ne of Head er Informa tion ; H2 - 2nd line of Header Informati on ; L1 - 1st line o f DIR disp lay ; L2 - Selection line text ; MAX - M ultiple De scription ; If passe d, enterin g a new li ne is not allowed ; Optional, defaults t o "" if no t passed ; INDENT - 1 to inden t 2 spaces ; Optiona l, default s to 0 ; S ECT - Sect ion Header ; Returns : # - User wants to edit Entry # ; 0 - U ser wants to Add a n ew Entry ; -1 - User wants to skip this section ; -2 - User wants to e xit templa te N DEL,D IR,DIROUT, DIRUT,DOK, DTOUT,DUOU T,IX,LN,X, XX,Y,YY S: '$D(MAX) M AX="" S:'$ D(INDENT) INDENT=0 S :'$D(SECT) SECT="" S DIR(0)="F O",LN=0 S LN=LN+1,DI R("A",LN)= L1 S LN=LN +1,DIR("A" ,LN)=" " S LN=LN+1,D IR("A",LN) =H1 S LN=L N+1,DIR("A ",LN)=H2 S IX="" F D Q:IX="" . S IX=$O (ARRAY(IX) ) . Q:IX=" " . S LN=L N+1,DIR("A ",LN)=$P(A RRAY(IX)," ^",2) S LN =LN+1,DIR( "A",LN)=" " S LN=LN+ 1,DIR("A", LN)=L2 S D IR("A")=$S (INDENT:" ",1:"")_"S election # " W !!SELE 1 ; S XX=" Select NO to skip th is section . Select Y ES to ente r "_SECT_" ." S XX=XX _" To dele te an entr y from the list, sel ect D foll owed by th e " S XX=X X_"number of the ent ry you wis h to delet e." S DIR( "?")=XX D ^DIR S DOK =1 S Y=$$U P^XLFSTR(Y ) ; Conver t to Upper I Y?1"D". N D Q:DOK Y . S XX= $P(Y,"D",2 ) . I XX>0 ,XX'>CNT,X X?.N Q ; Selected Entry to d elete . S DOK=0 . D SELERR(IND ENT) G:'DO K SELE1 I Y?1"^"1.E D JUMPERR^ IBTRH5H G SELE1 I $D (DUOUT) Q -2 ; User pressed ^ I $D(DTOUT ) Q -1 ; U ser timed out I Y="" Q -1 ; Us er pressed return S XX=$$UP^XL FSTR(Y) S YY=$S((XX= "NEW")!(XX ="N")!(XX= "NE"):1,1: 0) ; User wants to e nter a new one I MAX '="",YY D G SELE1 . W *7,!!,$ S(INDENT:" ",1:"") . W "The ma ximum Numb er of "_MA X_" have a lready bee n entered. ",! Q:YY 0 ; Creatin g a new on e I XX>0,X X'>CNT,XX? .N Q XX ; Selected Entry D SE LERR(INDEN T) G SELE1 ;SELERR(I NDENT) ; M ultiple Se lection er ror ; Inpu t: INDENT - 1 to ind ent error message di splay W !! ,*7,$S(IND ENT:" ",1: "") W "Ent er a numbe r from 1-" ,CNT,". En ter NEW to enter a n ew entry." W !,$S(IN DENT:" ",1 :"") W "To delete an entry fro m the list , select D followed by the " W !,$S(INDE NT:" ",1:" ") W "numb er of the entry you wish to re move. Pres s return t o skip sel ection." W !! Q | |
| 3805 | Modified L ogic (Chan ges are in bold) | |
| 3806 | IBTRH5D ;A LB/FA - HC SR Create 278 Reques t ;12-AUG- 2014 ;;2.0 ;INTEGRATE D BILLING; **517,592* *;21-MAR-9 4;Build 24 0 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ;; ; C ontains Fu nctions us ed in crea ting a 278 request f rom a ; se lected ent ry in the HCSR Respo nse workli st ; ; --- ---------- ---------- --- Entry Points --- ---------- ---------- --------- ; SELAPI - Allows th e user to see a quic k view of the curren tly entere d ; Additi onal Patie nt Informa tion lines and eithe r pick one to ; edi t, enter a new one o r skip. ; SELDX - Al lows the u ser to see a quick v iew of the currently entered ; Diagnoses and eithe r pick one to edit, enter a ne w one or ; skip. ; S ELPD - All ows the us er to see a quick vi ew of the currently entered ; Patient Ev ent Provid er Data Li nes and ei ther pick one to ; edit, ente r a new on e or skip. ;-------- ---------- ---------- ---------- ---------- ---------- ---------- --------- ;SELAPI(IB TRIEN) ;EP ; Called from withi n Input te mplate IB CREATE 278 REQUEST ; Provides the user w ith a quic k view of currently entered Ad ditional P atient ; I nformation multiples and allow s them to select one to edit o r enter a new ; one . ; Input: IBTRIEN - IEN of th e 356.22 e ntry being edited ; Returns: V alue of th e .01 fiel d of the m ultiple to edit ; "" if creati ng a new m ultiple, - 2 to exit template ; IBNEW - 1 if creati ng a new e ntry N AID ATA,CNT,EN TNUM,FDA,I EN,H1,H2,L 1,L2,MAX,R ETIEN,RTYP E,SECT,X,X X,Y,YY S I BNEW=0,SEC T="Additio nal Patien t Informat ion" ; ; F irst check for an em pty Additi onal Patie nt Informa tion Line to delete D DELAPI(I BTRIEN) ; ; Next cre ate an arr ay of all current Ad ditional P atient Inf ormation l ines to ; display S XX=+$P($G( ^IBT(356.2 2,IBTRIEN, 11,0)),"^" ,4) ; Tota l # of API Lines S M AX=$S(XX<1 0:"",1:"Ad ditional P atient Inf ormation L ines") S I EN=0,CNT=0 F D Q:+ IEN=0 . S IEN=$O(^IB T(356.22,I BTRIEN,11, IEN)) . Q: +IEN=0 . S CNT=CNT+1 . S XX=$$ LJ^XLFSTR( CNT,4) ; S election # . S YY=$$ GET1^DIQ(3 56.2211,IE N_","_DA_" ,",.01) ; Report Typ e Desc . S YY=$E(YY, 1,28)_" " . S XX=XX_ $$LJ^XLFST R(YY,30) . S YY=$$GE T1^DIQ(356 .2211,IEN_ ","_DA_"," ,.02) ; De livery Met hod . S YY =$E(YY,1,2 0)_" " . S XX=XX_$$L J^XLFSTR(Y Y,23) . S YY=$$GET1^ DIQ(356.22 11,IEN_"," _DA_",",.0 3) ; Attac hment # . S YY=$E(YY ,1,22) . S XX=XX_$$L J^XLFSTR(Y Y,22) . S AIDATA(CNT )=IEN_"^"_ XX ; I 'CN T D Q $S( $O(RETIEN( 0)):RETIEN ($O(RETIEN (0))),1:XX ) . W !!," No Additio nal Patien t Informat ion is cur rently on file.",! . S XX=$$AS KNEW("Add Additional Patient I nformation ","NO") . Q:XX<0 . S RTYPE=$$R TYPE(IBTRI EN) ; Get the .01 va lue . I RT YPE="" S X X=-1 Q ; None en tered . S IBNEW=1,XX =RTYPE . S FDA(356.2 211,"+1,"_ IBTRIEN_", ",.01)=RTY PE . D UPD ATE^DIE("" ,"FDA","RE TIEN") ; F ile the ne w line ; ; Next disp lay all of the curre nt Additio nal Patien t Informat ion S H1=" # Report T ype Delive ry Method Attachment Control # " S H2="-- --------- ---------- --------- ---------- ---------- - -------- ---------- ----" S L1 ="The foll owing Addi tional Pat ient Infor mation is currently on file." S L2="Ente r the # of an entry to edit, ' NEW' to ad d one or p ress Retur n to skip. " S XX=$$S ELENT(.AID ATA,H1,H2, L1,L2,MAX, "",SECT) I XX?1"D".N D Q -3 . S (XX,ENT NUM)=$P(XX ,"D",2) . S XX=$P(AI DATA(XX),U ) . D DELA PI(IBTRIEN ,XX) . W ! ,"Entry #" ,ENTNUM," has been d eleted." I XX<0 Q XX I XX=0 D Q $S($O(R ETIEN(0)): RETIEN($O( RETIEN(0)) ),1:XX) . S RTYPE=$$ RTYPE(IBTR IEN) ; Get the .01 v alue . I R TYPE="" S XX=-1 Q ; None e ntered . S IBNEW=1 . S XX=RTYP E . S FDA( 356.2211," +1,"_IBTRI EN_",",.01 )=RTYPE . D UPDATE^D IE("","FDA ","RETIEN" ) ; File t he new lin e Q $P(AID ATA(XX),"^ ",1) ;DELA PI(IBTRIEN ,IEN) ; Ch ecks to se e if the u ser entere d 'NEW' to create a new ; Add itional Pa tient Info rmation Li ne and did n't enter any data f or it. Als o ; checks to see if user sele cted to de lete a spe cified lin e. If so, the ; Add itional Pa tient Info rmation li ne with no data (or selected) is deleted ; Input: IBTRIEN - IEN of the 356.22 en try being edited ; I EN - Optio nal, IEN o f the mult iple to be deleted i f passed ; defaults to "" ; Ou tput: Empt y or selec ted Additi onal Patie nt Informa tion line is deleted (Potentia lly) N API IEN,DA,DIK ,X,XX,Y S: '$D(IEN) I EN="" I IE N'="" D Q . S DA(1) =IBTRIEN,D A=IEN . S DIK="^IBT( 356.22,DA( 1),11," . D ^DIK ; D elete the multiple ; S APIIEN= +$P($G(^IB T(356.22,I BTRIEN,11, 0)),"^",3) ; Last Mu ltiple IEN Q:'APIIEN S XX=$G(^ IBT(356.22 ,IBTRIEN,1 1,APIIEN,0 )) S $P(XX ,"^",1)="" ; Remo ve .01 fie ld Q:$TR(X X,"^","")' ="" ; 0 no de data ex ists S DA( 1)=IBTRIEN ,DA=APIIEN S DIK="^I BT(356.22, DA(1),11," D ^DIK ; Delete the multiple Q ;RTYPE(I BTRIEN) ; Prompts th e user to enter the .01 (Repor t Type) fi eld of the ; Additio nal Patien t Informat ion multip le ; Input : IBTRIEN - IEN of t he 356.22 entry bein g edited ; Returns: IEN of the selected Report Typ e or "" of not enter ed N DA,DI R,DIROUT,D IRUT,DTOUT ,DUOUT,X,Y S DA(1)=I BTRIEN S D IR(0)="356 .2211,.01" ,DIR("A")= " Report T ype" D ^DI R Q:$D(DIR UT) "" Q $ P(Y,"^",1) ;SELPD(IB TRIEN) ;EP ; Called from withi n Input te mplate IB CREATE 278 REQUEST ; Provides the user w ith a quic k view of currently entered Pr ovider Dat a ; multip les and al lows them to select one to edi t or enter a new one . ; Input: IBTRIEN - IEN of th e 356.22 e ntry being edited ; IBTRBRF - 1 if this display is being use d from the brief tem plate ; 0 or undefin ed otherwi se ; Retur ns: Value of the .01 field of the multip le to edit ; "" if c reating a new multip le, -2 to exit templ ate ; IBNE W=1 when c reating a new entry N CNT,ENTN UM,FDA,IEN ,H1,H2,L1, L2,MAX,PDD ATA,PTYPE, RETIEN,SEC T,X,XX,Y,Y Y S IBNEW= 0,SECT="Pr ovider Dat a Informat ion" ; ; F irst check for an em pty Provid er Data Li ne to dele te D DELPD (IBTRIEN) ; ; Next c reate an a rray of al l current Provider D ata Inform ation line s S XX=+$P ($G(^IBT(3 56.22,IBTR IEN,13,0)) ,"^",4) ; # of Multi ples S MAX =$S(XX<14: "",1:"Prov ider Data Lines") S IEN=0,CNT= 0 F D Q: +IEN=0 . S IEN=$O(^I BT(356.22, IBTRIEN,13 ,IEN)) . Q :+IEN=0 . S CNT=CNT+ 1 . S XX=$ $LJ^XLFSTR (CNT,4) ; Selection # . S YY=$ $GET1^DIQ( 356.2213,I EN_","_DA_ ",",.01) ; Prov Type Desc . S YY=$E(YY,1 ,30)_" " . S XX=XX_$ $LJ^XLFSTR (YY,32) . ; . ; IBTR BRF is def ined in IB CREATE 27 8 REQUEST SHORT inpu t template . I $G(IB TRBRF)'=1 D . . S YY =$$GET1^DI Q(356.2213 ,IEN_","_D A_",",.02) ; Person/ Non-Person . . S XX= XX_$$LJ^XL FSTR(YY,12 ) . S YY=$ $GET1^DIQ( 356.2213,I EN_","_DA_ ",",.03) . S XX=XX_$ $LJ^XLFSTR (YY,"28T") . S PDDAT A(CNT)=IEN _"^"_XX ; I 'CNT D Q $S($O(R ETIEN(0)): RETIEN($O( RETIEN(0)) ),1:XX) .I $G(IBTRBR F)'=1 D .. W !!,"No P rovider Da ta Informa tion is cu rrently on file.",! ..S XX=$$A SKNEW("Add Provider Data Infor mation") . .Q .I $G(I BTRBRF)=1 S XX=0 .Q: XX<0 .S PT YPE=$$PTYP E(IBTRIEN) ; Get the .01 value .I PTYPE= "" S XX=-1 Q ; N one entere d .S IBNEW =1,XX=PTYP E .S FDA(3 56.2213,"+ 1,"_IBTRIE N_",",.01) =PTYPE .D UPDATE^DIE ("","FDA", "RETIEN") ; File the new line .Q ; ; Nex t display all of the current P rovider Da ta lines S H1="# Pro vider Type " I $G(IB TRBRF)'=1 S H1=H1_" Per/Non" S H1=H1_" P rovider" S H2="-- -- ---------- ---------- --------" I $G(IBTRB RF)'=1 S H 2=H2_" --- -------" S H2=H2_" - ---------- ---------- ---------" S L1="The following Provider Data Infor mation is currently on file." S L2="Ente r the # of an entry to edit, ' NEW' to ad d one or p ress Retur n to skip. " S XX=$$S ELENT(.PDD ATA,H1,H2, L1,L2,MAX, "",SECT) I XX?1"D".N D Q -3 . S (XX,ENT NUM)=$P(XX ,"D",2) . S XX=$P(PD DATA(XX),U ) . D DELP D(IBTRIEN, XX) . W !, "Entry #", ENTNUM," h as been de leted." I XX<0 Q XX I XX=0 D Q $S($O(RE TIEN(0)):R ETIEN($O(R ETIEN(0))) ,1:XX) . S PTYPE=$$P TYPE(IBTRI EN) ; Get the .01 va lue . I PT YPE="" S X X=-1 Q ; None en tered . S XX=PTYPE . S IBNEW=1 . S FDA(3 56.2213,"+ 1,"_IBTRIE N_",",.01) =PTYPE . D UPDATE^DI E("","FDA" ,"RETIEN") ; File th e new line Q $P(PDDA TA(XX),"^" ,1) ;DELPD (IBTRIEN,I EN) ; Chec ks to see if the use r entered 'NEW' to c reate a ne w ; Provi der Data L ine and di dn't enter any data for it or selected a line to ; be delet ed. If so, the empty or select ed Provide r Data lin e is delet ed ; Input : IBTRIEN - IEN of t he 356.22 entry bein g edited ; IEN - Opt ional, IEN of the mu ltiple to be deleted if passed ; default s to "" ; Output: Em pty or sel ected Prov ider Data line is de leted (Pot entially) N PDIEN,DA ,DIK,X,XX, Y S:'$D(IE N) IEN="" I IEN'="" D Q . S D A(1)=IBTRI EN,DA=IEN . S DIK="^ IBT(356.22 ,DA(1),13, " . D ^DIK ; Delete the multip le ; S PDI EN=+$P($G( ^IBT(356.2 2,IBTRIEN, 13,0)),"^" ,3) ; Last Multiple IEN Q:'PDI EN S XX=$G (^IBT(356. 22,IBTRIEN ,13,PDIEN, 0)) S $P(X X,"^",1)=" " ; Rem ove .01 fi eld Q:$TR( XX,"^","") '="" ; 0 n ode data e xists S DA (1)=IBTRIE N,DA=PDIEN S DIK="^I BT(356.22, DA(1),13," D ^DIK ; Delete the multiple Q ;PTYPE(I BTRIEN) ; Prompts th e user to enter the .01 (Provi der Type) field of t he ; Provi der Data m ultiple ; Input: IBT RIEN - IEN of the 35 6.22 entry being edi ted ; Retu rns: IEN o f the sele cted Provi der Type o r "" of no t entered N DA,DIR,D IROUT,DIRU T,DTOUT,DU OUT,X,Y S DA(1)=IBTR IEN S DIR( 0)="356.22 13,.01",DI R("A")=" P rovider Ty pe" D ^DIR Q:$D(DIRU T) "" Q $P (Y,"^",1) ;SELDX(IBT RIEN) ;EP ; Called f rom within Input tem plate IB C REATE 278 REQUEST ; Provides t he user wi th a quick view of c urrently e ntered Dia gnoses and ; allows them to se lect one t o edit or enter a ne w diagnosi s. ; Input : IBTRIEN - IEN of t he 356.22 entry bein g edited ; IBTRBRF - 1 if this display i s being us ed from th e brief te mplate ; 0 or undefi ned other otherwise ; Returns: Value of the .01 fi eld of the multiple to edit ; "" if crea ting a new multiple, -2 to exi t template ; -3 if a if a line was delet ed ; IBNEW =1 when cr eating a n ew entry N CNT,DXDAT A,DXTYPE,E NTNUM,FDA, IEN,H1,H2, L1,L2,MAX, RETIEN,SEC T,X,XX,Y,Y Y S IBNEW= 0,SECT="Di agnosis In formation" ; ; First check for an empty Diagnosis Line to de lete D DEL DX(IBTRIEN ) ; ; Next create an array of all curren t Diagnose s lines S XX=+$P($G( ^IBT(356.2 2,IBTRIEN, 3,0)),"^", 4) ; Total # of Dx L ines S MAX =$S(XX<12: "",1:"Diag nosis Line s") S IEN= 0,CNT=0 F D Q:+IEN =0 . S IEN =$O(^IBT(3 56.22,IBTR IEN,3,IEN) ) . Q:+IEN =0 . S CNT =CNT+1 . S XX=$$LJ^X LFSTR(CNT, 4) ; Selec tion # . S YY=$$GET1 ^DIQ(356.2 23,IEN_"," _DA_",",.0 1,"I") ; D iagnosis T ype . S YY =$$GET1^DI Q(356.006, YY_",",.01 ) . S XX=X X_$$LJ^XLF STR(YY,7) . S YY=$$G ET1^DIQ(35 6.223,IEN_ ","_DA_"," ,.02) ; Di agnosis . S XX=XX_$$ LJ^XLFSTR( YY,11) . I $G(IBTRBR F)'=1 D . . S YY=$$G ET1^DIQ(35 6.223,IEN_ ","_DA_"," ,.03) ; Da te Known . . S XX=XX _$$LJ^XLFS TR(YY,14) . S DXDATA (CNT)=IEN_ "^"_XX ; ; Creating 1st Diagno sis Line? I 'CNT D Q $S($O(RE TIEN(0)):R ETIEN($O(R ETIEN(0))) ,1:XX) .I $G(IBTRBRF )'=1 D ..W !!,"No Di agnosis In formation is current ly on file .",! ..S X X=$$ASKNEW ("Add a ne w Diagnosi s") ..Q .I $G(IBTRBR F)=1 S XX= 0 .Q:XX<0 .S DXTYPE= $$DXTYPE(I BTRIEN) ; Get the .0 1 value .I DXTYPE="" S XX=-1 Q ; None entered . S IBNEW=1, XX=DXTYPE .S FDA(356 .223,"+1," _IBTRIEN_" ,",.01)=DX TYPE .D UP DATE^DIE(" ","FDA","R ETIEN") ; File the n ew line .Q ; ; Next display al l of the c urrent Dia gnoses and let the u ser select one S H1= "# Type Di agnosis" I $G(IBTRBR F)'=1 S H1 =H1_" Date DX Known" S H2="-- ----- ---- -----" I $ G(IBTRBRF) '=1 S H2=H 2_" ------ -------" S L1="The f ollowing D iagnoses a re current ly on file ." S L2="E nter the # of a Diag nosis to e dit, 'NEW' to add on e or press Return to skip." S XX=$$SELEN T(.DXDATA, H1,H2,L1,L 2,MAX,"",S ECT) I XX? 1"D".N D Q -3 . S ( XX,ENTNUM) =$P(XX,"D" ,2) . S XX =$P(DXDATA (XX),U) . D DELDX(IB TRIEN,XX) . W !,"Ent ry #",ENTN UM," has b een delete d." I XX<0 Q XX I XX =0 D Q $S ($O(RETIEN (0)):RETIE N($O(RETIE N(0))),1:X X) . S DXT YPE=$$DXTY PE(IBTRIEN ) ; Get th e .01 valu e . I DXTY PE="" S XX =-1 Q ; None ente red . S XX =DXTYPE . S IBNEW=1 . S FDA(35 6.223,"+1, "_IBTRIEN_ ",",.01)=D XTYPE . D UPDATE^DIE ("","FDA", "RETIEN") ; File the new line Q $P(DXDAT A(XX),"^", 1) ;DXTYPE (IBTRIEN) ; Prompts the user t o enter th e .01 (Dia gnosis Typ e) field o f ; the di agnosis mu ltiple ; I nput: IBTR IEN - IEN of the 356 .22 entry being edit ed ; Retur ns: IEN of the selec ted Diagno sis Type o r "" of no t entered N DA,DIR,D IROUT,DIRU T,DTOUT,DU OUT,X,Y S DA(1)=IBTR IEN,DA=$P( $G(^IBT(35 6.22,IBTRI EN,3,0))," ^",3)+1 S DIR(0)="35 6.223,.01" ,DIR("A")= " Diagnosi s Qualifie r" D ^DIR Q:$D(DIRUT ) "" Q $P( Y,"^",1) ; DELDX(IBTR IEN,IEN) ; Checks to see if th e user ent ered 'NEW' to create a new ; Diagnosis Line and d idn't ente r any data for it or selected a multiple to ; to b e deleted. If so, th e empty or selected multiple i s deleted ; Input: I BTRIEN - I EN of the 356.22 ent ry being e dited ; IE N - Option al, IEN of the multi ple to be deleted if passed ; defaults t o "" ; Out put: Empty or select ed Diagnos is line is deleted ( Potentiall y) N DA,DI K,DXIEN,X, XX,Y S:'$D (IEN) IEN= "" I IEN'= "" D Q . S DA(1)=IB TRIEN,DA=I EN . S DIK ="^IBT(356 .22,DA(1), 3," . D ^D IK ; Delet e the mult iple ; S D XIEN=+$P($ G(^IBT(356 .22,IBTRIE N,3,0)),"^ ",3) ; Las t Multiple IEN Q:'DX IEN S XX=$ G(^IBT(356 .22,IBTRIE N,3,DXIEN, 0)) S $P(X X,"^",1)=" " ; Rem ove .01 fi eld Q:$TR( XX,"^","") '="" ; 0 n ode data e xists S DA (1)=IBTRIE N,DA=DXIEN S DIK="^I BT(356.22, DA(1),3," D ^DIK ; D elete the multiple Q ;ASKNEW(P ROMPT,DEFA ULT) ;EP ; Ask if us er wants t o create a new entry ; Input: PROMPT - Y es/No ques tion to as k the user ; DEFALT - Default Answer ; O ptional, i f not pass ed, set to 'YES' ; R eturns: 0 - User wan ts to add a new Entr y ; -1 - U ser doesn' t want to add a new entry ; -2 - User wa nts to exi t template N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,XX,Y S :'$D(DEFAU LT) DEFAUL T="YES" S XX=$P(PROM PT,"Add ", 2) S DIR(" ?")="Selec t NO to sk ip this se ction. Sel ect YES to enter "_X X_"." S DI R(0)="Y",D IR("A")=PR OMPT,DIR(" B")=DEFAUL TA1 ; D ^D IR I Y?1"^ "1.E D JUM PERR^IBTRH 5H G A1 Q: $D(DUOUT) -2 ; User Pressed ^ Q:$D(DTOUT ) -1 ; Use r timed ou t I Y=0 Q -1 Q 1 ;SE LENT(ARRAY ,H1,H2,L1, L2,MAX,IND ENT,SECT) ; Select a n entry to add/edit from a lis t ; Input: ARRAY() - Array of multiple l ines to be displayed ; H1 - 1s t line of Header Inf ormation ; H2 - 2nd line of He ader Infor mation ; L 1 - 1st li ne of DIR display ; L2 - Selec tion line text ; MAX - Multipl e Descript ion ; If p assed, ent ering a ne w line is not allowe d ; Option al, defaul ts to "" i f not pass ed ; INDEN T - 1 to i ndent 2 sp aces ; Opt ional, def aults to 0 ; SECT - Section He ader ; Ret urns: # - User wants to edit E ntry # ; 0 - User wa nts to Add a new Ent ry ; -1 - User wants to skip t his sectio n ; -2 - U ser wants to exit te mplate N D EL,DIR,DIR OUT,DIRUT, DOK,DTOUT, DUOUT,IX,L N,X,XX,Y,Y Y S:'$D(MA X) MAX="" S:'$D(INDE NT) INDENT =0 S:'$D(S ECT) SECT= "" S DIR(0 )="FO",LN= 0 S LN=LN+ 1,DIR("A", LN)=L1 S L N=LN+1,DIR ("A",LN)=" " S LN=LN +1,DIR("A" ,LN)=H1 S LN=LN+1,DI R("A",LN)= H2 S IX="" F D Q:I X="" . S I X=$O(ARRAY (IX)) . Q: IX="" . S LN=LN+1,DI R("A",LN)= $P(ARRAY(I X),"^",2) S LN=LN+1, DIR("A",LN )=" " S LN =LN+1,DIR( "A",LN)=L2 S DIR("A" )=$S(INDEN T:" ",1:"" )_"Selecti on #" W !! SELE1 ; ;S XX="Selec t NO to sk ip this se ction. Sel ect YES to enter "_S ECT_"." S XX="To del ete an ent ry from th e list, se lect D fol lowed by t he " S XX= XX_"number of the en try you wi sh to dele te." S DIR ("?")=XX D ^DIR S DO K=1 S Y=$$ UP^XLFSTR( Y) ; Conve rt to Uppe r I Y?1"D" .N D Q:DO K Y . S XX =$P(Y,"D", 2) . I XX> 0,XX'>CNT, XX?.N Q ; Selected Entry to delete . S DOK=0 . D SELERR(IN DENT) G:'D OK SELE1 I Y?1"^"1.E D JUMPERR ^IBTRH5H G SELE1 I $ D(DUOUT) Q -2 ; User pressed ^ I $D(DTOU T) Q -1 ; User timed out I Y=" " Q -1 ; U ser presse d return S XX=$$UP^X LFSTR(Y) S YY=$S((XX ="NEW")!(X X="N")!(XX ="NE"):1,1 :0) ; User wants to enter a ne w one I MA X'="",YY D G SELE1 . W *7,!!, $S(INDENT: " ",1:"") . W "The m aximum Num ber of "_M AX_" have already be en entered .",! . ;JW S;IB*2.0*5 92 . I +CN T>21 R !!, "Press <EN TER> to co ntinue",X: 30 Q:YY 0 ; Creating a new one I XX>0,XX '>CNT,XX?. N Q XX ; Selected E ntry D SEL ERR(INDENT ) G SELE1 ;SELERR(IN DENT) ; Mu ltiple Sel ection err or ; Input : INDENT - 1 to inde nt error m essage dis play W !!, *7,$S(INDE NT:" ",1:" ") W "Ente r a number from 1-", CNT,". Ent er NEW to enter a ne w entry." W !,$S(IND ENT:" ",1: "") W "To delete an entry from the list, select D followed b y the " W !,$S(INDEN T:" ",1:"" ) W "numbe r of the e ntry you w ish to rem ove. Press return to skip sele ction." W !! Q | |
| 3807 | ||
| 3808 | ||
| 3809 | The follow ing input template n eeds to be modified to handle the change s to IB SC REEN8. | |
| 3810 | NUMBER: 15 13 NA ME: IB SCR EEN8 | |
| 3811 | DATE CRE ATED: MAR 13, 2014@0 9:53 READ ACCES S: @ | |
| 3812 | FILE: BI LL/CLAIMS WRITE ACCE SS: @ | |
| 3813 | DATE LAS T USED: MA R 20, 2017 | |
| 3814 | ROUTINE INVOKED: ^ IBXS8 PREVIOUS R OUTINE INV OKED: IBXS 8 | |
| 3815 | EDIT FIE LDS (c) | |
| 3816 | ||
| 3817 | : @81 | |
| 3818 | : I $$FT^I BCU3(IBIFN )=7 S Y="@ 801" | |
| 3819 | : S:IBDR20 '["81" Y=" @82" | |
| 3820 | : COB TOTA L NON-COVE RED AMOUNT ;"COB Non- Covered Ch arge Amt" | |
| 3821 | : @82 | |
| 3822 | : S:IBDR20 '["82" Y=" @83" | |
| 3823 | : PROPERTY /CASUALTY CLAIM NUMB ER;"Claim Number" | |
| 3824 | : S:IBT=3 Y="@84" | |
| 3825 | : PROP/CAS DATE OF 1 ST CONTACT ;"Date of 1st Contac t" | |
| 3826 | : PROPERTY /CASUALTY CONTACT NA ME;"Contac t Name" | |
| 3827 | : PROP/CAS COMMUNICA TION NUMBE R;"Contact Phone" | |
| 3828 | : PROP/CAS EXTENSION NUMBER;"C ontact Pho ne Extensi on" | |
| 3829 | : @83 | |
| 3830 | : S:IBDR20 '["83" Y=" @84" | |
| 3831 | : PRIMARY SURGICAL P ROC CODE;" Primary Co de" | |
| 3832 | : SECONDAR Y SURGICAL PROC CODE ;"Secondar y Code" | |
| 3833 | : @84 | |
| 3834 | : S:IBDR20 '["84" Y=" @85" | |
| 3835 | : ATTACHME NT REPORT TYPE;"Repo rt Type" | |
| 3836 | : ATTACHME NT REPORT TRANS CODE ;"Transmis sion Metho d" | |
| 3837 | : ATTACHME NT CONTROL NUMBER;"A ttachment Control #" | |
| 3838 | : @85 | |
| 3839 | : S:IBDR20 '["85" Y=" @86" | |
| 3840 | : DISABILI TY START D ATE;"Disab ility Star t Date" | |
| 3841 | : DISABILI TY END DAT E;"Disabil ity End Da te" | |
| 3842 | : @86 | |
| 3843 | : S:IBDR20 '["86" Y=" @87" | |
| 3844 | : S:$P($G( ^DGCR(IBIF N,0)),U,19 )=3 Y="@87 " | |
| 3845 | : ASSUMED CARE DATE; "Assumed C are Date" | |
| 3846 | : RELINQUI SHED CARE DATE;"Reli nquished C are Date" | |
| 3847 | : @87 | |
| 3848 | : S:IBDR20 '["87" Y=" @88" | |
| 3849 | : SPECIAL PROGRAM IN DICATOR/// /^S X=$S($ P($G(^DGCR (399,DA, | |
| 3850 | "U2")),U,1 6)'="":$P( $G(^DGCR(3 99,DA,"U2" )),U,16), | |
| 3851 | $$WNRBILL^ IBEFUNC(DA ):"31",1:" ") | |
| 3852 | : SPECIAL PROGRAM IN DICATOR;"S pecial Pro gram" | |
| 3853 | : @88 | |
| 3854 | : S:IBDR20 '["88" Y=" @89" | |
| 3855 | : HOMEBOUN D;"Homebou nd" | |
| 3856 | : @89 | |
| 3857 | : S:IBDR20 '["89" Y=" @899" | |
| 3858 | : DATE LAS T SEEN;"Da te Last Se en" | |
| 3859 | : @899 COMPI LED (c): Y ES | |
| 3860 | EDIT FIELD S (c): @81 | |
| 3861 | : S:IBDR20 '["81" Y=" @82" | |
| 3862 | : COB TOTA L NON-COVE RED AMOUNT ;"COB Non- Covered Ch arge Amt" | |
| 3863 | : @82 | |
| 3864 | : S:IBDR 20'["82" Y ="@83" | |
| 3865 | : PROPERTY /CASUALTY CLAIM NUMB ER;"Claim Number" | |
| 3866 | : S:IBT=3 Y="@84" | |
| 3867 | : PROP/CAS DATE OF 1 ST CONTACT ;"Date of 1st Contac t" | |
| 3868 | : PROPERTY /CASUALTY CONTACT NA ME;"Contac t Name" | |
| 3869 | : PROP/CAS COMMUNICA TION NUMBE R;"Contact Phone" | |
| 3870 | : PROP/CAS EXTENSION NUMBER;"C ontact Pho ne Extensi on" | |
| 3871 | : @83 | |
| 3872 | : S:IBDR20 '["83" Y=" @84" | |
| 3873 | : PRIMARY SURGICAL P ROC CODE;" Primary Co de" | |
| 3874 | : SECONDAR Y SURGICAL PROC CODE ;"Secondar y Code" | |
| 3875 | : @84 | |
| 3876 | : S:IBDR20 '["84" Y=" @85" | |
| 3877 | : ATTACHME NT REPORT TYPE;"Repo rt Type" | |
| 3878 | : ATTACHME NT REPORT TRANS CODE ;"Transmis sion Metho d" | |
| 3879 | : ATTACHME NT CONTROL NUMBER;"A ttachment Control #" | |
| 3880 | : @85 | |
| 3881 | : S:IBDR20 '["85" Y=" @86" | |
| 3882 | : DISABILI TY START D ATE;"Disab ility Star t Date" | |
| 3883 | : DISABILI TY END DAT E;"Disabil ity End Da te" | |
| 3884 | : @86 | |
| 3885 | : S:IBDR20 '["86" Y=" @87" | |
| 3886 | : S:$P($G( ^DGCR(IBIF N,0)),U,19 )=3 Y="@87 " | |
| 3887 | : ASSUMED CARE DATE; "Assumed C are Date" | |
| 3888 | : RELINQUI SHED CARE DATE;"Reli nquished C are Date" | |
| 3889 | : @87 | |
| 3890 | : S:IBDR20 '["87" Y=" @88" | |
| 3891 | : 238////^ S X=$S($P( $G(^DGCR(3 99,DA,"U2" )),U,16)'= "": | |
| 3892 | $P($G(^DGC R(399,DA," U2")),U,16 ),$$WNRBIL L^IBEFUNC( DA):"31",1 :"") | |
| 3893 | : SPECIAL PROGRAM IN DICATOR;"S pecial Pro gram" | |
| 3894 | : @88 | |
| 3895 | : S:IBDR20 '["88" Y=" @89" | |
| 3896 | : HOMEBOUN D;"Homebou nd" | |
| 3897 | : @89 | |
| 3898 | : S:IBDR20 '["89" Y=" @899" | |
| 3899 | : DATE LAS T SEEN;"Da te Last Se en" | |
| 3900 | : Y=”@899” | |
| 3901 | : @801 | |
| 3902 | : S:IBDR20 '["81" Y=" @802" | |
| 3903 | : TOOTH ST ATUS | |
| 3904 | : TOOTH NU MBER;"Toot h Number" | |
| 3905 | : STATUS C ODE;”Statu s Code” | |
| 3906 | ; @802 | |
| 3907 | : S:IBDR20 '["82" Y=" @803" | |
| 3908 | ; BANDING DATE;”Band ing Date” | |
| 3909 | : TREATMEN T INDICATO R;"Treatme nt Indicat or" | |
| 3910 | : TREATMEN T MONTHS C OUNT;"Trea tment Mont hs Count" | |
| 3911 | : TREATMEN T MONTHS R EMAINING;" Treatment Months | |
| 3912 | Remaining Count" | |
| 3913 | ; @803 | |
| 3914 | : S:IBDR20 '["83" Y=" @899" | |
| 3915 | : ATTACHME NT REPORT TYPE;"Repo rt Type" | |
| 3916 | : ATTACHME NT REPORT TRANS CODE ;"Transmis sion Metho d" | |
| 3917 | : ATTACHME NT CONTROL NUMBER;"A ttachment Control #" | |
| 3918 | : @899 | |
| 3919 | ||
| 3920 | The follow ing input template n eeds to be modified to handle the change s to IB SC REEN 10. | |
| 3921 | NUMBER: 2787 NAME: IB S CREEN10H | |
| 3922 | DATE CRE ATED: MAR 07, 2017@1 1:12 READ ACCES S: @ | |
| 3923 | FILE: BI LL/CLAIMS USER #: 52 0824637 | |
| 3924 | WRITE AC CESS: @ DATE LAST USED: MAR 07, 2017 | |
| 3925 | ROUTINE INVOKED: ^ IBXSAH PREVIOUS R OUTINE INV OKED:IBXSA H | |
| 3926 | EDIT FIE LDS (c) | |
| 3927 | : K DI PA S DIPA( "I1")=$G(^ DGCR(399,D A, | |
| 3928 | "I1")),DIP A("I2")=$G (^("I2")), | |
| 3929 | DIPA("I3") =$G(^("I3" )) | |
| 3930 | : S:I BDR20'["10 1" Y="@102 " | |
| 3931 | : UNA BLE TO WOR K FROM | |
| 3932 | : UNA BLE TO WOR K TO | |
| 3933 | : @10 2 | |
| 3934 | : S:I BDR20'["10 2" Y="@103 " | |
| 3935 | : S:' $$INPAT^IB CEF(DA) Y= "@1021" | |
| 3936 | : ADM ITTING DIA GNOSIS | |
| 3937 | : @10 21 | |
| 3938 | : FOR M LOCATOR 64A;T | |
| 3939 | : S:' DIPA("I2") Y="@1025" | |
| 3940 | : FOR M LOCATOR 64B;T | |
| 3941 | : S:' DIPA("I3") Y="@1025" | |
| 3942 | : FOR M LOCATOR 64C | |
| 3943 | : @10 25 | |
| 3944 | : TRE ATMENT AUT HORIZATION CODE;"PRI MARY AUTHO RIZATION | |
| 3945 | CODE" | |
| 3946 | : PRI MARY REFER RAL NUMBER | |
| 3947 | : S:' DIPA("I2") Y="@1029" | |
| 3948 | : SEC ONDARY AUT HORIZATION CODE | |
| 3949 | : SEC ONDARY REF ERRAL NUMB ER | |
| 3950 | : S:' DIPA("I3") Y="@1029" | |
| 3951 | : TER TIARY AUTH ORIZATION CODE | |
| 3952 | : TER TIARY REFE RRAL NUMBE R | |
| 3953 | : @10 29 | |
| 3954 | : @10 3 | |
| 3955 | : S:I BDR20'["10 3" Y="@104 " | |
| 3956 | : PRO VIDER | |
| 3957 | : FUNCTION | |
| 3958 | : S DIPA("RF ")=X S:$D( ^XUSEC("IB PROVIDER EDIT",DUZ) ) | |
| 3959 | DLAYGO=35 5.93 | |
| 3960 | : PERFORMED BY | |
| 3961 | : K DLAYGO S DIPA("PRF ")=X S:X=" " Y="@1039 9" | |
| 3962 | : N Z1 S Z1= $P($G(^DGC R(399,DA(1 ),"PRV",DA ,0)),U,2) | |
| 3963 | S DIPA("N VA_PRV")=$ S(Z1["IBA( 355.93":+Z 1,1:0) | |
| 3964 | : S:DIPA("NV A_PRV")=0 Y="@1038" | |
| 3965 | : PERFORMED BY:355.93: | |
| 3966 | : S DIPA( "NVA_PRV- | |
| 3967 | 0")=$G(^IB A(355.93,D IPA("NVA_P RV"),0)) | |
| 3968 | : S:$P(DI PA("NVA_PR V-0"),U,2) =1 Y="@103 2" | |
| 3969 | : S:$P(DI PA("NVA_PR V-0"),U,3) '="" Y="@1 031" | |
| 3970 | : CREDENT IALS | |
| 3971 | : @1031 | |
| 3972 | : S:$P(DI PA("NVA_PR V-0"),U,3) '="" Y="@1 035" | |
| 3973 | : SPECIAL TY | |
| 3974 | : S Y="@1 035" | |
| 3975 | : @1032 | |
| 3976 | : S:$P(DI PA("NVA_PR V- | |
| 3977 | 0"),U,5)'= ""&($P(DIP A("NVA_PRV -0"),U,6 | |
| 3978 | )'="")&($P (DIPA("NVA _PRV-0"),U ,7)'="") | |
| 3979 | Y="@1033" | |
| 3980 | : STREET ADDRESS | |
| 3981 | : STREET ADDRESS LI NE 2 | |
| 3982 | : CITY | |
| 3983 | : STATE | |
| 3984 | : ZIP COD E | |
| 3985 | : @1033 | |
| 3986 | : S:$P(DI PA("NVA_PR V-0"),U,9) '="" Y="@1 034" | |
| 3987 | : FACILIT Y DEFAULT ID NUMBER; "LAB OR FA CILITY | |
| 3988 | PRIMARY I D" | |
| 3989 | : @1034 | |
| 3990 | : S:$P(DI PA("NVA_PR V-0"),U,11 )'="" Y="@ 1035" | |
| 3991 | : X12 TYP E OF FACIL ITY | |
| 3992 | : @1035 | |
| 3993 | : S:$P(DI PA("NVA_PR V-0"),U,14 )'="" Y="@ 1036" | |
| 3994 | : D EN2^I BCEP82(DIP A("NVA_PRV "),4) | |
| 3995 | : @1036 | |
| 3996 | : S:$D(^I BA(355.93, DIPA("NVA_ PRV"),"TAX ONOMY"))>0 | |
| 3997 | Y="@1037" | |
| 3998 | : TAXONOM Y CODE | |
| 3999 | : ALL | |
| 4000 | : @1037 | |
| 4001 | : @1038 | |
| 4002 | : S DIK="^DG CR(399,"_D A(1)_",""P RV"",",DIK (1)=".02" D | |
| 4003 | EN1^DIK K DIK | |
| 4004 | : TAXONOMY | |
| 4005 | : D DISPTAX^ IBCEP81($P ($G(^DGCR( 399,DA(1), "PRV" | |
| 4006 | ,DA,0)),U, 15),"") | |
| 4007 | : N Z S Z=$$ EXPAND^IBT RE(399.022 2,.08,$P($ G(^DGCR(39 9 | |
| 4008 | ,DA(1),"PR V",DA,0)), U,8)),DIPA ("SPC")=$S (Z'="":Z,1 :"UNSPECIF IED") W !, " Prov Specialty On File: " ,DIPA("SPC ") | |
| 4009 | : S DIPA("CR D")=$$CRED ^IBCEU($P( ^DGCR(399 | |
| 4010 | ,DA(1),"PR V",DA,0),U ,2)) | |
| 4011 | : CREDENTIAL S | |
| 4012 | : K DIPA("W1 ") S:$G(DI PA("CRD")) '=$P(^DGCR (399 | |
| 4013 | ,DA(1),"PR V",DA,0),U ,3) DIPA(" W1")=1 | |
| 4014 | : I $G(DIPA( "W1")) D W RT1^IBCSC1 0H($G(DIPA ("CRD"))) | |
| 4015 | : K DIPA("W1 ") | |
| 4016 | : I '$G(DIPA ("I1")) S Y="@10305" | |
| 4017 | : D PROVID^I BCEP2B(DA( 1),DA,1,.D IPA) S | |
| 4018 | Y=$S(DIPA( "EDIT")<0: "@10382", | |
| 4019 | DIPA("EDIT ")=1:"@103 91",DIPA(" EDIT") | |
| 4020 | =2:"@10371 ",1:"") | |
| 4021 | : @10382 | |
| 4022 | : I '$G(DIPA ("I2")) S Y="@10305" | |
| 4023 | : D PROVID^I BCEP2B(DA( 1),DA,2,.D IPA) S | |
| 4024 | Y=$S(DIPA ("EDIT")<0 :"@10383", | |
| 4025 | DIPA("EDIT ")=1:"@103 92",DIPA(" EDIT") | |
| 4026 | =2:"@10372 ",1:"") | |
| 4027 | : @10383 | |
| 4028 | : I '$G(DIPA ("I3")) S Y="@10305" | |
| 4029 | : D PROVID^I BCEP2B(DA( 1),DA,3,.D IPA) S | |
| 4030 | Y=$S(DIPA ("EDIT")<0 :"@10305", | |
| 4031 | DIPA("EDIT ")=1:"@103 93",DIPA(" EDIT") | |
| 4032 | =2:"@10373 ",1:"") | |
| 4033 | : S Y="@1030 5" | |
| 4034 | : @10391 | |
| 4035 | : PRIM INS P ROVIDER ID TYPE;T;RE Q | |
| 4036 | : PRIMARY IN S CO ID NU MBER;T | |
| 4037 | : S Y="@1038 2" | |
| 4038 | : @10392 | |
| 4039 | : SEC INS PR OVIDER ID TYPE;T;REQ | |
| 4040 | : SECONDARY INS CO ID NUMBER;T | |
| 4041 | : S Y="@1038 3" | |
| 4042 | : @10393 | |
| 4043 | : TERT INS P ROVIDER ID TYPE;T;RE Q | |
| 4044 | : TERTIARY I NS CO ID N UMBER;T | |
| 4045 | : S Y="@1030 5" | |
| 4046 | : @10371 | |
| 4047 | : PRIM INS P ROVIDER ID TYPE////^ S X=DIPA(" PRIDT") | |
| 4048 | : PRIMARY IN S CO ID NU MBER////^S X=DIPA("P RID") | |
| 4049 | : S Y="@1038 2" | |
| 4050 | : @10372 | |
| 4051 | : SEC INS PR OVIDER ID TYPE////^S X=DIPA("P RIDT") | |
| 4052 | : SECONDARY INS CO ID NUMBER//// ^S X=DIPA( "PRID") | |
| 4053 | : S Y="@1038 3" | |
| 4054 | : @10373 | |
| 4055 | : TERT INS P ROVIDER ID TYPE////^ S X=DIPA(" PRIDT") | |
| 4056 | : TERTIARY I NS CO ID N UMBER////^ S X=DIPA(" PRID") | |
| 4057 | : S Y="@1030 5" | |
| 4058 | : @10305 | |
| 4059 | : @10399 | |
| 4060 | : W @IOF | |
| 4061 | : @10 4 | |
| 4062 | : S:I BDR20'["10 4" Y="@106 " | |
| 4063 | : NON -VA FACILI TY | |
| 4064 | : S D IPA("NVA_F C")=X S:X= "" Y="@104 6" | |
| 4065 | : NON -VA FACILI TY: | |
| 4066 | : S DIPA("NV A_FC-0")=$ G(^IBA(355 .93,+DIPA | |
| 4067 | ("NVA_FC") ,0)) S:$P( DIPA("NVA_ FC | |
| 4068 | -0"),U,5)' =""&($P(DI PA("NVA_FC | |
| 4069 | -0"),U,6)' ="")&($P(D IPA("NVA_F C-0") | |
| 4070 | ,U,7)'="") Y="@1041" | |
| 4071 | : STREET ADD RESS | |
| 4072 | : STREET ADD RESS LINE 2 | |
| 4073 | : CITY | |
| 4074 | : STATE | |
| 4075 | : ZIP CODE | |
| 4076 | : @1041 | |
| 4077 | : S:$P(DIPA( "NVA_FC-0" ),U,9)'="" Y="@1042" | |
| 4078 | : FACILITY D EFAULT ID NUMBER;"LA B OR FACIL ITY | |
| 4079 | PRIMARY I D" | |
| 4080 | : @1042 | |
| 4081 | : S:$P(DIPA( "NVA_FC-0" ),U,11)'=" " Y="@1043 " | |
| 4082 | : X12 TYPE O F FACILITY | |
| 4083 | : @1043 | |
| 4084 | : S:$P(DIPA( "NVA_FC-0" ),U,14)'=" " Y="@1044 " | |
| 4085 | : D EN2^IBCE P82(+DIPA( "NVA_FC"), 2) | |
| 4086 | : @1044 | |
| 4087 | : S:$D(^IBA( 355.93,+DI PA("NVA_FC "), | |
| 4088 | "TAXONOMY" ))>0 Y="@1 045" | |
| 4089 | : TAXONOMY C ODE | |
| 4090 | : ALL | |
| 4091 | : @1045 | |
| 4092 | : S D IK="^DGCR( 399,",DIK( 1)="232" D EN1^DIK | |
| 4093 | : K D IK | |
| 4094 | : NON -VA FACILI TY TAXONOM Y | |
| 4095 | : D D ISPTAX^IBC EP81($P($G (^DGCR(399 ,DA,"U3")) | |
| 4096 | ,U,3),"Non -VA Facili ty") | |
| 4097 | : NON -VA CARE T YPE | |
| 4098 | : @10 46 | |
| 4099 | : S D IPA("OLDCL IA")=$P($G (^DGCR(399 ,DA,"U2")) ,U,13) | |
| 4100 | : LAB CLIA NUMB ER | |
| 4101 | : I X ="",$G(DIP A("OLDCLIA "))'="" S IBMDOTCN=1 | |
| 4102 | : @10 47 | |
| 4103 | : I ' $$XRAY^IBC EP8A(DA) S Y="@1048" | |
| 4104 | : D M AMMODP^IBC EP8A(DA) | |
| 4105 | : MAM MOGRAPHY C ERT NUMBER | |
| 4106 | : @10 48 | |
| 4107 | : @10 6 | |
| 4108 | : S:I BDR20'["10 6" Y="@107 " | |
| 4109 | : I $ $FT^IBCU3( IBIFN)=7 S Y="@1061" | |
| 4110 | : FOR M LOC 19-U NSPECIFIED DATA;T | |
| 4111 | : D A SK19^IBCEU 3(DA) | |
| 4112 | : S Y ="@107" | |
| 4113 | : @10 61 | |
| 4114 | : DEN TAL CLAIM NOTE | |
| 4115 | : @10 7 | |
| 4116 | : S:I BDR20'["10 7" Y="@108 " | |
| 4117 | : BIL LING PROVI DER TAXONO MY | |
| 4118 | : D D ISPTAX^IBC EP81($P($G (^DGCR(399 , | |
| 4119 | DA,"U3")), U,11),"Bil ling Provi der") | |
| 4120 | : I $ P($G(^DGCR (399,DA,"U 3")),U,11) N X,Y,DIR | |
| 4121 | S DIR(0)= "EA",DIR(" A")="Press | |
| 4122 | Return to continue" D ^DIR K DIR | |
| 4123 | : @10 8 | |
| 4124 | : S:I BDR20'["10 8" Y="@109 " | |
| 4125 | : I ' $G(DIPA("I 1")) S Y=" @109" | |
| 4126 | : K D IPA("BRANC H") S DIPA ("BRANCH") =$$ACINTEL | |
| 4127 | ^IBCSC10(D IPA("I1"), "@1081") | |
| 4128 | : S:D IPA("BRANC H")]"" Y=D IPA("BRANC H") K DIPA ("BRANCH") | |
| 4129 | : S D IPA("OLDAL TT1")=$P($ G(^DGCR(39 9,DA,"M2") ),U) | |
| 4130 | : PRI MARY PAYER -ALT ID TY PE;"Primar y Payer – Alt | |
| 4131 | Prof Prim Payer ID Type" | |
| 4132 | : I X ="",$G(DIP A("OLDALTT 1"))="" S Y="@1081" | |
| 4133 | : I $ P($G(^DGCR (399,DA,"M 2")),U)="" S Y="@108 1" | |
| 4134 | : S D IPA("OLDAL TI1")=$P($ G(^DGCR(39 9,DA,"M2") ),U,2) | |
| 4135 | : PRI MARY PAYER -ALT ID;"P rimary Pay er - Alt P rof Prim | |
| 4136 | Payer ID" | |
| 4137 | : I X ="",$G(DIP A("OLDALTI 1"))="" S Y="@10811" | |
| 4138 | : S Y ="@1081" | |
| 4139 | : @10 811 | |
| 4140 | : PRI MARY PAYER -ALT ID TY PE////@ | |
| 4141 | : @10 81 | |
| 4142 | : I ' $G(DIPA("I 2")) S Y=" @109" | |
| 4143 | : K D IPA("BRANC H") S DIPA ("BRANCH") =$$ACINTEL | |
| 4144 | ^IBCSC10(D IPA("I2"), "@1082") | |
| 4145 | : S:D IPA("BRANC H")]"" Y=D IPA("BRANC H") K DIPA ("BRANCH") | |
| 4146 | : S D IPA("OLDAL TT2")=$P($ G(^DGCR(39 9,DA,"M2") ),U,3) | |
| 4147 | : SEC ONDARY PAY ER-ALT ID TYPE;"Seco ndary Paye r – Alt | |
| 4148 | Prof Prim Payer ID Type" | |
| 4149 | : I X ="",$G(DIP A("OLDALTT 2"))="" S Y="@1082" | |
| 4150 | : I $ P($G(^DGCR (399,DA,"M 2")),U,3)= "" S Y="@1 082" | |
| 4151 | : S D IPA("OLDAL TI2")=$P($ G(^DGCR(39 9,DA,"M2") ),U,4) | |
| 4152 | : SEC ONDARY PAY ER-ALT ID; "Secondary Payer - A lt Prof | |
| 4153 | Prim Paye r ID" | |
| 4154 | : I X ="",$G(DIP A("OLDALTI 2"))="" S Y="@10821" | |
| 4155 | : S Y ="@1082" | |
| 4156 | : @10 821 | |
| 4157 | : SEC ONDARY PAY ER-ALT ID TYPE////@ | |
| 4158 | : @10 82 | |
| 4159 | : I ' $G(DIPA("I 3")) S Y=" @109" | |
| 4160 | : K D IPA("BRANC H") S DIPA ("BRANCH") =$$ACINTEL | |
| 4161 | ^IBCSC10(D IPA("I3"), "@109") | |
| 4162 | : S:D IPA("BRANC H")]"" Y=D IPA("BRANC H") K DIPA ("BRANCH") | |
| 4163 | : S D IPA("OLDAL TT2")=$P($ G(^DGCR(39 9,DA,"M2") ),U,5) | |
| 4164 | : TER TIARY PAYE R-ALT ID T YPE;"Terti ary Payer | |
| 4165 | - Alt Pro f Prim Pay er ID Type " | |
| 4166 | : I X ="",$G(DIP A("OLDALTT 3"))="" S Y="@1083" | |
| 4167 | : I $ P($G(^DGCR (399,DA,"M 2")),U,5)= "" S Y="@1 083" | |
| 4168 | : S D IPA("OLDAL TI3")=$P($ G(^DGCR(39 9,DA,"M2") ),U,6) | |
| 4169 | : TER TIARY PAYE R-ALT ID;" Tertiary P ayer – | |
| 4170 | Alt Prof P rim Payer ID" | |
| 4171 | : I X ="",$G(DIP A("OLDALTI 3"))="" S Y="@10831" | |
| 4172 | : S Y ="@1083" | |
| 4173 | : @10 831 | |
| 4174 | : TER TIARY PAYE R-ALT ID// //@ | |
| 4175 | : @10 83 | |
| 4176 | : @10 9 | |
| 4177 | : S:I BDR20'["10 9" Y="@101 0" | |
| 4178 | : I $ $TEST^IBCE F84(DA) S Y="@1090" | |
| 4179 | : I ' $P($G(^DGC R(399,DA," TX")),U,8) ,'$$TXMT^I BCEF4(DA) | |
| 4180 | S Y="@109 2" | |
| 4181 | : I $ $REQMRA^IB EFUNC(DA) S Y="@1091 1" | |
| 4182 | : FOR CE CLAIM T O PRINT//N O FORCED P RINT | |
| 4183 | : S Y ="@1092" | |
| 4184 | : @10 90 | |
| 4185 | : D M ESSAGE^IBC EF84 | |
| 4186 | : S Y ="@1092" | |
| 4187 | : @10 911 | |
| 4188 | : FOR CE PRINT M RA SECONDA RY//NO FOR CED PRINT | |
| 4189 | : @10 92 | |
| 4190 | : @10 10 | |
| 4191 | ||
| 4192 | ||
| 4193 | The follow ing Post I nstall rou tine will be run aft er install ation of p atch IB*2. 0*592 in o rder to pe rform the following funtions: | |
| 4194 | Create the following new IB ER ROR codes: | |
| 4195 | IB357 – Re ndering Pr ovider or Assistant Surgeon re quired on Dental Cla ims. | |
| 4196 | IB358 – As sistant Su rgeon’s NP I is requ ired. | |
| 4197 | IB256 – As sistant Su rgeon taxo nomy missi ng. | |
| 4198 | IB335 – Cl aim Level Assistant Surgeon di ffers fro m all Line Level Ass istant Sur geons. | |
| 4199 | IB359 – Me dicare (WN R) does no t accept D ental clai ms. | |
| 4200 | IB362 – In surance Co mpany does not have Dental Cov erage. | |
| 4201 | ||
| 4202 | Create the following new Type of Service entries f or Dental: | |
| 4203 | 23 DIAGNOS TIC DENTAL | |
| 4204 | 24 PERIODO NTICS | |
| 4205 | 25 RESTORA TIVE | |
| 4206 | 26 ENDODON TICS | |
| 4207 | 27 MAXILLO FACIAL PRO STHETICS | |
| 4208 | 28 ADJUNCT IVE DENTAL SERVICES | |
| 4209 | 35 DENTAL CARE | |
| 4210 | 36 DENTAL CROWNS | |
| 4211 | 37 DENTAL ACCIDENT | |
| 4212 | 38 ORTHODO NTICS | |
| 4213 | 39 PROSTHO DONTICS | |
| 4214 | 40 ORAL SU RGERY | |
| 4215 | 41 PREVENT IVE DENTAL | |
| 4216 | E12 BASIC RESTORATIV E – DENTAL | |
| 4217 | E13 MAJOR RESTORATIV E – DENTAL | |
| 4218 | E14 FIXED PROSTHODON TICS | |
| 4219 | E15 REMOVA BLE PROSTH ODONTICS | |
| 4220 | E16 INTRAO RAL IMAGES - COMPLET E SERIES | |
| 4221 | E17 ORAL E VALUATION | |
| 4222 | E18 DENTAL PROPHYLAX IS | |
| 4223 | E19 PANORA MIC IMAGES | |
| 4224 | E20 SEALAN TS | |
| 4225 | E21 FLOURI DE TREATME NTS | |
| 4226 | E22 DENTAL IMPLANTS | |
| 4227 | E23 TEMPOR OMANDIBULA R JOINT DY SFUNCTION | |
| 4228 | F3 DENTAL COVERAGE | |
| 4229 | F7 ORTHODO NTIA COVER AGE | |
| 4230 | Set the ne w Dental C laims proc essing fla g to YES i n IB Site Parameters . | |
| 4231 | ||
| 4232 | Routines | |
| 4233 | Activities | |
| 4234 | Routine Na me | |
| 4235 | IBY592PO | |
| 4236 | Enhancemen t Category | |
| 4237 | New | |
| 4238 | Modify | |
| 4239 | Delete | |
| 4240 | No Change | |
| 4241 | RTM | |
| 4242 | ||
| 4243 | Related Op tions | |
| 4244 | None | |
| 4245 | Related Ro utines | |
| 4246 | Routines “ Called By” | |
| 4247 | Routines “ Called” | |
| 4248 | ||
| 4249 | ||
| 4250 | ||
| 4251 | ||
| 4252 | Data Dicti onary (DD) Reference s | |
| 4253 | ||
| 4254 | Related Pr otocols | |
| 4255 | None | |
| 4256 | Related In tegration Control Re gistration s (ICRs) | |
| 4257 | None | |
| 4258 | Data Passi ng | |
| 4259 | Input | |
| 4260 | Output Re ference | |
| 4261 | Both | |
| 4262 | Global Re ference | |
| 4263 | Local | |
| 4264 | Input Attr ibute Name and Defin ition | |
| 4265 | Name: | |
| 4266 | Definition : | |
| 4267 | Output Att ribute Nam e and Defi nition | |
| 4268 | Name: | |
| 4269 | Definition : | |
| 4270 | Current Lo gic | |
| 4271 | N/A | |
| 4272 | Modified L ogic (Chan ges are in bold) | |
| 4273 | IBY592PO ; EDE/JWS - POST-INSTA LL FOR IB* 2.0*592 ;2 2-FEB-2017 ;;2.0;INT EGRATED BI LLING;**59 2**;21-MAR -94;Build 6 ;;Per VA Directive 6402, thi s routine should not be modifi ed. ;EN ;E ntry Point S IBA(2)= "IB*2*592 Post-Insta ll...",(IB A(1),IBA(3 ))=" " D M ES^XPDUTL( .IBA) K IB A D UPDERR ,UPDTOS ; set defaul t processi ng of Dent al Claims to YES in Site Param eters S DI E="^IBE(35 0.9,",DA=1 ,DR="8.2// //1" D ^DI E S IBA(2) ="IB*2*592 Post-Inst all Comple te.",(IBA( 1),IBA(3)) =" " D MES ^XPDUTL(.I BA) K IBA Q ;UPDERR ; Update e xisting er ror code m essage for 350.8 N I BCODE,IBME SN,IBIEN,D IE,DIC,DA, DR,X,Y S I BCODE="IB3 57",IBMESN ="Renderin g Provider or Assist ant Surgeo n required on Dental Claims." S IBIEN=$O (^IBE(350. 8,"C",IBCO DE,0)) I ' IBIEN D CR EATE S IBC ODE="IB358 ",IBMESN=" Assistant Surgeon's NPI is req uired." S IBIEN=$O(^ IBE(350.8, "C",IBCODE ,0)) I 'IB IEN D CREA TE S IBCOD E="IB256", IBMESN="As sistant Su rgeon taxo nomy missi ng." S IBI EN=$O(^IBE (350.8,"C" ,IBCODE,0) ) I 'IBIEN D CREATE S IBCODE=" IB335",IBM ESN="Claim Level Ass istant Sur geon diffe rs from al l Line Lev el Assista nt Surgeon s." S IBIE N=$O(^IBE( 350.8,"C", IBCODE,0)) I 'IBIEN D CREATE S IBCODE="I B359",IBME SN="Medica re (WNR) d oes not ac cept Denta l claims." S IBIEN=$ O(^IBE(350 .8,"C",IBC ODE,0)) I 'IBIEN D C REATE S IB CODE="IB36 2",IBMESN= "Insurance Company d oes not ha ve Dental Coverage." S IBIEN=$ O(^IBE(350 .8,"C",IBC ODE,0)) I 'IBIEN D C REATE Q ;C REATE ;Cre ate entry for 'IB357 ' in D350. 8 if not t here S DIC ="^IBE(350 .8,",DIC(0 )="",X=IBC ODE D FILE ^DICN K DI C,X I Y=-1 D MES^XPD UTL(">> IB ERROR - E ntry '"_IB CODE_"' wa s unable t o be creat ed <<") Q S IBIEN=+Y S DIE="^I BE(350.8," ,DA=IBIEN, DR=".02/// /"_IBMESN_ ";.03////" _IBCODE_"; .04////1;. 05////1" D ^DIE K DI E,DIC,DA,D R Q ;UPDTO S ;Create Type of Se rvice entr ies for De ntal file 353.2 N IB FDA,I,IBIE N,ERROR F I=23,24,25 ,26,27,28, 35,36,37,3 8,39,40,41 ,"E12","E1 3","E14"," E15","E16" ,"E17","E1 8","E19"," E20","E21" ,"E22","E2 3","F3","F 7" D . I $ O(^IBE(353 .2,"B",I,0 )) Q ;alr eady exist s . S IBFD A(353.2,"+ 1,",.01)=I . I +I<29 D .. S IB FDA(353.2, "+1,",.02) =$P("DIAGN OSTIC DENT AL,PERIODO NTICS,REST ORATIVE,EN DODONTICS, MAXILLOFAC IAL PROSTH ETICS,ADJU NCTIVE DEN TAL SERVIC ES",",",I- 22) .. S I BFDA(353.2 ,"+1,",.03 )=$P("DIAG NOSTIC DEN TAL,PERIOD ONTICS,RES TORATIVE,E NDODONTICS ,MAXILLOFA CIAL PRO,A DJUNCTIVE SERVICES", ",",I-22) . I +I>34, +I<42 D .. S IBFDA(3 53.2,"+1," ,.02)=$P(" DENTAL CAR E,DENTAL C ROWNS,DENT AL ACCIDEN T,ORTHODON TICS,PROST HODONTICS, ORAL SURGE RY,PREVENT IVE DENTAL ",",",I-34 ) .. S IBF DA(353.2," +1,",.03)= $P("DENTAL CARE,DENT AL CROWNS, DENTAL ACC IDENT,ORTH ODONTICS,P ROSTHODONT ICS,ORAL S URGERY,PRE VENTIVE DE NTAL",",", I-34) . I $E(I)="E" D .. S CT= $E(I,2,3) .. I CT<18 S IBFDA(3 53.2,"+1," ,.02)=$P(" BASIC REST ORATIVE - DENTAL,MAJ OR RESTORA TIVE - DEN TAL,FIXED PROSTHODON TICS,REMOV ABLE PROST HODONTICS, INTRAORAL IMAGES - C OMPLETE SE RIES,ORAL EVALUATION ",",",CT-1 1) .. I CT >17 S IBFD A(353.2,"+ 1,",.02)=$ P("DENTAL PROPHYLAXI S,PANORAMI C IMAGES,S EALANTS,FL OURIDE TRE ATMENTS,DE NTAL IMPLA NTS,TEMPOR OMANDIBULA R JOINT DY SFUNCTION" ,",",CT-17 ) .. S IBF DA(353.2," +1,",.03)= $P("BASIC RESTORATIV E,MAJOR RE STORATIVE, FIXED PROS TH,REMOVAB LE PROSTH, IMAGES - C OMPLETE,OR AL EVALUAT ION,PROPHY LAXIS,PANO RAMIC IMAG ES,SEALANT S,FLOURIDE ,DENTAL IM PLANTS,JOI NT DYSFUNC TION",",", CT-11) . I I="F3" D .. S IBFDA (353.2,"+1 ,",.02)="D ENTAL COVE RAGE" .. S IBFDA(353 .2,"+1,",. 03)="DENTA L COVERAGE " . I I="F 7" D .. S IBFDA(353. 2,"+1,",.0 2)="ORTHOD ONTIA COVE RAGE" .. S IBFDA(353 .2,"+1,",. 03)="ORTHO DONTIA COV ERAGE" . D UPDATE^DI E("","IBFD A","IBIEN" ,"ERROR") . I $D(ERR OR) D MES^ XPDUTL(">> IB ERROR - IB*2.0*5 92 Post In stall - "_ $G(ERROR(" DIERR",1," TEXT",1))_ " <<") . K IBIEN,ERR OR Q |
Araxis Merge (but not the data content of this report) is Copyright © 1993-2016 Araxis Ltd (www.araxis.com). All rights reserved.