12. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 9/11/2018 8:57:52 AM Central Daylight 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.

12.1 Files compared

# Location File Last Modified
1 OSCIF MCCF EDI TAS_Sept2018.zip TAS+eBill+SDD+US3+v2.00.docx Mon Jul 9 15:28:45 2018 UTC
2 OSCIF MCCF EDI TAS_Sept2018.zip TAS+eBill+SDD+US3+v2.00.docx Mon Sep 10 18:22:57 2018 UTC

12.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 5 10890
Changed 4 8
Inserted 0 0
Removed 0 0

12.3 Comparison options

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

12.4 Active regular expressions

No regular expressions were active.

12.5 Comparison detail

  1   TAS eBill  SDD US3 v2 .0
  2   System Des ign Docume nt
  3   IB*2.0*608
  4  
  5  
  6  
  7  
  8   Department  of Vetera ns Affairs
  9   March 2018
  10   Version 2. 0
  11   Revision H istory
  12   Date
  13   Version
  14   Descriptio n
  15   Author
  16   10/17
  17   1.0
  18   Initial su bmittal pr ior to dev elopment
  19   PII
  20   3/18
  21   1.1
  22   Updated af ter comple tion of de velopment
  23   PII
  24   5/18
  25   2.0
  26   Updated af ter comple tion of ad ditional a nd final d evelopment
  27   PII
  28  
  29  
  30  
  31  
  32  
  33  
  34  
  35  
  36  
  37  
  38  
  39  
  40  
  41  
  42  
  43  
  44  
  45  
  46  
  47  
  48  
  49  
  50  
  51  
  52  
  53  
  54  
  55   User Story  Number: N O ID
  56   User Story  Name: CMN  Oxygen an d EPN Nutr ition
  57   Product Ba cklog ID:  n/a
  58   Rally ID:  US-3
  59   Design/Ass umption:
  60   The design  for this  user story  is going  on the ass umption th at FILEMAN  22.2 (pat ch DI*22.2 *3) will h ave been i nstalled a t all site s.
  61   Resolution  Summary:
  62   To resolve  this requ est, the f ollowing i tems will  need to be  accomplis hed.  Note  that the  user will  be prompte d for CMN  data only  if the cla im is Prof essional ( Institutio nal & Dent al exclude d):
  63   Create sec tion 21 in  the IB Sy stem Param eters call ed “CMN CP T Code Inc lusion” wh ich contai ns a list  of CPT cod es requiri ng CMN pro mpting (ro utines IBJ PS & IBJPS 8).  There  is also a  function  in this ro utine to d etermine i f a partic ular code  is in the  list.
  64   Create a n ew Procedu res sub-fi eld 399.30 4,23 to st ore the re sponse to  the “CMN R equired?”  prompt (Ye s or No).   CMN promp ting will  only occur  for proce dures in t he “CMN CP T Code Inc lusion” li st.
  65   Create new  file CMN  FORM TYPES  (399.6) t hat will b e pointed  to from th e new CMN  FORM TYPE  field 399. 304,24 (IV  below). T his new fi le will st ore an ent ry for eac h of the C MN Form Ty pes.  At t his time t here are o nly two CM N Form Typ es referen ced in thi s SDD, nam ely, the C MS-484 For m for Oxyg en, and th e CMS-1012 6 form for  Enteral a nd Parente ral Nutrit ion.  Thou gh this fe ature coul d have bee n handled  by definin g the new  field in t he 399.304  sub-file  as a “SET” , there is  a potenti al for up  to 12 diff erent Form  Types so  rather tha n possibly  having to  convert t he new fie ld to a po inter in t he future,  it was de termined t hat a new  file would  be best t o store th e CMN Form  Types.
  66  
  67   Create a n ew Procedu res sub-fi eld CMN FO RM TYPE (3 99.304,24)  to store  the CMN Fo rm Type.
  68   Create Pro cedures su b-fields ( a.k.a. CMN  fields) 2 4.01 thru  24.08 hold ing respon ses for qu estions wh ich are th e same for  both form s, fields  24.1 thru  24.115 for  questions  specific  to the CMN -484, and  fields 24. 201 thru 2 4.216 for  questions  specific t o the CMN- 10126.  Ne w nodes in  ^DGCR wil l be creat ed to hold  the respo nses to th e prompts  for each o f the new  CMN forms:   Node ‘CM N’ will ho ld respons es to ques tions that  are the s ame for bo th forms,  node ‘CMN- 484’ will  hold respo nses speci fic to the  CMN-484 f orm, and n ode ‘CMN-1 0126’ will  hold resp onses spec ific to th e CMN-1012 6 form.
  69   Add entrie s to files  364.5 (IB  DATA ELEM ENT DEFINI TION), 364 .6 (IB FOR M SKELETON  DEFINITIO N) and 364 .7 (IB FOR M FIELD CO NTENT) in  order to i nclude the  new CMN f ields in t he 837 Tra nsmission.
  70   Add IB err or message s for miss ing requir ed CMN fie lds, field s missing  a correspo nding date , or CMN d ata irregu larities ( routines I BCBB1, IBC BB13).  Th is involve s adding 1 2 entries  to file 35 0.8 (IB ER ROR) to st ore the CM N data err or message s.
  71   Entries ad ded to fil es 364.5,  364.6 and  364.7 done  via the p re-install  routine I BY608PR.
  72   CMN CPT Co de Inclusi on list in  IB System  Parameter s is popul ated via t he post-in stall rout ine IBY608 PO.
  73   DR prompti ng used to  collect t he data fo r CMN fiel ds 23 thro ugh 24.216  specified  above (ro utine IBCU 7 and IBCU 75)
  74   Develop Ex tract Code  for to pu ll the val ues for th e new CMN  fields and  related d ata (routi ne IBCEF31 ).
  75  
  76   Add the CM N nodes to  compariso n code whe n rolling  up procedu res for th e 837 tran smission ( routine IB CF23A)
  77   Modify the  cloning o f a claim  to include  the new C MN fields  (routine I BCCC2).
  78   Modify the  Interface  Control D ocument (I CD) for th e 837-P mo dification s by addin g the CMN,  FRM, LQ a nd MEA seg ments (sep arate docu ment).
  79   Rules to b e Applied  during Des ign:    
  80   If user st ates no CM N is Requi red, then  none of th e subseque nt CMN rel ated promp ts will ap pear.  The  system wi ll automat ically con tinue with  the “Sele ct CPT MOD IFIER SEQU ENCE:” pro mpt.
  81   If the cla im has a C MN then qu alifier UT  for CMN i s required  in 2440 L Q01 and th e “CMN For m type” (3 99.0304,24 ) is Requi red in 244 0 LQ02 Cod e Set.
  82   “Certifica tion Type”  (399.0304 ,24.01) is  Required.
  83   “Patient H eight (in) ” (399.030 4,24.02) i s Not Requ ired and n eeds modif ier TR whe n populate d.  “Patie nt Weight  (lbs)” (39 9.0304,24. 03) field  is Not Req uired, but  when popu lated it n eeds modif ier 01.
  84   The “Edema  due to CH F Present? ” (399.030 4,24.104),  “COR Pulm onale/Pulm onary Hype rtension P resent?” ( 399.0304,2 4.105) and  “Hematocr it > 56%?”  (399.0304 ,24.106) p rompts sho uld only a ppear if t he “ABG PO 2 (mmHg)”  (399.0304, 24.1) is b etween 56  and 59 or  the “O2 Sa turation ( %)” (399.0 304,24.102 ) value is  equal to  89.
  85   When “Cert ification  Type” (399 .0304,24.0 1) equals  R or S, a  date is re quired in  “Recertifi cation/Rev ision Date ” (399.030 4,24.07) a nd needs Q ualifier 6 07
  86   “Date Ther apy Starte d” (399.03 04,24.05)  is require d and need s Qualifie r 463
  87   “Last Cert ification  Date” (399 .0304,24.0 6) is requ ired and n eeds Quali fier 461
  88   The only o ption for  Units of M easurement  for the l ength of t ime for eq uipment is  months so  the defau lt for 240 0 CR302 is  equal to  MO for Mon ths.
  89   The Suppli er should  be calcula ted to be  the Billin g Provider .
  90   Oxygen flo w rate can  be a numb er or X if  less than  1.
  91   The “Lates t 4 LPM AB G PO2 (mmH g)” (399.0 304,24.111 ), “Date o f Latest 4  LPM ABG T est” (399. 0304,24.11 2), “Lates t 4 LPM O2  Saturatio n (%)” (39 9.0304,24. 113) and “ Date of La test 4 LPM  O2 Satura tion Test”  (399.0304 ,24.114) f ields shou ld only ha ve values  when the “ Highest O2  Flow Rate ” (399.030 4,24.11) f ield is gr eater than  4 LPM.
  92   CRC Condit ion Indica tor/Durabl e Medical  Equipment  should be  populated  with Repla cement Ite m equal to  ZV.  For  example: C RC*09*N*ZV
  93   Detailed D esign:
  94   I)  Create  new Proce dures sub- field 23 –  “CMN REQU IRED?”:
  95   Create a n ew field 3 99.304,23  to store t he respons e to the “ CMN Requir ed?” promp t.  This i s a REQUIR ED field.
  96   399.0304,2 3   CMN RE QUIRED?           CMN ;1 SET (Re quired)
  97                  CMN Re quired?                                           
  98                                      '0' FOR  NO; 
  99                                      '1' FOR  YES; 
  100                  LAST E DITED:       NOV 15,  2017 
  101                  HELP-P ROMPT:       Enter 'Y es' (1) if  this proc edure requ ires a Cer tificate o f Medical  Necessity,  or 'No' ( 0) if it d oes not. 
  102                  DESCRI PTION:       This fie ld indicat es whether  a Certifi cate of Me dical Nece ssity must  be submit ted with t his proced ure.  
  103   [NOTE:  If  CMN is NO T REQUIRED , then non e of the s ubsequent  CMN relate d prompts  will appea r.  The sy stem will  automatica lly contin ue with th e “Select  CPT MODIFI ER SEQUENC E:” prompt .]
  104  
  105  
  106   II)  Creat e new “CMN  Form Type s” file 39 9.6 contai ning 4 fie lds:
  107   STANDARD D ATA DICTIO NARY #399. 6 -- CMN F ORM TYPES  FILE                                                                  5/23/1 8    PAGE  1
  108   STORED IN  ^IBE(399.6 ,  (2 ENTR IES)   SIT E: TEST.CH EYENNE.MED .VA.GOV    UCI: VISTA ,ROU                                  (VERS ION 2.0)    
  109  
  110   DATA           NAME                    GLOB AL         DATA
  111   ELEMENT        TITLE                   LOCA TION       TYPE
  112   ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- -
  113   The CMN FO RM TYPES f ile was cr eated to h old specif ications f or the var ious Certi ficate of  Medical Ne cessity (C MN) form t ypes and i s
  114   used in En ter/Edit B illing whe n the user  specifies  CMN infor mation for  an eligib le procedu re. 
  115  
  116                  DD ACC ESS: @
  117                  RD ACC ESS: @
  118                  WR ACC ESS: @
  119                 DEL ACC ESS: @
  120               LAYGO ACC ESS: @
  121               AUDIT ACC ESS: @
  122  
  123   POINTED TO  BY: CMN F ORM TYPE f ield (#24)  of the PR OCEDURES s ub-field ( #399.0304)  of the BI LL/CLAIMS  File (#399
  124                   
  125   CROSS
  126   REFERENCED  BY: NAME( B)
  127  
  128        CREATED ON : JUN 2,20 17 by  P I
I
      LAST MODIF IED: MAY 2 2,2018@11: 44:39
  129  
  130   399.6,.01      NAME                     0;1  FREE TEXT  (Required )
  131                  INPUT  TRANSFORM:   K:$L(X)> 50!($L(X)< 3)!'(X'?1P .E) X
  132                  MAXIMU M LENGTH:    50
  133                  LAST E DITED:       MAY 22,  2018 
  134                  HELP-P ROMPT:       Enter th e external  name of t he CMN for m.  Enter  between 3  and 50 fre e-text cha racters. 
  135                  DESCRI PTION:       This is  the extern al name of  the Certi ficate of  Medical Ne cessity (C MN) form.   For examp le: 'OXYGE N (CMS-484 )' 
  136  
  137                  CROSS- REFERENCE:   399.6^B 
  138                                      1)= S ^I BE(399.6," B",$E(X,1, 30),DA)=""
  139                                      2)= K ^I BE(399.6," B",$E(X,1, 30),DA)
  140  
  141   399.6,1        DESCRI PTION             0;2  FREE TEXT
  142                  INPUT  TRANSFORM:   K:$L(X)> 80!($L(X)< 1) X
  143                  MAXIMU M LENGTH:    80
  144                  LAST E DITED:       MAY 22,  2018 
  145                  HELP-P ROMPT:       Enter a  brief desc ription (u p to 80 ch aracters)  of the For m Type 
  146                  DESCRI PTION:  Th is is a fr ee-text de scription  of the CMN  form type .  
  147  
  148   399.6,2        INDUST RY CODE           0;3  FREE TEXT  (Required )
  149                  INPUT  TRANSFORM:   K:$L(X)> 15!($L(X)< 1) X
  150                  MAXIMU M LENGTH:    15
  151                  LAST E DITED:       MAY 22,  2018 
  152                  HELP-P ROMPT:       Enter th e Industry  Code (up  to 15 free -text char acters) as sociated w ith this C MN form ty pe. 
  153                  DESCRI PTION:       This is  the indust ry code as sociated w ith this f orm.  It i s usually  found in t he upper-r ight corne r of the p rinted for m and is t he number  following  'DME'.  Fo r the 'E &  P NUTRITI ON (CMS-10 126)' form  the indus try code i s 10.3 and  for the ' OXYGEN (CM S-484)' it  is 484.3.   
  154  
  155   399.6,3        DATA N ODE               0;4  FREE TEXT  (Required )
  156                  INPUT  TRANSFORM:   K:$L(X)> 20!($L(X)< 7) X
  157                  MAXIMU M LENGTH:    20
  158                  LAST E DITED:       MAY 22,  2018 
  159                  HELP-P ROMPT:       Enter th e node in  ^DGCR wher e data for  this form  is stored .  Enter b etween 7 a nd 20 free -text char acters. 
  160                  DESCRI PTION:       This is  the node i n ^DGCR wh ere the CM N data for  a particu lar form i s stored.   For the " 484" form,  the data  node MUST  be 'CMN-48 4' and for  the "1012 6" form, t he data no de MUST be  'CMN-1012 6'.    
  161  
  162               Create th e 2 necess ary D399.6  entries f or the CMS -484 and C MS-10126 f orms:
  163               CMS-484-O xygen
  164   NAME: OXYG EN (CMS-48 4)
  165     DESCRIPT ION: CERTI FICATE OF  MEDICAL NE CESSITY FO RM 484.3 F OR OXYGEN
  166     INDUSTRY  CODE: 484 .3                   
  167     DATA NOD E: CMN-484
  168  
  169               CMS-10126 -Enteral &  Parentera l Nutritio n
  170   NAME: ENTE RAL & PARE NTERAL NUT RITION (CM S-10126)
  171     DESCRIPT ION: CERTI FICATE OF  MEDICAL NE CESSITY FO RM 10126 F OR ENTERAL  & PARENTE RAL NUTRIT ION                             
  172     INDUSTRY  CODE: 10. 03
  173     DATA NOD E: CMN-101 26
  174  
  175  
  176   III)  Crea te Procedu res sub-fi eld 24 – “ CMN FORM T YPE”
  177   Create a n ew field 3 99.304,24  to store t he CMN For m Type, wh ich is a p ointer to  the new CM N FORM TYP ES file (3 99.6).  Th is is a RE QUIRED fie ld.
  178   399.0304,2 4   CMN FO RM TYPE           CMN ;2 POINTER  TO CMN FO RM TYPES F ILE (#399. 6)
  179                  CMN Fo rm type                                           
  180                  LAST E DITED:       MAR 08,  2018 
  181                  HELP-P ROMPT:       Select t he REQUIRE D CMN form  type that  will be s ent with t his proced ure. 
  182                  DESCRI PTION:       This fie ld indicat es the Cer tificate o f Medical  Necessity  form type  that is to  be submit ted with t his proced ure.  
  183                  TECHNI CAL DESCR:   If the C MN Require d? field i s set to " Y"es, this  field mus t be an en try in the  CMS FORM  TYPES file  #399.6.
  184  
  185  
  186  
  187   IV)  Creat e Procedur e sub-fiel ds 24.01 t hru 24.08,  24.1 thru  24.115, a nd 24.201  thru 24.21 9 to promp t the user  for the n ew CMN for m informat ion.  
  188   Creation o f these Pr ocedure su b-fields i nvolves cr eating 3 n ew nodes i n ^DGCR(39 9), namely  nodes ‘CM N’, CMN-48 4’ and ‘CM N-10126’,  which will  contain t he respons es for BOT H forms, t he CMN-484  form, and  the CMN-1 0126 form,  respectiv ely.
  189       Fields  24.01 thr u 24.09 ar e the same  for both  the CMN-48 4 and the  CMN-10126:
  190   399.0304,2 4.01   CMN  CERTIFICA TION TYPE  [REQUIRED]
  191   399.0304,2 4.01 CMN C ERTIFICATI ON TYPE CM N;3 SET
  192                  Certif ication Ty pe                                     
  193                                      'I' FOR  INITIAL; 
  194                                      'R' FOR  RENEWAL; 
  195                                      'S' FOR  REVISED; 
  196                  LAST E DITED:       MAR 08,  2018 
  197                  HELP-P ROMPT:       Select t he REQUIRE D Type of  Certificat ion reques ted. 
  198                  DESCRI PTION:      This fiel d indicate s the type  of Certif ication th at is bein g requeste d.
  199   [NOTE:  Wh en “CMN CE RTIFICATIO N TYPE” eq uals ‘R’ o r ‘S’, a d ate is req uired for  the “CMN R ECERTIFICA TION/REVIS ION DATE”  (399.0304, 24.07)]
  200  
  201   399.0304,2 4.02   CMN  PATIENT H EIGHT (IN)   [Qualifi er TR]
  202   399.0304,2 4.02 CMN P ATIENT HEI GHT (IN) C MN;4 NUMBE R
  203                  Patien t Height ( in)                                    
  204                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  205                  LAST E DITED:       APR 03,  2018 
  206                  HELP-P ROMPT:       Enter th e Patient' s height i n whole nu mbers repr esenting i nches. 
  207                  DESCRI PTION:       This fie ld indicat es the Pat ient's hei ght in who le numbers  represent ing inches .  
  208                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  209  
  210   399.0304,2 4.03   CMN  PATIENT W EIGHT (LBS )  [Qualif ier 01]
  211   399.0304,2 4.03 CMN P ATIENT WEI GHT (LBS)  CMN;5 NUMB ER
  212                  Patien t Weight ( lbs)                                   
  213                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  214                  LAST E DITED:       MAR 02,  2018 
  215                  HELP-P ROMPT:       Enter th e Patient' s weight i n whole nu mbers repr esenting p ounds. 
  216                  DESCRI PTION:   T his field  indicates  the Patien t's weight  in whole  numbers re presenting  pounds.  
  217                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  218  
  219   399.0304,2 4.04   CMN  MONTHS DM E EQUIP NE EDED
  220   399.0304,2 4.04 CMN M ONTHS DME  EQUIP NEED ED CMN;6 N UMBER
  221                  Months  DME Equip ment Neede d                           
  222                  INPUT  TRANSFORM:   K:+X'=X! (X>99)!(X< 1)!(X?.E1" ."1N.N) X
  223                  LAST E DITED:       NOV 14,  2017 
  224                  HELP-P ROMPT:       Enter th e number o f MONTHS t he patient  will need  the DME E quipment.   Enter 1-9 9 with 99  equal to a  lifetime.  
  225                  DESCRI PTION:       This fie ld indicat es the num ber of MON THS that t he Patient  will need  the DME E quipment.   '99' repr esents a l ifetime.
  226  
  227   399.0304,2 4.05   CMN  DATE THER APY STARTE D  [REQUIR ED; Qualif ier is 463 ]
  228   399.0304,2 4.05 CMN D ATE THERAP Y STARTED  CMN;7 DATE
  229                  Date T herapy Sta rted                                   
  230                  INPUT  TRANSFORM:   S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  231                  LAST E DITED:       MAR 08,  2018 
  232                  HELP-P ROMPT:       Enter th e REQUIRED  date the  therapy be gan. 
  233                  DESCRI PTION:      This fiel d indicate s the date  the thera py began.
  234  
  235   399.0304,2 4.06   CMN  LAST CERT IFICATION  DATE  [REQ UIRED; Qua lifier is  461]
  236   399.0304,2 4.06 CMN L AST CERTIF ICATION DA TE CMN;8 D ATE
  237                  Last C ertificati on Date                                
  238                  INPUT  TRANSFORM:   S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  239                  LAST E DITED:       MAR 08,  2018 
  240                  HELP-P ROMPT:       Enter th e REQUIRED  date the  physician  signed the  Certifica te of Medi cal Necess ity. 
  241                  DESCRI PTION:      This fiel d indicate s the date  the physi cian signe d the Cert ificate of  Medical N ecessity.
  242  
  243   399.0304,2 4.07   CMN  RECERTIFI CATION/REV ISN DT   [ REQUIRED w hen “CMN C ERTIFICATI ON TYPE” ( 399.0304,2 4.01) equa ls ‘R’ or  ‘S’]
  244   399.0304,2 4.07 CMN R ECERTIFICA TION/REVIS N DT CMN;9  DATE
  245                  Recert ification/ Revision D ate                         
  246                  INPUT  TRANSFORM:   S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  247                  LAST E DITED:       NOV 14,  2017 
  248                  HELP-P ROMPT:       If the C ertificati on Type is  a Renewal  or Revise d, enter a  REQUIRED  Recertific ation/Revi sion date.  
  249                  DESCRI PTION:       If the C ertificati on Type is  a Renewal  or Revise d, this fi eld is REQ UIRED and  indicates  the date o f the Rece rtificatio n/Renewal.
  250  
  251   399.0304,2 4.08   CMN  REPLACEME NT ITEM?
  252   399.0304,2 4.08 CMN R EPLACEMENT  ITEM?  CM N;10 SET
  253                  Replac ement Item ?                                      
  254                                      '0' FOR  NO; 
  255                                      '1' FOR  YES; 
  256                  LAST E DITED:       NOV 14,  2017 
  257                  HELP-P ROMPT:       Enter 'Y es' (1) if  this item  is being  billed as  a replacem ent item,  or 'No' (0 ) if it is  not. 
  258                  DESCRI PTION:      This fiel d indicate s whether  or not the  item bein g billed i s a Replac ement item .
  259  
  260              Fields 24. 1 thru 24. 115 are sp ecific to  the CMN-48 4:
  261   399.0304,2 4.1   CMN  ABG PO2 (M MHG) 
  262   399.0304,2 4.1 CMN AB G PO2 (MMH G)     CMN -484;16 NU MBER
  263                  ABG PO 2 (mmHg)                                          
  264                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  265                  LAST E DITED:       MAR 02,  2018 
  266                  HELP-P ROMPT:       Enter th e result o f the most  recent AB G test.  E nter a who le Number  which will  be report ed as mmHg
  267                  DESCRI PTION:       This fie ld indicat es the res ult of the  most rece nt ABG tes t.  The Nu mber enter ed will be  reported  as mmHg.  
  268                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  269  
  270   399.0304,2 4.102   CM N O2 SATUR ATION %
  271   399.0304,2 4.102 CMN  O2 SATURAT ION %   CM N-484;2 NU MBER
  272                  O2 Sat uration (% )                                      
  273                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  274                  LAST E DITED:       MAR 02,  2018 
  275                  HELP-P ROMPT:       Enter th e result o f the most  recent Ox ygen satur ation test .  Enter a  whole num ber which  will be re ported as  %. 
  276                  DESCRI PTION:       This fie ld indicat es the res ult of the  most rece nt Oxygen  saturation  test.  Th e number e ntered wil l be repor ted as %.   
  277                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  278  
  279   399.0304,2 4.103  CMN  DT LAST A BG PO2 AND  O2 SAT
  280   399.0304,2 4.103 CMN  DT LAST AB G PO2 AND  O2 SAT CMN -484;3 DAT E
  281  
  282                  Date o f Last ABG  PO2 and/o r O2 Satur ation Test (s)   
  283                  INPUT  TRANSFORM:   S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  284                  LAST E DITED:       MAR 14,  2018 
  285                  HELP-P ROMPT:       Enter th e REQUIRED  date for  the most r ecent ABG  PO2 and/or  O2 Satura tion Test( s). 
  286                  DESCRI PTION:        This fi eld indica tes the Da te for the  most rece nt ABG PO2  and/or O2  Saturatio n test(s).
  287  
  288   399.0304,2 4.104   CM N EDEMA DU E TO CHF P RESENT?
  289   399.0304,2 4.104 CMN  EDEMA DUE  TO CHF PRE SENT? CMN- 484;4 SET
  290                  Edema  due to CHF  Present?                              
  291                                      '0' FOR  NO; 
  292                                      '1' FOR  YES; 
  293                  LAST E DITED:       NOV 14,  2017 
  294                  HELP-P ROMPT:       Enter 'Y es' (1) if  Edema bei ng due to  CHF being  Present, o r 'No' (0)  if it is  not. 
  295                  DESCRI PTION:       This fie ld indicat es whether  or not th e patient  has depend ent Edema  due to Con gestive He art Failur e.  
  296    [NOTE:  T he “CMN ED EMA DUE TO  CHF PRESE NT?” promp t should o nly appear  if the “C MN ABG PO2 ” (399.030 4,24.1) va lue is bet ween 56 an d 59 or th e “CMN O2  SATURATION  %” (399.0 304,24.102 ) value is  equal to  89.]
  297  
  298   399.0304,2 4.105   CM N COR PULM ONARY HYPE RTENSION?
  299   399.0304,2 4.105 CMN  COR PULMON ARY HYPERT ENSN? CMN- 484;5 SET
  300                  COR Pu lmonale/Pu lmonary Hy pertension  Present?        
  301                                      '0' FOR  NO; 
  302                                      '1' FOR  YES; 
  303                  LAST E DITED:       NOV 14,  2017 
  304                  HELP-P ROMPT:       Enter 'Y es' (1) if  COR Pulmo nale or Pu lmonary Hy pertension  is Presen t, or 'No'  (0) if it  is not. 
  305                  DESCRI PTION:       This fie ld indicat es whether  or not th e patient  has cor pu lmonate or  pulmonary  hypertens ion docume nted by P  pulmonale  on an EKG  or echocar diogram, g ated blood  pool scan  or direct  pulmonary  artery pr essure mea surement.
  306   [NOTE:  Th e “COR Pul monary/Pul monary Hyp ertension  Present?”  prompt sho uld only a ppear if t he “CMN AB G PO2 (MMH G)” (399.0 304,24.1)  value is b etween 56  and 59 or  the “CMN O 2 SATURATI ON %” (399 .0304,24.1 02) value  is equal t o 89.]
  307  
  308   399.0304,2 4.106   CM N HEMATOCR IT > 56%?
  309   399.0304,2 4.106 CMN  HEMATOCRIT  > 56%? CM N-484;6 SE T
  310                  Hemato crit > 56% ?                                      
  311                                      '0' FOR  NO; 
  312                                      '1' FOR  YES; 
  313                  LAST E DITED:       NOV 14,  2017 
  314                  HELP-P ROMPT:       Enter 'Y es' (1) if  the patie nt has a H ematocrit  level grea ter that 5 6% or 'No'  (0) if no t. 
  315                  DESCRI PTION:      This fiel d indicate s whether  or not the  patient h as a Hemat ocrit leve l greater  than 56%.
  316   [NOTE:  Th e “Hematoc rit > 56%? ” prompt s hould only  appear if  the “CMN  ABG PO2 (M MHG)” (399 .0304,24.1 ) value is  between 5 6 and 59 o r the “CMN  O2 SATURA TION %”  ( 399.0304,2 4.102) val ue is equa l to 89.]
  317  
  318   399.0304,2 4.107   CM N PT CONDI TION AT TE ST TIME
  319   399.0304,2 4.107 CMN  PT CONDITI ON AT TEST  TIME CMN- 484;7 SET
  320                  Patien t Conditio n At Test  Time                        
  321                                      '1' FOR  CHRONIC AN D STABLE A S OUTPT; 
  322                                      '2' FOR  W/I TWO DA YS PRIOR T O D/C FROM  INPT FACI LITY; 
  323                                      '3' FOR  UNDER OTHE R CIRCUMST ANCES; 
  324                  LAST E DITED:       NOV 14,  2017 
  325                  HELP-P ROMPT:       Enter th e patient' s conditio n at the t ime of the  ABG and/o r O2 Satur ation test (s). 
  326                  DESCRI PTION:      This fiel d indicate s the pati ent's cond ition at t he time of  the ABG a nd/or O2 S aturation  test(s).
  327  
  328   399.0304,2 4.108   CM N TEST CON DITIONS
  329   399.0304,2 4.108 CMN  TEST CONDI TIONS   CM N-484;8 SE T
  330                  Test C onditions                                         
  331                                      '1' FOR  AT REST; 
  332                                      '2' FOR  DURING EXE RCISE; 
  333                                      '3' FOR  DURING SLE EP; 
  334                  LAST E DITED:       NOV 14,  2017 
  335                  HELP-P ROMPT:       Enter th e conditio ns for the  ABG and/o r O2 Satur ation test (s). 
  336                  DESCRI PTION:     This field  indicates  the condi tion for t he ABG and /or O2 Sat uration te st(s).
  337  
  338   399.0304,2 4.109   CM N PORTABLE  O2 INDICA TOR
  339   399.0304,2 4.109  CMN  PORTABLE  O2 INDICAT OR CMN-484 ;9 SET
  340                  Portab le O2 Indi cator                                  
  341                                      'Y' FOR  PATIENT MO BILE WITHI N HOME; 
  342                                      'N' FOR  PATIENT NO T MOBILE W ITHIN HOME
  343                                      'D' FOR  NOT ORDERI NG PORTABL E OXYGEN; 
  344                  LAST E DITED:       NOV 14,  2017 
  345                  HELP-P ROMPT:       Enter th e patient' s mobility  if orderi ng portabl e oxygen o r indicate  if not or dering por table oxyg en. 
  346                  DESCRI PTION:          This  field indi cates the  patient's  mobility c oncerning  the orderi ng of port able oxyge n.
  347  
  348   399.0304,2 4.11   CMN  HIGHEST O 2 FLOW RAT E
  349   399.0304,2 4.11 CMN H IGHEST O2  FLOW RATE  CMN-484;10  FREE TEXT
  350                  Highes t O2 Flow  Rate                                   
  351                  INPUT  TRANSFORM:   K:$L(X)> 50!($L(X)< 1) X
  352                  MAXIMU M LENGTH:    50
  353                  LAST E DITED:       MAR 02,  2018 
  354                  HELP-P ROMPT:       Enter th e highest  oxygen flo w rate ord ered for t his patien t in liter s per minu te (LPM).   Enter a n umber.  If  oxygen ra te is less  than 1 LP M, enter ' X'. 
  355                  DESCRI PTION:       This fie ld indicat es the hig hest oxyge n flow rat e ordered  for this P atient in  liters per  minute (L PM).  The  value is e ither a nu mber, or i f the valu e is less  than 1 LPM , it shoul d be enter ed as an " X".  
  356                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER.
  357  
  358   399.0304,2 4.111   CM N LAST 4 L PM ABG PO2  (MMHG)
  359   399.0304,2 4.111 CMN  LAST 4 LPM  ABG PO2 ( MMHG) CMN- 484;11 NUM BER
  360                  Latest  4 LPM ABG  PO2 (mmHg )                           
  361                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  362                  LAST E DITED:       MAR 02,  2018 
  363                  HELP-P ROMPT:       Enter th e result o f the most  recent AB G test tak en on 4 LP M.  Enter  a whole nu mber which  will be r eported as  mmHg. 
  364                  DESCRI PTION:       This fie ld indicat es the res ult of the  most rece nt ABG tes t taken on  4 LPM.  T he number  entered wi ll be repo rted as mm Hg.  
  365                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  366  
  367   399.0304,2 4.113   CM N LAST 4 L PM O2 SATU RATION %
  368   399.0304,2 4.113 CMN  LAST 4 LPM  O2 SATURA TION % CMN -484;13 NU MBER
  369                  Latest  4 LPM O2  Saturation  (%)                        
  370                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  371                  LAST E DITED:       MAR 02,  2018 
  372                  HELP-P ROMPT:       Enter th e result o f the most  recent Ox ygen satur ation test .  Enter a  whole num ber which  will be re ported as  %. 
  373                  DESCRI PTION:       This fie ld indicat es the res ult of the  most rece nt Oxygen  saturation  test.  Th e number e ntered wil l be repor ted as %.   
  374                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  375  
  376   399.0304,2 4.114   CM N DATE OF  LAST 4 LPM  TESTS
  377   399.0304,2 4.114 CMN  DATE OF LA ST 4 LPM T ESTS CMN-4 84;14 DATE
  378                  Date o f the Late st 4 LPM T est(s)                          
  379                  INPUT  TRANSFORM:   S %DT="E X" D ^%DT  S X=Y K:Y< 1 X
  380                  LAST E DITED:       MAR 14,  2018 
  381                  HELP-P ROMPT:       Enter th e REQUIRED  date for  the most r ecent 4 LP M Test(s).  
  382                  DESCRI PTION:       This fie ld indicat es the Dat e for the  most recen t ABG PO2  and/or O2  Saturation  test(s) t aken on 4  LPM.
  383  
  384   399.0304,2 4.115   CM N EQUIPMEN T/COST DES CRIPTION
  385    399.0304, 24.115  CM N EQUIPMEN T/COST DES CRIPTION C MN-484;15  FREE TEXT
  386                  Equipm ent/Cost D escription                             
  387                  INPUT  TRANSFORM:   K:$L(X)> 50!($L(X)< 1) X
  388                  MAXIMU M LENGTH:    50
  389                  LAST E DITED:       NOV 14,  2017 
  390                  HELP-P ROMPT:       Enter a  1-50 chara cter free  text descr iption of  items, acc essories,  and option s ordered,  suppliers  charge an d Medicare  Fee Sched ule allowa nce for ea ch item, a ccessory a nd option.  
  391                  DESCRI PTION:       This fie ld indicat es the des cription o f the item s, accesso ries, and  options or dered, sup pliers cha rge and Me dicare Fee  Schedule  Allowance  for each i tem, acces sory and o ption.
  392  
  393  
  394              Fields 24. 201 thru 2 4.219 are  specific t o the CMN- 10126 
  395  
  396   399.0304,2 4.201   CM N SM BOWEL  ABSORPTIO N DOC?
  397   399.0304,2 4.201  CMN  SM BOWEL  ABSORPTION  DOC? CMN- 10126;1 SE T
  398                  Small  Bowel Abso rption Doc umentation  Present?        
  399                                      '0' FOR  NO; 
  400                                      '1' FOR  YES; 
  401                  LAST E DITED:       NOV 14,  2017 
  402                  HELP-P ROMPT:       Enter 'Y es' (1) if  there is  documentat ion on fil e for Smal l Bowel Ab sorption,  or 'No' (0 ) if there  is not. 
  403                  DESCRI PTION:       This fie ld indicat es whether  or not th ere is doc umentation  in the me dical reco rd that su pports the  patient's  permanent  non-funct ion or dis ease of th e structur es that pe rmit food  to reach o r be absor bed from t he small b owel.
  404  
  405   399.0304,2 4.202   CM N ENTERAL  NUTRITION  BY TUBE?
  406   399.0304,2 4.202 CMN  ENTERAL NU TRITION BY  TUBE? CMN -10126;2 S ET
  407                  Entera l Nutritio n by Tube?                             
  408                                      '0' FOR  NO; 
  409                                      '1' FOR  YES; 
  410                  LAST E DITED:       NOV 21,  2017 
  411                  HELP-P ROMPT:   E nter 'Yes'  (1) if th e Enteral  Nutrition  is being a dministere d by a tub e, or 'No'  (0) if it  is not. 
  412                  DESCRI PTION:   T his field  indicates  whether or  not the E nteral Nut rition is  being admi nistered v ia a tube  (Example:  gastrostom y tube).
  413  
  414   399.0304,2 4.203   CM N PROCEDUR E A CALORI ES
  415   399.0304,2 4.203 CMN  PROCEDURE  A CALORIES  CMN-10126 ;3 NUMBER
  416                  Proced ure A Calo ries                                   
  417                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  418                  LAST E DITED:       APR 20,  2018 
  419                  HELP-P ROMPT:       Enter th e calories  per day a ssociated  with Proce dure A. 
  420                  DESCRI PTION:
  421                                      This fie ld indicat es the cal ories per  day associ ated with  Procedure  A.  
  422                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  423  
  424   399.0304,2 4.204   CM N PROCEDUR E A
  425   399.0304,2 4.204 CMN  PROCEDURE  A       CM N-10126;4  POINTER TO  CPT FILE  (#81)
  426                  Proced ure A                                             
  427                  LAST E DITED:       APR 20,  2018 
  428                  HELP-P ROMPT:       Enter fi rst proced ure with a ssociated  calories. 
  429                  DESCRI PTION:        This is  the proce dure code  to which t he "Proced ure A Calo ries" fiel d correspo nds.
  430  
  431   399.0304,2 4.205   CM N METHOD O F ADMINIST RATION
  432   399.0304,2 4.205 CMN  METHOD OF  ADMINISTRA TION CMN-1 0126;5 SET
  433                  Method  of Admini stration                               
  434                                      '1' FOR  SYRINGE; 
  435                                      '2' FOR  GRAVITY; 
  436                                      '3' FOR  PUMP; 
  437                                      '4' FOR  ORAL; 
  438                  LAST E DITED:       NOV 15,  2017 
  439                  HELP-P ROMPT:   S elect the  appropriat e method b y which th e service  was admini stered. 
  440                  DESCRI PTION:      This fiel d indicate s the meth od by whic h the serv ice was ad ministered .
  441  
  442   399.030424 ,24.206    CMN DAYS P ER WEEK AD MINISTERED
  443   399.0304,2 4.206  CMN  DAYS PER  WEEK ADMIN ISTERED CM N-10126;6  NUMBER
  444                  Days/W eek Admini stered                                 
  445                  INPUT  TRANSFORM:   K:+X'=X! (X>7)!(X<1 )!(X?.E1". "1N.N) X
  446                  LAST E DITED:       NOV 14,  2017 
  447                  HELP-P ROMPT:       Enter th e number o f days per  week that  the nutri tion is ad ministered  or infuse d. 
  448                  DESCRI PTION:         This f ield indic ates the n umber of d ays per we ek that th e nutritio n is admin istered or  infused.
  449  
  450   399.030424 ,24.207    CMN SEVERE  MALABSORP TION DOC?
  451   399.0304,2 4.207  CMN  SEVERE MA LABSORPTIO N DOC? CMN -10126;7 S ET
  452                  Severe  Malabsorp tion Docum entation P resent?          
  453                                      '0' FOR  NO; 
  454                                      '1' FOR  YES; 
  455                  LAST E DITED:       NOV 14,  2017 
  456                  HELP-P ROMPT:       Enter 'Y es' (1) if  there is  documentat ion on fil e for Seve re Malabso rption, or  'No' (0)  if there i s not. 
  457                  DESCRI PTION:       This fie ld indicat es whether  or not th ere is doc umentation  in the me dical reco rd that su pports the  patient h aving perm anent dise ase of the  gastroint estinal tr act causin g malabsor ption seve re enough  to prevent  maintenan ce of weig ht and str ength.
  458  
  459   399.030424 ,24.208    CMN AMINO  ACID (ML/D AY)
  460   399.0304,2 4.208 CMN  AMINO ACID  (ML/DAY)  CMN-10126; 8 NUMBER
  461                  Amino  Acid (ml/d ay)                                    
  462                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  463                  LAST E DITED:       MAR 02,  2018 
  464                  HELP-P ROMPT:       Enter th e number o f millilit ers of the  component  Amino Aci d that are  administe red per da y in this  nutritiona l formula.  
  465                  DESCRI PTION:       This fie ld indicat es the num ber of mil liliters o f the comp onent Amin o Acid tha t are admi nistered p er day in  this nutri tional for mula.  
  466                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  467  
  468   399.030424 ,24.209    CMN AMINO  ACID CONCE NTRATION %
  469   399.0304,2 4.209 CMN  AMINO ACID  CONCENTRA TION % CMN -10126;9 N UMBER
  470                  Amino  Acid Conce ntration ( %)                          
  471                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  472                  LAST E DITED:       MAR 02,  2018 
  473                  HELP-P ROMPT:      Enter the  percent c oncentrati on of Amin o Acids in  this nutr itional fo rmula. 
  474                  DESCRI PTION:        This fi eld indica tes the pe rcent conc entration  of Amino A cids in th is nutriti onal formu la.  
  475                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  476  
  477   399.030424 ,24.21   C MN AMINO A CID PROTEI N (GM/DY)
  478   399.0304,2 4.21 CMN A MINO ACID  PROTEIN (G M/DY) CMN- 10126;10 N UMBER
  479                  Amino  Acid Prote in (gm/day )                           
  480                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  481                  LAST E DITED:       MAR 02,  2018 
  482                  HELP-P ROMPT:       Enter th e amount o f protein  administer ed in gram s/day in t his nutrit ional form ula. 
  483                  DESCRI PTION:         This f ield indic ates the a mount of p rotein adm inistered  in grams/d ay in this  nutrition al formula .  
  484                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  485  
  486   399.030424 ,24.211    CMN DEXTRO SE (ML/DAY )
  487   399.0304,2 4.211 CMN  DEXTROSE ( ML/DAY) CM N-10126;11  NUMBER
  488                  Dextro se (ml/day )                                      
  489                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  490                  LAST E DITED:       MAR 02,  2018 
  491                  HELP-P ROMPT:       Enter th e number o f millilit ers of the  component  Dextrose  that are a dministere d per day  in this nu tritional  formula. 
  492                  DESCRI PTION:       This fie ld indicat es the num ber of mil liliters o f the comp onent Dext rose that  are admini stered per  day in th is nutriti onal formu la.  
  493                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  494  
  495   399.030424 ,24.212    CMN DEXTRO SE CONCENT RATE %
  496   399.0304,2 4.212 CMN  DEXTROSE C ONCENTRATE  % CMN-101 26;12 NUMB ER
  497                  Dextro se Concent rate (%)                               
  498                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  499                  LAST E DITED:       MAR 02,  2018 
  500                  HELP-P ROMPT:   E nter the p ercent con centration  of Dextro se in this  nutrition al formula
  501                  DESCRI PTION:      This fiel d indicate s the perc ent concen tration of  Dextrose  in this nu tritional  formula.  
  502  
  503                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  504  
  505   399.030424 ,24.213    CMN LIPIDS  (ML/DAY)
  506   399.0304,2 4.213 CMN  LIPIDS (ML /DAY)   CM N-10126;13  NUMBER
  507                  Lipids  (ml/day)                                         
  508                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  509                  LAST E DITED:       MAR 02,  2018 
  510                  HELP-P ROMPT:       Enter th e number o f millilit ers of the  component  Lipids th at are adm inistered  per day in  this nutr itional fo rmula. 
  511                  DESCRI PTION:       This fie ld indicat es the num ber of mil liliters o f the comp onent Lipi ds that ar e administ ered per d ay in this  nutrition al formula .  
  512                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  513  
  514   399.030424 ,24.214    ROUTE OF A DMINISTRAT ION
  515   399.0304,2 4.214 CMN  ROUTE OF A DMINISTRAT ION CMN-10 126;14 SET
  516                  Route  of Adminis tration                                
  517                                      '1' FOR  CENTRAL LI NE (INCLUD ES PICC); 
  518                                      '2' FOR  HEMODIALYS IS ACCESS  LINE; 
  519                                      '3' FOR  PERITONEAL  CATHETER;  
  520                  LAST E DITED:       NOV 14,  2017 
  521                  HELP-P ROMPT:       Enter th e number t hat repres ents the a ppropriate  route by  which the  nutrition  was admini stered. 
  522                  DESCRI PTION:      This fiel d indicate s the rout e by which  the nutri tion was a dministere d.
  523  
  524                399.0304 24,24.215    CMN LIPI DS (DAYS/W EEK)
  525   399.0304,2 4.215  CMN  LIPIDS (D AYS/WEEK)  CMN-10126; 15 NUMBER
  526                  Lipids  (days/wk)                                        
  527                  INPUT  TRANSFORM:   K:+X'=X! (X>7)!(X<1 )!(X?.E1". "1N.N) X
  528                  LAST E DITED:       NOV 14,  2017 
  529                  HELP-P ROMPT:       Enter th e number o f days per  week the  component  lipids are  administe red in thi s nutritio nal formul a. 
  530                  DESCRI PTION:       This fie ld indicat es the num ber of day s per week  the compo nent Lipid s are admi nistered i n this nut ritional f ormula.
  531  
  532                399.0304 24,24.216    CMN LIPI DS CONCENT RATE %
  533   399.0304,2 4.216 CMN  LIPIDS CON CENTRATE %  CMN-10126 ;16 NUMBER
  534                  Lipids  Concentra te (%)                                 
  535                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  536                  LAST E DITED:       MAR 02,  2018 
  537                  HELP-P ROMPT:      Enter the  percent c oncentrati on of Lipi ds in this  nutrition al formula
  538                  DESCRI PTION:        This fi eld indica tes the pe rcent conc entration  of Lipids  in this nu tritional  formula.  
  539                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  540  
  541                 399.030 424,24.217    CMN PAR ENTERAL/EN TERAL/BOTH
  542   399.0304,2 4.217 CMN  PARENTERAL /ENTERAL/B OTH CMN-10 126;17 SET
  543                  Is thi s for Pare nteral nut rition, En teral nutr ition, or  Both?   
  544                                      'P' FOR  PARENTERAL
  545                                      'E' FOR  ENTERAL; 
  546                                      'B' FOR  BOTH; 
  547                  LAST E DITED:       APR 23,  2018 
  548                  HELP-P ROMPT:       Is this  CMN for Pa renteral n utrition,  enteral nu trition, o r both? 
  549                  DESCRI PTION:       This fie ld designa tes whethe r this CMN  form is f or Parente ral nutrit ion, enter al nutriti on, or bot h.
  550  
  551                 399.030 424,24.218    CMN PRO CEDURE B C ALORIES
  552    399.0304, 24.218 CMN  PROCEDURE  B CALORIE S CMN-1012 6;18 NUMBE R
  553                  Proced ure B Calo ries                                   
  554                  INPUT  TRANSFORM:   K:+X'=X! (X<1)!(X?. E1"."1N.N)  X
  555                  LAST E DITED:       APR 23,  2018 
  556                  HELP-P ROMPT:       Enter th e calories  per day a ssociated  with Proce dure B. 
  557                  DESCRI PTION:       This fie ld indicat es the cal ories per  day associ ated with  Procedure  B.  
  558                  NOTES:              XXXX--CA N'T BE ALT ERED EXCEP T BY PROGR AMMER
  559  
  560                 399.030 424,24.219    CMN PRO CEDURE B
  561   399.0304,2 4.219 CMN  PROCEDURE  B       CM N-10126;19  POINTER T O CPT FILE  (#81)
  562                  Proced ure B                                             
  563                  LAST E DITED:       APR 20,  2018 
  564                  HELP-P ROMPT:       Enter se cond proce dure with  associated  calories.  
  565                  DESCRI PTION:       This is  the proced ure code t o which th e "Procedu re B Calor ies" field  correspon ds.
  566  
  567  
  568  
  569   V)  Create  new Entri es in File s 364.5, 3 64.6 and 3 64.7 for t he 837 Tra nsmission  of CMN Dat a via new  segments C MN, FRM, L Q and MEA  and 2 new  pieces add ed to the  existing P T1 segment .
  570   File 364.5  Entries:
  571   N-CMN RECO RD ID ‘CMN  ‘
  572   NAME: N-CM N RECORD I D 'CMN '            
  573   SECURITY L EVEL: NATI ONAL,NO ED IT
  574   TYPE OF EL EMENT: EXT RACTED VIA  CODE   
  575   ELEMENT CA TEGORY: IN DIVIDUAL E LEMENT
  576  
  577   N-CMN RECO RD ID ‘FRM  ‘
  578   NAME: N-CM N RECORD I D 'FRM '             
  579   SECURITY L EVEL: NATI ONAL,NO ED IT
  580   TYPE OF EL EMENT: EXT RACTED VIA  CODE   
  581   ELEMENT CA TEGORY: IN DIVIDUAL E LEMENT
  582  
  583   N-CMN RECO RD ID ‘LQ   ‘
  584   NAME: N-CM N RECORD I D 'LQ  '             
  585   SECURITY L EVEL: NATI ONAL,NO ED IT
  586   TYPE OF EL EMENT: EXT RACTED VIA  CODE   
  587   ELEMENT CA TEGORY: IN DIVIDUAL E LEMENT
  588  
  589   N-CMN RECO RD ID ‘MEA  ‘
  590   NAME: N-CM N RECORD I D 'MEA '             
  591   SECURITY L EVEL: NATI ONAL,NO ED IT
  592   TYPE OF EL EMENT: EXT RACTED VIA  CODE   
  593   ELEMENT CA TEGORY: IN DIVIDUAL E LEMENT
  594  
  595   File 364.6  Entries
  596       CMN Se gment
  597                 CMN REC ORD ID 'CM N  '
  598   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  599     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  600     STARTING  COLUMN OR  PIECE: 1             LENGTH: 4
  601     SHORT DE SCRIPTION:  CMN RECOR D ID 'CMN  '
  602     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  603               CMN DATA  EXTRACT
  604   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  605     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  606     STARTING  COLUMN OR  PIECE: 1. 5          LENGTH: 1
  607     SHORT DE SCRIPTION:  CMN DATA  EXTRACT   
  608     CALCULAT E ONLY OR  OUTPUT: CA LCULATE ON LY
  609     TRANSMIT  IGNORES I F NULL: TR UE
  610  
  611                SERVICE  LINE #
  612   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  613     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  614     STARTING  COLUMN OR  PIECE: 2             LENGTH: 6
  615     SHORT DE SCRIPTION:  SERVICE L INE #     
  616     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  617  
  618                CMN CERT IFICATION  TYPE
  619   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  620     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  621     STARTING  COLUMN OR  PIECE: 3             LENGTH: 1
  622     SHORT DE SCRIPTION:  CMN CERTI FICATION T YPE
  623     CALCULAT E ONLY OR  OUTPUT: OU TPUT      
  624     DATA REQ UIRED FOR  FIELD: NO
  625  
  626                CMN UNIT  OR BASIS  FOR MEASUR EMENT CODE
  627   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  628     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  629     STARTING  COLUMN OR  PIECE: 4             LENGTH: 2
  630     SHORT DE SCRIPTION:  CMN UNIT  OR BASIS F OR MEASURE MENT CODE
  631     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  632  
  633                CMN MONT HS DME EQU IPMENT NEE DED
  634   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  635     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  636     STARTING  COLUMN OR  PIECE: 5             LENGTH: 2
  637     SHORT DE SCRIPTION:  CMN MONTH S DME EQUI PMENT NEED ED
  638     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  639  
  640                CMN CODE  CATEGORY
  641   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  642     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  643     STARTING  COLUMN OR  PIECE: 6             LENGTH: 2
  644     SHORT DE SCRIPTION:  CMN CODE  CATEGORY  
  645     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  646  
  647                CMN CERT IFICATION  CONDITION  INDICATOR
  648   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  649     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  650     STARTING  COLUMN OR  PIECE: 7             LENGTH: 1
  651     SHORT DE SCRIPTION:  CMN CERTI FICATION C ONDITION I NDICATOR
  652     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  653  
  654                CMN COND ITION INDI CATOR
  655   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  656     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  657     STARTING  COLUMN OR  PIECE: 8             LENGTH: 3
  658     SHORT DE SCRIPTION:  CMN CONDI TION INDIC ATOR
  659     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  660  
  661                CMN REPL ACEMENT IT EM?
  662   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  663     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  664     STARTING  COLUMN OR  PIECE: 9             LENGTH: 3
  665     SHORT DE SCRIPTION:  CMN REPLA CEMENT ITE M?
  666     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  667  
  668                CMN DATE  THERAPY S TARTED QUA LIFIER
  669   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  670     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  671     STARTING  COLUMN OR  PIECE: 10            LENGTH: 3
  672     SHORT DE SCRIPTION:  CMN DATE  THERAPY ST ARTED QUAL IFIER
  673     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  674  
  675                CMN DATE  THERAPY S TARTED
  676   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  677     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  678     STARTING  COLUMN OR  PIECE: 11            LENGTH: 8
  679     SHORT DE SCRIPTION:  CMN DATE  THERAPY ST ARTED
  680     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  681  
  682                CMN LAST  CERTIFICA TION DATE  QUALIFIER
  683   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  684     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  685     STARTING  COLUMN OR  PIECE: 12            LENGTH: 3
  686     SHORT DE SCRIPTION:  CMN LAST  CERTIFICAT ION DATE Q UALIFIER
  687     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  688  
  689                CMN LAST  CERTIFICA TION DATE
  690   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  691     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  692     STARTING  COLUMN OR  PIECE: 13            LENGTH: 8
  693     SHORT DE SCRIPTION:  CMN LAST  CERTIFICAT ION DATE
  694     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  695  
  696                CMN CERT IFICATION  TYPE QUAL
  697   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  698     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  699     STARTING  COLUMN OR  PIECE: 14            LENGTH: 3
  700     SHORT DE SCRIPTION:  CMN CERTI FICATION T YPE QUAL
  701     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  702  
  703                CMN RECE RTIFICATIO N/REVISION  DATE
  704   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  705     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  706     STARTING  COLUMN OR  PIECE: 15            LENGTH: 8
  707     SHORT DE SCRIPTION:  CMN RECER TIFICATION /REVISION  DATE
  708     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  709          
  710                CMN ATTA CHMENT REP ORT TYPE C ODE
  711   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  712     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  713     STARTING  COLUMN OR  PIECE: 16            LENGTH: 2
  714     SHORT DE SCRIPTION:  CMN ATTAC HMENT REPO RT TYPE CO DE
  715     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  716     
  717                CMN ATTA CHMENT TRA NSMISSION  CODE
  718   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  719     PAGE OR  SEQUENCE:  191.4                 FIRST LINE  NUMBER: 1
  720     STARTING  COLUMN OR  PIECE: 17            LENGTH: 2
  721     SHORT DE SCRIPTION:  CMN ATTAC HMENT TRAN SMISSION C ODE
  722     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  723  
  724    
  725              FRM Segmen t
  726  
  727                CMN RECO RD ID 'FRM  '
  728   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  729     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  730     STARTING  COLUMN OR  PIECE: 1             LENGTH: 4
  731     SHORT DE SCRIPTION:  CMN RECOR D ID 'FRM  '
  732     CALCULAT E ONLY OR  OUTPUT: OU TPUT       TRANSMIT I GNORES IF  NULL: FALS E
  733     DATA REQ UIRED FOR  FIELD: YES
  734  
  735                FRM DATA  EXTRACT
  736   BILL FORM:  IB 837 TR ANSMISSION            PAGE OR SE QUENCE: 21 0
  737     FIRST LI NE NUMBER:  1                    LOCAL OVER RIDE ALLOW ED: NO
  738     STARTING  COLUMN OR  PIECE: 1. 5          LENGTH: 1
  739     SHORT DE SCRIPTION:  FRM DATA  EXTRACT   
  740     CALCULAT E ONLY OR  OUTPUT: CA LCULATE ON LY
  741     TRANSMIT  IGNORES I F NULL: TR UE
  742  
  743                SERVICE  LINE #
  744   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  745     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  746     STARTING  COLUMN OR  PIECE: 2             LENGTH: 6
  747     SHORT DE SCRIPTION:  SERVICE L INE #     
  748     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  749  
  750                CMN QUES TION NUMBE R/LETTER
  751   BILL FORM:  IB 837 TR ANSMISSION            PAGE OR SE QUENCE: 21 0
  752     FIRST LI NE NUMBER:  1                    STARTING C OLUMN OR P IECE: 3
  753     LENGTH:  20
  754     SHORT DE SCRIPTION:  CMN QUEST ION NUMBER /LETTER
  755     CALCULAT E ONLY OR  OUTPUT: OU TPUT      
  756     TRANSMIT  IGNORES I F NULL: FA LSE
  757  
  758                CMN QUES TION RESPO NSE Y/N
  759   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  760     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  761     STARTING  COLUMN OR  PIECE: 4             LENGTH: 1
  762     SHORT DE SCRIPTION:  CMN QUEST ION RESPON SE Y/N
  763     CALCULAT E ONLY OR  OUTPUT: OU TPUT      
  764     
  765                CMN QUES TION RESPO NSE REF ID
  766   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  767     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  768     STARTING  COLUMN OR  PIECE: 5             LENGTH: 50
  769     SHORT DE SCRIPTION:  CMN QUEST ION RESPON SE REF ID
  770     CALCULAT E ONLY OR  OUTPUT: OU TPUT      
  771  
  772                CMN QUES TION RESPO NSE DATE
  773   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  774     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  775     STARTING  COLUMN OR  PIECE: 6             LENGTH: 8
  776     SHORT DE SCRIPTION:  CMN QUEST ION RESPON SE DATE
  777     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  778  
  779                CMN QUES TION RESPO NSE % & DE CIMAL
  780   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  781     PAGE OR  SEQUENCE:  210                   FIRST LINE  NUMBER: 1
  782     STARTING  COLUMN OR  PIECE: 7             LENGTH: 6
  783     SHORT DE SCRIPTION:  CMN QUEST ION RESPON SE % & DEC IMAL
  784     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  785  
  786  
  787            L Q Segment
  788  
  789                CMN RECO RD ID 'LQ   '
  790   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  791     PAGE OR  SEQUENCE:  205                   FIRST LINE  NUMBER: 1
  792     STARTING  COLUMN OR  PIECE: 1             LENGTH: 4
  793     SHORT DE SCRIPTION:  CMN RECOR D ID 'LQ   '
  794     CALCULAT E ONLY OR  OUTPUT: OU TPUT       TRANSMIT I GNORES IF  NULL: FALS E
  795     DATA REQ UIRED FOR  FIELD: YES
  796  
  797                LQ DATA  EXTRACT
  798   BILL FORM:  IB 837 TR ANSMISSION            PAGE OR SE QUENCE: 20 5
  799     FIRST LI NE NUMBER:  1                    LOCAL OVER RIDE ALLOW ED: NO
  800     STARTING  COLUMN OR  PIECE: 1. 5          LENGTH: 1
  801     SHORT DE SCRIPTION:  LQ DATA E XTRACT    
  802     CALCULAT E ONLY OR  OUTPUT: CA LCULATE ON LY
  803     TRANSMIT  IGNORES I F NULL: TR UE
  804  
  805                SERVICE  LINE #
  806   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  807     PAGE OR  SEQUENCE:  205                   FIRST LINE  NUMBER: 1
  808     STARTING  COLUMN OR  PIECE: 2             LENGTH: 6
  809     SHORT DE SCRIPTION:  SERVICE L INE #     
  810     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  811     TRANSMIT  IGNORES I F NULL: TR UE         DATA REQUI RED FOR FI ELD: NO
  812  
  813                CMN FORM  TYPE QUAL IFIER
  814   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  815     PAGE OR  SEQUENCE:  205                   FIRST LINE  NUMBER: 1
  816     STARTING  COLUMN OR  PIECE: 3             LENGTH: 30
  817     SHORT DE SCRIPTION:  CMN FORM  TYPE QUALI FIER
  818     CALCULAT E ONLY OR  OUTPUT: OU TPUT       TRANSMIT I GNORES IF  NULL: FALS E
  819     DATA REQ UIRED FOR  FIELD: NO
  820                
  821                CMN INDU STRY CODE
  822   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  823     PAGE OR  SEQUENCE:  205                   FIRST LINE  NUMBER: 1
  824     STARTING  COLUMN OR  PIECE: 4             LENGTH: 10
  825     SHORT DE SCRIPTION:  CMN INDUS TRY CODE  
  826     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  827     TRANSMIT  IGNORES I F NULL: FA LSE        DATA REQUI RED FOR FI ELD: NO
  828  
  829  
  830            M EA Segment
  831  
  832                CMN RECO RD ID 'MEA  '
  833   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  834     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  835     STARTING  COLUMN OR  PIECE: 1             LENGTH: 4
  836     SHORT DE SCRIPTION:  CMN RECOR D ID 'MEA  '
  837     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  838  
  839               MEA DATA  EXTRACT
  840   BILL FORM:  IB 837 TR ANSMISSION           
  841     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  842     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  843     STARTING  COLUMN OR  PIECE: 1. 5          LENGTH: 1
  844     SHORT DE SCRIPTION:  MEA DATA  EXTRACT   
  845     CALCULAT E ONLY OR  OUTPUT: CA LCULATE ON LY
  846  
  847                SERVICE  LINE #
  848   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  849     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  850     STARTING  COLUMN OR  PIECE: 2             LENGTH: 6
  851     SHORT DE SCRIPTION:  SERVICE L INE #     
  852     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  853  
  854                CMN MEAS UREMENT RE FERENCE ID  CODE  (Pa tient Heig ht Modifie r)
  855   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  856     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  857     STARTING  COLUMN OR  PIECE: 3             LENGTH: 2
  858     SHORT DE SCRIPTION:  CMN MEASU REMENT REF ERENCE ID  CODE
  859     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  860  
  861                CMN MEAS UREMENT QU ALIFIER
  862   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  863     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  864     STARTING  COLUMN OR  PIECE: 4             LENGTH: 3
  865     SHORT DE SCRIPTION:  CMN MEASU REMENT QUA LIFIER
  866     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  867  
  868                CMN TEST  RESULTS   (Patient H eight)
  869   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  870     PAGE OR  SEQUENCE:  191.7                 FIRST LINE  NUMBER: 1
  871     STARTING  COLUMN OR  PIECE: 5             LENGTH: 20
  872     SHORT DE SCRIPTION:  CMN TEST  RESULTS   
  873     CALCULAT E ONLY OR  OUTPUT: OU TPUT
  874  
  875  
  876            P T1 Segment
  877  
  878                CMN PATI ENT WEIGHT  MODIFIER
  879     BILL FOR M: IB 837  TRANSMISSI ON           SECURITY  LEVEL: NA TIONAL,NO  EDIT
  880     PAGE OR  SEQUENCE:  40                    FIRST LINE  NUMBER: 1
  881     STARTING  COLUMN OR  PIECE: 14            LENGTH: 2
  882     SHORT DE SCRIPTION:  CMN PATIE NT WEIGHT  MODIFIER
  883     CALCULAT E ONLY OR  OUTPUT: OU TPUT 
  884  
  885                CMN PATI ENT WEIGHT  (LBS)
  886   BILL FORM:  IB 837 TR ANSMISSION            SECURITY L EVEL: NATI ONAL,NO ED IT
  887     PAGE OR  SEQUENCE:  40                    FIRST LINE  NUMBER: 1
  888     STARTING  COLUMN OR  PIECE: 15            LENGTH: 4
  889     SHORT DE SCRIPTION:  CMN PATIE NT WEIGHT  (LBS)
  890     CALCULAT E ONLY OR  OUTPUT: OU TPUT   
  891     
  892  
  893   File 364.7  Entries
  894  
  895            C MN Segment
  896   CMN RECORD  ID 'CMN '
  897   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  898     SECURITY  LEVEL: NA TIONAL,NO  EDIT      
  899     DATA ELE MENT: N-CM N RECORD I D 'CMN '
  900     PAD CHAR ACTER: NO  PAD REQUIR ED        
  901     FORMAT C ODE: K IBX DATA S IBX DATA="CMN 
  902  
  903   CMN DATA E XTRACT
  904   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  905     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  906     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  907     FORMAT C ODE: D:$D( IBXSAVE("C MNDEX"))'> 1 CMNDEX^I BCEF31(IBX IEN,.IBXSA VE) 
  908  
  909   SERVICE LI NE #
  910   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  911     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  912     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  913     FORMAT C ODE: D:$D( IBXSAVE("C MNDEX"))'> 1 CMNDEX^I BCEF31(IBX IEN,.IBXSA VE) 
  914  
  915   CMN CERTIF ICATION TY PE
  916   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  917     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  918     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  919     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  920     EDIT STA TUS: EDITA BLE
  921     FORMAT C ODE: N Z N  Z K IBXDA TA S Z=0 F   S Z=$O(I BXSAVE("CM NDEX",Z))  Q:'Z  S IB XDATA(Z)=$ $CMNDATA^I BCEF31(IBX IEN,+IBXSA VE("CMNDEX ",Z),24.01 ,"I")
  922  
  923   CMN UNIT O R BASIS FO R MEASUREM ENT CODE
  924   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  925     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  926     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  927     PAD CHAR ACTER: NO  PAD REQUIR ED
  928     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="MO" 
  929  
  930   CMN MONTHS  DME EQUIP MENT NEEDE D
  931   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  932     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  933     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  934     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  935     EDIT STA TUS: EDITA BLE
  936     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$CMN DATA^IBCEF 31(IBXIEN, +IBXSAVE(" CMNDEX",Z) ,24.04) 
  937  
  938   CMN CODE C ATEGORY
  939   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  940     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  941     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  942     PAD CHAR ACTER: NO  PAD REQUIR ED
  943     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="09"
  944     
  945   CMN CERTIF ICATION CO NDITION IN DICATOR
  946   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  947     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  948     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  949     PAD CHAR ACTER: NO  PAD REQUIR ED
  950     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="Y"
  951  
  952   CMN CONDIT ION INDICA TOR
  953   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  954     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  955     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  956     PAD CHAR ACTER: NO  PAD REQUIR ED
  957     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="38"
  958  
  959   CMN REPLAC EMENT ITEM ?
  960   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  961     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  962     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  963     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  964     EDIT STA TUS: EDITA BLE
  965     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   I $$CMND ATA^IBCEF3 1(IBXIEN,+ IBXSAVE("C MNDEX",Z), 24.08,"I")  S IBXDATA (Z)="ZV"
  966  
  967   CMN DATE T HERAPY STA RTED QUALI FIER
  968   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  969     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  970     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  971     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  972     EDIT STA TUS: DISPL AY ONLY
  973     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=463
  974     FORMAT C ODE DESCRI PTION:   T he value o f CMN DATE  THERAPY S TARTED QUA LIFIER is  always '46 3'.
  975  
  976   CMN DATE T HERAPY STA RTED
  977   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  978     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  979     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  980     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  981     EDIT STA TUS: EDITA BLE
  982     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$DT^ IBCEFG1($$ CMNDATA^IB CEF31(IBXI EN,+IBXSAV E("CMNDEX" ,Z),24.05, "I"),"","D 8")
  983  
  984   CMN LAST C ERTIFICATI ON DATE QU ALIFIER
  985   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  986     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  987     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  988     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  989     EDIT STA TUS: EDITA BLE
  990     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=461
  991  
  992   CMN LAST C ERTIFICATI ON DATE
  993   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  994     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  995     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  996     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  997     EDIT STA TUS: EDITA BLE
  998     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$DT^ IBCEFG1($$ CMNDATA^IB CEF31(IBXI EN,+IBXSAV E("CMNDEX" ,Z),24.06, "I"),"","D 8")
  999  
  1000   CMN CERTIF ICATION TY PE QUAL
  1001   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1002     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1003     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1004     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1005     EDIT STA TUS: DISPL AY ONLY
  1006     FORMAT C ODE: N Z,C ERTYP K IB XDATA S Z= 0 F  S Z=$ O(IBXSAVE( "CMNDEX",Z )) Q:'Z  S  CERTYP=$$ CMNDATA^IB CEF31(IBXI EN,+IBXSAV E("CMNDEX" ,Z),24.01, "I") I CER TYP="R"!(C ERTYP="S")  S IBXDATA (Z)=607
  1007  
  1008   CMN RECERT IFICATION/ REVISION D ATE
  1009   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1010     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1011     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1012     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1013     EDIT STA TUS: EDITA BLE
  1014     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$DT^ IBCEFG1($$ CMNDATA^IB CEF31(IBXI EN,+IBXSAV E("CMNDEX" ,Z),24.07, "I"),"","D 8")
  1015     
  1016   CMN ATTACH MENT REPOR T TYPE COD E
  1017   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1018     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1019     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1020     PAD CHAR ACTER: NO  PAD REQUIR ED
  1021     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="CT"
  1022  
  1023   CMN ATTACH MENT TRANS MISSION CO DE
  1024   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1025     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1026     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1027     PAD CHAR ACTER: NO  PAD REQUIR ED
  1028     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="AD"
  1029  
  1030  
  1031              FRM Segmen t
  1032   CMN RECORD  ID 'FRM '
  1033   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1034     SECURITY  LEVEL: NA TIONAL,NO  EDIT       DATA ELEME NT: N-CMN  RECORD ID  'FRM '
  1035     PAD CHAR ACTER: NO  PAD REQUIR ED         EDIT STATU S: DISPLAY  ONLY
  1036     FORMAT C ODE: K IBX DATA S IBX DATA="FRM  "
  1037  
  1038   FRM DATA E XTRACT
  1039   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1040     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1041     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1042     PAD CHAR ACTER: NO  PAD REQUIR ED
  1043     FORMAT C ODE: K IBX SAVE("FRM" ) D FRM^IB CEF31(IBXI EN,.IBXSAV E)
  1044  
  1045   SERVICE LI NE #
  1046   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1047     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1048     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1049     PAD CHAR ACTER: NO  PAD REQUIR ED         EDIT STATU S: DISPLAY  ONLY
  1050     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z )=$P(IBXSA VE("FRM",Z ),U,6) D:Z >1 ID^IBCE F2(Z,"FRM" )
  1051  
  1052   CMN QUESTI ON NUMBER/ LETTER
  1053   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1054     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1055     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1056     PAD CHAR ACTER: NO  PAD REQUIR ED
  1057     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z )=$P(IBXSA VE("FRM",Z ),U)
  1058  
  1059                 CMN QUE STION RESP ONSE Y/N
  1060   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1061     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1062     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1063     PAD CHAR ACTER: NO  PAD REQUIR ED
  1064     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z )=$P(IBXSA VE("FRM",Z ),U,2)
  1065  
  1066   CMN QUESTI ON RESPONS E REF ID
  1067   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1068     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1069     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1070     PAD CHAR ACTER: NO  PAD REQUIR ED
  1071     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z )=$P(IBXSA VE("FRM",Z ),U,3)
  1072  
  1073   CMN QUESTI ON RESPONS E DATE
  1074   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1075     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1076     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1077     PAD CHAR ACTER: NO  PAD REQUIR ED
  1078     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z
  1079   )=$P(IBXSA VE("FRM",Z ),U,4)
  1080  
  1081   CMN QUESTI ON RESPONS E % & DECI MAL
  1082   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1083     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1084     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1085     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("FRM",Z )) Q:'Z  S  IBXDATA(Z )=$P(IBXSA VE("FRM",Z ),U,5)
  1086  
  1087  
  1088               LQ Segmen t
  1089   CMN RECORD  ID 'LQ  '
  1090   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1091     SECURITY  LEVEL: NA TIONAL,NO  EDIT       DATA ELEME NT: N-CMN  RECORD ID  'LQ  '
  1092     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1093     EDIT STA TUS: DISPL AY ONLY               FORMAT COD E: K IBXDA TA S IBXDA TA="LQ  "   
  1094  
  1095   LQ DATA EX TRACT
  1096   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1097     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1098     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1099     PAD CHAR ACTER: NO  PAD REQUIR ED
  1100     FORMAT C ODE: D:$D( IBXSAVE("C MNDEX"))'> 1 CMNDEX^I BCEF31(IBX IEN,.IBXSA VE)
  1101  
  1102   SERVICE LI NE #
  1103   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1104     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1105     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1106     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1107     EDIT STA TUS: DISPL AY ONLY
  1108     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$P(IB XSAVE("CMN DEX",Z),U, 2) D:Z>1 I D^IBCEF2(Z ,"LQ")
  1109  
  1110   CMN FORM T YPE QUALIF IER
  1111   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1112     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1113     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1114     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1115     EDIT STA TUS: DISPL AY ONLY
  1116     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="UT"
  1117    FORMAT CO DE DESCRIP TION:   Th e CMN FORM  TYPE QUAL IFIER is a lways 'UT' .  
  1118  
  1119   CMN INDUST RY CODE
  1120   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1121     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1122     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1123     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1124     EDIT STA TUS: DISPL AY ONLY
  1125     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$CMN DATA^IBCEF 31(IBXIEN, +IBXSAVE(" CMNDEX",Z) ,"24:2")
  1126  
  1127               MEA Segme nt
  1128   CMN RECORD  ID ‘MEA ‘
  1129   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1130     SECURITY  LEVEL: NA TIONAL,NO  EDIT      
  1131     DATA ELE MENT: N-CM N RECORD I D 'MEA '
  1132     PAD CHAR ACTER: NO  PAD REQUIR ED       
  1133    FORMAT CO DE: K IBXD ATA S IBXD ATA="MEA "
  1134  
  1135   MEA DATA E XTRACT
  1136   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1137     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1138     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1139     PAD CHAR ACTER: NO  PAD REQUIR ED
  1140     FORMAT C ODE: D:$D( IBXSAVE("C MNDEX"))'> 1 CMNDEX^I BCEF31(IBX IEN,.IBXSA VE)
  1141  
  1142   SERVICE LI NE #
  1143   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1144     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1145     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1146     PAD CHAR ACTER: NO  PAD REQUIR ED
  1147     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$P(IB XSAVE("CMN DEX",Z),U, 2) D:Z>1 I D^IBCEF2(Z ,"MEA")
  1148  
  1149   CMN MEASUR EMENT REFE RENCE ID C ODE
  1150   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1151     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1152     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1153     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1154     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="TR"
  1155  
  1156   CMN MEASUR EMENT QUAL IFIER
  1157   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1158     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1159     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1160     PAD CHAR ACTER: NO  PAD REQUIR ED
  1161     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)="" I  $$CMNDATA^ IBCEF31(IB XIEN,+IBXS AVE("CMNDE X",Z),24.0 2) S IBXDA TA(Z)="HT"
  1162  
  1163   CMN TEST R ESULTS
  1164   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1165     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1166     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1167     PAD CHAR ACTER: NO  PAD REQUIR ED
  1168     FORMAT C ODE: N Z K  IBXDATA S  Z=0 F  S  Z=$O(IBXSA VE("CMNDEX ",Z)) Q:'Z   S IBXDAT A(Z)=$$CMN DATA^IBCEF 31(IBXIEN, +IBXSAVE(" CMNDEX",Z) ,24.02)
  1169  
  1170            P T1 Segment
  1171                CMN PATI ENT WEIGHT  (LBS)
  1172   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1173     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1174     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1175     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1176     EDIT STA TUS: EDITA BLE
  1177     FORMAT C ODE: K IBX DATA S IBX DATA=$$PTW T^IBCEF31( IBXIEN)  
  1178     
  1179                CMN PATI ENT WEIGHT  MODIFIER
  1180   FORM FIELD  REFERENCE : IB 837 T RANSMISSIO N
  1181     SECURITY  LEVEL: NA TIONAL,NO  EDIT
  1182     DATA ELE MENT: N-GE T FROM PRE VIOUS EXTR ACT
  1183     PAD CHAR ACTER: NO  PAD REQUIR ED         REQUIRED:  NO
  1184     EDIT STA TUS: EDITA BLE
  1185     FORMAT C ODE: K IBX DATA S IBX DATA="" I  $$PTWT^IBC EF31(IBXIE N) S IBXDA TA="01"
  1186     FORMAT C ODE DESCRI PTION:   T his is the  PATIENT W EIGHT MODI FIER which  is always  '01'.
  1187  
  1188  
  1189   VI)  New e ntries to  the IB ERR OR file 35 0.8 for mi ssing or i ncorrect C MN Data:
  1190   IB CMN NOT  REQ BUT D ATA
  1191   NAME: IB C MN NOT REQ  BUT DATA
  1192     ERROR ME SSAGE: - " CMN Requir ed?" set t o NO, but  CMN data e xists.
  1193     ERROR CO DE: IB901
  1194     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1195     ERROR AC TION: DISP LAY MESSAG E
  1196  
  1197   IB CMN FOR M TYPE
  1198   NAME: IB C MN FORM TY PE                   
  1199     ERROR ME SSAGE: - " CMN Form t ype" missi ng.
  1200     ERROR CO DE: IB902
  1201     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1202     ERROR AC TION: DISP LAY MESSAG E
  1203  
  1204   IB CMN NO  DATA NODE
  1205   NAME: IB C MN NO DATA  NODE
  1206     ERROR ME SSAGE: - C MN form-sp ecific dat a missing  for the Fo rm Type ch osen.
  1207     ERROR CO DE: IB903
  1208     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1209     ERROR AC TION: DISP LAY MESSAG E
  1210  
  1211   IB CMN BAD  DATA NODE
  1212   NAME: IB C MN BAD DAT A NODE
  1213     ERROR ME SSAGE: - C MN data do es not mat ch the cho sen Form T ype.
  1214     ERROR CO DE: IB904
  1215     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1216     ERROR AC TION: DISP LAY MESSAG E
  1217  
  1218   IB CMN CER T TYPE
  1219   NAME: IB C MN CERT TY PE                   
  1220     ERROR ME SSAGE: - " Certificat ion Type"  missing.
  1221     ERROR CO DE: IB905
  1222     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1223     ERROR AC TION: DISP LAY MESSAG E
  1224  
  1225   IB CMN PEB
  1226   NAME: IB C MN PEB
  1227     ERROR ME SSAGE: - " Is this fo r Parenter al nutriti on, Entera l nutritio n, or Both ?" missing .              
  1228     ERROR CO DE: IB906
  1229     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1230     ERROR AC TION: DISP LAY MESSAG E
  1231  
  1232   IB CMN THE RAPY DT
  1233   NAME: IB C MN THERAPY  DT                  
  1234     ERROR ME SSAGE: - " Date Thera py Started " missing.
  1235     ERROR CO DE: IB907
  1236     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1237     ERROR AC TION: DISP LAY MESSAG E
  1238  
  1239   IB CMN LAS T CERT DT
  1240   NAME: IB C MN LAST CE RT DT
  1241     ERROR ME SSAGE: - " Last Certi fication D ate" missi ng.
  1242     ERROR CO DE: IB908
  1243     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1244     ERROR AC TION: DISP LAY MESSAG E
  1245  
  1246   IB CMN REC ERT/REVISI ON DT
  1247   NAME: IB C MN RECERT/ REVISION D T
  1248     ERROR ME SSAGE: - " Recertific ation/Revi sion Date"  missing.
  1249     ERROR CO DE: IB909
  1250     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1251     ERROR AC TION: DISP LAY MESSAG E
  1252  
  1253   IB CMN ABG  SAT DT
  1254   NAME: IB C MN ABG SAT  DT
  1255     ERROR ME SSAGE: - D ate of las t "ABG PO2 " and/or " O2 Saturat ion" Test( s) missing .
  1256     ERROR CO DE: IB912
  1257     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1258     ERROR AC TION: DISP LAY MESSAG E
  1259  
  1260   IB CMN 4 L PM DATE
  1261   NAME: IB C MN 4 LPM D ATE
  1262     ERROR ME SSAGE: - " Date of La test 4 LPM  Test(s) m issing.
  1263     ERROR CO DE: IB914
  1264     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1265     ERROR AC TION: DISP LAY MESSAG E
  1266  
  1267   IB CMN ERR ORS HEADER
  1268   NAME: IB C MN ERRORS  HEADER               
  1269     ERROR ME SSAGE: The  following  CMN field (s) missin g or in er ror for at  least 1 p rocedure:
  1270     ERROR CO DE: IB915                       
  1271     PACKAGE  REPORTING  ERROR: INT EGRATED BI LLING
  1272     ERROR AC TION: DISP LAY MESSAG E
  1273  
  1274  
  1275   Routines M odified
  1276  
  1277   V1)  Check  for missi ng CMN dat a after en tering a b ill and di splay appr opriate er ror messag es:
  1278   IBCBB1 – C alls routi ne IBCBB13  to perfor m the chec ks for mis sing CMN d ata
  1279   Routines
  1280   Activities
  1281   Routine Na me
  1282   IBCBB1
  1283   Enhancemen t Category
  1284    New
  1285    Modify
  1286    Delete
  1287    No Change
  1288   RTM
  1289  
  1290   Related Op tions
  1291   None
  1292   Related Ro utines
  1293   Routines “ Called By”
  1294   Routines “ Called”   
  1295  
  1296  
  1297  
  1298  
  1299   Data Dicti onary (DD)  Reference s
  1300  
  1301   Related Pr otocols
  1302   None
  1303   Related In tegration  Control Re gistration s (ICRs)
  1304   None
  1305   Data Passi ng
  1306    Input
  1307    Output Re ference
  1308    Both
  1309    Global Re ference
  1310    Local
  1311   Input Attr ibute Name  and Defin ition
  1312   Name:
  1313   Definition :
  1314   Output Att ribute Nam e and Defi nition
  1315   Name:
  1316   Definition :
  1317   Current Lo gic
  1318   IBCBB1 ;AL B/AAS - CO NTINUATION  OF EDIT C HECK ROUTI NE ;2-NOV- 89
  1319    ;;2.0;INT EGRATED BI LLING;**27 ,52,80,93, 106,51,151 ,148,153,1 37,232,280 ,155,320,3 43,349,363 ,371,395,3 84,432,447 ,488,554,5 77,592**;2 1-MAR-94;B uild 25
  1320    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  1321    ;
  1322    ; *** Beg in IB*2.0* 488 VD  (I ssue 46 RB N)
  1323    N I
  1324    S I=""
  1325    S X=+$G(^ DGCR(399,I BIFN,"MP") )
  1326    I 'X,$$MC RWNR^IBEFU NC(+$$CURR ^IBCEF2(IB IFN)) S X= +$$CURR^IB CEF2(IBIFN )
  1327    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1328    I X,+$G(^ DIC(36,X,3 )) S I=$P( ^(3),U,$S( $$FT^IBCEF (IBIFN)=2: 2,$$FT^IBC EF(IBIFN)= 7:2,1:4))
  1329    S I=$$UP^ XLFSTR(I)
  1330    I (I'=""& (I["PRNT") &($G(IBER) '["IB488") ) D 
  1331    . S IBER= $G(IBER)_" IB488;"
  1332    ;
  1333    ; Cause a n error if  FORCED TO  PRINT TO  CLEARINGHO USE
  1334    I $P($G(^ DGCR(399,I BIFN,"TX") ),U,8)=2 D
  1335    . S IBER= $G(IBER)_" IB489;"
  1336    ;
  1337    ; Cause a  fatal err or if the  claim has  no procedu res & is N OT a UB-04  Inpatient  claim.
  1338    I +$O(^DG CR(399,IBI FN,"CP",0) )=0 D
  1339    .I $$INPA T^IBCEF(IB IFN,1),$$I NSPRF^IBCE F(IBIFN) Q    ; inpat ient UB-04  check
  1340    .I '$$INP AT^IBCEF(I BIFN,1),$$ INSPRF^IBC EF(IBIFN)  D  Q       ; Outpatie nt Institu tional Cla im.
  1341    ..I IBER[ "IB352" Q
  1342    ..S IBER= IBER_"IB35 2;"
  1343    .;
  1344    .; Profes sional cla im
  1345    .I IBER[" IB353" Q
  1346    .S IBER=I BER_"IB353 ;"
  1347    .Q
  1348    ; *** End  IB*2.0*48 8 -- VD
  1349    ;
  1350    ;MAP TO D GCRBB1
  1351    ;
  1352   % ;Bill St atus
  1353    N Z,Z0,Z1 ,IBFT
  1354    I $S(+IBS T=0:1,1:"^ 1^2^3^4^7^ "'[(U_IBST _U)) S IBE R=IBER_"IB 045;"
  1355    ;
  1356    ;Statemen t Covers F rom
  1357    I IBFDT=" " S IBER=I BER_"IB061 ;"
  1358    I IBFDT]" ",IBFDT'?7 N&(IBFDT'? 7N1".".N)  S IBER=IBE R_"IB061;"
  1359    I IBFDT>I BTDT S IBE R=IBER_"IB 061;" ; fr om must be  on or bef ore the to  date 
  1360    S IBFFY=$ $FY^IBOUTL (IBFDT)
  1361    ; if inpa t - from d ate must n ot be prio r to admit  date.
  1362    I $$INPAT ^IBCEF(IBI FN,1),(IBF DT<($P($G( ^DGPT(+$P( IBND0,U,8) ,0)),U,2)\ 1))  S IBE R=IBER_"IB 061;"
  1363    ;
  1364    ;Statemen t Covers T o
  1365    I IBTDT=" " S IBER=I BER_"IB062 ;"
  1366    I IBTDT]" ",IBTDT'?7 N&(IBTDT'? 7N1".".N)  S IBER=IBE R_"IB062;"
  1367    I IBTDT>D T!(IBTDT<I BFDT) S IB ER=IBER_"I B062;"  ;  to date mu st not be  >than toda y's date
  1368    S IBTFY=$ $FY^IBOUTL (IBTDT)
  1369    ;
  1370    ;Total Ch arges
  1371    ; IB*2.0* 447/TAZ Re moved this  error so  that zero  dollar rev enue codes  can proce ss on the  837
  1372    ;I +IBTC' >0!(+IBTC' =IBTC) S I BER=IBER_" IB064;"
  1373    ;
  1374    ;Billable  charges f or seconda ry claim
  1375    I $$MCRON BIL^IBEFUN C(IBIFN)&( ($P(IBNDU1 ,U,1)-$P(I BNDU1,U,2) )'>0) S IB ER=IBER_"I B094;"
  1376    ;Fiscal Y ear 1
  1377    S IBFFY=$ $FY^IBOUTL (IBFDT)
  1378    ;
  1379    ;Check pr ovider lin k for curr ent user,  enterer, r eviewer an d Authoriz or
  1380    I '$D(^VA (200,DUZ,0 )) S IBER= IBER_"IB04 8;"
  1381    I IBEU]"" ,'$D(^VA(2 00,IBEU,0) ) S IBER=I BER_"IB048 ;"
  1382    I IBRU]"" ,'$D(^VA(2 00,IBRU,0) ) S IBER=I BER_"IB060 ;"
  1383    I IBAU]"" ,'$D(^VA(2 00,IBAU,0) ) S IBER=I BER_"IB041 ;"
  1384    ;
  1385    I IBER="" ,+$$STA^PR CAFN(IBIFN )=104 S IB ER=IBER_"I B040;"
  1386    ; If ins  bill, must  have vali d COB sequ ence
  1387    I $P(IBND 0,U,11)="i ",$S($P(IB ND0,U,21)= "":1,1:"PS T"'[$P(IBN D0,U,21))  S IBER=IBE R_"IB324;"
  1388    ;
  1389    ; Check f or valid s ec provide r id for c urrent ins
  1390    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"PRV",Z )) Q:'Z  S  Z0=$G(^(Z ,0)),Z1=+$ $COBN^IBCE F(IBIFN) I  $P(Z0,U,4 +Z1)'="",$ P(Z0,U,11+ Z1)'="" D
  1391    . I '$$SE CIDCK^IBCE F74(IBIFN, Z1,$P(Z0,U ,11+Z1),Z)  D WARN^IB CBB11("Pro v secondar y id type  for the "_ $P("PRIMAR Y^SECONDAR Y^TERTIARY ",U,Z1)_"  "_$$EXTERN AL^DILFD(3 99.0222,.0 1,,+Z0)_"  is invalid /won't tra nsmit")
  1392    ; Check N PIs
  1393    D NPICHK^ IBCBB11
  1394    ;
  1395    ; Check m ultiple rx  NPIs
  1396    D RXNPI^I BCBB11(IBI FN)
  1397    ;
  1398    ; Check t axonomies
  1399    D TAXCHK^ IBCBB11
  1400    ;
  1401    ; Check f or Physici an Name
  1402    K IBXDATA  D F^IBCEF ("N-ATT/RE ND PHYSICI AN NAME",, ,IBIFN)
  1403    ; IB*2.0* 432 - CMS1 500 no lon ger needs  a claim le vel render ing
  1404    S IBFT=$$ FT^IBCEF(I BIFN)
  1405    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1406    I IBFT'=2 ,IBFT'=7,$ P($G(IBXDA TA),U)=""  S IBER=IBE R_"IB303;"
  1407    ;
  1408    N FUNCTIO N,IBINS
  1409    ; IB*2.0* 432 - CMS1 500 no lon ger needs  a claim le vel render ing
  1410    ;S FUNCTI ON=$S($$FT ^IBCEF(IBI FN)=3:4,1: 3)
  1411    S FUNCTIO N=$S(IBFT= 3:4,1:3)
  1412    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1413    I IBFT'=2 ,IBFT'=7,I BER'["IB30 3;" D
  1414    . F IBINS =1:1:3 D
  1415    .. S Z=$$ GETTYP^IBC EP2A(IBIFN ,IBINS)
  1416    .. I Z,$P (Z,U,2) D   ; Renderi ng/attendi ng prov se condary id  required
  1417    ... N IBI D,IBOK,Q0
  1418    ... D PRO VINF^IBCEF 74(IBIFN,I BINS,.IBID ,1,"C")  ;  check all  as though  they were  current
  1419    ... S IBO K=0
  1420    ... S Q0= 0 F  S Q0= $O(IBID(1, FUNCTION,Q 0)) Q:'Q0   I $P(IBID (1,FUNCTIO N,Q0),U,9) =+Z S IBOK =1 Q
  1421    ... I 'IB OK S IBER= IBER_$S(IB INS=1:"IB2 36;",IBINS =2:"IB237; ",IBINS=3: "IB238;",1 :"")
  1422    ;
  1423    ; Patch 4 32 enh5:Th e IB syste m shall no  longer pr event user s from aut horizing(f atal error  message)a  claim bec ause the s ystem cann ot find th e provider sSSNorEIN
  1424    ; D PRIID CHK^IBCBB1 1
  1425    ;
  1426    N IBM,IBM 1
  1427    S IBM=$G( ^DGCR(399, IBIFN,"M") )
  1428    S IBM1=$G (^DGCR(399 ,IBIFN,"M1 "))
  1429    I $P(IBM, U),$P($G(^ DIC(36,$P( IBM,U),4)) ,U,6),$P(I BM1,U,2)=" " S IBER=I BER_"IB244 ;"
  1430    I $P(IBM, U,2),$P($G (^DIC(36,$ P(IBM,U,2) ,4)),U,6), $P(IBM1,U, 3)="" S IB ER=IBER_"I B245;"
  1431    I $P(IBM, U,3),$P($G (^DIC(36,$ P(IBM,U,3) ,4)),U,6), $P(IBM1,U, 4)="" S IB ER=IBER_"I B246;"
  1432    ;
  1433    ; If outs ide facili ty, check  for ID and  qualifier  in 355.93
  1434    ; 5/15/06  - esg - h ard error  IB243 turn ed into wa rning mess age instea d
  1435    S Z=$P($G (^DGCR(399 ,IBIFN,"U2 ")),U,10)
  1436    I Z D
  1437    . I $P($G (^IBA(355. 93,Z,0)),U ,9)=""!($P ($G(^IBA(3 55.93,Z,0) ),U,13)="" ) D
  1438    .. N Z1,Z 2
  1439    .. S Z1=" Missing La b or Facil ity Primar y ID for n on-VA faci lity, "
  1440    .. S Z2=$ $EXTERNAL^ DILFD(399, 232,,Z)
  1441    .. I $L(Z 2)'>19 D W ARN^IBCBB1 1(Z1_Z2) Q
  1442    .. D WARN ^IBCBB11(Z 1),WARN^IB CBB11("      "_Z2)
  1443    .. Q
  1444    . Q
  1445    ;
  1446    ; Must be  one and o nly one di vision on  bill
  1447    S IBZ=$$M ULTDIV^IBC BB11(IBIFN ,IBND0)
  1448    ; I IBZ S  IBER=IBER _$S(IBZ=1: "IB095;",I BZ=2:"IB10 4;",1:"IB1 05;")
  1449    ; Allow m ulti-divis ional for  OP instuti onal claim s
  1450    I IBZ,$$I NPAT^IBCEF (IBIFN)!'( $$INSPRF^I BCEF(IBIFN )) S IBER= IBER_$S(IB Z=1:"IB095 ;",IBZ=2:" IB104;",1: "IB105;")
  1451    ; Still n eed error  msg on OP  Institutio nal if No  Default di vision
  1452    I IBZ=3,' $$INPAT^IB CEF(IBIFN) ,$$INSPRF^ IBCEF(IBIF N) S IBER= IBER_"IB10 5;"
  1453    ; Divisio n address  must be de fined in i nstitution  file
  1454    I $P(IBND 0,U,22) D
  1455    . N Z,Z0, Z1
  1456    . S Z0=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),0 ))
  1457    . S Z1=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),1 ))
  1458    . I $P(Z0 ,U,2)="" S  IBER=IBER _"IB097;"  Q
  1459    . F Z=1,3 ,4 I $P(Z1 ,U,Z)="" S  IBER=IBER _"IB097;"  Q
  1460    ;
  1461    ; IB*2.0* 432 Check  ambulance  addresses,  COB Non-c overed amt . & Attach ment Contr ol
  1462    I $$AMBCK ^IBCBB11(I BIFN)=1 S  IBER=IBER_ "IB329;"
  1463    I $$COBAM T^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB330;"
  1464    I $$TMCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB331;"
  1465    I $$ACCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB332;"
  1466    I $$COBMR A^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB342;"
  1467    I $$COBSE C^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB343;"
  1468    ;
  1469    ;CHAMPVA  Rate Type  and Primar y Insuranc e Carriers  Type of C overage mu st match
  1470    S (IBRTCH V,IBPICHV) =0
  1471    I $P($G(^ DGCR(399.3 ,+IBAT,0)) ,U,1)="CHA MPVA" S IB RTCHV=1
  1472    I $P($G(^ IBE(355.2, +$P($G(^DI C(36,+IBND MP,0)),U,1 3),0)),U,1 )="CHAMPVA " S IBPICH V=1
  1473    I (+IBRTC HV!+IBPICH V)&('IBRTC HV!'IBPICH V) S IBER= IBER_"IB08 5;"
  1474    ;
  1475    ;Non-VA b ill must u se FEE REI MB INS rat e type; FE E REIMB IN S rate typ e can only  be used f or Non-VA  bill
  1476    ;IB*2.0*5 54/DRF 10/ 9/2015
  1477    ;N IBNVAR T,IBNVAST
  1478    ;S (IBNVA RT,IBNVAST )=0
  1479    ;I $P($G( ^DGCR(399. 3,+IBAT,0) ),U,1)="FE E REIMB IN S" S IBNVA RT=1
  1480    ;S IBNVAS T=$$NONVAF LG(IBIFN)
  1481    ;I IBNVAR T,'IBNVAST  S IBER=IB ER_"IB360; "  ;Non-VA  rate type  used for  bill that  is not Non -VA
  1482    ;I 'IBNVA RT,IBNVAST  S IBER=IB ER_"IB361; "  ;Non-VA  rate type  not used  for bill t hat is Non -VA
  1483    ;
  1484    N IBZPRC, IBZPRCUB
  1485    D F^IBCEF ("N-ALL PR OCEDURES", "IBZPRC",, IBIFN)
  1486    ; Procedu re Clinic  is require d for Surg ical Proce dures Outp t Facility  Charges
  1487    I +$P(IBN D0,U,27)'= 2,$$BILLRA TE^IBCRU3( IBAT,IBCL, IBEVDT,"RC  OUTPATIEN T") D
  1488    . N Z,Z0, Z1,ZE S (Z E,Z)=0 F   S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z  D   I +ZE S I BER=IBER_" IB320;" Q
  1489    .. S Z0=$ G(^DGCR(39 9,IBIFN,"C P",Z,0)),Z 1=+Z0 I Z0 '[";ICPT("  Q
  1490    .. I '((Z 1'<10000)& (Z1'>69999 ))&'((Z1'< 93501)&(Z1 '>93533))  Q
  1491    .. I '$P( Z0,U,7) S  ZE=1
  1492    ;
  1493    ; Extract  procedure s for UB-0 4
  1494    D F^IBCEF ("N-UB-04  PROCEDURES ","IBZPRCU B",,IBIFN)
  1495    ; Does th is bill ha ve ANY pre scriptions  associate d with it?
  1496    ; Must bi ll prescri ptions sep arately fr om other c harges
  1497    ;
  1498    ; DEM;432  - Call li ne level p rovider ed it checks.
  1499    D LNPROV^ IBCBB12(IB IFN)  ; DE M;432 - If  there are  line prov ider edits , then rou tine LNPRO V^IBCBB12( IBIFN) upd ates IBER  string.
  1500    ; DEM;432  - Call to  Other Ope rating/Ope rating Pro vider edit  checks.
  1501    I $$OPPRO VCK^IBCBB1 2(IBIFN)=1  S IBER=IB ER_"IB337; "  ; DEM;4 32
  1502    ; DEM;432  - Line le vel Attach ment Contr ol edits.
  1503    I $$LNTMC K^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB331;"   ; DEM;432
  1504    I $$LNACC K^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB332;"   ; DEM;432
  1505    ;
  1506    ; vd/Begi nning of I B*2*577 -  Validate L ine Level  NDC edits.
  1507    I $$LNNDC CK^IBCBB11 (IBIFN)=1  S IBER=IBE R_"IB365;"   ;IB*2*57 7;JWS;11/2 0/17 FIX
  1508    ; vd/End  of IB*2*57 7
  1509    I $$ISRX^ IBCEF1(IBI FN) D
  1510    . N IBZ,I BRXDEF
  1511    . S IBRXD EF=$P($G(^ IBE(350.9, 1,1)),U,30 ),IBZ=0
  1512    . F  S IB Z=$O(IBZPR CUB(IBZ))  Q:'IBZ  I  IBZPRCUB(I BZ),+$P(IB ZPRCUB(IBZ ),U)'=IBRX DEF S IBER =IBER_"IB1 02;" Q
  1513    . K IBZ
  1514    ;
  1515    ; Check t hat COB se quences ar e not skip ped
  1516    K Z
  1517    F Z=1:1:3  S:+$G(^DG CR(399,IBI FN,"I"_Z))  Z(Z)=""
  1518    F Z=0:1:2  S Z0=$O(Z (Z)) Q:'Z0   I Z0'=(Z +1) S IBER =IBER_"IB3 22;" Q
  1519    K Z
  1520    ; HD64676   IB*2*371  - OK for  payer sequ ence to be  blank whe n the Rate
  1521    ;    Type  is either  Interagen cy or Shar ing Agreem ent
  1522    I $P($G(^ DGCR(399,I BIFN,0)),U ,21)="",$P ($G(^DGCR( 399,IBIFN, 0)),U,7)'= 4,$P($G(^D GCR(399,IB IFN,0)),U, 7)'=9 S IB ER=IBER_"I B323;"
  1523    K IBXDATA  D F^IBCEF ("N-PROCED URE CODING  METHD",,, IBIFN)
  1524    ; Coding  method sho uld agree  with types  of proced ure codes
  1525    S IBOK=$S ('$O(IBZPR C(0))!(IBX DATA=""):1 ,1:0)
  1526    I 'IBOK S  IBOK=1,IB Z=0 F  S I BZ=$O(IBZP RC(IBZ)) Q :'IBZ  I I BZPRC(IBZ) ,$P(IBZPRC (IBZ),U)'[ $S(IBXDATA =9:"ICD",1 :"ICP") S  IBOK=0 Q
  1527    I 'IBOK D  WARN^IBCB B11("Codin g Method d oes not ag ree with a ll procedu re codes f ound on bi ll")
  1528    D EDITMRA ^IBCBB3(.I BQUIT,.IBE R,IBIFN,IB FT)
  1529    Q:$G(IBQU IT)
  1530    ;
  1531    ;Other th ings that  could be a dded:  Rev  Code - ca lculating  charges
  1532    ;         Diagnosis  Coding, if  MT copay  - check fo r other co -payments
  1533    ;
  1534    I $P(IBND TX,U,8),$$ REQMRA^IBE FUNC(IBIFN ) S IBER=I BER_"IB121 ;"   ; can 't force M RAs to pri nt
  1535    I $P(IBND TX,U,8)!$P (IBNDTX,U, 9) D
  1536    . Q:$P(IB NDTX,U,8)= 2    ; Don 't want to  do this f or option  2 any more .
  1537    . D WARN^ IBCBB11($S ($$REQMRA^ IBEFUNC(IB IFN)&($P(I BNDTX,U,9) ):"MRA Sec ondary ",1 :"")_"Bill  has been  forced to  print "_$S ($P(IBNDTX ,U,8)=1!($ P(IBNDTX,U ,9)=1):"lo cally",1:" at clearin ghouse"))
  1538    N IBXZ,IB IZ F IBIZ= 12,13,14 S  IBXZ=$P(I BNDM,U,IBI Z) I +IBXZ  S IBXZ=$P ($G(^DPT(D FN,.312,IB XZ,0)),U,1 8) I +IBXZ  S IBXZ=$G (^IBA(355. 3,+IBXZ,0) ) I +$P(IB XZ,U,12) D
  1539    . D WARN^ IBCBB11($P ($G(^DIC(3 6,+IBXZ,0) ),U,1)_" r equires Am b Care Cer tification ")
  1540    ;
  1541    D VALNDC^ IBCBB11(IB IFN,DFN)   ;validate  NDC#
  1542    ;
  1543    ;Build AR  array if  no errors  and MRA no t needed o r already  rec'd
  1544    I IBER="" ,$S($$NEED MRA^IBEFUN C(IBIFN)!( $$REQMRA^I BEFUNC(IBI FN)):0,1:1 ) D ARRAY
  1545    ;
  1546    ;Check RO I
  1547    N ROIERR
  1548    S ROIERR= 0 I $P($G( ^DGCR(399, IBIFN,"U") ),U,5)=1,+ $P($G(^DGC R(399,IBIF N,"U")),U, 7)=0 S ROI ERR=1 ; sc reen 7 sen sitive rec ord and no  ROI
  1549    I $$ROICH K^IBCBB11( IBIFN,DFN, +IBNDMP) S  ROIERR=1  ; check fi le for sen sitive Rx  and missin g ROI
  1550    I ROIERR  S IBER=IBE R_"IB328;"
  1551    ;
  1552    ;Verify L ine Charge s Match Cl aim Total  Charge. IB *2.0*447 B I
  1553    I +$$GET1 ^DIQ(399,I BIFN_",",2 01)'=+$$IB LNTOT^IBCB B13(IBIFN)  S IBER=IB ER_"IB344; "
  1554    ;
  1555    ;Test for  valid EIN /SY ID Val ues. IB*2. 0*447 BI
  1556    I $$IBSYE I^IBCBB13( IBIFN) S I BER=IBER_" IB345;"
  1557    ;
  1558    ;Test for  a missing  ICN. IB*2 .0*447 BI
  1559    I $$IBMIC N^IBCBB13( IBIFN) S I BER=IBER_" IB346;"
  1560    ;
  1561    ;Test for  a ZERO ch arge amoun ts. IB*2.0 *447 BI
  1562    I $$IBRCC HK^IBCBB13 (IBIFN) D  WARN^IBCBB 11("Claim  contains r evenue cod es with no  associate d charges. ")
  1563    ;
  1564    ;Test for  missing " Patient re ason for v isit". IB* 2.0*447 BI
  1565    I $$FT^IB CEF(IBIFN) =3,'$$INPA T^IBCEF(IB IFN),$$IBP RV3^IBCBB1 3(IBIFN) S  IBER=IBER _"IB347;"
  1566    ;
  1567    ;Test for  missing P ayer ID. I B*2.0*447  BI
  1568    ;I $$IBMP ID^IBCBB13 (IBIFN) S  IBER=IBER_ "IB348;"
  1569    ;Changed  Error to W arning. IB *2.0*447 T AZ
  1570    I $$IBMPI D^IBCBB13( IBIFN) D W ARN^IBCBB1 1("Not all  payers ha ve Payer I Ds.")
  1571    ;
  1572    ;Test for  missing " Priority ( Type) of A dmission"  for UB-04.  IB*2.0*44 7 BI
  1573    I $$FT^IB CEF(IBIFN) =3,$$GET1^ DIQ(399,IB IFN_",",15 8)="" S IB ER=IBER_"I B349;"
  1574    ;
  1575   END ;Don't  kill IBIF N, IBER, D FN
  1576    I $O(^TMP ($J,"BILL- WARN",0)), $G(IBER)=" " S IBER=" WARN" ;War nings only
  1577    K IBBNO,I BEVDT,IBLO C,IBCL,IBT F,IBAT,IBW HO,IBST,IB FDT,IBTDT, IBTC,IBFY, IBFY1,IBAU ,IBRU,IBEU ,IBARTP,IB FYC,IBMRA, IBTOB,IBTO B12,IBNDU2 ,IBNDUF3,I BNDUF31,IB NDTX
  1578    K IBNDS,I BND0,IBNDU ,IBNDM,IBN DMP,IBNDU1 ,IBFFY,IBT FY,IBFT,IB RTCHV,IBPI CHV,IBXDAT A,IBOK
  1579    I $D(IBER ),IBER=""  W !,"No Er rors found  for Natio nal edits"
  1580    Q
  1581    ;
  1582   ARRAY ;Bui ld PRCASV( array)
  1583    N IBCOBN, X
  1584    K PRCASV
  1585    Q:$$MCRWN R^IBEFUNC( +$$CURR^IB CEF2(IBIFN ))
  1586    S IBCOBN= $$COBN^IBC EF(IBIFN)
  1587    S X=IBIFN
  1588    S PRCASV( "BDT")=DT, PRCASV("AR REC")=IBIF N
  1589    S PRCASV( "APR")=DUZ
  1590    S PRCASV( "PAT")=DFN ,PRCASV("C AT")=$P(^D GCR(399.3, IBAT,0),"^ ",6)
  1591    I IBWHO=" i" S PRCAS V("DEBTOR" )=+IBNDMP_ ";DIC(36,"
  1592    S PRCASV( "DEBTOR")= $S(IBWHO=" p":DFN_";D PT(",IBWHO ="o":$P(IB NDM,"^",11 )_";DIC(4, ",IBWHO="i ":PRCASV(" DEBTOR"),1 :"")
  1593    S PRCASV( "CARE")=$E ($$TOB^IBC EF1(IBIFN) ,1,2)
  1594    S PRCASV( "FY")=$$FY ^IBOUTL(DT )_U_($P(IB NDU1,U)-$P (IBNDU1,U, 2))
  1595    ;S PRCASV ("FY")=$P( IBNDU1,U,9 )_U_$S($P( IBNDU1,U,2 )]"":($P(I BNDU1,U,10 )-$P(IBNDU 1,U,2)),1: $P(IBNDU1, U,10))_$S( $P(IBNDU1, U,11)]"":U _$P(IBNDU1 ,U,11)_U_$ P(IBNDU1,U ,12),1:"")
  1596   PLUS I IBW HO="i",$P( IBNDM,"^", 2),$D(^DIC (36,$P(IBN DM,"^",2), 0)) S PRCA SV("2NDINS ")=$P(IBND M,"^",2)
  1597    I IBWHO=" i",$P(IBND M,"^",3),$ D(^DIC(36, $P(IBNDM," ^",3),0))  S PRCASV(" 3RDINS")=$ P(IBNDM,"^ ",3)
  1598    ;
  1599    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=""
  1600    N IBNDI1
  1601    Q:'$D(^DG CR(399,IBI FN,IBX))   S IBNDI1=^ (IBX)
  1602    S:$P(IBND I1,"^",3)] "" PRCASV( "GPNO")=$P (IBNDI1,"^ ",3)
  1603    S:$P(IBND I1,"^",15) ]"" PRCASV ("GPNM")=$ P(IBNDI1," ^",15)
  1604    S:$P(IBND I1,"^",17) ]"" PRCASV ("INPA")=$ P(IBNDI1," ^",17)
  1605    S:$P(IBND I1,"^",2)] "" PRCASV( "IDNO")=$P (IBNDI1,"^ ",2),PRCAS V("INID")= PRCASV("ID NO")
  1606    ; Check t hat this i s a second ary or ter tiary bill  and insur ance for p revious
  1607    ; COB seq uence is M edicare WN R and MRA  is active  --> send d ata elemen ts to AR
  1608    I IBCOBN> 1,$$WNRBIL L^IBEFUNC( IBIFN,IBCO BN-1),$$ED IACTV^IBCE F4(2) D MR A
  1609    Q
  1610    ;
  1611   MRA N IBEO B S IBEOB= 0
  1612    ;
  1613    K PRCASV( "MEDURE"), PRCASV("ME DCA")
  1614    ; Get EOB  data
  1615    F  S IBEO B=$O(^IBM( 361.1,"B", IBIFN,IBEO B)) Q:'IBE OB  D
  1616    . D MRACA LC^IBCEMU2 (IBEOB,IBI FN,1,.PRCA SV)
  1617    Q  ;MRA
  1618    ;
  1619    ;; PREGNA NCY DX COD ES: V22**- V24**, V27 **-V28**,  630**-677* *
  1620    ;; FLU SH OTS PROCED URE CODES:  90724, G0 008, 90732 , G0009
  1621    ;
  1622   NONVAFLG(I BIFN) ; Ch eck if Non -VA bill
  1623    ; Functio n returns  1 if Non-V A bill
  1624    ; IB*2.0* 554/DRF 10 /9/2015
  1625    N FLAG,PT F
  1626    S FLAG=0
  1627    I $P($G(^ DGCR(399,I BIFN,"U2") ),U,10)]""  S FLAG=1  ;Non-VA pr ovider def ined
  1628    S PTF=$P( $G(^DGCR(3 99,IBIFN,0 )),U,8)
  1629    I PTF,$P( $G(^DGPT(P TF,0)),U,4 )=1 S FLAG =1 ;PTF en try indica tes Non-VA
  1630    Q FLAG
  1631   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  1632   IBCBB1 ;AL B/AAS - CO NTINUATION  OF EDIT C HECK ROUTI NE ;2-NOV- 89
  1633    ;;2.0;INT EGRATED BI LLING;**27 ,52,80,93, 106,51,151 ,148,153,1 37,232,280 ,155,320,3 43,349,363 ,371,395,3 84,432,447 ,488,554,5 77,592,608 **;21-MAR- 94;Build 2 1
  1634    ;Per VA D irective 6 402, this  routine sh ould not b e modified .
  1635    ;
  1636    ; *** Beg in IB*2.0* 488 VD  (I ssue 46 RB N)
  1637    N I
  1638    S I=""
  1639    S X=+$G(^ DGCR(399,I BIFN,"MP") )
  1640    I 'X,$$MC RWNR^IBEFU NC(+$$CURR ^IBCEF2(IB IFN)) S X= +$$CURR^IB CEF2(IBIFN )
  1641    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1642    I X,+$G(^ DIC(36,X,3 )) S I=$P( ^(3),U,$S( $$FT^IBCEF (IBIFN)=2: 2,$$FT^IBC EF(IBIFN)= 7:2,1:4))
  1643    S I=$$UP^ XLFSTR(I)
  1644    I (I'=""& (I["PRNT") &($G(IBER) '["IB488") ) D 
  1645    . S IBER= $G(IBER)_" IB488;"
  1646    ;
  1647    ; Cause a n error if  FORCED TO  PRINT TO  CLEARINGHO USE
  1648    I $P($G(^ DGCR(399,I BIFN,"TX") ),U,8)=2 D
  1649    . S IBER= $G(IBER)_" IB489;"
  1650    ;
  1651    ; Cause a  fatal err or if the  claim has  no procedu res & is N OT a UB-04  Inpatient  claim.
  1652    I +$O(^DG CR(399,IBI FN,"CP",0) )=0 D
  1653    .I $$INPA T^IBCEF(IB IFN,1),$$I NSPRF^IBCE F(IBIFN) Q    ; inpat ient UB-04  check
  1654    .I '$$INP AT^IBCEF(I BIFN,1),$$ INSPRF^IBC EF(IBIFN)  D  Q       ; Outpatie nt Institu tional Cla im.
  1655    ..I IBER[ "IB352" Q
  1656    ..S IBER= IBER_"IB35 2;"
  1657    .;
  1658    .; Profes sional cla im
  1659    .I IBER[" IB353" Q
  1660    .S IBER=I BER_"IB353 ;"
  1661    .Q
  1662    ; *** End  IB*2.0*48 8 -- VD
  1663    ;
  1664    ;MAP TO D GCRBB1
  1665    ;
  1666   % ;Bill St atus
  1667    N Z,Z0,Z1 ,IBFT
  1668    I $S(+IBS T=0:1,1:"^ 1^2^3^4^7^ "'[(U_IBST _U)) S IBE R=IBER_"IB 045;"
  1669    ;
  1670    ;Statemen t Covers F rom
  1671    I IBFDT=" " S IBER=I BER_"IB061 ;"
  1672    I IBFDT]" ",IBFDT'?7 N&(IBFDT'? 7N1".".N)  S IBER=IBE R_"IB061;"
  1673    I IBFDT>I BTDT S IBE R=IBER_"IB 061;" ; fr om must be  on or bef ore the to  date 
  1674    S IBFFY=$ $FY^IBOUTL (IBFDT)
  1675    ; if inpa t - from d ate must n ot be prio r to admit  date.
  1676    I $$INPAT ^IBCEF(IBI FN,1),(IBF DT<($P($G( ^DGPT(+$P( IBND0,U,8) ,0)),U,2)\ 1))  S IBE R=IBER_"IB 061;"
  1677    ;
  1678    ;Statemen t Covers T o
  1679    I IBTDT=" " S IBER=I BER_"IB062 ;"
  1680    I IBTDT]" ",IBTDT'?7 N&(IBTDT'? 7N1".".N)  S IBER=IBE R_"IB062;"
  1681    I IBTDT>D T!(IBTDT<I BFDT) S IB ER=IBER_"I B062;"  ;  to date mu st not be  >than toda y's date
  1682    S IBTFY=$ $FY^IBOUTL (IBTDT)
  1683    ;
  1684    ;Total Ch arges
  1685    ; IB*2.0* 447/TAZ Re moved this  error so  that zero  dollar rev enue codes  can proce ss on the  837
  1686    ;I +IBTC' >0!(+IBTC' =IBTC) S I BER=IBER_" IB064;"
  1687    ;
  1688    ;Billable  charges f or seconda ry claim
  1689    I $$MCRON BIL^IBEFUN C(IBIFN)&( ($P(IBNDU1 ,U,1)-$P(I BNDU1,U,2) )'>0) S IB ER=IBER_"I B094;"
  1690    ;Fiscal Y ear 1
  1691    S IBFFY=$ $FY^IBOUTL (IBFDT)
  1692    ;
  1693    ;Check pr ovider lin k for curr ent user,  enterer, r eviewer an d Authoriz or
  1694    I '$D(^VA (200,DUZ,0 )) S IBER= IBER_"IB04 8;"
  1695    I IBEU]"" ,'$D(^VA(2 00,IBEU,0) ) S IBER=I BER_"IB048 ;"
  1696    I IBRU]"" ,'$D(^VA(2 00,IBRU,0) ) S IBER=I BER_"IB060 ;"
  1697    I IBAU]"" ,'$D(^VA(2 00,IBAU,0) ) S IBER=I BER_"IB041 ;"
  1698    ;
  1699    I IBER="" ,+$$STA^PR CAFN(IBIFN )=104 S IB ER=IBER_"I B040;"
  1700    ; If ins  bill, must  have vali d COB sequ ence
  1701    I $P(IBND 0,U,11)="i ",$S($P(IB ND0,U,21)= "":1,1:"PS T"'[$P(IBN D0,U,21))  S IBER=IBE R_"IB324;"
  1702    ;
  1703    ; Check f or valid s ec provide r id for c urrent ins
  1704    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"PRV",Z )) Q:'Z  S  Z0=$G(^(Z ,0)),Z1=+$ $COBN^IBCE F(IBIFN) I  $P(Z0,U,4 +Z1)'="",$ P(Z0,U,11+ Z1)'="" D
  1705    . I '$$SE CIDCK^IBCE F74(IBIFN, Z1,$P(Z0,U ,11+Z1),Z)  D WARN^IB CBB11("Pro v secondar y id type  for the "_ $P("PRIMAR Y^SECONDAR Y^TERTIARY ",U,Z1)_"  "_$$EXTERN AL^DILFD(3 99.0222,.0 1,,+Z0)_"  is invalid /won't tra nsmit")
  1706    ; Check N PIs
  1707    D NPICHK^ IBCBB11
  1708    ;
  1709    ; Check m ultiple rx  NPIs
  1710    D RXNPI^I BCBB11(IBI FN)
  1711    ;
  1712    ; Check t axonomies
  1713    D TAXCHK^ IBCBB11
  1714    ;
  1715    ; Check f or Physici an Name
  1716    K IBXDATA  D F^IBCEF ("N-ATT/RE ND PHYSICI AN NAME",, ,IBIFN)
  1717    ; IB*2.0* 432 - CMS1 500 no lon ger needs  a claim le vel render ing
  1718    S IBFT=$$ FT^IBCEF(I BIFN)
  1719    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1720    I IBFT'=2 ,IBFT'=7,$ P($G(IBXDA TA),U)=""  S IBER=IBE R_"IB303;"
  1721    ;
  1722    N FUNCTIO N,IBINS
  1723    ; IB*2.0* 432 - CMS1 500 no lon ger needs  a claim le vel render ing
  1724    ;S FUNCTI ON=$S($$FT ^IBCEF(IBI FN)=3:4,1: 3)
  1725    S FUNCTIO N=$S(IBFT= 3:4,1:3)
  1726    ;JWS;IB*2 .0*592:US1 108 - Dent al form ch eck
  1727    I IBFT'=2 ,IBFT'=7,I BER'["IB30 3;" D
  1728    . F IBINS =1:1:3 D
  1729    .. S Z=$$ GETTYP^IBC EP2A(IBIFN ,IBINS)
  1730    .. I Z,$P (Z,U,2) D   ; Renderi ng/attendi ng prov se condary id  required
  1731    ... N IBI D,IBOK,Q0
  1732    ... D PRO VINF^IBCEF 74(IBIFN,I BINS,.IBID ,1,"C")  ;  check all  as though  they were  current
  1733    ... S IBO K=0
  1734    ... S Q0= 0 F  S Q0= $O(IBID(1, FUNCTION,Q 0)) Q:'Q0   I $P(IBID (1,FUNCTIO N,Q0),U,9) =+Z S IBOK =1 Q
  1735    ... I 'IB OK S IBER= IBER_$S(IB INS=1:"IB2 36;",IBINS =2:"IB237; ",IBINS=3: "IB238;",1 :"")
  1736    ;
  1737    ; Patch 4 32 enh5:Th e IB syste m shall no  longer pr event user s from aut horizing(f atal error  message)a  claim bec ause the s ystem cann ot find th e provider sSSNorEIN
  1738    ; D PRIID CHK^IBCBB1 1
  1739    ;
  1740    N IBM,IBM 1
  1741    S IBM=$G( ^DGCR(399, IBIFN,"M") )
  1742    S IBM1=$G (^DGCR(399 ,IBIFN,"M1 "))
  1743    I $P(IBM, U),$P($G(^ DIC(36,$P( IBM,U),4)) ,U,6),$P(I BM1,U,2)=" " S IBER=I BER_"IB244 ;"
  1744    I $P(IBM, U,2),$P($G (^DIC(36,$ P(IBM,U,2) ,4)),U,6), $P(IBM1,U, 3)="" S IB ER=IBER_"I B245;"
  1745    I $P(IBM, U,3),$P($G (^DIC(36,$ P(IBM,U,3) ,4)),U,6), $P(IBM1,U, 4)="" S IB ER=IBER_"I B246;"
  1746    ;
  1747    ; If outs ide facili ty, check  for ID and  qualifier  in 355.93
  1748    ; 5/15/06  - esg - h ard error  IB243 turn ed into wa rning mess age instea d
  1749    S Z=$P($G (^DGCR(399 ,IBIFN,"U2 ")),U,10)
  1750    I Z D
  1751    . I $P($G (^IBA(355. 93,Z,0)),U ,9)=""!($P ($G(^IBA(3 55.93,Z,0) ),U,13)="" ) D
  1752    .. N Z1,Z 2
  1753    .. S Z1=" Missing La b or Facil ity Primar y ID for n on-VA faci lity, "
  1754    .. S Z2=$ $EXTERNAL^ DILFD(399, 232,,Z)
  1755    .. I $L(Z 2)'>19 D W ARN^IBCBB1 1(Z1_Z2) Q
  1756    .. D WARN ^IBCBB11(Z 1),WARN^IB CBB11("      "_Z2)
  1757    .. Q
  1758    . Q
  1759    ;
  1760    ; Must be  one and o nly one di vision on  bill
  1761    S IBZ=$$M ULTDIV^IBC BB11(IBIFN ,IBND0)
  1762    ; I IBZ S  IBER=IBER _$S(IBZ=1: "IB095;",I BZ=2:"IB10 4;",1:"IB1 05;")
  1763    ; Allow m ulti-divis ional for  OP instuti onal claim s
  1764    I IBZ,$$I NPAT^IBCEF (IBIFN)!'( $$INSPRF^I BCEF(IBIFN )) S IBER= IBER_$S(IB Z=1:"IB095 ;",IBZ=2:" IB104;",1: "IB105;")
  1765    ; Still n eed error  msg on OP  Institutio nal if No  Default di vision
  1766    I IBZ=3,' $$INPAT^IB CEF(IBIFN) ,$$INSPRF^ IBCEF(IBIF N) S IBER= IBER_"IB10 5;"
  1767    ; Divisio n address  must be de fined in i nstitution  file
  1768    I $P(IBND 0,U,22) D
  1769    . N Z,Z0, Z1
  1770    . S Z0=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),0 ))
  1771    . S Z1=$G (^DIC(4,+$ P($G(^DG(4 0.8,+$P(IB ND0,U,22), 0)),U,7),1 ))
  1772    . I $P(Z0 ,U,2)="" S  IBER=IBER _"IB097;"  Q
  1773    . F Z=1,3 ,4 I $P(Z1 ,U,Z)="" S  IBER=IBER _"IB097;"  Q
  1774    ;
  1775    ; IB*2.0* 432 Check  ambulance  addresses,  COB Non-c overed amt . & Attach ment Contr ol
  1776    I $$AMBCK ^IBCBB11(I BIFN)=1 S  IBER=IBER_ "IB329;"
  1777    I $$COBAM T^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB330;"
  1778    I $$TMCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB331;"
  1779    I $$ACCK^ IBCBB11(IB IFN)=1 S I BER=IBER_" IB332;"
  1780    I $$COBMR A^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB342;"
  1781    I $$COBSE C^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB343;"
  1782    ;
  1783    ;CHAMPVA  Rate Type  and Primar y Insuranc e Carriers  Type of C overage mu st match
  1784    S (IBRTCH V,IBPICHV) =0
  1785    I $P($G(^ DGCR(399.3 ,+IBAT,0)) ,U,1)="CHA MPVA" S IB RTCHV=1
  1786    I $P($G(^ IBE(355.2, +$P($G(^DI C(36,+IBND MP,0)),U,1 3),0)),U,1 )="CHAMPVA " S IBPICH V=1
  1787    I (+IBRTC HV!+IBPICH V)&('IBRTC HV!'IBPICH V) S IBER= IBER_"IB08 5;"
  1788    ;
  1789    ;Non-VA b ill must u se FEE REI MB INS rat e type; FE E REIMB IN S rate typ e can only  be used f or Non-VA  bill
  1790    ;IB*2.0*5 54/DRF 10/ 9/2015
  1791    ;N IBNVAR T,IBNVAST
  1792    ;S (IBNVA RT,IBNVAST )=0
  1793    ;I $P($G( ^DGCR(399. 3,+IBAT,0) ),U,1)="FE E REIMB IN S" S IBNVA RT=1
  1794    ;S IBNVAS T=$$NONVAF LG(IBIFN)
  1795    ;I IBNVAR T,'IBNVAST  S IBER=IB ER_"IB360; "  ;Non-VA  rate type  used for  bill that  is not Non -VA
  1796    ;I 'IBNVA RT,IBNVAST  S IBER=IB ER_"IB361; "  ;Non-VA  rate type  not used  for bill t hat is Non -VA
  1797    ;
  1798    N IBZPRC, IBZPRCUB
  1799    D F^IBCEF ("N-ALL PR OCEDURES", "IBZPRC",, IBIFN)
  1800    ; Procedu re Clinic  is require d for Surg ical Proce dures Outp t Facility  Charges
  1801    I +$P(IBN D0,U,27)'= 2,$$BILLRA TE^IBCRU3( IBAT,IBCL, IBEVDT,"RC  OUTPATIEN T") D
  1802    . N Z,Z0, Z1,ZE S (Z E,Z)=0 F   S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z  D   I +ZE S I BER=IBER_" IB320;" Q
  1803    .. S Z0=$ G(^DGCR(39 9,IBIFN,"C P",Z,0)),Z 1=+Z0 I Z0 '[";ICPT("  Q
  1804    .. I '((Z 1'<10000)& (Z1'>69999 ))&'((Z1'< 93501)&(Z1 '>93533))  Q
  1805    .. I '$P( Z0,U,7) S  ZE=1
  1806    ;
  1807    ; Extract  procedure s for UB-0 4
  1808    D F^IBCEF ("N-UB-04  PROCEDURES ","IBZPRCU B",,IBIFN)
  1809    ; Does th is bill ha ve ANY pre scriptions  associate d with it?
  1810    ; Must bi ll prescri ptions sep arately fr om other c harges
  1811    ;
  1812    ; DEM;432  - Call li ne level p rovider ed it checks.
  1813    D LNPROV^ IBCBB12(IB IFN)  ; DE M;432 - If  there are  line prov ider edits , then rou tine LNPRO V^IBCBB12( IBIFN) upd ates IBER  string.
  1814    ; DEM;432  - Call to  Other Ope rating/Ope rating Pro vider edit  checks.
  1815    I $$OPPRO VCK^IBCBB1 2(IBIFN)=1  S IBER=IB ER_"IB337; "  ; DEM;4 32
  1816    ; DEM;432  - Line le vel Attach ment Contr ol edits.
  1817    I $$LNTMC K^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB331;"   ; DEM;432
  1818    I $$LNACC K^IBCBB11( IBIFN)=1 S  IBER=IBER _"IB332;"   ; DEM;432
  1819    ;
  1820    ; vd/Begi nning of I B*2*577 -  Validate L ine Level  NDC edits.
  1821    I $$LNNDC CK^IBCBB11 (IBIFN)=1  S IBER=IBE R_"IB360;"   ;IB*2*57 7
  1822    ; vd/End  of IB*2*57 7
  1823    I $$ISRX^ IBCEF1(IBI FN) D
  1824    . N IBZ,I BRXDEF
  1825    . S IBRXD EF=$P($G(^ IBE(350.9, 1,1)),U,30 ),IBZ=0
  1826    . F  S IB Z=$O(IBZPR CUB(IBZ))  Q:'IBZ  I  IBZPRCUB(I BZ),+$P(IB ZPRCUB(IBZ ),U)'=IBRX DEF S IBER =IBER_"IB1 02;" Q
  1827    . K IBZ
  1828    ;
  1829    ; Check t hat COB se quences ar e not skip ped
  1830    K Z
  1831    F Z=1:1:3  S:+$G(^DG CR(399,IBI FN,"I"_Z))  Z(Z)=""
  1832    F Z=0:1:2  S Z0=$O(Z (Z)) Q:'Z0   I Z0'=(Z +1) S IBER =IBER_"IB3 22;" Q
  1833    K Z
  1834    ; HD64676   IB*2*371  - OK for  payer sequ ence to be  blank whe n the Rate
  1835    ;    Type  is either  Interagen cy or Shar ing Agreem ent
  1836    I $P($G(^ DGCR(399,I BIFN,0)),U ,21)="",$P ($G(^DGCR( 399,IBIFN, 0)),U,7)'= 4,$P($G(^D GCR(399,IB IFN,0)),U, 7)'=9 S IB ER=IBER_"I B323;"
  1837    K IBXDATA  D F^IBCEF ("N-PROCED URE CODING  METHD",,, IBIFN)
  1838    ; Coding  method sho uld agree  with types  of proced ure codes
  1839    S IBOK=$S ('$O(IBZPR C(0))!(IBX DATA=""):1 ,1:0)
  1840    I 'IBOK S  IBOK=1,IB Z=0 F  S I BZ=$O(IBZP RC(IBZ)) Q :'IBZ  I I BZPRC(IBZ) ,$P(IBZPRC (IBZ),U)'[ $S(IBXDATA =9:"ICD",1 :"ICP") S  IBOK=0 Q
  1841    I 'IBOK D  WARN^IBCB B11("Codin g Method d oes not ag ree with a ll procedu re codes f ound on bi ll")
  1842    D EDITMRA ^IBCBB3(.I BQUIT,.IBE R,IBIFN,IB FT)
  1843    Q:$G(IBQU IT)
  1844    ;
  1845    ;Other th ings that  could be a dded:  Rev  Code - ca lculating  charges
  1846    ;         Diagnosis  Coding, if  MT copay  - check fo r other co -payments
  1847    ;
  1848    I $P(IBND TX,U,8),$$ REQMRA^IBE FUNC(IBIFN ) S IBER=I BER_"IB121 ;"   ; can 't force M RAs to pri nt
  1849    I $P(IBND TX,U,8)!$P (IBNDTX,U, 9) D
  1850    . Q:$P(IB NDTX,U,8)= 2    ; Don 't want to  do this f or option  2 any more .
  1851    . D WARN^ IBCBB11($S ($$REQMRA^ IBEFUNC(IB IFN)&($P(I BNDTX,U,9) ):"MRA Sec ondary ",1 :"")_"Bill  has been  forced to  print "_$S ($P(IBNDTX ,U,8)=1!($ P(IBNDTX,U ,9)=1):"lo cally",1:" at clearin ghouse"))
  1852    N IBXZ,IB IZ F IBIZ= 12,13,14 S  IBXZ=$P(I BNDM,U,IBI Z) I +IBXZ  S IBXZ=$P ($G(^DPT(D FN,.312,IB XZ,0)),U,1 8) I +IBXZ  S IBXZ=$G (^IBA(355. 3,+IBXZ,0) ) I +$P(IB XZ,U,12) D
  1853    . D WARN^ IBCBB11($P ($G(^DIC(3 6,+IBXZ,0) ),U,1)_" r equires Am b Care Cer tification ")
  1854    ;
  1855    D VALNDC^ IBCBB11(IB IFN,DFN)   ;validate  NDC#
  1856    ;
  1857    ;Build AR  array if  no errors  and MRA no t needed o r already  rec'd
  1858    I IBER="" ,$S($$NEED MRA^IBEFUN C(IBIFN)!( $$REQMRA^I BEFUNC(IBI FN)):0,1:1 ) D ARRAY
  1859    ;
  1860    ;Check RO I
  1861    N ROIERR
  1862    S ROIERR= 0 I $P($G( ^DGCR(399, IBIFN,"U") ),U,5)=1,+ $P($G(^DGC R(399,IBIF N,"U")),U, 7)=0 S ROI ERR=1 ; sc reen 7 sen sitive rec ord and no  ROI
  1863    I $$ROICH K^IBCBB11( IBIFN,DFN, +IBNDMP) S  ROIERR=1  ; check fi le for sen sitive Rx  and missin g ROI
  1864    I ROIERR  S IBER=IBE R_"IB328;"
  1865    ;
  1866    ;Verify L ine Charge s Match Cl aim Total  Charge. IB *2.0*447 B I
  1867    I +$$GET1 ^DIQ(399,I BIFN_",",2 01)'=+$$IB LNTOT^IBCB B13(IBIFN)  S IBER=IB ER_"IB344; "
  1868    ;
  1869    ;Test for  valid EIN /SY ID Val ues. IB*2. 0*447 BI
  1870    I $$IBSYE I^IBCBB13( IBIFN) S I BER=IBER_" IB345;"
  1871    ;
  1872    ;Test for  a missing  ICN. IB*2 .0*447 BI
  1873    I $$IBMIC N^IBCBB13( IBIFN) S I BER=IBER_" IB346;"
  1874    ;
  1875    ;Test for  a ZERO ch arge amoun ts. IB*2.0 *447 BI
  1876    I $$IBRCC HK^IBCBB13 (IBIFN) D  WARN^IBCBB 11("Claim  contains r evenue cod es with no  associate d charges. ")
  1877    ;
  1878    ;Test for  missing " Patient re ason for v isit". IB* 2.0*447 BI
  1879    I $$FT^IB CEF(IBIFN) =3,'$$INPA T^IBCEF(IB IFN),$$IBP RV3^IBCBB1 3(IBIFN) S  IBER=IBER _"IB347;"
  1880    ;
  1881    ;Test for  missing P ayer ID. I B*2.0*447  BI
  1882    ;I $$IBMP ID^IBCBB13 (IBIFN) S  IBER=IBER_ "IB348;"
  1883    ;Changed  Error to W arning. IB *2.0*447 T AZ
  1884    I $$IBMPI D^IBCBB13( IBIFN) D W ARN^IBCBB1 1("Not all  payers ha ve Payer I Ds.")
  1885    ;
  1886    ;Test for  missing " Priority ( Type) of A dmission"  for UB-04.  IB*2.0*44 7 BI
  1887    I $$FT^IB CEF(IBIFN) =3,$$GET1^ DIQ(399,IB IFN_",",15 8)="" S IB ER=IBER_"I B349;"
  1888    ;
  1889    I $$FT^IB CEF(IBIFN) =2 S IBER= IBER_$$CMN CHK^IBCBB1 3(IBIFN)   ;JRA;IB*2. 0*608 Chec k for miss ing CMN in fo
  1890    ;
  1891   END ;Don't  kill IBIF N, IBER, D FN
  1892    I $O(^TMP ($J,"BILL- WARN",0)), $G(IBER)=" " S IBER=" WARN" ;War nings only
  1893    K IBBNO,I BEVDT,IBLO C,IBCL,IBT F,IBAT,IBW HO,IBST,IB FDT,IBTDT, IBTC,IBFY, IBFY1,IBAU ,IBRU,IBEU ,IBARTP,IB FYC,IBMRA, IBTOB,IBTO B12,IBNDU2 ,IBNDUF3,I BNDUF31,IB NDTX
  1894    K IBNDS,I BND0,IBNDU ,IBNDM,IBN DMP,IBNDU1 ,IBFFY,IBT FY,IBFT,IB RTCHV,IBPI CHV,IBXDAT A,IBOK
  1895    I $D(IBER ),IBER=""  W !,"No Er rors found  for Natio nal edits"
  1896    Q
  1897    ;
  1898   ARRAY ;Bui ld PRCASV( array)
  1899    N IBCOBN, X
  1900    K PRCASV
  1901    Q:$$MCRWN R^IBEFUNC( +$$CURR^IB CEF2(IBIFN ))
  1902    S IBCOBN= $$COBN^IBC EF(IBIFN)
  1903    S X=IBIFN
  1904    S PRCASV( "BDT")=DT, PRCASV("AR REC")=IBIF N
  1905    S PRCASV( "APR")=DUZ
  1906    S PRCASV( "PAT")=DFN ,PRCASV("C AT")=$P(^D GCR(399.3, IBAT,0),"^ ",6)
  1907    I IBWHO=" i" S PRCAS V("DEBTOR" )=+IBNDMP_ ";DIC(36,"
  1908    S PRCASV( "DEBTOR")= $S(IBWHO=" p":DFN_";D PT(",IBWHO ="o":$P(IB NDM,"^",11 )_";DIC(4, ",IBWHO="i ":PRCASV(" DEBTOR"),1 :"")
  1909    S PRCASV( "CARE")=$E ($$TOB^IBC EF1(IBIFN) ,1,2)
  1910    S PRCASV( "FY")=$$FY ^IBOUTL(DT )_U_($P(IB NDU1,U)-$P (IBNDU1,U, 2))
  1911    ;S PRCASV ("FY")=$P( IBNDU1,U,9 )_U_$S($P( IBNDU1,U,2 )]"":($P(I BNDU1,U,10 )-$P(IBNDU 1,U,2)),1: $P(IBNDU1, U,10))_$S( $P(IBNDU1, U,11)]"":U _$P(IBNDU1 ,U,11)_U_$ P(IBNDU1,U ,12),1:"")
  1912   PLUS I IBW HO="i",$P( IBNDM,"^", 2),$D(^DIC (36,$P(IBN DM,"^",2), 0)) S PRCA SV("2NDINS ")=$P(IBND M,"^",2)
  1913    I IBWHO=" i",$P(IBND M,"^",3),$ D(^DIC(36, $P(IBNDM," ^",3),0))  S PRCASV(" 3RDINS")=$ P(IBNDM,"^ ",3)
  1914    ;
  1915    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=""
  1916    N IBNDI1
  1917    Q:'$D(^DG CR(399,IBI FN,IBX))   S IBNDI1=^ (IBX)
  1918    S:$P(IBND I1,"^",3)] "" PRCASV( "GPNO")=$P (IBNDI1,"^ ",3)
  1919    S:$P(IBND I1,"^",15) ]"" PRCASV ("GPNM")=$ P(IBNDI1," ^",15)
  1920    S:$P(IBND I1,"^",17) ]"" PRCASV ("INPA")=$ P(IBNDI1," ^",17)
  1921    S:$P(IBND I1,"^",2)] "" PRCASV( "IDNO")=$P (IBNDI1,"^ ",2),PRCAS V("INID")= PRCASV("ID NO")
  1922    ; Check t hat this i s a second ary or ter tiary bill  and insur ance for p revious
  1923    ; COB seq uence is M edicare WN R and MRA  is active  --> send d ata elemen ts to AR
  1924    I IBCOBN> 1,$$WNRBIL L^IBEFUNC( IBIFN,IBCO BN-1),$$ED IACTV^IBCE F4(2) D MR A
  1925    Q
  1926    ;
  1927   MRA N IBEO B S IBEOB= 0
  1928    ;
  1929    K PRCASV( "MEDURE"), PRCASV("ME DCA")
  1930    ; Get EOB  data
  1931    F  S IBEO B=$O(^IBM( 361.1,"B", IBIFN,IBEO B)) Q:'IBE OB  D
  1932    . D MRACA LC^IBCEMU2 (IBEOB,IBI FN,1,.PRCA SV)
  1933    Q  ;MRA
  1934    ;
  1935    ;; PREGNA NCY DX COD ES: V22**- V24**, V27 **-V28**,  630**-677* *
  1936    ;; FLU SH OTS PROCED URE CODES:  90724, G0 008, 90732 , G0009
  1937    ;
  1938   NONVAFLG(I BIFN) ; Ch eck if Non -VA bill
  1939    ; Functio n returns  1 if Non-V A bill
  1940    ; IB*2.0* 554/DRF 10 /9/2015
  1941    N FLAG,PT F
  1942    S FLAG=0
  1943    I $P($G(^ DGCR(399,I BIFN,"U2") ),U,10)]""  S FLAG=1  ;Non-VA pr ovider def ined
  1944    S PTF=$P( $G(^DGCR(3 99,IBIFN,0 )),U,8)
  1945    I PTF,$P( $G(^DGPT(P TF,0)),U,4 )=1 S FLAG =1 ;PTF en try indica tes Non-VA
  1946    Q FLAG
  1947  
  1948   IBCBB13 –  Perform th e actual c hecks for  missing CM N data (ca lled by IB CBB1)
  1949   Routines
  1950   Activities
  1951   Routine Na me
  1952   IBCBB13
  1953   Enhancemen t Category
  1954    New
  1955    Modify
  1956    Delete
  1957    No Change
  1958   RTM
  1959  
  1960   Related Op tions
  1961   None
  1962   Related Ro utines
  1963   Routines “ Called By”
  1964   Routines “ Called”   
  1965  
  1966  
  1967  
  1968  
  1969   Data Dicti onary (DD)  Reference s
  1970  
  1971   Related Pr otocols
  1972   None
  1973   Related In tegration  Control Re gistration s (ICRs)
  1974   None
  1975   Data Passi ng
  1976    Input
  1977    Output Re ference
  1978    Both
  1979    Global Re ference
  1980    Local
  1981   Input Attr ibute Name  and Defin ition
  1982   Name:
  1983   Definition :
  1984   Output Att ribute Nam e and Defi nition
  1985   Name:
  1986   Definition :
  1987   Current Lo gic
  1988   IBCBB13 ;A LB/BI - PR OCEDURE AN D LINE LEV EL PROVIDE R EDITS ;5 -OCT-2011
  1989    ;;2.0;INT EGRATED BI LLING;**44 7**;21-MAR -94;Build  80
  1990    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  1991    Q
  1992    ;
  1993   IBLNTOT(IB IFN)   ; C alculate L ine total  charges.   IB*2.0*447  BI
  1994    N X,SUM S  SUM=0
  1995    S X=0 F   S X=$O(^DG CR(399,IBI FN,"RC",X) ) Q:+X=0   D
  1996    . S SUM=S UM+$P($G(^ DGCR(399,I BIFN,"RC", X,0)),"^", 4)
  1997    Q SUM
  1998    ;
  1999   IBSYEI(IBI FN)   ; Te st for val id EIN/SY  ID Values.  IB*2.0*44 7 BI
  2000    N X12CODE ,RESULT,IB PIEN,IBWIE N,IBLIEN
  2001    S RESULT= 0
  2002    ; Check C laim Level  Providers
  2003    S IBWIEN= IBIFN_","
  2004    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,128,"I")_ ",",.03)
  2005    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,122),"-", "")'?9N S  RESULT=1 Q  RESULT
  2006    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,129,"I")_ ",",.03)
  2007    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,123),"-", "")'?9N S  RESULT=1 Q  RESULT
  2008    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,130,"I")_ ",",.03)
  2009    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,124),"-", "")'?9N S  RESULT=1 Q  RESULT
  2010    ; Check C laim Level  Providers
  2011    S IBPIEN= 0 F  S IBP IEN=$O(^DG CR(399,IBI FN,"PRV",I BPIEN)) Q: +IBPIEN=0   Q:RESULT= 1  D
  2012    .S IBWIEN =IBPIEN_", "_IBIFN_", "
  2013    .; Test f or each pr ovider lis ted.
  2014    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.12 ,"I")_",", .03)
  2015    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.05 ),"-","")' ?9N S RESU LT=1 Q
  2016    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.13 ,"I")_",", .03)
  2017    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.06 ),"-","")' ?9N S RESU LT=1 Q 
  2018    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.14 ,"I")_",", .03)
  2019    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.07 ),"-","")' ?9N S RESU LT=1 Q
  2020    ; Check L ine Level  Providers
  2021    ; For eac h charge c ode / line .
  2022    S IBLIEN= 0 F  S IBL IEN=$O(^DG CR(399,IBI FN,"CP",IB LIEN)) Q:+ IBLIEN=0   Q:RESULT=1   D
  2023    .; For ea ch provide r associat ed with th e line.
  2024    .S IBPIEN =0 F  S IB PIEN=$O(^D GCR(399,IB IFN,"CP",I BLIEN,"LNP RV",IBPIEN )) Q:+IBPI EN=0  Q:RE SULT=1  D
  2025    ..S IBWIE N=IBPIEN_" ,"_IBLIEN_ ","_IBIFN_ ","
  2026    ..; Test  for each p rovider li sted.
  2027    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 2,"I")_"," ,.03)
  2028    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 5),"-","") '?9N S RES ULT=1 Q
  2029    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 3,"I")_"," ,.03)
  2030    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 6),"-","") '?9N S RES ULT=1 Q
  2031    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 4,"I")_"," ,.03)
  2032    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 7),"-","") '?9N S RES ULT=1 Q
  2033    Q RESULT
  2034    ;
  2035   IBMICN(IBI FN)   ; Te st for a m issing ICN . IB*2.0*4 47 BI
  2036    N IBTFOB  ; TIMEFRAM E OF BILL
  2037    N IBCBPS  ; CURRENT  BILL PAYER  SEQUENCE,  P-PRI, S- SEC, T-TER , A-PATIEN T
  2038    S IBTFOB= $$GET1^DIQ (399,IBIFN _",",.06," I")
  2039    I '((IBTF OB=7)!(IBT FOB=8)) Q  0
  2040    S IBCBPS= $$GET1^DIQ (399,IBIFN _",",.21," I")
  2041    I IBCBPS= "P",$$GET1 ^DIQ(399,I BIFN_",",1 01)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",453)=""  Q 1
  2042    I IBCBPS= "S",$$GET1 ^DIQ(399,I BIFN_",",1 02)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",454)=""  Q 1
  2043    I IBCBPS= "T",$$GET1 ^DIQ(399,I BIFN_",",1 03)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",455)=""  Q 1
  2044    Q 0
  2045    ;
  2046   IBRCCHK(IB IFN)   ; T est for a  ZERO charg e amounts.  IB*2.0*44 7 BI
  2047    N IBN0
  2048    N IBRCCNT  S IBRCCNT =0
  2049    N IBRCCHG  S IBRCCHG =0
  2050    F  S IBRC CNT=$O(^DG CR(399,IBI FN,"RC",IB RCCNT)) Q: +IBRCCNT=0   Q:IBRCCH G=1  D
  2051    .S IBN0=$ G(^DGCR(39 9,IBIFN,"R C",IBRCCNT ,0))
  2052    .I $P(IBN 0,U,1)'="" ,+$P(IBN0, U,4)=0 S I BRCCHG=1
  2053    Q IBRCCHG
  2054    ;
  2055   IBPRV3(IBI FN)   ; Te st for mis sing "Pati ent reason  for visit ". IB*2.0* 447 BI
  2056    I $$GET1^ DIQ(399,IB IFN_",",24 9)="",$$GE T1^DIQ(399 ,IBIFN_"," ,250)="",$ $GET1^DIQ( 399,IBIFN_ ",",251)=" " Q 1
  2057    Q 0
  2058    ;
  2059   IBMPID(IBI FN)   ; Te st for mul tiple paye rs. IB*2.0 *447 BI
  2060    N IBPAY1  S IBPAY1=$ $GET1^DIQ( 399,IBIFN_ ",",101,"I ")
  2061    N IBPAY2  S IBPAY2=$ $GET1^DIQ( 399,IBIFN_ ",",102,"I ")
  2062    N IBPAY3  S IBPAY3=$ $GET1^DIQ( 399,IBIFN_ ",",103,"I ")
  2063    N IBCNT S  IBCNT=0
  2064    S:IBPAY1  IBCNT=IBCN T+1 S:IBPA Y2 IBCNT=I BCNT+1 S:I BPAY3 IBCN T=IBCNT+1  I IBCNT<2  Q 0
  2065    N IBINSTI T S IBINST IT=$$INSPR F^IBCEF(IB IFN)
  2066    I IBPAY1, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y1_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY1_",", 3.02))=""  Q 1
  2067    I IBPAY2, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y2_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY2_",", 3.02))=""  Q 1
  2068    I IBPAY3, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y3_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY3_",", 3.02))=""  Q 1
  2069    Q 0
  2070   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  2071   IBCBB13 ;A LB/BI - PR OCEDURE AN D LINE LEV EL PROVIDE R EDITS ;5 -OCT-2011
  2072    ;;2.0;INT EGRATED BI LLING;**44 7,608**;21 -MAR-94;Bu ild 40
  2073    ;;Per VHA  Directive  2004-038,  this rout ine should  not be mo dified.
  2074    Q
  2075    ;
  2076   IBLNTOT(IB IFN)   ; C alculate L ine total  charges.   IB*2.0*447  BI
  2077    N X,SUM S  SUM=0
  2078    S X=0 F   S X=$O(^DG CR(399,IBI FN,"RC",X) ) Q:+X=0   D
  2079    . S SUM=S UM+$P($G(^ DGCR(399,I BIFN,"RC", X,0)),"^", 4)
  2080    Q SUM
  2081    ;
  2082   IBSYEI(IBI FN)   ; Te st for val id EIN/SY  ID Values.  IB*2.0*44 7 BI
  2083    N X12CODE ,RESULT,IB PIEN,IBWIE N,IBLIEN
  2084    S RESULT= 0
  2085    ; Check C laim Level  Providers
  2086    S IBWIEN= IBIFN_","
  2087    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,128,"I")_ ",",.03)
  2088    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,122),"-", "")'?9N S  RESULT=1 Q  RESULT
  2089    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,129,"I")_ ",",.03)
  2090    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,123),"-", "")'?9N S  RESULT=1 Q  RESULT
  2091    S X12CODE =$$GET1^DI Q(355.97,$ $GET1^DIQ( 399,IBWIEN ,130,"I")_ ",",.03)
  2092    I ((X12CO DE="SY")!( X12CODE="E I")),$TR($ $GET1^DIQ( 399,IBWIEN ,124),"-", "")'?9N S  RESULT=1 Q  RESULT
  2093    ; Check C laim Level  Providers
  2094    S IBPIEN= 0 F  S IBP IEN=$O(^DG CR(399,IBI FN,"PRV",I BPIEN)) Q: +IBPIEN=0   Q:RESULT= 1  D
  2095    .S IBWIEN =IBPIEN_", "_IBIFN_", "
  2096    .; Test f or each pr ovider lis ted.
  2097    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.12 ,"I")_",", .03)
  2098    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.05 ),"-","")' ?9N S RESU LT=1 Q
  2099    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.13 ,"I")_",", .03)
  2100    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.06 ),"-","")' ?9N S RESU LT=1 Q 
  2101    .S X12COD E=$$GET1^D IQ(355.97, $$GET1^DIQ (399.0222, IBWIEN,.14 ,"I")_",", .03)
  2102    .I ((X12C ODE="SY")! (X12CODE=" EI")),$TR( $$GET1^DIQ (399.0222, IBWIEN,.07 ),"-","")' ?9N S RESU LT=1 Q
  2103    ; Check L ine Level  Providers
  2104    ; For eac h charge c ode / line .
  2105    S IBLIEN= 0 F  S IBL IEN=$O(^DG CR(399,IBI FN,"CP",IB LIEN)) Q:+ IBLIEN=0   Q:RESULT=1   D
  2106    .; For ea ch provide r associat ed with th e line.
  2107    .S IBPIEN =0 F  S IB PIEN=$O(^D GCR(399,IB IFN,"CP",I BLIEN,"LNP RV",IBPIEN )) Q:+IBPI EN=0  Q:RE SULT=1  D
  2108    ..S IBWIE N=IBPIEN_" ,"_IBLIEN_ ","_IBIFN_ ","
  2109    ..; Test  for each p rovider li sted.
  2110    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 2,"I")_"," ,.03)
  2111    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 5),"-","") '?9N S RES ULT=1 Q
  2112    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 3,"I")_"," ,.03)
  2113    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 6),"-","") '?9N S RES ULT=1 Q
  2114    ..S X12CO DE=$$GET1^ DIQ(355.97 ,$$GET1^DI Q(399.0404 ,IBWIEN,.1 4,"I")_"," ,.03)
  2115    ..I ((X12 CODE="SY") !(X12CODE= "EI")),$TR ($$GET1^DI Q(399.0404 ,IBWIEN,.0 7),"-","") '?9N S RES ULT=1 Q
  2116    Q RESULT
  2117    ;
  2118   IBMICN(IBI FN)   ; Te st for a m issing ICN . IB*2.0*4 47 BI
  2119    N IBTFOB  ; TIMEFRAM E OF BILL
  2120    N IBCBPS  ; CURRENT  BILL PAYER  SEQUENCE,  P-PRI, S- SEC, T-TER , A-PATIEN T
  2121    S IBTFOB= $$GET1^DIQ (399,IBIFN _",",.06," I")
  2122    I '((IBTF OB=7)!(IBT FOB=8)) Q  0
  2123    S IBCBPS= $$GET1^DIQ (399,IBIFN _",",.21," I")
  2124    I IBCBPS= "P",$$GET1 ^DIQ(399,I BIFN_",",1 01)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",453)=""  Q 1
  2125    I IBCBPS= "S",$$GET1 ^DIQ(399,I BIFN_",",1 02)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",454)=""  Q 1
  2126    I IBCBPS= "T",$$GET1 ^DIQ(399,I BIFN_",",1 03)'="",$$ GET1^DIQ(3 99,IBIFN_" ,",455)=""  Q 1
  2127    Q 0
  2128    ;
  2129   IBRCCHK(IB IFN)   ; T est for a  ZERO charg e amounts.  IB*2.0*44 7 BI
  2130    N IBN0
  2131    N IBRCCNT  S IBRCCNT =0
  2132    N IBRCCHG  S IBRCCHG =0
  2133    F  S IBRC CNT=$O(^DG CR(399,IBI FN,"RC",IB RCCNT)) Q: +IBRCCNT=0   Q:IBRCCH G=1  D
  2134    .S IBN0=$ G(^DGCR(39 9,IBIFN,"R C",IBRCCNT ,0))
  2135    .I $P(IBN 0,U,1)'="" ,+$P(IBN0, U,4)=0 S I BRCCHG=1
  2136    Q IBRCCHG
  2137    ;
  2138   IBPRV3(IBI FN)   ; Te st for mis sing "Pati ent reason  for visit ". IB*2.0* 447 BI
  2139    I $$GET1^ DIQ(399,IB IFN_",",24 9)="",$$GE T1^DIQ(399 ,IBIFN_"," ,250)="",$ $GET1^DIQ( 399,IBIFN_ ",",251)=" " Q 1
  2140    Q 0
  2141    ;
  2142   IBMPID(IBI FN)   ; Te st for mul tiple paye rs. IB*2.0 *447 BI
  2143    N IBPAY1  S IBPAY1=$ $GET1^DIQ( 399,IBIFN_ ",",101,"I ")
  2144    N IBPAY2  S IBPAY2=$ $GET1^DIQ( 399,IBIFN_ ",",102,"I ")
  2145    N IBPAY3  S IBPAY3=$ $GET1^DIQ( 399,IBIFN_ ",",103,"I ")
  2146    N IBCNT S  IBCNT=0
  2147    S:IBPAY1  IBCNT=IBCN T+1 S:IBPA Y2 IBCNT=I BCNT+1 S:I BPAY3 IBCN T=IBCNT+1  I IBCNT<2  Q 0
  2148    N IBINSTI T S IBINST IT=$$INSPR F^IBCEF(IB IFN)
  2149    I IBPAY1, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y1_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY1_",", 3.02))=""  Q 1
  2150    I IBPAY2, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y2_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY2_",", 3.02))=""  Q 1
  2151    I IBPAY3, $S(IBINSTI T:$$GET1^D IQ(36,IBPA Y3_",",3.0 4),1:$$GET 1^DIQ(36,I BPAY3_",", 3.02))=""  Q 1
  2152    Q 0
  2153    ;
  2154   CMNCHK(IBI FN) ;JRA;I B*2.0*608  Check for  missing re quired Cer tificate o f Medical  Necessity  (CMN) data
  2155    ; Input :  IBIFN = I EN of the  Bill/Claim  (D399)
  2156    ; Output:  IBER  = N ULL if no  errors       
  2157    ;                = S tring of I B Error Me ssage code s delimite d by ';'
  2158    ;                =>  Note that  the return  value is  appended t o the 'IBE R' variabl e in routi ne ^IBCBB1
  2159    Q:IBIFN=" " ""
  2160    N CERTYP, CMNNODE,CM NREQ,DA,DI E,ERR,FRMN AM,FRMIEN, FORM,FRMTY P,IBER,IBP ROCP,PROCN UM
  2161    S IBER=""
  2162    ;Set up a rray of ea ch existin g Form Typ e (i.e. Fo rm IENs) a nd associa ted ^DGCR  data node.
  2163    S FRMNAM= "" F  S FR MNAM=$O(^I BE(399.6," B",FRMNAM) ) Q:FRMNAM =""  S FRM IEN=+$O(^I BE(399.6," B",FRMNAM, "")) I FRM IEN D
  2164    . S FORM( FRMIEN)=$P ($G(^IBE(3 99.6,FRMIE N,0)),U,4)
  2165    ;Loop thr u all proc edures on  the claim  searching  for missin g CMN data
  2166    S IBPROCP =0 F  S IB PROCP=$O(^ DGCR(399,I BIFN,"CP", IBPROCP))  Q:'IBPROCP   D  Q:IBE R]""
  2167    . ;If "CM N Required ?" is NULL  then QUIT  w/out fur ther check ing
  2168    . S CMNRE Q=$$CVALCH K(IBPROCP, 23,,"I") Q :CMNREQ=""
  2169    . I 'CMNR EQ,$D(FORM )>1 D  Q   ;"CMN Requ ired?" fla gged as "N O" so chec k if data  node(s) ex ist anyway  for at le ast 1 form
  2170    . . S ERR =0,FRMIEN= "" F  S FR MIEN=$O(FO RM(FRMIEN) ) Q:FRMIEN =""  I FOR M(FRMIEN)] "" D  Q:ER R
  2171    . . . S C MNNODE="^D GCR(399,"_ IBIFN_","" CP"","_IBP ROCP_",""" _FORM(FRMI EN)_""")"  I $D(@CMNN ODE) S ERR =1,IBER=IB ER_"IB901; "
  2172    . S FRMTY P=$$CVALCH K(IBPROCP, 24,"IB902" ,"I") Q:'F RMTYP  ;Ch eck for "C MN FORM TY PE" (Inter nal value)
  2173    . I $G(FO RM(FRMTYP) )]"" D  Q: ERR
  2174    . . ;Chec k if any d ata exists  at the no de specifi c to the F orm Type
  2175    . . S ERR =0,CMNNODE ="^DGCR(39 9,"_IBIFN_ ",""CP""," _IBPROCP_" ,"""_FORM( FRMTYP)_"" ")" 
  2176    . . I '$D (@CMNNODE)  S ERR=1,I BER=IBER_" IB903;" Q
  2177    . . Q:FOR M(FRMTYP)' [10126
  2178    . . N ND1 0126
  2179    . . S ND1 0126=@CMNN ODE
  2180    . . I $P( ND10126,U, 17)]"" S $ P(ND10126, U,17)="" I  $TR(ND101 26,U)="" S  ERR=1,IBE R=IBER_"IB 903;"
  2181    . ;Check  if any dat a exists f or at leas t 1 node o ther than  that assoc iated with  the Form  Type 
  2182    . S ERR=0 ,FRMIEN=""  F  S FRMI EN=$O(FORM (FRMIEN))  Q:FRMIEN=" "  I FRMIE N'=FRMTYP, FORM(FRMIE N)]"" D  Q :ERR
  2183    . . S CMN NODE="^DGC R(399,"_IB IFN_",""CP "","_IBPRO CP_","""_F ORM(FRMIEN )_""")" I  $D(@CMNNOD E) S ERR=1 ,IBER=IBER _"IB904;"
  2184    . ;Check  for Requir ed fields  at the dat a node com mon to all  forms (no de 'CMN')
  2185    . S CERTY P=$$CVALCH K(IBPROCP, 24.01,"IB9 05","I") Q :CERTYP=""   ;Check f or "CMN CE RTIFICATIO N TYPE"
  2186    . D CVALC HK(IBPROCP ,24.05,"IB 907","I")   ;Check fo r "CMN DAT E THERAPY  STARTED"
  2187    . D CVALC HK(IBPROCP ,24.06,"IB 908","I")   ;Check fo r "CMN LAS T CERTIFIC ATION DATE "
  2188    . ;IF Cer tificate T ype is "RE NEWAL" (R)  or "REVIS ED" (S) th en "CMN RE CERTIFICAT ION/REVISN  DT" is Re quired.
  2189    . I CERTY P="R"!(CER TYP="S") D  CVALCHK(I BPROCP,24. 07,"IB909" ,"I")
  2190    . ;
  2191    . ;Check  for requir ed fields  specific t o the CMN- 484 form
  2192    . I FORM( FRMTYP)[48 4 D  ;Chec k for requ ired field s/dates
  2193    . . I $$C VALCHK(IBP ROCP,24.1, ,"I")]""!( $$CVALCHK( IBPROCP,24 .102,,"I") ]"") D CVA LCHK(IBPRO CP,24.103, "IB912","I ")
  2194    . . I $$C VALCHK(IBP ROCP,24.11 1,,"I")]"" !($$CVALCH K(IBPROCP, 24.113,,"I ")]"") D C VALCHK(IBP ROCP,24.11 4,"IB914", "I")
  2195    . ;
  2196    . ;Check  for requir ed fields  specific t o the CMN- 10126 form
  2197    . I FORM( FRMTYP)[10 126 D
  2198    . . D CVA LCHK(IBPRO CP,24.217, "IB906","I ")
  2199    . . N PRO CMSG
  2200    . . S PRO CMSG="CMN  ""Procedur e ",PROCMS G(1)=""" h as no asso ciated Cal ories."
  2201    . . I $$C VALCHK(IBP ROCP,24.20 4,,"I")]"" ,'$$CVALCH K(IBPROCP, 24.203,,"I ") D WARN^ IBCBB11(PR OCMSG_"A"_ PROCMSG(1) )
  2202    . . I $$C VALCHK(IBP ROCP,24.21 9,,"I")]"" ,'$$CVALCH K(IBPROCP, 24.218,,"I ") D WARN^ IBCBB11(PR OCMSG_"B"_ PROCMSG(1) )
  2203    ;
  2204    I IBER]""  S IBER="I B915;"_IBE R
  2205    Q IBER
  2206    ;
  2207   CVALCHK(IB PROCP,FLD, ERROR,FLG)  ;JRA;IB*2 .0*608 Che ck value o f CMN fiel d & append  Error Cod e (if any)  to list o f errors
  2208    Q:($G(FLD )=""!('$G( IBPROCP)))
  2209    N VAL
  2210    S VAL=$$C MNDATA^IBC EF31(IBIFN ,IBPROCP,F LD,$G(FLG) )
  2211    I $G(ERRO R)]"",VAL= "" S IBER= IBER_ERROR _";"
  2212    Q VAL
  2213    ;
  2214  
  2215  
  2216   VII)  Use  DR Prompti ng to coll ect CMN in formation:
  2217   IBCU7 – Ca lls new ro utine IBCU 75 to prom pt user fo r CMN info  (due to l arge size  of IBCU7)
  2218   Routines
  2219   Activities
  2220   Routine Na me
  2221   IBCU7
  2222   Enhancemen t Category
  2223    New
  2224    Modify
  2225    Delete
  2226    No Change
  2227   RTM
  2228  
  2229   Related Op tions
  2230   None
  2231   Related Ro utines
  2232   Routines “ Called By”
  2233   Routines “ Called”   
  2234  
  2235  
  2236  
  2237  
  2238   Data Dicti onary (DD)  Reference s
  2239  
  2240   Related Pr otocols
  2241   None
  2242   Related In tegration  Control Re gistration s (ICRs)
  2243   None
  2244   Data Passi ng
  2245    Input
  2246    Output Re ference
  2247    Both
  2248    Global Re ference
  2249    Local
  2250   Input Attr ibute Name  and Defin ition
  2251   Name:
  2252   Definition :
  2253   Output Att ribute Nam e and Defi nition
  2254   Name:
  2255   Definition :
  2256   Current Lo gic
  2257   IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT  OF PROCEDU RE CODES ; 29-OCT-91
  2258    ;;2.0;INT EGRATED BI LLING;**62 ,52,106,12 5,51,137,2 10,245,228 ,260,348,3 71,432,447 ,488,461,5 16,522,577 ,592**;21- MAR-94;Bui ld 25
  2259    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2260    ;
  2261    ;MAP TO D GCRU7
  2262    ;
  2263   CHKX ;  -i nterceptio n of input  x from Ad ditional P rocedure i nput
  2264    G:X=" " C HKXQ
  2265    I $$INPAT ^IBCEF(DA( 1)),'$P($G (^IBE(350. 9,1,1)),"^ ",15),X'?1 A1.2N D  G  CHKXQ
  2266    . K X
  2267    . D EN^DD IOL("Site  param does  not allow  entry of  non-PTF pr ocedures")  ;Fileman  error here  will be:  The previo us error o ccurred wh en perform ing an act ion specif ied in a P re-lookup  transform  (7.5 node) .
  2268    G:'$D(^UT ILITY($J," IB")) CHKX Q
  2269    ;S M=($A( $E(X,1))-6 4),S=+$E(X ,2) Q:'$G( ^UTILITY($ J,"IB",M,S ))  S X="` "_+^(S)
  2270    S M=0 I X ?1A1.2N S  N=$G(^UTIL ITY($J,"IB ","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(^UT ILITY($J," IB","B",P) ,U,3)="Y"
  2271    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,!
  2272   CHKXQ Q
  2273    ;
  2274   CODMUL ;Da te oriente d entry of  procedure
  2275   DELASK I $ D(IBZ20),I BZ20,IBZ20 '=$P(^DGCR (399,IBIFN ,0),U,9) S  %=2 W !," SINCE THE  PROCEDURE  CODING MET HOD HAS BE EN CHANGED , DO YOU W ANT TO DEL ETE ALL",! ,"PROCEDUR E CODES IN  THIS BILL "
  2276    I  D YN^D ICN Q:%=-1   D:%=1 DE LADD I %Y? 1."?" W !! ,"If you a nswer 'Yes ', all pro cedure cod es will be  DELETED f rom this b ill.",! G  DELASK
  2277    K %,%Y,DA ,IBZ20,DIK  ;W !,"Pro cedure Ent ry:"
  2278    ;
  2279   CODDT 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)=8 1",1:"")
  2280    I $P($G(^ DGCR(399,I BIFN,0))," ^",5)<3 S  IBZTYPE=1  I $P($G(^U TILITY($J, "IB",1,1)) ,"^",2) S  DGPROCDT=$ P(^(1),"^" ,2) D ASKC OD
  2281    S X=$$PRC DIV^IBCU71 (IBIFN) I  +X W !!,$P (X,U,2),!
  2282    N Z,Z0 S  Z=$G(^DGCR (399,IBIFN ,"U")),Z0= $$FMTE^XLF DT($P(Z,U) ,"2D")_"-" _$$FMTE^XL FDT($P(Z,U ,2),"2D")
  2283    W !,"Sele ct PROCEDU RE DATE"_$ S($TR(Z0," -")'="":"  ("_Z0_")", 1:"")_": "  R X:DTIME  G:'$T!("^ "[X) CODQ  D:X["?" CO DHLP
  2284    S IBEX=0  D  ; Get p rocedure d ate
  2285    . I X=" " ,$D(DGPROC DT),DGPROC DT?7N S Y= DGPROCDT D  D^DIQ W "    (",Y,") " Q
  2286    . I X=" " ,+$P($G(^D GCR(399,IB IFN,"OP",0 )),"^",4)  S (DGPROCD T,Y)=$O(^D GCR(399,IB IFN,"OP",0 )) D D^DIQ  W "   (", Y,")" Q
  2287    . S %DT=" EXP",%DT(0 )=-DT D ^% DT K %DT I  Y<1 S IBE X=1 Q
  2288    . I '$$OP V2^IBCU41( Y,IBIFN,1)  S IBEX=1  Q
  2289    . S:'$G(I BZTYPE) X= $$OPV^IBCU 41(Y,IBIFN ) S DGPROC DT=Y
  2290    I 'IBEX D  ASKCOD,AD DCPT^IBCU7 1:$D(DGCPT )
  2291    K IBEX
  2292    G CODDT
  2293    ;
  2294   ASKCOD N Z ,Z0,DA,IBA CT,IBQUIT, IBLNPRV  ; WCJ;2.0*43 2
  2295    N IBPOPOU T  S IBPOP OUT=0  ; I B*2.0*447  BI
  2296    K DGCPT
  2297    S DGCPT=0 ,DGCPTUP=$ P($G(^IBE( 350.9,1,1) ),"^",19), DGADDVST=0 ,IBFT=$P($ G(^DGCR(39 9,IBIFN,0) ),"^",19)
  2298    I '$D(^DG CR(399,IBI FN,"CP",0) ) S ^DGCR( 399,IBIFN, "CP",0)=U_ $$GETSPEC^ IBEFUNC(39 9,304)
  2299    ;
  2300    F  S IBQU IT=0 D  Q: IBQUIT
  2301    . S IBPOP OUT=0
  2302    . D DICV  ; restrict  code type  to PCM
  2303    . S DIC(" A")="   Se lect PROCE DURE: "
  2304    . S DIC=" ^DGCR(399, "_IBIFN_", ""CP"","
  2305    . S DIC(0 )="AEQMNL"
  2306    . S DIC(" S")="I '$D (DIV(""S"" ))&($P(^(0 ),U,2)=DGP ROCDT)"
  2307    . S DIC(" DR")="1/// ^S X=DGPRO CDT"
  2308    . S DA(1) =IBIFN,DLA YGO=399
  2309    . W ! D ^ DIC I Y<1  S IBQUIT=1  Q
  2310    . S IBPRO CP=+Y
  2311    . ; If we  just adde d inactive  code - it  must be d eleted.
  2312    . S IBACT =0 ; Activ e flag
  2313    . I Y["IC D0" S IBAC T=$$ICD0AC T^IBACSV(+ $P(Y,U,2), $$BDATE^IB ACSV(IBIFN ))
  2314    . I Y["IC PT" S IBAC T=$$CPTACT ^IBACSV(+$ P(Y,U,2),D GPROCDT)
  2315    . S DGCPT NEW=$P(Y," ^",3) ;Was  the proce dure just  added?
  2316    . I DGCPT NEW,'IBACT  D DELPROC  Q
  2317    . I 'IBAC T W !,*7," Warning:   Procedure  code is in active on  this date" ,!
  2318    . I DGCPT NEW,$D(^UT ILITY($J," IB")),$$IN PAT^IBCEF( IBIFN),Y[" ICPT(" D D ATA^IBCU74 (Y,.IBLNPR V)
  2319    . S DGADD VST=$S(DGC PTNEW:1,$D (DGADDVST) :DGADDVST, 1:0)
  2320    . N IBPRV ,IBPRVO,IB PRVN
  2321    . ;
  2322    . ; Line  level prov ider funct ion by for m type.
  2323    . ;     C MS-1500 (F ORM TYPE=2 )
  2324    . ;               RE NDERING PR OVIDER, RE FERRING PR OVIDER,
  2325    . ;               an d SUPERVIS ING PROVID ER.
  2326    . ;     U B-04 (FORM  TYPE=3)
  2327    . ;               RE NDERING PR OVIDER, RE FERRING PR OVIDER,
  2328    . ;               OP ERATING PR OVIDER, an d OTHER OP ERATING
  2329    . ;               PR OVIDER.
  2330    . ;
  2331    . ; Remov ed: Call t o $$MAINPR V^IBCEU(IB IFN) is fo r claim
  2332    . ;           level  provider d efaults.
  2333    . ;     1 . For new  line level  providers  we don't  need
  2334    . ;         or want  default cl aim level  provider
  2335    . ;         (require ment).
  2336    . ;     2 . We don't  want to d efault cla im level t o
  2337    . ;         line lev el provide r (require ment).
  2338    . ;
  2339    . K DIC(" V")  ; DEM ;432 - KIL L DIC("V")  because t his was fo r previous  variable  pointer us e.
  2340    . ;
  2341    . N IBPRO CSV  ; DEM ;432 - Var iable IBPR OCSV is va riable to  preserve v alue of 'Y ', which i s procedur e code inf o returned  by call t o ^DIC.
  2342    . 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).
  2343    . K DR    ;WCJ;IB*2. 0*432
  2344    . ;
  2345    . I IBPRO CSV["ICD0"  S DR=".01 ",DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($D(Y))   K DR ; I B*2.0*461
  2346    . ;
  2347    . I IBPRO CSV["ICPT"  S DR=".01 ;16",DIE=D IC,(IBPROC P,DA)=+Y D  ^DIE Q:'$ D(DA)!($D( Y))  K DR  ; IB*2.0*4 47 BI
  2348    . ;
  2349    . S DR=""
  2350    . ;
  2351    . ; MRD;I B*2.0*516  - Added li ne level P ROCEDURE D ESCRIPTION  field,
  2352    . ; asked  only if t he procedu re is an " NOC".
  2353    . I IBPRO CSV["ICPT" ,$$NOCPROC (IBPROCSV)  D
  2354    . . S DA= $P(IBPROCS V,"^")  ;  The line#  on the bil l/claim.
  2355    . . S DR= 51                 ;  Field# for  PROCEDURE  DESCRIPTI ON
  2356    . . D ^DI E
  2357    . . Q
  2358    . ;
  2359    . D EN^IB CU7B ; DEM ;432 - Cal l to line  level prov ider user  input.
  2360    . S Y=IBP ROCSV  ; D EM;432 - R estore val ue of Y af ter calls  to FileMan
  2361    . K IBPRO CSV
  2362    . K DR    ;WCJ;IB*2. 0*432
  2363    . I IBPOP OUT Q   ;  IB*2.0*447  BI
  2364    . S DR=""  I Y["ICPT " S DR="6; 5//"_$$DEF DIV(IBIFN) _";"
  2365    . ;JWS;IB *2.0*592 U S1108 - De ntal
  2366    . ;IA# 10 018
  2367    . 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)
  2368    . K DR    ;WCJ;IB*2. 0*432
  2369    . ;
  2370    . ; MRD;I B*2.0*516  - Allow us er to add  an NDC and  Units.  A sk only if
  2371    . ; codin g system i s not ICD  and this i s not a pr escription  claim. If
  2372    . ; an ND C is enter ed, prompt  for Units .
  2373    . I $P($G (^DGCR(399 ,IBIFN,0)) ,U,9)'=9,' $$RXLINK^I BCSC5C(IBI FN,IBPROCP ) D
  2374    . . ;JWS; IB*2.0*592  US1108 -  Dental
  2375    . . I IBF T=7 Q
  2376    . . K DA
  2377    . . S DA= IBPROCP,DA (1)=IBIFN, DIE="^DGCR (399,"_IBI FN_",""CP" ","
  2378    . . ; vd/ Beginning  IB*2*577 -  Added the  prompt fo r Unit/Bas is of Meas urement.
  2379    . . ; S D R="53NDC N UMBER;I X= """" S Y=" """;54//1"
  2380    . . S DR= "53NDC NUM BER;I X="" "" S Y=""" ";52//UN;5 4QUANTITY/ /1"  ;Prom pt for NDC , UN & amt .
  2381    . . ; vd/ Ending IB* 2*577
  2382    . . D ^DI E
  2383    . . Q
  2384    . ;
  2385    . I IBFT= 3 D:'$$INP AT^IBCEF(I BIFN) ATTA CH  ; DEM; 432 - Prom pt for Att achment Co ntrol Numb er.
  2386    . ; DEM;4 32 - Add A dditional  OB Minutes  to DR str ing for ca ll to DIE.
  2387    . S DR=$$ SPCUNIT(IB IFN,IBPROC P) S:DR["1 5;" DR=DR_ "74Additio nal OB Min utes" D ^D IE ; miles /minutes/h ours
  2388    . ;JWS;IB *2.0*592 U S1108 - De ntal
  2389    . I IBFT= 2!(IBFT=7)  D
  2390    .. D DX^I BCU72(IBIF N,IBPROCP)
  2391    .. ;JWS;I B*2.0*592  US1108 - D ental
  2392    .. I IBFT '=7 S X=$$ ADDTNL(IBI FN,.DA)
  2393    . Q:$$INP AT^IBCEF(I BIFN)  ;on ly outpati ent bills
  2394    . ;JWS;IB *2.0*592 U S1108 - De ntal input  fields
  2395    . I $$FT^ IBCEF(IBIF N)=7 D ORA L^IBCU72
  2396    . ;add pr ocedures t o array fo r download  to PCE: d gcpt(assoc  clinic,cp t,'provide r^first dx ^modifiers ',cnt)=""
  2397    . S DGPRO C=$G(^DGCR (399,IBIFN ,"CP",+DA, 0))
  2398    . S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15)
  2399    . I 'DGCP TNEW,$P(DG PROC,"^",7 )="" S DGC PTNEW=2
  2400    . I DGCPT UP,DGCPTNE W S DGCPT= DGCPT+1 I  $P(DGPROC, "^",7) S D GCPT($P(DG PROC,"^",7 ),+DGPROC, X,DGCPT)=" "
  2401    . ; add v isit date  to bill
  2402    . I DGADD VST S (X,D INUM)=DGPR OCDT D VFI LE1^IBCOPV 1 K DINUM, X,DGNOADD, DGADDVST
  2403    ; Delete  modifiers  with only  a sequence  #, no cod e
  2404    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z  S  Z0=0 F  S  Z0=$O(^DGC R(399,IBIF N,"CP",Z," MOD",Z0))  Q:'Z0  I $ P($G(^(Z0, 0)),U,2)=" " S DA(2)= IBIFN,DA(1 )=Z,DA=Z0, DIK="^DGCR (399,"_DA( 2)_",""CP" ","_DA(1)_ ",""MOD"", " D ^DIK
  2405    Q
  2406    ;
  2407   CODQ K %DT ,DGPROC,DI C,DIE,DR,D GPROCDT,IB PROCP,DLAY GO
  2408    K IBFT,DG NOADD,DGAD DVST,DGCPT ,DGCPTUP,I BZTYPE,DGC PTNEW
  2409    Q
  2410    ;
  2411   DELPROC ;  Remove the  selected  procedure,  because o f inactive  status (c ancel sele ction)
  2412    W !!,*7," The Proced ure code i s inactive  on ",$$DA T1^IBOUTL( DGPROCDT), "."
  2413    W !,"Plea se select  another Pr ocedure."
  2414    S DA(1)=I BIFN,DA=+Y ,DIK="^DGC R(399,"_IB IFN_",""CP "","
  2415    D ^DIK
  2416    Q
  2417    ;
  2418   DELADD N Z ,Z0,DA,DIK ,X,Y
  2419    S DA(1)=I BIFN
  2420    ;Delete r eferences  to proc on  rev codes
  2421    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"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  DIE="^DGC R(399,"_DA (1)_",""RC "",",DA=Z, DR=".11/// @;.15///@" _$S($P(Z0, U,8):"",1: ";.08////1 ") D ^DIE
  2422    S DIK="^D GCR(399,"_ DA(1)_","" CP""," F D A=0:0 S DA =$O(^DGCR( 399,DA(1), "CP",DA))  Q:'DA  D ^ DIK
  2423    S DGRVRCA L=1
  2424    Q
  2425    ;
  2426   DTMES ;Mes sage if pr ocedure da te not in  date range
  2427    Q:'$D(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"U" ))  S DGNO DUU=^("U")
  2428    G:X'<$P(D GNODUU,"^" )&(X'>$P(D GNODUU,"^" ,2)) DTMES Q
  2429    W *7,!!?3 ,"Date mus t be withi n STATEMEN T COVERS F ROM and ST ATEMENT CO VERS TO pe riod."
  2430    S Y=$P(DG NODUU,"^")  X ^DD("DD ")
  2431    W !?3,"En ter a date  between " ,Y," and "  S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,!
  2432    K X,Y
  2433   DTMESQ K D GNODUU Q
  2434    ;
  2435   CODHLP ;Di splay Addi tional Pro cedure cod es
  2436    N I,J,Y,I BMOD
  2437    I '$O(^DG CR(399,IBI FN,"CP",0) ) W !!?5," No Codes E ntered!",!  Q
  2438    W ! F I=0 :0 S I=$O( ^DGCR(399, IBIFN,"CP" ,I)) Q:'I   S Y=$G(^( I,0)) S Z= $$PRCNM^IB CSCH1($P(Y ,"^",1),$P (Y,"^",2))  W !?5,$E( $P(Z,"^",2 ),1,33),?4 0,"- ",$P( Z,"^") D
  2439    . N IBY
  2440    . S IBY=$ P(Y,U,2)
  2441    . S IBMOD =$$GETMOD^ IBEFUNC(IB IFN,I,1)
  2442    . I IBMOD '="" S IBM OD="/"_IBM OD W IBMOD
  2443    . W ?60," Date: " S  Y=IBY D DT ^DIQ
  2444    W !
  2445    ;
  2446    K Z Q
  2447    ;
  2448   DICV 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:"")
  2449    Q
  2450    ;
  2451   DEFDIV(IBI FN) ; Find  default d ivision fo r bill IBI FN
  2452    Q $P($G(^ DG(40.8,+$ P($G(^DGCR (399,IBIFN ,0)),U,22) ,0)),U)
  2453    ;
  2454   ADDTNL(IBI FN,DA) ;
  2455    N DR,IBOK ,X,Y,DIR
  2456    S IBOK=1
  2457    S DR="19T ;50.09T;50 .08T" D ^D IE  ; WCJ; IB*2.0*488  Added Ts
  2458    ;I '($$FT ^IBCEF(IBI FN)'=3&($$ INPAT^IBCE F(IBIFN)))  D ATTACH   ; DEM;432  - Prompt  for Attach ment Contr ol Number.
  2459    I '($$FT^ IBCEF(IBIF N)=3&($$IN PAT^IBCEF( IBIFN))) D  ATTACH  ;  DEM;432 -  Prompt fo r Attachme nt Control  Number.
  2460    I $D(Y) S  IBOK=0 G  ADDTNLQ
  2461    ;/Beginni ng of IB*2 .0*488 (vd )
  2462    ;S DIR("B ")="NO",DI R("A")="ED IT CMS-150 0 SPECIAL  PROGRAM FI ELDS and B OX 19?: ", DIR("A",1) =" ",DIR(0 )="YA"
  2463    ;S DIR("? ",1)="Resp ond YES on ly if you  need to ad d/edit dat a for chir opractic v isits,"
  2464    ;S DIR("? ")="EPSDT  care, or i f billing  for HOSPIC E and atte nding is n ot a hospi ce employe e."
  2465    ;D ^DIR K  DIR
  2466    ;I Y'=1 S  IBOK=0 G  ADDTNLQ
  2467    ;S DR="W  !,""  <<EP SDT>>"";50 .07;W !!," "  <<HOSPI CE>>"";50. 03"
  2468    S DR="50. 07T;50.03T "   ;WCJ;I B*2.0*488  added Ts
  2469    ;/End of  IB*2.0*488  (vd)
  2470    D ^DIE
  2471    W !
  2472   ADDTNLQ Q  IBOK
  2473    ;
  2474   XTRA1(Y) ;
  2475    K Y
  2476    Q
  2477    ;
  2478   SPCUNIT(IB IFN,DA) ;  return fie lds for sp ecial unit s if appli cable, in  DR form
  2479    N IB0,IBC PT,IBDR,IB CT,IBFT,DF N S IBDR=" "
  2480    S IB0=$G( ^DGCR(399, +$G(IBIFN) ,0)),IBCT= $P(IB0,U,2 7),IBFT=$P (IB0,U,19) ,DFN=$P(IB 0,U,2)
  2481    S IBCPT=$ G(^DGCR(39 9,+$G(IBIF N),"CP",+$ G(DA),0))  I IBCPT'[" ICPT" G SP CUNTQ
  2482    I +$$ITMU NIT^IBCRU4 (+IBCPT,5, IBCT) S IB DR="15;" D  SROMIN^IB CU74(IBIFN ,DA) G SPC UNTQ ; min utes
  2483    I +$$ITMU NIT^IBCRU4 (+IBCPT,4, IBCT) S IB DR="21;" G  SPCUNTQ ;  miles
  2484    I +$$ITMU NIT^IBCRU4 (+IBCPT,6, IBCT) S IB DR="22//"_ $$OBSHOUR^ IBCU74(DFN ,$P(IBCPT, U,2))_";"  G SPCUNTQ  ; hours
  2485    I +IBFT=2 ,$P($G(^IB E(353.2,+$ P(IBCPT,U, 10),0)),U, 2)="ANESTH ESIA" S IB DR="15;" ;  minutes
  2486   SPCUNTQ Q  IBDR
  2487    ;
  2488   ATTACH ; D EM;432 - A ttachment  control nu mber.
  2489    ; Ask if  user wants  to enter  Attachment  Control N umber.
  2490    N DIR,X,Y ,DA,DIE,DR
  2491    S DIR("A" )="Enter A ttachment  Control Nu mber"
  2492    S DIR(0)= "Y",DIR("B ")="NO"
  2493    D ^DIR
  2494    Q:'Y
  2495    ; User ch ose to ent er Attachm ent Contro l Number.
  2496    ; User en ters Attac hment Cont rol fields .
  2497    S DA(1)=I BIFN,DA=IB PROCP
  2498    S DIE="^D GCR(399,"_ DA(1)_","" CP"","
  2499    S DR="71R eport Type ;72Report  Transmissi on Method; 70Attachme nt Control  Number"
  2500    D ^DIE
  2501    Q
  2502    ;
  2503   NOCPROC(IB PROCSV) ;  MRD;IB*2.0 *516 - Fun ction to d etermine i f procedur e is an
  2504    ; "NOC".   Returns ' 1' if "NOC " procedur e, otherwi se '0'.
  2505    ;
  2506    N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX
  2507    S IBNOC=0
  2508    I $G(IBPR OCSV)="" G  NOCPROCQ
  2509    S IBPROCI N=$P($P(IB PROCSV,U,2 ),";")
  2510    I IBPROCI N="" G NOC PROCQ
  2511    ;
  2512    ; If proc edure code  ends in ' 99', quit  with a '1' .
  2513    ;
  2514    S IBPROCE X=$P($G(^I CPT(IBPROC IN,0)),U,1 )
  2515    I $E(IBPR OCEX,$L(IB PROCEX)-1, $L(IBPROCE X))=99 S I BNOC=1 G N OCPROCQ
  2516    ;
  2517    ; Pull pr ocedure na me, then c heck to se e if it co ntains one  of the
  2518    ; specifi ed strings .
  2519    ;
  2520    S IBPROCN M=$P($G(^I CPT(IBPROC IN,0)),U,2 )
  2521    I IBPROCN M'="",$$NO C(IBPROCNM ) S IBNOC= 1 G NOCPRO CQ
  2522    ;
  2523    S IBX=0
  2524    F  S IBX= $O(^ICPT(I BPROCIN,"D ",IBX)) Q: 'IBX  D  I  IBNOC=1 Q
  2525    . S IBTEX T=$G(^ICPT (IBPROCIN, "D",IBX,0) )
  2526    . I $G(^I CPT(IBPROC IN,"D",IBX +1,0))'=""  S IBTEXT= IBTEXT_" " _$G(^ICPT( IBPROCIN," D",IBX+1,0 ))
  2527    . S IBNOC =$$NOC(IBT EXT)
  2528    . Q
  2529    ;
  2530   NOCPROCQ ;  Quit out.
  2531    Q IBNOC
  2532    ;
  2533   NOC(IBTEXT ) ; Quit w ith '1' if  IBTEXT co ntains one  of the sp ecified st rings.
  2534    ;
  2535    S IBTEXT= $TR(IBTEXT ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")
  2536    ;
  2537    I IBTEXT[ "NOT OTHER WISE" Q 1
  2538    I IBTEXT[ "NOT ELSEW HERE" Q 1
  2539    I IBTEXT[ "NOT LISTE D" Q 1
  2540    I IBTEXT[ "UNLISTED"  Q 1
  2541    I IBTEXT[ "UNSPECIFI ED" Q 1
  2542    I IBTEXT[ "UNCLASSIF IED" Q 1
  2543    I IBTEXT[ "NON-SPECI FIED" Q 1
  2544    I IBTEXT[ "NOS " Q 1
  2545    I IBTEXT[ "NOS;" Q 1
  2546    I IBTEXT[ "NOS." Q 1
  2547    I IBTEXT[ "NOS," Q 1
  2548    I IBTEXT[ "NOS/" Q 1
  2549    I IBTEXT[ "(NOS)" Q  1
  2550    I IBTEXT[ "NOC " Q 1
  2551    I IBTEXT[ "NOC;" Q 1
  2552    I IBTEXT[ "NOC." Q 1
  2553    I IBTEXT[ "NOC," Q 1
  2554    I IBTEXT[ "NOC/" Q 1
  2555    I IBTEXT[ "(NOC)" Q  1
  2556    ;
  2557    ; Check i f last thr ee charcte rs are 'NO C' or 'NOS '.
  2558    ;
  2559    S IBTEXT= $E(IBTEXT, $L(IBTEXT) -2,$L(IBTE XT))
  2560    I IBTEXT= "NOC" Q 1
  2561    I IBTEXT= "NOS" Q 1
  2562    ;
  2563    Q 0
  2564    ;
  2565   ORALCAV(FL D) ;EP
  2566    ; Diction ary Screen  function  called fro m Procedur es Oral Ca vity Field s:
  2567    ; 399.030 4.90.01, 3 99.0304.90 .02, 399.0 304.90.03,  399.0304. 90.04, 399 .0304.90.0
  2568    ; Prevent s the same  Oral Cavi ty from be ing select ed more th an once.
  2569    ; Input:    FLD   -  Field # of  the field  being che cked
  2570    ;           DA    -  IEN of the  Service L ine Multip le being e dited
  2571    ;           DA(1) -  IEN of the  356.22 en try being  edited
  2572    ;           Y     -  Internal V alue of th e user res ponse
  2573    ; Returns : 1 - Data  input by  the user i s valid, 0  otherwise
  2574    N NDE,RTN
  2575    S NDE=$G( ^DGCR(399, DA(1),"CP" ,DA,"DEN") )
  2576    S RTN=1                                ; A ssume Vali d Input
  2577    Q:Y="" 1                               ; N o value en tered
  2578    ;
  2579    ; Make su re there a re no dupl icates
  2580    I FLD=90. 01 D  Q RT N
  2581    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2582    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2583    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2584    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2585    I FLD=90. 02 D  Q RT N
  2586    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2587    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2588    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2589    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2590    I FLD=90. 03 D  Q RT N
  2591    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2592    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2593    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2594    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2595    I FLD=90. 04 D  Q RT N
  2596    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2597    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2598    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2599    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2600    I FLD=90. 05 D  Q RT N
  2601    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2602    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2603    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2604    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2605    Q RTN
  2606    ;
  2607   TOOTHS(FLD ) ;EP
  2608    ; Diction ary Screen  function  called fro m Dental S ervice Lin e Tooth fi elds:
  2609    ; 399,91, .02, 399,9 1,.03, 399 ,91,.04, 3 99,91,.05,  399,91,.0 6. Prevent s the 
  2610    ; same To oth Surfac e from bei ng selecte d more tha n once.
  2611    ; Input:    FLD   -  Field # of  the field  being che cked
  2612    ;           DA    -  Tooth Surf ace multip le IEN
  2613    ;           DA(1) -  Service Li ne multipl e IEN
  2614    ;           DA(2) -  IEN of the  356.22 en try being  edited
  2615    ;           Y     -  Internal V alue of th e user res ponse
  2616    ; Returns : 1 - Data  input by  the user i s valid, 0  otherwise
  2617    N NDE,RTN
  2618    S NDE=$G( ^DGCR(399, DA(2),"CP" ,DA(1),"DE N1",DA,0))
  2619    S RTN=1               ; Assume  Valid Inpu t
  2620    Q:Y="" 1              ; No valu e entered
  2621    ;
  2622    ; Make su re there a re no dupl icates
  2623    I FLD=.02  D  Q RTN
  2624    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2625    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2626    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2627    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  2628    I FLD=.03  D  Q RTN
  2629    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2630    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2631    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2632    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  2633    I FLD=.04  D  Q RTN
  2634    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2635    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2636    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2637    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  2638    I FLD=.05  D  Q RTN
  2639    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2640    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2641    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2642    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  2643    I FLD=.06  D  Q RTN
  2644    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2645    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2646    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2647    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2648    Q RTN
  2649    ;
  2650   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  2651   IBCU7 ;ALB /AAS - INT ERCEPT SCR EEN INPUT  OF PROCEDU RE CODES ; 29-OCT-91
  2652    ;;2.0;INT EGRATED BI LLING;**62 ,52,106,12 5,51,137,2 10,245,228 ,260,348,3 71,432,447 ,488,461,5 16,522,577 ,604,592,6 08**;21-MA R-94;Build  40
  2653    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2654    ;
  2655    ;MAP TO D GCRU7
  2656    ;
  2657    ; This ro utine is a  copy of I BUC7 for t esting pur poses.
  2658    ;
  2659   CHKX ;  -i nterceptio n of input  x from Ad ditional P rocedure i nput
  2660    G:X=" " C HKXQ
  2661    I $$INPAT ^IBCEF(DA( 1)),'$P($G (^IBE(350. 9,1,1)),"^ ",15),X'?1 A1.2N D  G  CHKXQ
  2662    . K X
  2663    . D EN^DD IOL("Site  param does  not allow  entry of  non-PTF pr ocedures")  ;Fileman  error here  will be:  The previo us error o ccurred wh en perform ing an act ion specif ied in a P re-lookup  transform  (7.5 node) .
  2664    G:'$D(^UT ILITY($J," IB")) CHKX Q
  2665    ;S M=($A( $E(X,1))-6 4),S=+$E(X ,2) Q:'$G( ^UTILITY($ J,"IB",M,S ))  S X="` "_+^(S)
  2666    S M=0 I X ?1A1.2N S  N=$G(^UTIL ITY($J,"IB ","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(^UT ILITY($J," IB","B",P) ,U,3)="Y"
  2667    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,!
  2668   CHKXQ Q
  2669    ;
  2670   CODMUL ;Da te oriente d entry of  procedure
  2671   DELASK I $ D(IBZ20),I BZ20,IBZ20 '=$P(^DGCR (399,IBIFN ,0),U,9) S  %=2 W !," SINCE THE  PROCEDURE  CODING MET HOD HAS BE EN CHANGED , DO YOU W ANT TO DEL ETE ALL",! ,"PROCEDUR E CODES IN  THIS BILL "
  2672    I  D YN^D ICN Q:%=-1   D:%=1 DE LADD I %Y? 1."?" W !! ,"If you a nswer 'Yes ', all pro cedure cod es will be  DELETED f rom this b ill.",! G  DELASK
  2673    K %,%Y,DA ,IBZ20,DIK  ;W !,"Pro cedure Ent ry:"
  2674    ;
  2675   CODDT 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)=8 1",1:"")
  2676    I $P($G(^ DGCR(399,I BIFN,0))," ^",5)<3 S  IBZTYPE=1  I $P($G(^U TILITY($J, "IB",1,1)) ,"^",2) S  DGPROCDT=$ P(^(1),"^" ,2) D ASKC OD
  2677    S X=$$PRC DIV^IBCU71 (IBIFN) I  +X W !!,$P (X,U,2),!
  2678    N Z,Z0 S  Z=$G(^DGCR (399,IBIFN ,"U")),Z0= $$FMTE^XLF DT($P(Z,U) ,"2D")_"-" _$$FMTE^XL FDT($P(Z,U ,2),"2D")
  2679    W !,"Sele ct PROCEDU RE DATE"_$ S($TR(Z0," -")'="":"  ("_Z0_")", 1:"")_": "  R X:DTIME  G:'$T!("^ "[X) CODQ  D:X["?" CO DHLP
  2680    S IBEX=0  D  ; Get p rocedure d ate
  2681    . I X=" " ,$D(DGPROC DT),DGPROC DT?7N S Y= DGPROCDT D  D^DIQ W "    (",Y,") " Q
  2682    . I X=" " ,+$P($G(^D GCR(399,IB IFN,"OP",0 )),"^",4)  S (DGPROCD T,Y)=$O(^D GCR(399,IB IFN,"OP",0 )) D D^DIQ  W "   (", Y,")" Q
  2683    . S %DT=" EXP",%DT(0 )=-DT D ^% DT K %DT I  Y<1 S IBE X=1 Q
  2684    . I '$$OP V2^IBCU41( Y,IBIFN,1)  S IBEX=1  Q
  2685    . S:'$G(I BZTYPE) X= $$OPV^IBCU 41(Y,IBIFN ) S DGPROC DT=Y
  2686    I 'IBEX D  ASKCOD,AD DCPT^IBCU7 1:$D(DGCPT )
  2687    K IBEX
  2688    G CODDT
  2689    ;
  2690   ASKCOD N Z ,Z0,DA,IBA CT,IBQUIT, IBLNPRV,IB CODE  ;WCJ ;2.0*432
  2691    N IBPOPOU T  S IBPOP OUT=0  ; I B*2.0*447  BI
  2692    K DGCPT
  2693    S DGCPT=0 ,DGCPTUP=$ P($G(^IBE( 350.9,1,1) ),"^",19), DGADDVST=0 ,IBFT=$P($ G(^DGCR(39 9,IBIFN,0) ),"^",19)
  2694    I '$D(^DG CR(399,IBI FN,"CP",0) ) S ^DGCR( 399,IBIFN, "CP",0)=U_ $$GETSPEC^ IBEFUNC(39 9,304)
  2695    ;
  2696    F  S IBQU IT=0 D  Q: IBQUIT
  2697    . S IBPOP OUT=0
  2698    . D DICV  ; restrict  code type  to PCM
  2699    . S DIC(" A")="   Se lect PROCE DURE: "
  2700    . S DIC=" ^DGCR(399, "_IBIFN_", ""CP"","
  2701    . S DIC(0 )="AEQMNL"
  2702    . S DIC(" S")="I '$D (DIV(""S"" ))&($P(^(0 ),U,2)=DGP ROCDT)"
  2703    . S DIC(" DR")="1/// ^S X=DGPRO CDT"
  2704    . S DA(1) =IBIFN,DLA YGO=399
  2705    . W ! D ^ DIC I Y<1  S IBQUIT=1  Q
  2706    . S IBPRO CP=+Y
  2707    . S IBCOD E=X ;Get t he code
  2708    . ; If we  just adde d inactive  code - it  must be d eleted.
  2709    . S IBACT =0 ; Activ e flag
  2710    . I Y["IC D0" S IBAC T=$$ICD0AC T^IBACSV(+ $P(Y,U,2), $$BDATE^IB ACSV(IBIFN ))
  2711    . I Y["IC PT" S IBAC T=$$CPTACT ^IBACSV(+$ P(Y,U,2),D GPROCDT)
  2712    . S DGCPT NEW=$P(Y," ^",3) ;Was  the proce dure just  added?
  2713    . I DGCPT NEW,'IBACT  D DELPROC  Q
  2714    . I 'IBAC T W !,*7," Warning:   Procedure  code is in active on  this date" ,!
  2715    . I DGCPT NEW,$D(^UT ILITY($J," IB")),$$IN PAT^IBCEF( IBIFN),Y[" ICPT(" D D ATA^IBCU74 (Y,.IBLNPR V)
  2716    . S DGADD VST=$S(DGC PTNEW:1,$D (DGADDVST) :DGADDVST, 1:0)
  2717    . N IBPRV ,IBPRVO,IB PRVN
  2718    . ;
  2719    . ; Line  level prov ider funct ion by for m type.
  2720    . ;     C MS-1500 (F ORM TYPE=2 )
  2721    . ;               RE NDERING PR OVIDER, RE FERRING PR OVIDER,
  2722    . ;               an d SUPERVIS ING PROVID ER.
  2723    . ;     U B-04 (FORM  TYPE=3)
  2724    . ;               RE NDERING PR OVIDER, RE FERRING PR OVIDER,
  2725    . ;               OP ERATING PR OVIDER, an d OTHER OP ERATING
  2726    . ;               PR OVIDER.
  2727    . ;
  2728    . ; Remov ed: Call t o $$MAINPR V^IBCEU(IB IFN) is fo r claim
  2729    . ;           level  provider d efaults.
  2730    . ;     1 . For new  line level  providers  we don't  need
  2731    . ;         or want  default cl aim level  provider
  2732    . ;         (require ment).
  2733    . ;     2 . We don't  want to d efault cla im level t o
  2734    . ;         line lev el provide r (require ment).
  2735    . ;
  2736    . K DIC(" V")  ; DEM ;432 - KIL L DIC("V")  because t his was fo r previous  variable  pointer us e.
  2737    . ;
  2738    . N IBPRO CSV  ; DEM ;432 - Var iable IBPR OCSV is va riable to  preserve v alue of 'Y ', which i s procedur e code inf o returned  by call t o ^DIC.
  2739    . 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).
  2740    . K DR    ;WCJ;IB*2. 0*432
  2741    . ;
  2742    . I IBPRO CSV["ICD0"  S DR=".01 ",DIE=DIC, (IBPROCP,D A)=+Y D ^D IE Q:'$D(D A)!($D(Y))   K DR ; I B*2.0*461
  2743    . ;
  2744    . ;JRA;IB *2.0*608 P rompt user  for Certi ficate of  Medical Ne cessity (C MN) info
  2745    . I $$FT^ IBCEF(IBIF N)=2,$$CMN PRMT^IBJPS 8(IBIFN,IB PROCP,$P($ P(IBPROCSV ,U,2),";") ) D CMN^IB CU75(IBIFN ,IBPROCP)
  2746    . ;
  2747    . I IBPRO CSV["ICPT"  S DR=".01 ;16",DIE=D IC,(IBPROC P,DA)=+Y D  ^DIE Q:'$ D(DA)!($D( Y))  K DR  ; IB*2.0*4 47 BI
  2748    . ;
  2749    . S DR=""
  2750    . ;
  2751    . ; MRD;I B*2.0*516  - Added li ne level P ROCEDURE D ESCRIPTION  field,
  2752    . ; asked  only if t he procedu re is an " NOC".
  2753    . I IBPRO CSV["ICPT" ,$$NOCPROC (IBPROCSV, IBCODE,DGP ROCDT) D   ; added IB CODE,DGPRO CDT in *60 4
  2754    . . S DA= $P(IBPROCS V,"^")  ;  The line#  on the bil l/claim.
  2755    . . S DR= 51                 ;  Field# for  PROCEDURE  DESCRIPTI ON
  2756    . . D ^DI E
  2757    . . Q
  2758    . ;
  2759    . D EN^IB CU7B ; DEM ;432 - Cal l to line  level prov ider user  input.
  2760    . S Y=IBP ROCSV  ; D EM;432 - R estore val ue of Y af ter calls  to FileMan
  2761    . K IBPRO CSV
  2762    . K DR    ;WCJ;IB*2. 0*432
  2763    . I IBPOP OUT Q   ;  IB*2.0*447  BI
  2764    . S DR=""  I Y["ICPT " S DR="6; 5//"_$$DEF DIV(IBIFN) _";"
  2765    . ;JWS;IB *2.0*592 U S1108 - De ntal
  2766    . ;IA# 10 018
  2767    . 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)
  2768    . K DR    ;WCJ;IB*2. 0*432
  2769    . ;
  2770    . ; MRD;I B*2.0*516  - Allow us er to add  an NDC and  Units.  A sk only if
  2771    . ; codin g system i s not ICD  and this i s not a pr escription  claim. If
  2772    . ; an ND C is enter ed, prompt  for Units .
  2773    . I $P($G (^DGCR(399 ,IBIFN,0)) ,U,9)'=9,' $$RXLINK^I BCSC5C(IBI FN,IBPROCP ) D
  2774    . . ;JWS; IB*2.0*592  US1108 -  Dental
  2775    . . I IBF T=7 Q
  2776    . . K DA
  2777    . . S DA= IBPROCP,DA (1)=IBIFN, DIE="^DGCR (399,"_IBI FN_",""CP" ","
  2778    . . ; vd/ Beginning  IB*2*577 -  Added the  prompt fo r Unit/Bas is of Meas urement.
  2779    . . ; S D R="53NDC N UMBER;I X= """" S Y=" """;54//1"
  2780    . . S DR= "53NDC NUM BER;I X="" "" S Y=""" ";52R~//UN ;54R~QUANT ITY//1"  ; Prompt for  NDC, UN &  amt.
  2781    . . ; vd/ Ending IB* 2*577
  2782    . . D ^DI E
  2783    . . Q
  2784    . ;
  2785    . I IBFT= 3 D:'$$INP AT^IBCEF(I BIFN) ATTA CH  ; DEM; 432 - Prom pt for Att achment Co ntrol Numb er.
  2786    . ; DEM;4 32 - Add A dditional  OB Minutes  to DR str ing for ca ll to DIE.
  2787    . S DR=$$ SPCUNIT(IB IFN,IBPROC P) S:DR["1 5;" DR=DR_ "74Additio nal OB Min utes" D ^D IE ; miles /minutes/h ours
  2788    . ;JWS;IB *2.0*592 U S1108 - De ntal
  2789    . I IBFT= 2!(IBFT=7)  D
  2790    .. D DX^I BCU72(IBIF N,IBPROCP)
  2791    .. ;JWS;I B*2.0*592  US1108 - D ental
  2792    .. I IBFT '=7 S X=$$ ADDTNL(IBI FN,.DA)
  2793    . Q:$$INP AT^IBCEF(I BIFN)  ;on ly outpati ent bills
  2794    . ;JWS;IB *2.0*592 U S1108 - De ntal input  fields
  2795    . I IBFT= 7 D ORAL^I BCU72
  2796    . ;add pr ocedures t o array fo r download  to PCE: d gcpt(assoc  clinic,cp t,'provide r^first dx ^modifiers ',cnt)=""
  2797    . S DGPRO C=$G(^DGCR (399,IBIFN ,"CP",+DA, 0))
  2798    . S X=$P( DGPROC,U,1 8)_U_+$G(^ IBA(362.3, +$P(DGPROC ,U,11),0)) _U_$P(DGPR OC,U,15)
  2799    . I 'DGCP TNEW,$P(DG PROC,"^",7 )="" S DGC PTNEW=2
  2800    . I DGCPT UP,DGCPTNE W S DGCPT= DGCPT+1 I  $P(DGPROC, "^",7) S D GCPT($P(DG PROC,"^",7 ),+DGPROC, X,DGCPT)=" "
  2801    . ; add v isit date  to bill
  2802    . I DGADD VST S (X,D INUM)=DGPR OCDT D VFI LE1^IBCOPV 1 K DINUM, X,DGNOADD, DGADDVST
  2803    ; Delete  modifiers  with only  a sequence  #, no cod e
  2804    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"CP",Z) ) Q:'Z  S  Z0=0 F  S  Z0=$O(^DGC R(399,IBIF N,"CP",Z," MOD",Z0))  Q:'Z0  I $ P($G(^(Z0, 0)),U,2)=" " S DA(2)= IBIFN,DA(1 )=Z,DA=Z0, DIK="^DGCR (399,"_DA( 2)_",""CP" ","_DA(1)_ ",""MOD"", " D ^DIK
  2805    Q
  2806   CODQ K %DT ,DGPROC,DI C,DIE,DR,D GPROCDT,IB PROCP,DLAY GO
  2807    K IBFT,DG NOADD,DGAD DVST,DGCPT ,DGCPTUP,I BZTYPE,DGC PTNEW
  2808    Q
  2809    ;
  2810   DELPROC ;  Remove the  selected  procedure,  because o f inactive  status (c ancel sele ction)
  2811    W !!,*7," The Proced ure code i s inactive  on ",$$DA T1^IBOUTL( DGPROCDT), "."
  2812    W !,"Plea se select  another Pr ocedure."
  2813    S DA(1)=I BIFN,DA=+Y ,DIK="^DGC R(399,"_IB IFN_",""CP "","
  2814    D ^DIK
  2815    Q
  2816    ;
  2817   DELADD N Z ,Z0,DA,DIK ,X,Y
  2818    S DA(1)=I BIFN
  2819    ;Delete r eferences  to proc on  rev codes
  2820    S Z=0 F   S Z=$O(^DG CR(399,IBI FN,"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  DIE="^DGC R(399,"_DA (1)_",""RC "",",DA=Z, DR=".11/// @;.15///@" _$S($P(Z0, U,8):"",1: ";.08////1 ") D ^DIE
  2821    S DIK="^D GCR(399,"_ DA(1)_","" CP""," F D A=0:0 S DA =$O(^DGCR( 399,DA(1), "CP",DA))  Q:'DA  D ^ DIK
  2822    S DGRVRCA L=1
  2823    Q
  2824    ;
  2825   DTMES ;Mes sage if pr ocedure da te not in  date range
  2826    Q:'$D(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"U" ))  S DGNO DUU=^("U")
  2827    G:X'<$P(D GNODUU,"^" )&(X'>$P(D GNODUU,"^" ,2)) DTMES Q
  2828    W *7,!!?3 ,"Date mus t be withi n STATEMEN T COVERS F ROM and ST ATEMENT CO VERS TO pe riod."
  2829    S Y=$P(DG NODUU,"^")  X ^DD("DD ")
  2830    W !?3,"En ter a date  between " ,Y," and "  S Y=$P(DG NODUU,"^", 2) X ^DD(" DD") W Y,!
  2831    K X,Y
  2832   DTMESQ K D GNODUU Q
  2833    ;
  2834   CODHLP ;Di splay Addi tional Pro cedure cod es
  2835    N I,J,Y,I BMOD
  2836    I '$O(^DG CR(399,IBI FN,"CP",0) ) W !!?5," No Codes E ntered!",!  Q
  2837    W ! F I=0 :0 S I=$O( ^DGCR(399, IBIFN,"CP" ,I)) Q:'I   S Y=$G(^( I,0)) S Z= $$PRCNM^IB CSCH1($P(Y ,"^",1),$P (Y,"^",2))  W !?5,$E( $P(Z,"^",2 ),1,33),?4 0,"- ",$P( Z,"^") D
  2838    . N IBY
  2839    . S IBY=$ P(Y,U,2)
  2840    . S IBMOD =$$GETMOD^ IBEFUNC(IB IFN,I,1)
  2841    . I IBMOD '="" S IBM OD="/"_IBM OD W IBMOD
  2842    . W ?60," Date: " S  Y=IBY D DT ^DIQ
  2843    W !
  2844    ;
  2845    K Z Q
  2846    ;
  2847   DICV 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:"")
  2848    Q
  2849    ;
  2850   DEFDIV(IBI FN) ; Find  default d ivision fo r bill IBI FN
  2851    Q $P($G(^ DG(40.8,+$ P($G(^DGCR (399,IBIFN ,0)),U,22) ,0)),U)
  2852    ;
  2853   ADDTNL(IBI FN,DA) ;
  2854    N DR,IBOK ,X,Y,DIR
  2855    S IBOK=1
  2856    S DR="19T ;50.09T;50 .08T" D ^D IE  ; WCJ; IB*2.0*488  Added Ts
  2857    ;I '($$FT ^IBCEF(IBI FN)'=3&($$ INPAT^IBCE F(IBIFN)))  D ATTACH   ; DEM;432  - Prompt  for Attach ment Contr ol Number.
  2858    I '($$FT^ IBCEF(IBIF N)=3&($$IN PAT^IBCEF( IBIFN))) D  ATTACH  ;  DEM;432 -  Prompt fo r Attachme nt Control  Number.
  2859    I $D(Y) S  IBOK=0 G  ADDTNLQ
  2860    ;/Beginni ng of IB*2 .0*488 (vd )
  2861    ;S DIR("B ")="NO",DI R("A")="ED IT CMS-150 0 SPECIAL  PROGRAM FI ELDS and B OX 19?: ", DIR("A",1) =" ",DIR(0 )="YA"
  2862    ;S DIR("? ",1)="Resp ond YES on ly if you  need to ad d/edit dat a for chir opractic v isits,"
  2863    ;S DIR("? ")="EPSDT  care, or i f billing  for HOSPIC E and atte nding is n ot a hospi ce employe e."
  2864    ;D ^DIR K  DIR
  2865    ;I Y'=1 S  IBOK=0 G  ADDTNLQ
  2866    ;S DR="W  !,""  <<EP SDT>>"";50 .07;W !!," "  <<HOSPI CE>>"";50. 03"
  2867    S DR="50. 07T;50.03T "   ;WCJ;I B*2.0*488  added Ts
  2868    ;/End of  IB*2.0*488  (vd)
  2869    D ^DIE
  2870    W !
  2871   ADDTNLQ Q  IBOK
  2872    ;
  2873   XTRA1(Y) ;
  2874    K Y
  2875    Q
  2876    ;
  2877   SPCUNIT(IB IFN,DA) ;  return fie lds for sp ecial unit s if appli cable, in  DR form
  2878    N IB0,IBC PT,IBDR,IB CT,IBFT,DF N S IBDR=" "
  2879    S IB0=$G( ^DGCR(399, +$G(IBIFN) ,0)),IBCT= $P(IB0,U,2 7),IBFT=$P (IB0,U,19) ,DFN=$P(IB 0,U,2)
  2880    S IBCPT=$ G(^DGCR(39 9,+$G(IBIF N),"CP",+$ G(DA),0))  I IBCPT'[" ICPT" G SP CUNTQ
  2881    I +$$ITMU NIT^IBCRU4 (+IBCPT,5, IBCT) S IB DR="15;" D  SROMIN^IB CU74(IBIFN ,DA) G SPC UNTQ ; min utes
  2882    I +$$ITMU NIT^IBCRU4 (+IBCPT,4, IBCT) S IB DR="21;" G  SPCUNTQ ;  miles
  2883    I +$$ITMU NIT^IBCRU4 (+IBCPT,6, IBCT) S IB DR="22//"_ $$OBSHOUR^ IBCU74(DFN ,$P(IBCPT, U,2))_";"  G SPCUNTQ  ; hours
  2884    I +IBFT=2 ,$P($G(^IB E(353.2,+$ P(IBCPT,U, 10),0)),U, 2)="ANESTH ESIA" S IB DR="15;" ;  minutes
  2885   SPCUNTQ Q  IBDR
  2886    ;
  2887   ATTACH ; D EM;432 - A ttachment  control nu mber.
  2888    ; Ask if  user wants  to enter  Attachment  Control N umber.
  2889    N DIR,X,Y ,DA,DIE,DR
  2890    S DIR("A" )="Enter A ttachment  Control Nu mber"
  2891    S DIR(0)= "Y",DIR("B ")="NO"
  2892    D ^DIR
  2893    Q:'Y
  2894    ; User ch ose to ent er Attachm ent Contro l Number.
  2895    ; User en ters Attac hment Cont rol fields .
  2896    S DA(1)=I BIFN,DA=IB PROCP
  2897    S DIE="^D GCR(399,"_ DA(1)_","" CP"","
  2898    S DR="71R eport Type ;72Report  Transmissi on Method; 70Attachme nt Control  Number"
  2899    D ^DIE
  2900    Q
  2901    ;
  2902   NOCPROC(IB PROCSV,IBC ODE,IBDATE ) ; MRD;IB *2.0*516 -  Function  to determi ne if proc edure is a n
  2903    ; "NOC".  Returns '1 ' if "NOC"  procedure , otherwis e '0'.
  2904    ;
  2905    N IBNOC,I BPROCEX,IB PROCIN,IBP ROCNM,IBX, IBLINES,IB STR,IBEND, IBLN
  2906    S IBNOC=0
  2907    I $G(IBPR OCSV)="" G  NOCPROCQ
  2908    I $G(IBCO DE)="" G N OCPROCQ
  2909    I $G(IBDA TE)'?7N G  NOCPROCQ
  2910    S IBPROCI N=$P($P(IB PROCSV,U,2 ),";") ;pa rsing out  the IEN
  2911    I IBPROCI N="" G NOC PROCQ
  2912    ;
  2913    ; If proc edure code  ends in ' 99', quit  with a '1' .
  2914    ;
  2915    I $E(IBCO DE,$L(IBCO DE)-1,$L(I BCODE))=99  S IBNOC=1  G NOCPROC Q ;Does co de end wit h 99? If s o NOC
  2916    ;
  2917    ; Pull pr ocedure na me, then c heck to se e if it co ntains one  of the
  2918    ; specifi ed strings .
  2919    ;
  2920    S IBPROCN M=$$CPT^IC PTCOD(IBCO DE,IBDATE)
  2921    S IBPROCN M=$P(IBPRO CNM,U,3)
  2922    I IBPROCN M'="",($$N OC(IBPROCN M)) S IBNO C=1 G NOCP ROCQ ; Doe s external  match NOC  strings?  if so NOC
  2923    ;
  2924    ;Does arr ay strings  match any  of the sp ecified st rings
  2925    S IBLINES =$$CPTD^IC PTCOD(IBCO DE,"IBINFO ",,IBDATE)  ;get numb er of line s/array of  lines
  2926    S IBEND=1  S:IBLINES >1 IBEND=I BLINES-1 ; set up cou nter for l oop
  2927    F IBLN=1: 1:IBEND D   Q:IBNOC=1   ;loop th rough arra y so we ca n check if  node valu es = NOC
  2928    . N IBSTR  S IBSTR=$ $TM($G(IBI NFO(IBLN)) )_" "_$$TM ($G(IBINFO (IBLN+1))) _" " ;Buil d strings  for NOC co mparison
  2929    . S IBNOC =$$NOC(IBS TR) ;is cu rrent comb ination of  strings a  NOC?
  2930    . Q
  2931    ;
  2932   NOCPROCQ ;  Quit out.
  2933    K IBINFO  ;killing t he array m ade in CPT D^ICPTCOD
  2934    Q IBNOC
  2935    ;
  2936   NOC(IBTEXT ) ; Quit w ith '1' if  IBTEXT co ntains one  of the sp ecified st rings.
  2937    ;
  2938    S IBTEXT= $TR(IBTEXT ,"abcdefgh ijklmnopqr stuvwxyz", "ABCDEFGHI JKLMNOPQRS TUVWXYZ")
  2939    ;
  2940    I IBTEXT[ "NOT OTHER WISE" Q 1
  2941    I IBTEXT[ "NOT ELSEW HERE" Q 1
  2942    I IBTEXT[ "NOT LISTE D" Q 1
  2943    I IBTEXT[ "UNLISTED"  Q 1
  2944    I IBTEXT[ "UNSPECIFI ED" Q 1
  2945    I IBTEXT[ "UNCLASSIF IED" Q 1
  2946    I IBTEXT[ "NON-SPECI FIED" Q 1
  2947    I IBTEXT[ "NOS " Q 1
  2948    I IBTEXT[ "NOS;" Q 1
  2949    I IBTEXT[ "NOS." Q 1
  2950    I IBTEXT[ "NOS," Q 1
  2951    I IBTEXT[ "NOS/" Q 1
  2952    I IBTEXT[ "(NOS)" Q  1
  2953    I IBTEXT[ "NOC " Q 1
  2954    I IBTEXT[ "NOC;" Q 1
  2955    I IBTEXT[ "NOC." Q 1
  2956    I IBTEXT[ "NOC," Q 1
  2957    I IBTEXT[ "NOC/" Q 1
  2958    I IBTEXT[ "(NOC)" Q  1
  2959    ;
  2960    ; Check i f last thr ee charcte rs are 'NO C' or 'NOS '.
  2961    ;
  2962    S IBTEXT= $E(IBTEXT, $L(IBTEXT) -2,$L(IBTE XT))
  2963    Q 0
  2964    ;
  2965   TM(IBX,IBY ) ; Trim C haracter Y  - Default  " "
  2966    S IBX=$G( IBX) Q:IBX ="" IBX  S  IBY=$G(IB Y) S:'$L(I BY) IBY="  "
  2967    F  Q:$E(I BX,1)'=IBY   S IBX=$E (IBX,2,$L( IBX))
  2968    F  Q:$E(I BX,$L(IBX) )'=IBY  S  IBX=$E(IBX ,1,($L(IBX )-1))
  2969    Q IBX
  2970    ;
  2971   ORALCAV(FL D) ;EP;IB* 2.0*592
  2972    ; Diction ary Screen  function  called fro m Procedur es Oral Ca vity Field s:
  2973    ; 399.030 4.90.01, 3 99.0304.90 .02, 399.0 304.90.03,  399.0304. 90.04, 399 .0304.90.0
  2974    ; Prevent s the same  Oral Cavi ty from be ing select ed more th an once.
  2975    ; Input:  FLD - Fiel d # of the  field bei ng checked
  2976    ; DA - IE N of the S ervice Lin e Multiple  being edi ted
  2977    ; DA(1) -  IEN of th e 399 entr y being ed ited
  2978    ; Y - Int ernal Valu e of the u ser respon se
  2979    ; Returns : 1 - Data  input by  the user i s valid, 0  otherwise
  2980    N NDE,RTN
  2981    S NDE=$G( ^DGCR(399, DA(1),"CP" ,DA,"DEN") )
  2982    S RTN=1 ;  Assume Va lid Input
  2983    Q:Y="" 1  ; No value  entered
  2984    ;
  2985    ; Make su re there a re no dupl icates
  2986    I FLD=90. 01 D  Q RT N
  2987    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2988    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2989    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2990    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2991    I FLD=90. 02 D  Q RT N
  2992    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2993    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  2994    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  2995    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  2996    I FLD=90. 03 D  Q RT N
  2997    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  2998    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  2999    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3000    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3001    I FLD=90. 04 D  Q RT N
  3002    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  3003    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3004    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3005    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3006    I FLD=90. 05 D  Q RT N
  3007    . I $P(ND E,"^",1)=Y  S RTN=0 Q
  3008    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3009    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3010    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3011    Q RTN
  3012    ;
  3013   TOOTHS(FLD ) ;EP;IB*2 .0*592
  3014    ; Diction ary Screen  function  called fro m Dental S ervice Lin e Tooth fi elds:
  3015    ; 399,91, .02, 399,9 1,.03, 399 ,91,.04, 3 99,91,.05,  399,91,.0 6. Prevent s the 
  3016    ; same To oth Surfac e from bei ng selecte d more tha n once.
  3017    ; Input:  FLD - Fiel d # of the  field bei ng checked
  3018    ; DA - To oth Surfac e multiple  IEN
  3019    ; DA(1) -  Service L ine multip le IEN
  3020    ; DA(2) -  IEN of th e 399 entr y being ed ited
  3021    ; Y - Int ernal Valu e of the u ser respon se
  3022    ; Returns : 1 - Data  input by  the user i s valid, 0  otherwise
  3023    N NDE,RTN
  3024    S NDE=$G( ^DGCR(399, DA(2),"CP" ,DA(1),"DE N1",DA,0))
  3025    S RTN=1 ;  Assume Va lid Input
  3026    Q:Y="" 1  ; No value  entered
  3027    ;
  3028    ; Make su re there a re no dupl icates
  3029    I FLD=.02  D  Q RTN
  3030    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3031    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3032    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3033    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  3034    I FLD=.03  D  Q RTN
  3035    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3036    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3037    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3038    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  3039    I FLD=.04  D  Q RTN
  3040    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3041    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3042    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3043    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  3044    I FLD=.05  D  Q RTN
  3045    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3046    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3047    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3048    . I $P(ND E,"^",6)=Y  S RTN=0 Q
  3049    I FLD=.06  D  Q RTN
  3050    . I $P(ND E,"^",2)=Y  S RTN=0 Q
  3051    . I $P(ND E,"^",3)=Y  S RTN=0 Q
  3052    . I $P(ND E,"^",4)=Y  S RTN=0 Q
  3053    . I $P(ND E,"^",5)=Y  S RTN=0 Q
  3054    Q RTN
  3055    ;
  3056  
  3057   IBCU75 – U se DR Prom pting to p rompt user  for CMN i nformation  (called b y IBCU7)
  3058   Routines
  3059   Activities
  3060   Routine Na me
  3061   IBCU75
  3062   Enhancemen t Category
  3063    New
  3064    Modify
  3065    Delete
  3066    No Change
  3067   RTM
  3068  
  3069   Related Op tions
  3070   None
  3071   Related Ro utines
  3072   Routines “ Called By”
  3073   Routines “ Called”   
  3074  
  3075  
  3076  
  3077  
  3078   Data Dicti onary (DD)  Reference s
  3079  
  3080   Related Pr otocols
  3081   None
  3082   Related In tegration  Control Re gistration s (ICRs)
  3083   None
  3084   Data Passi ng
  3085    Input
  3086    Output Re ference
  3087    Both
  3088    Global Re ference
  3089    Local
  3090   Input Attr ibute Name  and Defin ition
  3091   Name:
  3092   Definition :
  3093   Output Att ribute Nam e and Defi nition
  3094   Name:
  3095   Definition :
  3096   Current Lo gic
  3097   IBCU75 ;AL B/JRA - IN TERCEPT SC REEN INPUT  OF PROCED URE CODES  (ENTER CMN  INFO) ;23 -Apr-18
  3098    ;;2.0;INT EGRATED BI LLING;**60 8**;23-Apr -18
  3099    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3100    ;
  3101    Q
  3102    ;
  3103   CMN(IBXIEN ,IBPROCP)  ;JRA;IB*2. 0*608 Prom pt user fo r CMN info
  3104    ;Input: I BXIEN  = I nternal bi ll/claim n umber
  3105    ;       I BPROCP = P rocedure l ine subscr ipt in ^DG CR
  3106    ;
  3107    Q:('$G(IB XIEN)!('$G (IBPROCP)) )
  3108    N ABGMSG, ABGPO2,CER TDT,CERTYP ,CHNGFRM,C MNNODE,CMN REQ,CMSG,D A,DIC,DIE, DIR,DGLB,D R,DRTAG,DT OLD,EDIT,E VNTDT,FIEN ,FNAM,FORM ,FRMTAG
  3109    N FRMTYP, HT,HTOLD,I ,IBPEB,WTO LD,LKGLB,L PM4ABG,LPM 4SAT,MSG,N ODE0,O2SAT ,OK,OLDVAL ,PROCA,PRO CB,QUIT,RR DT,TDY,THE RPYDT,X,Y
  3110    S DGLB="^ TMP(""CMN" ",$J)" K @ DGLB
  3111    S LKGLB=" ^DGCR(399, "_IBXIEN_" )" L +@LKG LB:0 I '$T  W !,$C(7) ,"Another  user is ed iting this  entry --  EXITING" H  2 Q
  3112    S EVNTDT= $$FMTE^DIL IBF($G(IBD T),"5U")   ;Get the E vent Date  - will be  the defaul t for seve ral date f ields.
  3113    S TDY=$$H TFM^DILIBF (+$H)
  3114    S ABGMSG= """ABG PO2 "" and/or  ""O2 Satur ation"" Te st(s) REQU IRED"
  3115    S DA=IBPR OCP,DA(1)= IBXIEN,DIE ="^DGCR(39 9,"_IBXIEN _",""CP"", "
  3116    ;Set FORM  array of  CMN Data N odes (D399 .6 field 3 ) indexed  by CMN For m Type ien
  3117    S FNAM=""  F  S FNAM =$O(^IBE(3 99.6,"B",F NAM)) Q:FN AM=""  S F IEN=+$O(^I BE(399.6," B",FNAM,"" )) I FIEN  D
  3118    . S FORM( FIEN)=$P($ G(^IBE(399 .6,FIEN,0) ),U,4) K:$ TR(FORM(FI EN)," ")=" " FORM(FIE N)
  3119    I $D(FORM )'>1 S FOR M(1)="CMN- 484",FORM( 2)="CMN-10 126"  ;Def ault nodes  for CMN d ata
  3120    S DIE("NO ^")="BACKO UTOK"
  3121    S CMNREQ( "MSG")="If  ""CMN Req uired?"" i s changed  to ""NO"",  existing  CMN data w ill be del eted!"
  3122    S FRMTYP( "MSG")="Ch anging the  Form Type  will dele te any dat a specific  to the cu rrent Form  Type!"
  3123    S CERTYP( "MSG")="Yo u are chan ging the C ertificati on Type!"
  3124    S CERTYP( "MSGI")="C hanging Ce rtificatio n Type to  ""I"" will  delete "" Recertific ation/Revi sion Date! """
  3125    D CMNREQ
  3126    S QUIT=0  F  D  Q:QU IT
  3127    . D ^DIE
  3128    . S CMNRE Q=$G(CMNRE Q),FRMTYP= $G(FRMTYP) ,CERTYP=$G (CERTYP)
  3129    . S CMNRE Q=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,23,"I ") I CMNRE Q=0 S QUIT =1 Q
  3130    . S FRMTY P=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24,"I ")
  3131    . S CERTY P=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.01 ,"I")
  3132    . I FRMTY P,CERTYP'= "" S QUIT= 1 Q
  3133    . I CMNRE Q="" W $C( 7),!,?3,"" "CMN Requi red?"" is  a REQUIRED  field!" D  CMNREQ Q
  3134    . S MSG=" "
  3135    . I FRMTY P="" S MSG ="""Form T ype"" and  ""Certific ation Type "" are REQ UIRED!",DR TAG="CMNRE Q"
  3136    . E  I CE RTYP="" S  MSG="""Cer tification  Type"" is  REQUIRED! ",DRTAG="C MNREQ"
  3137    . I MSG]" " S DR="", MSG=MSG_$C (13,10)_"    ** To ex it, set "" CMN Requir ed?"" to " "NO""" W $ C(7),!,?3, MSG D @DRT AG Q
  3138    . S QUIT= 1
  3139    ;
  3140    ;If CMN i s not requ ired, dele te all CMN  data that  may be as sociated w ith this p rocedure &  exit
  3141    I $G(CMNR EQ)=0 D  Q
  3142    . S FIEN= "" F  S FI EN=$O(FORM (FIEN)) Q: FIEN=""  I  FORM(FIEN )]"" D
  3143    . . S CMN NODE="^DGC R(399,"_IB XIEN_",""C P"","_IBPR OCP_","""_ FORM(FIEN) _""")" K @ CMNNODE
  3144    . S CMNNO DE="^DGCR( 399,"_IBXI EN_",""CP" ","_IBPROC P_",""CMN" ")" K @CMN NODE S @CM NNODE=0
  3145    ;
  3146    ;If user  selected F orm Type w e need to  remove dat a that may  exist for  any other  Form Type .
  3147    I $G(FRMT YP) S FIEN ="" F  S F IEN=$O(FOR M(FIEN)) Q :FIEN=""   I FIEN'=FR MTYP D
  3148    . S CMNNO DE="^DGCR( 399,"_IBXI EN_",""CP" ","_IBPROC P_","""_FO RM(FIEN)_" "")" K @CM NNODE
  3149    ;
  3150    I $G(CERT YP)="I" D  SETFLD(24. 07,"@")  ; If "Certif ication Ty pe" is "IN ITIAL" del ete "Recer tification /Revision  Date"
  3151    ;
  3152    I (($D(ED IT)&($G(ED IT)'="Y")) !(X=""!('$ G(CMNREQ)! ('$G(FRMTY P)!($G(CER TYP)=""))) )) Q
  3153    ;
  3154    S FRMTAG= "DR"_$S($G (FORM(FRMT YP))[484:4 84,1:10126 )  ;Set ta g to call  to set DR  with form- specific l ogic
  3155    D DRCOMM
  3156    ;
  3157    ;Prompt u ser for re maining qu estions &  check for  missing re quired fie lds
  3158    S (QUIT,U PCT)=0,DRT AG(1)="" F   D  Q:QUI T
  3159    . D ^DIE
  3160    . K MSG S  MSG=0
  3161    . S DRTAG =""
  3162    . S CERTY P=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.01 ,"I")
  3163    . S HT=$$ CMNDATA^IB CEF31(IBXI EN,IBPROCP ,24.02,"I" )
  3164    . S THERP YDT=$$CMND ATA^IBCEF3 1(IBXIEN,I BPROCP,24. 05,"I")
  3165    . S CERTD T=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.06 ,"I")
  3166    . S RRDT= $$CMNDATA^ IBCEF31(IB XIEN,IBPRO CP,24.07," I")
  3167    . I 'CERT DT S MSG=M SG+1,MSG(M SG)="""Las t Certific ation Date """ S DRTA G="DRCOMM"
  3168    . I 'RRDT ,CERTYP'=" I" S MSG=M SG+1,MSG(M SG)="""Rec ertificati on/Revisio n Date"""  S:DRTAG=""  DRTAG="RR DT"
  3169    . I 'THER PYDT S MSG =MSG+1,MSG (MSG)="""D ate Therap y Started" "" S:DRTAG ="" DRTAG= "STRTDT"
  3170    . I FORM( FRMTYP)[10 126 D
  3171    . . I $$C MNDATA^IBC EF31(IBXIE N,IBPROCP, 24.217,"I" )="" S MSG =MSG+1,MSG (MSG)="""I s this for  Parentera l nutritio n, Enteral  nutrition , or Both? """ S:DRTA G="" DRTAG ="DR10126"
  3172    . I +MSG  D  Q
  3173    . . S:X=" " UPCT=UPC T+1 I UPCT >1,DRTAG=D RTAG(1) S  QUIT=1 Q
  3174    . . S DR= "" W $C(7)  F I=1:1:M SG W !,?3, MSG(I)_" i s REQUIRED !"
  3175    . . W !,? 3,"** Exit ing now wi ll leave r equired fi elds unans wered."
  3176    . . W !,? 3,"** If y ou must ex it, enter  '^' again. "
  3177    . . S DRT AG(1)=DRTA G D @DRTAG
  3178    . S QUIT= 1
  3179    ;
  3180    ;Delete d ates assoc iated with  result fi elds that  were delet ed
  3181    I $D(@DGL B)>1 D
  3182    . N FLD
  3183    . S FLD=" " F  S FLD =$O(@DGLB@ (FLD)) Q:F LD=""  D S ETFLD(FLD, "@")
  3184    . K @DGLB
  3185    Q
  3186    ;
  3187   CMNREQ ; S et DR with  logic for  1st 3 fie lds: "CMN  Required?" , "Form Ty pe" and "C ertificati on Type"
  3188    S DR="@23 ;S CMNREQ( ""OLD"")=$ $CMNDATA^I BCEF31(IBX IEN,IBPROC P,23,""I"" );23R~T//N O;S CMNREQ =X I 'X,'C MNREQ(""OL D"") S Y=" "@999"";"
  3189    S DR=DR_" I CMNREQ=0 ,CMNREQ("" OLD"")=1 S  FRM=$$CMN DATA^IBCEF 31(IBXIEN, IBPROCP,24 ,""I"") S: 'FRM OK=1  S:FRM OK=$ $USEROK^IB CU75(23,1, CMNREQ(""M SG""))"
  3190    S DR=DR_"  S:OK Y="" @999"" I ' OK S Y=""@ 23"";"
  3191   FRMTYP ;En try point  to set DR  with logic  for "Form  Type" and  "Certific ation Type " fields i n preparat ion for re -prompting .
  3192    S DR=DR_" @24;S DIC( 0)=""N"" S  FRMTYP("" OLD"")=$$C MNDATA^IBC EF31(IBXIE N,IBPROCP, 24,""I""); 24R~T;S FR MTYP=X I F RMTYP(""OL D"")]"""", FRMTYP]""" ""
  3193    S DR=DR_" ,FRMTYP'=F RMTYP(""OL D"") S OK= $$USEROK^I BCU75(24,F RMTYP(""OL D""),FRMTY P(""MSG"") ) S:OK CHN GFRM=1 S:' OK Y=""@24 "";"
  3194    S DR=DR_" I $G(CHNGF RM)!($$CMN DATA^IBCEF 31(IBXIEN, IBPROCP,24 .01,""I"") ="""") D C OPYCMN^IBC U75(IBXIEN ,IBPROCP,F RMTYP);"
  3195    S DR=DR_" I $$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.01 ,""I"")]"" "",'$G(CHN GFRM) R !, ""Edit CMN  Informati on for thi s Procedur e? NO// "" ,EDIT S ED IT=$E($ZCO NVERT(EDIT ,""U"")) "
  3196    S DR=DR_" W:(EDIT]"" ""&(EDIT'= ""^"")) ""   ""_$S(ED IT=""Y"":" "YES"",1:" "NO"") I E DIT'=""Y""  S Y=""@99 9"";"
  3197   CERTYP ;En try point  to set DR  with logic  for "Cert ification  Type" fiel d in prepa ration for  re-prompt ing.
  3198    S DR=DR_" @01;S CERT YP(""OLD"" )=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.01 ,""I"");24 .01R~T//IN ITIAL"
  3199    S DR=DR_" ;S CERTYP= X I CERTYP (""OLD"")] """",CERTY P]"""",CER TYP'=CERTY P(""OLD"") "
  3200    S DR=DR_"  S CMSG=$S (CERTYP="" I"":CERTYP (""MSGI"") ,1:CERTYP( ""MSG""))"
  3201    S DR=DR_"  S OK=$$US EROK^IBCU7 5(24.01,CE RTYP(""OLD ""),CMSG)  S:'OK Y="" @01"";@999 ;"
  3202    Q
  3203    ;
  3204   DRCOMM ;Se t DR with  logic for  the remain ing fields  common to  all form  types
  3205    S DR="@06 ;S DTOLD=$ $CMNDATA^I BCEF31(IBX IEN,IBPROC P,24.06,"" I"");24.06 R~T//"_EVN TDT_";D DT CHK^IBCU75 (X,TDY,""0 6"",$G(DTO LD));"
  3206    S DR=DR_" I CERTYP=" "I"" S @DG LB@(24.07) ="""",Y="" @02"";"
  3207   RRDT ;Entr y point to  set DR wi th logic f or "Recert ification/ Revision D ate"... fi elds in pr eparation  for re-pro mpting.
  3208    S DR=DR_" @07;S DTOL D=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.07 ,""I"");24 .07R~T//"_ EVNTDT_";D  DTCHK^IBC U75(X,TDY, ""07"",$G( DTOLD));"
  3209    S DR=DR_" @02;S HTOL D=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.02 ,""I"");24 .02T;I X>9 6 S OK=$$U SEROK^IBCU 75(24.02,H TOLD,""Pat ient is ov er 8 feet  tall!"")"
  3210    S DR=DR_"  I 'OK S Y =""@02"";@ 03;S WTOLD =$$CMNDATA ^IBCEF31(I BXIEN,IBPR OCP,24.03, ""I"");24. 03T;I X>50 0 S OK=$$U SEROK^IBCU 75(24.03,W TOLD,"
  3211    S DR=DR_" ""Patient  is over 50 0 pounds!" ") I 'OK S  Y=""@03"" ;24.04T;"
  3212   STRTDT ;En try point  to set DR  with logic  for "Date  Therapy S tarted"...  fields in  preparati on for re- prompting.
  3213    S DR=DR_" @05;S DTOL D=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.05 ,""I"");24 .05R~T//"_ EVNTDT_";D  DTCHK^IBC U75(X,TDY, ""05"",$G( DTOLD));@0 8;24.08T// N;"
  3214    D @FRMTAG
  3215    Q
  3216    ;
  3217   DR484 ;Set  DR with l ogic speci fic for fo rm CMN-484
  3218    S DR=DR_" @100;24.1T ;S ABGPO2= X;@102;24. 102T;S O2S AT=X;I ABG PO2="""",O 2SAT=""""  S Y=""@104 "";"
  3219    S DR=DR_" @103;S DTO LD=$$CMNDA TA^IBCEF31 (IBXIEN,IB PROCP,24.1 03,""I""); 24.103T;D  DTCHK^IBCU 75(X,TDY,1 03,$G(DTOL D));"
  3220    S DR=DR_" @104;I (AB GPO2<56!(A BGPO2>59)) ,(O2SAT'=8 9) S @DGLB @(24.104)= """",@DGLB @(24.105)= """""
  3221    S DR=DR_" ,@DGLB@(24 .106)="""" ,Y=""@107" ";24.104T/ /NO;24.105 T//NO;24.1 06T//NO;@1 07;24.107T ;24.108T;2 4.109T;24. 11T;I X'>4  S @DGLB@( 24.111)="" """
  3222    S DR=DR_" ,@DGLB@(24 .113)="""" ,@DGLB@(24 .114)="""" ,Y=""@115" ";24.111T; S ABG4LPM= X;"
  3223    S DR=DR_" @113;24.11 3T;I 'ABG4 LPM,'X S Y =""@115"", @DGLB@(24. 114)=""""; "
  3224    S DR=DR_" @114;S DTO LD=$$CMNDA TA^IBCEF31 (IBXIEN,IB PROCP,24.1 14,""I""); 24.114T;D  DTCHK^IBCU 75(X,TDY,1 14,$G(DTOL D));@115;2 4.115T;@99 9;"
  3225    Q
  3226    ;
  3227   DR10126 ;S et DR with  logic spe cific to t he CMN-101 26
  3228    S DR=DR_" @217;S IBP EB(""OLD"" )=$$CMNDAT A^IBCEF31( IBXIEN,IBP ROCP,24.21 7,""I"");2 4.217R~T// P;S IBPEB= X I IBPEB( ""OLD"")]" """,IBPEB] """",IBPEB (""OLD"")' =IBPEB "
  3229    S DR=DR_" S OK=$$USE ROK^IBCU75 (24.217,IB PEB(""OLD" "),""You a re changin g the nutr ition type !"") S:'OK  Y=""@217" ";I $G(IBP EB)=""P""  S Y=""@206 "" "
  3230    S DR=DR_" N I F I=24 .201:.001: 24.205,24. 218,24.219  S @DGLB@( I)="""";24 .201T;24.2 02T;"
  3231    S DR=DR_" 24.204T;I  '+X S Y="" @205"",@DG LB@(24.203 )="""" I $ $CMNDATA^I BCEF31(IBX IEN,IBPROC P,24.219)] """" S Y=" "@219"";"
  3232    S DR=DR_" 24.203T;I  '+X S Y="" @205"" I $ $CMNDATA^I BCEF31(IBX IEN,IBPROC P,24.219)] """" S Y=" "@219"";"
  3233    S DR=DR_" @219;24.21 9T;I '+X S  Y=""@205" ",@DGLB@(2 4.218)=""" ";"
  3234    S DR=DR_" 24.218T;@2 05;24.205T ;@206;24.2 06T;I $G(I BPEB)=""E" " S Y=""@9 99"" "
  3235    S DR=DR_" N I F I=24 .207:.001: 24.216 S @ DGLB@(I)=" """;"
  3236    S DR=DR_" 24.207T;24 .208T;24.2 09T;24.21T ;24.211T;2 4.212T;24. 213T;24.21 5T;24.216T ;@214;24.2 14T;@999;"
  3237    Q
  3238    ;
  3239   COPYCMN(IB XIEN,IBPRO CP,FRMTYP)  ;Copy CMN  informati on from la st procedu re entered  that has  it to curr ent proced ure
  3240    ;Input: I BXIEN  = I nternal bi ll/claim n umber
  3241    ;       I BPROCP = P rocedure l ine subscr ipt
  3242    ;       F RMTYP  = C MN Form Ty pe ien
  3243    ;
  3244    N DONE
  3245    S DONE=0
  3246    Q:('$G(IB XIEN)!('$G (IBPROCP)! ('$G(FRMTY P))))
  3247    N FRMND,F RMNDI,IBPR OC,IBXSAVE ,Z
  3248    S FRMNDI= FORM(FRMTY P)
  3249    D CMNDEX^ IBCEF31(IB XIEN,.IBXS AVE)
  3250    S Z="" F   S Z=$O(IB XSAVE("CMN DEX",Z),-1 ) Q:'Z  S  IBPROC=+IB XSAVE("CMN DEX",Z) I  IBPROCP,IB PROC'=IBPR OCP D  Q:D ONE
  3251    . Q:('$D( ^DGCR(399, IBXIEN,"CP ",IBPROC," CMN"))!('$ D(^DGCR(39 9,IBXIEN," CP",IBPROC ,FRMNDI))) )
  3252    . S FRMND =$O(^DGCR( 399,IBXIEN ,"CP",IBPR OC,"CMN"))  Q:(FRMND= ""!(FRMND' =FRMNDI))
  3253    . S ^DGCR (399,IBXIE N,"CP",IBP ROCP,"CMN" )=^DGCR(39 9,IBXIEN," CP",IBPROC ,"CMN")
  3254    . S ^DGCR (399,IBXIE N,"CP",IBP ROCP,FRMND )=^DGCR(39 9,IBXIEN," CP",IBPROC ,FRMND)
  3255    . S DONE= 1
  3256    Q 
  3257    ;
  3258   USEROK(FLD ,OLDVAL,MS G) ;JRA;IB *2.0*608 P rompt user  if OK to  change fie ld value
  3259    ;Input: F LD    =  F ield for w hich we ar e asking t he user to  confirm t he change
  3260    ;       O LDVAL =  V alue of th e field be fore user  changed
  3261    ;       M SG    =  W arning mes sage to di splay to u ser regard ing the im plications  of the ch ange
  3262    ;
  3263    Q:'$G(FLD ) 0
  3264    N DIC,DIR ,X,Y
  3265    S OLDVAL= $G(OLDVAL)
  3266    W $C(7) I  $TR($G(MS G)," ")]""  W !,MSG
  3267    S DIR(0)= "Y",DIR("A ")="OK to  continue", DIR("B")=" NO" D ^DIR
  3268    I Y'=1 D  SETFLD(FLD ,OLDVAL)   ;Set field  back to o ld value i f user doe sn't want  to continu e
  3269    I Y=1 S X ="^"
  3270    Q Y
  3271    ;
  3272   SETFLD(FLD ,VAL) ;JRA ;IB*2.0*60 8 Set/Dele te field d ata w/out  user promp ting
  3273    ;Input: F LD = Field  to set/de lete
  3274    ;       V AL = Value  to set FL D to (Note : '@' will  delete fi eld value)
  3275    ;
  3276    Q:('$G(FL D)!($G(VAL )=""))
  3277    N DIE,DI, DL,DP,DQ,D R,X,Y
  3278    S DIE="^D GCR(399,"_ IBXIEN_"," "CP"","
  3279    S DR=FLD_ "////"_VAL
  3280    D ^DIE
  3281    Q
  3282    ;
  3283   DTCHK(X,TD Y,TAG,DTOL D) ;JRA;IB *2.0*608 C heck if fu ture date  entered by  user
  3284    ;Input:   X     = Us er entry f or date fi eld (inter nal FileMa n date for mat)
  3285    ;         TDY   = To day's inte rnal FileM an date
  3286    ;         TAG   = Fi eld tag to  jump to i f user ent ers a futu re date (u sually re- prompt sam e date)
  3287    ;         DTOLD = Th e value of  the date  field prio r to user  edit
  3288    ;
  3289    Q:('$G(X) )!('$G(TAG ))
  3290    N FLD
  3291    S:$G(DTOL D)="" DTOL D="@"
  3292    S:'$G(TDY ) TDY=$$HT FM^DILIBF( +$H) Q:X'> TDY
  3293    ;User ent ered futur e date so  display er ror and ch ange date  back to pr evious val ue.
  3294    W $C(7),! ,?3,"Futur e dates no t allowed? ?"
  3295    S Y="@"_T AG
  3296    D SETFLD( "24."_TAG, DTOLD)  ;s et back to  prior dat e
  3297    Q
  3298    ;
  3299  
  3300   VIII)  Cre ate extrac t code for  to pull t he values  for the ne w CMN fiel ds:
  3301   IBCEF31
  3302   Routines
  3303   Activities
  3304   Routine Na me
  3305   IBCEF31
  3306   Enhancemen t Category
  3307    New
  3308    Modify
  3309    Delete
  3310    No Change
  3311   RTM
  3312  
  3313   Related Op tions
  3314   None
  3315   Related Ro utines
  3316   Routines “ Called By”
  3317   Routines “ Called”   
  3318  
  3319  
  3320  
  3321  
  3322   Data Dicti onary (DD)  Reference s
  3323  
  3324   Related Pr otocols
  3325   None
  3326   Related In tegration  Control Re gistration s (ICRs)
  3327   None
  3328   Data Passi ng
  3329    Input
  3330    Output Re ference
  3331    Both
  3332    Global Re ference
  3333    Local
  3334   Input Attr ibute Name  and Defin ition
  3335   Name:
  3336   Definition :
  3337   Output Att ribute Nam e and Defi nition
  3338   Name:
  3339   Definition :
  3340   Current Lo gic
  3341   IBCEF31 ;A LB/ESG - F ORMATTER S PECIFIC BI LL FLD FUN CTIONS - C ONT ;14-NO V-03
  3342    ;;2.0;INT EGRATED BI LLING;**15 5,296,349, 400,432,48 8,516,592* *;21-MAR-9 4;Build 25
  3343    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3344    ;
  3345    Q
  3346    ;
  3347   ALLTYP(IBI FN) ; retu rns codes  to transla te to ALL  ins types  on a bill
  3348    ; IBIFN =  ien of bi ll
  3349    N IBX,Z
  3350    F Z=1:1:3  S $P(IBX, U,Z)=$$INS TYP(IBIFN, Z)
  3351    ; IBX = p rimary cod e^secondar y code^ter tiary code
  3352    Q IBX
  3353    ;
  3354   INSTYP(IBI FN,SEQ) ;  Returns in surance ty pe code fo r an ins o n a bill
  3355    ; IBIFN =  ien of bi ll
  3356    ; SEQ = s equence (1 ,2,3) of i nsurance w anted - pr im, second , tert
  3357    ;       D efault is  current in surance co
  3358    ;
  3359    N IBA,Z
  3360    ;
  3361    I '$G(SEQ ) S SEQ=$$ COBN^IBCEF (IBIFN)
  3362    S Z=+$G(^ DGCR(399,I BIFN,"I"_S EQ))
  3363    ;Codes 1: HMO;2:COMM ERCIAL;3:M EDICARE;4: MEDICAID;5 :GROUP POL ICY;9:OTHE R
  3364    I Z D
  3365    . S IBA=$ P($G(^DIC( 36,Z,3)),U ,9)
  3366    . I $$MCR WNR^IBEFUN C(Z) S IBA =3   ; for ce Medicar e (WNR) de finition t o be corre ct
  3367    . I IBA=" " S IBA=5  ;Default i s group po licy - 5 i f blank
  3368    ;
  3369    Q $G(IBA)
  3370    ;
  3371   POLTYP(IBI FN,IBSEQ)  ; Returns  ins electr onic polic y type cod e for one
  3372    ;   ins p olicy on a  bill
  3373    ; IBIFN =  ien of bi ll
  3374    ; IBSEQ =  sequence  (1,2,3) of  ins polic y wanted -  prim, sec ond, tert
  3375    ;       D efault is  current in surance co
  3376    ;
  3377    N IBPLAN, IBPLTYP
  3378    ;
  3379    I '$G(IBS EQ) S IBSE Q=+$$COBN^ IBCEF(IBIF N)
  3380    S IBPLAN= $G(^IBA(35 5.3,+$P($G (^DGCR(399 ,IBIFN,"I" _IBSEQ)),U ,18),0))
  3381    S IBPLTYP =$P(IBPLAN ,U,15)
  3382    ;
  3383    ; esg - 0 6/30/05 -  IB*2.0*296  - Force M edicare (W NR) to be  correct
  3384    ;JRA IB*2 .0*592 Tre at Dental  Form 7 (J4 30D) the s ame as CMS -1500
  3385    ;I $$WNRB ILL^IBEFUN C(IBIFN,IB SEQ),$$FT^ IBCEF(IBIF N)=2 S IBP LTYP="MB"    ; CMS-15 00 ----> M edicare Pa rt B  ;JRA  IB*2.0*59 2 ';'
  3386    ;I $$WNRB ILL^IBEFUN C(IBIFN,IB SEQ),$$FT^ IBCEF(IBIF N)=3 S IBP LTYP="MA"    ; UB-04  -------> M edicare Pa rt A
  3387    N FT S FT =$$FT^IBCE F(IBIFN)   ;JRA IB*2. 0*592
  3388    I $$WNRBI LL^IBEFUNC (IBIFN,IBS EQ),(FT=2! (FT=7)) S  IBPLTYP="M B"   ; CMS -1500 ---- > Medicare  Part B  ; JRA IB*2.0 *592 same  for J430D
  3389    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 fu nction cal l
  3390    ;
  3391    I IBPLTYP ="" S IBPL TYP="CI" ; Default is  commercia l - 'CI'
  3392    I IBPLTYP ="MX" D
  3393    . I $P(IB PLAN,U,14) '="","AB"[ $P(IBPLAN, U,14) S IB PLTYP="M"_ $P(IBPLAN, U,14) Q
  3394    . S IBPLT YP="CI"
  3395    Q $G(IBPL TYP)
  3396    ;
  3397   ALLPTYP(IB IFN) ; ret urns insur ance polic y type cod es for ALL  ins on a  bill
  3398    ; IBIFN =  ien of bi ll
  3399    N IBX,Z S  IBX=""
  3400    F Z=1:1:3  I $D(^DGC R(399,IBIF N,"I"_Z))  S $P(IBX,U ,Z)=$$POLT YP(IBIFN,Z )
  3401    ; IBX = p rimary cod e^secondar y code^ter tiary code
  3402    Q IBX
  3403    ;
  3404   PGDX(DXCNT ,IBX0,IBXD A,IBXLN,IB XCOL,IBXSI ZE,IBXSAVE ) ; Subrou tine - Che cks for Di agnosis Co des (Dx) b eyond 
  3405    ; the fir st four, t hat relate  to the cu rrent Dx p osition pa ssed in DX CNT.
  3406    ; This su broutine s tores the  Diagnosis  Codes in o utput glob al using d isplay par ameters (I BXLN,IBXCO L)
  3407    ;  THE PA GE IS ALWA YS 1 NOW S O WE DON'T  NEED 4 LI NES BELOW   BAA *488*
  3408    ; If DXCN T is 1, ch eck for Dx 's 5,9,... etc & disp lay on pag es 2,3,... etc
  3409    ; If DXCN T is 2, ch eck for Dx 's 6,10,.. .etc & dis play on pa ges 2,3,.. .etc
  3410    ; If DXCN T is 3, ch eck for Dx 's 7,11,.. .etc & dis play on pa ges 2,3,.. .etc
  3411    ; If DXCN T is 4, ch eck for Dx 's 8,12,.. .etc & dis play on pa ges 2,3,.. .etc
  3412    ;
  3413    ; Input:  DXCNT= pos ition of c urrent Dx  (from 1 to  4)
  3414    ;         IBX0= zero -level of  file 364.7  of curren t Dx
  3415    ;         IBXDA= ien # of file  364.6 of c urrent Dx
  3416    ;         IBXLN IBXC OL= line#  & Column#  of current  Dx
  3417    ;         IBXSIZE= s ize counte r
  3418    ;         IBXSAVE("D X")= local  array wit h all Dx's  on curren t bill
  3419    ;
  3420    ;  For pa tch *488* 
  3421    ;  S DXNM  = 12  Thi s is the n umber of d iagnosis o n a 1500 f orm  
  3422    ;  S IBPG =1  This i s the page  number.   All 12 pri nt on page  1
  3423    N IBPG,VA L
  3424    S IBPG=1
  3425    I '$D(IBX SAVE("DX", DXCNT)) Q
  3426    S VAL=$P( $$ICD9^IBA CSV(+IBXSA VE("DX",DX CNT)),U)    ; resolve  Dx pointe r
  3427    S VAL=$$F ORMAT^IBCE F3(VAL,$G( IBX0),$G(I BXDA))  ;f ormat Dx v alue
  3428    D SETGBL^ IBCEFG(IBP G,IBXLN,IB XCOL,VAL,. IBXSIZE) ; store in o utput glob al
  3429    Q  ;PGDX
  3430    ;
  3431   DXSV(IB,IB XSAVE) ; o utput form atter subr outine
  3432    ; save of f DX codes  in IBXSAV E("DX")
  3433    N Z,IBCT
  3434    S (Z,IBCT )=0
  3435    F  S Z=$O (IB(Z)) Q: 'Z  I $G(I B(Z)) S IB CT=IBCT+1  M IBXSAVE( "DX",IBCT) =IB(Z)
  3436    Q
  3437    ;
  3438   AUTRF(IBXI EN,IBL,Z)  ; returns  auth # and  referral#  if room f or both, s eparated b y a space  - IB*2.0*4 32
  3439    ; IBXIEN=   claim ie n
  3440    ; IBL   =   field le ngth-1 to  allow for  1 blank sp ace betwee n numbers  (28 for CM S 1500, 30  for UB-04 )
  3441    ; Z     =   1 for PR IMARY, 2 f or SECONDA RY, 3 for  TERTIARY
  3442    ; 
  3443    N IBXDATA ,IBZ
  3444    Q:$G(IBXI EN)="" ""
  3445    ; if CMS  1500, find  current c odes
  3446    I $G(Z)=" ",$G(IBL)= 28 S Z=$$C OBN^IBCEF( IBXIEN)
  3447    Q:$G(Z)=" " ""
  3448    ; if leng th not def ined, defa ult to sho rtest
  3449    S:IBL=""  IBL=28
  3450    D F^IBCEF ("N-"_$P(" PRIMARY^SE CONDARY^TE RTIARY",U, Z)_" AUTH  CODE",,,IB XIEN)
  3451    D F^IBCEF ("N-"_$P(" PRIMARY^SE CONDARY^TE RTIARY",U, Z)_" REFER RAL NUMBER ","IBZ",,I BXIEN)
  3452    ; if leng th of auth  and refer ral combin ed is too  long, only  return au th code
  3453    Q $S(IBZ= "":IBXDATA ,IBXDATA=" ":IBZ,$L(I BXDATA)+$L (IBZ)>IBL: IBXDATA,1: IBXDATA_"  "_IBZ)
  3454    ;
  3455   GRPNAME(IB IEN,IBXDAT A) ; Popul ate IBXDAT A with the  Group Nam e(s).
  3456    ; MRD;IB* 2.0*516 -  Created th is procedu re as extr act code f or
  3457    ; ^IBA(36 4.5,199),  N-ALL INSU RANCE GROU P NAME.
  3458    N A,Z
  3459    F Z=1:1:3  I $D(^DGC R(399,IBIE N,"I"_Z))  D
  3460    . S IBXDA TA(Z)=$$PO LICY^IBCEF (IBIEN,15, Z) I IBXDA TA(Z)'=""  Q
  3461    . S A=$$P OLICY^IBCE F(IBIEN,1, Z)            ; Pull  piece 1, I ns. Type.
  3462    . I A'=""  S IBXDATA (Z)=$P($G( ^DIC(36,+A ,0)),U)
  3463    . Q
  3464    Q
  3465    ;
  3466   GRPNUM(IBX IEN,IBXDAT A) ; Popul ate IBXDAT A with the  Group Num ber(s).
  3467    ; MRD;IB* 2.0*516 -  Created th is procedu re as extr act code f or
  3468    ; ^IBA(36 4.5,200),  N-ALL INSU RANCE GROU P NUMBER.
  3469    N Z
  3470    F Z=1:1:3  I $D(^DGC R(399,IBXI EN,"I"_Z))  S IBXDATA (Z)=$$POLI CY^IBCEF(I BXIEN,3,Z)
  3471    Q
  3472    ;
  3473   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  3474   IBCEF31 ;A LB/ESG - F ORMATTER S PECIFIC BI LL FLD FUN CTIONS - C ONT ;14-NO V-03
  3475    ;;2.0;INT EGRATED BI LLING;**15 5,296,349, 400,432,48 8,516,592, 608**;21-M AR-94;Buil d 40
  3476    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3477    ;
  3478    Q
  3479    ;
  3480   ALLTYP(IBI FN) ; retu rns codes  to transla te to ALL  ins types  on a bill
  3481    ; IBIFN =  ien of bi ll
  3482    N IBX,Z
  3483    F Z=1:1:3  S $P(IBX, U,Z)=$$INS TYP(IBIFN, Z)
  3484    ; IBX = p rimary cod e^secondar y code^ter tiary code
  3485    Q IBX
  3486    ;
  3487   INSTYP(IBI FN,SEQ) ;  Returns in surance ty pe code fo r an ins o n a bill
  3488    ; IBIFN =  ien of bi ll
  3489    ; SEQ = s equence (1 ,2,3) of i nsurance w anted - pr im, second , tert
  3490    ;       D efault is  current in surance co
  3491    ;
  3492    N IBA,Z
  3493    ;
  3494    I '$G(SEQ ) S SEQ=$$ COBN^IBCEF (IBIFN)
  3495    S Z=+$G(^ DGCR(399,I BIFN,"I"_S EQ))
  3496    ;Codes 1: HMO;2:COMM ERCIAL;3:M EDICARE;4: MEDICAID;5 :GROUP POL ICY;9:OTHE R
  3497    I Z D
  3498    . S IBA=$ P($G(^DIC( 36,Z,3)),U ,9)
  3499    . I $$MCR WNR^IBEFUN C(Z) S IBA =3   ; for ce Medicar e (WNR) de finition t o be corre ct
  3500    . I IBA=" " S IBA=5  ;Default i s group po licy - 5 i f blank
  3501    ;
  3502    Q $G(IBA)
  3503    ;
  3504   POLTYP(IBI FN,IBSEQ)  ; Returns  ins electr onic polic y type cod e for one
  3505    ;   ins p olicy on a  bill
  3506    ; IBIFN =  ien of bi ll
  3507    ; IBSEQ =  sequence  (1,2,3) of  ins polic y wanted -  prim, sec ond, tert
  3508    ;       D efault is  current in surance co
  3509    ;
  3510    N IBPLAN, IBPLTYP
  3511    ;
  3512    I '$G(IBS EQ) S IBSE Q=+$$COBN^ IBCEF(IBIF N)
  3513    S IBPLAN= $G(^IBA(35 5.3,+$P($G (^DGCR(399 ,IBIFN,"I" _IBSEQ)),U ,18),0))
  3514    S IBPLTYP =$P(IBPLAN ,U,15)
  3515    ;
  3516    ; esg - 0 6/30/05 -  IB*2.0*296  - Force M edicare (W NR) to be  correct
  3517    ;JRA IB*2 .0*592 Tre at Dental  Form 7 (J4 30D) the s ame as CMS -1500
  3518    ;I $$WNRB ILL^IBEFUN C(IBIFN,IB SEQ),$$FT^ IBCEF(IBIF N)=2 S IBP LTYP="MB"    ; CMS-15 00 ----> M edicare Pa rt B  ;JRA  IB*2.0*59 2 ';'
  3519    ;I $$WNRB ILL^IBEFUN C(IBIFN,IB SEQ),$$FT^ IBCEF(IBIF N)=3 S IBP LTYP="MA"    ; UB-04  -------> M edicare Pa rt A
  3520    N FT S FT =$$FT^IBCE F(IBIFN)   ;JRA IB*2. 0*592
  3521    I $$WNRBI LL^IBEFUNC (IBIFN,IBS EQ),(FT=2! (FT=7)) S  IBPLTYP="M B"   ; CMS -1500 ---- > Medicare  Part B  ; JRA IB*2.0 *592 same  for J430D
  3522    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 fu nction cal l
  3523    ;
  3524    I IBPLTYP ="" S IBPL TYP="CI" ; Default is  commercia l - 'CI'
  3525    I IBPLTYP ="MX" D
  3526    . I $P(IB PLAN,U,14) '="","AB"[ $P(IBPLAN, U,14) S IB PLTYP="M"_ $P(IBPLAN, U,14) Q
  3527    . S IBPLT YP="CI"
  3528    Q $G(IBPL TYP)
  3529    ;
  3530   ALLPTYP(IB IFN) ; ret urns insur ance polic y type cod es for ALL  ins on a  bill
  3531    ; IBIFN =  ien of bi ll
  3532    N IBX,Z S  IBX=""
  3533    F Z=1:1:3  I $D(^DGC R(399,IBIF N,"I"_Z))  S $P(IBX,U ,Z)=$$POLT YP(IBIFN,Z )
  3534    ; IBX = p rimary cod e^secondar y code^ter tiary code
  3535    Q IBX
  3536    ;
  3537   PGDX(DXCNT ,IBX0,IBXD A,IBXLN,IB XCOL,IBXSI ZE,IBXSAVE ) ; Subrou tine - Che cks for Di agnosis Co des (Dx) b eyond 
  3538    ; the fir st four, t hat relate  to the cu rrent Dx p osition pa ssed in DX CNT.
  3539    ; This su broutine s tores the  Diagnosis  Codes in o utput glob al using d isplay par ameters (I BXLN,IBXCO L)
  3540    ;  THE PA GE IS ALWA YS 1 NOW S O WE DON'T  NEED 4 LI NES BELOW   BAA *488*
  3541    ; If DXCN T is 1, ch eck for Dx 's 5,9,... etc & disp lay on pag es 2,3,... etc
  3542    ; If DXCN T is 2, ch eck for Dx 's 6,10,.. .etc & dis play on pa ges 2,3,.. .etc
  3543    ; If DXCN T is 3, ch eck for Dx 's 7,11,.. .etc & dis play on pa ges 2,3,.. .etc
  3544    ; If DXCN T is 4, ch eck for Dx 's 8,12,.. .etc & dis play on pa ges 2,3,.. .etc
  3545    ;
  3546    ; Input:  DXCNT= pos ition of c urrent Dx  (from 1 to  4)
  3547    ;         IBX0= zero -level of  file 364.7  of curren t Dx
  3548    ;         IBXDA= ien # of file  364.6 of c urrent Dx
  3549    ;         IBXLN IBXC OL= line#  & Column#  of current  Dx
  3550    ;         IBXSIZE= s ize counte r
  3551    ;         IBXSAVE("D X")= local  array wit h all Dx's  on curren t bill
  3552    ;
  3553    ;  For pa tch *488* 
  3554    ;  S DXNM  = 12  Thi s is the n umber of d iagnosis o n a 1500 f orm  
  3555    ;  S IBPG =1  This i s the page  number.   All 12 pri nt on page  1
  3556    N IBPG,VA L
  3557    S IBPG=1
  3558    I '$D(IBX SAVE("DX", DXCNT)) Q
  3559    S VAL=$P( $$ICD9^IBA CSV(+IBXSA VE("DX",DX CNT)),U)    ; resolve  Dx pointe r
  3560    S VAL=$$F ORMAT^IBCE F3(VAL,$G( IBX0),$G(I BXDA))  ;f ormat Dx v alue
  3561    D SETGBL^ IBCEFG(IBP G,IBXLN,IB XCOL,VAL,. IBXSIZE) ; store in o utput glob al
  3562    Q  ;PGDX
  3563    ;
  3564   DXSV(IB,IB XSAVE) ; o utput form atter subr outine
  3565    ; save of f DX codes  in IBXSAV E("DX")
  3566    N Z,IBCT
  3567    S (Z,IBCT )=0
  3568    F  S Z=$O (IB(Z)) Q: 'Z  I $G(I B(Z)) S IB CT=IBCT+1  M IBXSAVE( "DX",IBCT) =IB(Z)
  3569    Q
  3570    ;
  3571   AUTRF(IBXI EN,IBL,Z)  ; returns  auth # and  referral#  if room f or both, s eparated b y a space  - IB*2.0*4 32
  3572    ; IBXIEN=   claim ie n
  3573    ; IBL   =   field le ngth-1 to  allow for  1 blank sp ace betwee n numbers  (28 for CM S 1500, 30  for UB-04 )
  3574    ; Z     =   1 for PR IMARY, 2 f or SECONDA RY, 3 for  TERTIARY
  3575    ; 
  3576    N IBXDATA ,IBZ
  3577    Q:$G(IBXI EN)="" ""
  3578    ; if CMS  1500, find  current c odes
  3579    I $G(Z)=" ",$G(IBL)= 28 S Z=$$C OBN^IBCEF( IBXIEN)
  3580    Q:$G(Z)=" " ""
  3581    ; if leng th not def ined, defa ult to sho rtest
  3582    S:IBL=""  IBL=28
  3583    D F^IBCEF ("N-"_$P(" PRIMARY^SE CONDARY^TE RTIARY",U, Z)_" AUTH  CODE",,,IB XIEN)
  3584    D F^IBCEF ("N-"_$P(" PRIMARY^SE CONDARY^TE RTIARY",U, Z)_" REFER RAL NUMBER ","IBZ",,I BXIEN)
  3585    ; if leng th of auth  and refer ral combin ed is too  long, only  return au th code
  3586    Q $S(IBZ= "":IBXDATA ,IBXDATA=" ":IBZ,$L(I BXDATA)+$L (IBZ)>IBL: IBXDATA,1: IBXDATA_"  "_IBZ)
  3587    ;
  3588   GRPNAME(IB IEN,IBXDAT A) ; Popul ate IBXDAT A with the  Group Nam e(s).
  3589    ; MRD;IB* 2.0*516 -  Created th is procedu re as extr act code f or
  3590    ; ^IBA(36 4.5,199),  N-ALL INSU RANCE GROU P NAME.
  3591    N A,Z
  3592    F Z=1:1:3  I $D(^DGC R(399,IBIE N,"I"_Z))  D
  3593    . S IBXDA TA(Z)=$$PO LICY^IBCEF (IBIEN,15, Z) I IBXDA TA(Z)'=""  Q
  3594    . S A=$$P OLICY^IBCE F(IBIEN,1, Z)            ; Pull  piece 1, I ns. Type.
  3595    . I A'=""  S IBXDATA (Z)=$P($G( ^DIC(36,+A ,0)),U)
  3596    . Q
  3597    Q
  3598    ;
  3599   GRPNUM(IBX IEN,IBXDAT A) ; Popul ate IBXDAT A with the  Group Num ber(s).
  3600    ; MRD;IB* 2.0*516 -  Created th is procedu re as extr act code f or
  3601    ; ^IBA(36 4.5,200),  N-ALL INSU RANCE GROU P NUMBER.
  3602    N Z
  3603    F Z=1:1:3  I $D(^DGC R(399,IBXI EN,"I"_Z))  S IBXDATA (Z)=$$POLI CY^IBCEF(I BXIEN,3,Z)
  3604    Q
  3605    ;
  3606   CMNDATA(IB XIEN,IBPRO C,FLD,INT)  ;JRA;IB*2 .0*608 Ret urn data f or specifi ed Certifi cate of Me dical Nece ssity (CMN ) field.
  3607    ;Created  to return  data for a  specific  CMN field,  which is  a subfield  of file 3 99, field  304 (Proce dure).  Re turns data
  3608    ; in Exte rnal forma t by defau lt.
  3609    ;
  3610    ;Input:   IBXIEN = I nternal bi ll/claim n umber
  3611    ;         IBPROC = P rocedure #  (subscrip t in ^DGCR )
  3612    ;         FLD    = F ield numbe r of desir ed field
  3613    ;         INT    = F lag set to  'I' if th e subfield 's Interna l value is  to be ret urned (opt ional)
  3614    ;
  3615    ;Output:  VAL    = E xternal (o r optional ly Interna l) value o f the CMN  subfield s pecified b y FLD
  3616    ;
  3617    Q:('$G(IB XIEN)!('$G (FLD)!('$G (IBPROC))) ) ""
  3618    S INT=$G( INT)
  3619    N ND,VAL, X
  3620    S ND=IBPR OC_","_IBX IEN
  3621    S VAL=$$G ET1^DIQ(39 9.0304,ND, FLD,INT)
  3622    Q VAL
  3623    ;
  3624   CMNDEX(IBX IEN,IBXSAV E) ;JRA;IB *2.0*608 D ata Extrac t for LQ,  CMN and ME A segments
  3625    Q:'$G(IBX IEN)
  3626    ;
  3627    N CMNREQ, ND,X,IBXDA TA
  3628    ;Get Proc edure Link s for all  Procedures  on the cl aim.
  3629    D OUTPT^I BCEF11(IBX IEN,0) Q:' $D(IBXDATA )
  3630    N LP,Z,CN T
  3631    S LP=0 F   S LP=$O(I BXDATA(LP) ) Q:'+LP   D
  3632    . S CNT=$ G(CNT)+1
  3633    . Q:'$D(I BXDATA(LP, "CPLNK"))
  3634    . S ND=IB XDATA(LP," CPLNK")
  3635    . S ND=ND _","_IBXIE N_","
  3636    . S CMNRE Q=$$GET1^D IQ(399.030 4,ND,23,"I ")
  3637    . S:CMNRE Q="" CMNRE Q=0
  3638    . Q:'+CMN REQ
  3639    . S Z=$G( Z)+1
  3640    . S IBXSA VE("CMNDEX ",Z)=IBXDA TA(LP,"CPL NK")_U_CNT
  3641    Q
  3642    ;
  3643   FRM(IBXIEN ,IBXSAVE)  ;JRA;IB*2. 0*608 Data  Extract f or FRM seg ment
  3644    Q:'$G(IBX IEN)
  3645    ;
  3646    N CMNREQ, CNT,DEL,IB XDATA,LP,N D,QUIT,X,Z ,Z1
  3647    ;Get Proc edure Data  for all P rocedures  on the cla im.
  3648    D OUTPT^I BCEF11(IBX IEN,0) Q:' $D(IBXDATA )
  3649    S LP=0 F   S LP=$O(I BXDATA(LP) ) Q:'+LP   D
  3650    . Q:'$D(I BXDATA(LP, "CPLNK"))
  3651    . S CNT=$ G(CNT)+1
  3652    . S ND=IB XDATA(LP," CPLNK")
  3653    . S ND=ND _","_IBXIE N_","
  3654    . S CMNRE Q=$$GET1^D IQ(399.030 4,ND,23,"I ")
  3655    . S:CMNRE Q="" CMNRE Q=0
  3656    . Q:'+CMN REQ
  3657    . S Z=$G( Z)+1
  3658    . ;WHAT F ORM
  3659    . N DATA, FORM,FLD,F LDS,INTEXT ,QUES,QUES NUM,X
  3660    . S FORM= $TR($$GET1 ^DIQ(399.0 304,ND,"24 :3","I")," -")  ; get  the form  number to  figure wha t fields g o with it
  3661    . Q:FORM= ""  ; quit  if no for m number
  3662    . ;
  3663    . S FLDS= $P($T(@FOR M),";;",2, 9999)   ;  get all th e associat ed data fi elds from  below
  3664    . ;
  3665    . N PAIRE DQA
  3666    . ;Parse  FLDS to ge t DD field , question  number, t ype of res ponse (2=Y /N, 3=text /code, 4=d ate, 5=per cent/decim al), and t he respons e data.
  3667    . F X=1:1  S QUES=$P (FLDS,"~", X)  Q:QUES =""  D
  3668    .. S FLD= $P(QUES,U)
  3669    .. S QUES NUM=$P(QUE S,U,2)
  3670    .. S RESP TYP=$P(QUE S,U,3)
  3671    .. I RESP TYP=4 S IN TEXT="I"
  3672    .. E  S I NTEXT=$P(Q UES,U,4) S :INTEXT=""  INTEXT="E "
  3673    .. S DATA =$$GET1^DI Q(399.0304 ,ND,FLD,IN TEXT)
  3674    .. ;
  3675    .. ; KLUD GE; On for m CMN10126  If 4A or  3A is blan k, don't s end ther o ther (whic h means ge t rid of t he previou s Q/A)
  3676    .. ; same  for 4B/3B
  3677    .. I FORM ="CMN10126 ",".3A.3B. 4A.4B."[QU ESNUM S PA IRQ=0 D  Q :PAIRQ
  3678    ... I QUE SNUM="3A"! (QUESNUM=" 3B") S PAI REDQA(QUES NUM)=DATA  Q
  3679    ... I QUE SNUM="4A", $G(PAIREDQ A("3A"))=" " S PAIRQ= 1 Q
  3680    ... I QUE SNUM="4B", $G(PAIREDQ A("3B"))=" " S PAIRQ= 1 Q
  3681    ..;
  3682    .. Q:DATA =""  ;Do n ot include  FRM rec f or unanswe red questi ons
  3683    .. ;
  3684    .. S:RESP TYP=2 DATA =$E(DATA)   ; only wa nt Y or N
  3685    .. S:RESP TYP=4 DATA =$$DT^IBCE FG1(DATA," ","D8")  ; YYYYMMDD d ate format
  3686    .. ;Proce dure# has  a 1 to man y ratio wi th Questio n# but can 't have 2  subscripts  so combin e into 1,  ordering I BXSAVE by  Question#.
  3687    .. S IBXS AVE("FRM", (Z_"_"_(X/ 10)))=QUES NUM_U
  3688    .. S $P(I BXSAVE("FR M",(Z_"_"_ (X/10))),U ,RESPTYP)= DATA
  3689    .. S $P(I BXSAVE("FR M",(Z_"_"_ (X/10))),U ,6)=CNT
  3690    ;
  3691    ;Re-subsc ript IBXSA VE with se quential i ntegers as  current s ubscript f ormat will  not work  with Outpu t Formatte r.
  3692    S (Z,Z1)= 0 F  S Z=$ O(IBXSAVE( "FRM",Z))  Q:'Z  S Z1 =Z1+1,IBXS AVE("FRM", Z1)=IBXSAV E("FRM",Z) ,DEL(Z)=""
  3693    S Z=0 F   S Z=$O(DEL (Z)) Q:'Z   K IBXSAVE ("FRM",Z)
  3694    Q
  3695    ;
  3696   PTWT(IBXIE N) ;JRA;IB *2.0*608 R eturn CMN  Patient We ight from  1st Servic e Line # t hat has it  (or NULL  if none)
  3697    Q:'$G(IBX IEN)
  3698    N FOUND,I BPROC,IBXS AVE,PTWT
  3699    D CMNDEX( IBXIEN,.IB XSAVE)
  3700    S (FOUND, Z)=0,PTWT= "" F  S Z= $O(IBXSAVE ("CMNDEX", Z)) Q:Z=""   D  Q:FOU ND
  3701    . S IBPRO C=+IBXSAVE ("CMNDEX", Z) Q:'IBPR OC 
  3702    . S PTWT= $$CMNDATA( IBXIEN,IBP ROC,24.03)  S:PTWT FO UND=1
  3703    Q PTWT
  3704    ;
  3705    ;JRA;IB*2 .0*608 Tag s CMN484 &  CMN10126  added
  3706    ; FIELD#^ QUESTION#^ RESPONSE_T YPE^INT/EX T
  3707   CMN484 ;;2 4.1^1A^3~2 4.102^1B^5 ~24.103^1C ^4~24.107^ 2^3^I~24.1 08^3^3^I~2 4.109^4^3^ I~24.11^5^ 3~24.111^6 A^3~24.113 ^6B^5~24.1 14^6C^4~24 .104^7^2~2 4.105^8^2~ 24.106^9^2 ~24.115^C^ 3
  3708    ;
  3709   CMN10126 ; ;24.201^1^ 2~24.202^2 ^2~24.204^ 3A^3~24.21 9^3B^3~24. 203^4A^3~2 4.218^4B^3 ~24.205^5^ 3^I~24.206 ^6^3~24.20 7^7^2~24.2 08^8A^3~24 .209^8B^5~ 24.21^8C^3 ~24.211^8D ^3~24.212^ 8E^5~24.21 3^8F^3~24. 215^8G^3~2 4.216^8H^5 ~24.214^9^ 3^I
  3710    ;
  3711  
  3712  
  3713   IX)  Add t he CMN nod es to comp arison cod e:
  3714   IBCF23A
  3715   Routines
  3716   Activities
  3717   Routine Na me
  3718   IBCF23A
  3719   Enhancemen t Category
  3720    New
  3721    Modify
  3722    Delete
  3723    No Change
  3724   RTM
  3725  
  3726   Related Op tions
  3727   None
  3728   Related Ro utines
  3729   Routines “ Called By”
  3730   Routines “ Called”   
  3731  
  3732  
  3733  
  3734  
  3735   Data Dicti onary (DD)  Reference s
  3736  
  3737   Related Pr otocols
  3738   None
  3739   Related In tegration  Control Re gistration s (ICRs)
  3740   None
  3741   Data Passi ng
  3742    Input
  3743    Output Re ference
  3744    Both
  3745    Global Re ference
  3746    Local
  3747   Input Attr ibute Name  and Defin ition
  3748   Name:
  3749   Definition :
  3750   Output Att ribute Nam e and Defi nition
  3751   Name:
  3752   Definition :
  3753   Current Lo gic
  3754   IBCF23A ;A LB/ARH - H CFA 1500 1 9-90 DATA  - Split fr om IBCF23  ;12-JUN-93
  3755    ;;2.0;INT EGRATED BI LLING;**51 ,432,516,5 47,577,592 **;21-MAR- 94;Build 2 5
  3756    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3757    ;
  3758    ; $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) - I CR 10141
  3759    ;
  3760   B24 ; set  individual  entries i n print ar ray, exter nal format
  3761    ; IBAUX =  additiona l data for  EDI outpu t
  3762    ; IBRXF =  array of  RX procedu res
  3763    ;JWS;IB*2 .0*592;US1 31
  3764    ; IBDEN =  Dental da ta for EDI  output
  3765    ; IBDEN1  = array of  Dental da ta for EDI  output
  3766    N IBX,Z,I BD1,IBD2,I BCPLINK
  3767    S IBI=IBI +1,IBPROC= $P(IBSS,U, 2),IBD1=$$ DATE^IBCF2 3(IBDT1),I BD2=$S(IBD T1'=IBDT2: $$DATE^IBC F23(IBDT2) ,1:"")
  3768    I '$D(IBX IEN) S IBD 1=$E(IBD1, 5,8)_$E(IB D1,1,4),IB D2=$E(IBD2 ,5,8)_$E(I BD2,1,4)
  3769    S IBFLD(2 4,IBI)=IBD 1_U_IBD2_U _$P($G(^IB E(353.1,+$ P(IBSS,U,6 ),0)),U)_U _$P($G(^IB E(353.2,+$ P(IBSS,U,7 ),0)),U)
  3770    I +IBPROC  D
  3771    . S IBFLD (24,IBI)=I BFLD(24,IB I)_U_$P($$ PRCD^IBCEF 1(IBPROC,1 ),U,2) S:$ P(IBPROC," ;",2)'["IC PT" IBFLD( 24,IBI_"X" )=""
  3772    I 'IBPROC  S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$S('$D( IBXIEN):IB PROC,1:+IB REV),IBFLD (24,IBI_"A ")=$P($G(^ DGCR(399.2 ,+IBREV,0) ),U,2)
  3773    I $D(IBRX F),IBCHARG ="" S IBFL D(24,IBI_" A")=$P($G( ^DGCR(399. 2,+IBREV,0 )),U,2)
  3774    S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$P(IBSS ,U,5)_U_IB CHARG_U_IB UNIT_U_$P( IBSS,U,8)_ U_$G(IBPCH G)_U_$G(IB MIN)_U_$G( IBEMG)
  3775    I $D(IBSS ("L")) S Z =0 F  S Z= $O(IBSS("L ",Z)) Q:'Z   S IBFLD( 24,IBI,$P( IBSS("L",Z ),U),$P(IB SS("L",Z), U,2))=$G(I BFLD(24,IB I,$P(IBSS( "L",Z),U), $P(IBSS("L ",Z),U,2)) )+1
  3776    S:$TR($G( IBAUX),U)' ="" IBFLD( 24,IBI,"AU X")=$G(IBA UX)
  3777    S:$D(IBRX F) IBFLD(2 4,IBI,"RX" )=IBRXF
  3778    K IBPROC, IBSS("L")
  3779    S IBCPLIN K=$P(IBSS, U,$L(IBSS, U))
  3780    S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_IBCPLIN K
  3781    ; MRD;IB* 2.0*516 -  Added NDC  and Units  to line le vel of cla im.
  3782    ;I IBCPLI NK'="" S $ P(IBFLD(24 ,IBI),U,14 ,15)=$TR($ P($G(^DGCR (399,IBIFN ,"CP",IBCP LINK,1)),U ,7,8),"-")
  3783    ; vd/Begi nning of I B*2*577 -  Added Unit /Basis of  Measurment  to line l evel of cl aim.
  3784    I IBCPLIN K'="" S $P (IBFLD(24, IBI),U,14, 16)=$TR($P ($G(^DGCR( 399,IBIFN, "CP",IBCPL INK,1)),U, 7,8),"-")_ U_$P($G(^D GCR(399,IB IFN,"CP",I BCPLINK,2) ),U)
  3785    ; vd/End  of IB*2*57 7
  3786    ;JWS;IB*2 .0*592;US1 31
  3787    I $G(IBDE N)'="" S I BFLD(24,IB I,"DEN")=$ G(IBDEN)
  3788    I $D(IBDE N1) M IBFL D(24,IBI," DEN1")=IBD EN1
  3789    I $D(IBDE ND) S IBFL D(24,IBI," DEND")=$G( IBDEND)
  3790    ;end ;JWS ;IB*2.0*59 2;US131
  3791    Q
  3792    ;
  3793   AUXOK(IBSS ,IBSS1) ;  Check all  other flds  are the s ame to com bine procs
  3794    ; IBSS =  subscript  of IBCP to  check for  dups to c ombine - p ass by ref
  3795    ; IBSS(IB SS,"AUX-X" ,n) = all  the previo usly extra cted line  items for  the
  3796    ;  same s et of basi c data, bu t having d ifferent " AUX" data
  3797    ; IBSS1 =  the "AUX"  data of t he current  IBCP entr y
  3798    ;
  3799    ; Returns  entry # i n IBSS arr ay if matc h found, o r 0 if no  match
  3800    ; Set the  IBSS "AUX -X" node f or no matc h
  3801    N Z,Z0,Z1 ,XIEN
  3802    S Z=0 F   S Z=$O(IBS S(IBSS,"AU X-X",Z)) Q :'Z  I IBS S1=IBSS(IB SS,"AUX-X" ,Z) Q
  3803    ;JWS;IB*2 .0*592;Den tal fields  to check  for roll-u p
  3804    S XIEN=$G (IBSS(IBSS ,1))
  3805    I $D(IBCP (IBPO,"DEN "))!($D(IB CP(IBPO,"D EN1")))!($ D(IBCP(IBP O,"DEND")) )!($D(IBCP (XIEN,"DEN ")))!($D(I BCP(XIEN," DEN1")))!( $D(IBCP(XI EN,"DEND") )) D
  3806    . I $G(IB CP(IBPO,"D EN"))'=$G( IBCP(XIEN, "DEN")) S  Z=0 Q
  3807    . I $G(IB CP(IBPO,"D END"))'=$G (IBCP(XIEN ,"DEND"))  S Z=0 Q
  3808    . S Z1=0  F  S Z1=$O (IBCP(IBPO ,"DEN1",Z1 )) Q:'Z1   I $G(IBCP( IBPO,"DEN1 ",Z1,0))'= $G(IBCP(XI EN,"DEN1", Z1,0)) S Z =0 Q
  3809    I 'Z S Z0 =+$O(IBSS( IBSS,"AUX- X",""),-1) +1,IBSS(IB SS,"AUX-X" ,Z0)=IBSS1
  3810    Q +Z
  3811    ;
  3812   PRC ; Extr act proced ure data f or HCFA 15 00
  3813    ; IBRC(IB SS) = #rev  codes wit h same bil ling crite ria (IBSS)
  3814    ; IBLINK( 'CP' ien,' RC' ien) =  IBSS incl uding modi fiers,rx s eq in pc 7 ,8
  3815    ; IBLINK1 (IBSS, 'RC ' ien) =   auto (1)^  'CP' ien ( soft link)
  3816    ;
  3817    ; proc ar ray w/chrg
  3818    ;JWS;IB*2 .0*592;US1 31; added  IBLN1, IBD ENLN
  3819    ;IA# 3820
  3820    N IBPR,IB P,IBDENLN, IBLN1
  3821    S IBI=0 F   S IBI=$O (^DGCR(399 ,IBIFN,"CP ",IBI)) Q: 'IBI  S IB LN=^(IBI,0 ),IBLN1=$G (^(1)),IBA UXLN=$G(^( "AUX")),IB DENLN=$G(^ ("DEN")) D
  3822    . I $O(^D GCR(399,IB IFN,"CP",I BI,"DEN1", 0)) M IBDE NLN("DEN1" )=^DGCR(39 9,IBIFN,"C P",IBI,"DE N1")
  3823    . ;end ;J WS;IB*2.0* 592;US131
  3824    . N Z,Z0, Z1,Q1
  3825    . S IBPDT =$P(IBLN,U ,2)
  3826    . S IBSS= $$IBSS(IBI ,.IBDXI,IB LN)
  3827    . S IBPO= $S($P(IBLN ,U,4):+$P( IBLN,U,4), 1:IBI+1000 ) ;Set pri nt order
  3828    . S IBCP( IBPO)=IBPD T_"^"_IBSS ,IBCP(IBPO ,"AUX")=IB AUXLN
  3829    . S IBCP( IBPO,"LNK" )=IBI
  3830    . ;JWS;IB *2.0*592;U S131
  3831    . I $G(IB LN1)'="" S  IBCP(IBPO ,"DEND")=I BLN1
  3832    . I $G(IB DENLN)'=""  S IBCP(IB PO,"DEN")= IBDENLN
  3833    . I $O(IB DENLN("DEN 1",0)) M I BCP(IBPO," DEN1")=IBD ENLN("DEN1 ")
  3834    . ;end ;J WS;IB*2.0* 592;US131
  3835    . ; Rx
  3836    . N IBZ,I BITEM
  3837    . S IBZ=$ S($P(IBSS, U):$P(IBSS ,U),1:"")
  3838    . I IBZ'= "",$D(IBLI NKRX(IBZ,I BI)) D  Q: IBCHARG'=" "
  3839    .. S IBPO 1=IBPO
  3840    .. S IBIT EM=+$O(IBL INKRX(IBZ, IBI,0)),IB RV=$G(IBLI NKRX(IBZ,I BI,IBITEM) )
  3841    .. Q:$S(I BRV="":1,1 :'$G(IBRC( IBRV)))
  3842    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  3843    .. S $P(I BCP(IBPO1) ,U,9)=IBCH ARG,IBCP(I BPO1,"RX") =IBITEM K  IBLINKRX(I BZ,IBI,IBI TEM)
  3844    . ; find  chrgs dire ctly linke d to proc
  3845    . S IBK=0  F  S IBK= $O(IBLINK( IBI,IBK))  Q:'IBK  S  IBRV1=IBLI NK(IBI,IBK ),IBRV=$P( IBRV1,U,1, 6) I +IBRC (IBRV1) D
  3846    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV1)=I BRC(IBRV1) -1
  3847    .. I IBCH ARG'="" S  $P(IBSS,U, 8)=IBCHARG ,IBCP(IBPO )=IBPDT_"^ "_IBSS,IBP O=IBPO+.1
  3848    ;
  3849    ; add chr gs associa ted with a  proc (not  a direct  link)
  3850    ; find ch rg associa ted with p roc, if an y (match p roc,div,+/ -basc)
  3851    K IBP(0)
  3852    F IBP=3,2  Q:$D(IBP( 0))  S IBP O="" F  S  IBPO=$O(IB CP(IBPO))  Q:'IBPO  I  $P(IBCP(I BPO),U,9)= "" D
  3853    . S IBSS= $P(IBCP(IB PO),U,2,9)
  3854    . S IBCHA RG="",(IBR V,IBSS)=$P (IBSS,U,1, IBP) F  S  IBRV=$O(IB RC(IBRV))  Q:$P(IBRV, U,1,IBP)'= IBSS  S IB P(0)=0 I + IBRC(IBRV)  D  Q
  3855    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  3856    .. I IBRC (IBRV) S Z =0 F  S Z= $O(IBCP(IB PO,Z)) Q:' Z  S IBRC( IBRV)=IBRC (IBRV)-1
  3857    . S $P(IB CP(IBPO),U ,9)=IBCHAR G
  3858    . I IBCHA RG'="" S Z =$O(IBLINK 1(IBRV,0))  I Z S IBC P(IBPO,"L" ,Z)=IBLINK 1(IBRV,Z)  K IBLINK1( IBRV,Z)
  3859    ;
  3860    ; add chr gs not ass ociated wi th a proc  to first p roc with n o chrg
  3861    ; Aggggh! !! TP
  3862    S IBPO=""  F  S IBPO =$O(IBCP(I BPO)) Q:'I BPO  I $P( IBCP(IBPO) ,U,9)="" D
  3863    . S IBCHA RG="",IBRV ="^" F  S  IBRV=$O(IB RC(IBRV))  Q:IBRV=""! +IBRV  I + IBRC(IBRV)  D  Q
  3864    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  3865    .. S Z=$O (IBLINK1(I BRV,0)) I  Z S IBCP(I BPO,"L",Z) =IBLINK1(I BRV,Z) K I BLINK1(IBR V,Z)
  3866    . S $P(IB CP(IBPO),U ,9)=IBCHAR G
  3867    ;
  3868    Q
  3869   IBSS(IBI,I BDXI,IBLN)  ; Creates  index seq uence for  procedure
  3870    N IBPC,IB J,IBSS,IBL PI,IBX,IBL PAR
  3871    S (IBPC,I BLPI)=0
  3872    F IBJ=1,6 ,5,0,9,10  S IBPC=IBP C+1 S:IBJ  $P(IBSS,U, IBPC,IBPC+ 1)=($P(IBL N,U,IBJ)_U )
  3873    S $P(IBSS ,U,7)=($$G ETMOD^IBEF UNC(IBIFN, IBI)_U) ;M odifiers
  3874    ;IB*547/T AZ - IBDXI  not defin ed, use in ternal DX  pointer
  3875    I '$G(IBN WPTCH) F I BJ=11:1:14  I $P(IBLN ,U,IBJ) S  $P(IBSS,U, 4)=$P(IBSS ,U,4)_$S(I BJ>11:",", 1:"")_$G(I BDXI(+$P(I BLN,U,IBJ) )) ; dx
  3876    I $G(IBNW PTCH) F IB J=11:1:14  S IBX=$P(I BLN,U,IBJ)  I IBX S $ P(IBSS,U,4 )=$P(IBSS, U,4)_$S(IB J>11:",",1 :"")_$G(IB DXI(IBX),I BX) ; dx
  3877    S $P(IBSS ,U,10)=$P( IBLN,U,16) ,$P(IBSS,U ,9)=$P(IBL N,U,19),$P (IBSS,U,11 )=+$P(IBLN ,U,17)
  3878    G:'$G(IBN WPTCH) IBS SX
  3879    ;IB*547/T AZ - Add a dditional  fields for  roll-up c ompare
  3880    S $P(IBSS ,U,21)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ASSO CIATED CLI NIC","I")
  3881    S $P(IBSS ,U,22)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","TYPE  OF SERVIC E","I")
  3882    S $P(IBSS ,U,23)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ATTA CHMENT CON TROL NUMBE R","I")
  3883    S $P(IBSS ,U,24)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","NDC" ,"I")
  3884    S $P(IBSS ,U,25)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","PROC EDURE DESC RIPTION"," I")
  3885    S $P(IBSS ,U,26)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ADDI TIONAL OB  MINUTES"," I")
  3886    ;Add Prov ider info  in pieces  41-49
  3887    M IBLPAR= ^DGCR(399, IBIFN,"CP" ,IBI,"LNPR V")
  3888    F  S IBLP I=$O(IBLPA R(IBLPI))  Q:'IBLPI   S IBX=IBLP AR(IBLPI,0 ),$P(IBSS, U,40+IBX)= $TR(IBX,"^ ","~")
  3889    K IBLPAR
  3890   IBSSX ;
  3891    Q IBSS
  3892    ;
  3893   IBNWPTCH(I BIFN,IBPAT CH) ;
  3894    ;Checks t he date th e primary  claim was  1st transm itted and  returns 1  if the tra nsmitted d ate is aft er the pat ch
  3895    ;referenc ed in vari able IBPAT CH was rel eased. Thi s allows t he MRA/EOB s returnin g to roll  up procedu res the sa me
  3896    ;way as t hey went o ut.  Other wise the o rder chang es and the  MRA/EOB w on't match  up.
  3897    ;
  3898    N IBARY,I BIDT,IBPFN ,IBEFN,IBB N,IBX,IBBD T
  3899    S IBX=0
  3900    I $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) D    ;ICR 1014 1
  3901    . S IBX=1
  3902    . S IBIDT =$O(IBARY( ""))
  3903    . ; Get P rimary Bil l Number.  This will  insure COB  data is c onsistent  across all  bills.
  3904    . S IBPFN =$$GET1^DI Q(399,IBIF N_",","PRI MARY BILL  #","I") I  'IBPFN S I BPFN=IBIFN
  3905    . ; Find  1st Accept ed Entry ( A1, A2, or  Z) of Pri mary Bill  in EDI TRA NSMIT BILL  FILE (364 ) to deter mine Batch  Number
  3906    . S (IBEF N,IBBN)=0  F  S IBEFN =$O(^IBA(3 64,"B",IBP FN,IBEFN))  Q:'IBEFN   D  I IBBN  Q
  3907    .. I ",A1 ,A2,Z,"'[( ","_$$GET1 ^DIQ(364,I BEFN_","," TRANSMISSI ON STATUS" ,"I")_",")  Q
  3908    .. S IBBN =$$GET1^DI Q(364,IBEF N_",","BAT CH NUMBER" ,"I")
  3909    . ;Retrie ve the dat e the batc h was 1st  sent.  If  IBBN="" IB BDT will b e null
  3910    . S IBBDT =$$GET1^DI Q(364.1,$$ GET1^DIQ(3 64,IBBN_", ","BATCH N UMBER","I" )_",","DAT E FIRST SE NT","I")
  3911    . I IBBDT ,(IBBDT<IB IDT) S IBX =0
  3912    Q IBX
  3913   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  3914   IBCF23A ;A LB/ARH - H CFA 1500 1 9-90 DATA  - Split fr om IBCF23  ;12-JUN-93
  3915    ;;2.0;INT EGRATED BI LLING;**51 ,432,516,5 47,577,592 ,608**;21- MAR-94;Bui ld 3
  3916    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3917    ;
  3918    ; $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) - I CR 10141
  3919    ;
  3920   B24 ; set  individual  entries i n print ar ray, exter nal format
  3921    ; IBAUX =  additiona l data for  EDI outpu t
  3922    ; IBRXF =  array of  RX procedu res
  3923    ;JWS;IB*2 .0*592;US1 31
  3924    ; IBDEN =  Dental da ta for EDI  output
  3925    ; IBDEN1  = array of  Dental da ta for EDI  output
  3926    N IBX,Z,I BD1,IBD2,I BCPLINK
  3927    S IBI=IBI +1,IBPROC= $P(IBSS,U, 2),IBD1=$$ DATE^IBCF2 3(IBDT1),I BD2=$S(IBD T1'=IBDT2: $$DATE^IBC F23(IBDT2) ,1:"")
  3928    I '$D(IBX IEN) S IBD 1=$E(IBD1, 5,8)_$E(IB D1,1,4),IB D2=$E(IBD2 ,5,8)_$E(I BD2,1,4)
  3929    S IBFLD(2 4,IBI)=IBD 1_U_IBD2_U _$P($G(^IB E(353.1,+$ P(IBSS,U,6 ),0)),U)_U _$P($G(^IB E(353.2,+$ P(IBSS,U,7 ),0)),U)
  3930    I +IBPROC  D
  3931    . S IBFLD (24,IBI)=I BFLD(24,IB I)_U_$P($$ PRCD^IBCEF 1(IBPROC,1 ),U,2) S:$ P(IBPROC," ;",2)'["IC PT" IBFLD( 24,IBI_"X" )=""
  3932    I 'IBPROC  S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$S('$D( IBXIEN):IB PROC,1:+IB REV),IBFLD (24,IBI_"A ")=$P($G(^ DGCR(399.2 ,+IBREV,0) ),U,2)
  3933    I $D(IBRX F),IBCHARG ="" S IBFL D(24,IBI_" A")=$P($G( ^DGCR(399. 2,+IBREV,0 )),U,2)
  3934    S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_$P(IBSS ,U,5)_U_IB CHARG_U_IB UNIT_U_$P( IBSS,U,8)_ U_$G(IBPCH G)_U_$G(IB MIN)_U_$G( IBEMG)
  3935    I $D(IBSS ("L")) S Z =0 F  S Z= $O(IBSS("L ",Z)) Q:'Z   S IBFLD( 24,IBI,$P( IBSS("L",Z ),U),$P(IB SS("L",Z), U,2))=$G(I BFLD(24,IB I,$P(IBSS( "L",Z),U), $P(IBSS("L ",Z),U,2)) )+1
  3936    S:$TR($G( IBAUX),U)' ="" IBFLD( 24,IBI,"AU X")=$G(IBA UX)
  3937    S:$D(IBRX F) IBFLD(2 4,IBI,"RX" )=IBRXF
  3938    K IBPROC, IBSS("L")
  3939    S IBCPLIN K=$P(IBSS, U,$L(IBSS, U))
  3940    S IBFLD(2 4,IBI)=IBF LD(24,IBI) _U_IBCPLIN K
  3941    ; MRD;IB* 2.0*516 -  Added NDC  and Units  to line le vel of cla im.
  3942    ;I IBCPLI NK'="" S $ P(IBFLD(24 ,IBI),U,14 ,15)=$TR($ P($G(^DGCR (399,IBIFN ,"CP",IBCP LINK,1)),U ,7,8),"-")
  3943    ; vd/Begi nning of I B*2*577 -  Added Unit /Basis of  Measurment  to line l evel of cl aim.
  3944    I IBCPLIN K'="" S $P (IBFLD(24, IBI),U,14, 16)=$TR($P ($G(^DGCR( 399,IBIFN, "CP",IBCPL INK,1)),U, 7,8),"-")_ U_$P($G(^D GCR(399,IB IFN,"CP",I BCPLINK,2) ),U)
  3945    ; vd/End  of IB*2*57 7
  3946    ;JWS;IB*2 .0*592;US1 31
  3947    I $G(IBDE N)'="" S I BFLD(24,IB I,"DEN")=$ G(IBDEN)
  3948    I $D(IBDE N1) M IBFL D(24,IBI," DEN1")=IBD EN1
  3949    I $D(IBDE ND) S IBFL D(24,IBI," DEND")=$G( IBDEND)
  3950    ;end ;JWS ;IB*2.0*59 2;US131
  3951    Q
  3952    ;
  3953   AUXOK(IBSS ,IBSS1) ;  Check all  other flds  are the s ame to com bine procs
  3954    ; IBSS =  subscript  of IBCP to  check for  dups to c ombine - p ass by ref
  3955    ; IBSS(IB SS,"AUX-X" ,n) = all  the previo usly extra cted line  items for  the
  3956    ;  same s et of basi c data, bu t having d ifferent " AUX" data
  3957    ; IBSS1 =  the "AUX"  data of t he current  IBCP entr y
  3958    ;
  3959    ; Returns  entry # i n IBSS arr ay if matc h found, o r 0 if no  match
  3960    ; Set the  IBSS "AUX -X" node f or no matc h
  3961    N Z,Z0,Z1 ,XIEN
  3962    S Z=0 F   S Z=$O(IBS S(IBSS,"AU X-X",Z)) Q :'Z  I IBS S1=IBSS(IB SS,"AUX-X" ,Z) Q
  3963    ;JWS;IB*2 .0*592;Den tal fields  to check  for roll-u p
  3964    S XIEN=$G (IBSS(IBSS ,1))
  3965    I $D(IBCP (IBPO,"DEN "))!($D(IB CP(IBPO,"D EN1")))!($ D(IBCP(IBP O,"DEND")) )!($D(IBCP (XIEN,"DEN ")))!($D(I BCP(XIEN," DEN1")))!( $D(IBCP(XI EN,"DEND") )) D
  3966    . I $G(IB CP(IBPO,"D EN"))'=$G( IBCP(XIEN, "DEN")) S  Z=0 Q
  3967    . I $G(IB CP(IBPO,"D END"))'=$G (IBCP(XIEN ,"DEND"))  S Z=0 Q
  3968    . S Z1=0  F  S Z1=$O (IBCP(IBPO ,"DEN1",Z1 )) Q:'Z1   I $G(IBCP( IBPO,"DEN1 ",Z1,0))'= $G(IBCP(XI EN,"DEN1", Z1,0)) S Z =0 Q
  3969    I 'Z S Z0 =+$O(IBSS( IBSS,"AUX- X",""),-1) +1,IBSS(IB SS,"AUX-X" ,Z0)=IBSS1
  3970    Q +Z
  3971    ;
  3972   PRC ; Extr act proced ure data f or HCFA 15 00
  3973    ; IBRC(IB SS) = #rev  codes wit h same bil ling crite ria (IBSS)
  3974    ; IBLINK( 'CP' ien,' RC' ien) =  IBSS incl uding modi fiers,rx s eq in pc 7 ,8
  3975    ; IBLINK1 (IBSS, 'RC ' ien) =   auto (1)^  'CP' ien ( soft link)
  3976    ;
  3977    ; proc ar ray w/chrg
  3978    ;JWS;IB*2 .0*592;US1 31; added  IBLN1, IBD ENLN
  3979    N IBPR,IB P,IBDENLN, IBLN1
  3980    S IBI=0 F   S IBI=$O (^DGCR(399 ,IBIFN,"CP ",IBI)) Q: 'IBI  S IB LN=^(IBI,0 ),IBLN1=$G (^(1)),IBA UXLN=$G(^( "AUX")),IB DENLN=$G(^ ("DEN")) D
  3981    . I $O(^D GCR(399,IB IFN,"CP",I BI,"DEN1", 0)) M IBDE NLN("DEN1" )=^DGCR(39 9,IBIFN,"C P",IBI,"DE N1")
  3982    . ;end ;J WS;IB*2.0* 592;US131
  3983    . N Z,Z0, Z1,Q1
  3984    . S IBPDT =$P(IBLN,U ,2)
  3985    . S IBSS= $$IBSS(IBI ,.IBDXI,IB LN)
  3986    . S IBPO= $S($P(IBLN ,U,4):+$P( IBLN,U,4), 1:IBI+1000 ) ;Set pri nt order
  3987    . S IBCP( IBPO)=IBPD T_"^"_IBSS ,IBCP(IBPO ,"AUX")=IB AUXLN
  3988    . S IBCP( IBPO,"LNK" )=IBI
  3989    . ;JWS;IB *2.0*592;U S131
  3990    . I $G(IB LN1)'="" S  IBCP(IBPO ,"DEND")=I BLN1
  3991    . I $G(IB DENLN)'=""  S IBCP(IB PO,"DEN")= IBDENLN
  3992    . I $O(IB DENLN("DEN 1",0)) M I BCP(IBPO," DEN1")=IBD ENLN("DEN1 ")
  3993    . ;end ;J WS;IB*2.0* 592;US131
  3994    . ; Rx
  3995    . N IBZ,I BITEM
  3996    . S IBZ=$ S($P(IBSS, U):$P(IBSS ,U),1:"")
  3997    . I IBZ'= "",$D(IBLI NKRX(IBZ,I BI)) D  Q: IBCHARG'=" "
  3998    .. S IBPO 1=IBPO
  3999    .. S IBIT EM=+$O(IBL INKRX(IBZ, IBI,0)),IB RV=$G(IBLI NKRX(IBZ,I BI,IBITEM) )
  4000    .. Q:$S(I BRV="":1,1 :'$G(IBRC( IBRV)))
  4001    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  4002    .. S $P(I BCP(IBPO1) ,U,9)=IBCH ARG,IBCP(I BPO1,"RX") =IBITEM K  IBLINKRX(I BZ,IBI,IBI TEM)
  4003    . ; find  chrgs dire ctly linke d to proc
  4004    . S IBK=0  F  S IBK= $O(IBLINK( IBI,IBK))  Q:'IBK  S  IBRV1=IBLI NK(IBI,IBK ),IBRV=$P( IBRV1,U,1, 6) I +IBRC (IBRV1) D
  4005    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV1)=I BRC(IBRV1) -1
  4006    .. I IBCH ARG'="" S  $P(IBSS,U, 8)=IBCHARG ,IBCP(IBPO )=IBPDT_"^ "_IBSS,IBP O=IBPO+.1
  4007    ;
  4008    ; add chr gs associa ted with a  proc (not  a direct  link)
  4009    ; find ch rg associa ted with p roc, if an y (match p roc,div,+/ -basc)
  4010    K IBP(0)
  4011    F IBP=3,2  Q:$D(IBP( 0))  S IBP O="" F  S  IBPO=$O(IB CP(IBPO))  Q:'IBPO  I  $P(IBCP(I BPO),U,9)= "" D
  4012    . S IBSS= $P(IBCP(IB PO),U,2,9)
  4013    . S IBCHA RG="",(IBR V,IBSS)=$P (IBSS,U,1, IBP) F  S  IBRV=$O(IB RC(IBRV))  Q:$P(IBRV, U,1,IBP)'= IBSS  S IB P(0)=0 I + IBRC(IBRV)  D  Q
  4014    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  4015    .. I IBRC (IBRV) S Z =0 F  S Z= $O(IBCP(IB PO,Z)) Q:' Z  S IBRC( IBRV)=IBRC (IBRV)-1
  4016    . S $P(IB CP(IBPO),U ,9)=IBCHAR G
  4017    . I IBCHA RG'="" S Z =$O(IBLINK 1(IBRV,0))  I Z S IBC P(IBPO,"L" ,Z)=IBLINK 1(IBRV,Z)  K IBLINK1( IBRV,Z)
  4018    ;
  4019    ; add chr gs not ass ociated wi th a proc  to first p roc with n o chrg
  4020    ; Aggggh! !! TP
  4021    S IBPO=""  F  S IBPO =$O(IBCP(I BPO)) Q:'I BPO  I $P( IBCP(IBPO) ,U,9)="" D
  4022    . S IBCHA RG="",IBRV ="^" F  S  IBRV=$O(IB RC(IBRV))  Q:IBRV=""! +IBRV  I + IBRC(IBRV)  D  Q
  4023    .. S IBCH ARG=$P(IBR V,U,6),IBR C(IBRV)=IB RC(IBRV)-1
  4024    .. S Z=$O (IBLINK1(I BRV,0)) I  Z S IBCP(I BPO,"L",Z) =IBLINK1(I BRV,Z) K I BLINK1(IBR V,Z)
  4025    . S $P(IB CP(IBPO),U ,9)=IBCHAR G
  4026    ;
  4027    Q
  4028   IBSS(IBI,I BDXI,IBLN)  ; Creates  index seq uence for  procedure
  4029    N IBPC,IB J,IBSS,IBL PI,IBX,IBL PAR
  4030    S (IBPC,I BLPI)=0
  4031    F IBJ=1,6 ,5,0,9,10  S IBPC=IBP C+1 S:IBJ  $P(IBSS,U, IBPC,IBPC+ 1)=($P(IBL N,U,IBJ)_U )
  4032    S $P(IBSS ,U,7)=($$G ETMOD^IBEF UNC(IBIFN, IBI)_U) ;M odifiers
  4033    ;IB*547/T AZ - IBDXI  not defin ed, use in ternal DX  pointer
  4034    I '$G(IBN WPTCH) F I BJ=11:1:14  I $P(IBLN ,U,IBJ) S  $P(IBSS,U, 4)=$P(IBSS ,U,4)_$S(I BJ>11:",", 1:"")_$G(I BDXI(+$P(I BLN,U,IBJ) )) ; dx
  4035    I $G(IBNW PTCH) F IB J=11:1:14  S IBX=$P(I BLN,U,IBJ)  I IBX S $ P(IBSS,U,4 )=$P(IBSS, U,4)_$S(IB J>11:",",1 :"")_$G(IB DXI(IBX),I BX) ; dx
  4036    S $P(IBSS ,U,10)=$P( IBLN,U,16) ,$P(IBSS,U ,9)=$P(IBL N,U,19),$P (IBSS,U,11 )=+$P(IBLN ,U,17)
  4037    G:'$G(IBN WPTCH) IBS SX
  4038    ;IB*547/T AZ - Add a dditional  fields for  roll-up c ompare
  4039    S $P(IBSS ,U,21)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ASSO CIATED CLI NIC","I")
  4040    S $P(IBSS ,U,22)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","TYPE  OF SERVIC E","I")
  4041    S $P(IBSS ,U,23)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ATTA CHMENT CON TROL NUMBE R","I")
  4042    S $P(IBSS ,U,24)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","NDC" ,"I")
  4043    S $P(IBSS ,U,25)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","PROC EDURE DESC RIPTION"," I")
  4044    S $P(IBSS ,U,26)=$$G ET1^DIQ(39 9.0304,IBI _","_IBIFN _",","ADDI TIONAL OB  MINUTES"," I")
  4045    ;JRA;IB*2 .0*608 Put  Certifica te of Medi cal Necess ity (CMN)  info in pi eces 30,31 ,32
  4046    M IBLPAR= ^DGCR(399, IBIFN,"CP" ,IBI)
  4047    S $P(IBSS ,U,30)=$TR ($G(IBLPAR ("CMN")),U ,"~")
  4048    S $P(IBSS ,U,31)=$TR ($G(IBLPAR ("CMN-1012 6")),U,"~" )
  4049    S $P(IBSS ,U,32)=$TR ($G(IBLPAR ("CMN-484" )),U,"~")
  4050    K IBLPAR
  4051    ;Add Prov ider info  in pieces  41-49
  4052    M IBLPAR= ^DGCR(399, IBIFN,"CP" ,IBI,"LNPR V")
  4053    F  S IBLP I=$O(IBLPA R(IBLPI))  Q:'IBLPI   S IBX=IBLP AR(IBLPI,0 ),$P(IBSS, U,40+IBX)= $TR(IBX,"^ ","~")
  4054    K IBLPAR
  4055   IBSSX ;
  4056    Q IBSS
  4057    ;
  4058   IBNWPTCH(I BIFN,IBPAT CH) ;
  4059    ;Checks t he date th e primary  claim was  1st transm itted and  returns 1  if the tra nsmitted d ate is aft er the pat ch
  4060    ;referenc ed in vari able IBPAT CH was rel eased. Thi s allows t he MRA/EOB s returnin g to roll  up procedu res the sa me
  4061    ;way as t hey went o ut.  Other wise the o rder chang es and the  MRA/EOB w on't match  up.
  4062    ;
  4063    N IBARY,I BIDT,IBPFN ,IBEFN,IBB N,IBX,IBBD T
  4064    S IBX=0
  4065    I $$INSTA LDT^XPDUTL (IBPATCH,. IBARY) D    ;ICR 1014 1
  4066    . S IBX=1
  4067    . S IBIDT =$O(IBARY( ""))
  4068    . ; Get P rimary Bil l Number.  This will  insure COB  data is c onsistent  across all  bills.
  4069    . S IBPFN =$$GET1^DI Q(399,IBIF N_",","PRI MARY BILL  #","I") I  'IBPFN S I BPFN=IBIFN
  4070    . ; Find  1st Accept ed Entry ( A1, A2, or  Z) of Pri mary Bill  in EDI TRA NSMIT BILL  FILE (364 ) to deter mine Batch  Number
  4071    . S (IBEF N,IBBN)=0  F  S IBEFN =$O(^IBA(3 64,"B",IBP FN,IBEFN))  Q:'IBEFN   D  I IBBN  Q
  4072    .. I ",A1 ,A2,Z,"'[( ","_$$GET1 ^DIQ(364,I BEFN_","," TRANSMISSI ON STATUS" ,"I")_",")  Q
  4073    .. S IBBN =$$GET1^DI Q(364,IBEF N_",","BAT CH NUMBER" ,"I")
  4074    . ;Retrie ve the dat e the batc h was 1st  sent.  If  IBBN="" IB BDT will b e null
  4075    . S IBBDT =$$GET1^DI Q(364.1,$$ GET1^DIQ(3 64,IBBN_", ","BATCH N UMBER","I" )_",","DAT E FIRST SE NT","I")
  4076    . I IBBDT ,(IBBDT<IB IDT) S IBX =0
  4077    Q IBX
  4078  
  4079   X)  Modify  cloning o f a claim:
  4080   IBCCC2 – C opy CMN no des to new  claim whe n doing a  cancel/cop y
  4081   Routines
  4082   Activities
  4083   Routine Na me
  4084   IBCCC2
  4085   Enhancemen t Category
  4086    New
  4087    Modify
  4088    Delete
  4089    No Change
  4090   RTM
  4091  
  4092   Related Op tions
  4093   None
  4094   Related Ro utines
  4095   Routines “ Called By”
  4096   Routines “ Called”   
  4097  
  4098  
  4099  
  4100  
  4101   Data Dicti onary (DD)  Reference s
  4102  
  4103   Related Pr otocols
  4104   None
  4105   Related In tegration  Control Re gistration s (ICRs)
  4106   None
  4107   Data Passi ng
  4108    Input
  4109    Output Re ference
  4110    Both
  4111    Global Re ference
  4112    Local
  4113   Input Attr ibute Name  and Defin ition
  4114   Name:
  4115   Definition :
  4116   Output Att ribute Nam e and Defi nition
  4117   Name:
  4118   Definition :
  4119   Current Lo gic
  4120   IBCCC2 ;AL B/AAS - CA NCEL AND C LONE A BIL L - CONTIN UED ;6/6/0 3 9:56am
  4121    ;;2.0;INT EGRATED BI LLING;**80 ,106,124,1 38,51,151, 137,161,18 2,211,245, 155,296,32 0,348,349, 371,400,43 3,432,447, 516,577,59 2**;21-MAR -94;Build  25
  4122    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4123    ;
  4124    ;MAP TO D GCRCC2
  4125    ;
  4126    ;STEP 5 -  get remai nder of da ta to move  and store  in MCCR t hen x-ref
  4127    ;STEP 6 -  go to scr eens, come  out to IB B1 or some thing like  that
  4128    ;
  4129   STEP5 S IB IFN1=$P(^D GCR(399,IB IFN,0),"^" ,15) G END :$S(IBIFN1 ="":1,'$D( ^DGCR(399, IBIFN1,0)) :1,1:0)
  4130    ; NOTE:   any new or  changed d ata nodes  may also n eed to be  updated in  IBNCPDP5
  4131    ;move pur e data nod es
  4132    ; MRD;IB* 2.0*516 -  Added "In7 " nodes.
  4133    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)
  4134    ;
  4135    ;move top  level dat a node. ;D o not move  'TX' node  EXCEPT pi ece 8 (add ed with IB *2.0*432)
  4136    ;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
  4137    ; add new  data node s introduc ed with IB *2.0*432
  4138    F I="TX", "U","U1"," U2","U3"," U4","U5"," U6","U7"," U8","UF2", "UF3","UF3 1","UF32", "C","M" I  $D(^DGCR(3 99,IBIFN1, I)) S IBND (I)=^(I) D  @I
  4139    ;
  4140    ;move mul tiple leve l data
  4141    ;F I="CC" ,"OC","OP" ,"OT","RC" ,"CP","CV" ,"PRV" I $ D(^DGCR(39 9,IBIFN1,I ,0)) D @I
  4142    ; add new  data node s introduc ed with IB *2.0*447 B I
  4143    F I="CC", "OC","OP", "OT","RC", "CP","CV", "PRV","U9"  I $D(^DGC R(399,IBIF N1,I,0)) D  @I
  4144    ;
  4145    ;JWS;IB*2 .0*592;add  new Denta l Claim fi elds; IA#  3820
  4146    I $D(^DGC R(399,IBIF N1,"DEN"))  S ^DGCR(3 99,IBIFN," DEN")=^DGC R(399,IBIF N1,"DEN")
  4147    I $D(^DGC R(399,IBIF N1,"DEN1", 0)) S ^DGC R(399,IBIF N,"DEN1",0 )=^DGCR(39 9,IBIFN1," DEN1",0) D
  4148    . S K=0 F   S K=$O(^ DGCR(399,I BIFN1,"DEN 1",K)) Q:' K  S ^DGCR (399,IBIFN ,"DEN1",K, 0)=^DGCR(3 99,IBIFN1, "DEN1",K,0 )
  4149    I $D(^DGC R(399,IBIF N1,"DEN2") ) S ^DGCR( 399,IBIFN, "DEN2")=^D GCR(399,IB IFN1,"DEN2 ")
  4150    ;
  4151    ; IB*2.0* 432  ADDED  IBSILENT  flag so th at this ca n be proce ssed in ba ckground
  4152    D FTPRV^I BCEU5(IBIF N,$G(IBSIL ENT)) ; As k change p rov type i f form typ e not the  same
  4153    D COBCHG( IBIFN,,.IB COB)
  4154    ;
  4155    D ^IBCCC3  ; copy ta ble files  (362.3)
  4156    ;
  4157    S I=$G(^D GCR(399,IB IFN1,0)) I  $P(I,U,13 )=7,$P(I,U ,20)=1 D C OPYB^IBCDC (IBIFN1,IB IFN) ; upd ate auto b ill files
  4158    D PRIOR(I BIFN) ; ad d new bill  to previo us bills i n series,  primary/se condary
  4159    ;
  4160    I +$G(IBC TCOPY) N I BAUTO S IB AUTO=1 D P ROC^IBCU7A (IBIFN),BI LL^IBCRBC( IBIFN),CPT MOD26^IBCU 73(IBIFN)  D RECALL^D ILFD(399,I BIFN_",",D UZ) G END
  4161    ;
  4162   STEP6 N IB GOEND
  4163    ; need to  kill CRD  flag prior  to enteri ng billing  screens i n case a c opy for co rrespondin g claim is  needed
  4164    K IBCNCRD
  4165    ; don't c all IB bil l edit scr eens if th is is non- MRA backgr ound proce ssing
  4166    I $G(IBST SM)=1 G EN D
  4167    I '$G(IBC E("EDI"))! $G(IBCE("E DI","NEW") ),'$G(IBCE AUTO) D IB SCEDT G EN D:$G(IBGOE ND)
  4168    ;
  4169    ;
  4170   END K DFN, IB,IBA,IBA 2,IBAD,IBA DD1,IBBNO, IBCAN,IBCC C,IBDA,IBD PT,IBDR,IB DT,IBI,IBI 1,IBIDS,IB IFN,IBIFN1 ,IBND,IBQU IT,IBU,IBU N,IBARST,I BCOB,IBCNC OPY,IBCBCO PY,IBCNCRD ,IBKEY
  4171    K IBV,IBV 1,IBW,IBWW ,IBYN,IBZZ ,PRCASV,PR CAERCD,PRC AERR,PRCAS VC,PRCAT,I BBT,IBCH,I BNDS,IBOA, IBREV,IBX, DGXRF1,VAE L,VAERR,IB AC,IBCCC,I BDD1,IBIN, DGREV,DGRE V00,DGREVH DR,IBCHK
  4172    K IBBS,IB LS,DGPCM,I BIP,IBND0, IBNDU,IBO, IBPTF,IBST ,IBUC,IBDD ,D,%,%DT,D IC,VA,VADM ,X,X1,X2,X 3,X4,Y,I,J ,K,DGRVRCA L,DDH,DGAC TDT,DGAMNT ,DGBR,DGBR N,DGBSI,DG BSLOS,IBA1 ,IBOD,IBIN S,IBN,IBPR OC,DGFUNC, DGIFN
  4173    Q
  4174    ;
  4175    ;
  4176   IBSCEDT ;  call the I B bill edi t screens  and valida te the dat a
  4177    N IBV,IBP AR,IBAC,IB HV,IBH,IBC IREDT
  4178    ; 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
  4179    ; also, i f the user  came from  CBW->PC a nd this is  a non-MRA  claim and  the only  EEOB we ha ve has fil ing errors , set forc e print fl ag
  4180    I $G(IBMR ANOT)=1,$$ COBN^IBCEF (IBIFN)>1, $G(IBFROM) =2 D 
  4181    .I $G(IBD A)="" D FO RCEPRT^IBC APP($G(IBI FN)) Q
  4182    .I $D(^IB M(361.1,IB DA,"ERR"))  D FORCEPR T^IBCAPP($ G(IBIFN))  Q
  4183    D RECALL^ DILFD(399, IBIFN_",", DUZ)
  4184   ST1 S IBV= 0 D ^IBCSC U,^IBCSC1  I $G(IBPOP OUT) S IBG OEND=1 G I BSCX
  4185    S IBAC=1
  4186    D ^IBCB1
  4187    I $G(IBCI REDT) G ST 1
  4188   IBSCX ;
  4189    Q
  4190    ;
  4191    ;
  4192   TX F J=8 I  $P(IBND(" TX"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"TX" ),"^",J)=$ P(IBND("TX "),"^",J)
  4193    Q
  4194   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)
  4195    Q
  4196   U1 F J=1:1 :3,15 I $P (IBND("U1" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"U1")," ^",J)=$P(I BND("U1"), "^",J)
  4197    Q
  4198   U2 F J=1:1 :19 I $P(I BND("U2"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U2"),"^" ,J)=$P(IBN D("U2"),"^ ",J)
  4199    Q
  4200   U3 F J=1:1 :11 I $P(I BND("U3"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U3"),"^" ,J)=$P(IBN D("U3"),"^ ",J)
  4201    Q
  4202   UF2 F J=1, 3 I $P(IBN D("UF2")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "UF2"),"^" ,J)=$P(IBN D("UF2")," ^",J)
  4203    Q
  4204   UF3 F J=4: 1:6 I $P(I BND("UF3") ,"^",J)]""  S $P(^DGC R(399,IBIF N,"UF3")," ^",J)=$P(I BND("UF3") ,"^",J)
  4205    Q
  4206   U4 F J=1:1 :14 I $P(I BND("U4"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U4"),"^" ,J)=$P(IBN D("U4"),"^ ",J)
  4207    Q
  4208   U5 F J=1:1 :6 I $P(IB ND("U5")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U5"),"^", J)=$P(IBND ("U5"),"^" ,J)
  4209    Q
  4210   U6 F J=1:1 :6 I $P(IB ND("U6")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U6"),"^", J)=$P(IBND ("U6"),"^" ,J)
  4211    Q
  4212   U7 F J=1:1 :5 I $P(IB ND("U7")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U7"),"^", J)=$P(IBND ("U7"),"^" ,J)
  4213    Q
  4214   U8 F J=1:1 :3 I $P(IB ND("U8")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U8"),"^", J)=$P(IBND ("U8"),"^" ,J)
  4215    Q
  4216   UF31 F J=3  I $P(IBND ("UF31")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "UF31"),"^ ",J)=$P(IB ND("UF31") ,"^",J)
  4217    Q
  4218   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 )
  4219    Q
  4220   C F J=10 I  $P(IBND(" C"),"^",J) ]"" S $P(^ DGCR(399,I BIFN,"C"), "^",J)=$P( IBND("C"), "^",J)
  4221    I '$D(^DG CR(399,IBI FN1,"CP"))  D CP1
  4222    Q
  4223   M F J=1:1: 9,11:1:14  I $P(IBND( "M"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"M") ,"^",J)=$P (IBND("M") ,"^",J)
  4224    Q
  4225   CC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4226    S IBDD=39 9.04 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)=^DG CR(399,IBI FN1,I,J,0) ,X=$P(^(0) ,"^")
  4227   OP S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4228    S IBDD=39 9.043 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 ),"^")
  4229    Q
  4230   OC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4231    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 ),"^")
  4232    Q
  4233   OT S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4234    S IBDD=39 9.048 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 ),"^")
  4235    Q
  4236   CV ; Don't  copy valu e codes fr om inpatie nt inst to  inpatient  prof bill s
  4237    I $$FT^IB CEF(IBIFN1 )'=2,$$FT^ IBCEF(IBIF N)=2 Q
  4238    S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0)
  4239    S IBDD=39 9.047 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 ),"^")
  4240    Q
  4241   RC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4242    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)
  4243    Q
  4244   CP S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4245    I +$G(IBN OCPT) Q
  4246    S IBDD=39 9.0304 F J =0:0 S J=$ O(^DGCR(39 9,IBIFN1,I ,J)) Q:'J   I $D(^(J, 0)) S IBND ("CP")=^(0 ),IBND("CP 1")=$G(^(1 )),IBND("C P2")=$G(^( 2)),IBND(" CP-AUX")=$ G(^("AUX") ) D
  4247    . 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)
  4248    . ; IB*2. 0*432 add  new 1 node
  4249    . ; MRD;I B*2.0*516  - Added pi eces 7 & 8  (NDC, Uni ts) to 1-n ode.
  4250    . F K=1:1 :8 S $P(^D GCR(399,IB IFN,I,J,1) ,"^",K)=$P (IBND("CP1 "),"^",K)
  4251    . ; WCJ;I B*2.0*577  - Added pi ece 1 (UNI TS/BASIS O F MEASUREM ENT) to 2- node.
  4252    . F K=1:1 :1 S $P(^D GCR(399,IB IFN,I,J,2) ,"^",K)=$P (IBND("CP2 "),"^",K)
  4253    . ; esg -  11/2/06 -  IB*2*348  - 50.09 fi eld was ad ded - AUX  piece [9]
  4254    . I IBND( "CP-AUX")' ="" F K=1: 1:9 S $P(^ DGCR(399,I BIFN,I,J," AUX"),"^", K)=$P(IBND ("CP-AUX") ,"^",K)
  4255    . ; IB*2. 0*432 add  new LNPRV  multiple
  4256    . 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
  4257    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"LNPRV",K )) Q:'K  D
  4258    ... S ^DG CR(399,IBI FN,I,J,"LN PRV",K,0)= ^DGCR(399, IBIFN1,I,J ,"LNPRV",K ,0)
  4259    . 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
  4260    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"MOD",K))  Q:'K  D
  4261    ... I $G( IBNOTC),$P ($$MOD^ICP TMOD(+$P($ G(^DGCR(39 9,IBIFN1,I ,J,"MOD",K ,0)),U,2), "I"),U,2)= "TC" Q  ;  Don't copy  TC modifi er from in st to prof  bill
  4262    ... S ^DG CR(399,IBI FN,I,J,"MO D",K,0)=^D GCR(399,IB IFN1,I,J," MOD",K,0)
  4263    . ;JWS;IB *2.0*592;a dd new Den tal claim  form field s
  4264    . I $D(^D GCR(399,IB IFN1,I,J," DEN")) S ^ DGCR(399,I BIFN,I,J," DEN")=^DGC R(399,IBIF N1,I,J,"DE N")
  4265    . I $D(^D GCR(399,IB IFN1,I,J," DEN1",0))  S ^DGCR(39 9,IBIFN,I, J,"DEN1",0 )=^DGCR(39 9,IBIFN1,I ,J,"DEN1", 0) D
  4266    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"DEN1",K) ) Q:'K  D
  4267    ... S ^DG CR(399,IBI FN,I,J,"DE N1",K,0)=^ DGCR(399,I BIFN1,I,J, "DEN1",K,0 )
  4268   CP1 S IBCO D=$P($G(^D GCR(399,IB IFN,0)),"^ ",9) Q:IBC OD=""!('$D (^DGCR(399 ,IBIFN1,"C ")))
  4269    I IBCOD=9  F DGI=4,5 ,6 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S  X=$P(^("C "),"^",DGI )_";ICD0(" ,DGPROCDT= $P(^("C"), "^",DGI+7)  D FILE
  4270    I IBCOD=4  F DGI=1,2 ,3 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S  X=$P(^("C "),"^",DGI )_";ICPT(" ,DGPROCDT= $P(^("C"), "^",DGI+10 ) D FILE
  4271    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
  4272    Q
  4273    ;
  4274   PRV ; Copy  providers  for clone d claim
  4275    N Z,Z0,CN T
  4276    S Z=$P($G (^DGCR(399 ,IBIFN,0)) ,U,19),Z0= $P($G(^DGC R(399,IBIF N1,0)),U,1 9),CNT=0
  4277    S IBDD=39 9.0222 F J =0:0 S J=$ O(^DGCR(39 9,IBIFN1,I ,J)) Q:'J   I $D(^(J, 0)) D
  4278    . I $$GET NPI^IBCEF7 3A($P(^DGC R(399,IBIF N1,I,J,0), U,2))="" Q   ;Don't f ile provid er if no N PI - IB*2* 516
  4279    . S CNT=C NT+1,^DGCR (399,IBIFN ,I,CNT,0)= ^DGCR(399, IBIFN1,I,J ,0),X=$P(^ (0),"^")
  4280    . I Z'=Z0 ,$S(X=3:Z0 =3,X=4:Z0= 2,1:0) S $ P(^DGCR(39 9,IBIFN,I, CNT,0),U)= (Z0+1)
  4281    I CNT S ^ DGCR(399,I BIFN,I,0)= ^DGCR(399, IBIFN1,I,0 ),$P(^DGCR (399,IBIFN ,I,0),U,3) =CNT,$P(^D GCR(399,IB IFN,I,0),U ,4)=CNT
  4282    Q
  4283    ;
  4284   U9 ; Added  for new d ata elemen ts in IB*2 .0*447 BI
  4285    M ^DGCR(3 99,IBIFN,I )=^DGCR(39 9,IBIFN1,I )
  4286    Q
  4287    ;
  4288   COB S J=0  F  S J=$O( IBCOB(I,J) ) Q:'J  S  $P(^DGCR(3 99,IBIFN,I ),U,J)=IBC OB(I,J)
  4289    Q
  4290    ;
  4291   FILE N DIC ,DIE,DR,DA ,X,Y,DLAYG O,DD,DO
  4292    I '$D(^DG CR(399,IBI FN,"CP",0) ) S DIC("P ")=$$GETSP EC^IBEFUNC (399,304)
  4293    S DIC(0)= "L",DLAYGO =399,DA(1) =IBIFN,DIC ="^DGCR(39 9,"_DA(1)_ ",""CP"","  Q:X=""  D  FILE^DICN  K DO,DD Q :+Y<1  S D A=+Y
  4294    S DIE="^D GCR(399,"_ DA(1)_","" CP"",",DR= "1///"_DGP ROCDT D ^D IE
  4295    K DGPROCD T
  4296    Q
  4297    ;
  4298   INDEX ;ind ex entire  file (set  logic)
  4299    N IBMAED  D SAVERC(I BIFN,.IBMA ED)  ; IB* 2.0*447 BI  - Save th e value of  piece 16  of each RC  node befo re re-inde xing.
  4300    S DIK="^D GCR(399,", DA=IBIFN D  IX1^DIK K  DA,DIK
  4301    D RESTRC( IBIFN,.IBM AED)  ; IB *2.0*447 B I - Restor e the valu e of piece  16 of eac h RC node  before re- indexing.
  4302    Q
  4303    ;
  4304   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
  4305    N IBSEQ,I BSEQN,IBM1 ,I,IBIFN1
  4306    S IBSEQ=$ $COB^IBCEF (IBIFN)
  4307    S IBSEQN= $S(IBSEQ=" S":6,IBSEQ ="T":7,1:" ") Q:'IBSE QN
  4308    ;
  4309    S IBM1=$G (^DGCR(399 ,IBIFN,"M1 ")) I +$P( ^DGCR(399, IBIFN,0),U ,13)=7 S I BIFN=""
  4310    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
  4311    Q
  4312    ;
  4313   COBCHG(IBI FN,IBINS,I BCOB) ; Ma ke changes  for a new  COB payer  for bill
  4314    ; IBIFN =  ien of bi ll in file  399
  4315    ; IBINS =  ien of bi ll's curre nt insuran ce (option al)
  4316    ; IBCOB =  array sub scripted b y node,pie ce of COB  data field  change
  4317    ;
  4318    N I,IBFRM TYP,IBTAXL ST
  4319    ; Subtrac t the Prio r Payments  from the  bill's Off set (these  are re-ad ded by tri ggers)
  4320    F I=4,5,6   S $P(^DG CR(399,IBI FN,"U1"),U ,2)=$P($G( ^DGCR(399, IBIFN,"U1" )),U,2)-$P ($G(^DGCR( 399,IBIFN, "U2")),U,I )
  4321    ;
  4322    I $G(IBIN S),$$MCRWN R^IBEFUNC( IBINS) D
  4323    . ;MCRWNR  is curren t insuranc e ... move  payer onl y
  4324    . N IBCOB N,IBX
  4325    . S IBCOB N=$$COBN^I BCEF(IBIFN )
  4326    . S IBCOB (0,21)=$P( "S^T^",U,I BCOBN)
  4327    . S IBCOB ("M1",IBCO BN+4)=IBIF N
  4328    . S IBCOB ("TX",1)=" ",IBCOB("T X",2)=""
  4329    . S IBX=$ $REQMRA^IB EFUNC(IBIF N)
  4330    . I IBX=0  S IBCOB(" TX",5)=0                            ; MRA n ot needed
  4331    . I IBX[" R" S IBCOB ("TX",5)=" A"                       ; MRA s kipped
  4332    . I IBX=1 ,$$CHK^IBC EMU1(IBIFN ) S IBCOB( "TX",5)="C "  ; MRA o n file
  4333    . I $G(IB PRCOB) S I BCOB("TX", 5)="C"                   ; MRA b eing proc' d
  4334    . D PRIOR (IBIFN)
  4335    . Q
  4336    ;
  4337    ;reset fi elds for n ext Sequen ce Payer
  4338    F I=0,"M1 ","U2","TX " I $D(IBC OB(I)) D C OB
  4339    ;
  4340    ; IB*2.0* 211
  4341    ; save of f Form Typ e
  4342    S IBFRMTY P=$P($G(^D GCR(399,IB IFN,0)),U, 19)
  4343    ; Save of f Taxonomi es for pro viders.
  4344    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)
  4345    ;
  4346    ; fire xr efs set lo gic
  4347    D INDEX
  4348    ;
  4349    ; Restore  Form Type  if change d, but don 't restore  Form Type  if
  4350    ;   creat ing CMS-15 00 claim f rom CTCOPY 1^IBCCCB
  4351    I $G(IBCT COPY)'=1,I BFRMTYP'=$ P($G(^DGCR (399,IBIFN ,0)),U,19)  N DA,DIE, DR S DA=IB IFN,DIE="^ DGCR(399," ,DR=".19// //"_IBFRMT YP D ^DIE
  4352    ;
  4353    ; Restore  Claim MRA  Status fi eld since  triggers i n fields 1 01 & 102
  4354    ;   will  overwrite  the correc t value wh en process ing the MR A/EOB.
  4355    ; If we'r e processi ng the MRA /EOB, then  a valid M RA has bee n received .
  4356    I $G(IBPR COB) N DA, DIE,DR S D A=IBIFN,DI E="^DGCR(3 99,",DR="2 4////C" D  ^DIE
  4357    ;
  4358    ; Only if  cloning,  then resto re Taxonom ies in fie lds 243 an d 244 and  252.
  4359    I '$G(IBI NS),'$G(IB PRCOB) D
  4360    . S I=$P( $G(IBND("U 3")),U,2)
  4361    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,2 ) D
  4362    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 3////"_$S( I'="":I,1: "@") D ^DI E
  4363    . ;
  4364    . S I=$P( $G(IBND("U 3")),U,3)
  4365    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,3 ) D
  4366    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 4////"_$S( I'="":I,1: "@") D ^DI E
  4367    . ;
  4368    . S I=$P( $G(IBND("U 3")),U,11)
  4369    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,1 1) D
  4370    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="25 2////"_$S( I'="":I,1: "@") D ^DI E
  4371    . Q
  4372    ;
  4373    ; Restore  Taxonomie s in field  .15 in su b-file 399 .0222.
  4374    S IBTAXLS T=0 F  S I BTAXLST=$O (IBTAXLST( IBTAXLST))  Q:'IBTAXL ST  D
  4375    . S I=IBT AXLST(IBTA XLST)
  4376    . I I=$P( $G(^DGCR(3 99,IBIFN," PRV",IBTAX LST,0)),U, 15) Q  ; N o change
  4377    . N DA,DI E,DR
  4378    . S DA(1) =IBIFN,DA= IBTAXLST
  4379    . S DIE=" ^DGCR(399, "_DA(1)_", ""PRV"",", DR=".15/// /"_$S(I'=" ":I,1:"@")
  4380    . D ^DIE
  4381    . Q
  4382    ;
  4383    K IBCOB(" TX")
  4384    Q
  4385    ;
  4386   SAVERC(IBI FN,IBMAED)   ; IB*2.0 *447 BI -  Save the v alue of pi ece 16 of  each RC no de before  re-indexin g.
  4387    Q:$G(IBCT COPY)=1  Q :$G(IBCTCO PY)=2
  4388    N IBCNT S  IBCNT=0
  4389    Q:'$G(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"RC "))
  4390    F  S IBCN T=$O(^DGCR (399,IBIFN ,"RC",IBCN T)) Q:+IBC NT=0  D
  4391    . S IBMAE D(IBCNT)=$ P($G(^DGCR (399,IBIFN ,"RC",IBCN T,0)),U,16 )
  4392    Q
  4393    ;
  4394   RESTRC(IBI FN,IBMAED)   ; IB*2.0 *447 BI -  Restore th e value of  piece 16  of each RC  node afte r re-index ing.
  4395    Q:$G(IBCT COPY)=1  Q :$G(IBCTCO PY)=2
  4396    N IBCNT S  IBCNT=0
  4397    Q:'$G(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"RC "))
  4398    F  S IBCN T=$O(IBMAE D(IBCNT))  Q:+IBCNT=0   D
  4399    . S $P(^D GCR(399,IB IFN,"RC",I BCNT,0),U, 16)=IBMAED (IBCNT)
  4400    Q
  4401   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  4402   IBCCC2 ;AL B/AAS - CA NCEL AND C LONE A BIL L - CONTIN UED ;6/6/0 3 9:56am
  4403    ;;2.0;INT EGRATED BI LLING;**80 ,106,124,1 38,51,151, 137,161,18 2,211,245, 155,296,32 0,348,349, 371,400,43 3,432,447, 516,592,60 8**;21-MAR -94;Build  40
  4404    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4405    ;
  4406    ;MAP TO D GCRCC2
  4407    ;
  4408    ;STEP 5 -  get remai nder of da ta to move  and store  in MCCR t hen x-ref
  4409    ;STEP 6 -  go to scr eens, come  out to IB B1 or some thing like  that
  4410    ;
  4411   STEP5 S IB IFN1=$P(^D GCR(399,IB IFN,0),"^" ,15) G END :$S(IBIFN1 ="":1,'$D( ^DGCR(399, IBIFN1,0)) :1,1:0)
  4412    ; NOTE:   any new or  changed d ata nodes  may also n eed to be  updated in  IBNCPDP5
  4413    ;move pur e data nod es
  4414    ; MRD;IB* 2.0*516 -  Added "In7 " nodes.
  4415    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)
  4416    ;
  4417    ;move top  level dat a node. ;D o not move  'TX' node  EXCEPT pi ece 8 (add ed with IB *2.0*432)
  4418    ;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
  4419    ; add new  data node s introduc ed with IB *2.0*432
  4420    F I="TX", "U","U1"," U2","U3"," U4","U5"," U6","U7"," U8","UF2", "UF3","UF3 1","UF32", "C","M" I  $D(^DGCR(3 99,IBIFN1, I)) S IBND (I)=^(I) D  @I
  4421    ;
  4422    ;move mul tiple leve l data
  4423    ;F I="CC" ,"OC","OP" ,"OT","RC" ,"CP","CV" ,"PRV" I $ D(^DGCR(39 9,IBIFN1,I ,0)) D @I
  4424    ; add new  data node s introduc ed with IB *2.0*447 B I
  4425    F I="CC", "OC","OP", "OT","RC", "CP","CV", "PRV","U9"  I $D(^DGC R(399,IBIF N1,I,0)) D  @I
  4426    ;
  4427    ;JWS;IB*2 .0*592;add  new Denta l Claim fi elds
  4428    I $D(^DGC R(399,IBIF N1,"DEN"))  S ^DGCR(3 99,IBIFN," DEN")=^DGC R(399,IBIF N1,"DEN")
  4429    I $D(^DGC R(399,IBIF N1,"DEN1", 0)) S ^DGC R(399,IBIF N,"DEN1",0 )=^DGCR(39 9,IBIFN1," DEN1",0) D
  4430    . S K=0 F   S K=$O(^ DGCR(399,I BIFN1,"DEN 1",K)) Q:' K  S ^DGCR (399,IBIFN ,"DEN1",K, 0)=^DGCR(3 99,IBIFN1, "DEN1",K,0 )
  4431    I $D(^DGC R(399,IBIF N1,"DEN2") ) S ^DGCR( 399,IBIFN, "DEN2")=^D GCR(399,IB IFN1,"DEN2 ")
  4432    ;
  4433    ; IB*2.0* 432  ADDED  IBSILENT  flag so th at this ca n be proce ssed in ba ckground
  4434    D FTPRV^I BCEU5(IBIF N,$G(IBSIL ENT)) ; As k change p rov type i f form typ e not the  same
  4435    D COBCHG( IBIFN,,.IB COB)
  4436    ;
  4437    D ^IBCCC3  ; copy ta ble files  (362.3)
  4438    ;
  4439    S I=$G(^D GCR(399,IB IFN1,0)) I  $P(I,U,13 )=7,$P(I,U ,20)=1 D C OPYB^IBCDC (IBIFN1,IB IFN) ; upd ate auto b ill files
  4440    D PRIOR(I BIFN) ; ad d new bill  to previo us bills i n series,  primary/se condary
  4441    ;
  4442    I +$G(IBC TCOPY) N I BAUTO S IB AUTO=1 D P ROC^IBCU7A (IBIFN),BI LL^IBCRBC( IBIFN),CPT MOD26^IBCU 73(IBIFN)  D RECALL^D ILFD(399,I BIFN_",",D UZ) G END
  4443    ;
  4444   STEP6 N IB GOEND
  4445    ; need to  kill CRD  flag prior  to enteri ng billing  screens i n case a c opy for co rrespondin g claim is  needed
  4446    K IBCNCRD
  4447    ; don't c all IB bil l edit scr eens if th is is non- MRA backgr ound proce ssing
  4448    I $G(IBST SM)=1 G EN D
  4449    I '$G(IBC E("EDI"))! $G(IBCE("E DI","NEW") ),'$G(IBCE AUTO) D IB SCEDT G EN D:$G(IBGOE ND)
  4450    ;
  4451    ;
  4452   END K DFN, IB,IBA,IBA 2,IBAD,IBA DD1,IBBNO, IBCAN,IBCC C,IBDA,IBD PT,IBDR,IB DT,IBI,IBI 1,IBIDS,IB IFN,IBIFN1 ,IBND,IBQU IT,IBU,IBU N,IBARST,I BCOB,IBCNC OPY,IBCBCO PY,IBCNCRD ,IBKEY
  4453    K IBV,IBV 1,IBW,IBWW ,IBYN,IBZZ ,PRCASV,PR CAERCD,PRC AERR,PRCAS VC,PRCAT,I BBT,IBCH,I BNDS,IBOA, IBREV,IBX, DGXRF1,VAE L,VAERR,IB AC,IBCCC,I BDD1,IBIN, DGREV,DGRE V00,DGREVH DR,IBCHK
  4454    K IBBS,IB LS,DGPCM,I BIP,IBND0, IBNDU,IBO, IBPTF,IBST ,IBUC,IBDD ,D,%,%DT,D IC,VA,VADM ,X,X1,X2,X 3,X4,Y,I,J ,K,DGRVRCA L,DDH,DGAC TDT,DGAMNT ,DGBR,DGBR N,DGBSI,DG BSLOS,IBA1 ,IBOD,IBIN S,IBN,IBPR OC,DGFUNC, DGIFN
  4455    Q
  4456    ;
  4457    ;
  4458   IBSCEDT ;  call the I B bill edi t screens  and valida te the dat a
  4459    N IBV,IBP AR,IBAC,IB HV,IBH,IBC IREDT
  4460    ; 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
  4461    ; also, i f the user  came from  CBW->PC a nd this is  a non-MRA  claim and  the only  EEOB we ha ve has fil ing errors , set forc e print fl ag
  4462    I $G(IBMR ANOT)=1,$$ COBN^IBCEF (IBIFN)>1, $G(IBFROM) =2 D 
  4463    .I $G(IBD A)="" D FO RCEPRT^IBC APP($G(IBI FN)) Q
  4464    .I $D(^IB M(361.1,IB DA,"ERR"))  D FORCEPR T^IBCAPP($ G(IBIFN))  Q
  4465    D RECALL^ DILFD(399, IBIFN_",", DUZ)
  4466   ST1 S IBV= 0 D ^IBCSC U,^IBCSC1  I $G(IBPOP OUT) S IBG OEND=1 G I BSCX
  4467    S IBAC=1
  4468    D ^IBCB1
  4469    I $G(IBCI REDT) G ST 1
  4470   IBSCX ;
  4471    Q
  4472    ;
  4473    ;
  4474   TX F J=8 I  $P(IBND(" TX"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"TX" ),"^",J)=$ P(IBND("TX "),"^",J)
  4475    Q
  4476   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)
  4477    Q
  4478   U1 F J=1:1 :3,15 I $P (IBND("U1" ),"^",J)]" " S $P(^DG CR(399,IBI FN,"U1")," ^",J)=$P(I BND("U1"), "^",J)
  4479    Q
  4480   U2 F J=1:1 :19 I $P(I BND("U2"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U2"),"^" ,J)=$P(IBN D("U2"),"^ ",J)
  4481    Q
  4482   U3 F J=1:1 :11 I $P(I BND("U3"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U3"),"^" ,J)=$P(IBN D("U3"),"^ ",J)
  4483    Q
  4484   UF2 F J=1, 3 I $P(IBN D("UF2")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "UF2"),"^" ,J)=$P(IBN D("UF2")," ^",J)
  4485    Q
  4486   UF3 F J=4: 1:6 I $P(I BND("UF3") ,"^",J)]""  S $P(^DGC R(399,IBIF N,"UF3")," ^",J)=$P(I BND("UF3") ,"^",J)
  4487    Q
  4488   U4 F J=1:1 :14 I $P(I BND("U4"), "^",J)]""  S $P(^DGCR (399,IBIFN ,"U4"),"^" ,J)=$P(IBN D("U4"),"^ ",J)
  4489    Q
  4490   U5 F J=1:1 :6 I $P(IB ND("U5")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U5"),"^", J)=$P(IBND ("U5"),"^" ,J)
  4491    Q
  4492   U6 F J=1:1 :6 I $P(IB ND("U6")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U6"),"^", J)=$P(IBND ("U6"),"^" ,J)
  4493    Q
  4494   U7 F J=1:1 :5 I $P(IB ND("U7")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U7"),"^", J)=$P(IBND ("U7"),"^" ,J)
  4495    Q
  4496   U8 F J=1:1 :3 I $P(IB ND("U8")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "U8"),"^", J)=$P(IBND ("U8"),"^" ,J)
  4497    Q
  4498   UF31 F J=3  I $P(IBND ("UF31")," ^",J)]"" S  $P(^DGCR( 399,IBIFN, "UF31"),"^ ",J)=$P(IB ND("UF31") ,"^",J)
  4499    Q
  4500   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 )
  4501    Q
  4502   C F J=10 I  $P(IBND(" C"),"^",J) ]"" S $P(^ DGCR(399,I BIFN,"C"), "^",J)=$P( IBND("C"), "^",J)
  4503    I '$D(^DG CR(399,IBI FN1,"CP"))  D CP1
  4504    Q
  4505   M F J=1:1: 9,11:1:14  I $P(IBND( "M"),"^",J )]"" S $P( ^DGCR(399, IBIFN,"M") ,"^",J)=$P (IBND("M") ,"^",J)
  4506    Q
  4507   CC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4508    S IBDD=39 9.04 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)=^DG CR(399,IBI FN1,I,J,0) ,X=$P(^(0) ,"^")
  4509   OP S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4510    S IBDD=39 9.043 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 ),"^")
  4511    Q
  4512   OC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4513    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 ),"^")
  4514    Q
  4515   OT S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4516    S IBDD=39 9.048 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 ),"^")
  4517    Q
  4518   CV ; Don't  copy valu e codes fr om inpatie nt inst to  inpatient  prof bill s
  4519    I $$FT^IB CEF(IBIFN1 )'=2,$$FT^ IBCEF(IBIF N)=2 Q
  4520    S ^DGCR(3 99,IBIFN,I ,0)=^DGCR( 399,IBIFN1 ,I,0)
  4521    S IBDD=39 9.047 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 ),"^")
  4522    Q
  4523   RC S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4524    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)
  4525    Q
  4526   CP S ^DGCR (399,IBIFN ,I,0)=^DGC R(399,IBIF N1,I,0)
  4527    I +$G(IBN OCPT) Q
  4528    S IBDD=39 9.0304 F J =0:0 S J=$ O(^DGCR(39 9,IBIFN1,I ,J)) Q:'J   I $D(^(J, 0)) S IBND ("CP")=^(0 ),IBND("CP 1")=$G(^(1 )),IBND("C P-AUX")=$G (^("AUX"))  D
  4529    . 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)
  4530    . ; IB*2. 0*432 add  new 1 node
  4531    . ; MRD;I B*2.0*516  - Added pi eces 7 & 8  (NDC, Uni ts) to 1-n ode.
  4532    . F K=1:1 :8 S $P(^D GCR(399,IB IFN,I,J,1) ,"^",K)=$P (IBND("CP1 "),"^",K)
  4533    . ; esg -  11/2/06 -  IB*2*348  - 50.09 fi eld was ad ded - AUX  piece [9]
  4534    . I IBND( "CP-AUX")' ="" F K=1: 1:9 S $P(^ DGCR(399,I BIFN,I,J," AUX"),"^", K)=$P(IBND ("CP-AUX") ,"^",K)
  4535    . ; IB*2. 0*432 add  new LNPRV  multiple
  4536    . 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
  4537    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"LNPRV",K )) Q:'K  D
  4538    ... S ^DG CR(399,IBI FN,I,J,"LN PRV",K,0)= ^DGCR(399, IBIFN1,I,J ,"LNPRV",K ,0)
  4539    . 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
  4540    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"MOD",K))  Q:'K  D
  4541    ... I $G( IBNOTC),$P ($$MOD^ICP TMOD(+$P($ G(^DGCR(39 9,IBIFN1,I ,J,"MOD",K ,0)),U,2), "I"),U,2)= "TC" Q  ;  Don't copy  TC modifi er from in st to prof  bill
  4542    ... S ^DG CR(399,IBI FN,I,J,"MO D",K,0)=^D GCR(399,IB IFN1,I,J," MOD",K,0)
  4543    . ;JWS;IB *2.0*592;a dd new Den tal claim  form field s
  4544    . I $D(^D GCR(399,IB IFN1,I,J," DEN")) S ^ DGCR(399,I BIFN,I,J," DEN")=^DGC R(399,IBIF N1,I,J,"DE N")
  4545    . I $D(^D GCR(399,IB IFN1,I,J," DEN1",0))  S ^DGCR(39 9,IBIFN,I, J,"DEN1",0 )=^DGCR(39 9,IBIFN1,I ,J,"DEN1", 0) D
  4546    .. S K=0  F  S K=$O( ^DGCR(399, IBIFN1,I,J ,"DEN1",K) ) Q:'K  D
  4547    ... S ^DG CR(399,IBI FN,I,J,"DE N1",K,0)=^ DGCR(399,I BIFN1,I,J, "DEN1",K,0 )
  4548    . ;JRA;IB *2.0*608 A dd CMN inf o - Node ' CMN-10126'  contains  data speci fic to onl y the CMS- 10126 form , node 'CM N-484' con tains data  specific  to
  4549    . ; only  the CMN-48 4 form, an d node 'CM N' contain s data com mon to bot h forms.
  4550    . I $D(^D GCR(399,IB IFN1,I,J," CMN")) S ^ DGCR(399,I BIFN,I,J," CMN")=^DGC R(399,IBIF N1,I,J,"CM N")
  4551    . I $D(^D GCR(399,IB IFN1,I,J," CMN-10126" )) S ^DGCR (399,IBIFN ,I,J,"CMN- 10126")=^D GCR(399,IB IFN1,I,J," CMN-10126" )
  4552    . I $D(^D GCR(399,IB IFN1,I,J," CMN-484"))  S ^DGCR(3 99,IBIFN,I ,J,"CMN-48 4")=^DGCR( 399,IBIFN1 ,I,J,"CMN- 484")
  4553   CP1 S IBCO D=$P($G(^D GCR(399,IB IFN,0)),"^ ",9) Q:IBC OD=""!('$D (^DGCR(399 ,IBIFN1,"C ")))
  4554    I IBCOD=9  F DGI=4,5 ,6 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S  X=$P(^("C "),"^",DGI )_";ICD0(" ,DGPROCDT= $P(^("C"), "^",DGI+7)  D FILE
  4555    I IBCOD=4  F DGI=1,2 ,3 I $P(^D GCR(399,IB IFN1,"C"), "^",DGI) S  X=$P(^("C "),"^",DGI )_";ICPT(" ,DGPROCDT= $P(^("C"), "^",DGI+10 ) D FILE
  4556    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
  4557    Q
  4558    ;
  4559   PRV ; Copy  providers  for clone d claim
  4560    N Z,Z0,CN T
  4561    S Z=$P($G (^DGCR(399 ,IBIFN,0)) ,U,19),Z0= $P($G(^DGC R(399,IBIF N1,0)),U,1 9),CNT=0
  4562    S IBDD=39 9.0222 F J =0:0 S J=$ O(^DGCR(39 9,IBIFN1,I ,J)) Q:'J   I $D(^(J, 0)) D
  4563    . I $$GET NPI^IBCEF7 3A($P(^DGC R(399,IBIF N1,I,J,0), U,2))="" Q   ;Don't f ile provid er if no N PI - IB*2* 516
  4564    . S CNT=C NT+1,^DGCR (399,IBIFN ,I,CNT,0)= ^DGCR(399, IBIFN1,I,J ,0),X=$P(^ (0),"^")
  4565    . I Z'=Z0 ,$S(X=3:Z0 =3,X=4:Z0= 2,1:0) S $ P(^DGCR(39 9,IBIFN,I, CNT,0),U)= (Z0+1)
  4566    I CNT S ^ DGCR(399,I BIFN,I,0)= ^DGCR(399, IBIFN1,I,0 ),$P(^DGCR (399,IBIFN ,I,0),U,3) =CNT,$P(^D GCR(399,IB IFN,I,0),U ,4)=CNT
  4567    Q
  4568    ;
  4569   U9 ; Added  for new d ata elemen ts in IB*2 .0*447 BI
  4570    M ^DGCR(3 99,IBIFN,I )=^DGCR(39 9,IBIFN1,I )
  4571    Q
  4572    ;
  4573   COB S J=0  F  S J=$O( IBCOB(I,J) ) Q:'J  S  $P(^DGCR(3 99,IBIFN,I ),U,J)=IBC OB(I,J)
  4574    Q
  4575    ;
  4576   FILE N DIC ,DIE,DR,DA ,X,Y,DLAYG O,DD,DO
  4577    I '$D(^DG CR(399,IBI FN,"CP",0) ) S DIC("P ")=$$GETSP EC^IBEFUNC (399,304)
  4578    S DIC(0)= "L",DLAYGO =399,DA(1) =IBIFN,DIC ="^DGCR(39 9,"_DA(1)_ ",""CP"","  Q:X=""  D  FILE^DICN  K DO,DD Q :+Y<1  S D A=+Y
  4579    S DIE="^D GCR(399,"_ DA(1)_","" CP"",",DR= "1///"_DGP ROCDT D ^D IE
  4580    K DGPROCD T
  4581    Q
  4582    ;
  4583   INDEX ;ind ex entire  file (set  logic)
  4584    N IBMAED  D SAVERC(I BIFN,.IBMA ED)  ; IB* 2.0*447 BI  - Save th e value of  piece 16  of each RC  node befo re re-inde xing.
  4585    S DIK="^D GCR(399,", DA=IBIFN D  IX1^DIK K  DA,DIK
  4586    D RESTRC( IBIFN,.IBM AED)  ; IB *2.0*447 B I - Restor e the valu e of piece  16 of eac h RC node  before re- indexing.
  4587    Q
  4588    ;
  4589   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
  4590    N IBSEQ,I BSEQN,IBM1 ,I,IBIFN1
  4591    S IBSEQ=$ $COB^IBCEF (IBIFN)
  4592    S IBSEQN= $S(IBSEQ=" S":6,IBSEQ ="T":7,1:" ") Q:'IBSE QN
  4593    ;
  4594    S IBM1=$G (^DGCR(399 ,IBIFN,"M1 ")) I +$P( ^DGCR(399, IBIFN,0),U ,13)=7 S I BIFN=""
  4595    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
  4596    Q
  4597    ;
  4598   COBCHG(IBI FN,IBINS,I BCOB) ; Ma ke changes  for a new  COB payer  for bill
  4599    ; IBIFN =  ien of bi ll in file  399
  4600    ; IBINS =  ien of bi ll's curre nt insuran ce (option al)
  4601    ; IBCOB =  array sub scripted b y node,pie ce of COB  data field  change
  4602    ;
  4603    N I,IBFRM TYP,IBTAXL ST
  4604    ; Subtrac t the Prio r Payments  from the  bill's Off set (these  are re-ad ded by tri ggers)
  4605    F I=4,5,6   S $P(^DG CR(399,IBI FN,"U1"),U ,2)=$P($G( ^DGCR(399, IBIFN,"U1" )),U,2)-$P ($G(^DGCR( 399,IBIFN, "U2")),U,I )
  4606    ;
  4607    I $G(IBIN S),$$MCRWN R^IBEFUNC( IBINS) D
  4608    . ;MCRWNR  is curren t insuranc e ... move  payer onl y
  4609    . N IBCOB N,IBX
  4610    . S IBCOB N=$$COBN^I BCEF(IBIFN )
  4611    . S IBCOB (0,21)=$P( "S^T^",U,I BCOBN)
  4612    . S IBCOB ("M1",IBCO BN+4)=IBIF N
  4613    . S IBCOB ("TX",1)=" ",IBCOB("T X",2)=""
  4614    . S IBX=$ $REQMRA^IB EFUNC(IBIF N)
  4615    . I IBX=0  S IBCOB(" TX",5)=0                            ; MRA n ot needed
  4616    . I IBX[" R" S IBCOB ("TX",5)=" A"                       ; MRA s kipped
  4617    . I IBX=1 ,$$CHK^IBC EMU1(IBIFN ) S IBCOB( "TX",5)="C "  ; MRA o n file
  4618    . I $G(IB PRCOB) S I BCOB("TX", 5)="C"                   ; MRA b eing proc' d
  4619    . D PRIOR (IBIFN)
  4620    . Q
  4621    ;
  4622    ;reset fi elds for n ext Sequen ce Payer
  4623    F I=0,"M1 ","U2","TX " I $D(IBC OB(I)) D C OB
  4624    ;
  4625    ; IB*2.0* 211
  4626    ; save of f Form Typ e
  4627    S IBFRMTY P=$P($G(^D GCR(399,IB IFN,0)),U, 19)
  4628    ; Save of f Taxonomi es for pro viders.
  4629    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)
  4630    ;
  4631    ; fire xr efs set lo gic
  4632    D INDEX
  4633    ;
  4634    ; Restore  Form Type  if change d, but don 't restore  Form Type  if
  4635    ;   creat ing CMS-15 00 claim f rom CTCOPY 1^IBCCCB
  4636    I $G(IBCT COPY)'=1,I BFRMTYP'=$ P($G(^DGCR (399,IBIFN ,0)),U,19)  N DA,DIE, DR S DA=IB IFN,DIE="^ DGCR(399," ,DR=".19// //"_IBFRMT YP D ^DIE
  4637    ;
  4638    ; Restore  Claim MRA  Status fi eld since  triggers i n fields 1 01 & 102
  4639    ;   will  overwrite  the correc t value wh en process ing the MR A/EOB.
  4640    ; If we'r e processi ng the MRA /EOB, then  a valid M RA has bee n received .
  4641    I $G(IBPR COB) N DA, DIE,DR S D A=IBIFN,DI E="^DGCR(3 99,",DR="2 4////C" D  ^DIE
  4642    ;
  4643    ; Only if  cloning,  then resto re Taxonom ies in fie lds 243 an d 244 and  252.
  4644    I '$G(IBI NS),'$G(IB PRCOB) D
  4645    . S I=$P( $G(IBND("U 3")),U,2)
  4646    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,2 ) D
  4647    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 3////"_$S( I'="":I,1: "@") D ^DI E
  4648    . ;
  4649    . S I=$P( $G(IBND("U 3")),U,3)
  4650    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,3 ) D
  4651    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="24 4////"_$S( I'="":I,1: "@") D ^DI E
  4652    . ;
  4653    . S I=$P( $G(IBND("U 3")),U,11)
  4654    . I I'=$P ($G(^DGCR( 399,IBIFN, "U3")),U,1 1) D
  4655    .. N DA,D IE,DR S DA =IBIFN,DIE ="^DGCR(39 9,",DR="25 2////"_$S( I'="":I,1: "@") D ^DI E
  4656    . Q
  4657    ;
  4658    ; Restore  Taxonomie s in field  .15 in su b-file 399 .0222.
  4659    S IBTAXLS T=0 F  S I BTAXLST=$O (IBTAXLST( IBTAXLST))  Q:'IBTAXL ST  D
  4660    . S I=IBT AXLST(IBTA XLST)
  4661    . I I=$P( $G(^DGCR(3 99,IBIFN," PRV",IBTAX LST,0)),U, 15) Q  ; N o change
  4662    . N DA,DI E,DR
  4663    . S DA(1) =IBIFN,DA= IBTAXLST
  4664    . S DIE=" ^DGCR(399, "_DA(1)_", ""PRV"",", DR=".15/// /"_$S(I'=" ":I,1:"@")
  4665    . D ^DIE
  4666    . Q
  4667    ;
  4668    K IBCOB(" TX")
  4669    Q
  4670    ;
  4671   SAVERC(IBI FN,IBMAED)   ; IB*2.0 *447 BI -  Save the v alue of pi ece 16 of  each RC no de before  re-indexin g.
  4672    Q:$G(IBCT COPY)=1  Q :$G(IBCTCO PY)=2
  4673    N IBCNT S  IBCNT=0
  4674    Q:'$G(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"RC "))
  4675    F  S IBCN T=$O(^DGCR (399,IBIFN ,"RC",IBCN T)) Q:+IBC NT=0  D
  4676    . S IBMAE D(IBCNT)=$ P($G(^DGCR (399,IBIFN ,"RC",IBCN T,0)),U,16 )
  4677    Q
  4678    ;
  4679   RESTRC(IBI FN,IBMAED)   ; IB*2.0 *447 BI -  Restore th e value of  piece 16  of each RC  node afte r re-index ing.
  4680    Q:$G(IBCT COPY)=1  Q :$G(IBCTCO PY)=2
  4681    N IBCNT S  IBCNT=0
  4682    Q:'$G(IBI FN)  Q:'$D (^DGCR(399 ,IBIFN,"RC "))
  4683    F  S IBCN T=$O(IBMAE D(IBCNT))  Q:+IBCNT=0   D
  4684    . S $P(^D GCR(399,IB IFN,"RC",I BCNT,0),U, 16)=IBMAED (IBCNT)
  4685    Q
  4686  
  4687   IBJPS – Ma in entry f or IB Site  Parameter s which ca lls IBJPS8  to set up  CMN CPT I nclusion
  4688   Routines
  4689   Activities
  4690   Routine Na me
  4691   IBJPS
  4692   Enhancemen t Category
  4693    New
  4694    Modify
  4695    Delete
  4696    No Change
  4697   RTM
  4698  
  4699   Related Op tions
  4700   None
  4701   Related Ro utines
  4702   Routines “ Called By”
  4703   Routines “ Called”   
  4704  
  4705  
  4706  
  4707  
  4708   Data Dicti onary (DD)  Reference s
  4709  
  4710   Related Pr otocols
  4711   None
  4712   Related In tegration  Control Re gistration s (ICRs)
  4713   None
  4714   Data Passi ng
  4715    Input
  4716    Output Re ference
  4717    Both
  4718    Global Re ference
  4719    Local
  4720   Input Attr ibute Name  and Defin ition
  4721   Name:
  4722   Definition :
  4723   Output Att ribute Nam e and Defi nition
  4724   Name:
  4725   Definition :
  4726   Current Lo gic
  4727    IBJPS ;AL B/MAF,ARH  - IBSP IB  SITE PARAM ETER SCREE N ;22-DEC- 1995
  4728    ;;2.0;INT EGRATED BI LLING;**39 ,52,70,115 ,143,51,13 7,161,155, 320,348,34 9,377,384, 400,432,49 4,461,516, 547,592**; 21-MAR-94; Build 40
  4729    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4730    ;
  4731   EN ; -- ma in entry p oint for I BJP IB SIT E PARAMETE RS, displa y IB site  parameters
  4732    D EN^VALM ("IBJP IB  SITE PARAM ETERS")
  4733    Q
  4734    ;
  4735   HDR ; -- h eader code
  4736    S VALMHDR (1)="Only  authorized  persons m ay edit th is data."
  4737    Q
  4738    ;
  4739   INIT ; --  init varia bles and l ist array
  4740    K ^TMP("I BJPS",$J), ^TMP("IBJP SAX",$J)
  4741    D BLD^IBJ PS1
  4742    Q
  4743    ;
  4744   HELP ; --  help code
  4745    S X="?" D  DISP^XQOR M1 W !!
  4746    Q
  4747    ;
  4748   EXIT ; --  exit code
  4749    K ^TMP("I BJPS",$J), ^TMP("IBJP SAX",$J)
  4750    D CLEAR^V ALM1
  4751    Q
  4752    ;
  4753   NXEDIT ; - - IBJP IB  SITE PARAM ETER EDIT  ACTION (EP ): Select  data set t o edit, do  edit
  4754    N VALMY,I BSELN,IBSE T
  4755    D EN^VALM 2($G(XQORN OD(0)))
  4756    I $D(VALM Y) S IBSEL N=0 F  S I BSELN=$O(V ALMY(IBSEL N)) Q:'IBS ELN  D
  4757    . S IBSET =$P($G(^TM P("IBJPSAX ",$J,IBSEL N)),U,1) Q :'IBSET
  4758    . D EDIT( IBSET)
  4759    S VALMBCK ="R"
  4760    Q
  4761    ;
  4762   EDIT(IBSET ) ; edit I B Site Par ameters
  4763    D FULL^VA LM1
  4764    N DR
  4765    I IBSET'= "" D
  4766    . ; MRD;I B*2.0*516  - Added TR ICARE Pay- To Provide rs.
  4767    . ; WCJ;I B*2.0*547  - shifted  the number s down to  insert a n ew one
  4768    . I IBSET =8 D EN^IB JPS5 Q
  4769    . I IBSET =11 D EN^I BJPS3(0) Q
  4770    . I IBSET =12 D EN^I BJPS3(1) Q
  4771    . ;WCJ;IB *2.0*547 a dded defau lt Adminis trative co ntractors  for billin g (medicar e and comm ercial)
  4772    . I IBSET =17 D EN^I BJPS6(1) Q    ; medic are
  4773    . I IBSET =18 D EN^I BJPS6(2) Q    ; comme rcial
  4774    . S DR=$P ($T(@IBSET ),";;",2,9 99)
  4775    . Q
  4776    ; WCJ;IB* 2.0*547 -  shifted th e number d own to ins ert a new  one
  4777    I IBSET=9 ,$$ICD9SYS ^IBACSV(DT )=30 S $P( DR,";",1)= 7.05
  4778    ;
  4779    I $G(DR)' ="" S DIE= "^IBE(350. 9,",DA=1 D  ^DIE K DA ,DR,DIE,DI C,X,Y
  4780    D INIT^IB JPS S VALM BCK="R"
  4781    Q
  4782    ;
  4783    ;WCJ;IB*2 .0*547 - c leared the  spot for  the new #8 , added 17  & 18, mov e 16 to 19 .
  4784    ;gef;IB*2 .0*547 - a dded 20
  4785    ;JWS;IB*2 .0*592 - a dded field  8.2 to 16
  4786   1 ;;.09;.1 3;.14
  4787   2 ;;1.2;.1 5;.11;.12; 7.04
  4788   3 ;;1.09;1 .07;2.07
  4789   4 ;;4.04;6 .25;6.24
  4790   5 ;;.02;1. 14;1.25;1. 08
  4791   6 ;;1.23;1 .16;1.22;1 .19;1.15;1 .17
  4792   7 ;;1.33;1 .32;1.31;1 .27;8.14T; 8.15T;8.16 T;8.19T
  4793   9 ;;1.29;1 .3;1.18;1. 28
  4794   10 ;;1.01; 1.02;1.05
  4795   13 ;;2.08; 2.09
  4796   14 ;;11.01
  4797   15 ;;10.02 ;10.03;10. 04;10.05;D  INIT^IBAT FILE
  4798   16 ;;2.11; 8.01;8.09; 8.03;8.06; 8.04;8.07; 8.02;8.12T ;8.11T;8.1 7T;8.2T
  4799   19 ;;50.01 ;50.02;50. 05;50.06;5 0.03;50.04 ;50.07
  4800   20 ;;52.01 ;52.02
  4801    ;
  4802   Modified L ogic (Chan ges are hi ghlighted  in yellow)
  4803   IBJPS ;ALB /MAF,ARH -  IBSP IB S ITE PARAME TER SCREEN  ;22-DEC-1 995
  4804    ;;2.0;INT EGRATED BI LLING;**39 ,52,70,115 ,143,51,13 7,161,155, 320,348,34 9,377,384, 400,432,49 4,461,516, 547,592,60 8**;21-MAR -94;Build  40
  4805    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4806    ;
  4807   EN ; -- ma in entry p oint for I BJP IB SIT E PARAMETE RS, displa y IB site  parameters
  4808    D EN^VALM ("IBJP IB  SITE PARAM ETERS")
  4809    Q
  4810    ;
  4811   HDR ; -- h eader code
  4812    S VALMHDR (1)="Only  authorized  persons m ay edit th is data."
  4813    Q
  4814    ;
  4815   INIT ; --  init varia bles and l ist array
  4816    K ^TMP("I BJPS",$J), ^TMP("IBJP SAX",$J)
  4817    D BLD^IBJ PS1
  4818    Q
  4819    ;
  4820   HELP ; --  help code
  4821    S X="?" D  DISP^XQOR M1 W !!
  4822    Q
  4823    ;
  4824   EXIT ; --  exit code
  4825    K ^TMP("I BJPS",$J), ^TMP("IBJP SAX",$J)
  4826    D CLEAR^V ALM1
  4827    Q
  4828    ;
  4829   NXEDIT ; - - IBJP IB  SITE PARAM ETER EDIT  ACTION (EP ): Select  data set t o edit, do  edit
  4830    N VALMY,I BSELN,IBSE T
  4831    D EN^VALM 2($G(XQORN OD(0)))
  4832    I $D(VALM Y) S IBSEL N=0 F  S I BSELN=$O(V ALMY(IBSEL N)) Q:'IBS ELN  D
  4833    . S IBSET =$P($G(^TM P("IBJPSAX ",$J,IBSEL N)),U,1) Q :'IBSET
  4834    . D EDIT( IBSET)
  4835    S VALMBCK ="R"
  4836    Q
  4837    ;
  4838   EDIT(IBSET ) ; edit I B Site Par ameters
  4839    D FULL^VA LM1
  4840    N DR
  4841    I IBSET'= "" D
  4842    . ; MRD;I B*2.0*516  - Added TR ICARE Pay- To Provide rs.
  4843    . ; WCJ;I B*2.0*547  - shifted  the number s down to  insert a n ew one
  4844    . I IBSET =8 D EN^IB JPS5 Q
  4845    . I IBSET =11 D EN^I BJPS3(0) Q
  4846    . I IBSET =12 D EN^I BJPS3(1) Q
  4847    . ;WCJ;IB *2.0*547 a dded defau lt Adminis trative co ntractors  for billin g (medicar e and comm ercial)
  4848    . I IBSET =17 D EN^I BJPS6(1) Q    ; medic are
  4849    . I IBSET =18 D EN^I BJPS6(2) Q    ; comme rcial
  4850    . I IBSET =21 D EN^I BJPS8 Q    ; WCJ;IB*2 .0*608;US3 ;
  4851    . S DR=$P ($T(@IBSET ),";;",2,9 99)
  4852    . Q
  4853    ; WCJ;IB* 2.0*547 -  shifted th e number d own to ins ert a new  one
  4854    I IBSET=9 ,$$ICD9SYS ^IBACSV(DT )=30 S $P( DR,";",1)= 7.05
  4855    ;
  4856    I $G(DR)' ="" S DIE= "^IBE(350. 9,",DA=1 D  ^DIE K DA ,DR,DIE,DI C,X,Y
  4857    D INIT^IB JPS S VALM BCK="R"
  4858    Q
  4859    ;
  4860    ;WCJ;IB*2 .0*547 - c leared the  spot for  the new #8 , added 17  & 18, mov e 16 to 19 .
  4861    ;gef;IB*2 .0*547 - a dded 20
  4862    ;JWS;IB*2 .0*592 - a dded field  8.2 to 16
  4863   1 ;;.09;.1 3;.14
  4864   2 ;;1.2;.1 5;.11;.12; 7.04
  4865   3 ;;1.09;1 .07;2.07
  4866   4 ;;4.04;6 .25;6.24
  4867   5 ;;.02;1. 14;1.25;1. 08
  4868   6 ;;1.23;1 .16;1.22;1 .19;1.15;1 .17
  4869   7 ;;1.33;1 .32;1.31;1 .27;8.14T; 8.15T;8.16 T;8.19T
  4870   9 ;;1.29;1 .3;1.18;1. 28
  4871   10 ;;1.01; 1.02;1.05
  4872   13 ;;2.08; 2.09
  4873   14 ;;11.01
  4874   15 ;;10.02 ;10.03;10. 04;10.05;D  INIT^IBAT FILE
  4875   16 ;;2.11; 8.01;8.09; 8.03;8.06; 8.04;8.07; 8.02;8.12T ;8.11T;8.1 7T;8.2T
  4876   19 ;;50.01 ;50.02;50. 05;50.06;5 0.03;50.04 ;50.07
  4877   20 ;;52.01 ;52.02
  4878    ;
  4879  
  4880   IBJPS8 – S et up CMN  CPT Inclus ions in IB  System Pa rameters &  check bef ore CMN pr ompt
  4881   Routines
  4882   Activities
  4883   Routine Na me
  4884   IBJPS8
  4885   Enhancemen t Category
  4886    New
  4887    Modify
  4888    Delete
  4889    No Change
  4890   RTM
  4891  
  4892   Related Op tions
  4893   None
  4894   Related Ro utines
  4895   Routines “ Called By”
  4896   Routines “ Called”   
  4897  
  4898  
  4899  
  4900  
  4901   Data Dicti onary (DD)  Reference s
  4902  
  4903   Related Pr otocols
  4904   None
  4905   Related In tegration  Control Re gistration s (ICRs)
  4906   None
  4907   Data Passi ng
  4908    Input
  4909    Output Re ference
  4910    Both
  4911    Global Re ference
  4912    Local
  4913   Input Attr ibute Name  and Defin ition
  4914   Name:
  4915   Definition :
  4916   Output Att ribute Nam e and Defi nition
  4917   Name:
  4918   Definition :
  4919   Current Lo gic
  4920   IBJPS8 ;AI TC/WCJ - I B Site Par ameters, C MN CPT Inc lusions CP T Codes ;0 2-Feb-2018
  4921    ;;2.0;INT EGRATED BI LLING;**60 8**;21-MAR -94;Build  40
  4922    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4923    ;
  4924   EN ; -- ma in entry p oint for I BJP IB CMN  CPTS
  4925    D EN^VALM ("IBJPS CM N CPTS")
  4926    Q
  4927    ;
  4928   HDR ; -- h eader code
  4929    S VALMSG= ""
  4930    Q
  4931    ;
  4932   INIT ; --  init varia bles and l ist array
  4933    N ERROR,I BCNT,IBLN, IBSTR
  4934    N CPTDATA ,CIENS,CPT IEN,RTYDSC
  4935    ;
  4936    S (VALMCN T,IBCNT,IB LN)=0
  4937    I $D(^IBE (350.9,1,1 6,"B")) D
  4938    . S CPTIE N=0 F  S C PTIEN=$O(^ IBE(350.9, 1,16,"B",C PTIEN)) Q: 'CPTIEN  D
  4939    . . ;
  4940    . . S CIE NS=CPTIEN_ ","
  4941    . . D GET S^DIQ(81,C IENS,".001 ;.01;2","I ","CPTDATA ","ERROR")
  4942    . . S IBC NT=IBCNT+1
  4943    . . S IBS TR=$$SETST R^VALM1($J (IBCNT,4)_ ".","",2,6 )
  4944    . . S IBS TR=$$SETST R^VALM1($G (CPTDATA(8 1,CIENS,.0 1,"I")),IB STR,10,10)
  4945    . . S IBS TR=$$SETST R^VALM1($G (CPTDATA(8 1,CIENS,2, "I")),IBST R,25,30)
  4946    . . S IBL N=$$SET(IB LN,IBSTR)
  4947    . . ;S @V ALMAR@("ZI DX",IBCNT, $G(CPTDATA (81,CIENS, .001,"I")) )=""
  4948    . . S @VA LMAR@("ZID X",IBCNT,+ CIENS)=""
  4949    . . Q
  4950    ;
  4951    I 'IBLN S  IBLN=$$SE T(IBLN,$$S ETSTR^VALM 1("No CMN  CPTs defin ed.","",13 ,40))
  4952    ;
  4953    S VALMCNT =IBLN,VALM BG=1
  4954    Q
  4955    ;
  4956   HELP ; --  help code
  4957    S X="?" D  DISP^XQOR M1 W !!
  4958    Q
  4959    ;
  4960   EXIT ; --  exit code
  4961    D CLEAR^V ALM1,CLEAN ^VALM10
  4962    Q
  4963    ;
  4964   EXPND ; --  expand co de
  4965    Q
  4966    ;
  4967   RTADD(IBTC FLAG) ; --  Add a new  CPT Codes
  4968    N X,Y,DIE ,DIR,DIRUT ,DR,DTOUT, DUOUT,ERRM SG,FDA,RET IEN
  4969    ;
  4970    S VALMBCK ="R"
  4971    D FULL^VA LM1
  4972    D RTADD1
  4973    D INIT
  4974    Q
  4975    ;
  4976   RTADD1 ; L ooping tag  for Addin g CPT Code s
  4977    K DA,DIE, DIR,DIRUT, DR,DTOUT,D UOUT,ERRMS G,FDA,RETI EN,X,Y
  4978    ;
  4979    S DIR(0)= "350.916,. 01"
  4980    S DIR("A" )="CPT Cod e"
  4981    D ^DIR
  4982    Q:'+Y
  4983    ;
  4984    I $D(^IBE (350.9,1,1 6,"B",+Y))  D  G RTAD D1
  4985    . D FULL^ VALM1
  4986    . W @IOF
  4987    . W !,"Th is CPT Cod e already  exists on  the Inclus ion list."
  4988    . W !,"Pl ease enter  another C PT Code."
  4989    . Q
  4990    ;
  4991    S FDA(350 .916,"+1,1 ,",.01)=+Y
  4992    D UPDATE^ DIE("","FD A","RETIEN ","ERRMSG" )
  4993    G RTADD1
  4994    ;
  4995   RTDEL ; --  Delete a  CPT Coode
  4996    N DR
  4997    D RTDEL1
  4998    S VALMBCK ="R"
  4999    Q
  5000    ;
  5001   RTDEL1 ; L ooping tag  for delet ing CPT Co des
  5002    N Z,VALMY
  5003    D FULL^VA LM1
  5004    D EN^VALM 2($G(XQORN OD(0)))
  5005    S Z=0
  5006    F  S Z=$O (VALMY(Z))  Q:'Z  D
  5007    . N DIK,I EN,RIEN
  5008    . S IEN=$ O(@VALMAR@ ("ZIDX",Z, ""))
  5009    . Q:IEN=" "
  5010    . S RIEN= $O(^IBE(35 0.9,1,16," B",IEN,"") )
  5011    . I +RIEN  S DIK="^I BE(350.9,1 ,16,",DA(1 )=1,DA=RIE N D ^DIK
  5012    K @VALMAR
  5013    D INIT
  5014    Q
  5015    ;
  5016   SET(IBLN,I BSTR) ; --  Add a lin e to displ ay list
  5017    ; returns  line numb er added
  5018    S IBLN=IB LN+1 D SET ^VALM10(IB LN,IBSTR,I BLN)
  5019    Q IBLN
  5020    ;
  5021   CMNPRMT(IB XIEN,IBPRO CP,CPTIEN)  ;JRA Dete rmine if p rocedure r equires pr ompting fo r CMN Info
  5022    ;Basicall y checks i f CPTIEN i s in the " CMN CPT Co de Inclusi on" list
  5023    ;  Input:  IBXIEN  =  Internal  bill/claim  number
  5024    ;          IBPROCP =  Procedure  line subs cript
  5025    ;          CPTIEN  =  CPT code  ien
  5026    ;
  5027    ;  Output : 1 = Prom pt user fo r CMN info
  5028    ;           0 = Don' t prompt u ser for CM N info
  5029    ;
  5030    I '$G(IBX IEN)!('$G( IBPROCP)!( '$G(CPTIEN ))) Q 0
  5031    ;Prompt i f the CPT  is in IB S ite Parame ters "CMN  CPT Code I nclusion"  list -OR-  if "CMN Re quired?" a lready set  to "YES"
  5032    I $D(^IBE (350.9,1,1 6,"B",CPTI EN))>1!($$ CMNDATA^IB CEF31(IBXI EN,IBPROCP ,23,"I"))  Q 1
  5033    Q 0
  5034    ;
  5035  
  5036   IBY608PR -  The new e ntries for  files 364 .5, 364.6,  364.7 and  350.8 are  added
  5037   Routines
  5038   Activities
  5039   Routine Na me
  5040   IBY608PR
  5041   Enhancemen t Category
  5042    New
  5043    Modify
  5044    Delete
  5045    No Change
  5046   RTM
  5047  
  5048   Related Op tions
  5049   None
  5050   Related Ro utines
  5051   Routines “ Called By”
  5052   Routines “ Called”   
  5053  
  5054  
  5055  
  5056  
  5057   Data Dicti onary (DD)  Reference s
  5058  
  5059   Related Pr otocols
  5060   None
  5061   Related In tegration  Control Re gistration s (ICRs)
  5062   None
  5063   Data Passi ng
  5064    Input
  5065    Output Re ference
  5066    Both
  5067    Global Re ference
  5068    Local
  5069   Input Attr ibute Name  and Defin ition
  5070   Name:
  5071   Definition :
  5072   Output Att ribute Nam e and Defi nition
  5073   Name:
  5074   Definition :
  5075   Current Lo gic
  5076   IBY608PR ; EDE/JRA -  Pre-Instal lation for  IB patch  608 ; 10/1 2/17 2:12  pm
  5077    ;;2.0;INT EGRATED BI LLING;**60 8**;21-MAR -94;Build  40
  5078    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5079    ;
  5080    ; delete  all output  formatter  (O.F.) da ta element s included  in build
  5081    D DELOF
  5082    Q
  5083    ;
  5084   INCLUDE(FI LE,Y) ; fu nction to  determine  if O.F. en try should  be includ ed in the  build
  5085    ; FILE=5, 6,7 indica ting file  364.x or F ILE=8 indi cating fil e 350.8 (I B ERROR)
  5086    ; Y=ien t o file
  5087    NEW OK,LN ,TAG,DATA
  5088    S OK=0
  5089    F LN=2:1  S TAG="ENT "_FILE_"+" _LN,DATA=$ P($T(@TAG) ,";;",2) Q :DATA=""   I $F(DATA, U_Y_U) S O K=1 Q
  5090    Q OK
  5091    ;
  5092    ;Delete e dited entr ies to ins ure clean  install of  new entri es
  5093    ;Delete o bsolete en tries.
  5094   DELOF   ;  Delete inc luded OF e ntries
  5095    NEW FILE, DIK,LN,TAG ,TAGLN,DAT A,PCE,DA,Y
  5096    F FILE=5: 1:8 S DIK= $S(FILE=8: "^IBE(350. ",1:"^IBA( 364.")_FIL E_"," D
  5097    . F TAG=" ENT"_FILE, "DEL"_FILE  D
  5098    .. F LN=2 :1 S TAGLN =TAG_"+"_L N,DATA=$P( $T(@TAGLN) ,";;",2) Q :DATA=""   D
  5099    ... F PCE =2:1 S DA= $P(DATA,U, PCE) Q:'DA   D
  5100    .... I FI LE=8,$D(^I BE(350.8,D A,0)) D ^D IK
  5101    .... Q:FI LE=8
  5102    .... I $D (^IBA("364 ."_FILE,DA ,0)) D ^DI K
  5103    Q
  5104    ;
  5105    ; Example  for ENT5,  ENT6, ENT 7, ENT8, D EL5, DEL6,  and DEL7:
  5106    ;;^195^25 4^259^269^ 324^325^
  5107    ; Note:   Must have  beginning  and ending  up-carat
  5108    ;
  5109    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5110    ; 364.5 O .F. entrie s added:
  5111    ;
  5112    ;  225  N -COB CLAIM  LEVEL AMO UNTS 'COB1 -1.9' (US2 486)
  5113    ;  226  N -MEDICARE  INPT CLAIM  COB AMTS  'MIA1-1.9'  (US2486)
  5114    ;  227  N -MEDICARE  OUTPT CLAI M COB AMT  'MOA1-1.9'  (US2486)
  5115    ;  228  N -COB CLAIM  LEVEL ADJ USTMENTS ' CCAS-1.9'  (US2486)
  5116    ;  396  N -CMN RECOR D ID 'LQ   '
  5117    ;  438  N -CMN RECOR D ID 'FRM  '
  5118    ;  440  N -CMN RECOR D ID 'CMN  '
  5119    ;  442  N -CMN RECOR D ID 'MEA  '
  5120    ;  
  5121   ENT5 ;O.F.  entries i n file 364 .5 to be a dded
  5122    ;
  5123    ;;^225^22 6^227^228^ 396^438^44 0^442^
  5124    ;
  5125    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5126    ; 364.6 O .F. entrie s added:
  5127    ;
  5128    ;  2383 C MN RECORD  ID 'LQ  '
  5129    ;  2384 C MN FORM TY PE QUALIFI ER
  5130    ;  2385 S ERVICE LIN E #
  5131    ;  2387 C MN INDUSTR Y CODE
  5132    ;  2388 C MN CERTIFI CATION TYP E
  5133    ;  2390 C MN CERTIFI CATION TYP E QUAL
  5134    ;  2392 C MN MEASURE MENT REFER ENCE ID CO DE
  5135    ;  2393 C MN PATIENT  WEIGHT (L BS)
  5136    ;  2394 C MN PATIENT  WEIGHT MO DIFIER
  5137    ;  2395 C MN MONTHS  DME EQUIPM ENT NEEDED
  5138    ;  2396 C MN DATE TH ERAPY STAR TED
  5139    ;  2397 C MN DATE TH ERAPY STAR TED QUALIF IER
  5140    ;  2398 C MN LAST CE RTIFICATIO N DATE
  5141    ;  2399 C MN LAST CE RTIFICATIO N DATE QUA LIFIER
  5142    ;  2400 C MN RECERTI FICATION/R EVISION DA TE
  5143    ;  2401 C MN REPLACE MENT ITEM?
  5144    ;  2433 L Q DATA EXT RACT
  5145    ;  2436 F RM DATA EX TRACT
  5146    ;  2438 C MN RECORD  ID 'FRM '
  5147    ;  2439 S ERVICE LIN E #
  5148    ;  2442 C MN QUESTIO N NUMBER/L ETTER
  5149    ;  2443 C MN QUESTIO N RESPONSE  Y/N
  5150    ;  2444 C MN QUESTIO N RESPONSE  REF ID
  5151    ;  2445 C MN QUESTIO N RESPONSE  DATE
  5152    ;  2446 C MN QUESTIO N RESPONSE  % & DECIM AL
  5153    ;  2447 S ERVICE LIN E #
  5154    ;  2448 C MN DATA EX TRACT
  5155    ;  2449 C MN RECORD  ID 'CMN '
  5156    ;  2451 C MN UNIT OR  BASIS FOR  MEASUREME NT CODE
  5157    ;  2452 C MN CERTIFI CATION CON DITION IND ICATOR
  5158    ;  2453 C MN CONDITI ON INDICAT OR
  5159    ;  2454 C MN ATTACHM ENT REPORT  TYPE CODE
  5160    ;  2455 C MN ATTACHM ENT TRANSM ISSION COD E
  5161    ;  2456 C MN CODE CA TEGORY
  5162    ;  2457 C MN RECORD  ID 'MEA '
  5163    ;  2458 M EA DATA EX TRACT
  5164    ;  2461 S ERVICE LIN E #
  5165    ;  2462 C MN MEASURE MENT QUALI FIER
  5166    ;  2463 C MN TEST RE SULTS
  5167    ;
  5168   ENT6 ;O.F.  entries i n file 364 .6 to be a dded
  5169    ;
  5170    ;;^2383^2 384^2385^2 387^2388^2 390^2392^2 393^2394^2 395^2396^2 397^2398^
  5171    ;;^2399^2 400^2401^2 433^2436^2 438^2439^2 442^2443^2 444^2445^2 446^2447^
  5172    ;;^2448^2 449^2451^2 452^2453^2 454^2455^2 456^2457^2 458^2461^2 462^2463^
  5173    ;
  5174    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5175    ; 364.7 O .F. entrie s added:
  5176    ;
  5177    ;  105  V C1 VALUE C ODE (837 T ransaction ) (PC 2) ( US9)
  5178    ;  176  I NS SERVICE  LINE COUN TER (PC 2)  (US9)
  5179    ;  178  I NS SERVICE  UNIT COUN T (PC 5) ( US9)
  5180    ;  179  I NS BLANK ( PC 6) (US9 )
  5181    ;  180  I NS SERVICE  LINE CHAR GE AMT (PC  9) (US9)
  5182    ;  181  I NS PROCEDU RE MODIFIE R (1) (PC  7) (US9)
  5183    ;  189  I NS PROCEDU RE CODE (P C 4) (US9)
  5184    ;  478  B GN N-RECOR D ID (PC1)  (US9)
  5185    ;  482  I NS SERVICE  LINE NON- COVERED CH ARGE AMT ( PC 12) (US 9)
  5186    ;  805  I NS UNITS/B ASIS FOR M EASUREMENT  CODE (PC  13) (US9)
  5187    ;  985  N -GET FROM  PREVIOUS E XTRACT 'LC OB-1.9' -  US2486
  5188    ; 1015  G EN-7
  5189    ; 1751  L DATE SERVI CE LINE CO UNTER (PC  2)
  5190    ; 1752  L DAT DATA E XTRACT (83 7 Transact ion) (PC 1 .9) (US9)
  5191    ; 1765  L DAT CLEANU P (837 Tra nsaction)  (PC 99.9)  (US9)
  5192    ; 1969  C MN RECORD  ID 'LQ  '
  5193    ; 1970  S ERVICE LIN E #
  5194    ; 1971  C MN FORM TY PE QUALIFI ER
  5195    ; 1973  C MN INDUSTR Y CODE
  5196    ; 1974  C MN CERTIFI CATION TYP E
  5197    ; 1975  C MN CERTIFI CATION TYP E QUAL
  5198    ; 1977  C MN MEASURE MENT REFER ENCE ID CO DE
  5199    ; 1978  C MN PATIENT  WEIGHT (L BS)
  5200    ; 1979  C MN PATIENT  WEIGHT MO DIFIER
  5201    ; 1980  C MN MONTHS  DME EQUIPM ENT NEEDED
  5202    ; 1981  C MN DATE TH ERAPY STAR TED
  5203    ; 1982  C MN DATE TH ERAPY STAR TED QUALIF IER
  5204    ; 1983  C MN LAST CE RTIFICATIO N DATE
  5205    ; 1984  C MN LAST CE RTIFICATIO N DATE QUA LIFIER
  5206    ; 1985  C MN RECERTI FICATION/R EVISION DA TE
  5207    ; 1986  C MN REPLACE MENT ITEM?
  5208    ; 2018  L Q DATA EXT RACT
  5209    ; 2019  F RM DATA EX TRACT
  5210    ; 2020  C MN RECORD  ID 'FRM '
  5211    ; 2021  C MN QUESTIO N NUMBER/L ETTER
  5212    ; 2022  C MN QUESTIO N RESPONSE  Y/N
  5213    ; 2023  C MN QUESTIO N RESPONSE  REF ID
  5214    ; 2024  C MN QUESTIO N RESPONSE  DATE
  5215    ; 2025  C MN QUESTIO N RESPONSE  % & DECIM AL
  5216    ; 2026  S ERVICE LIN E #
  5217    ; 2027  S ERVICE LIN E #
  5218    ; 2028  C MN DATA EX TRACT
  5219    ; 2029  C MN RECORD  ID 'CMN '
  5220    ; 2030  C MN UNIT OR  BASIS FOR  MEASUREME NT CODE
  5221    ; 2031  C MN CERTIFI CATION CON DITION IND ICATOR
  5222    ; 2032  C MN ATTACHM ENT REPORT  TYPE CODE
  5223    ; 2033  C MN ATTACHM ENT TRANSM ISSION COD E
  5224    ; 2034  C MN CODE CA TEGORY
  5225    ; 2035  C MN CONDITI ON INDICAT OR
  5226    ; 2038  C MN RECORD  ID 'MEA '
  5227    ; 2039  M EA DATA EX TRACT
  5228    ; 2040  S ERVICE LIN E #
  5229    ; 2041  C MN MEASURE MENT QUALI FIER
  5230    ; 2042  C MN TEST RE SULTS
  5231    ;
  5232   ENT7 ; O.F . entries  in file 36 4.7 to be  added
  5233    ;
  5234    ;;^105^17 6^178^179^ 180^181^18 9^478^482^ 805^985^10 15^1751^17 52^1765^
  5235    ;;^1969^1 970^1971^1 973^1974^1 975^1977^1 978^1979^1 980^1981^
  5236    ;;^1982^1 983^1984^1 985^1986^2 018^2019^2 020^2021^2 022^2023^
  5237    ;;^2024^2 025^2026^2 027^2028^2 029^2030^2 031^2032^2 033^2034^
  5238    ;;^2035^2 038^2039^2 040^2041^2 042^
  5239    ;
  5240    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5241    ; 350.8 O .F. entrie s added:
  5242    ;
  5243    ; 239   I B CMN NOT  REQ BUT DA TA  (IB901 )
  5244    ; 240   I B CMN FORM  TYPE  (IB 902)
  5245    ; 241   I B CMN NO D ATA NODE   (IB903)
  5246    ; 243   I B CMN BAD  DATA NODE   (IB904)
  5247    ; 244   I B CMN CERT  TYPE  (IB 905)
  5248    ; 246   I B CMN THER APY DT  (I B907)
  5249    ; 247   I B CMN LAST  CERT DT   (IB908)
  5250    ; 248   I B CMN RECE RT/REVISIO N DT  (IB9 09)
  5251    ; 259   I B CMN ABG  SAT DT  (I B912)
  5252    ; 271   I B CMN 4 LP M DATE  (I B914)
  5253    ; 272   I B CMN ERRO RS HEADER   (IB915)
  5254    ; 273   I B CMN PEB  (IB906)
  5255    ;
  5256   ENT8 ;O.F.  entries i n file 350 .8 to be a dded
  5257    ;
  5258    ;;^239^24 0^241^243^ 244^246^24 7^248^259^ 271^272^27 3^
  5259    ;
  5260    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5261    ; 364.5 e ntries del eted:
  5262    ;
  5263   DEL5    ;  remove O.F . entries  in file 36 4.5 (not r e-added)
  5264    ;
  5265    ;;
  5266    ;
  5267    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5268    ; 364.6 e ntries del eted:
  5269    ;
  5270   DEL6    ;  remove O.F . entries  in file 36 4.6 (not r e-added)
  5271    ;
  5272    ;;
  5273    ;
  5274    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5275    ; 364.7 e ntries del eted:
  5276    ;
  5277    ;
  5278   DEL7    ;  remove O.F . entries  in file 36 4.7 (not r e-added)
  5279    ;
  5280    ;;
  5281    ;
  5282    ;-------- ---------- ---------- ---------- ---------- ---------- ---------- ---
  5283    ; 350.8 E ntries del eted:
  5284    ;
  5285    ;  238  I B CMN REQ
  5286    ;
  5287   DEL8    ;  remove ent ries from  350.8 (IB  ERROR)
  5288    ;
  5289    ;;
  5290    ;
  5291  
  5292   IBY608PO –  Add 50 CP T codes to  the CMN C PT Code In clusion li st in IB S ystem Para meters – i f one of t hese codes  in entere d on a cla im, the us er will be  prompted  for CMN in fo.
  5293   Routines
  5294   Activities
  5295   Routine Na me
  5296   IBY608PO
  5297   Enhancemen t Category
  5298    New
  5299    Modify
  5300    Delete
  5301    No Change
  5302   RTM
  5303  
  5304   Related Op tions
  5305   None
  5306   Related Ro utines
  5307   Routines “ Called By”
  5308   Routines “ Called”   
  5309  
  5310  
  5311  
  5312  
  5313   Data Dicti onary (DD)  Reference s
  5314  
  5315   Related Pr otocols
  5316   None
  5317   Related In tegration  Control Re gistration s (ICRs)
  5318   None
  5319   Data Passi ng
  5320    Input
  5321    Output Re ference
  5322    Both
  5323    Global Re ference
  5324    Local
  5325   Input Attr ibute Name  and Defin ition
  5326   Name:
  5327   Definition :
  5328   Output Att ribute Nam e and Defi nition
  5329   Name:
  5330   Definition :
  5331   Current Lo gic
  5332   IBY608PO ; ALB/KDM -  POST-INSTA LL FOR IB* 2.0*608 ;1 3-DEC-2017
  5333    ;;2.0;INT EGRATED BI LLING;**60 8**;21-MAR -94;Build  40
  5334    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5335    ;
  5336    ;KDM 12/2 017 US1909  
  5337    ; run rep ort of all  insurance  companies  that have  the curre nt setting  for Trans mit Electr onically s et to zero - which is  NO
  5338    ; send em ail of rep ort to eBi z rapid re sponse gro up
  5339    N IBA,RNA ME
  5340    S RNAME=" IBY608PO"
  5341    K ^TMP(RN AME)
  5342    S IBA(2)= "IB*2*608  Post-Insta ll...",(IB A(1),IBA(3 ))=" " D M ES^XPDUTL( .IBA) K IB A
  5343    D MES^XPD UTL(">> Ru nning Insu rance Comp any EDI Pa rameter Re port...ple ase stand  by....")
  5344    D RPT
  5345    D MES^XPD UTL(">> Re port Compl eted.")
  5346    D CMNCPT
  5347    D:$$PROD^ XUPROD(1)  EMAIL      ;LIVE
  5348    D EMAIL      ;TESTIN G  
  5349    S IBA(2)= "IB*2*608  Post-Insta ll Complet e.",(IBA(1 ),IBA(3))= " " D MES^ XPDUTL(.IB A) K IBA
  5350    Q
  5351    ;
  5352   RPT ; Get  all Insura nce compan ies that h ave the 3. 01- transm it electro nically fi eld blank  or set to  No.
  5353    ;N IBADDR ESS,IBCITY ,IBNAME,IB PIEN,IBSTA TE,STATE,T RANSCD,TRA NSMIT
  5354    N IBADDRE SS,IBCITY, IBNAME,IBP IEN,IBSTAT E,INACTFLG ,STATE,TRA NSMIT
  5355    S IBNAME= ""
  5356    F  S IBNA ME=$O(^DIC (36,"B",IB NAME)) Q:I BNAME=""   D
  5357    . S IBPIE N=0
  5358    . F  S IB PIEN=$O(^D IC(36,"B", IBNAME,IBP IEN)) Q:'+ IBPIEN  D
  5359    . . S TRA NSMIT=$$GE T1^DIQ(36, IBPIEN,3.0 1,"I")
  5360    . . Q:+TR ANSMIT  ;O nly want t o report t he insuran ce compani es that ha ve a setti ng of 0 or  NULL
  5361    . . S (IB ADDRESS,IB CITY,IBSTA TE,INACTFL G,STATE)=" "
  5362    . . S IBA DDRESS=$$G ET1^DIQ(36 ,IBPIEN,.1 11)
  5363    . . S IBC ITY=$$GET1 ^DIQ(36,IB PIEN,.114)
  5364    . . S IBS TATE=$$GET 1^DIQ(36,I BPIEN,.115 ,"I")
  5365    . . I +IB STATE S ST ATE=$$GET1 ^DIQ(5,+IB STATE,1)
  5366    . . S INA CTFLG=$$GE T1^DIQ(36, IBPIEN,.05 )
  5367    . . I INA CTFLG="" S  INACTFLG= ""
  5368    . . S ^TM P(RNAME,$J ,IBNAME,IB PIEN)=IBAD DRESS_U_IB CITY_U_STA TE_U_INACT FLG_U_$S(T RANSMIT="" :"",1:"NO" )
  5369    Q
  5370    ;
  5371   EMAIL ; Se nd an emai l message  to eBiz Ra pid Respon se group w ith the re port.
  5372    N ADDRESS ,CITY,DATA ,FULLADD,I BNAME,IBNA MEX,IBPIEN ,INACTFLG, LN,MSG
  5373    N SPACES, SITE,SITEN AME,SITENO ,STATE,STA TION,SUBJ, TOTAL,TRAN S,TRANSCD, XMINSTR,XM TO
  5374    D BMES^XP DUTL(">> S ending Ema il...")
  5375    D MES^XPD UTL("----- --------")
  5376    D MES^XPD UTL("Sendi ng email n otificatio n to eBiz  Rapid resp onse group  ... ")
  5377    ;S SPACES =$J(" ",10 0)
  5378    S $P(SPAC ES,"_",100 )="_"
  5379    S SITE=$$ SITE^VASIT E,SITENAME =$P(SITE,U ,2),SITENO =$P(SITE,U ,1),STATIO N=$P(SITE, U,3)
  5380    S SUBJ="P ATCH IB*2. 0*608 - In surance Co mpany EDI  Report"_"  for Statio n# "_$P(SI TE,U,3)_"  - "_$P(SIT E,U,2)
  5381    S SUBJ=$E (SUBJ,1,65 )
  5382    S MSG(1)= "PATCH IB* 2.0*608 -  Insurance  Company ED I Paramete r Report"
  5383    S MSG(2)= ""
  5384    S MSG(3)= "Site: "_S ITENO_" "_ SITENAME_"  - Station  "_STATION
  5385    S MSG(4)= "Domain: " _$G(^XMB(" NETNAME"))
  5386    S MSG(5)= "Date/Time : "_$$FMTE ^XLFDT($$N OW^XLFDT)
  5387    S MSG(6)= ""
  5388    S MSG(7)= "INSURANCE  COMPANY__ __________ ______ADDR ESS_______ __________ __________ __________ __________ __________ _INACTIVE_ ___EDI-TRA NSMIT"
  5389    S MSG(8)= "========= ========== ========== ========== ========== ========== ========== ========== ========== ========== ========== ========== ====="
  5390    S MSG(9)= ""
  5391    S LN=10,I BNAME="",T OTAL=0
  5392    F  S IBNA ME=$O(^TMP (RNAME,$J, IBNAME)) Q :IBNAME=""   D
  5393    . S IBPIE N=""
  5394    . F  S IB PIEN=$O(^T MP(RNAME,$ J,IBNAME,I BPIEN)) Q: IBPIEN=""   D
  5395    . . S DAT A=^TMP(RNA ME,$J,IBNA ME,IBPIEN)
  5396    . . S IBN AMEX=$$UNS PACE($E(IB NAME,1,30) )
  5397    . . S ADD RESS=$$UNS PACE($E($P (DATA,U,1) ,1,30)),CI TY=$$UNSPA CE($E($P(D ATA,U,2),1 ,25)),STAT E=$$UNSPAC E($P(DATA, U,3))
  5398    . . S FUL LADD=ADDRE SS_", "_CI TY_", "_ST ATE
  5399    . . I '$L (ADDRESS), '$L(CITY), '$L(STATE)  S FULLADD =""
  5400    . . S INA CTFLG=$P(D ATA,U,4)
  5401    . . S TRA NS=$P(DATA ,U,5)
  5402    . . S LN= LN+1,MSG(L N)=IBNAMEX _$E(SPACES ,1,35-$L(I BNAMEX))_F ULLADD_$E( SPACES,1,6 8-$L(FULLA DD))
  5403    . . S MSG (LN)=MSG(L N)_INACTFL G_$E(SPACE S,1,15-$L( INACTFLG)) _TRANS
  5404    . . S TOT AL=TOTAL+1
  5405    S LN=LN+1 ,MSG(LN)=" "
  5406    S LN=LN+1 ,MSG(LN)=" Total: "_+ TOTAL
  5407    S LN=LN+1 ,MSG(LN)=" "
  5408    S LN=LN+1 ,MSG(LN)=" End of Rep ort"
  5409    ;
  5410    ; ***test ing email  to vito,an ne,cj,jane  vs live** * must cha nge back t o live bef ore puttin g in build  ***
  5411    ;S XMTO(" vito.d'ami co@va.gov" )=""
  5412    ;S XMTO(" anne.debac ker@va.gov ")=""
  5413    ;S XMTO(" cherie.min ch@va.gov" )=""
  5414    ;S XMTO(" jane.balch unas@va.go v")=""
  5415    ;S XMTO(" william.ju tzi@va.gov ")=""
  5416    S XMTO("V HAeBilling RR@va.gov" )=""
  5417    ;
  5418    S XMINSTR ("FROM")=" VistA-eBil ling"
  5419    D SENDMSG ^XMXAPI(DU Z,SUBJ,"MS G",.XMTO,. XMINSTR)
  5420    ;
  5421   EMAILX ;
  5422    D MES^XPD UTL(" Done .")
  5423    D CLEAN^D ILF
  5424    Q
  5425    ;
  5426   UNSPACE(FL DX) ; Elim inate spac es at the  end of the  field.
  5427    N I
  5428    F  S I=$L (FLDX) Q:( $E(FLDX,I) '=" ")  I  $E(FLDX,I) =" " S FLD X=$E(FLDX, 1,I-1)
  5429    Q FLDX
  5430    ;
  5431   CMNCPT ;Se t CMN CPT  CODES in I B System P arameters
  5432    D MES^XPD UTL("Setti ng CMN CPT  Codes in  IB SITE PA RAMETER fi le.....")
  5433    N CODES,C PTCD,CPTIE N,CPTS,DA, DIC,DIE,DR ,ERRMSG,FD A,I,RETIEN
  5434    S CODES=" "
  5435    F I=1:1 S  CPTS=$P($ T(CPTCD+I) ,";;",2) Q :CPTS=""   S CODES=$S (CODES="": CPTS,1:COD ES_U_CPTS)
  5436    F I=1:1 S  CPTCD=$P( CODES,U,I)  Q:CPTCD=" "  D
  5437    . S CPTIE N=$$FIND1^ DIC(81,,"X ",CPTCD) Q :'CPTIEN
  5438    . I $D(^I BE(350.9,1 ,16,"B",CP TIEN)) Q
  5439    . K FDA,E RRMSG,RETI EN
  5440    . S FDA(3 50.916,"+1 ,1,",.01)= CPTIEN
  5441    . D UPDAT E^DIE(""," FDA","RETI EN","ERRMS G")
  5442    D MES^XPD UTL("..... CMN CPT Co des set. " )
  5443    Q
  5444    ;
  5445   CPTCD ;
  5446    ;;B4102^B 4103^B4104 ^B4149^B41 50^B4152^B 4153^B4154 ^B4155^B41 57^B4158^B 4159^B4160 ^B4161^B41 62^B4164^B 4168
  5447    ;;B4172^B 4176^B4178 ^B4180^B41 85^B4189^B 4193^B4197 ^B4199^B42 16^B5000^B 5100^B5200 ^B9002^B90 04^B9006^E 0424
  5448    ;;E0431^E 0433^E0434 ^E0439^E04 41^E0442^E 0443^E0444 ^E0776^E07 91^E1390^E 1391^E1392 ^E1405^E14 06^K0738
  5449    ;