1. EPMO Open Source Coordination Office Redaction File Detail Report

Produced by Araxis Merge on 3/20/2019 1:04:39 PM Eastern 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.

1.1 Files compared

# Location File Last Modified
1 eInsurance_IB_2.0_602.zip IB_2.0_602_KIDS Wed Mar 20 11:58:48 2019 UTC
2 eInsurance_IB_2.0_602.zip IB_2.0_602_KIDS Wed Mar 20 16:56:41 2019 UTC

1.2 Comparison summary

Description Between
Files 1 and 2
Text Blocks Lines
Unchanged 4 16676
Changed 3 6
Inserted 0 0
Removed 0 0

1.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

1.4 Active regular expressions

No regular expressions were active.

1.5 Comparison detail

  1   $END TXT
  2   $KID IB*2. 0*602
  3   **INSTALL  NAME**
  4   IB*2.0*602
  5   "BLD",1110 5,0)
  6   IB*2.0*602 ^INTEGRATE D BILLING^ 0^3190221^ y
  7   "BLD",1110 5,4,0)
  8   ^9.64PA^^
  9   "BLD",1110 5,6)
  10   10^
  11   "BLD",1110 5,6.3)
  12   22
  13   "BLD",1110 5,"INID")
  14   ^n
  15   "BLD",1110 5,"INIT")
  16   IBY602PO
  17   "BLD",1110 5,"KRN",0)
  18   ^9.67PA^77 9.2^20
  19   "BLD",1110 5,"KRN",.4 ,0)
  20   .4
  21   "BLD",1110 5,"KRN",.4 ,"NM",0)
  22   ^9.68A^^
  23   "BLD",1110 5,"KRN",.4 01,0)
  24   .401
  25   "BLD",1110 5,"KRN",.4 02,0)
  26   .402
  27   "BLD",1110 5,"KRN",.4 03,0)
  28   .403
  29   "BLD",1110 5,"KRN",.5 ,0)
  30   .5
  31   "BLD",1110 5,"KRN",.8 4,0)
  32   .84
  33   "BLD",1110 5,"KRN",3. 6,0)
  34   3.6
  35   "BLD",1110 5,"KRN",3. 6,"NM",0)
  36   ^9.68A^^
  37   "BLD",1110 5,"KRN",3. 8,0)
  38   3.8
  39   "BLD",1110 5,"KRN",9. 2,0)
  40   9.2
  41   "BLD",1110 5,"KRN",9. 8,0)
  42   9.8
  43   "BLD",1110 5,"KRN",9. 8,"NM",0)
  44   ^9.68A^20^ 19
  45   "BLD",1110 5,"KRN",9. 8,"NM",1,0 )
  46   IBCNAU3^^0 ^B12969808
  47   "BLD",1110 5,"KRN",9. 8,"NM",2,0 )
  48   IBCNBOA^^0 ^B68100333
  49   "BLD",1110 5,"KRN",9. 8,"NM",3,0 )
  50   IBCNBOF^^0 ^B33394771
  51   "BLD",1110 5,"KRN",9. 8,"NM",4,0 )
  52   IBCNERP3^^ 0^B1021282 47
  53   "BLD",1110 5,"KRN",9. 8,"NM",5,0 )
  54   IBCNERPD^^ 0^B1265238 71
  55   "BLD",1110 5,"KRN",9. 8,"NM",6,0 )
  56   IBCNSP^^0^ B77777224
  57   "BLD",1110 5,"KRN",9. 8,"NM",7,0 )
  58   IBCNSUR^^0 ^B13141899 3
  59   "BLD",1110 5,"KRN",9. 8,"NM",8,0 )
  60   IBCOC1^^0^ B24512676
  61   "BLD",1110 5,"KRN",9. 8,"NM",9,0 )
  62   IBCOMD1^^0 ^B37249446
  63   "BLD",1110 5,"KRN",9. 8,"NM",10, 0)
  64   IBCOMN1^^0 ^B18271189
  65   "BLD",1110 5,"KRN",9. 8,"NM",11, 0)
  66   IBCNEKIT^^ 0^B1644960 28
  67   "BLD",1110 5,"KRN",9. 8,"NM",12, 0)
  68   IBCNSMM^^0 ^B19438322
  69   "BLD",1110 5,"KRN",9. 8,"NM",14, 0)
  70   IBCNSMM2^^ 0^B1523423 3
  71   "BLD",1110 5,"KRN",9. 8,"NM",15, 0)
  72   IBCNBOE^^0 ^B11271632 0
  73   "BLD",1110 5,"KRN",9. 8,"NM",16, 0)
  74   IBCNSMM1^^ 0^B2778804 8
  75   "BLD",1110 5,"KRN",9. 8,"NM",17, 0)
  76   IBY602PO^^ 0^B4368711 5
  77   "BLD",1110 5,"KRN",9. 8,"NM",18, 0)
  78   IBCNEUT5^^ 0^B6544439 0
  79   "BLD",1110 5,"KRN",9. 8,"NM",19, 0)
  80   IBCNEDE4^^ 0^B6182662 0
  81   "BLD",1110 5,"KRN",9. 8,"NM",20, 0)
  82   IBCNEHL3^^ 0^B1729506 82
  83   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNAU3" ,1)
  84  
  85   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNBOA" ,2)
  86  
  87   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNBOE" ,15)
  88  
  89   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNBOF" ,3)
  90  
  91   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNEDE4 ",19)
  92  
  93   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNEHL3 ",20)
  94  
  95   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNEKIT ",11)
  96  
  97   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNERP3 ",4)
  98  
  99   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNERPD ",5)
  100  
  101   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNEUT5 ",18)
  102  
  103   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNSMM" ,12)
  104  
  105   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNSMM1 ",16)
  106  
  107   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNSMM2 ",14)
  108  
  109   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNSP", 6)
  110  
  111   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCNSUR" ,7)
  112  
  113   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCOC1", 8)
  114  
  115   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCOMD1" ,9)
  116  
  117   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBCOMN1" ,10)
  118  
  119   "BLD",1110 5,"KRN",9. 8,"NM","B" ,"IBY602PO ",17)
  120  
  121   "BLD",1110 5,"KRN",19 ,0)
  122   19
  123   "BLD",1110 5,"KRN",19 ,"NM",0)
  124   ^9.68A^24^ 24
  125   "BLD",1110 5,"KRN",19 ,"NM",1,0)
  126   IBCN LIST  INACTIVE I NS W/PAT^^ 4^
  127   "BLD",1110 5,"KRN",19 ,"NM",2,0)
  128   IBCN EXPIR E GROUP SU BSCRIBERS^ ^0
  129   "BLD",1110 5,"KRN",19 ,"NM",3,0)
  130   IBCN INSUR ANCE MGMT  MENU^^0
  131   "BLD",1110 5,"KRN",19 ,"NM",4,0)
  132   IBCN INSUR ANCE CO ED IT^^4^
  133   "BLD",1110 5,"KRN",19 ,"NM",5,0)
  134   IBCN PATIE NT INSURAN CE^^4^
  135   "BLD",1110 5,"KRN",19 ,"NM",6,0)
  136   IBCN VIEW  PATIENT IN SURANCE^^4 ^
  137   "BLD",1110 5,"KRN",19 ,"NM",7,0)
  138   IBCN VIEW  INSURANCE  CO^^4^
  139   "BLD",1110 5,"KRN",19 ,"NM",8,0)
  140   IBCN LIST  NEW NOT VE R^^4^
  141   "BLD",1110 5,"KRN",19 ,"NM",9,0)
  142   IBCN LIST  PLANS BY I NS CO^^4^
  143   "BLD",1110 5,"KRN",19 ,"NM",10,0 )
  144   IBCN INSUR ANCE BUFFE R PROCESS^ ^4^
  145   "BLD",1110 5,"KRN",19 ,"NM",11,0 )
  146   IBCN POL W /NO EFF DA TE REPORT^ ^4^
  147   "BLD",1110 5,"KRN",19 ,"NM",12,0 )
  148   IBCN ID DU P INSURANC E ENTRIES^ ^4^
  149   "BLD",1110 5,"KRN",19 ,"NM",13,0 )
  150   IBCN MOVE  SUBSCRIB T O PLAN^^4^
  151   "BLD",1110 5,"KRN",19 ,"NM",14,0 )
  152   IBCN NO CO VERAGE VER IFIED^^4^
  153   "BLD",1110 5,"KRN",19 ,"NM",15,0 )
  154   IBCN PT W/ WO INSURAN CE REPORT^ ^4^
  155   "BLD",1110 5,"KRN",19 ,"NM",16,0 )
  156   IBCN REMOT E INSURANC E QUERY^^4 ^
  157   "BLD",1110 5,"KRN",19 ,"NM",17,0 )
  158   IBCNE IIV  MENU^^4^
  159   "BLD",1110 5,"KRN",19 ,"NM",18,0 )
  160   IBCNE PAYE R MAINTENA NCE MENU^^ 4^
  161   "BLD",1110 5,"KRN",19 ,"NM",19,0 )
  162   IBCNR E-PH ARMACY MEN U^^4^
  163   "BLD",1110 5,"KRN",19 ,"NM",20,0 )
  164   IBCN INSUR ANCE EDI R EPORT^^4^
  165   "BLD",1110 5,"KRN",19 ,"NM",21,0 )
  166   IBCN INS R PTS^^4^
  167   "BLD",1110 5,"KRN",19 ,"NM",22,0 )
  168   IBCN INTER FACILITY I NS UPDATE^ ^4^
  169   "BLD",1110 5,"KRN",19 ,"NM",23,0 )
  170   IBCN HPID  CLAIM RPT^ ^4^
  171   "BLD",1110 5,"KRN",19 ,"NM",24,0 )
  172   IBCN INS P LANS MISSI NG DATA^^4 ^
  173   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN EXPI RE GROUP S UBSCRIBERS ",2)
  174  
  175   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN HPID  CLAIM RPT ",23)
  176  
  177   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN ID D UP INSURAN CE ENTRIES ",12)
  178  
  179   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INS  PLANS MISS ING DATA", 24)
  180  
  181   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INS  RPTS",21)
  182  
  183   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INSU RANCE BUFF ER PROCESS ",10)
  184  
  185   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INSU RANCE CO E DIT",4)
  186  
  187   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INSU RANCE EDI  REPORT",20 )
  188  
  189   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INSU RANCE MGMT  MENU",3)
  190  
  191   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN INTE RFACILITY  INS UPDATE ",22)
  192  
  193   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN LIST  INACTIVE  INS W/PAT" ,1)
  194  
  195   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN LIST  NEW NOT V ER",8)
  196  
  197   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN LIST  PLANS BY  INS CO",9)
  198  
  199   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN MOVE  SUBSCRIB  TO PLAN",1 3)
  200  
  201   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN NO C OVERAGE VE RIFIED",14 )
  202  
  203   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN PATI ENT INSURA NCE",5)
  204  
  205   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN POL  W/NO EFF D ATE REPORT ",11)
  206  
  207   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN PT W /WO INSURA NCE REPORT ",15)
  208  
  209   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN REMO TE INSURAN CE QUERY", 16)
  210  
  211   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN VIEW  INSURANCE  CO",7)
  212  
  213   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCN VIEW  PATIENT I NSURANCE", 6)
  214  
  215   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCNE IIV  MENU",17)
  216  
  217   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCNE PAY ER MAINTEN ANCE MENU" ,18)
  218  
  219   "BLD",1110 5,"KRN",19 ,"NM","B", "IBCNR E-P HARMACY ME NU",19)
  220  
  221   "BLD",1110 5,"KRN",19 .1,0)
  222   19.1
  223   "BLD",1110 5,"KRN",10 1,0)
  224   101
  225   "BLD",1110 5,"KRN",40 9.61,0)
  226   409.61
  227   "BLD",1110 5,"KRN",77 1,0)
  228   771
  229   "BLD",1110 5,"KRN",77 9.2,0)
  230   779.2
  231   "BLD",1110 5,"KRN",87 0,0)
  232   870
  233   "BLD",1110 5,"KRN",89 89.51,0)
  234   8989.51
  235   "BLD",1110 5,"KRN",89 89.52,0)
  236   8989.52
  237   "BLD",1110 5,"KRN",89 94,0)
  238   8994
  239   "BLD",1110 5,"KRN","B ",.4,.4)
  240  
  241   "BLD",1110 5,"KRN","B ",.401,.40 1)
  242  
  243   "BLD",1110 5,"KRN","B ",.402,.40 2)
  244  
  245   "BLD",1110 5,"KRN","B ",.403,.40 3)
  246  
  247   "BLD",1110 5,"KRN","B ",.5,.5)
  248  
  249   "BLD",1110 5,"KRN","B ",.84,.84)
  250  
  251   "BLD",1110 5,"KRN","B ",3.6,3.6)
  252  
  253   "BLD",1110 5,"KRN","B ",3.8,3.8)
  254  
  255   "BLD",1110 5,"KRN","B ",9.2,9.2)
  256  
  257   "BLD",1110 5,"KRN","B ",9.8,9.8)
  258  
  259   "BLD",1110 5,"KRN","B ",19,19)
  260  
  261   "BLD",1110 5,"KRN","B ",19.1,19. 1)
  262  
  263   "BLD",1110 5,"KRN","B ",101,101)
  264  
  265   "BLD",1110 5,"KRN","B ",409.61,4 09.61)
  266  
  267   "BLD",1110 5,"KRN","B ",771,771)
  268  
  269   "BLD",1110 5,"KRN","B ",779.2,77 9.2)
  270  
  271   "BLD",1110 5,"KRN","B ",870,870)
  272  
  273   "BLD",1110 5,"KRN","B ",8989.51, 8989.51)
  274  
  275   "BLD",1110 5,"KRN","B ",8989.52, 8989.52)
  276  
  277   "BLD",1110 5,"KRN","B ",8994,899 4)
  278  
  279   "BLD",1110 5,"QDEF")
  280   ^^^^NO^^^^ YES^^YES
  281   "BLD",1110 5,"QUES",0 )
  282   ^9.62^^
  283   "BLD",1110 5,"REQB",0 )
  284   ^9.611^2^1
  285   "BLD",1110 5,"REQB",2 ,0)
  286   IB*2.0*621 ^1
  287   "BLD",1110 5,"REQB"," B","IB*2.0 *621",2)
  288  
  289   "INIT")
  290   IBY602PO
  291   "KRN",19,2 913770,-1)
  292   0^3
  293   "KRN",19,2 913770,0)
  294   IBCN INSUR ANCE MGMT  MENU^Patie nt Insuran ce Menu^^M ^^^^^^^^
  295   "KRN",19,2 913770,1,0 )
  296   ^19.06^1^1 ^3180314^^ ^^
  297   "KRN",19,2 913770,1,1 ,0)
  298   This is th e main men u to edit,  view, and  print ins urance inf ormation.
  299   "KRN",19,2 913770,10, 0)
  300   ^19.01IP^2 5^25
  301   "KRN",19,2 913770,10, 2,0)
  302   2913771^EI ^3
  303   "KRN",19,2 913770,10, 2,"^")
  304   IBCN INSUR ANCE CO ED IT
  305   "KRN",19,2 913770,10, 3,0)
  306   2913772^PI ^1
  307   "KRN",19,2 913770,10, 3,"^")
  308   IBCN PATIE NT INSURAN CE
  309   "KRN",19,2 913770,10, 4,0)
  310   2913773^VP ^2
  311   "KRN",19,2 913770,10, 4,"^")
  312   IBCN VIEW  PATIENT IN SURANCE
  313   "KRN",19,2 913770,10, 5,0)
  314   2913774^VI ^4
  315   "KRN",19,2 913770,10, 5,"^")
  316   IBCN VIEW  INSURANCE  CO
  317   "KRN",19,2 913770,10, 6,0)
  318   2913790^LC ^49
  319   "KRN",19,2 913770,10, 6,"^")
  320   IBCN LIST  INACTIVE I NS W/PAT
  321   "KRN",19,2 913770,10, 7,0)
  322   2913792^NV
  323   "KRN",19,2 913770,10, 7,"^")
  324   IBCN LIST  NEW NOT VE R
  325   "KRN",19,2 913770,10, 8,0)
  326   2915092^LP ^53
  327   "KRN",19,2 913770,10, 8,"^")
  328   IBCN LIST  PLANS BY I NS CO
  329   "KRN",19,2 913770,10, 9,0)
  330   2917882^BI ^21
  331   "KRN",19,2 913770,10, 9,"^")
  332   IBCN INSUR ANCE BUFFE R PROCESS
  333   "KRN",19,2 913770,10, 10,0)
  334   2918301^NE
  335   "KRN",19,2 913770,10, 10,"^")
  336   IBCN POL W /NO EFF DA TE REPORT
  337   "KRN",19,2 913770,10, 11,0)
  338   2918300^ID ^37
  339   "KRN",19,2 913770,10, 11,"^")
  340   IBCN ID DU P INSURANC E ENTRIES
  341   "KRN",19,2 913770,10, 12,0)
  342   2918302^MV ^61
  343   "KRN",19,2 913770,10, 12,"^")
  344   IBCN MOVE  SUBSCRIB T O PLAN
  345   "KRN",19,2 913770,10, 13,0)
  346   2918304^NC
  347   "KRN",19,2 913770,10, 13,"^")
  348   IBCN NO CO VERAGE VER IFIED
  349   "KRN",19,2 913770,10, 15,0)
  350   2918303^WO
  351   "KRN",19,2 913770,10, 15,"^")
  352   IBCN PT W/ WO INSURAN CE REPORT
  353   "KRN",19,2 913770,10, 16,0)
  354   2919241^RQ I
  355   "KRN",19,2 913770,10, 16,"^")
  356   IBCN REMOT E INSURANC E QUERY
  357   "KRN",19,2 913770,10, 17,0)
  358   2919334^EI V^25
  359   "KRN",19,2 913770,10, 17,"^")
  360   IBCNE IIV  MENU
  361   "KRN",19,2 913770,10, 18,0)
  362   2919335^PM
  363   "KRN",19,2 913770,10, 18,"^")
  364   IBCNE PAYE R MAINTENA NCE MENU
  365   "KRN",19,2 913770,10, 19,0)
  366   2919873^EP H^29
  367   "KRN",19,2 913770,10, 19,"^")
  368   IBCNR E-PH ARMACY MEN U
  369   "KRN",19,2 913770,10, 20,0)
  370   2920073^EP R^17
  371   "KRN",19,2 913770,10, 20,"^")
  372   IBCN INSUR ANCE EDI R EPORT
  373   "KRN",19,2 913770,10, 21,0)
  374   2922289^IN SR^45
  375   "KRN",19,2 913770,10, 21,"^")
  376   IBCN INS R PTS
  377   "KRN",19,2 913770,10, 22,0)
  378   2922293^IF IU^41
  379   "KRN",19,2 913770,10, 22,"^")
  380   IBCN INTER FACILITY I NS UPDATE
  381   "KRN",19,2 913770,10, 23,0)
  382   2922294^HP ID^33
  383   "KRN",19,2 913770,10, 23,"^")
  384   IBCN HPID  CLAIM RPT
  385   "KRN",19,2 913770,10, 24,0)
  386   2922342^MD ^57
  387   "KRN",19,2 913770,10, 24,"^")
  388   IBCN INS P LANS MISSI NG DATA
  389   "KRN",19,2 913770,10, 25,0)
  390   2922538^XP IR^65
  391   "KRN",19,2 913770,10, 25,"^")
  392   IBCN EXPIR E GROUP SU BSCRIBERS
  393   "KRN",19,2 913770,99)
  394   65021,3038 1
  395   "KRN",19,2 913770,99. 1)
  396   65064,4023 6
  397   "KRN",19,2 913770,"U" )
  398   PATIENT IN SURANCE ME NU
  399   "KRN",19,2 913771,-1)
  400   4^4
  401   "KRN",19,2 913771,0)
  402   IBCN INSUR ANCE CO ED IT
  403   "KRN",19,2 913772,-1)
  404   4^5
  405   "KRN",19,2 913772,0)
  406   IBCN PATIE NT INSURAN CE
  407   "KRN",19,2 913773,-1)
  408   4^6
  409   "KRN",19,2 913773,0)
  410   IBCN VIEW  PATIENT IN SURANCE
  411   "KRN",19,2 913774,-1)
  412   4^7
  413   "KRN",19,2 913774,0)
  414   IBCN VIEW  INSURANCE  CO
  415   "KRN",19,2 913790,-1)
  416   4^1
  417   "KRN",19,2 913790,0)
  418   IBCN LIST  INACTIVE I NS W/PAT
  419   "KRN",19,2 913792,-1)
  420   4^8
  421   "KRN",19,2 913792,0)
  422   IBCN LIST  NEW NOT VE R
  423   "KRN",19,2 915092,-1)
  424   4^9
  425   "KRN",19,2 915092,0)
  426   IBCN LIST  PLANS BY I NS CO
  427   "KRN",19,2 917882,-1)
  428   4^10
  429   "KRN",19,2 917882,0)
  430   IBCN INSUR ANCE BUFFE R PROCESS
  431   "KRN",19,2 918300,-1)
  432   4^12
  433   "KRN",19,2 918300,0)
  434   IBCN ID DU P INSURANC E ENTRIES
  435   "KRN",19,2 918301,-1)
  436   4^11
  437   "KRN",19,2 918301,0)
  438   IBCN POL W /NO EFF DA TE REPORT
  439   "KRN",19,2 918302,-1)
  440   4^13
  441   "KRN",19,2 918302,0)
  442   IBCN MOVE  SUBSCRIB T O PLAN
  443   "KRN",19,2 918303,-1)
  444   4^15
  445   "KRN",19,2 918303,0)
  446   IBCN PT W/ WO INSURAN CE REPORT
  447   "KRN",19,2 918304,-1)
  448   4^14
  449   "KRN",19,2 918304,0)
  450   IBCN NO CO VERAGE VER IFIED
  451   "KRN",19,2 919241,-1)
  452   4^16
  453   "KRN",19,2 919241,0)
  454   IBCN REMOT E INSURANC E QUERY
  455   "KRN",19,2 919334,-1)
  456   4^17
  457   "KRN",19,2 919334,0)
  458   IBCNE IIV  MENU
  459   "KRN",19,2 919335,-1)
  460   4^18
  461   "KRN",19,2 919335,0)
  462   IBCNE PAYE R MAINTENA NCE MENU
  463   "KRN",19,2 919873,-1)
  464   4^19
  465   "KRN",19,2 919873,0)
  466   IBCNR E-PH ARMACY MEN U
  467   "KRN",19,2 920073,-1)
  468   4^20
  469   "KRN",19,2 920073,0)
  470   IBCN INSUR ANCE EDI R EPORT
  471   "KRN",19,2 922289,-1)
  472   4^21
  473   "KRN",19,2 922289,0)
  474   IBCN INS R PTS
  475   "KRN",19,2 922293,-1)
  476   4^22
  477   "KRN",19,2 922293,0)
  478   IBCN INTER FACILITY I NS UPDATE
  479   "KRN",19,2 922294,-1)
  480   4^23
  481   "KRN",19,2 922294,0)
  482   IBCN HPID  CLAIM RPT
  483   "KRN",19,2 922342,-1)
  484   4^24
  485   "KRN",19,2 922342,0)
  486   IBCN INS P LANS MISSI NG DATA
  487   "KRN",19,2 922538,-1)
  488   0^2
  489   "KRN",19,2 922538,0)
  490   IBCN EXPIR E GROUP SU BSCRIBERS^ Expire Gro up Plan^^R ^^^^^^^n^I NTEGRATED  BILLING
  491   "KRN",19,2 922538,1,0 )
  492   ^^3^3^3180 406^
  493   "KRN",19,2 922538,1,1 ,0)
  494   This optio n allows u sers to en ter an exp iration da te to expi re all
  495   "KRN",19,2 922538,1,2 ,0)
  496   subscriber  policies  associated  with a gr oup plan w ithout req uiring 
  497   "KRN",19,2 922538,1,3 ,0)
  498   them to be  moved to  a new plan .
  499   "KRN",19,2 922538,10. 1)
  500   Expire Gro up Plan
  501   "KRN",19,2 922538,25)
  502   EXPGRP^IBC NSUR
  503   "KRN",19,2 922538,"U" )
  504   EXPIRE GRO UP PLAN
  505   "MBREQ")
  506   0
  507   "ORD",18,1 9)
  508   19;18;;;OP T^XPDTA;OP TF1^XPDIA; OPTE1^XPDI A;OPTF2^XP DIA;;OPTDE L^XPDIA
  509   "ORD",18,1 9,0)
  510   OPTION
  511   "PKG",230, -1)
  512   1^1
  513   "PKG",230, 0)
  514   INTEGRATED  BILLING^I B^INTEGRAT ED BILLING
  515   "PKG",230, 22,0)
  516   ^9.49I^1^1
  517   "PKG",230, 22,1,0)
  518   2.0^294032 1^2940525
  519   "PKG",230, 22,1,"PAH" ,1,0)
  520   602^319022 1^217
  521   "QUES","XP F1",0)
  522   Y
  523   "QUES","XP F1","??")
  524   ^D REP^XPD H
  525   "QUES","XP F1","A")
  526   Shall I wr ite over y our |FLAG|  File
  527   "QUES","XP F1","B")
  528   YES
  529   "QUES","XP F1","M")
  530   D XPF1^XPD IQ
  531   "QUES","XP F2",0)
  532   Y
  533   "QUES","XP F2","??")
  534   ^D DTA^XPD H
  535   "QUES","XP F2","A")
  536   Want my da ta |FLAG|  yours
  537   "QUES","XP F2","B")
  538   YES
  539   "QUES","XP F2","M")
  540   D XPF2^XPD IQ
  541   "QUES","XP I1",0)
  542   YO
  543   "QUES","XP I1","??")
  544   ^D INHIBIT ^XPDH
  545   "QUES","XP I1","A")
  546   Want KIDS  to INHIBIT  LOGONs du ring the i nstall
  547   "QUES","XP I1","B")
  548   NO
  549   "QUES","XP I1","M")
  550   D XPI1^XPD IQ
  551   "QUES","XP M1",0)
  552   PO^VA(200, :EM
  553   "QUES","XP M1","??")
  554   ^D MG^XPDH
  555   "QUES","XP M1","A")
  556   Enter the  Coordinato r for Mail  Group '|F LAG|'
  557   "QUES","XP M1","B")
  558  
  559   "QUES","XP M1","M")
  560   D XPM1^XPD IQ
  561   "QUES","XP O1",0)
  562   Y
  563   "QUES","XP O1","??")
  564   ^D MENU^XP DH
  565   "QUES","XP O1","A")
  566   Want KIDS  to Rebuild  Menu Tree s Upon Com pletion of  Install
  567   "QUES","XP O1","B")
  568   YES
  569   "QUES","XP O1","M")
  570   D XPO1^XPD IQ
  571   "QUES","XP Z1",0)
  572   Y
  573   "QUES","XP Z1","??")
  574   ^D OPT^XPD H
  575   "QUES","XP Z1","A")
  576   Want to DI SABLE Sche duled Opti ons, Menu  Options, a nd Protoco ls
  577   "QUES","XP Z1","B")
  578   YES
  579   "QUES","XP Z1","M")
  580   D XPZ1^XPD IQ
  581   "QUES","XP Z2",0)
  582   Y
  583   "QUES","XP Z2","??")
  584   ^D RTN^XPD H
  585   "QUES","XP Z2","A")
  586   Want to MO VE routine s to other  CPUs
  587   "QUES","XP Z2","B")
  588   NO
  589   "QUES","XP Z2","M")
  590   D XPZ2^XPD IQ
  591   "RTN")
  592   19
  593   "RTN","IBC NAU3")
  594   0^1^B12969 808^B12671 484
  595   "RTN","IBC NAU3",1,0)
  596   IBCNAU3 ;A LB/KML/AWC  - eIV USE R EDIT REP ORT (PRINT ) ;6-APRIL -2015
  597   "RTN","IBC NAU3",2,0)
  598    ;;2.0;INT EGRATED BI LLING;**52 8,602**;21 -MAR-94;Bu ild 22
  599   "RTN","IBC NAU3",3,0)
  600    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  601   "RTN","IBC NAU3",4,0)
  602    ;
  603   "RTN","IBC NAU3",5,0)
  604    ;  Requir ed variabl e input:   ALLUSERS,  ALLINS, PL ANS, ALLPL ANS, EXCEL
  605   "RTN","IBC NAU3",6,0)
  606    ;  ^TMP(" IBINC",$J)  
  607   "RTN","IBC NAU3",7,0)
  608    ;  ^TMP(" IBUSER",$J
  609   "RTN","IBC NAU3",8,0)
  610    ;  DATE(" START") an d DATE("EN D") requir ed array e lements if  all dates  not selec ted
  611   "RTN","IBC NAU3",9,0)
  612    Q
  613   "RTN","IBC NAU3",10,0 )
  614    ;
  615   "RTN","IBC NAU3",11,0 )
  616   EN(ALLPLAN S,PLANS) ;
  617   "RTN","IBC NAU3",12,0 )
  618    ; Print t he report.
  619   "RTN","IBC NAU3",13,0 )
  620    ;                   
  621   "RTN","IBC NAU3",14,0 )
  622    I EXCEL D  EXCEL(PLA NS) Q
  623   "RTN","IBC NAU3",15,0 )
  624    N IBI,IBJ ,IBK,IBL,I BM,IB01,IB 02,IBQUIT, IBPAG,IBPD ,IBHDT
  625   "RTN","IBC NAU3",16,0 )
  626    S (IB02,I BQUIT,IBPA G)=0
  627   "RTN","IBC NAU3",17,0 )
  628    S IBHDT=$ $FMTE^XLFD T($$NOW^XL FDT())
  629   "RTN","IBC NAU3",18,0 )
  630    ;
  631   "RTN","IBC NAU3",19,0 )
  632    D HDR(ALL PLANS,PLAN S)
  633   "RTN","IBC NAU3",20,0 )
  634    I '$D(^TM P("IBPR",$ J)) W !!," User Edits  do not ex ist per th e selected  filters."  D PAUSE Q
  635   "RTN","IBC NAU3",21,0 )
  636    ;
  637   "RTN","IBC NAU3",22,0 )
  638    F IB01=0, 1 F  S IB0 2=$O(^TMP( "IBPR",$J, IB01,IB02) ) Q:'IB02   Q:IBQUIT   S IBPD=$G (^TMP("IBP R",$J,IB01 ,IB02)) D   Q:IBQUIT
  639   "RTN","IBC NAU3",23,0 )
  640    . I $Y>(I OSL-5) D P AUSE Q:IBQ UIT  D HDR (ALLPLANS, PLANS)
  641   "RTN","IBC NAU3",24,0 )
  642    . D PLAN
  643   "RTN","IBC NAU3",25,0 )
  644    W !!,"END  OF REPORT " D PAUSE
  645   "RTN","IBC NAU3",26,0 )
  646    Q
  647   "RTN","IBC NAU3",27,0 )
  648    ;
  649   "RTN","IBC NAU3",28,0 )
  650    ;
  651   "RTN","IBC NAU3",29,0 )
  652   HDR(ALLPLA NS,PLANS)  ; Print RE PORT heade r
  653   "RTN","IBC NAU3",30,0 )
  654    I $E(IOST ,1,2)="C-" !(IBPAG) W  @IOF
  655   "RTN","IBC NAU3",31,0 )
  656    S IBPAG=I BPAG+1
  657   "RTN","IBC NAU3",32,0 )
  658    W !,"USER  EDIT REPO RT"
  659   "RTN","IBC NAU3",33,0 )
  660    W ?IOM-34 ,IBHDT,?IO M-10,"Page : ",IBPAG
  661   "RTN","IBC NAU3",34,0 )
  662    W !?5,"In surance Co mpany"
  663   "RTN","IBC NAU3",35,0 )
  664    I PLANS W  ?42,"Grou p Name"
  665   "RTN","IBC NAU3",36,0 )
  666    W !!?5,"U ser",?25," Date/Time  of Change" ,?49,"Modi fied Field ",?75,"Pre vious Valu e of Data" ,?100,"Mod ified Valu e of Data"
  667   "RTN","IBC NAU3",37,0 )
  668    W !,$TR($ J(" ",IOM) ," ","_"), !
  669   "RTN","IBC NAU3",38,0 )
  670    Q
  671   "RTN","IBC NAU3",39,0 )
  672    ;
  673   "RTN","IBC NAU3",40,0 )
  674   PLAN ; Pri nt plan in formation.
  675   "RTN","IBC NAU3",41,0 )
  676    N USER,DA TE
  677   "RTN","IBC NAU3",42,0 )
  678    S USER=$$ GET1^DIQ(2 00,$P(IBPD ,U,3)_",", .01)
  679   "RTN","IBC NAU3",43,0 )
  680    S DATE=$$ FMTE^XLFDT ($P(IBPD,U ,4),2),DAT E=$TR(DATE ,"@"," ")
  681   "RTN","IBC NAU3",44,0 )
  682    W !?5,$P( IBPD,U),?4 2,$S('IB01 :"",1:$P(I BPD,U,2))
  683   "RTN","IBC NAU3",45,0 )
  684    W !?5,USE R,?25,DATE ,?49,$P(IB PD,U,7),?7 5,$S($P(IB PD,U,5)="" :"<no prev ious value >",1:$P(IB PD,U,5)),? 100,$P(IBP D,U,6),!!
  685   "RTN","IBC NAU3",46,0 )
  686    Q
  687   "RTN","IBC NAU3",47,0 )
  688    ;
  689   "RTN","IBC NAU3",48,0 )
  690   PAUSE ; Pa use for sc reen outpu t.
  691   "RTN","IBC NAU3",49,0 )
  692    Q:$E(IOST ,1,2)'["C- "
  693   "RTN","IBC NAU3",50,0 )
  694    S DIR(0)= "E" D ^DIR  K DIR I $ D(DIRUT)!( $D(DUOUT))  S IBQUIT= 1 K DIRUT, DTOUT,DUOU T
  695   "RTN","IBC NAU3",51,0 )
  696    Q
  697   "RTN","IBC NAU3",52,0 )
  698    ;
  699   "RTN","IBC NAU3",53,0 )
  700   EXCEL(PLAN S) ; user  selected f ormat that  can be vi ewed in MS  Excel
  701   "RTN","IBC NAU3",54,0 )
  702    N IBI,IBJ ,IBK,IBL,I BM,IB01,IB 02,USER,DA TE
  703   "RTN","IBC NAU3",55,0 )
  704    S (IB01,I B02)=0
  705   "RTN","IBC NAU3",56,0 )
  706    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets 
  707   "RTN","IBC NAU3",57,0 )
  708    W !,"USER  EDIT REPO RT^"_$$FMT E^XLFDT($$ NOW^XLFDT, 1)
  709   "RTN","IBC NAU3",58,0 )
  710    ; IB*602/ HN end  
  711   "RTN","IBC NAU3",59,0 )
  712    ; 
  713   "RTN","IBC NAU3",60,0 )
  714    I PLANS W  !,"Insura nce Compan y^Group Na me^User^Da te/Time of  Change^Mo dified Fie ld^Previou s Value of  Data^Modi fied Value  of Data", !
  715   "RTN","IBC NAU3",61,0 )
  716    E  W !,"I nsurance C ompany^Use r^Date/Tim e of Chang e^Modified  Field^Pre vious Valu e of Data^ Modified V alue of Da ta",!
  717   "RTN","IBC NAU3",62,0 )
  718    ;
  719   "RTN","IBC NAU3",63,0 )
  720    F IB01=0, 1 F  S IB0 2=$O(^TMP( "IBPR",$J, IB01,IB02) ) Q:'IB02   S IBPD=$G (^TMP("IBP R",$J,IB01 ,IB02)) D
  721   "RTN","IBC NAU3",64,0 )
  722    . S USER= $$GET1^DIQ (200,$P(IB PD,U,3)_", ",.01)
  723   "RTN","IBC NAU3",65,0 )
  724    . S DATE= $$FMTE^XLF DT($P(IBPD ,U,4),2)
  725   "RTN","IBC NAU3",66,0 )
  726    . I IB01= 0 W $P(IBP D,U)_U_USE R_U_DATE_U _$P(IBPD,U ,7)_U_$S($ P(IBPD,U,5 )="":"<no  previous v alue>",1:$ P(IBPD,U,5 ))_U_$P(IB PD,U,6)
  727   "RTN","IBC NAU3",67,0 )
  728    . E  W $P (IBPD,U)_U _$P(IBPD,U ,2)_U_USER _U_DATE_U_ $P(IBPD,U, 7)_U_$S($P (IBPD,U,5) ="":"<no p revious va lue>",1:$P (IBPD,U,5) )_U_$P(IBP D,U,6)
  729   "RTN","IBC NAU3",68,0 )
  730    . W !
  731   "RTN","IBC NAU3",69,0 )
  732    ; -- writ e to scree n
  733   "RTN","IBC NAU3",70,0 )
  734    I $E(IOST ,1,2)["C-"  W !,"[END  OF REPORT ]",! S DIR ("A")="Pre ss RETURN  to continu e" D PAUSE
  735   "RTN","IBC NAU3",71,0 )
  736    Q
  737   "RTN","IBC NBOA")
  738   0^2^B68100 333^B66757 822
  739   "RTN","IBC NBOA",1,0)
  740   IBCNBOA ;A LB/ARH - I ns Buffer:  Activity  Report ;1  Jun 97
  741   "RTN","IBC NBOA",2,0)
  742    ;;2.0;INT EGRATED BI LLING;**82 ,305,528,6 02**;21-MA R-94;Build  22
  743   "RTN","IBC NBOA",3,0)
  744    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  745   "RTN","IBC NBOA",4,0)
  746    ;
  747   "RTN","IBC NBOA",5,0)
  748   EN ;get pa rameters t hen run th e report
  749   "RTN","IBC NBOA",6,0)
  750    ;
  751   "RTN","IBC NBOA",7,0)
  752    K ^TMP($J ) D HOME^% ZIS S IBHD R="INSURAN CE BUFFER  ACTIVITY R EPORT" W @ IOF,!!,?25 ,IBHDR
  753   "RTN","IBC NBOA",8,0)
  754    W !!,"Thi s report c ontains th e counts a nd time st atistics f or all act ivity in t he",!,"Ins urance Buf fer.",!!
  755   "RTN","IBC NBOA",9,0)
  756    ;
  757   "RTN","IBC NBOA",10,0 )
  758    S IBBEG=$ $DATES^IBC NBOE("Begi nning") G: 'IBBEG EXI T
  759   "RTN","IBC NBOA",11,0 )
  760    S IBEND=$ $DATES^IBC NBOE("Endi ng",IBBEG)  G:'IBEND  EXIT  W !!
  761   "RTN","IBC NBOA",12,0 )
  762    ;
  763   "RTN","IBC NBOA",13,0 )
  764    S IBMONTH =$$MONTH^I BCNBOE G:I BMONTH=""  EXIT  W !!
  765   "RTN","IBC NBOA",14,0 )
  766    ;
  767   "RTN","IBC NBOA",15,0 )
  768    S IBOUT=$ $OUT^IBCNB OE G:IBOUT ="" EXIT
  769   "RTN","IBC NBOA",16,0 )
  770    ;
  771   "RTN","IBC NBOA",17,0 )
  772   DEV ;get t he device
  773   "RTN","IBC NBOA",18,0 )
  774    S %ZIS="Q M",%ZIS("A ")="OUTPUT  DEVICE: "  D ^%ZIS G :POP EXIT
  775   "RTN","IBC NBOA",19,0 )
  776    I $D(IO(" Q")) S ZTR TN="RPT^IB CNBOA",ZTD ESC=IBHDR, ZTSAVE("IB *")="" D ^ %ZTLOAD K  IO("Q") G  EXIT
  777   "RTN","IBC NBOA",20,0 )
  778    U IO
  779   "RTN","IBC NBOA",21,0 )
  780    ;
  781   "RTN","IBC NBOA",22,0 )
  782   RPT ; run  report
  783   "RTN","IBC NBOA",23,0 )
  784    S IBQUIT= 0
  785   "RTN","IBC NBOA",24,0 )
  786    ;
  787   "RTN","IBC NBOA",25,0 )
  788    ;Patch 30 5- QUIT in  line belo w inserted  for trans mission to  ARC
  789   "RTN","IBC NBOA",26,0 )
  790    D SEARCH( IBBEG,IBEN D,IBMONTH)  Q:$G(IBAR FLAG)  G:I BQUIT EXIT
  791   "RTN","IBC NBOA",27,0 )
  792    D PRINT(I BBEG,IBEND ,IBOUT)
  793   "RTN","IBC NBOA",28,0 )
  794    ;
  795   "RTN","IBC NBOA",29,0 )
  796   EXIT K ^TM P($J),IBHD R,IBBEG,IB END,IBMONT H,IBOUT,IB QUIT
  797   "RTN","IBC NBOA",30,0 )
  798    Q:$D(ZTQU EUED)
  799   "RTN","IBC NBOA",31,0 )
  800    D ^%ZISC
  801   "RTN","IBC NBOA",32,0 )
  802    Q
  803   "RTN","IBC NBOA",33,0 )
  804    ;
  805   "RTN","IBC NBOA",34,0 )
  806   SEARCH(IBB EG,IBEND,I BMONTH) ;  search/sor t statisti cs for act ivity repo rt
  807   "RTN","IBC NBOA",35,0 )
  808    N IBXST,I BXDT,IBBUF DA,IBB0,IB STAT,IBTIM E,IBS3,IBD ATE,IBVER, IBDT2 S IB QUIT=""
  809   "RTN","IBC NBOA",36,0 )
  810    S IBBEG=$ G(IBBEG)-. 01,IBEND=$ S('$G(IBEN D):9999999 ,1:$P(IBEN D,".")+.9)
  811   "RTN","IBC NBOA",37,0 )
  812    ;
  813   "RTN","IBC NBOA",38,0 )
  814    S IBXST=" " F  S IBX ST=$O(^IBA (355.33,"A FST",IBXST )) Q:IBXST =""  D   Q :IBQUIT
  815   "RTN","IBC NBOA",39,0 )
  816    . S IBXDT =+IBBEG F   S IBXDT=$ O(^IBA(355 .33,"AFST" ,IBXST,IBX DT)) Q:'IB XDT!(IBXDT >IBEND)  D   S IBQUIT =$$STOP Q: IBQUIT
  817   "RTN","IBC NBOA",40,0 )
  818    .. S IBBU FDA=0 F  S  IBBUFDA=$ O(^IBA(355 .33,"AFST" ,IBXST,IBX DT,IBBUFDA )) Q:'IBBU FDA  D
  819   "RTN","IBC NBOA",41,0 )
  820    ... ;
  821   "RTN","IBC NBOA",42,0 )
  822    ... S IBB 0=$G(^IBA( 355.33,IBB UFDA,0)),I BSTAT=$P(I BB0,U,4),I BVER=$P(IB B0,U,10)
  823   "RTN","IBC NBOA",43,0 )
  824    ... ;
  825   "RTN","IBC NBOA",44,0 )
  826    ... ; ent ered
  827   "RTN","IBC NBOA",45,0 )
  828    ... I IBX ST="E" S I BDATE=+IBB 0 I +IBDAT E,IBDATE>I BBEG,IBDAT E<IBEND D
  829   "RTN","IBC NBOA",46,0 )
  830    .... S IB DT2=+$P(IB B0,U,10) I  'IBDT2 S  IBDT2=+$P( IBB0,U,5)  I 'IBDT2 S  IBDT2=$$N OW^XLFDT
  831   "RTN","IBC NBOA",47,0 )
  832    .... S IB TIME=+$$FM DIFF^XLFDT (IBDT2,IBD ATE,2),IBS TAT="ENTER ED",IBS3=1
  833   "RTN","IBC NBOA",48,0 )
  834    .... I +$ G(IBMONTH)  D SET(IBS TAT,$E(IBD ATE,1,5),I BS3,IBTIME ,IBB0)
  835   "RTN","IBC NBOA",49,0 )
  836    .... D SE T(IBSTAT,9 9999,IBS3, IBTIME,IBB 0)
  837   "RTN","IBC NBOA",50,0 )
  838    ... ;
  839   "RTN","IBC NBOA",51,0 )
  840    ... ; ver ified
  841   "RTN","IBC NBOA",52,0 )
  842    ... I IBX ST="V" S I BDATE=+$P( IBB0,U,10)  I +IBDATE ,IBDATE>IB BEG,IBDATE <IBEND D
  843   "RTN","IBC NBOA",53,0 )
  844    .... S IB TIME=+$$FM DIFF^XLFDT (IBDATE,+I BB0,2),IBS TAT="VERIF IED",IBS3= 2
  845   "RTN","IBC NBOA",54,0 )
  846    .... I +$ G(IBMONTH)  D SET(IBS TAT,$E(IBD ATE,1,5),I BS3,IBTIME ,IBB0)
  847   "RTN","IBC NBOA",55,0 )
  848    .... D SE T(IBSTAT,9 9999,IBS3, IBTIME,IBB 0)
  849   "RTN","IBC NBOA",56,0 )
  850    ... ;
  851   "RTN","IBC NBOA",57,0 )
  852    ... ; pro cessed
  853   "RTN","IBC NBOA",58,0 )
  854    ... I IBX ST="A"!(IB XST="R") S  IBDATE=+$ P(IBB0,U,5 ) I +IBDAT E,IBDATE>I BBEG,IBDAT E<IBEND D
  855   "RTN","IBC NBOA",59,0 )
  856    .... S IB DT2=+IBVER  I 'IBVER  S IBDT2=+I BB0
  857   "RTN","IBC NBOA",60,0 )
  858    .... S IB TIME=+$$FM DIFF^XLFDT (IBDATE,+I BDT2,2),IB STAT="UNKN OWN",IBS3= 6
  859   "RTN","IBC NBOA",61,0 )
  860    .... I $P (IBB0,U,4) ="A" S IBS 3=3,IBSTAT ="ACCEPTED " I 'IBVER  S IBS3=4, IBSTAT=IBS TAT_" (&V) "
  861   "RTN","IBC NBOA",62,0 )
  862    .... I $P (IBB0,U,4) ="R" S IBS 3=5,IBSTAT ="REJECTED " I +IBVER  S IBS3=6, IBSTAT=IBS TAT_" (V)"
  863   "RTN","IBC NBOA",63,0 )
  864    .... I +$ G(IBMONTH)  D SET(IBS TAT,$E(IBD ATE,1,5),I BS3,IBTIME ,IBB0)
  865   "RTN","IBC NBOA",64,0 )
  866    .... D SE T(IBSTAT,9 9999,IBS3, IBTIME,IBB 0)
  867   "RTN","IBC NBOA",65,0 )
  868    ;
  869   "RTN","IBC NBOA",66,0 )
  870    Q
  871   "RTN","IBC NBOA",67,0 )
  872    ;
  873   "RTN","IBC NBOA",68,0 )
  874   SET(STAT,S 1,S3,TIME, IBB0) ;
  875   "RTN","IBC NBOA",69,0 )
  876    D TMP("IB CNBOA",S1, 1,S3,TIME, STAT)
  877   "RTN","IBC NBOA",70,0 )
  878    I S3<3 D  TMP("IBCNB OA",S1,2,1 ,TIME,"NOT  PROCESSED ")
  879   "RTN","IBC NBOA",71,0 )
  880    I S3>2 D  TMP("IBCNB OA",S1,2,2 ,TIME,"PRO CESSED")
  881   "RTN","IBC NBOA",72,0 )
  882    D TMP("IB CNBOA",S1, 2,9,TIME," TOTAL")
  883   "RTN","IBC NBOA",73,0 )
  884    ;
  885   "RTN","IBC NBOA",74,0 )
  886    Q:$E(STAT )'="A"
  887   "RTN","IBC NBOA",75,0 )
  888    ;
  889   "RTN","IBC NBOA",76,0 )
  890    D TMP1("I BCNBOAC",S 1,+$P(IBB0 ,U,7),+$P( IBB0,U,8), +$P(IBB0,U ,9))
  891   "RTN","IBC NBOA",77,0 )
  892    Q
  893   "RTN","IBC NBOA",78,0 )
  894    ;
  895   "RTN","IBC NBOA",79,0 )
  896   TMP(XREF,S 1,S2,S3,TI ME,NAME) ;
  897   "RTN","IBC NBOA",80,0 )
  898    S ^TMP($J ,XREF,S1,S 2,S3)=NAME
  899   "RTN","IBC NBOA",81,0 )
  900    S ^TMP($J ,XREF,S1,S 2,S3,"CNT" )=$G(^TMP( $J,XREF,S1 ,S2,S3,"CN T"))+1
  901   "RTN","IBC NBOA",82,0 )
  902    S ^TMP($J ,XREF,S1,S 2,S3,"TM") =$G(^TMP($ J,XREF,S1, S2,S3,"TM" ))+TIME
  903   "RTN","IBC NBOA",83,0 )
  904    I '$G(^TM P($J,XREF, S1,S2,S3," HG"))!($G( ^TMP($J,XR EF,S1,S2,S 3,"HG"))<T IME) S ^TM P($J,XREF, S1,S2,S3," HG")=TIME
  905   "RTN","IBC NBOA",84,0 )
  906    I '$G(^TM P($J,XREF, S1,S2,S3," LS"))!($G( ^TMP($J,XR EF,S1,S2,S 3,"LS"))>T IME) S ^TM P($J,XREF, S1,S2,S3," LS")=TIME
  907   "RTN","IBC NBOA",85,0 )
  908    Q
  909   "RTN","IBC NBOA",86,0 )
  910    ;
  911   "RTN","IBC NBOA",87,0 )
  912   TMP1(XREF, S1,IC,GC,P C) ;
  913   "RTN","IBC NBOA",88,0 )
  914    I +IC S ^ TMP($J,XRE F,S1,"I")= $G(^TMP($J ,XREF,S1," I"))+1
  915   "RTN","IBC NBOA",89,0 )
  916    I +GC S ^ TMP($J,XRE F,S1,"G")= $G(^TMP($J ,XREF,S1," G"))+1
  917   "RTN","IBC NBOA",90,0 )
  918    I +PC S ^ TMP($J,XRE F,S1,"P")= $G(^TMP($J ,XREF,S1," P"))+1
  919   "RTN","IBC NBOA",91,0 )
  920    S ^TMP($J ,XREF,S1," CNT")=$G(^ TMP($J,XRE F,S1,"CNT" ))+1
  921   "RTN","IBC NBOA",92,0 )
  922    Q
  923   "RTN","IBC NBOA",93,0 )
  924    ;
  925   "RTN","IBC NBOA",94,0 )
  926    ;
  927   "RTN","IBC NBOA",95,0 )
  928    ;
  929   "RTN","IBC NBOA",96,0 )
  930   PRINT(IBBE G,IBEND,IB OUT) ;
  931   "RTN","IBC NBOA",97,0 )
  932    N IBXREF, IBLABLE,IB S1,IBS2,IB S3,IBINS,I BGRP,IBPOL ,IBCNT,IBI P,IBGP,IBP P,IBRDT,IB PGN,IBRANG E,IBLN,IBI
  933   "RTN","IBC NBOA",98,0 )
  934    ;
  935   "RTN","IBC NBOA",99,0 )
  936    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  937   "RTN","IBC NBOA",100, 0)
  938    S IBRANGE =$$FMTE^XL FDT(+IBBEG )_" - "_$$ FMTE^XLFDT (IBEND)
  939   "RTN","IBC NBOA",101, 0)
  940    S IBRDT=$ $FMTE^XLFD T($J($$NOW ^XLFDT,0,4 ),2),IBRDT =$TR(IBRDT ,"@"," "), (IBLN,IBPG N)=0
  941   "RTN","IBC NBOA",102, 0)
  942    ;
  943   "RTN","IBC NBOA",103, 0)
  944    ; Excel o utput
  945   "RTN","IBC NBOA",104, 0)
  946    I IBOUT=" E" D PHDL  D  S IBI=$ $PAUSE Q
  947   "RTN","IBC NBOA",105, 0)
  948    . S IBXRE F="IBCNBOA ",IBS1=""  F  S IBS1= $O(^TMP($J ,IBXREF,IB S1)) Q:IBS 1=""  D
  949   "RTN","IBC NBOA",106, 0)
  950    .. S IBLA BLE=$S(IBS 1=99999:"T OTALS",($E (IBBEG,1,5 )<IBS1)&($ E(IBEND,1, 5)>IBS1):$ $FMTE^XLFD T(IBS1_"00 "),1:"")
  951   "RTN","IBC NBOA",107, 0)
  952    .. I IBLA BLE="" S I BLABLE=$$F MTE^XLFDT( $S($E(IBBE G,1,5)<IBS 1:IBS1_"01 ",1:IBBEG) )_" - "_$$ FMTE^XLFDT ($S($E(IBE ND,1,5)>IB S1:$$SCH^X LFDT("1M(L )",IBS1_11 ),1:IBEND) )
  953   "RTN","IBC NBOA",108, 0)
  954    .. S IBS2 =0 F  S IB S2=$O(^TMP ($J,IBXREF ,IBS1,IBS2 )) Q:IBS2= ""  D
  955   "RTN","IBC NBOA",109, 0)
  956    ... S IBS 3="" F  S  IBS3=$O(^T MP($J,IBXR EF,IBS1,IB S2,IBS3))  Q:'IBS3  D  PRTLN
  957   "RTN","IBC NBOA",110, 0)
  958    .. ;
  959   "RTN","IBC NBOA",111, 0)
  960    .. S IBIN S=+$G(^TMP ($J,"IBCNB OAC",IBS1, "I")),IBGR P=+$G(^TMP ($J,"IBCNB OAC",IBS1, "G"))
  961   "RTN","IBC NBOA",112, 0)
  962    .. S IBPO L=+$G(^TMP ($J,"IBCNB OAC",IBS1, "P")),IBCN T=+$G(^TMP ($J,"IBCNB OAC",IBS1, "CNT"))
  963   "RTN","IBC NBOA",113, 0)
  964    .. S (IBI P,IBGP,IBP P)=0 I IBC NT'=0 S IB IP=((IBINS /IBCNT)*10 0)\1,IBGP= ((IBGRP/IB CNT)*100)\ 1,IBPP=((I BPOL/IBCNT )*100)\1
  965   "RTN","IBC NBOA",114, 0)
  966    .. W U_IB INS_U_IBIP _"%"_U_IBG RP_U_IBGP_ "%"_U_IBPO L_U_IBPP_" %"
  967   "RTN","IBC NBOA",115, 0)
  968    ;
  969   "RTN","IBC NBOA",116, 0)
  970    D HDR
  971   "RTN","IBC NBOA",117, 0)
  972    ;
  973   "RTN","IBC NBOA",118, 0)
  974    S IBXREF= "IBCNBOA", IBS1="" F   S IBS1=$O (^TMP($J,I BXREF,IBS1 )) Q:IBS1= ""  D:IBLN >(IOSL-17)  HDR Q:IBQ UIT  D  S  IBLN=IBLN+ 7
  975   "RTN","IBC NBOA",119, 0)
  976    . S IBLAB LE=$S(IBS1 =99999:"TO TALS",($E( IBBEG,1,5) <IBS1)&($E (IBEND,1,5 )>IBS1):$$ FMTE^XLFDT (IBS1_"00" ),1:"")
  977   "RTN","IBC NBOA",120, 0)
  978    . I IBLAB LE="" S IB LABLE=$$FM TE^XLFDT($ S($E(IBBEG ,1,5)<IBS1 :IBS1_"01" ,1:IBBEG)) _" - "_$$F MTE^XLFDT( $S($E(IBEN D,1,5)>IBS 1:$$SCH^XL FDT("1M(L) ",IBS1_11) ,1:IBEND))
  979   "RTN","IBC NBOA",121, 0)
  980    . W !,?(4 0-($L(IBLA BLE)/2)),I BLABLE,!
  981   "RTN","IBC NBOA",122, 0)
  982    . W !,?43 ,"AVERAGE" ,?56,"LONG EST",?68," SHORTEST"
  983   "RTN","IBC NBOA",123, 0)
  984    . W !,"ST ATUS",?22, "COUNT",?3 0,"PERCENT ",?43,"# D AYS",?56," # DAYS",?6 8,"# DAYS"
  985   "RTN","IBC NBOA",124, 0)
  986    . ;
  987   "RTN","IBC NBOA",125, 0)
  988    . S IBS2= 0 F  S IBS 2=$O(^TMP( $J,IBXREF, IBS1,IBS2) ) Q:IBS2=" "  D  S IB LN=IBLN+1
  989   "RTN","IBC NBOA",126, 0)
  990    .. W !,"- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ------"
  991   "RTN","IBC NBOA",127, 0)
  992    .. S IBS3 ="" F  S I BS3=$O(^TM P($J,IBXRE F,IBS1,IBS 2,IBS3)) Q :'IBS3  D  PRTLN  S I BLN=IBLN+1
  993   "RTN","IBC NBOA",128, 0)
  994    . ;
  995   "RTN","IBC NBOA",129, 0)
  996    . S IBINS =+$G(^TMP( $J,"IBCNBO AC",IBS1," I")),IBGRP =+$G(^TMP( $J,"IBCNBO AC",IBS1," G"))
  997   "RTN","IBC NBOA",130, 0)
  998    . S IBPOL =+$G(^TMP( $J,"IBCNBO AC",IBS1," P")),IBCNT =+$G(^TMP( $J,"IBCNBO AC",IBS1," CNT"))
  999   "RTN","IBC NBOA",131, 0)
  1000    . S (IBIP ,IBGP,IBPP )=0 I IBCN T'=0 S IBI P=((IBINS/ IBCNT)*100 )\1,IBGP=( (IBGRP/IBC NT)*100)\1 ,IBPP=((IB POL/IBCNT) *100)\1
  1001   "RTN","IBC NBOA",132, 0)
  1002    . W !!,?2 ,IBINS," N ew Compan" ,$S(IBINS= 1:"y",1:"i es")," (", IBIP,"%),  "
  1003   "RTN","IBC NBOA",133, 0)
  1004    . W IBGRP ," New Gro up/Plan",$ S(IBGRP=1: "",1:"s"), " (",IBGP, "%), "
  1005   "RTN","IBC NBOA",134, 0)
  1006    . W IBPOL ," New Pat ient Polic ",$S(IBPOL =1:"y",1:" ies")," (" ,IBPP,"%)" ,!
  1007   "RTN","IBC NBOA",135, 0)
  1008    ;
  1009   "RTN","IBC NBOA",136, 0)
  1010    I 'IBQUIT  S IBI=$$P AUSE
  1011   "RTN","IBC NBOA",137, 0)
  1012    Q
  1013   "RTN","IBC NBOA",138, 0)
  1014    ;
  1015   "RTN","IBC NBOA",139, 0)
  1016   PRTLN ;
  1017   "RTN","IBC NBOA",140, 0)
  1018    N IBSTX,I BCNT,IBTM, IBHG,IBLS, IBTCNT
  1019   "RTN","IBC NBOA",141, 0)
  1020    ;
  1021   "RTN","IBC NBOA",142, 0)
  1022    S IBSTX=$ G(^TMP($J, IBXREF,IBS 1,IBS2,IBS 3))
  1023   "RTN","IBC NBOA",143, 0)
  1024    S IBCNT=$ G(^TMP($J, IBXREF,IBS 1,IBS2,IBS 3,"CNT"))  Q:'IBCNT
  1025   "RTN","IBC NBOA",144, 0)
  1026    S IBTM=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"TM"))
  1027   "RTN","IBC NBOA",145, 0)
  1028    S IBHG=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"HG"))
  1029   "RTN","IBC NBOA",146, 0)
  1030    S IBLS=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"LS"))
  1031   "RTN","IBC NBOA",147, 0)
  1032    S IBTCNT= $G(^TMP($J ,IBXREF,IB S1,2,9,"CN T")) Q:'IB TCNT
  1033   "RTN","IBC NBOA",148, 0)
  1034    ;
  1035   "RTN","IBC NBOA",149, 0)
  1036    ; Excel o utput
  1037   "RTN","IBC NBOA",150, 0)
  1038    I IBOUT=" E" W !,IBL ABLE_U_IBS TX_U_$FN(I BCNT,",")_ U_((IBCNT/ IBTCNT)*10 0)_"%"_U_$ $STD((IBTM /IBCNT))_U _$$STD(IBH G)_U_$$STD (IBLS) Q
  1039   "RTN","IBC NBOA",151, 0)
  1040    ;
  1041   "RTN","IBC NBOA",152, 0)
  1042    ; Report  output
  1043   "RTN","IBC NBOA",153, 0)
  1044    W !,IBSTX ,?20,$J($F N(IBCNT,", "),7),?30, $J(((IBCNT /IBTCNT)*1 00),6,1)," %",?43,$J( $$STD((IBT M/IBCNT)), 6,1),?56,$ J($$STD(IB HG),6,1),? 68,$J($$ST D(IBLS),6, 1)
  1045   "RTN","IBC NBOA",154, 0)
  1046    Q
  1047   "RTN","IBC NBOA",155, 0)
  1048    ;
  1049   "RTN","IBC NBOA",156, 0)
  1050   STD(SEC) ;  convert s econds to  days
  1051   "RTN","IBC NBOA",157, 0)
  1052    N IBX,IBD ,IBS,IBH,D AYS S DAYS ="" G:'$G( SEC) STDQ
  1053   "RTN","IBC NBOA",158, 0)
  1054    S IBD=(SE C/86400),I BD=+$P(IBD ,".")
  1055   "RTN","IBC NBOA",159, 0)
  1056    S IBS=SEC -(IBD*8640 0)
  1057   "RTN","IBC NBOA",160, 0)
  1058    S IBH=((I BS/60)/60) ,IBH=+$J(I BH,0,2)
  1059   "RTN","IBC NBOA",161, 0)
  1060    S DAYS=IB D+(IBH/24)
  1061   "RTN","IBC NBOA",162, 0)
  1062   STDQ Q DAY S
  1063   "RTN","IBC NBOA",163, 0)
  1064    ;
  1065   "RTN","IBC NBOA",164, 0)
  1066   HDR ;print  the repor t header
  1067   "RTN","IBC NBOA",165, 0)
  1068    S IBQUIT= $$STOP Q:I BQUIT
  1069   "RTN","IBC NBOA",166, 0)
  1070    I IBPGN>0  S IBQUIT= $$PAUSE Q: IBQUIT
  1071   "RTN","IBC NBOA",167, 0)
  1072    S IBPGN=I BPGN+1,IBL N=4 I IBPG N>1!($E(IO ST,1,2)["C -") W @IOF
  1073   "RTN","IBC NBOA",168, 0)
  1074    W !,"INSU RANCE BUFF ER ACTIVIT Y REPORT    ",IBRANGE ," "
  1075   "RTN","IBC NBOA",169, 0)
  1076    W ?(IOM-2 2),IBRDT,? (IOM-7),"  PAGE ",IBP GN,!
  1077   "RTN","IBC NBOA",170, 0)
  1078    S IBI="", $P(IBI,"-" ,IOM+1)=""  W IBI,!
  1079   "RTN","IBC NBOA",171, 0)
  1080    Q
  1081   "RTN","IBC NBOA",172, 0)
  1082    ;
  1083   "RTN","IBC NBOA",173, 0)
  1084   PHDL ; - P rint the h eader line  for the E xcel sprea dsheet
  1085   "RTN","IBC NBOA",174, 0)
  1086    N X
  1087   "RTN","IBC NBOA",175, 0)
  1088    ; ; IB*60 2/HN ; Add  report he aders to E xcel Sprea dsheets 
  1089   "RTN","IBC NBOA",176, 0)
  1090    W !,"INSU RANCE BUFF ER ACTIVIT Y REPORT^" ,IBRANGE_" ^"_$$FMTE^ XLFDT($$NO W^XLFDT,1) ,!
  1091   "RTN","IBC NBOA",177, 0)
  1092    ; IB*602/ HN end 
  1093   "RTN","IBC NBOA",178, 0)
  1094    S X="MONT H^STATUS^C OUNT^PERCE NT^AVERAGE  # DAYS^LO NGEST # DA YS^SHORTES T # DAYS^N ew Compani es^% New C ompanies^N ew Group/P lans^% New  Group/Pla ns^New Pat ient Polic ies^% New  Patient Po licies"
  1095   "RTN","IBC NBOA",179, 0)
  1096    W X
  1097   "RTN","IBC NBOA",180, 0)
  1098    K X
  1099   "RTN","IBC NBOA",181, 0)
  1100    Q
  1101   "RTN","IBC NBOA",182, 0)
  1102    ;
  1103   "RTN","IBC NBOA",183, 0)
  1104   PAUSE() ;p ause at en d of scree n if being  displayed  on a term inal
  1105   "RTN","IBC NBOA",184, 0)
  1106    N IBX,DIR ,DIRUT,X,Y  S IBX=0
  1107   "RTN","IBC NBOA",185, 0)
  1108    I $E(IOST ,1,2)["C-"  W !! S DI R(0)="E" D  ^DIR K DI R I $D(DUO UT)!($D(DI RUT)) S IB X=1
  1109   "RTN","IBC NBOA",186, 0)
  1110    Q IBX
  1111   "RTN","IBC NBOA",187, 0)
  1112    ;
  1113   "RTN","IBC NBOA",188, 0)
  1114   STOP() ;de termine if  user has  requested  the queued  report to  stop
  1115   "RTN","IBC NBOA",189, 0)
  1116    I $D(ZTQU EUED),$$S^ %ZTLOAD S  ZTSTOP=1 K  ZTREQ I + $G(IBPGN)  W !,"***TA SK STOPPED  BY USER** *"
  1117   "RTN","IBC NBOA",190, 0)
  1118    Q +$G(ZTS TOP)
  1119   "RTN","IBC NBOA",191, 0)
  1120    ;
  1121   "RTN","IBC NBOA",192, 0)
  1122   IBAR(IBBEG ,IBEND) ;E ntry point  for Vista  IB AR dat a to ARC
  1123   "RTN","IBC NBOA",193, 0)
  1124    ;patch 30 5 - called  by IBRFN4
  1125   "RTN","IBC NBOA",194, 0)
  1126    N IBMONTH ,IBARFLAG, IBARDATA,I BTM,IBCNT
  1127   "RTN","IBC NBOA",195, 0)
  1128    S IBMONTH =0,IBARFLA G=1 K ^TMP ($J)
  1129   "RTN","IBC NBOA",196, 0)
  1130    D RPT
  1131   "RTN","IBC NBOA",197, 0)
  1132    S IBTM=$G (^TMP($J," IBCNBOA",9 9999,2,2," TM"))
  1133   "RTN","IBC NBOA",198, 0)
  1134    S IBCNT=$ G(^TMP($J, "IBCNBOA", 99999,2,2, "CNT"))
  1135   "RTN","IBC NBOA",199, 0)
  1136    I 'IBCNT  S IBARDATA =0 G IBARQ
  1137   "RTN","IBC NBOA",200, 0)
  1138    S IBARDAT A=$FN($$ST D((IBTM/IB CNT)),"",1 )
  1139   "RTN","IBC NBOA",201, 0)
  1140    K ^TMP($J )
  1141   "RTN","IBC NBOA",202, 0)
  1142   IBARQ Q IB ARDATA
  1143   "RTN","IBC NBOE")
  1144   0^15^B1127 16320^B109 925669
  1145   "RTN","IBC NBOE",1,0)
  1146   IBCNBOE ;A LB/ARH - I ns Buffer:  Employee  Report ;1  Jun 97
  1147   "RTN","IBC NBOE",2,0)
  1148    ;;2.0;INT EGRATED BI LLING;**82 ,528,602** ;21-MAR-94 ;Build 22
  1149   "RTN","IBC NBOE",3,0)
  1150    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1151   "RTN","IBC NBOE",4,0)
  1152    ;
  1153   "RTN","IBC NBOE",5,0)
  1154   EN ;get pa rameters t hen run th e report
  1155   "RTN","IBC NBOE",6,0)
  1156    N IBX S I BX=$$WR Q: 'IBX  I IB X=1 G ^IBC NBOF ; WHI CH REPORT?   entered  or process ed
  1157   "RTN","IBC NBOE",7,0)
  1158    ;
  1159   "RTN","IBC NBOE",8,0)
  1160    ;
  1161   "RTN","IBC NBOE",9,0)
  1162    K ^TMP($J ) D HOME^% ZIS S IBHD R="INSURAN CE BUFFER  INSURANCE  EMPLOYEE R EPORT" W @ IOF,!!,?17 ,IBHDR
  1163   "RTN","IBC NBOE",10,0 )
  1164    W !!,"Thi s report p roduces co unts and t ime statis tics for I nsurance E mployees t hat",!,"ha ve either  Verified o r Processe d (Accept/ Reject) an  Insurance  Buffer en try.",!!
  1165   "RTN","IBC NBOE",11,0 )
  1166    ;
  1167   "RTN","IBC NBOE",12,0 )
  1168    S IBEMPL= $$EMPL G:I BEMPL="" E XIT  W !!
  1169   "RTN","IBC NBOE",13,0 )
  1170    ;
  1171   "RTN","IBC NBOE",14,0 )
  1172    I +IBEMPL  S IBEMPL= $$SELEMPL( "Verifies  or Process es") G:IBE MPL="" EXI T  W !!
  1173   "RTN","IBC NBOE",15,0 )
  1174    ;
  1175   "RTN","IBC NBOE",16,0 )
  1176    S IBBEG=$ $DATES("Be ginning")  G:'IBBEG E XIT
  1177   "RTN","IBC NBOE",17,0 )
  1178    S IBEND=$ $DATES("En ding",IBBE G) G:'IBEN D EXIT  W  !!
  1179   "RTN","IBC NBOE",18,0 )
  1180    ;
  1181   "RTN","IBC NBOE",19,0 )
  1182    S IBMONTH =$$MONTH G :IBMONTH=" " EXIT  W  !!
  1183   "RTN","IBC NBOE",20,0 )
  1184    ;
  1185   "RTN","IBC NBOE",21,0 )
  1186    S IBOUT=$ $OUT G:IBO UT="" EXIT
  1187   "RTN","IBC NBOE",22,0 )
  1188    ;
  1189   "RTN","IBC NBOE",23,0 )
  1190   DEV ;get t he device
  1191   "RTN","IBC NBOE",24,0 )
  1192    S %ZIS="Q M",%ZIS("A ")="OUTPUT  DEVICE: "  D ^%ZIS G :POP EXIT
  1193   "RTN","IBC NBOE",25,0 )
  1194    I $D(IO(" Q")) S ZTR TN="RPT^IB CNBOE",ZTD ESC=IBHDR, ZTSAVE("IB *")="" D ^ %ZTLOAD K  IO("Q") G  EXIT
  1195   "RTN","IBC NBOE",26,0 )
  1196    U IO
  1197   "RTN","IBC NBOE",27,0 )
  1198    ;
  1199   "RTN","IBC NBOE",28,0 )
  1200   RPT ; run  report
  1201   "RTN","IBC NBOE",29,0 )
  1202    S IBQUIT= 0
  1203   "RTN","IBC NBOE",30,0 )
  1204    ;
  1205   "RTN","IBC NBOE",31,0 )
  1206    D SEARCH( IBBEG,IBEN D,IBMONTH, IBEMPL) G: IBQUIT EXI T
  1207   "RTN","IBC NBOE",32,0 )
  1208    D PRINT(I BBEG,IBEND ,IBEMPL,IB OUT)
  1209   "RTN","IBC NBOE",33,0 )
  1210    ;
  1211   "RTN","IBC NBOE",34,0 )
  1212   EXIT K ^TM P($J),IBHD R,IBBEG,IB END,IBMONT H,IBOUT,IB QUIT,IBEMP L
  1213   "RTN","IBC NBOE",35,0 )
  1214    Q:$D(ZTQU EUED)
  1215   "RTN","IBC NBOE",36,0 )
  1216    D ^%ZISC
  1217   "RTN","IBC NBOE",37,0 )
  1218    Q
  1219   "RTN","IBC NBOE",38,0 )
  1220    ;
  1221   "RTN","IBC NBOE",39,0 )
  1222   SEARCH(IBB EG,IBEND,I BMONTH,IBE MPL) ; sea rch/sort s tatistics  for activi ty report
  1223   "RTN","IBC NBOE",40,0 )
  1224    N IBXST,I BXDT,IBBUF DA,IBB0,IB DATE,IBEMP ,IBTIME,IB STAT,IBDT2 ,IBVER,IBS 3 S IBQUIT =""
  1225   "RTN","IBC NBOE",41,0 )
  1226    S IBBEG=$ G(IBBEG)-. 01,IBEND=$ S('$G(IBEN D):9999999 ,1:$P(IBEN D,".")+.9)
  1227   "RTN","IBC NBOE",42,0 )
  1228    ;
  1229   "RTN","IBC NBOE",43,0 )
  1230    F IBXST=" A","R","V"   D  Q:IBQ UIT
  1231   "RTN","IBC NBOE",44,0 )
  1232    . S IBXDT =IBBEG F   S IBXDT=$O (^IBA(355. 33,"AFST", IBXST,IBXD T)) Q:'IBX DT!(IBXDT> IBEND)  D   S IBQUIT= $$STOP Q:I BQUIT
  1233   "RTN","IBC NBOE",45,0 )
  1234    .. S IBBU FDA=0 F  S  IBBUFDA=$ O(^IBA(355 .33,"AFST" ,IBXST,IBX DT,IBBUFDA )) Q:'IBBU FDA  D
  1235   "RTN","IBC NBOE",46,0 )
  1236    ... ;
  1237   "RTN","IBC NBOE",47,0 )
  1238    ... S IBB 0=$G(^IBA( 355.33,IBB UFDA,0))
  1239   "RTN","IBC NBOE",48,0 )
  1240    ... ;
  1241   "RTN","IBC NBOE",49,0 )
  1242    ... ; ver ified
  1243   "RTN","IBC NBOE",50,0 )
  1244    ... I IBX ST="V" S I BDATE=+$P( IBB0,U,10)  I +IBDATE ,IBDATE>IB BEG,IBDATE <IBEND D
  1245   "RTN","IBC NBOE",51,0 )
  1246    .... S IB EMP=+$P(IB B0,U,11) I  +IBEMPL,I BEMPL'=IBE MP Q
  1247   "RTN","IBC NBOE",52,0 )
  1248    .... S IB TIME=$$FMD IFF^XLFDT( IBDATE,+IB B0,2),IBST AT="VERIFI ED",IBS3=1
  1249   "RTN","IBC NBOE",53,0 )
  1250    .... D SE T(IBSTAT,I BEMP,$E(IB DATE,1,5), IBS3,IBTIM E,IBB0,$G( IBMONTH))
  1251   "RTN","IBC NBOE",54,0 )
  1252    ... ;
  1253   "RTN","IBC NBOE",55,0 )
  1254    ... ; pro cessed
  1255   "RTN","IBC NBOE",56,0 )
  1256    ... I IBX ST="A"!(IB XST="R") S  IBDATE=+$ P(IBB0,U,5 ) I +IBDAT E,IBDATE>I BBEG,IBDAT E<IBEND D
  1257   "RTN","IBC NBOE",57,0 )
  1258    .... S IB EMP=+$P(IB B0,U,6) I  +IBEMPL,IB EMPL'=IBEM P Q
  1259   "RTN","IBC NBOE",58,0 )
  1260    .... S IB VER=$P(IBB 0,U,10),IB STAT="UNKN OWN",IBS3= 6
  1261   "RTN","IBC NBOE",59,0 )
  1262    .... S IB DT2=$S(+IB VER:+IBVER ,1:+IBB0), IBTIME=$$F MDIFF^XLFD T(IBDATE,+ IBDT2,2)
  1263   "RTN","IBC NBOE",60,0 )
  1264    .... ;
  1265   "RTN","IBC NBOE",61,0 )
  1266    .... I $P (IBB0,U,4) ="A" S IBS 3=2,IBSTAT ="ACCEPTED " I 'IBVER  S IBS3=3, IBSTAT=IBS TAT_" (&V) "
  1267   "RTN","IBC NBOE",62,0 )
  1268    .... I $P (IBB0,U,4) ="R" S IBS 3=4,IBSTAT ="REJECTED " I +IBVER  S IBS3=5, IBSTAT=IBS TAT_" (V)"
  1269   "RTN","IBC NBOE",63,0 )
  1270    .... D SE T(IBSTAT,I BEMP,$E(IB DATE,1,5), IBS3,IBTIM E,IBB0,$G( IBMONTH))
  1271   "RTN","IBC NBOE",64,0 )
  1272    ;
  1273   "RTN","IBC NBOE",65,0 )
  1274    Q
  1275   "RTN","IBC NBOE",66,0 )
  1276    ;
  1277   "RTN","IBC NBOE",67,0 )
  1278   SET(STAT,I BEMP,IBDAT E,S3,TIME, IBB0,IBMON TH) ;
  1279   "RTN","IBC NBOE",68,0 )
  1280    I +$G(IBM ONTH) D SE T1(IBSTAT, IBEMP,$E(I BDATE,1,5) ,S3,IBTIME ,IBB0)
  1281   "RTN","IBC NBOE",69,0 )
  1282    D SET1(IB STAT,IBEMP ,99999,S3, IBTIME,IBB 0)
  1283   "RTN","IBC NBOE",70,0 )
  1284    D SET1(IB STAT,"~",9 9999,S3,IB TIME,IBB0)
  1285   "RTN","IBC NBOE",71,0 )
  1286    Q
  1287   "RTN","IBC NBOE",72,0 )
  1288    ;
  1289   "RTN","IBC NBOE",73,0 )
  1290   SET1(STAT, S1,S2,S3,T IME,IBB0)  ;
  1291   "RTN","IBC NBOE",74,0 )
  1292    ;
  1293   "RTN","IBC NBOE",75,0 )
  1294    D TMP("IB CNBOE",S1, S2,S3,TIME ,STAT)
  1295   "RTN","IBC NBOE",76,0 )
  1296    D TMP("IB CNBOE",S1, S2,9,TIME, "TOTAL")
  1297   "RTN","IBC NBOE",77,0 )
  1298    ;
  1299   "RTN","IBC NBOE",78,0 )
  1300    Q:$E(STAT )'="A"
  1301   "RTN","IBC NBOE",79,0 )
  1302    ;
  1303   "RTN","IBC NBOE",80,0 )
  1304    D TMP1("I BCNBOEC",S 1,S2,+$P(I BB0,U,7),+ $P(IBB0,U, 8),+$P(IBB 0,U,9))
  1305   "RTN","IBC NBOE",81,0 )
  1306    Q
  1307   "RTN","IBC NBOE",82,0 )
  1308    ;
  1309   "RTN","IBC NBOE",83,0 )
  1310   TMP(XREF,S 1,S2,S3,TI ME,NAME) ;
  1311   "RTN","IBC NBOE",84,0 )
  1312    S ^TMP($J ,XREF,S1,S 2,S3)=NAME
  1313   "RTN","IBC NBOE",85,0 )
  1314    S ^TMP($J ,XREF,S1,S 2,S3,"CNT" )=$G(^TMP( $J,XREF,S1 ,S2,S3,"CN T"))+1
  1315   "RTN","IBC NBOE",86,0 )
  1316    S ^TMP($J ,XREF,S1,S 2,S3,"TM") =$G(^TMP($ J,XREF,S1, S2,S3,"TM" ))+TIME
  1317   "RTN","IBC NBOE",87,0 )
  1318    I '$G(^TM P($J,XREF, S1,S2,S3," HG"))!($G( ^TMP($J,XR EF,S1,S2,S 3,"HG"))<T IME) S ^TM P($J,XREF, S1,S2,S3," HG")=TIME
  1319   "RTN","IBC NBOE",88,0 )
  1320    I '$G(^TM P($J,XREF, S1,S2,S3," LS"))!($G( ^TMP($J,XR EF,S1,S2,S 3,"LS"))>T IME) S ^TM P($J,XREF, S1,S2,S3," LS")=TIME
  1321   "RTN","IBC NBOE",89,0 )
  1322    Q
  1323   "RTN","IBC NBOE",90,0 )
  1324    ;
  1325   "RTN","IBC NBOE",91,0 )
  1326   TMP1(XREF, S1,S2,IC,G C,PC) ;
  1327   "RTN","IBC NBOE",92,0 )
  1328    I +IC S ^ TMP($J,XRE F,S1,S2,"I ")=$G(^TMP ($J,XREF,S 1,S2,"I")) +1
  1329   "RTN","IBC NBOE",93,0 )
  1330    I +GC S ^ TMP($J,XRE F,S1,S2,"G ")=$G(^TMP ($J,XREF,S 1,S2,"G")) +1
  1331   "RTN","IBC NBOE",94,0 )
  1332    I +PC S ^ TMP($J,XRE F,S1,S2,"P ")=$G(^TMP ($J,XREF,S 1,S2,"P")) +1
  1333   "RTN","IBC NBOE",95,0 )
  1334    S ^TMP($J ,XREF,S1,S 2,"CNT")=$ G(^TMP($J, XREF,S1,S2 ,"CNT"))+1
  1335   "RTN","IBC NBOE",96,0 )
  1336    Q
  1337   "RTN","IBC NBOE",97,0 )
  1338    ;
  1339   "RTN","IBC NBOE",98,0 )
  1340    ;
  1341   "RTN","IBC NBOE",99,0 )
  1342    ;
  1343   "RTN","IBC NBOE",100, 0)
  1344   PRINT(IBBE G,IBEND,IB EMPL,IBOUT ) ;
  1345   "RTN","IBC NBOE",101, 0)
  1346    N IBXREF, IBLABLE,IB EMPN,IBS1, IBS2,IBS3, IBINS,IBGR P,IBPOL,IB CNT,IBIP,I BGP,IBPP,I BRDT,IBPGN ,IBRANGE,I BLN,IBI
  1347   "RTN","IBC NBOE",102, 0)
  1348    ;
  1349   "RTN","IBC NBOE",103, 0)
  1350    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  1351   "RTN","IBC NBOE",104, 0)
  1352    S IBRANGE =$$FMTE^XL FDT(IBBEG) _" - "_$$F MTE^XLFDT( IBEND)
  1353   "RTN","IBC NBOE",105, 0)
  1354    S IBRDT=$ $FMTE^XLFD T($J($$NOW ^XLFDT,0,4 ),2),IBRDT =$TR(IBRDT ,"@"," "), (IBLN,IBPG N)=0
  1355   "RTN","IBC NBOE",106, 0)
  1356    ;
  1357   "RTN","IBC NBOE",107, 0)
  1358    ; Excel o utput
  1359   "RTN","IBC NBOE",108, 0)
  1360    I IBOUT=" E" D PHDL  D  S IBI=$ $PAUSE Q
  1361   "RTN","IBC NBOE",109, 0)
  1362    . S IBXRE F="IBCNBOE ",IBS1=""  F  S IBS1= $O(^TMP($J ,IBXREF,IB S1)) Q:IBS 1=""  D
  1363   "RTN","IBC NBOE",110, 0)
  1364    .. S IBS2 =0 F  S IB S2=$O(^TMP ($J,IBXREF ,IBS1,IBS2 )) Q:IBS2= ""  D
  1365   "RTN","IBC NBOE",111, 0)
  1366    ... S IBL ABLE=$S(IB S2=99999:" TOTALS",($ E(IBBEG,1, 5)<IBS2)&( $E(IBEND,1 ,5)>IBS2): $$FMTE^XLF DT(IBS2_"0 0"),1:"")
  1367   "RTN","IBC NBOE",112, 0)
  1368    ... I IBL ABLE="" S  IBLABLE=$$ FMTE^XLFDT ($S($E(IBB EG,1,5)<IB S2:IBS2_"0 1",1:IBBEG ))_" - "_$ $FMTE^XLFD T($S($E(IB END,1,5)>I BS2:$$SCH^ XLFDT("1M( L)",IBS2_1 1),1:IBEND ))
  1369   "RTN","IBC NBOE",113, 0)
  1370    ... S IBE MPN=$P($G( ^VA(200,IB S1,0)),U,1 )
  1371   "RTN","IBC NBOE",114, 0)
  1372    ... S IBS 3="" F  S  IBS3=$O(^T MP($J,IBXR EF,IBS1,IB S2,IBS3))  Q:'IBS3  D  PRTLN
  1373   "RTN","IBC NBOE",115, 0)
  1374    ... ;
  1375   "RTN","IBC NBOE",116, 0)
  1376    ... S IBI NS=+$G(^TM P($J,"IBCN BOEC",IBS1 ,IBS2,"I") ),IBGRP=+$ G(^TMP($J, "IBCNBOEC" ,IBS1,IBS2 ,"G"))
  1377   "RTN","IBC NBOE",117, 0)
  1378    ... S IBP OL=+$G(^TM P($J,"IBCN BOEC",IBS1 ,IBS2,"P") ),IBCNT=+$ G(^TMP($J, "IBCNBOEC" ,IBS1,IBS2 ,"CNT"))
  1379   "RTN","IBC NBOE",118, 0)
  1380    ... S (IB IP,IBGP,IB PP)=0 I IB CNT'=0 S I BIP=((IBIN S/IBCNT)*1 00)\1,IBGP =((IBGRP/I BCNT)*100) \1,IBPP=(( IBPOL/IBCN T)*100)\1
  1381   "RTN","IBC NBOE",119, 0)
  1382    ... W U_I BINS_U_IBI P_"%"_U_IB GRP_U_IBGP _"%"_U_IBP OL_U_IBPP_ "%"
  1383   "RTN","IBC NBOE",120, 0)
  1384    ;
  1385   "RTN","IBC NBOE",121, 0)
  1386    D HDR
  1387   "RTN","IBC NBOE",122, 0)
  1388    ;
  1389   "RTN","IBC NBOE",123, 0)
  1390    S IBXREF= "IBCNBOE", IBS1="" F   S IBS1=$O (^TMP($J,I BXREF,IBS1 )) Q:IBS1= ""  D  Q:I BQUIT
  1391   "RTN","IBC NBOE",124, 0)
  1392    . ;
  1393   "RTN","IBC NBOE",125, 0)
  1394    . S IBS2= 0 F  S IBS 2=$O(^TMP( $J,IBXREF, IBS1,IBS2) ) Q:IBS2=" "  D:IBLN> (IOSL-15)  HDR Q:IBQU IT  D  S I BLN=IBLN+8
  1395   "RTN","IBC NBOE",126, 0)
  1396    .. S IBLA BLE=$S(IBS 2=99999:"T OTALS",($E (IBBEG,1,5 )<IBS2)&($ E(IBEND,1, 5)>IBS2):$ $FMTE^XLFD T(IBS2_"00 "),1:"")
  1397   "RTN","IBC NBOE",127, 0)
  1398    .. I IBLA BLE="" S I BLABLE=$$F MTE^XLFDT( $S($E(IBBE G,1,5)<IBS 2:IBS2_1,1 :IBBEG))_"  - "_$$FMT E^XLFDT($S ($E(IBEND, 1,5)>IBS2: $$SCH^XLFD T("1M(L)", IBS2_11),1 :IBEND))
  1399   "RTN","IBC NBOE",128, 0)
  1400    .. S IBLA BLE=$P($G( ^VA(200,IB S1,0)),U,1 )_"  "_IBL ABLE
  1401   "RTN","IBC NBOE",129, 0)
  1402    .. W !,?( 40-($L(IBL ABLE)/2)), IBLABLE,!
  1403   "RTN","IBC NBOE",130, 0)
  1404    .. W !,?4 3,"AVERAGE ",?56,"LON GEST",?68, "SHORTEST"
  1405   "RTN","IBC NBOE",131, 0)
  1406    .. W !,"S TATUS",?22 ,"COUNT",? 30,"PERCEN T",?43,"#  DAYS",?56, "# DAYS",? 68,"# DAYS "
  1407   "RTN","IBC NBOE",132, 0)
  1408    .. W !,"- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ------"
  1409   "RTN","IBC NBOE",133, 0)
  1410    .. ;
  1411   "RTN","IBC NBOE",134, 0)
  1412    .. S IBS3 ="" F  S I BS3=$O(^TM P($J,IBXRE F,IBS1,IBS 2,IBS3)) Q :'IBS3  D  PRTLN  S I BLN=IBLN+1
  1413   "RTN","IBC NBOE",135, 0)
  1414    .. ;
  1415   "RTN","IBC NBOE",136, 0)
  1416    .. S IBIN S=+$G(^TMP ($J,"IBCNB OEC",IBS1, IBS2,"I")) ,IBGRP=+$G (^TMP($J," IBCNBOEC", IBS1,IBS2, "G"))
  1417   "RTN","IBC NBOE",137, 0)
  1418    .. S IBPO L=+$G(^TMP ($J,"IBCNB OEC",IBS1, IBS2,"P")) ,IBCNT=+$G (^TMP($J," IBCNBOEC", IBS1,IBS2, "CNT"))
  1419   "RTN","IBC NBOE",138, 0)
  1420    .. S (IBI P,IBGP,IBP P)=0 I IBC NT'=0 S IB IP=((IBINS /IBCNT)*10 0)\1,IBGP= ((IBGRP/IB CNT)*100)\ 1,IBPP=((I BPOL/IBCNT )*100)\1
  1421   "RTN","IBC NBOE",139, 0)
  1422    .. W !!,? 2,IBINS,"  New Compan ",$S(IBINS =1:"y",1:" ies")," (" ,IBIP,"%),  "
  1423   "RTN","IBC NBOE",140, 0)
  1424    .. W IBGR P," New Gr oup/Plan", $S(IBGRP=1 :"",1:"s") ," (",IBGP ,"%), "
  1425   "RTN","IBC NBOE",141, 0)
  1426    .. W IBPO L," New Pa tient Poli c",$S(IBPO L=1:"y",1: "ies")," ( ",IBPP,"%) ",!
  1427   "RTN","IBC NBOE",142, 0)
  1428    ;
  1429   "RTN","IBC NBOE",143, 0)
  1430    I 'IBQUIT  S IBI=$$P AUSE
  1431   "RTN","IBC NBOE",144, 0)
  1432    Q
  1433   "RTN","IBC NBOE",145, 0)
  1434    ;
  1435   "RTN","IBC NBOE",146, 0)
  1436   PRTLN ;
  1437   "RTN","IBC NBOE",147, 0)
  1438    N IBSTX,I BCNT,IBTM, IBHG,IBLS, IBTCNT
  1439   "RTN","IBC NBOE",148, 0)
  1440    ;
  1441   "RTN","IBC NBOE",149, 0)
  1442    S IBSTX=$ G(^TMP($J, IBXREF,IBS 1,IBS2,IBS 3))
  1443   "RTN","IBC NBOE",150, 0)
  1444    S IBCNT=$ G(^TMP($J, IBXREF,IBS 1,IBS2,IBS 3,"CNT"))  Q:'IBCNT
  1445   "RTN","IBC NBOE",151, 0)
  1446    S IBTM=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"TM"))
  1447   "RTN","IBC NBOE",152, 0)
  1448    S IBHG=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"HG"))
  1449   "RTN","IBC NBOE",153, 0)
  1450    S IBLS=$G (^TMP($J,I BXREF,IBS1 ,IBS2,IBS3 ,"LS"))
  1451   "RTN","IBC NBOE",154, 0)
  1452    S IBTCNT= $G(^TMP($J ,IBXREF,IB S1,IBS2,9, "CNT")) Q: 'IBTCNT
  1453   "RTN","IBC NBOE",155, 0)
  1454    ;
  1455   "RTN","IBC NBOE",156, 0)
  1456    ; Excel o utput
  1457   "RTN","IBC NBOE",157, 0)
  1458    I IBOUT=" E" W !,IBE MPN_U_IBLA BLE_U_IBST X_U_$FN(IB CNT,",")_U _((IBCNT/I BTCNT)*100 )_"%"_U_$$ STD((IBTM/ IBCNT))_U_ $$STD(IBHG )_U_$$STD( IBLS) Q
  1459   "RTN","IBC NBOE",158, 0)
  1460    ;
  1461   "RTN","IBC NBOE",159, 0)
  1462    ; Report  output
  1463   "RTN","IBC NBOE",160, 0)
  1464    W !,IBSTX ,?20,$J($F N(IBCNT,", "),7),?30, $J(((IBCNT /IBTCNT)*1 00),6,1)," %",?43,$J( $$STD((IBT M/IBCNT)), 6,1),?56,$ J($$STD(IB HG),6,1),? 68,$J($$ST D(IBLS),6, 1)
  1465   "RTN","IBC NBOE",161, 0)
  1466    Q
  1467   "RTN","IBC NBOE",162, 0)
  1468    ;
  1469   "RTN","IBC NBOE",163, 0)
  1470   STD(SEC) ;  convert s econds to  days
  1471   "RTN","IBC NBOE",164, 0)
  1472    N IBX,IBD ,IBS,IBH,D AYS S DAYS ="" G:'$G( SEC) STDQ
  1473   "RTN","IBC NBOE",165, 0)
  1474    S IBD=(SE C/86400),I BD=+$P(IBD ,".")
  1475   "RTN","IBC NBOE",166, 0)
  1476    S IBS=SEC -(IBD*8640 0)
  1477   "RTN","IBC NBOE",167, 0)
  1478    S IBH=((I BS/60)/60) ,IBH=+$J(I BH,0,2)
  1479   "RTN","IBC NBOE",168, 0)
  1480    S DAYS=IB D+(IBH/24)
  1481   "RTN","IBC NBOE",169, 0)
  1482   STDQ Q DAY S
  1483   "RTN","IBC NBOE",170, 0)
  1484    ;
  1485   "RTN","IBC NBOE",171, 0)
  1486   HDR ;print  the repor t header
  1487   "RTN","IBC NBOE",172, 0)
  1488    S IBQUIT= $$STOP Q:I BQUIT
  1489   "RTN","IBC NBOE",173, 0)
  1490    I IBPGN>0  S IBQUIT= $$PAUSE Q: IBQUIT
  1491   "RTN","IBC NBOE",174, 0)
  1492    S IBPGN=I BPGN+1,IBL N=5 I IBPG N>1!($E(IO ST,1,2)["C -") W @IOF
  1493   "RTN","IBC NBOE",175, 0)
  1494    W !,"INSU RANCE BUFF ER EMPLOYE E REPORT    ",IBRANGE ," "
  1495   "RTN","IBC NBOE",176, 0)
  1496    W ?(IOM-2 2),IBRDT,? (IOM-7),"  PAGE ",IBP GN,!
  1497   "RTN","IBC NBOE",177, 0)
  1498    I +$G(IBE MPL) W !," EMPLOYEE:   ",$P($G(^ VA(200,+IB EMPL,0)),U ,1),!
  1499   "RTN","IBC NBOE",178, 0)
  1500    S IBI="", $P(IBI,"-" ,IOM+1)=""  W IBI,!
  1501   "RTN","IBC NBOE",179, 0)
  1502    Q
  1503   "RTN","IBC NBOE",180, 0)
  1504    ;
  1505   "RTN","IBC NBOE",181, 0)
  1506   PHDL ; - P rint the h eader line  for the E xcel sprea dsheet
  1507   "RTN","IBC NBOE",182, 0)
  1508    N X
  1509   "RTN","IBC NBOE",183, 0)
  1510    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets 
  1511   "RTN","IBC NBOE",184, 0)
  1512    W !,"INSU RANCE BUFF ER EMPLOYE E REPORT^" _IBRANGE_" ^"_$$FMTE^ XLFDT($$NO W^XLFDT,1) ,!
  1513   "RTN","IBC NBOE",185, 0)
  1514    I +$G(IBE MPL) W "EM PLOYEE:  " ,$P($G(^VA (200,+IBEM PL,0)),U,1 ),!
  1515   "RTN","IBC NBOE",186, 0)
  1516    ; IB*602/ HN end  
  1517   "RTN","IBC NBOE",187, 0)
  1518    S X="EMPL OYEE^MONTH ^STATUS^CO UNT^PERCEN T^AVERAGE  # DAYS^LON GEST # DAY S^SHORTEST  # DAYS^Ne w Companie s^% New Co mpanies^Ne w Group/Pl ans^% New  Group/Plan s^New Pati ent Polici es^% New P atient Pol icies"
  1519   "RTN","IBC NBOE",188, 0)
  1520    W X
  1521   "RTN","IBC NBOE",189, 0)
  1522    K X
  1523   "RTN","IBC NBOE",190, 0)
  1524    Q
  1525   "RTN","IBC NBOE",191, 0)
  1526    ;
  1527   "RTN","IBC NBOE",192, 0)
  1528   PAUSE() ;p ause at en d of scree n if beein g displaye d on a ter minal
  1529   "RTN","IBC NBOE",193, 0)
  1530    N IBX,DIR ,DIRUT,X,Y  S IBX=0
  1531   "RTN","IBC NBOE",194, 0)
  1532    I $E(IOST ,1,2)["C-"  W !! S DI R(0)="E" D  ^DIR K DI R I $D(DUO UT)!($D(DI RUT)) S IB X=1
  1533   "RTN","IBC NBOE",195, 0)
  1534    Q IBX
  1535   "RTN","IBC NBOE",196, 0)
  1536    ;
  1537   "RTN","IBC NBOE",197, 0)
  1538   STOP() ;de termine if  user has  requested  the queued  report to  stop
  1539   "RTN","IBC NBOE",198, 0)
  1540    I $D(ZTQU EUED),$$S^ %ZTLOAD S  ZTSTOP=1 K  ZTREQ I + $G(IBPGN)  W !,"***TA SK STOPPED  BY USER** *"
  1541   "RTN","IBC NBOE",199, 0)
  1542    Q +$G(ZTS TOP)
  1543   "RTN","IBC NBOE",200, 0)
  1544    ;
  1545   "RTN","IBC NBOE",201, 0)
  1546   WR() ; whi ch report
  1547   "RTN","IBC NBOE",202, 0)
  1548    N DIR,X,Y ,DIRUT,DUO UT,IBX S I BX=""
  1549   "RTN","IBC NBOE",203, 0)
  1550    S DIR("?" )="Enter ' V' for a r eport base d on emplo yees that  verify or  process (a ccept/reje ct) buffer  entries."
  1551   "RTN","IBC NBOE",204, 0)
  1552    S DIR("?" ,5)="Enter  'E' for a  report ba sed on emp loyees tha t create n ew buffer  entries."
  1553   "RTN","IBC NBOE",205, 0)
  1554    S DIR("?" ,1)="This  report may  be printe d for thos e employee s that cre ate Buffer  entries,"
  1555   "RTN","IBC NBOE",206, 0)
  1556    S DIR("?" ,2)="prima rily non-I nsurance p ersonnel o r for thos e employee s that ver ify and pr ocess",DIR ("?",3)="( accept/rej ect) Buffe r entries,  primarily  Insurance  Personnel .",DIR("?" ,4)=" "
  1557   "RTN","IBC NBOE",207, 0)
  1558    S DIR("A" )="Include  which Typ e of Emplo yee",DIR(0 )="SO^1:En tered By;2 :Verified/ Processed  By" D ^DIR
  1559   "RTN","IBC NBOE",208, 0)
  1560    S IBX=$S( Y>0:+Y,1:" ")
  1561   "RTN","IBC NBOE",209, 0)
  1562    Q IBX
  1563   "RTN","IBC NBOE",210, 0)
  1564    ;
  1565   "RTN","IBC NBOE",211, 0)
  1566   EMPL() ; p rint a sin gle or all  employees ?
  1567   "RTN","IBC NBOE",212, 0)
  1568    N DIR,X,Y ,DIRUT,DUO UT,IBX S I BX=""
  1569   "RTN","IBC NBOE",213, 0)
  1570    S DIR("?" ,1)="Repor t of activ ity in the  Buffer fi le by Empl oyee and d ate range. "
  1571   "RTN","IBC NBOE",214, 0)
  1572    S DIR("?" ,2)="Enter  'S' to in clude only  a single  employee i n the repo rt."
  1573   "RTN","IBC NBOE",215, 0)
  1574    S DIR("?" )="Enter ' A' to incl ude all em ployees in  the repor t."
  1575   "RTN","IBC NBOE",216, 0)
  1576    S DIR("A" )="Include  Selected  or All Emp loyees"
  1577   "RTN","IBC NBOE",217, 0)
  1578    S DIR("B" )="All",DI R(0)="SO^A :All Emplo yees;S:Sel ected Empl oyee" D ^D IR
  1579   "RTN","IBC NBOE",218, 0)
  1580    S IBX=$S( Y="S":1,Y= "A":0,1:"" )
  1581   "RTN","IBC NBOE",219, 0)
  1582    Q IBX
  1583   "RTN","IBC NBOE",220, 0)
  1584    ;
  1585   "RTN","IBC NBOE",221, 0)
  1586   SELEMPL(TY PE) ; get  the name o f an emplo yee
  1587   "RTN","IBC NBOE",222, 0)
  1588    N DIC,X,Y ,DTOUT,DUO UT,IBX S I BX=""
  1589   "RTN","IBC NBOE",223, 0)
  1590    S DIC("A" )="Select  an Employe e that "_T YPE_" Buff er entries : "
  1591   "RTN","IBC NBOE",224, 0)
  1592    S DIC="^V A(200,",DI C(0)="AEMQ " D ^DIC S  IBX=+Y I  $D(DTOUT)! $D(DUOUT)! (Y<1) S IB X=""
  1593   "RTN","IBC NBOE",225, 0)
  1594    Q IBX
  1595   "RTN","IBC NBOE",226, 0)
  1596    ;
  1597   "RTN","IBC NBOE",227, 0)
  1598   DATES(LABL E,IBBEG) ;
  1599   "RTN","IBC NBOE",228, 0)
  1600    N DIR,X,Y ,DIRUT,DUO UT,IBX,IBB ,IBD S IBX ="",IBB=$P ($S(+$G(IB BEG):IBBEG ,1:+$O(^IB A(355.33," B",0))),". "),IBD=$S( +$G(IBBEG) :DT,1:IBB)
  1601   "RTN","IBC NBOE",229, 0)
  1602    S DIR("?" )="Enter t he "_LABLE _" date to  include i n the repo rt."
  1603   "RTN","IBC NBOE",230, 0)
  1604    S DIR("?" ,1)="Enter  a date fr om the dat e of the f irst Buffe r entry to  today."
  1605   "RTN","IBC NBOE",231, 0)
  1606    S DIR("A" )=LABLE_"  Date",DIR( "B")=$$FMT E^XLFDT(IB D)
  1607   "RTN","IBC NBOE",232, 0)
  1608    S DIR(0)= "DO^"_IBB_ ":"_DT_":E X" D ^DIR  S IBX=Y I  $D(DIRUT)! $D(DUOUT)  S IBX=""
  1609   "RTN","IBC NBOE",233, 0)
  1610    Q IBX
  1611   "RTN","IBC NBOE",234, 0)
  1612    ;
  1613   "RTN","IBC NBOE",235, 0)
  1614   MONTH() ;
  1615   "RTN","IBC NBOE",236, 0)
  1616    N DIR,X,Y ,DIRUT,DUO UT,IBX S I BX=""
  1617   "RTN","IBC NBOE",237, 0)
  1618    S DIR("?" )="Enter N o if only  totals for  the date  range shou ld be repo rted."
  1619   "RTN","IBC NBOE",238, 0)
  1620    S DIR("?" ,1)="Enter  Yes if th e report s hould be b roken down  by month. "
  1621   "RTN","IBC NBOE",239, 0)
  1622    S DIR("A" )="Report  By Month", DIR(0)="Y" ,DIR("B")= "No" D ^DI R
  1623   "RTN","IBC NBOE",240, 0)
  1624    S IBX=$S( Y=1:Y,Y=0: Y,1:"")
  1625   "RTN","IBC NBOE",241, 0)
  1626    Q IBX
  1627   "RTN","IBC NBOE",242, 0)
  1628    ;
  1629   "RTN","IBC NBOE",243, 0)
  1630   OUT() ;
  1631   "RTN","IBC NBOE",244, 0)
  1632    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  1633   "RTN","IBC NBOE",245, 0)
  1634    W !
  1635   "RTN","IBC NBOE",246, 0)
  1636    S DIR(0)= "SA^E:Exce l;R:Report "
  1637   "RTN","IBC NBOE",247, 0)
  1638    S DIR("A" )="(E)xcel  Format or  (R)eport  Format: "
  1639   "RTN","IBC NBOE",248, 0)
  1640    S DIR("B" )="Report"
  1641   "RTN","IBC NBOE",249, 0)
  1642    D ^DIR I  $D(DIRUT)  Q ""
  1643   "RTN","IBC NBOE",250, 0)
  1644    Q Y
  1645   "RTN","IBC NBOF")
  1646   0^3^B33394 771^B32265 412
  1647   "RTN","IBC NBOF",1,0)
  1648   IBCNBOF ;A LB/ARH - I ns Buffer:  Employee  Report (En tered);1 J un 97
  1649   "RTN","IBC NBOF",2,0)
  1650    ;;2.0;INT EGRATED BI LLING;**82 ,528,602** ;21-MAR-94 ;Build 22
  1651   "RTN","IBC NBOF",3,0)
  1652    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1653   "RTN","IBC NBOF",4,0)
  1654    ;
  1655   "RTN","IBC NBOF",5,0)
  1656   EN ;get pa rameters t hen run th e report
  1657   "RTN","IBC NBOF",6,0)
  1658    ;
  1659   "RTN","IBC NBOF",7,0)
  1660    K ^TMP($J ) D HOME^% ZIS S IBHD R="INSURAN CE BUFFER  EMPLOYEE R EPORT" W @ IOF,!!,?25 ,IBHDR
  1661   "RTN","IBC NBOF",8,0)
  1662    W !!,"Thi s report p roduces a  count of t he number  of entries  added to  the Buffer ",!,"file  for a spec ified date  range sor ted by emp loyee.  Al so include d are",!," sub-totals  and perce ntages bas ed on the  current st atus of th ose entrie s."
  1663   "RTN","IBC NBOF",9,0)
  1664    ;
  1665   "RTN","IBC NBOF",10,0 )
  1666    S IBEMPL= +$$EMPL^IB CNBOE G:IB EMPL="" EX IT  W !!
  1667   "RTN","IBC NBOF",11,0 )
  1668    I +IBEMPL  S IBEMPL= $$SELEMPL^ IBCNBOE("E nters/Crea tes") G:IB EMPL="" EX IT  W !!
  1669   "RTN","IBC NBOF",12,0 )
  1670    ;
  1671   "RTN","IBC NBOF",13,0 )
  1672    S IBBEG=$ $DATES^IBC NBOE("Begi nning") G: 'IBBEG EXI T
  1673   "RTN","IBC NBOF",14,0 )
  1674    S IBEND=$ $DATES^IBC NBOE("Endi ng",IBBEG)  G:'IBEND  EXIT  W !!
  1675   "RTN","IBC NBOF",15,0 )
  1676    ;
  1677   "RTN","IBC NBOF",16,0 )
  1678    S IBMONTH =$$MONTH^I BCNBOE G:I BMONTH=""  EXIT  W !!
  1679   "RTN","IBC NBOF",17,0 )
  1680    ;
  1681   "RTN","IBC NBOF",18,0 )
  1682    S IBOUT=$ $OUT^IBCNB OE G:IBOUT ="" EXIT
  1683   "RTN","IBC NBOF",19,0 )
  1684    ;
  1685   "RTN","IBC NBOF",20,0 )
  1686   DEV ;get t he device
  1687   "RTN","IBC NBOF",21,0 )
  1688    I IBOUT=" R" W !,"Re port requi res 132 co lumns."
  1689   "RTN","IBC NBOF",22,0 )
  1690    S %ZIS="Q M",%ZIS("A ")="OUTPUT  DEVICE: "  D ^%ZIS G :POP EXIT
  1691   "RTN","IBC NBOF",23,0 )
  1692    I $D(IO(" Q")) S ZTR TN="RPT^IB CNBOF",ZTD ESC=IBHDR, ZTSAVE("IB *")="" D ^ %ZTLOAD K  IO("Q") G  EXIT
  1693   "RTN","IBC NBOF",24,0 )
  1694    U IO
  1695   "RTN","IBC NBOF",25,0 )
  1696    ;
  1697   "RTN","IBC NBOF",26,0 )
  1698   RPT ; run  report
  1699   "RTN","IBC NBOF",27,0 )
  1700    S IBQUIT= 0
  1701   "RTN","IBC NBOF",28,0 )
  1702    ;
  1703   "RTN","IBC NBOF",29,0 )
  1704    D SEARCH( IBBEG,IBEN D,IBMONTH, IBEMPL) G: IBQUIT EXI T
  1705   "RTN","IBC NBOF",30,0 )
  1706    D PRINT(I BBEG,IBEND ,IBMONTH,I BEMPL,IBOU T)
  1707   "RTN","IBC NBOF",31,0 )
  1708    ;
  1709   "RTN","IBC NBOF",32,0 )
  1710   EXIT K ^TM P($J),IBHD R,IBBEG,IB END,IBMONT H,IBOUT,IB QUIT,IBEMP L
  1711   "RTN","IBC NBOF",33,0 )
  1712    Q:$D(ZTQU EUED)
  1713   "RTN","IBC NBOF",34,0 )
  1714    D ^%ZISC
  1715   "RTN","IBC NBOF",35,0 )
  1716    Q
  1717   "RTN","IBC NBOF",36,0 )
  1718    ;
  1719   "RTN","IBC NBOF",37,0 )
  1720   SEARCH(IBB EG,IBEND,I BMONTH,IBE MPL) ; sea rch/sort s tatistics  for employ ee report
  1721   "RTN","IBC NBOF",38,0 )
  1722    N IBXDT,I BBUFDA,IBB 0,IBXREF,I BS1,IBEMP
  1723   "RTN","IBC NBOF",39,0 )
  1724    S IBBEG=$ G(IBBEG)-. 01,IBEND=$ S('$G(IBEN D):9999999 ,1:$P(IBEN D,".")+.9)
  1725   "RTN","IBC NBOF",40,0 )
  1726    ;
  1727   "RTN","IBC NBOF",41,0 )
  1728    S IBXDT=I BBEG F  S  IBXDT=$O(^ IBA(355.33 ,"B",IBXDT )) Q:'IBXD T!(IBXDT>I BEND)  D   S IBQUIT=$ $STOP Q:IB QUIT
  1729   "RTN","IBC NBOF",42,0 )
  1730    . S IBBUF DA=0 F  S  IBBUFDA=$O (^IBA(355. 33,"B",IBX DT,IBBUFDA )) Q:'IBBU FDA  D
  1731   "RTN","IBC NBOF",43,0 )
  1732    .. ;
  1733   "RTN","IBC NBOF",44,0 )
  1734    .. S IBB0 =$G(^IBA(3 55.33,IBBU FDA,0)),IB EMP=+$P(IB B0,U,2) I  'IBEMP Q
  1735   "RTN","IBC NBOF",45,0 )
  1736    .. I +IBE MPL,IBEMPL '=IBEMP Q
  1737   "RTN","IBC NBOF",46,0 )
  1738    .. ;
  1739   "RTN","IBC NBOF",47,0 )
  1740    .. I $G(I BMONTH) D  SET("IBCNB OF",IBEMP, $E(+IBB0,1 ,5),$P(IBB 0,U,4),+$P (IBB0,U,7) ,+$P(IBB0, U,8),+$P(I BB0,U,9))
  1741   "RTN","IBC NBOF",48,0 )
  1742    .. D SET( "IBCNBOF", IBEMP,9999 9,$P(IBB0, U,4),+$P(I BB0,U,7),+ $P(IBB0,U, 8),+$P(IBB 0,U,9))
  1743   "RTN","IBC NBOF",49,0 )
  1744    .. D SET( "IBCNBOF", "~",99999, $P(IBB0,U, 4),+$P(IBB 0,U,7),+$P (IBB0,U,8) ,+$P(IBB0, U,9))
  1745   "RTN","IBC NBOF",50,0 )
  1746    ;
  1747   "RTN","IBC NBOF",51,0 )
  1748    Q
  1749   "RTN","IBC NBOF",52,0 )
  1750    ;
  1751   "RTN","IBC NBOF",53,0 )
  1752   SET(XREF,S 1,S2,STAT, NC,NG,NP)  ;
  1753   "RTN","IBC NBOF",54,0 )
  1754    S ^TMP($J ,XREF,S1,S 2,"CNT")=$ G(^TMP($J, XREF,S1,S2 ,"CNT"))+1
  1755   "RTN","IBC NBOF",55,0 )
  1756    I STAT="E " S ^TMP($ J,XREF,S1, S2,"EN")=$ G(^TMP($J, XREF,S1,S2 ,"EN"))+1
  1757   "RTN","IBC NBOF",56,0 )
  1758    I STAT="R " S ^TMP($ J,XREF,S1, S2,"RJ")=$ G(^TMP($J, XREF,S1,S2 ,"RJ"))+1
  1759   "RTN","IBC NBOF",57,0 )
  1760    I STAT="A " S ^TMP($ J,XREF,S1, S2,"AC")=$ G(^TMP($J, XREF,S1,S2 ,"AC"))+1
  1761   "RTN","IBC NBOF",58,0 )
  1762    I +NC S ^ TMP($J,XRE F,S1,S2,"N C")=$G(^TM P($J,XREF, S1,S2,"NC" ))+1
  1763   "RTN","IBC NBOF",59,0 )
  1764    I +NG S ^ TMP($J,XRE F,S1,S2,"N G")=$G(^TM P($J,XREF, S1,S2,"NG" ))+1
  1765   "RTN","IBC NBOF",60,0 )
  1766    I +NP S ^ TMP($J,XRE F,S1,S2,"N P")=$G(^TM P($J,XREF, S1,S2,"NP" ))+1
  1767   "RTN","IBC NBOF",61,0 )
  1768    Q
  1769   "RTN","IBC NBOF",62,0 )
  1770    ;
  1771   "RTN","IBC NBOF",63,0 )
  1772    ;
  1773   "RTN","IBC NBOF",64,0 )
  1774   PRINT(IBBE G,IBEND,IB MONTH,IBEM PL,IBOUT)  ;
  1775   "RTN","IBC NBOF",65,0 )
  1776    N IBXREF, IBS1,IBS2, IBRDT,IBPG N,IBRANGE, IBLN,IBI
  1777   "RTN","IBC NBOF",66,0 )
  1778    ;
  1779   "RTN","IBC NBOF",67,0 )
  1780    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  1781   "RTN","IBC NBOF",68,0 )
  1782    S IBRANGE =$$FMTE^XL FDT(IBBEG) _" - "_$$F MTE^XLFDT( IBEND)
  1783   "RTN","IBC NBOF",69,0 )
  1784    S IBRDT=$ $FMTE^XLFD T($J($$NOW ^XLFDT,0,4 ),2),IBRDT =$TR(IBRDT ,"@"," "), (IBLN,IBPG N)=0
  1785   "RTN","IBC NBOF",70,0 )
  1786    ;
  1787   "RTN","IBC NBOF",71,0 )
  1788    D HDR:IBO UT="R",PHD L:IBOUT="E "
  1789   "RTN","IBC NBOF",72,0 )
  1790    ;
  1791   "RTN","IBC NBOF",73,0 )
  1792    S IBXREF= "IBCNBOF", IBS1="" F   S IBS1=$O (^TMP($J,I BXREF,IBS1 )) Q:IBS1= ""  D  Q:I BQUIT
  1793   "RTN","IBC NBOF",74,0 )
  1794    . I +$G(I BMONTH),(I BOUT="R")  W ! S IBLN =IBLN+1
  1795   "RTN","IBC NBOF",75,0 )
  1796    . ;
  1797   "RTN","IBC NBOF",76,0 )
  1798    . S IBS2= 0 F  S IBS 2=$O(^TMP( $J,IBXREF, IBS1,IBS2) ) Q:IBS2=" "  D:IBLN> (IOSL-3)&( IBOUT="R")  HDR Q:IBQ UIT  D
  1799   "RTN","IBC NBOF",77,0 )
  1800    .. D PRTL N  S IBLN= IBLN+1
  1801   "RTN","IBC NBOF",78,0 )
  1802    ;
  1803   "RTN","IBC NBOF",79,0 )
  1804    I 'IBQUIT  S IBI=$$P AUSE
  1805   "RTN","IBC NBOF",80,0 )
  1806    Q
  1807   "RTN","IBC NBOF",81,0 )
  1808    ;
  1809   "RTN","IBC NBOF",82,0 )
  1810   PRTLN ;
  1811   "RTN","IBC NBOF",83,0 )
  1812    N IBEMP,I BCNT,IBEN, IBAC,IBRJ, IBNC,IBNG, IBNP,DATM
  1813   "RTN","IBC NBOF",84,0 )
  1814    ;
  1815   "RTN","IBC NBOF",85,0 )
  1816    S IBEMP=$ P($G(^VA(2 00,+IBS1,0 )),U,1) I  IBS1="~" S  IBEMP="TO TAL"
  1817   "RTN","IBC NBOF",86,0 )
  1818    S IBCNT=$ G(^TMP($J, IBXREF,IBS 1,IBS2,"CN T")) Q:'IB CNT
  1819   "RTN","IBC NBOF",87,0 )
  1820    S IBEN=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"EN" ))
  1821   "RTN","IBC NBOF",88,0 )
  1822    S IBAC=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"AC" ))
  1823   "RTN","IBC NBOF",89,0 )
  1824    S IBRJ=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"RJ" ))
  1825   "RTN","IBC NBOF",90,0 )
  1826    S IBNC=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"NC" ))
  1827   "RTN","IBC NBOF",91,0 )
  1828    S IBNG=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"NG" ))
  1829   "RTN","IBC NBOF",92,0 )
  1830    S IBNP=$G (^TMP($J,I BXREF,IBS1 ,IBS2,"NP" ))
  1831   "RTN","IBC NBOF",93,0 )
  1832    S DATM=$S (IBS2=9999 9:"TOTAL", 1:$$FMTE^X LFDT(IBS2_ "00"))
  1833   "RTN","IBC NBOF",94,0 )
  1834    ;
  1835   "RTN","IBC NBOF",95,0 )
  1836    ; Excel o utput
  1837   "RTN","IBC NBOF",96,0 )
  1838    I IBOUT=" E" D  Q
  1839   "RTN","IBC NBOF",97,0 )
  1840    .W !,IBEM P_U_DATM_U _$FN(IBCNT ,",")_U_$F N(IBEN,"," )_U_$FN((( IBEN/IBCNT )*100),"," ,1)_"%"_U_ $FN(IBAC," ,")_U_$FN( ((IBAC/IBC NT)*100)," ,",1)_"%"
  1841   "RTN","IBC NBOF",98,0 )
  1842    .W U_$FN( IBRJ,",")_ U_$FN(((IB RJ/IBCNT)* 100),",",1 )_"%"_U_$F N(IBNC,"," )_U_$FN(IB NG,",")_U_ $FN(IBNP," ,")
  1843   "RTN","IBC NBOF",99,0 )
  1844    ;
  1845   "RTN","IBC NBOF",100, 0)
  1846    ; Report  output
  1847   "RTN","IBC NBOF",101, 0)
  1848    W !,$E(IB EMP,1,15), ?17,DATM,? 25,$J($FN( IBCNT,",") ,7)
  1849   "RTN","IBC NBOF",102, 0)
  1850    W ?35,$J( $FN(IBEN," ,"),7),?43 ,$J("("_$F N(((IBEN/I BCNT)*100) ,",",1)_"% )",8)
  1851   "RTN","IBC NBOF",103, 0)
  1852    W ?54,$J( $FN(IBAC," ,"),7),?62 ,$J("("_$F N(((IBAC/I BCNT)*100) ,",",1)_"% )",8)
  1853   "RTN","IBC NBOF",104, 0)
  1854    W ?73,$J( $FN(IBRJ," ,"),7),?81 ,$J("("_$F N(((IBRJ/I BCNT)*100) ,",",1)_"% )",8)
  1855   "RTN","IBC NBOF",105, 0)
  1856    W ?92,$J( $FN(IBNC," ,"),7),?10 2,$J($FN(I BNG,","),7 ),?112,$J( $FN(IBNP," ,"),7)
  1857   "RTN","IBC NBOF",106, 0)
  1858    Q
  1859   "RTN","IBC NBOF",107, 0)
  1860    ;
  1861   "RTN","IBC NBOF",108, 0)
  1862   HDR ;print  the repor t header
  1863   "RTN","IBC NBOF",109, 0)
  1864    S IBQUIT= $$STOP Q:I BQUIT
  1865   "RTN","IBC NBOF",110, 0)
  1866    I IBPGN>0  S IBQUIT= $$PAUSE Q: IBQUIT
  1867   "RTN","IBC NBOF",111, 0)
  1868    S IBPGN=I BPGN+1,IBL N=5 I IBPG N>1!($E(IO ST,1,2)["C -") W @IOF
  1869   "RTN","IBC NBOF",112, 0)
  1870    W !,"INSU RANCE BUFF ER (ENTERI NG) EMPLOY EE REPORT    ",IBRANG E," "
  1871   "RTN","IBC NBOF",113, 0)
  1872    W ?(IOM-2 2),IBRDT,? (IOM-7),"  PAGE ",IBP GN,!,?39," NOT YET",? 93,"NEW",? 104,"NEW", ?113,"NEW"
  1873   "RTN","IBC NBOF",114, 0)
  1874    W !,"EMPL OYEE",?17, "MONTH",?2 7,"TOTAL", ?39,"PROCE SSED",?58, "ACCEPTED" ,?77,"REJE CTED",?93, "INS CO",? 104,"GROUP ",?113,"PO LICY",!
  1875   "RTN","IBC NBOF",115, 0)
  1876    S IBI="", $P(IBI,"-" ,IOM+1)=""  W IBI
  1877   "RTN","IBC NBOF",116, 0)
  1878    Q
  1879   "RTN","IBC NBOF",117, 0)
  1880    ;
  1881   "RTN","IBC NBOF",118, 0)
  1882   PHDL ; - P rint the h eader line  for the E xcel sprea dsheet
  1883   "RTN","IBC NBOF",119, 0)
  1884    N X
  1885   "RTN","IBC NBOF",120, 0)
  1886    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets 
  1887   "RTN","IBC NBOF",121, 0)
  1888    W !,"INSU RANCE BUFF ER (ENTERI NG) EMPLOY EE REPORT^ "_IBRANGE_ "^"_$$FMTE ^XLFDT($$N OW^XLFDT,1 ),!
  1889   "RTN","IBC NBOF",122, 0)
  1890    ; IB*602/ HN end  
  1891   "RTN","IBC NBOF",123, 0)
  1892    S X="EMPL OYEE^MONTH ^TOTAL^NOT  YET PROCE SSED^% NOT  YET PROCE SSED^ACCEP TED^% ACCE PTED^REJEC TED^% REJE CTED^NEW I NS CO^NEW  GROUP^NEW  POLICY"
  1893   "RTN","IBC NBOF",124, 0)
  1894    W X
  1895   "RTN","IBC NBOF",125, 0)
  1896    K X
  1897   "RTN","IBC NBOF",126, 0)
  1898    Q
  1899   "RTN","IBC NBOF",127, 0)
  1900    ;
  1901   "RTN","IBC NBOF",128, 0)
  1902   PAUSE() ;p ause at en d of scree n if beein g displaye d on a ter minal
  1903   "RTN","IBC NBOF",129, 0)
  1904    N IBX,DIR ,DIRUT,DUO UT,X,Y S I BX=0
  1905   "RTN","IBC NBOF",130, 0)
  1906    I $E(IOST ,1,2)["C-"  W !! S DI R(0)="E" D  ^DIR K DI R I $D(DUO UT)!($D(DI RUT)) S IB X=1
  1907   "RTN","IBC NBOF",131, 0)
  1908    Q IBX
  1909   "RTN","IBC NBOF",132, 0)
  1910    ;
  1911   "RTN","IBC NBOF",133, 0)
  1912   STOP() ;de termine if  user has  requested  the queued  report to  stop
  1913   "RTN","IBC NBOF",134, 0)
  1914    I $D(ZTQU EUED),$$S^ %ZTLOAD S  ZTSTOP=1 K  ZTREQ I + $G(IBPGN)  W !,"***TA SK STOPPED  BY USER** *"
  1915   "RTN","IBC NBOF",135, 0)
  1916    Q +$G(ZTS TOP)
  1917   "RTN","IBC NEDE4")
  1918   0^19^B6182 6620^B6008 9694
  1919   "RTN","IBC NEDE4",1,0 )
  1920   IBCNEDE4 ; AITC/DM -  EICD (Elec tronic Ins urance Cov erage Disc overy) ext ract;24-JU N-2002
  1921   "RTN","IBC NEDE4",2,0 )
  1922    ;;2.0;INT EGRATED BI LLING;**18 4,271,416, 621,602**; 21-MAR-94; Build 22
  1923   "RTN","IBC NEDE4",3,0 )
  1924    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  1925   "RTN","IBC NEDE4",4,0 )
  1926    ;
  1927   "RTN","IBC NEDE4",5,0 )
  1928    ; **Progr am Descrip tion**
  1929   "RTN","IBC NEDE4",6,0 )
  1930    ; The Ele ctronic In surance Co verage Dis covery a.k .a EICD ex tract (#4)
  1931   "RTN","IBC NEDE4",7,0 )
  1932    ; is call ed from th e nightly  job - IBCN EDE.
  1933   "RTN","IBC NEDE4",8,0 )
  1934    ;
  1935   "RTN","IBC NEDE4",9,0 )
  1936    ; Formerl y known as  "No Insur ance", we  are rework ing the en tire logic  for 
  1937   "RTN","IBC NEDE4",10, 0)
  1938    ; determi ning insur ance for t hose who d on't have  active pol icies with  patch IB* 2.0*621.
  1939   "RTN","IBC NEDE4",11, 0)
  1940    ;
  1941   "RTN","IBC NEDE4",12, 0)
  1942    Q
  1943   "RTN","IBC NEDE4",13, 0)
  1944    ;
  1945   "RTN","IBC NEDE4",14, 0)
  1946   EN ; EICD  extract en try 
  1947   "RTN","IBC NEDE4",15, 0)
  1948    N CLNC,DA TA1,DATA2, DATA5,DFN, EACTIVE,EL G,FRESHDT, IBACTV,IBA PPTDT
  1949   "RTN","IBC NEDE4",16, 0)
  1950    N IBBEGDT ,IBCSIEN,I BDFNDONE,I BEFF,IBEIC DPAY,IBEND DT,IBERR,I BEXP,IBFDA
  1951   "RTN","IBC NEDE4",17, 0)
  1952    N IBFREQ, IBIDX,IBIN SNM,IBMSG, IBSDA,IBTA SKTOT,IBTO PIEN,IBTQC NT,IBTQIEN
  1953   "RTN","IBC NEDE4",18, 0)
  1954    N IBTQSTA T,IBWK1,IB WK2,IBWKIE N,MAXCNT,O K
  1955   "RTN","IBC NEDE4",19, 0)
  1956    ;
  1957   "RTN","IBC NEDE4",20, 0)
  1958    ;  Get Ex tract para meters
  1959   "RTN","IBC NEDE4",21, 0)
  1960    S EACTIVE =$$SETTING S^IBCNEDE7 (4)
  1961   "RTN","IBC NEDE4",22, 0)
  1962    I 'EACTIV E G ENQQ ;  not activ e, or requ ired field s missing
  1963   "RTN","IBC NEDE4",23, 0)
  1964    S MAXCNT= $P(EACTIVE ,U,4) ; th rottle dai ly extract  queries
  1965   "RTN","IBC NEDE4",24, 0)
  1966    S:MAXCNT= "" MAXCNT= 9999999999
  1967   "RTN","IBC NEDE4",25, 0)
  1968    S IBWK1=$ P(EACTIVE, U,6) ; sta rt days
  1969   "RTN","IBC NEDE4",26, 0)
  1970    S IBBEGDT =$$FMADD^X LFDT(DT,IB WK1) ; beg in date =  today + st art days
  1971   "RTN","IBC NEDE4",27, 0)
  1972    S IBENDDT =$$FMADD^X LFDT(DT,IB WK1+$P(EAC TIVE,U,7))  ; end dat e = today  + start da ys + days  after star t
  1973   "RTN","IBC NEDE4",28, 0)
  1974    S IBFREQ= $P(EACTIVE ,U,8) ; fr equency
  1975   "RTN","IBC NEDE4",29, 0)
  1976    S FRESHDT =$$FMADD^X LFDT(DT,-I BFREQ)
  1977   "RTN","IBC NEDE4",30, 0)
  1978    S IBCSIEN =$$FIND1^D IC(355.12, ,"X","CONT RACT SERVI CES","C")
  1979   "RTN","IBC NEDE4",31, 0)
  1980    S IBTQSTA T=$$FIND1^ DIC(365.14 ,,"X","Rea dy to Tran smit","B")
  1981   "RTN","IBC NEDE4",32, 0)
  1982    ;
  1983   "RTN","IBC NEDE4",33, 0)
  1984    ; see if  the EICD P AYER site  parameter  has been p opulated
  1985   "RTN","IBC NEDE4",34, 0)
  1986    ; and is  nationally  and local ly active,  if not, q uietly qui
  1987   "RTN","IBC NEDE4",35, 0)
  1988    S IBEICDP AY=+$$GET1 ^DIQ(350.9 ,"1,",51.3 1,"I") ; " EICD PAYER "
  1989   "RTN","IBC NEDE4",36, 0)
  1990    I 'IBEICD PAY G ENQQ
  1991   "RTN","IBC NEDE4",37, 0)
  1992    I '($$GET 1^DIQ(365. 121,"1,"_I BEICDPAY_" ,",.02,"I" )) G ENQQ  ; "NATIONA L ACTIVE"
  1993   "RTN","IBC NEDE4",38, 0)
  1994    I '($$GET 1^DIQ(365. 121,"1,"_I BEICDPAY_" ,",.03,"I" )) G ENQQ  ; "LOCAL A CTIVE"
  1995   "RTN","IBC NEDE4",39, 0)
  1996    ;
  1997   "RTN","IBC NEDE4",40, 0)
  1998    ; gather  the non-ac tive insur ance compa ny names
  1999   "RTN","IBC NEDE4",41, 0)
  2000    ; we will  strip all  blanks fr om the nam es, so das hes ('-')  are treate d properly  for a com pare 
  2001   "RTN","IBC NEDE4",42, 0)
  2002    F IBIDX=2 :1 S IBWK1 =$P($T(NAI NSCO+IBIDX ),";;",2)  Q:IBWK1=""   S IBINSN M($TR(IBWK 1," ","")) =""
  2003   "RTN","IBC NEDE4",43, 0)
  2004    ;
  2005   "RTN","IBC NEDE4",44, 0)
  2006    ; gather  the non-ac tive type  of plan ie ns
  2007   "RTN","IBC NEDE4",45, 0)
  2008    F IBIDX=2 :1 S IBWK1 =$P($T(NAT PLANS+IBID X),";;",2)  Q:IBWK1=" "  D
  2009   "RTN","IBC NEDE4",46, 0)
  2010    . S IBWK2 =+$$FIND1^ DIC(355.1, ,"BQX",IBW K1)
  2011   "RTN","IBC NEDE4",47, 0)
  2012    . Q:'IBWK 2
  2013   "RTN","IBC NEDE4",48, 0)
  2014    . S IBTOP IEN(IBWK2) =""
  2015   "RTN","IBC NEDE4",49, 0)
  2016    ;
  2017   "RTN","IBC NEDE4",50, 0)
  2018    S IBTASKT OT=0 ; Tas kman check
  2019   "RTN","IBC NEDE4",51, 0)
  2020    S IBTQCNT =0 ; TQ en try count 
  2021   "RTN","IBC NEDE4",52, 0)
  2022    K ^TMP($J ,"SDAMA301 "),^TMP($J ,"IBCNEDE4 "),IBDFNDO NE
  2023   "RTN","IBC NEDE4",53, 0)
  2024    ;
  2025   "RTN","IBC NEDE4",54, 0)
  2026    ; Loop th rough clin ics 
  2027   "RTN","IBC NEDE4",55, 0)
  2028    S CLNC=0  F  S CLNC= $O(^SC(CLN C)) Q:'CLN C  D
  2029   "RTN","IBC NEDE4",56, 0)
  2030    . D CLINI CEX^IBCNED E2 Q:'OK   ; clinic e xcluded
  2031   "RTN","IBC NEDE4",57, 0)
  2032    . S ^TMP( $J,"IBCNED E4",CLNC)= ""
  2033   "RTN","IBC NEDE4",58, 0)
  2034    ;
  2035   "RTN","IBC NEDE4",59, 0)
  2036    ; Set up  variables  for schedu ling api a nd call
  2037   "RTN","IBC NEDE4",60, 0)
  2038    S IBSDA(" FLDS")=8
  2039   "RTN","IBC NEDE4",61, 0)
  2040    S IBSDA(1 )=IBBEGDT_ ";"_IBENDD T
  2041   "RTN","IBC NEDE4",62, 0)
  2042    S IBSDA(2 )="^TMP($J ,""IBCNEDE 4"","
  2043   "RTN","IBC NEDE4",63, 0)
  2044    S IBSDA(3 )="R"
  2045   "RTN","IBC NEDE4",64, 0)
  2046    S OK=$$SD API^SDAMA3 01(.IBSDA)  I OK<1 D: OK<0 ERRMS G G ENQQ
  2047   "RTN","IBC NEDE4",65, 0)
  2048    ;
  2049   "RTN","IBC NEDE4",66, 0)
  2050    ; loop th rough retu rned clini cs
  2051   "RTN","IBC NEDE4",67, 0)
  2052    S CLNC=0
  2053   "RTN","IBC NEDE4",68, 0)
  2054    F  S CLNC =$O(^TMP($ J,"SDAMA30 1",CLNC))  Q:'CLNC  D   G ENQQ:$ G(ZTSTOP)! (IBTQCNT'< MAXCNT)
  2055   "RTN","IBC NEDE4",69, 0)
  2056    . ;
  2057   "RTN","IBC NEDE4",70, 0)
  2058    . ; Loop  through pa tients ret urned
  2059   "RTN","IBC NEDE4",71, 0)
  2060    . S DFN=0
  2061   "RTN","IBC NEDE4",72, 0)
  2062    . F  S DF N=$O(^TMP( $J,"SDAMA3 01",CLNC,D FN)) Q:'DF N  D  Q:$G (ZTSTOP)!( IBTQCNT'<M AXCNT)
  2063   "RTN","IBC NEDE4",73, 0)
  2064    .. ;
  2065   "RTN","IBC NEDE4",74, 0)
  2066    .. ; CHEC K DFN STUF F
  2067   "RTN","IBC NEDE4",75, 0)
  2068    .. Q:$D(I BDFNDONE(D FN))  ; DF N has been  handled
  2069   "RTN","IBC NEDE4",76, 0)
  2070    .. ;
  2071   "RTN","IBC NEDE4",77, 0)
  2072    .. S OK=1
  2073   "RTN","IBC NEDE4",78, 0)
  2074    .. S IBWK 1=+$$GET1^ DIQ(2,DFN_ ",",.6,"I" ) ; "TEST  PATIENT IN DICATOR"
  2075   "RTN","IBC NEDE4",79, 0)
  2076    .. S:IBWK 1 OK=0
  2077   "RTN","IBC NEDE4",80, 0)
  2078    .. ;
  2079   "RTN","IBC NEDE4",81, 0)
  2080    .. S IBWK 1=+$$GET1^ DIQ(2,DFN_ ",",2001," I") ; "DAT E LAST EIC D RUN" fro m PATIENT  INS node
  2081   "RTN","IBC NEDE4",82, 0)
  2082    .. I IBWK 1,(IBWK1>F RESHDT) S  OK=0
  2083   "RTN","IBC NEDE4",83, 0)
  2084    .. ; 
  2085   "RTN","IBC NEDE4",84, 0)
  2086    .. S IBWK 1=+$$GET1^ DIQ(2,DFN_ ",",.351," I") ; "DAT E OF DEATH
  2087   "RTN","IBC NEDE4",85, 0)
  2088    .. S:IBWK 1 OK=0
  2089   "RTN","IBC NEDE4",86, 0)
  2090    .. ;
  2091   "RTN","IBC NEDE4",87, 0)
  2092    .. ; any  value for  CITY is va lid, HL7 w ill replac e a "" wit h "UNKNOWN
  2093   "RTN","IBC NEDE4",88, 0)
  2094    .. S IBWK 1=$$GET1^D IQ(2,DFN_" ,",.115) ;  "STATE"
  2095   "RTN","IBC NEDE4",89, 0)
  2096    .. S:IBWK 1="" OK=0
  2097   "RTN","IBC NEDE4",90, 0)
  2098    .. S IBWK 1=$$GET1^D IQ(2,DFN_" ,",.116) ;  "ZIP CODE "
  2099   "RTN","IBC NEDE4",91, 0)
  2100    .. S:IBWK 1="" OK=0
  2101   "RTN","IBC NEDE4",92, 0)
  2102    .. ;
  2103   "RTN","IBC NEDE4",93, 0)
  2104    .. I 'OK  S IBDFNDON E(DFN)=""  Q  ; patie nt require ments not  met 
  2105   "RTN","IBC NEDE4",94, 0)
  2106    .. ;   
  2107   "RTN","IBC NEDE4",95, 0)
  2108    .. ; Loop  through d ates in ra nge at cli nic
  2109   "RTN","IBC NEDE4",96, 0)
  2110    .. S IBAP PTDT=IBBEG DT
  2111   "RTN","IBC NEDE4",97, 0)
  2112    .. F  S I BAPPTDT=$O (^TMP($J," SDAMA301", CLNC,DFN,I BAPPTDT))  Q:('IBAPPT DT)!((IBAP PTDT\1)>IB ENDDT)  D   Q:$G(ZTST OP)!(IBTQC NT'<MAXCNT )
  2113   "RTN","IBC NEDE4",98, 0)
  2114    ... ;
  2115   "RTN","IBC NEDE4",99, 0)
  2116    ... ; Upd ate count  for period ic check
  2117   "RTN","IBC NEDE4",100 ,0)
  2118    ... S IBT ASKTOT=IBT ASKTOT+1
  2119   "RTN","IBC NEDE4",101 ,0)
  2120    ... ; Che ck for req uest to st op backgro und job, p eriodicall y
  2121   "RTN","IBC NEDE4",102 ,0)
  2122    ... I $D( ZTQUEUED), IBTASKTOT# 100=0,$$S^ %ZTLOAD()  S ZTSTOP=1  Q
  2123   "RTN","IBC NEDE4",103 ,0)
  2124    ... ;
  2125   "RTN","IBC NEDE4",104 ,0)
  2126    ... Q:$D( IBDFNDONE( DFN))  ; w e've alrea dy seen th is DFN
  2127   "RTN","IBC NEDE4",105 ,0)
  2128    ... ;
  2129   "RTN","IBC NEDE4",106 ,0)
  2130    ... S IBW K1=$G(^TMP ($J,"SDAMA 301",CLNC, DFN,IBAPPT DT))
  2131   "RTN","IBC NEDE4",107 ,0)
  2132    ... S ELG =$P(IBWK1, U,8)
  2133   "RTN","IBC NEDE4",108 ,0)
  2134    ... S:ELG ="" ELG=$$ GET1^DIQ(2 ,DFN_",",. 361) ; "PR IMARY ELIG IBILITY CO DE" 
  2135   "RTN","IBC NEDE4",109 ,0)
  2136    ... D ELG ^IBCNEDE2  Q:'OK  ; e ligibility  exclusion
  2137   "RTN","IBC NEDE4",110 ,0)
  2138    ... ;
  2139   "RTN","IBC NEDE4",111 ,0)
  2140    ... ; ski p any pati ent with " active" in surance 
  2141   "RTN","IBC NEDE4",112 ,0)
  2142    ... S IBA CTV=0
  2143   "RTN","IBC NEDE4",113 ,0)
  2144    ... S IBI DX=0 ; che ck policie s for "act ive" insur ance 
  2145   "RTN","IBC NEDE4",114 ,0)
  2146    ... F  S  IBIDX=$O(^ DPT(DFN,.3 12,IBIDX))  Q:('IBIDX )!IBACTV   D
  2147   "RTN","IBC NEDE4",115 ,0)
  2148    .... S IB WKIEN=IBID X_","_DFN_ ","
  2149   "RTN","IBC NEDE4",116 ,0)
  2150    .... S IB EFF=+$$GET 1^DIQ(2.31 2,IBWKIEN, 8,"I") ; e ffective d ate 
  2151   "RTN","IBC NEDE4",117 ,0)
  2152    .... S IB EXP=+$$GET 1^DIQ(2.31 2,IBWKIEN, 3,"I") ; e xpiration  date
  2153   "RTN","IBC NEDE4",118 ,0)
  2154    .... I 'I BEFF Q  ;  non-active
  2155   "RTN","IBC NEDE4",119 ,0)
  2156    .... I IB EXP,(IBEXP <(IBAPPTDT \1)) Q  ;  non-active
  2157   "RTN","IBC NEDE4",120 ,0)
  2158    .... ; 
  2159   "RTN","IBC NEDE4",121 ,0)
  2160    .... S IB WK1=$TR($$ GET1^DIQ(2 .312,IBWKI EN,.01,"E" )," ","")  ; insuranc e company  name
  2161   "RTN","IBC NEDE4",122 ,0)
  2162    .... ; IB *2.0*602/T AZ Screen  out bad po inters to  File 36
  2163   "RTN","IBC NEDE4",123 ,0)
  2164    .... I IB WK1="" Q   ; bad poin ter to INS URANCE COM PANY File  (#36)
  2165   "RTN","IBC NEDE4",124 ,0)
  2166    .... I $D (IBINSNM(I BWK1)) Q   ; matches  non-active  insurance
  2167   "RTN","IBC NEDE4",125 ,0)
  2168    .... S IB WK1=$$GET1 ^DIQ(2.312 ,IBWKIEN,. 18,"I")    ; group pl an ien 
  2169   "RTN","IBC NEDE4",126 ,0)
  2170    .... S IB WK2=$$GET1 ^DIQ(355.3 ,IBWK1_"," ,.09,"I")  ; type of  plan ien
  2171   "RTN","IBC NEDE4",127 ,0)
  2172    .... ; no  type of p lan is con sidered ac tive 
  2173   "RTN","IBC NEDE4",128 ,0)
  2174    .... I IB WK2'="",$D (IBTOPIEN( IBWK2)) Q   ; matches  non-activ e type of  plan
  2175   "RTN","IBC NEDE4",129 ,0)
  2176    .... ; 
  2177   "RTN","IBC NEDE4",130 ,0)
  2178    .... ; 'I BEXP is co nsidered a ctive at t his point 
  2179   "RTN","IBC NEDE4",131 ,0)
  2180    .... S IB ACTV=1 Q   ; active 
  2181   "RTN","IBC NEDE4",132 ,0)
  2182    ... ;
  2183   "RTN","IBC NEDE4",133 ,0)
  2184    ... I IBA CTV Q  ; n ext clinic  appt 
  2185   "RTN","IBC NEDE4",134 ,0)
  2186    ... ; 
  2187   "RTN","IBC NEDE4",135 ,0)
  2188    ... ; Thi s DFN is c onsidered  non-active , we'll at tempt a TQ  entry
  2189   "RTN","IBC NEDE4",136 ,0)
  2190    ... S IBD FNDONE(DFN )=""  ; ok  to flag D FN as hand led now 
  2191   "RTN","IBC NEDE4",137 ,0)
  2192    ... ; the re should  be no TQ e ntry for t his DFN, c onsider it  a safety  check 
  2193   "RTN","IBC NEDE4",138 ,0)
  2194    ... I '$$ ADDTQ^IBCN EUT5(DFN,I BEICDPAY,D T,IBFREQ,1 ) Q
  2195   "RTN","IBC NEDE4",139 ,0)
  2196    ... ; SET  prepare a nd file th e TQ
  2197   "RTN","IBC NEDE4",140 ,0)
  2198    ... ; DFN :Patient I EN
  2199   "RTN","IBC NEDE4",141 ,0)
  2200    ... ; IBE ICDPAY:EIC D payer IE N
  2201   "RTN","IBC NEDE4",142 ,0)
  2202    ... ; IBT QSTAT:TQ S TATUS IEN  - Ready to  Transmit 
  2203   "RTN","IBC NEDE4",143 ,0)
  2204    ... ; FRE SHDT:Fresh ness date 
  2205   "RTN","IBC NEDE4",144 ,0)
  2206    ... ; 4:E ICD data e xtract (#4 )
  2207   "RTN","IBC NEDE4",145 ,0)
  2208    ... ; I:I dentificat ion 
  2209   "RTN","IBC NEDE4",146 ,0)
  2210    ... ; DT: Todays dat
  2211   "RTN","IBC NEDE4",147 ,0)
  2212    ... ; IBC SIEN:Sourc e of Infor mation IEN  - Contrac t Services     
  2213   "RTN","IBC NEDE4",148 ,0)
  2214    ... S DAT A1=DFN_U_I BEICDPAY_U _IBTQSTAT_ U_""_U_""_ U_FRESHDT
  2215   "RTN","IBC NEDE4",149 ,0)
  2216    ... S DAT A2=4_U_"I" _U_DT
  2217   "RTN","IBC NEDE4",150 ,0)
  2218    ... S DAT A5=IBCSIEN
  2219   "RTN","IBC NEDE4",151 ,0)
  2220    ... S IBT QIEN=$$SET TQ^IBCNEDE 7(DATA1,DA TA2,,,DATA 5) ; Sets  in TQ
  2221   "RTN","IBC NEDE4",152 ,0)
  2222    ... I IBT QIEN="" K  IBDFNDONE( DFN) Q   ;  didn't fi le, unmark  DFN 
  2223   "RTN","IBC NEDE4",153 ,0)
  2224    ... S IBT QCNT=IBTQC NT+1                ;  increment  the TQ co unt
  2225   "RTN","IBC NEDE4",154 ,0)
  2226    ... ; pla ce a stub  into EIV E ICD TRACKI NG (#365.1 8)
  2227   "RTN","IBC NEDE4",155 ,0)
  2228    ... K IBF DA,IBERR
  2229   "RTN","IBC NEDE4",156 ,0)
  2230    ... ; EIV  EICD TRAC KING, .01: TRANSMISSI ON .02:DAT E CREATED  .03:PAYER  .05:PATIEN T
  2231   "RTN","IBC NEDE4",157 ,0)
  2232    ... S IBF DA(365.18, "+1,",.01) =IBTQIEN,I BFDA(365.1 8,"+1,",.0 2)=DT
  2233   "RTN","IBC NEDE4",158 ,0)
  2234    ... S IBF DA(365.18, "+1,",.03) =IBEICDPAY ,IBFDA(365 .18,"+1,", .05)=DFN
  2235   "RTN","IBC NEDE4",159 ,0)
  2236    ... D UPD ATE^DIE(," IBFDA",,"I BERR")
  2237   "RTN","IBC NEDE4",160 ,0)
  2238    ... I $G( IBERR("DIE RR",1,"TEX T",1))'=""  D  Q
  2239   "RTN","IBC NEDE4",161 ,0)
  2240    .... S IB MSG=""
  2241   "RTN","IBC NEDE4",162 ,0)
  2242    .... D MS G002^IBCNE MS1(.IBMSG ,.IBERR,IB TQIEN)
  2243   "RTN","IBC NEDE4",163 ,0)
  2244    .... D MS G^IBCNEUT5 ($$MGRP^IB CNEUT5()," eIV Proble m: Error w riting EIV  EICD TRAC KING (#365 .18)","IBM SG(")
  2245   "RTN","IBC NEDE4",164 ,0)
  2246    ... Q  ;  next clini c appt
  2247   "RTN","IBC NEDE4",165 ,0)
  2248    ... ; 
  2249   "RTN","IBC NEDE4",166 ,0)
  2250   ENQQ ; cle an and qui
  2251   "RTN","IBC NEDE4",167 ,0)
  2252    K ^TMP($J ,"SDAMA301 "),^TMP($J ,"IBCNEDE2 ")
  2253   "RTN","IBC NEDE4",168 ,0)
  2254    Q
  2255   "RTN","IBC NEDE4",169 ,0)
  2256    ;
  2257   "RTN","IBC NEDE4",170 ,0)
  2258   ERRMSG ; S end a mess age indica ting an ex tract erro r has occu rred
  2259   "RTN","IBC NEDE4",171 ,0)
  2260    S IBMSG=" "
  2261   "RTN","IBC NEDE4",172 ,0)
  2262    D MSG001^ IBCNEMS1(. IBMSG,"EIC D")
  2263   "RTN","IBC NEDE4",173 ,0)
  2264    D MSG^IBC NEUT5($$MG RP^IBCNEUT 5(),"eIV P roblem: EI CD Extract ","IBMSG(" )
  2265   "RTN","IBC NEDE4",174 ,0)
  2266    ;
  2267   "RTN","IBC NEDE4",175 ,0)
  2268    Q
  2269   "RTN","IBC NEDE4",176 ,0)
  2270    ;
  2271   "RTN","IBC NEDE4",177 ,0)
  2272   NAINSCO ;  Non-active  Insurance  companies
  2273   "RTN","IBC NEDE4",178 ,0)
  2274    ;
  2275   "RTN","IBC NEDE4",179 ,0)
  2276    ;;MEDICAR E (WNR)
  2277   "RTN","IBC NEDE4",180 ,0)
  2278    ;;VACAA-W NR  
  2279   "RTN","IBC NEDE4",181 ,0)
  2280    ;;CAMP LE JEUNE - WN R
  2281   "RTN","IBC NEDE4",182 ,0)
  2282    ;;IVF - W NR
  2283   "RTN","IBC NEDE4",183 ,0)
  2284    ;;VHA DIR ECTIVE 102 9 WNR
  2285   "RTN","IBC NEDE4",184 ,0)
  2286    ;
  2287   "RTN","IBC NEDE4",185 ,0)
  2288   NATPLANS ;  Non-activ e Type of  Plans
  2289   "RTN","IBC NEDE4",186 ,0)
  2290    ;
  2291   "RTN","IBC NEDE4",187 ,0)
  2292    ;;ACCIDEN T AND HEAL TH INSURAN CE
  2293   "RTN","IBC NEDE4",188 ,0)
  2294    ;;AUTOMOB ILE
  2295   "RTN","IBC NEDE4",189 ,0)
  2296    ;;AVIATIO N TRIP INS URANCE
  2297   "RTN","IBC NEDE4",190 ,0)
  2298    ;;CATASTR OPHIC INSU RANCE
  2299   "RTN","IBC NEDE4",191 ,0)
  2300    ;;CHAMPVA
  2301   "RTN","IBC NEDE4",192 ,0)
  2302    ;;COINSUR ANCE
  2303   "RTN","IBC NEDE4",193 ,0)
  2304    ;;DENTAL  INSURANCE
  2305   "RTN","IBC NEDE4",194 ,0)
  2306    ;;DUAL CO VERAGE
  2307   "RTN","IBC NEDE4",195 ,0)
  2308    ;;INCOME  PROTECTION  (INDEMNIT Y)
  2309   "RTN","IBC NEDE4",196 ,0)
  2310    ;;KEY-MAN  HEALTH IN SURANCE
  2311   "RTN","IBC NEDE4",197 ,0)
  2312    ;;LABS, P ROCEDURES,  X-RAY, ET C. (ONLY)
  2313   "RTN","IBC NEDE4",198 ,0)
  2314    ;;MEDI-CA L
  2315   "RTN","IBC NEDE4",199 ,0)
  2316    ;;MEDICAI D
  2317   "RTN","IBC NEDE4",200 ,0)
  2318    ;;MEDICAR E (M)
  2319   "RTN","IBC NEDE4",201 ,0)
  2320    ;;MEDICAR E/MEDICAID  (MEDI-CAL )
  2321   "RTN","IBC NEDE4",202 ,0)
  2322    ;;MENTAL  HEALTH
  2323   "RTN","IBC NEDE4",203 ,0)
  2324    ;;NO-FAUL T INSURANC E
  2325   "RTN","IBC NEDE4",204 ,0)
  2326    ;;PRESCRI PTION
  2327   "RTN","IBC NEDE4",205 ,0)
  2328    ;;QUALIFI ED IMPAIRM ENT INSURA NCE
  2329   "RTN","IBC NEDE4",206 ,0)
  2330    ;;SPECIAL  CLASS INS URANCE
  2331   "RTN","IBC NEDE4",207 ,0)
  2332    ;;SPECIAL  RISK INSU RANCE
  2333   "RTN","IBC NEDE4",208 ,0)
  2334    ;;SPECIFI ED DISEASE  INSURANCE
  2335   "RTN","IBC NEDE4",209 ,0)
  2336    ;;Substan ce abuse o nly
  2337   "RTN","IBC NEDE4",210 ,0)
  2338    ;;TORT FE ASOR
  2339   "RTN","IBC NEDE4",211 ,0)
  2340    ;;TRICARE
  2341   "RTN","IBC NEDE4",212 ,0)
  2342    ;;TRICARE  SUPPLEMEN TAL
  2343   "RTN","IBC NEDE4",213 ,0)
  2344    ;;VA SPEC IAL CLASS
  2345   "RTN","IBC NEDE4",214 ,0)
  2346    ;;VISION
  2347   "RTN","IBC NEDE4",215 ,0)
  2348    ;;WORKERS ' COMPENSA TION INSUR ANCE
  2349   "RTN","IBC NEDE4",216 ,0)
  2350    ;
  2351   "RTN","IBC NEDE4",217 ,0)
  2352    Q
  2353   "RTN","IBC NEDE4",218 ,0)
  2354    ;
  2355   "RTN","IBC NEHL3")
  2356   0^20^B1729 50682^B172 154152
  2357   "RTN","IBC NEHL3",1,0 )
  2358   IBCNEHL3 ; DAOU/ALA -  HL7 Proce ss Incomin g RPI Cont inued ;03- JUL-2002   ; Compiled  June 2, 2 005 14:20: 19
  2359   "RTN","IBC NEHL3",2,0 )
  2360    ;;2.0;INT EGRATED BI LLING;**30 0,416,497, 506,595,62 1,602**;21 -MAR-94;Bu ild 22
  2361   "RTN","IBC NEHL3",3,0 )
  2362    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  2363   "RTN","IBC NEHL3",4,0 )
  2364    ;
  2365   "RTN","IBC NEHL3",5,0 )
  2366    ;**Progra m Descript ion**
  2367   "RTN","IBC NEHL3",6,0 )
  2368    ;  This i s a contin uation of  IBCNEHL1 w hich proce sses an in coming
  2369   "RTN","IBC NEHL3",7,0 )
  2370    ;  RPI II V message.
  2371   "RTN","IBC NEHL3",8,0 )
  2372    ;  
  2373   "RTN","IBC NEHL3",9,0 )
  2374    ;  This r outine is  based on I BCNEHLS wh ich was in troduced w ith patch  184, and s ubsequentl y
  2375   "RTN","IBC NEHL3",10, 0)
  2376    ;  patche d with pat ch 271.  I BCNEHLS is  obsolete  and delete d with pat ch 300.
  2377   "RTN","IBC NEHL3",11, 0)
  2378    ;
  2379   "RTN","IBC NEHL3",12, 0)
  2380    Q   ; no  direct cal ls allow
  2381   "RTN","IBC NEHL3",13, 0)
  2382    ;
  2383   "RTN","IBC NEHL3",14, 0)
  2384   ERROR(TQN, ERACT,ERCO N,TRCN) ;  Entry poin t
  2385   "RTN","IBC NEHL3",15, 0)
  2386    ; Input:   TQN - IEN  for eIV T ransmissio n Queue (# 365.1), re quired
  2387   "RTN","IBC NEHL3",16, 0)
  2388    ;          ERACT - E rror Actio n Code (#3 65.14), re quired
  2389   "RTN","IBC NEHL3",17, 0)
  2390    ;          ERCON - E rror Condi tion Code  (#365.17),  required
  2391   "RTN","IBC NEHL3",18, 0)
  2392    ;          TRCN - Tr ace # from  eIV Respo nse (#365)
  2393   "RTN","IBC NEHL3",19, 0)
  2394    ;
  2395   "RTN","IBC NEHL3",20, 0)
  2396    ;          IIVSTAT -  IIV statu s transmit ted by EC
  2397   "RTN","IBC NEHL3",21, 0)
  2398    ;                     Note: MAP (IIVSTAT)  = IIV STAT US IEN
  2399   "RTN","IBC NEHL3",22, 0)
  2400    N MSG,ERD ESC,ERIEN, XMY,DA,DIE ,DR
  2401   "RTN","IBC NEHL3",23, 0)
  2402    ;
  2403   "RTN","IBC NEHL3",24, 0)
  2404    I $G(TQN) ="" G ERRO RX
  2405   "RTN","IBC NEHL3",25, 0)
  2406    ;
  2407   "RTN","IBC NEHL3",26, 0)
  2408    ;/Removed  the follo wing lines  of code a s part of  IB*2.0*506  but wante d to
  2409   "RTN","IBC NEHL3",27, 0)
  2410    ;/leave t his code a vailable i f it shoul d be neede d in the f uture.
  2411   "RTN","IBC NEHL3",28, 0)
  2412    ; Scenari os:
  2413   "RTN","IBC NEHL3",29, 0)
  2414    ; #1 - If  error mes sage = "Re submission  Allowed"  OR "Please  Resubmit
  2415   "RTN","IBC NEHL3",30, 0)
  2416    ; Origina l Transact ion" - set  TQ
  2417   "RTN","IBC NEHL3",31, 0)
  2418    ; Fut Tra ns Dt to T  + Comm Fa ilure Days  and Statu s to "Hold "
  2419   "RTN","IBC NEHL3",32, 0)
  2420    ;I ERACT= "R"!(ERACT ="P") D G  ERRORX
  2421   "RTN","IBC NEHL3",33, 0)
  2422    ;. I $P($ G(^IBCN(36 5.1,TQN,0) ),U,9)=""  D Q ; firs t time pay er asked u s to resub mit
  2423   "RTN","IBC NEHL3",34, 0)
  2424    ;. . ; Up date IIV T Q fields:  "Hold" (4) , IIV Site  Param Com m Failure  Days
  2425   "RTN","IBC NEHL3",35, 0)
  2426    ;. . D UP DATE(TQN,4 ,+$P($G(^I BE(350.9,1 ,51)),U,5) ,ERACT)
  2427   "RTN","IBC NEHL3",36, 0)
  2428    ;. . ;
  2429   "RTN","IBC NEHL3",37, 0)
  2430    ;. ; paye r asked us  to resubm it for the  2nd time  for this i nquiry
  2431   "RTN","IBC NEHL3",38, 0)
  2432    ;. ; Upda te IIV TQ  fields: "R esponse Re ceived" (3 ), n/a ("" )
  2433   "RTN","IBC NEHL3",39, 0)
  2434    ;. D UPDA TE(TQN,3," ",ERACT,ER CON)
  2435   "RTN","IBC NEHL3",40, 0)
  2436    ;. ; clea r future t ransmissio n date so  it won't d isplay in  the buffer
  2437   "RTN","IBC NEHL3",41, 0)
  2438    ;. S DA=T QN,DIE="^I BCN(365.1, ",DR=".09/ //@" D ^DI E
  2439   "RTN","IBC NEHL3",42, 0)
  2440    ;
  2441   "RTN","IBC NEHL3",43, 0)
  2442    ; #2 - If  error mes sage = "Pl ease Wait  30 Days an d Resubmit " - set TQ
  2443   "RTN","IBC NEHL3",44, 0)
  2444    ; Fut Tra ns Dt to T  + 30 and  Status to  "Hold"
  2445   "RTN","IBC NEHL3",45, 0)
  2446    ;I ERACT= "W" D G ER RORX
  2447   "RTN","IBC NEHL3",46, 0)
  2448    ;. ; Upda te IIV TQ  fields: "H old" (4),  30
  2449   "RTN","IBC NEHL3",47, 0)
  2450    ;. D UPDA TE(TQN,4,3 0,ERACT)
  2451   "RTN","IBC NEHL3",48, 0)
  2452    ;
  2453   "RTN","IBC NEHL3",49, 0)
  2454    ; #3 - If  error mes sage = "Pl ease Wait  10 Days an d Resubmit " - set TQ
  2455   "RTN","IBC NEHL3",50, 0)
  2456    ; Fut Tra ns Dt to T  + 10 and  Status to  "Hold"
  2457   "RTN","IBC NEHL3",51, 0)
  2458    ;I ERACT= "X" D G ER RORX
  2459   "RTN","IBC NEHL3",52, 0)
  2460    ;. ; Upda te IIV TQ  fields: "H old" (4),  10
  2461   "RTN","IBC NEHL3",53, 0)
  2462    ;. D UPDA TE(TQN,4,1 0,ERACT)
  2463   "RTN","IBC NEHL3",54, 0)
  2464    ;
  2465   "RTN","IBC NEHL3",55, 0)
  2466    ; #4 - If  error mes sage = "Re submission  Not Allow ed" or
  2467   "RTN","IBC NEHL3",56, 0)
  2468    ; "Do not  resubmit  ...." OR " Please cor rect and r esubmit"
  2469   "RTN","IBC NEHL3",57, 0)
  2470    ; - set T Q Status t o "Respons e Received "
  2471   "RTN","IBC NEHL3",58, 0)
  2472    ; If we r eceive err or txt, tr eat as an  "N"
  2473   "RTN","IBC NEHL3",59, 0)
  2474    ;I ERACT= "" S ERACT ="N"
  2475   "RTN","IBC NEHL3",60, 0)
  2476    ;I ERACT= "N"!(ERACT ="Y")!(ERA CT="S")!(E RACT="C")  D G ERRORX
  2477   "RTN","IBC NEHL3",61, 0)
  2478    ;. ; Upda te IIV TQ  fields: "R esponse Re ceived" (3 ), n/a ("" )
  2479   "RTN","IBC NEHL3",62, 0)
  2480    ;. D UPDA TE(TQN,3," ",ERACT,ER CON)
  2481   "RTN","IBC NEHL3",63, 0)
  2482    ;
  2483   "RTN","IBC NEHL3",64, 0)
  2484    ; #5 - Er ror messag e is unfam iliar - ne w Error Ac tion Code
  2485   "RTN","IBC NEHL3",65, 0)
  2486    ; *** Cur rently pro cessed in  IBCNEHL1 * **
  2487   "RTN","IBC NEHL3",66, 0)
  2488    ;/End of  removed co de for IB* 2.0*506
  2489   "RTN","IBC NEHL3",67, 0)
  2490    ;
  2491   "RTN","IBC NEHL3",68, 0)
  2492    ; /IB*2.0 *506 Begin ning
  2493   "RTN","IBC NEHL3",69, 0)
  2494    ; For all  Scenarios  1 thru 5,  set TQ St atus to "R esponse Re ceived"
  2495   "RTN","IBC NEHL3",70, 0)
  2496    I ERACT=" " S ERACT= "N"
  2497   "RTN","IBC NEHL3",71, 0)
  2498    I ",R,P,W ,X,N,Y,S,C ,"[(","_ER ACT_",") D   G ERRORX
  2499   "RTN","IBC NEHL3",72, 0)
  2500    . ; Updat e IIV TQ f ields: "Re sponse Rec eived" (3) , n/a ("")
  2501   "RTN","IBC NEHL3",73, 0)
  2502    . D UPDAT E(TQN,3,"" ,ERACT,ERC ON)
  2503   "RTN","IBC NEHL3",74, 0)
  2504    ; /IB*2.0 *506 End
  2505   "RTN","IBC NEHL3",75, 0)
  2506    ;
  2507   "RTN","IBC NEHL3",76, 0)
  2508   ERRORX ; E RROR exit  pt
  2509   "RTN","IBC NEHL3",77, 0)
  2510    Q
  2511   "RTN","IBC NEHL3",78, 0)
  2512    ;
  2513   "RTN","IBC NEHL3",79, 0)
  2514   UPDATE(TQN ,TSTS,TDAY S,ERACT,ER CON) ;  Up date Trans mission Qu eue (#365. 1)
  2515   "RTN","IBC NEHL3",80, 0)
  2516    ; Update/ Create Buf fer inform ation as n ecessary
  2517   "RTN","IBC NEHL3",81, 0)
  2518    ; * If un solicited  error or n egative Ve rification  response  do not
  2519   "RTN","IBC NEHL3",82, 0)
  2520    ; update  TQ entry.   However,  create a n ew Buffer  entry.
  2521   "RTN","IBC NEHL3",83, 0)
  2522    ; Input V ariables
  2523   "RTN","IBC NEHL3",84, 0)
  2524    ; ERACT,E RCON,IIVST AT,TDAYS,T QN,TSTS
  2525   "RTN","IBC NEHL3",85, 0)
  2526    ;
  2527   "RTN","IBC NEHL3",86, 0)
  2528    ; Output  Variables
  2529   "RTN","IBC NEHL3",87, 0)
  2530    ; IIVSTAT  (updated)
  2531   "RTN","IBC NEHL3",88, 0)
  2532    ;
  2533   "RTN","IBC NEHL3",89, 0)
  2534    ; Init op tional par am
  2535   "RTN","IBC NEHL3",90, 0)
  2536    S ERCON=$ G(ERCON)
  2537   "RTN","IBC NEHL3",91, 0)
  2538    ;
  2539   "RTN","IBC NEHL3",92, 0)
  2540    ; Init va rs
  2541   "RTN","IBC NEHL3",93, 0)
  2542    N D,D0,DA ,DFN,DI,DI C,DIE,DQ,D R,FTDT,IBD ATA,IBIEN, IBQFL,IBST S,IBSYM
  2543   "RTN","IBC NEHL3",94, 0)
  2544    N INSIEN, RSTYPE,SYM BOL,TQDATA ,X
  2545   "RTN","IBC NEHL3",95, 0)
  2546    ;
  2547   "RTN","IBC NEHL3",96, 0)
  2548    ; If no Z EB segment  received,  set IIVST AT to "V"
  2549   "RTN","IBC NEHL3",97, 0)
  2550    I $TR(IIV STAT," ")= "" S IIVST AT="V"
  2551   "RTN","IBC NEHL3",98, 0)
  2552    ;
  2553   "RTN","IBC NEHL3",99, 0)
  2554    S TQDATA= $G(^IBCN(3 65.1,TQN,0 ))
  2555   "RTN","IBC NEHL3",100 ,0)
  2556    I TQDATA= "" G UPDAT X
  2557   "RTN","IBC NEHL3",101 ,0)
  2558    ;
  2559   "RTN","IBC NEHL3",102 ,0)
  2560    ; Ins Buf fer IEN
  2561   "RTN","IBC NEHL3",103 ,0)
  2562    S IBIEN=$ P(TQDATA,U ,5)
  2563   "RTN","IBC NEHL3",104 ,0)
  2564    S IBQFL=$ P(TQDATA,U ,11)
  2565   "RTN","IBC NEHL3",105 ,0)
  2566    S RSTYPE= $P($G(^IBC N(365,RIEN ,0)),U,10)
  2567   "RTN","IBC NEHL3",106 ,0)
  2568    ;
  2569   "RTN","IBC NEHL3",107 ,0)
  2570    ; If unso licited er ror or neg ative Iden tification  response  DON'T
  2571   "RTN","IBC NEHL3",108 ,0)
  2572    ; update  TQ entry o r Buffer ( includes n ot creatin g a new bu ffer)
  2573   "RTN","IBC NEHL3",109 ,0)
  2574    I RSTYPE= "U",(IBQFL ="I") G UP DATX
  2575   "RTN","IBC NEHL3",110 ,0)
  2576    ;
  2577   "RTN","IBC NEHL3",111 ,0)
  2578    I RSTYPE= "U" S IBIE N=""  ; ma kes sure a  new buffe r is creat ed
  2579   "RTN","IBC NEHL3",112 ,0)
  2580    ;
  2581   "RTN","IBC NEHL3",113 ,0)
  2582    ; Ins Buf fer proces sing
  2583   "RTN","IBC NEHL3",114 ,0)
  2584    I IBIEN'= "" D
  2585   "RTN","IBC NEHL3",115 ,0)
  2586    . ; Ins B uf data
  2587   "RTN","IBC NEHL3",116 ,0)
  2588    . S IBDAT A=$G(^IBA( 355.33,+IB IEN,0))
  2589   "RTN","IBC NEHL3",117 ,0)
  2590    . S IBSTS =$P(IBDATA ,U,4)   ;  Status
  2591   "RTN","IBC NEHL3",118 ,0)
  2592    . S IBSYM =$P(IBDATA ,U,12)  ;  Symbol
  2593   "RTN","IBC NEHL3",119 ,0)
  2594    . ; If IB  status is  (A)ccepte d or (R)ej ected or I B symbol i s "*"
  2595   "RTN","IBC NEHL3",120 ,0)
  2596    . ;  (ver ified) or  IB symbol  is "-" (de nied), upd ate TQ sta tus to
  2597   "RTN","IBC NEHL3",121 ,0)
  2598    . ;  Resp  Rec'd (3)  and DON'T  update th e Ins Buff er symbol
  2599   "RTN","IBC NEHL3",122 ,0)
  2600    . I IBSTS ="A"!(IBST S="R")!(IB SYM=8)!(IB SYM=9) S T STS=3 Q
  2601   "RTN","IBC NEHL3",123 ,0)
  2602    . ; If TQ  status is  "Hold", u pdate buff er symbol  to "?" (10 )
  2603   "RTN","IBC NEHL3",124 ,0)
  2604    . I TSTS= 4 D BUFF^I BCNEUT2(IB IEN,10) Q   ; Set buf fer symbol  to "?"
  2605   "RTN","IBC NEHL3",125 ,0)
  2606    . ; If TQ  status is  "Response  Received" , update b uffer symb ol to "-"  (9) for Er ror
  2607   "RTN","IBC NEHL3",126 ,0)
  2608    . ; Actio n Codes (' N','Y','S' ) & Action  Codes ('P ','R', if  2nd time p ayer sent  that code)
  2609   "RTN","IBC NEHL3",127 ,0)
  2610    . I TSTS= 3,(ERACT=" N"!(ERACT= "Y")!(ERAC T="S")!(ER ACT="C")!( ERACT="P") !(ERACT="R ")) D  Q
  2611   "RTN","IBC NEHL3",128 ,0)
  2612    .. S SYMB OL=MAP(IIV STAT)
  2613   "RTN","IBC NEHL3",129 ,0)
  2614    .. D BUFF ^IBCNEUT2( IBIEN,SYMB OL) ; Set  buffer sym bol to EC  value
  2615   "RTN","IBC NEHL3",130 ,0)
  2616    .. D IIVP ROC(IBIEN)    ; Set I IV process  date & II V status
  2617   "RTN","IBC NEHL3",131 ,0)
  2618    . ; If TQ  status is  "Response  Received" , update b uffer symb ol to "!"  (12 = B9)  for new Er ror Action  Code
  2619   "RTN","IBC NEHL3",132 ,0)
  2620    . I TSTS= 3,",W,X,R, P,C,N,Y,S, "'[(","_ER ACT_",") D  BUFF^IBCN EUT2(IBIEN ,22) Q
  2621   "RTN","IBC NEHL3",133 ,0)
  2622    ;
  2623   "RTN","IBC NEHL3",134 ,0)
  2624    ; Non-Ins  Buffer pr ocessing,  create ent ry only fo r Verifica tion queri es
  2625   "RTN","IBC NEHL3",135 ,0)
  2626    I IBIEN=" ",IBQFL="V " D
  2627   "RTN","IBC NEHL3",136 ,0)
  2628    . ; Deter mine Patie nt DFN
  2629   "RTN","IBC NEHL3",137 ,0)
  2630    . S DFN=$ P(TQDATA,U ,2)
  2631   "RTN","IBC NEHL3",138 ,0)
  2632    . ; Deter mine Patie nt Ins rec ord IEN
  2633   "RTN","IBC NEHL3",139 ,0)
  2634    . S INSIE N=$P(TQDAT A,U,13)  ;  If INSIEN ="" avoids  TQ update
  2635   "RTN","IBC NEHL3",140 ,0)
  2636    . ; If ER ACT="C" sy mbol is pa ssed by EC
  2637   "RTN","IBC NEHL3",141 ,0)
  2638    . I ERACT ="C" S SYM BOL=MAP(II VSTAT) D B UF Q
  2639   "RTN","IBC NEHL3",142 ,0)
  2640    . ;  Resu bmission N ot Allowed  or Do Not  Resubmit  ...
  2641   "RTN","IBC NEHL3",143 ,0)
  2642    . I ERACT ="N"!(ERAC T="Y")!(ER ACT="S") S  SYMBOL=MA P(IIVSTAT)  D BUF Q
  2643   "RTN","IBC NEHL3",144 ,0)
  2644    . ; An un known erro r action -  generate  a '#'
  2645   "RTN","IBC NEHL3",145 ,0)
  2646    . I ",W,X ,R,P,C,N,Y ,S,"'[("," _ERACT_"," ) S SYMBOL =22 D BUF  Q
  2647   "RTN","IBC NEHL3",146 ,0)
  2648    ;
  2649   "RTN","IBC NEHL3",147 ,0)
  2650    I RSTYPE= "U" G UPDA TX  ; fini shed creat ing new bu ffer
  2651   "RTN","IBC NEHL3",148 ,0)
  2652    ;
  2653   "RTN","IBC NEHL3",149 ,0)
  2654    ; Update  TQ record  - Status
  2655   "RTN","IBC NEHL3",150 ,0)
  2656    D SST^IBC NEUT2(TQN, TSTS)
  2657   "RTN","IBC NEHL3",151 ,0)
  2658    ;
  2659   "RTN","IBC NEHL3",152 ,0)
  2660    ; If TQ S tatus = "H old", upda te TQ reco rd - Futur e Transmis sion Date
  2661   "RTN","IBC NEHL3",153 ,0)
  2662    I TSTS=4, +$G(TDAYS)  D
  2663   "RTN","IBC NEHL3",154 ,0)
  2664    . S FTDT= $$FMADD^XL FDT($$DT^X LFDT,TDAYS )
  2665   "RTN","IBC NEHL3",155 ,0)
  2666    . S DIE=" ^IBCN(365. 1,",DA=TQN ,DR=".09// /^S X=FTDT "
  2667   "RTN","IBC NEHL3",156 ,0)
  2668    . D ^DIE
  2669   "RTN","IBC NEHL3",157 ,0)
  2670    I TSTS=4, $P(TQDATA, U,8) D
  2671   "RTN","IBC NEHL3",158 ,0)
  2672    . S DIE=" ^IBCN(365. 1,",DA=TQN ,DR=".08// /0"
  2673   "RTN","IBC NEHL3",159 ,0)
  2674    . D ^DIE
  2675   "RTN","IBC NEHL3",160 ,0)
  2676    ;
  2677   "RTN","IBC NEHL3",161 ,0)
  2678   UPDATX ; U PDATE exit  point
  2679   "RTN","IBC NEHL3",162 ,0)
  2680    Q
  2681   "RTN","IBC NEHL3",163 ,0)
  2682    ;
  2683   "RTN","IBC NEHL3",164 ,0)
  2684   PCK ; Paye r Check
  2685   "RTN","IBC NEHL3",165 ,0)
  2686    ;  Find t he associa ted Respon se IEN
  2687   "RTN","IBC NEHL3",166 ,0)
  2688    ;
  2689   "RTN","IBC NEHL3",167 ,0)
  2690    ; Input V ariables
  2691   "RTN","IBC NEHL3",168 ,0)
  2692    ; MSGID
  2693   "RTN","IBC NEHL3",169 ,0)
  2694    ;
  2695   "RTN","IBC NEHL3",170 ,0)
  2696    ; Output  Variables
  2697   "RTN","IBC NEHL3",171 ,0)
  2698    ; RIEN,ER FLG
  2699   "RTN","IBC NEHL3",172 ,0)
  2700    ;
  2701   "RTN","IBC NEHL3",173 ,0)
  2702    N BUFF,DA ,DFN,DIE,D R,IEN,IERN ,IN1DATA,M DTM,QFL,PA YR,PIEN,PP
  2703   "RTN","IBC NEHL3",174 ,0)
  2704    N PRDATA, PRIEN,RSIE N,X
  2705   "RTN","IBC NEHL3",175 ,0)
  2706    N NOPAYER ,TQIEN
  2707   "RTN","IBC NEHL3",176 ,0)
  2708    ;
  2709   "RTN","IBC NEHL3",177 ,0)
  2710    K ^TMP("I BCNEMID",$ J)
  2711   "RTN","IBC NEHL3",178 ,0)
  2712    D FIND^DI C(365,""," ","P",MSGI D,"","B"," ","","^TMP (""IBCNEMI D"",$J)")
  2713   "RTN","IBC NEHL3",179 ,0)
  2714    ;
  2715   "RTN","IBC NEHL3",180 ,0)
  2716    S PP=0,QF L=0,(RIEN, PIEN)=""
  2717   "RTN","IBC NEHL3",181 ,0)
  2718    S NOPAYER =$$FIND1^D IC(365.12, ,"X","~NO  PAYER"),TQ IEN=$O(^IB CN(365.1," C",MSGID," "))
  2719   "RTN","IBC NEHL3",182 ,0)
  2720    F  S PP=$ O(^TMP("IB CNEMID",$J ,"DILIST", PP)) Q:'PP   D  Q:QFL
  2721   "RTN","IBC NEHL3",183 ,0)
  2722    . S PRIEN =$P(^TMP(" IBCNEMID", $J,"DILIST ",PP,0),U, 1)
  2723   "RTN","IBC NEHL3",184 ,0)
  2724    . ;
  2725   "RTN","IBC NEHL3",185 ,0)
  2726    . ;  If t his is a r esponse w/ o an IN1 s egment
  2727   "RTN","IBC NEHL3",186 ,0)
  2728    . ;  Get  payer IEN  from TQ as  original  response s hell will  change for
  2729   "RTN","IBC NEHL3",187 ,0)
  2730    . ;  ~NO  PAYER if a  payer res ponse is r eceived
  2731   "RTN","IBC NEHL3",188 ,0)
  2732    . S IN1DA TA=$S(EVEN TYP=1:"",1 :$$GIN1())  ; IB*2.0* 621
  2733   "RTN","IBC NEHL3",189 ,0)
  2734    . I IN1DA TA="",PRIE N'="",TQIE N'="" D
  2735   "RTN","IBC NEHL3",190 ,0)
  2736    ..  S QFL =1,PIEN=$P (^IBCN(365 .1,TQIEN,0 ),U,3)
  2737   "RTN","IBC NEHL3",191 ,0)
  2738    . ;
  2739   "RTN","IBC NEHL3",192 ,0)
  2740    . I 'PIEN  D PFN(IN1 DATA) I 'P IEN S QFL= 1 Q
  2741   "RTN","IBC NEHL3",193 ,0)
  2742    . ;
  2743   "RTN","IBC NEHL3",194 ,0)
  2744    . ; If me ssage id/p ayer found  & Respons e (#365) s tatus is N OT
  2745   "RTN","IBC NEHL3",195 ,0)
  2746    . ; 'Resp onse Recei ved' updat e the exis ting respo nse entry  (set RIEN)
  2747   "RTN","IBC NEHL3",196 ,0)
  2748    . I $P(^I BCN(365,PR IEN,0),U,3 )=PIEN,($P (^IBCN(365 ,PRIEN,0), U,6)'=3) D   Q
  2749   "RTN","IBC NEHL3",197 ,0)
  2750    .. S RIEN =PRIEN,QFL =1
  2751   "RTN","IBC NEHL3",198 ,0)
  2752    ..;
  2753   "RTN","IBC NEHL3",199 ,0)
  2754    ..; If me ssage id/p ayer found  & Respons e (#365) s tatus equa ls
  2755   "RTN","IBC NEHL3",200 ,0)
  2756    . ; 'Resp onse Recei ved', RIEN  is still  null so th at this ta g knows
  2757   "RTN","IBC NEHL3",201 ,0)
  2758    . ; to cr eate a new  unsolicit ed respons e entry
  2759   "RTN","IBC NEHL3",202 ,0)
  2760    . ; 
  2761   "RTN","IBC NEHL3",203 ,0)
  2762    . ; If pa yer respon se receive d to ~NO P AYER, upda te eIV Res ponse file
  2763   "RTN","IBC NEHL3",204 ,0)
  2764    . ; w/ re sponding p ayer
  2765   "RTN","IBC NEHL3",205 ,0)
  2766    . I RIEN= "" S PRDAT A=$G(^IBCN (365,PRIEN ,0)) I $P( PRDATA,U,3 )=NOPAYER, $P(PRDATA, U,6)'=3,$P (PRDATA,U, 10)="O" D   Q
  2767   "RTN","IBC NEHL3",206 ,0)
  2768    .. S RIEN =PRIEN,QFL =1
  2769   "RTN","IBC NEHL3",207 ,0)
  2770    .. S DIE= "^IBCN(365 ,",DA=RIEN ,DR=".03// /^S X=PIEN " D ^DIE
  2771   "RTN","IBC NEHL3",208 ,0)
  2772    ;
  2773   "RTN","IBC NEHL3",209 ,0)
  2774    ;  If mes sage id/pa yer not fo und or uns olicited r esponse, c reate new  response e ntry
  2775   "RTN","IBC NEHL3",210 ,0)
  2776    I RIEN=""  D  Q:ERFL G
  2777   "RTN","IBC NEHL3",211 ,0)
  2778    . I $G(PR IEN)'="" D
  2779   "RTN","IBC NEHL3",212 ,0)
  2780    .. S PRDA TA=$G(^IBC N(365,PRIE N,0))
  2781   "RTN","IBC NEHL3",213 ,0)
  2782    .. S DFN= $P(PRDATA, U,2),IEN=$ P(PRDATA,U ,5),MDTM=$ P(PRDATA,U ,8)
  2783   "RTN","IBC NEHL3",214 ,0)
  2784    . ;
  2785   "RTN","IBC NEHL3",215 ,0)
  2786    . I PIEN= "" D  Q:ER FLG
  2787   "RTN","IBC NEHL3",216 ,0)
  2788    ..  S IN1 DATA=$$GIN 1()
  2789   "RTN","IBC NEHL3",217 ,0)
  2790    ..  I IN1 DATA]"" D  PFN(IN1DAT A) I 'PIEN  S PIEN="" ,QFL=1
  2791   "RTN","IBC NEHL3",218 ,0)
  2792    . S PAYR= PIEN,(RSTY PE,BUFF)=" "
  2793   "RTN","IBC NEHL3",219 ,0)
  2794    . ;I MDTM ="" S MDTM =$$NOW^XLF DT
  2795   "RTN","IBC NEHL3",220 ,0)
  2796    . D RESP^ IBCNEDEQ
  2797   "RTN","IBC NEHL3",221 ,0)
  2798    . S RIEN= RSIEN
  2799   "RTN","IBC NEHL3",222 ,0)
  2800    ;
  2801   "RTN","IBC NEHL3",223 ,0)
  2802    ; If no p ayer in re sponse fil e, set it
  2803   "RTN","IBC NEHL3",224 ,0)
  2804    ; IB*2*59 5/DM corre ctly ident ify a paye r when the  payer nam e begins w ith number
  2805   "RTN","IBC NEHL3",225 ,0)
  2806    I $G(PIEN )'="",$G(R IEN)'="",$ P($G(^IBCN (365,RIEN, 0)),U,3)=" " D
  2807   "RTN","IBC NEHL3",226 ,0)
  2808    . S DIE=" ^IBCN(365, ",DA=RIEN, DR=".03/// /^S X=PIEN " D ^DIE ; stuff inte rnal value  for payer
  2809   "RTN","IBC NEHL3",227 ,0)
  2810    Q
  2811   "RTN","IBC NEHL3",228 ,0)
  2812    ;
  2813   "RTN","IBC NEHL3",229 ,0)
  2814   BUF ; Crea te Buffer  Record if  Doesn't Ex ist
  2815   "RTN","IBC NEHL3",230 ,0)
  2816    ;
  2817   "RTN","IBC NEHL3",231 ,0)
  2818    ; Input V ariables
  2819   "RTN","IBC NEHL3",232 ,0)
  2820    ; RIEN,RS TYPE,TQN
  2821   "RTN","IBC NEHL3",233 ,0)
  2822    ;
  2823   "RTN","IBC NEHL3",234 ,0)
  2824    ; Output  Variables
  2825   "RTN","IBC NEHL3",235 ,0)
  2826    ; ERROR,S YMBOL is k illed,TQIE N and IRIE N may be r eset
  2827   "RTN","IBC NEHL3",236 ,0)
  2828    ;
  2829   "RTN","IBC NEHL3",237 ,0)
  2830    N BUFF,IB FDA,UP
  2831   "RTN","IBC NEHL3",238 ,0)
  2832    I $G(RSTY PE)="U" S  (TQIEN,IRI EN)=""
  2833   "RTN","IBC NEHL3",239 ,0)
  2834    D RP^IBCN EBF(RIEN,1 )
  2835   "RTN","IBC NEHL3",240 ,0)
  2836    S BUFF=+I BFDA
  2837   "RTN","IBC NEHL3",241 ,0)
  2838    S UP(365, RIEN_",",. 04)=+IBFDA
  2839   "RTN","IBC NEHL3",242 ,0)
  2840    I RSTYPE= "O" S UP(3 65.1,TQN_" ,",.05)=+I BFDA
  2841   "RTN","IBC NEHL3",243 ,0)
  2842    D FILE^DI E("I","UP" ,"ERROR")
  2843   "RTN","IBC NEHL3",244 ,0)
  2844    K SYMBOL
  2845   "RTN","IBC NEHL3",245 ,0)
  2846    Q
  2847   "RTN","IBC NEHL3",246 ,0)
  2848    ;
  2849   "RTN","IBC NEHL3",247 ,0)
  2850   IIVPROC(BU FF) ; Set  IIV Proces sed Date t o current  dt/tm & II V stat (ak a SYMBOL)
  2851   "RTN","IBC NEHL3",248 ,0)
  2852    ; Input V ariables
  2853   "RTN","IBC NEHL3",249 ,0)
  2854    ; BUFF
  2855   "RTN","IBC NEHL3",250 ,0)
  2856    ;
  2857   "RTN","IBC NEHL3",251 ,0)
  2858    ; Output  Variables
  2859   "RTN","IBC NEHL3",252 ,0)
  2860    ; SYMBOL
  2861   "RTN","IBC NEHL3",253 ,0)
  2862    ;
  2863   "RTN","IBC NEHL3",254 ,0)
  2864    N IDUZ,UP
  2865   "RTN","IBC NEHL3",255 ,0)
  2866    S UP(355. 33,BUFF_", ",.15)=$$N OW^XLFDT()
  2867   "RTN","IBC NEHL3",256 ,0)
  2868    ;  Set ID UZ to the  specific,  non-human  user.
  2869   "RTN","IBC NEHL3",257 ,0)
  2870    S IDUZ=$$ FIND1^DIC( 200,"","X" ,"INTERFAC E,IB EIV")
  2871   "RTN","IBC NEHL3",258 ,0)
  2872    D FILE^DI E("I","UP" ,"ERROR")
  2873   "RTN","IBC NEHL3",259 ,0)
  2874    ; set the  symbol of  the buffe r entry
  2875   "RTN","IBC NEHL3",260 ,0)
  2876    D BUFF^IB CNEUT2(BUF F,SYMBOL)   ; reset s ymbol to a ppropriate  value
  2877   "RTN","IBC NEHL3",261 ,0)
  2878    Q
  2879   "RTN","IBC NEHL3",262 ,0)
  2880    ;
  2881   "RTN","IBC NEHL3",263 ,0)
  2882   PFN(IN1DAT A) ;  Find  Payer fro m HL7 msg
  2883   "RTN","IBC NEHL3",264 ,0)
  2884    ;
  2885   "RTN","IBC NEHL3",265 ,0)
  2886    ; Input V ariables
  2887   "RTN","IBC NEHL3",266 ,0)
  2888    ; IN1DATA , TRACE
  2889   "RTN","IBC NEHL3",267 ,0)
  2890    ;
  2891   "RTN","IBC NEHL3",268 ,0)
  2892    ; Output  Variables
  2893   "RTN","IBC NEHL3",269 ,0)
  2894    ; ERFLG,E RROR,PIEN
  2895   "RTN","IBC NEHL3",270 ,0)
  2896    ;
  2897   "RTN","IBC NEHL3",271 ,0)
  2898    N IERN,PA YRID
  2899   "RTN","IBC NEHL3",272 ,0)
  2900    S PAYRID= $$CLNSTR^I BCNEHLU($P ($P(IN1DAT A,HLFS,4), $E(HL("ECH "))),HL("E CH"),$E(HL ("ECH")))
  2901   "RTN","IBC NEHL3",273 ,0)
  2902    S PIEN=+$ $FIND1^DIC (365.12,"" ,"MX",PAYR ID)
  2903   "RTN","IBC NEHL3",274 ,0)
  2904    I PIEN=0  D  Q
  2905   "RTN","IBC NEHL3",275 ,0)
  2906    . S ERFLG =1,IERN=$$ ERRN^IBCNE UT7("ERROR (""DIERR"" )")
  2907   "RTN","IBC NEHL3",276 ,0)
  2908    . S ERROR ("DIERR",I ERN,"TEXT" ,1)="Natio nal Id: "_ PAYRID_" n ot found i n Payer Ta ble"
  2909   "RTN","IBC NEHL3",277 ,0)
  2910    . S ERROR ("DIERR",I ERN,"TEXT" ,2)="for T race Numbe r: "_TRACE
  2911   "RTN","IBC NEHL3",278 ,0)
  2912    Q
  2913   "RTN","IBC NEHL3",279 ,0)
  2914    ;
  2915   "RTN","IBC NEHL3",280 ,0)
  2916   GIN1() ;Ge t IN1 segm ent
  2917   "RTN","IBC NEHL3",281 ,0)
  2918    ;
  2919   "RTN","IBC NEHL3",282 ,0)
  2920    ; Input V ariables
  2921   "RTN","IBC NEHL3",283 ,0)
  2922    ; HCT
  2923   "RTN","IBC NEHL3",284 ,0)
  2924    ;
  2925   "RTN","IBC NEHL3",285 ,0)
  2926    ; Returns  value of  SEGMT
  2927   "RTN","IBC NEHL3",286 ,0)
  2928    ;
  2929   "RTN","IBC NEHL3",287 ,0)
  2930    N IPCT,SE GMT
  2931   "RTN","IBC NEHL3",288 ,0)
  2932    S IPCT=HC T,SEGMT=""
  2933   "RTN","IBC NEHL3",289 ,0)
  2934    F  S IPCT =$O(^TMP($ J,"IBCNEHL I",IPCT))  Q:IPCT=""   D
  2935   "RTN","IBC NEHL3",290 ,0)
  2936    . I $E(^T MP($J,"IBC NEHLI",IPC T,0),1,3)= "IN1" S SE GMT=^TMP($ J,"IBCNEHL I",IPCT,0)
  2937   "RTN","IBC NEHL3",291 ,0)
  2938    Q SEGMT
  2939   "RTN","IBC NEHL3",292 ,0)
  2940    ;
  2941   "RTN","IBC NEHL3",293 ,0)
  2942    ; ======= ========== ========== ========== ========== ========== ========
  2943   "RTN","IBC NEHL3",294 ,0)
  2944   WARN ;  Cr eate and s end a resp onse proce ssing erro r warning  message
  2945   "RTN","IBC NEHL3",295 ,0)
  2946    ;
  2947   "RTN","IBC NEHL3",296 ,0)
  2948    ; Input V ariables
  2949   "RTN","IBC NEHL3",297 ,0)
  2950    ; ERROR,  TRACE
  2951   "RTN","IBC NEHL3",298 ,0)
  2952    ;
  2953   "RTN","IBC NEHL3",299 ,0)
  2954    ; Output  Variables
  2955   "RTN","IBC NEHL3",300 ,0)
  2956    ; ERFLG=1
  2957   "RTN","IBC NEHL3",301 ,0)
  2958    ;
  2959   "RTN","IBC NEHL3",302 ,0)
  2960    N MCT,MSG ,SUBCNT,VE N,XMY
  2961   "RTN","IBC NEHL3",303 ,0)
  2962    S VEN=0,M CT=9,ERFLG =1,SUBCNT= ""
  2963   "RTN","IBC NEHL3",304 ,0)
  2964    S MSG(1)= "IMPORTANT : Error Wh ile Proces sing Respo nse Messag e from the  EC"
  2965   "RTN","IBC NEHL3",305 ,0)
  2966    S MSG(2)= "--------- ---------- ---------- ---------- ---------- ---------- --"
  2967   "RTN","IBC NEHL3",306 ,0)
  2968    S MSG(3)= "*** IRM * ** Please  contact He lp Desk be cause the"
  2969   "RTN","IBC NEHL3",307 ,0)
  2970    S MSG(4)= "response  message re ceived fro m the Elig ibility Co mmunicator "
  2971   "RTN","IBC NEHL3",308 ,0)
  2972    S MSG(5)= "could not  be proces sed.  Prog ramming ch anges may  be necessa ry"
  2973   "RTN","IBC NEHL3",309 ,0)
  2974    S MSG(6)= "to proper ly handle  the respon se."
  2975   "RTN","IBC NEHL3",310 ,0)
  2976    S MSG(7)= "The assoc iated Trac e # is "_$ S($G(TRACE )="":"Unkn own",1:TRA CE)_". If  applicable ,"
  2977   "RTN","IBC NEHL3",311 ,0)
  2978    S MSG(8)= "please re view the r esponse wi th the eIV  Response  Report by  Trace#."
  2979   "RTN","IBC NEHL3",312 ,0)
  2980    S MSG(9)= " "
  2981   "RTN","IBC NEHL3",313 ,0)
  2982    F  S VEN= $O(ERROR(" DIERR",VEN )) Q:'VEN   D
  2983   "RTN","IBC NEHL3",314 ,0)
  2984    .S MCT=MC T+1,MSG(MC T)="Error: "
  2985   "RTN","IBC NEHL3",315 ,0)
  2986    .F  S SUB CNT=$O(ERR OR("DIERR" ,VEN,"TEXT ",SUBCNT))  Q:'SUBCNT   S MCT=MC T+1,MSG(MC T)=ERROR(" DIERR",VEN ,"TEXT",SU BCNT)
  2987   "RTN","IBC NEHL3",316 ,0)
  2988    .S MCT=MC T+1,MSG(MC T)=" "
  2989   "RTN","IBC NEHL3",317 ,0)
  2990    .I $G(ERR OR("DIERR" ,VEN,"PARA M","FILE") )'="" S MC T=MCT+1,MS G(MCT)="Fi le: "_ERRO R("DIERR", VEN,"PARAM ","FILE")
  2991   "RTN","IBC NEHL3",318 ,0)
  2992    .I $G(ERR OR("DIERR" ,VEN,"PARA M","IENS") )'="" S MC T=MCT+1,MS G(MCT)="IE NS: "_ERRO R("DIERR", VEN,"PARAM ","IENS")
  2993   "RTN","IBC NEHL3",319 ,0)
  2994    .I $G(ERR OR("DIERR" ,VEN,"PARA M","FIELD" ))'="" S M CT=MCT+1,M SG(MCT)="F ield: "_ER ROR("DIERR ",VEN,"PAR AM","FIELD ")
  2995   "RTN","IBC NEHL3",320 ,0)
  2996    .S MCT=MC T+1,MSG(MC T)=" "
  2997   "RTN","IBC NEHL3",321 ,0)
  2998    .Q
  2999   "RTN","IBC NEHL3",322 ,0)
  3000    D MSG^IBC NEUT5(MGRP ,MSG(1),"M SG(",,.XMY )
  3001   "RTN","IBC NEHL3",323 ,0)
  3002    Q
  3003   "RTN","IBC NEHL3",324 ,0)
  3004    ;
  3005   "RTN","IBC NEHL3",325 ,0)
  3006    ; ======= ========== ========== ========== ========== ========== ========
  3007   "RTN","IBC NEHL3",326 ,0)
  3008   UEACT ; Se nd warning  msg if Un known Erro r Action C ode was re ceived or
  3009   "RTN","IBC NEHL3",327 ,0)
  3010    ; encount ered probl em filing  date
  3011   "RTN","IBC NEHL3",328 ,0)
  3012    ;
  3013   "RTN","IBC NEHL3",329 ,0)
  3014    ; Input V ariables
  3015   "RTN","IBC NEHL3",330 ,0)
  3016    ; ERROR,  IBIEN, IBQ FL, RIEN,  RSTYPE, TQ DATA, TRAC E
  3017   "RTN","IBC NEHL3",331 ,0)
  3018    ;
  3019   "RTN","IBC NEHL3",332 ,0)
  3020    ; Output  Variables
  3021   "RTN","IBC NEHL3",333 ,0)
  3022    ; ERFLG=1  (SET IN W ARN TAG)
  3023   "RTN","IBC NEHL3",334 ,0)
  3024    ;
  3025   "RTN","IBC NEHL3",335 ,0)
  3026    N DFN,SYM BOL
  3027   "RTN","IBC NEHL3",336 ,0)
  3028    D WARN  ;  send warn ing msg
  3029   "RTN","IBC NEHL3",337 ,0)
  3030    ;
  3031   "RTN","IBC NEHL3",338 ,0)
  3032    ; If the  response c ould not b e created  or there i s no assoc iated TQ e ntry, stop  processin g
  3033   "RTN","IBC NEHL3",339 ,0)
  3034    I '$G(RIE N)!(TQDATA ="") Q
  3035   "RTN","IBC NEHL3",340 ,0)
  3036    ;
  3037   "RTN","IBC NEHL3",341 ,0)
  3038    ;  For an  original  response,  set the Tr ansmission  Queue Sta tus to 'Re sponse Rec eived' &
  3039   "RTN","IBC NEHL3",342 ,0)
  3040    ;  update  remaining  retries t o comm fai lure (5)
  3041   "RTN","IBC NEHL3",343 ,0)
  3042    I $G(RSTY PE)="O" D  SST^IBCNEU T2(TQN,3), RSTA^IBCNE UT7(TQN)
  3043   "RTN","IBC NEHL3",344 ,0)
  3044    ;
  3045   "RTN","IBC NEHL3",345 ,0)
  3046    ; If it i s an ident ification  and policy  is not ac tive don't
  3047   "RTN","IBC NEHL3",346 ,0)
  3048    ; create  buffer ent ry
  3049   "RTN","IBC NEHL3",347 ,0)
  3050    I IBQFL=" I",IIVSTAT '=1 Q
  3051   "RTN","IBC NEHL3",348 ,0)
  3052    ;
  3053   "RTN","IBC NEHL3",349 ,0)
  3054    ; If unso licited me ssage or n o buffer i n TQ, crea te new buf fer entry
  3055   "RTN","IBC NEHL3",350 ,0)
  3056    I RSTYPE= "U" S IBIE N=""
  3057   "RTN","IBC NEHL3",351 ,0)
  3058    I IBIEN=" " D  Q
  3059   "RTN","IBC NEHL3",352 ,0)
  3060    .  S DFN= $P(TQDATA, U,2)         ; Determ ine Patien t DFN
  3061   "RTN","IBC NEHL3",353 ,0)
  3062    .  S SYMB OL=22 D BU F^IBCNEHL3   ; Create  a new buf fer entry
  3063   "RTN","IBC NEHL3",354 ,0)
  3064    ;
  3065   "RTN","IBC NEHL3",355 ,0)
  3066    ;Update b uffer symb ol
  3067   "RTN","IBC NEHL3",356 ,0)
  3068    D BUFF^IB CNEUT2(IBI EN,22)
  3069   "RTN","IBC NEHL3",357 ,0)
  3070    ;
  3071   "RTN","IBC NEHL3",358 ,0)
  3072    Q
  3073   "RTN","IBC NEHL3",359 ,0)
  3074    ;
  3075   "RTN","IBC NEHL3",360 ,0)
  3076   CHK1() ; c heck auto- update cri teria for  patient wh o is the s ubscriber
  3077   "RTN","IBC NEHL3",361 ,0)
  3078    ; called  from tag A UTOUPD, us es variabl es defined  there
  3079   "RTN","IBC NEHL3",362 ,0)
  3080    ;
  3081   "RTN","IBC NEHL3",363 ,0)
  3082    ; returns  1 if give n policy s atisfies a uto-update  criteria,  returns 0  otherwise
  3083   "RTN","IBC NEHL3",364 ,0)
  3084    N RES
  3085   "RTN","IBC NEHL3",365 ,0)
  3086    S RES=0
  3087   "RTN","IBC NEHL3",366 ,0)
  3088    I $P(RDAT A13,U,2)'= $P(IDATA7, U,2) G CHK 1X  ; Subs criber ID  doesn't ma tch   ; IB *2.0*497 c ompare sub scriber ID  data at t heir new l ocations
  3089   "RTN","IBC NEHL3",367 ,0)
  3090    I $P(RDAT A1,U,2)'=$ P(IDATA3,U ) G CHK1X   ; DOB doe sn't match
  3091   "RTN","IBC NEHL3",368 ,0)
  3092    I '$$NAME CMP^IBCNEH LU($P(RDAT A13,U),$P( IDATA7,U))  G CHK1X   ; Insured' s name doe sn't match   ; IB*2.0 *497 compa re name of  insured d ata at the ir new loc ations
  3093   "RTN","IBC NEHL3",369 ,0)
  3094    S RES=1
  3095   "RTN","IBC NEHL3",370 ,0)
  3096   CHK1X ;
  3097   "RTN","IBC NEHL3",371 ,0)
  3098    Q RES
  3099   "RTN","IBC NEHL3",372 ,0)
  3100    ;
  3101   "RTN","IBC NEHL3",373 ,0)
  3102   CHK2(MWNRT YP) ; chec k auto-upd ate criter ia for pat ient who i s not the  subscriber
  3103   "RTN","IBC NEHL3",374 ,0)
  3104    ; called  from tag A UTOUPD, us es variabl es defined  there
  3105   "RTN","IBC NEHL3",375 ,0)
  3106    ;
  3107   "RTN","IBC NEHL3",376 ,0)
  3108    ; returns  1 if poli cy satisfi es auto-up date crite ria, retur ns 0 other wise
  3109   "RTN","IBC NEHL3",377 ,0)
  3110    N DOB,ID, IDATA5,IEN S,NAME,PDO B,PNAME,RE S
  3111   "RTN","IBC NEHL3",378 ,0)
  3112    S RES=0
  3113   "RTN","IBC NEHL3",379 ,0)
  3114    S IDATA5= $G(^DPT(IE N2,.312,IE N312,5))
  3115   "RTN","IBC NEHL3",380 ,0)
  3116    S IENS=IE N2_","
  3117   "RTN","IBC NEHL3",381 ,0)
  3118    S ID=$P(R DATA13,U,2 )    ; IB* 2.0*497 Su bscriber I D needs to  be retrie ved from i ts new loc ation
  3119   "RTN","IBC NEHL3",382 ,0)
  3120    I ID'=$P( IDATA7,U,2 ),ID'=$P(I DATA5,U) G  CHK2X  ;  both Subsc riber ID a nd Patient  ID don't  match ; IB *2.0*497 c ompare sub scriber ID  at new lo cations
  3121   "RTN","IBC NEHL3",383 ,0)
  3122    S DOB=$P( RDATA1,U,2 ),PDOB=$$G ET1^DIQ(2, IENS,.03," I")
  3123   "RTN","IBC NEHL3",384 ,0)
  3124    I DOB'=$P (IDATA3,U) ,DOB'=PDOB  G CHK2X   ; both Sub scriber an d Patient  DOB don't  match
  3125   "RTN","IBC NEHL3",385 ,0)
  3126    S NAME=$P (RDATA13,U ),PNAME=$$ GET1^DIQ(2 ,IENS,.01)    ; IB*2. 0*497 get  name of in sured at i ts new loc ation
  3127   "RTN","IBC NEHL3",386 ,0)
  3128    I '+MWNRT YP,'$$NAME CMP^IBCNEH LU(NAME,$P (IDATA7,U) ),'$$NAMEC MP^IBCNEHL U(NAME,PNA ME) G CHK2 X  ; non-M edicare, b oth Subscr iber and P atient nam e don't ma tch ; IB*2 *497
  3129   "RTN","IBC NEHL3",387 ,0)
  3130    I +MWNRTY P,'$$NAMEC MP^IBCNEHL U(NAME,PNA ME) G CHK2 X  ; Medic are, Patie nt name do esn't matc h
  3131   "RTN","IBC NEHL3",388 ,0)
  3132    S RES=1
  3133   "RTN","IBC NEHL3",389 ,0)
  3134   CHK2X ;
  3135   "RTN","IBC NEHL3",390 ,0)
  3136    Q RES
  3137   "RTN","IBC NEHL3",391 ,0)
  3138    ;
  3139   "RTN","IBC NEHL3",392 ,0)
  3140   UPDIREC(RI EN,IEN312)  ; IB*2*59 5/DM updat e INSUR RE CORD IEN i n the resp onse file  (#365,.12)  
  3141   "RTN","IBC NEHL3",393 ,0)
  3142    ; RIEN -  ien in eIV  Response  file (365)
  3143   "RTN","IBC NEHL3",394 ,0)
  3144    ; IEN312  - ien in p at. insura nce multip le (2.312)
  3145   "RTN","IBC NEHL3",395 ,0)
  3146    ;
  3147   "RTN","IBC NEHL3",396 ,0)
  3148    N DATA,ER ROR,IENS
  3149   "RTN","IBC NEHL3",397 ,0)
  3150    I RIEN'>0 !(IEN312'> 0) Q
  3151   "RTN","IBC NEHL3",398 ,0)
  3152    ; IB*2*59 5/DM do no t update T Q file. 
  3153   "RTN","IBC NEHL3",399 ,0)
  3154    ; The pro per INSUR  RECORD IEN  field is  now locate d in the r esponse fi le 
  3155   "RTN","IBC NEHL3",400 ,0)
  3156    ;S IENS=$ P($G(^IBCN (365,RIEN, 0)),U,5)_" ," I IENS= "," Q
  3157   "RTN","IBC NEHL3",401 ,0)
  3158    ;S DATA(3 65.1,IENS, .13)=IEN31 2
  3159   "RTN","IBC NEHL3",402 ,0)
  3160    S DATA(36 5,RIEN_"," ,.12)=IEN3 12
  3161   "RTN","IBC NEHL3",403 ,0)
  3162    D FILE^DI E("ET","DA TA","ERROR ")
  3163   "RTN","IBC NEHL3",404 ,0)
  3164    Q
  3165   "RTN","IBC NEHL3",405 ,0)
  3166    ;
  3167   "RTN","IBC NEHL3",406 ,0)
  3168   LCKERR ; s end lockin g error me ssage
  3169   "RTN","IBC NEHL3",407 ,0)
  3170    N MSG,XMY
  3171   "RTN","IBC NEHL3",408 ,0)
  3172    S MSG(1)= "WARNING:  Unable to  Auto-file  Response M essage fro m the EC"
  3173   "RTN","IBC NEHL3",409 ,0)
  3174    S MSG(2)= "--------- ---------- ---------- ---------- ---------- --------"
  3175   "RTN","IBC NEHL3",410 ,0)
  3176    S MSG(3)= "Failed to  lock pati ent insura nce entry: "
  3177   "RTN","IBC NEHL3",411 ,0)
  3178    S MSG(4)= "  Patient  name - "_ $$GET1^DIQ (2,DFN_"," ,.01)
  3179   "RTN","IBC NEHL3",412 ,0)
  3180    S MSG(5)= "  Insuran ce - "_$$G ET1^DIQ(2. 312,IENS,. 01)
  3181   "RTN","IBC NEHL3",413 ,0)
  3182    S MSG(6)= "  IENS -  "_$S($G(IE NS)="":"Un known",1:I ENS)
  3183   "RTN","IBC NEHL3",414 ,0)
  3184    S MSG(7)= " "
  3185   "RTN","IBC NEHL3",415 ,0)
  3186    S MSG(8)= "The respo nse will b e filed in to Insuran ce Buffer  instead."
  3187   "RTN","IBC NEHL3",416 ,0)
  3188    S MSG(9)= " "
  3189   "RTN","IBC NEHL3",417 ,0)
  3190    D MSG^IBC NEUT5(MGRP ,MSG(1),"M SG(",,.XMY )
  3191   "RTN","IBC NEHL3",418 ,0)
  3192    Q
  3193   "RTN","IBC NEHL3",419 ,0)
  3194    ;
  3195   "RTN","IBC NEKIT")
  3196   0^11^B1644 96028^B147 072833
  3197   "RTN","IBC NEKIT",1,0 )
  3198   IBCNEKIT ; DAOU/ESG -  PURGE eIV  DATA FILE S ;11-JUL- 2002
  3199   "RTN","IBC NEKIT",2,0 )
  3200    ;;2.0;INT EGRATED BI LLING;**18 4,271,316, 416,549,59 5,621,602* *;21-MAR-9 4;Build 22
  3201   "RTN","IBC NEKIT",3,0 )
  3202    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3203   "RTN","IBC NEKIT",4,0 )
  3204    ;
  3205   "RTN","IBC NEKIT",5,0 )
  3206    ; This ro utine hand les the pu rging of t he eIV dat a stored i n the
  3207   "RTN","IBC NEKIT",6,0 )
  3208    ; eIV Tra nsmission  Queue file  (#365.1),  the eIV R esponse fi le (#365)  and
  3209   "RTN","IBC NEKIT",7,0 )
  3210    ; the EIV  EICD TRAC KING file  (#365.18)  IB*2.0*621 /DM
  3211   "RTN","IBC NEKIT",8,0 )
  3212    ; User ca n pick a d ate range  for the pu rge.  Data  created w ithin 6 mo nths
  3213   "RTN","IBC NEKIT",9,0 )
  3214    ; cannot  be purged.   The actu al global  kills are  done by a  background
  3215   "RTN","IBC NEKIT",10, 0)
  3216    ; task af ter hours  (8:00pm).
  3217   "RTN","IBC NEKIT",11, 0)
  3218    ;
  3219   "RTN","IBC NEKIT",12, 0)
  3220   EN ;
  3221   "RTN","IBC NEKIT",13, 0)
  3222    NEW STOP, BEGDT,ENDD T,STATLIST ,IBVER
  3223   "RTN","IBC NEKIT",14, 0)
  3224    S IBVER=1
  3225   "RTN","IBC NEKIT",15, 0)
  3226    D INIT I  STOP G EXI T       ;  initialize /calculate  default d ates
  3227   "RTN","IBC NEKIT",16, 0)
  3228    D DEFLT I  STOP G EX IT      ;  allow user  to change  default e nd date if  test syst em ;IB*2.0 *621
  3229   "RTN","IBC NEKIT",17, 0)
  3230    D BEGDT I  STOP G EX IT      ;  user inter face for b eginning d ate
  3231   "RTN","IBC NEKIT",18, 0)
  3232    D ENDDT I  STOP G EX IT      ;  user inter face for e nding date
  3233   "RTN","IBC NEKIT",19, 0)
  3234    D CONFIRM  I STOP G  EXIT    ;  confirmati on message /final che ck
  3235   "RTN","IBC NEKIT",20, 0)
  3236    D QUEUE                      ;  queuing pr ocess
  3237   "RTN","IBC NEKIT",21, 0)
  3238   EXIT ;
  3239   "RTN","IBC NEKIT",22, 0)
  3240    Q
  3241   "RTN","IBC NEKIT",23, 0)
  3242    ;
  3243   "RTN","IBC NEKIT",24, 0)
  3244   EN1 ; Auto mated Mont hly Purge  *IB*2*595
  3245   "RTN","IBC NEKIT",25, 0)
  3246    NEW STOP, BEGDT,ENDD T,STATLIST ,IBVER
  3247   "RTN","IBC NEKIT",26, 0)
  3248    S IBVER=2
  3249   "RTN","IBC NEKIT",27, 0)
  3250    D INIT I  STOP G EXI T1       ;  initializ e/calculat e default  dates
  3251   "RTN","IBC NEKIT",28, 0)
  3252    D QUEUE                      ;  queuing pr ocess
  3253   "RTN","IBC NEKIT",29, 0)
  3254   EXIT1 ;
  3255   "RTN","IBC NEKIT",30, 0)
  3256    Q
  3257   "RTN","IBC NEKIT",31, 0)
  3258   PURGE ; Th is procedu re is queu ed to run  in the bac kground an d does the
  3259   "RTN","IBC NEKIT",32, 0)
  3260    ; actual  purging.   Variables  available  from the T askMan cal l are:
  3261   "RTN","IBC NEKIT",33, 0)
  3262    ;
  3263   "RTN","IBC NEKIT",34, 0)
  3264    ; STATLIS T = list o f statuses  that are  OK to purg e
  3265   "RTN","IBC NEKIT",35, 0)
  3266    ;    BEGD T = beginn ing date f or purging
  3267   "RTN","IBC NEKIT",36, 0)
  3268    ;    ENDD T = ending  date for  purging
  3269   "RTN","IBC NEKIT",37, 0)
  3270    ;
  3271   "RTN","IBC NEKIT",38, 0)
  3272    ; First l oop throug h the eIV  Transmissi on Queue f ile and de lete all
  3273   "RTN","IBC NEKIT",39, 0)
  3274    ; records  in the da te range w hose statu s is in th e list
  3275   "RTN","IBC NEKIT",40, 0)
  3276    ;
  3277   "RTN","IBC NEKIT",41, 0)
  3278    N CNT,DA, DATE,DIK,H LIEN,PFLAG ,TQIEN,TQS    ;IB*2.0 *549 added  PFLAG
  3279   "RTN","IBC NEKIT",42, 0)
  3280    N IBWEXT, IBIORV
  3281   "RTN","IBC NEKIT",43, 0)
  3282    S DATE=$O (^IBCN(365 .1,"AE",BE GDT),-1),C NT=0
  3283   "RTN","IBC NEKIT",44, 0)
  3284    F  S DATE =$O(^IBCN( 365.1,"AE" ,DATE)) Q: 'DATE!($P( DATE,".",1 )>ENDDT)!$ G(ZTSTOP)   S TQIEN=0  F  S TQIE N=$O(^IBCN (365.1,"AE ",DATE,TQI EN)) Q:'TQ IEN  D  Q: $G(ZTSTOP)
  3285   "RTN","IBC NEKIT",45, 0)
  3286    . S CNT=C NT+1
  3287   "RTN","IBC NEKIT",46, 0)
  3288    . I $D(ZT QUEUED),CN T#100=0,$$ S^%ZTLOAD( ) S ZTSTOP =1 Q
  3289   "RTN","IBC NEKIT",47, 0)
  3290    . S TQS=$ P($G(^IBCN (365.1,TQI EN,0)),U,4 )     ; tr ans queue  status
  3291   "RTN","IBC NEKIT",48, 0)
  3292    . S IBWEX T=$P($G(^I BCN(365.1, TQIEN,0)), U,10) ; IB *2.0*621/D M WHICH EX TRACT
  3293   "RTN","IBC NEKIT",49, 0)
  3294    . S IBIOR V=$P($G(^I BCN(365.1, TQIEN,0)), U,11) ; IB *2.0*621/D M QUERY FL AG
  3295   "RTN","IBC NEKIT",50, 0)
  3296    . I IBWEX T=4,IBIORV ="V" Q                      ; sk ip EICD Ve rification  entries a s they 
  3297   "RTN","IBC NEKIT",51, 0)
  3298    . ;                                                wi ll be addr essed with  EICD Iden tification s
  3299   "RTN","IBC NEKIT",52, 0)
  3300    . I '$F(S TATLIST,", "_TQS_",")  Q               ; mu st be in t he list
  3301   "RTN","IBC NEKIT",53, 0)
  3302    . I IBWEX T=4,IBIORV ="I" D CHK TRK(TQIEN)  Q    ; ch eck EIV EI CD TRACKIN G for purg e
  3303   "RTN","IBC NEKIT",54, 0)
  3304    . ; loop  through th e HL7 mess ages multi ple and ki ll any res ponse
  3305   "RTN","IBC NEKIT",55, 0)
  3306    . ; recor ds that ar e found fo r this tra nsmission  queue entr y
  3307   "RTN","IBC NEKIT",56, 0)
  3308    . ; IB*2. 0*621/DM P reserve an y TQ and r esponse th at has DO  NOT PURGE  set to 1 ( YES)
  3309   "RTN","IBC NEKIT",57, 0)
  3310    . S PFLAG =0,HLIEN=0 ,DIK="^IBC N(365,"
  3311   "RTN","IBC NEKIT",58, 0)
  3312    . F  S HL IEN=$O(^IB CN(365.1,T QIEN,2,HLI EN)) Q:'HL IEN  D
  3313   "RTN","IBC NEKIT",59, 0)
  3314    .. S DA=$ P($G(^IBCN (365.1,TQI EN,2,HLIEN ,0)),U,3)  Q:'DA
  3315   "RTN","IBC NEKIT",60, 0)
  3316    .. I +$$G ET1^DIQ(36 5,DA_",",. 11,"I") S  PFLAG=1 Q   ;"DO NOT  PURGE"
  3317   "RTN","IBC NEKIT",61, 0)
  3318    .. D ^DIK
  3319   "RTN","IBC NEKIT",62, 0)
  3320    .. Q
  3321   "RTN","IBC NEKIT",63, 0)
  3322    . ;
  3323   "RTN","IBC NEKIT",64, 0)
  3324    . ; now w e can kill  the trans mission qu eue entry  itself
  3325   "RTN","IBC NEKIT",65, 0)
  3326    . ; as lo ng as ther e was no D O NOT PURG E response s IB*2.0*6 21/DM 
  3327   "RTN","IBC NEKIT",66, 0)
  3328    . I 'PFLA G S DA=TQI EN,DIK="^I BCN(365.1, " D ^DIK K  DA,DIK
  3329   "RTN","IBC NEKIT",67, 0)
  3330    . Q
  3331   "RTN","IBC NEKIT",68, 0)
  3332    ;
  3333   "RTN","IBC NEKIT",69, 0)
  3334    ; Check f or a stop  request
  3335   "RTN","IBC NEKIT",70, 0)
  3336    I $G(ZTST OP) G PURG EX
  3337   "RTN","IBC NEKIT",71, 0)
  3338    ;
  3339   "RTN","IBC NEKIT",72, 0)
  3340    ; Now we  must loop  through th e eIV Resp onse file  itself to  purge any
  3341   "RTN","IBC NEKIT",73, 0)
  3342    ; respons e records  that do no t have a c orrespondi ng transmi ssion
  3343   "RTN","IBC NEKIT",74, 0)
  3344    ; queue e ntry.  The se are the  unsolicit ed respons es.  The s tatus of
  3345   "RTN","IBC NEKIT",75, 0)
  3346    ; these r esponses i s always ' response r eceived' s o we don't  need to
  3347   "RTN","IBC NEKIT",76, 0)
  3348    ; check t he status.  For this  loop, star t from the  very begi nning of
  3349   "RTN","IBC NEKIT",77, 0)
  3350    ; the fil e.
  3351   "RTN","IBC NEKIT",78, 0)
  3352    ;
  3353   "RTN","IBC NEKIT",79, 0)
  3354    S DATE="" ,DIK="^IBC N(365,",CN T=0
  3355   "RTN","IBC NEKIT",80, 0)
  3356    F  S DATE =$O(^IBCN( 365,"AE",D ATE)) Q:'D ATE!($P(DA TE,".",1)> ENDDT)!$G( ZTSTOP)  S  DA=0 F  S  DA=$O(^IB CN(365,"AE ",DATE,DA) ) Q:'DA  D   Q:$G(ZTS TOP)
  3357   "RTN","IBC NEKIT",81, 0)
  3358    . S CNT=C NT+1
  3359   "RTN","IBC NEKIT",82, 0)
  3360    . I $D(ZT QUEUED),CN T#100=0,$$ S^%ZTLOAD( ) S ZTSTOP =1 Q
  3361   "RTN","IBC NEKIT",83, 0)
  3362    . ;
  3363   "RTN","IBC NEKIT",84, 0)
  3364    . ; IB*2. 0*602/TAZ  never drop  a DO NOT  PURGE resp onse
  3365   "RTN","IBC NEKIT",85, 0)
  3366    . Q:+$$GE T1^DIQ(365 ,DA_",",.1 1,"I")
  3367   "RTN","IBC NEKIT",86, 0)
  3368    . ; If th ere is a p ointer to  the transm ission que ue file,
  3369   "RTN","IBC NEKIT",87, 0)
  3370    . ; make  sure the t ransmissio n queue re cord actua lly exists .
  3371   "RTN","IBC NEKIT",88, 0)
  3372    . ; If th e TQ exist s, quit th is loop, i f not, rem ove this r esponse.
  3373   "RTN","IBC NEKIT",89, 0)
  3374    . ;
  3375   "RTN","IBC NEKIT",90, 0)
  3376    . S TQIEN =+$$GET1^D IQ(365,DA_ ",",.05,"I ")
  3377   "RTN","IBC NEKIT",91, 0)
  3378    . D ^DIK
  3379   "RTN","IBC NEKIT",92, 0)
  3380    . Q
  3381   "RTN","IBC NEKIT",93, 0)
  3382    ;
  3383   "RTN","IBC NEKIT",94, 0)
  3384    K DA,DIK
  3385   "RTN","IBC NEKIT",95, 0)
  3386   PURGEX ;
  3387   "RTN","IBC NEKIT",96, 0)
  3388    ; Tell Ta skManager  to delete  the task's  record
  3389   "RTN","IBC NEKIT",97, 0)
  3390    I $D(ZTQU EUED) S ZT REQ="@"
  3391   "RTN","IBC NEKIT",98, 0)
  3392    Q
  3393   "RTN","IBC NEKIT",99, 0)
  3394    ;
  3395   "RTN","IBC NEKIT",100 ,0)
  3396   INIT ; Thi s procedur e calculat es the def ault begin ning and e nding date s
  3397   "RTN","IBC NEKIT",101 ,0)
  3398    ; and dis plays scre en message s about th is option  to the use r.
  3399   "RTN","IBC NEKIT",102 ,0)
  3400    ;
  3401   "RTN","IBC NEKIT",103 ,0)
  3402    NEW DATE, FOUND,TQIE N,TQS,RPIE N,RPS,IBHL 7,IBDNP
  3403   "RTN","IBC NEKIT",104 ,0)
  3404    NEW DIR,X ,Y,DTOUT,D UOUT,DIRUT ,DIROUT
  3405   "RTN","IBC NEKIT",105 ,0)
  3406    ;
  3407   "RTN","IBC NEKIT",106 ,0)
  3408    S STOP=0
  3409   "RTN","IBC NEKIT",107 ,0)
  3410    ;
  3411   "RTN","IBC NEKIT",108 ,0)
  3412    ; This is  the list  of statuse s that are  OK to pur ge
  3413   "RTN","IBC NEKIT",109 ,0)
  3414    ;   3=Res ponse Rece ived
  3415   "RTN","IBC NEKIT",110 ,0)
  3416    ;   5=Com munication  Failure
  3417   "RTN","IBC NEKIT",111 ,0)
  3418    ;   7=Can celled
  3419   "RTN","IBC NEKIT",112 ,0)
  3420    S STATLIS T=","_$$FI ND1^DIC(36 5.14,,"B", "Response  Received")
  3421   "RTN","IBC NEKIT",113 ,0)
  3422    S STATLIS T=STATLIST _","_$$FIN D1^DIC(365 .14,,"B"," Communicat ion Failur e")
  3423   "RTN","IBC NEKIT",114 ,0)
  3424    S STATLIS T=STATLIST _","_$$FIN D1^DIC(365 .14,,"B"," Cancelled" )_","
  3425   "RTN","IBC NEKIT",115 ,0)
  3426    ;
  3427   "RTN","IBC NEKIT",116 ,0)
  3428    ; Try to  find a beg inning dat e in the e IV Transmi ssion Queu e file
  3429   "RTN","IBC NEKIT",117 ,0)
  3430    S DATE="" ,FOUND=0,B EGDT=DT
  3431   "RTN","IBC NEKIT",118 ,0)
  3432    F  S DATE =$O(^IBCN( 365.1,"AE" ,DATE)) Q: 'DATE!FOUN D  S TQIEN =0 F  S TQ IEN=$O(^IB CN(365.1," AE",DATE,T QIEN)) Q:' TQIEN  D   Q:FOUND
  3433   "RTN","IBC NEKIT",119 ,0)
  3434    . S TQS=$ P($G(^IBCN (365.1,TQI EN,0)),U,4 )    ; sta tus
  3435   "RTN","IBC NEKIT",120 ,0)
  3436    . I '$F(S TATLIST,", "_TQS_",")  Q
  3437   "RTN","IBC NEKIT",121 ,0)
  3438    . ;IB*2.0 *602/DM ma ke sure th e default  earliest d ate is not  a DO NOT  PURGE entr
  3439   "RTN","IBC NEKIT",122 ,0)
  3440    . ;check  the HL7 me ssages mul tiple to s ee if DO N OT PURGE i s set on a ny respons e
  3441   "RTN","IBC NEKIT",123 ,0)
  3442    . S (IBDN P,IBHL7)=0
  3443   "RTN","IBC NEKIT",124 ,0)
  3444    . F  S IB HL7=$O(^IB CN(365.1,T QIEN,2,IBH L7)) Q:'IB HL7!IBDNP   D
  3445   "RTN","IBC NEKIT",125 ,0)
  3446    .. S RPIE N=$P($G(^I BCN(365.1, TQIEN,2,IB HL7,0)),U, 3) Q:'RPIE N
  3447   "RTN","IBC NEKIT",126 ,0)
  3448    .. I +$$G ET1^DIQ(36 5,RPIEN_", ","DO NOT  PURGE","I" ) S IBDNP= 1
  3449   "RTN","IBC NEKIT",127 ,0)
  3450    .. Q
  3451   "RTN","IBC NEKIT",128 ,0)
  3452    . ;
  3453   "RTN","IBC NEKIT",129 ,0)
  3454    . I IBDNP ,IBVER=2 Q  
  3455   "RTN","IBC NEKIT",130 ,0)
  3456    . I IBDNP  W !,"Plea se wait, c hecking fo r the earl iest purge  date ..." ,! Q
  3457   "RTN","IBC NEKIT",131 ,0)
  3458    . ;
  3459   "RTN","IBC NEKIT",132 ,0)
  3460    . S FOUND =1
  3461   "RTN","IBC NEKIT",133 ,0)
  3462    . S BEGDT =$P(DATE," .",1)
  3463   "RTN","IBC NEKIT",134 ,0)
  3464    . Q
  3465   "RTN","IBC NEKIT",135 ,0)
  3466    ;
  3467   "RTN","IBC NEKIT",136 ,0)
  3468    ; If not  successful , try to f ind a begi nning date  in the eI V Response  file.
  3469   "RTN","IBC NEKIT",137 ,0)
  3470    I 'FOUND  D
  3471   "RTN","IBC NEKIT",138 ,0)
  3472    . S DATE= ""
  3473   "RTN","IBC NEKIT",139 ,0)
  3474    . F  S DA TE=$O(^IBC N(365,"AE" ,DATE)) Q: 'DATE!FOUN D  S RPIEN =0 F  S RP IEN=$O(^IB CN(365,"AE ",DATE,RPI EN)) Q:'RP IEN  D  Q: FOUND
  3475   "RTN","IBC NEKIT",140 ,0)
  3476    .. S RPS= $P($G(^IBC N(365,RPIE N,0)),U,6)     ; stat us
  3477   "RTN","IBC NEKIT",141 ,0)
  3478    .. I '$F( STATLIST," ,"_RPS_"," ) Q
  3479   "RTN","IBC NEKIT",142 ,0)
  3480    .. ;IB*2. 0*602/DM d o not choo se a DO NO T PURGE re sponse 
  3481   "RTN","IBC NEKIT",143 ,0)
  3482    .. I +$$G ET1^DIQ(36 5,RPIEN_", ","DO NOT  PURGE","I" ) Q
  3483   "RTN","IBC NEKIT",144 ,0)
  3484    .. S FOUN D=1
  3485   "RTN","IBC NEKIT",145 ,0)
  3486    .. S BEGD T=$P(DATE, ".",1)
  3487   "RTN","IBC NEKIT",146 ,0)
  3488    .. Q
  3489   "RTN","IBC NEKIT",147 ,0)
  3490    . Q
  3491   "RTN","IBC NEKIT",148 ,0)
  3492    ;
  3493   "RTN","IBC NEKIT",149 ,0)
  3494    ; default  end date,  Today min us 182 day s (approx  6 months)
  3495   "RTN","IBC NEKIT",150 ,0)
  3496    S ENDDT=$ $FMADD^XLF DT(DT,-182 )
  3497   "RTN","IBC NEKIT",151 ,0)
  3498    ;
  3499   "RTN","IBC NEKIT",152 ,0)
  3500    ;I IBVER= 1,'FOUND!( BEGDT>ENDD T) D  S ST OP=1 G INI TX ; IB*2. 0*621
  3501   "RTN","IBC NEKIT",153 ,0)
  3502    I IBVER=1 ,'FOUND,'$ $PROD^XUPR OD(1)!(BEG DT>ENDDT)  D  S STOP= 1 G INITX
  3503   "RTN","IBC NEKIT",154 ,0)
  3504    . W !!?5, "Purging o f eIV data  is not po ssible at  this time. "
  3505   "RTN","IBC NEKIT",155 ,0)
  3506    . I 'FOUN D W !?5,"T here are n o entries  in the fil e that are  eligible  to be",!?5 ,"purged o r there is  no data i n the file ."
  3507   "RTN","IBC NEKIT",156 ,0)
  3508    . E  W !? 5,"The old est date i n the file  is ",$$FM TE^XLFDT(B EGDT,"5Z") ,".",!?5," Data canno t be purge d unless i t is at le ast 6 mont hs old."
  3509   "RTN","IBC NEKIT",157 ,0)
  3510    . W ! S D IR(0)="E"  D ^DIR K D IR
  3511   "RTN","IBC NEKIT",158 ,0)
  3512    . Q
  3513   "RTN","IBC NEKIT",159 ,0)
  3514    I IBVER=2 ,'FOUND!(B EGDT>ENDDT ) D  S STO P=1 G INIT X
  3515   "RTN","IBC NEKIT",160 ,0)
  3516    .; Send a  MailMan m essage wit h Eligible  Purge cou nts ; IB*2 .0*621 - U pdated Mes sage
  3517   "RTN","IBC NEKIT",161 ,0)
  3518    .N MGRP,M SG,IBXMY
  3519   "RTN","IBC NEKIT",162 ,0)
  3520    .S MSG(1) ="Purge El ectronic I nsurance V erificatio n (eIV) Da ta Files d id not fin d records"
  3521   "RTN","IBC NEKIT",163 ,0)
  3522    .S MSG(2) ="for stat ion "_+$$S ITE^VASITE ()_"."
  3523   "RTN","IBC NEKIT",164 ,0)
  3524    .S MSG(3) =""
  3525   "RTN","IBC NEKIT",165 ,0)
  3526    .S MSG(4) ="The opti on runs au tomaticall y on a mon thly basis  and purge s data fro m the"
  3527   "RTN","IBC NEKIT",166 ,0)
  3528    .S MSG(5) ="IIV RESP ONSE file  (#365), th e IIV TRAN SMISSION Q UEUE file  (#365.1),  and the"
  3529   "RTN","IBC NEKIT",167 ,0)
  3530    .S MSG(6) ="EIV EICD  TRACKING  file (#365 .18).  The  data must  be at lea st six mon ths old"
  3531   "RTN","IBC NEKIT",168 ,0)
  3532    .S MSG(7) ="before i t can be p urged.  On ly insuran ce transac tions that  have a tr ansmission "
  3533   "RTN","IBC NEKIT",169 ,0)
  3534    .S MSG(8) ="status o f ""Respon se Receive d"", ""Com munication  Failure"" , or ""Can celled"""
  3535   "RTN","IBC NEKIT",170 ,0)
  3536    .S MSG(9) ="may be p urged."
  3537   "RTN","IBC NEKIT",171 ,0)
  3538    .; Set to  IB site p arameter M AILGROUP -  IBCNE EIV  MESSAGE
  3539   "RTN","IBC NEKIT",172 ,0)
  3540    .S MGRP=$ $MGRP^IBCN EUT5()
  3541   "RTN","IBC NEKIT",173 ,0)
  3542    .S IBXMY( " P I                     ")=""
  3543   "RTN","IBC NEKIT",174 ,0)
  3544    .D MSG^IB CNEUT5(MGR P,"eIV Pur ge No Data  Found for  Station " _+$$SITE^V ASITE(),"M SG(",,.IBX MY)
  3545   "RTN","IBC NEKIT",175 ,0)
  3546    .; Duplic ate messag e to Outlo ok group
  3547   "RTN","IBC NEKIT",176 ,0)
  3548    .; S MGRP =" P I                       "
  3549   "RTN","IBC NEKIT",177 ,0)
  3550    .; D MSG^ IBCNEUT5(M GRP,"eIV D ata Backgr ound Purge ","MSG(")
  3551   "RTN","IBC NEKIT",178 ,0)
  3552    .Q
  3553   "RTN","IBC NEKIT",179 ,0)
  3554    ;
  3555   "RTN","IBC NEKIT",180 ,0)
  3556    ; At this  point, we  know that  there are  some entr ies eligib le for
  3557   "RTN","IBC NEKIT",181 ,0)
  3558    ; purging .  Display  a message  to the us er about t his option .
  3559   "RTN","IBC NEKIT",182 ,0)
  3560    I IBVER=2  G INITX
  3561   "RTN","IBC NEKIT",183 ,0)
  3562    W @IOF
  3563   "RTN","IBC NEKIT",184 ,0)
  3564    W !?8,"Pu rge Electr onic Insur ance Verif ication (e IV) Data F iles"
  3565   "RTN","IBC NEKIT",185 ,0)
  3566    W !!!," T his option  will allo w you to p urge data  from the e IV Respons e File (#3 65)"
  3567   "RTN","IBC NEKIT",186 ,0)
  3568    W !," and  the eIV T ransmissio n Queue Fi le (#365.1 ).  The da ta must be  at least  six"
  3569   "RTN","IBC NEKIT",187 ,0)
  3570    W !," mon ths old be fore it ca n be purge d.  Only i nsurance t ransaction s that hav e a"
  3571   "RTN","IBC NEKIT",188 ,0)
  3572    W !," tra nsmission  status of  ""Response  Received" ", ""Commu nication F ailure"",  or"
  3573   "RTN","IBC NEKIT",189 ,0)
  3574    W !," ""C ancelled""  may be pu rged.  You  will be a llowed to  select a d ate range  for"
  3575   "RTN","IBC NEKIT",190 ,0)
  3576    W !," thi s purging.   The defa ult beginn ing date w ill be the  date of t he oldest"
  3577   "RTN","IBC NEKIT",191 ,0)
  3578    W !," eli gible reco rd in the  system.  T he default  ending da te will be  six month s"
  3579   "RTN","IBC NEKIT",192 ,0)
  3580    W !," ago  from toda y's date.   You may m odify this  default d ate range.   However,  you"
  3581   "RTN","IBC NEKIT",193 ,0)
  3582    W !," may  not selec t an endin g date tha t is more  recent tha n six mont hs ago."
  3583   "RTN","IBC NEKIT",194 ,0)
  3584    W !!
  3585   "RTN","IBC NEKIT",195 ,0)
  3586   INITX ;
  3587   "RTN","IBC NEKIT",196 ,0)
  3588    Q
  3589   "RTN","IBC NEKIT",197 ,0)
  3590    ;
  3591   "RTN","IBC NEKIT",198 ,0)
  3592   DEFLT ;  I B*621/DW A dded to as sist with  testing
  3593   "RTN","IBC NEKIT",199 ,0)
  3594    I IBVER=1 ,('$$PROD^ XUPROD(1))  D
  3595   "RTN","IBC NEKIT",200 ,0)
  3596    . W ?5,"* ** For Tes t Purposes  Only:"
  3597   "RTN","IBC NEKIT",201 ,0)
  3598    . W !!?5, "In test s ystems one  may overr ide the DE FAULT end  date."
  3599   "RTN","IBC NEKIT",202 ,0)
  3600    . W !!?5, "Current d efault end  date is T ODAY - 182  DAYS: "_$ $FMTE^XLFD T(ENDDT,"5 Z"),!!
  3601   "RTN","IBC NEKIT",203 ,0)
  3602    . NEW DIR ,X,Y,DTOUT ,DUOUT,DIR UT,DIROUT
  3603   "RTN","IBC NEKIT",204 ,0)
  3604    . S DIR(0 )="DOA^"_B EGDT_":"_D T_":AEX"
  3605   "RTN","IBC NEKIT",205 ,0)
  3606    . S DIR(" A")="Enter  the purge  default d ate: "
  3607   "RTN","IBC NEKIT",206 ,0)
  3608    . S DIR(" B")=$$FMTE ^XLFDT(END DT,"5Z")
  3609   "RTN","IBC NEKIT",207 ,0)
  3610    . S DIR(" ?")="This  response m ust be a d ate betwee n "_$$FMTE ^XLFDT(BEG DT,"5Z")_"  and "_$$F MTE^XLFDT( DT,"5Z")_" ."
  3611   "RTN","IBC NEKIT",208 ,0)
  3612    . D ^DIR  K DIR
  3613   "RTN","IBC NEKIT",209 ,0)
  3614    . I $D(DI RUT)!'Y S  STOP=1 G D EFLTX
  3615   "RTN","IBC NEKIT",210 ,0)
  3616    . S ENDDT =Y
  3617   "RTN","IBC NEKIT",211 ,0)
  3618    W !!!
  3619   "RTN","IBC NEKIT",212 ,0)
  3620   DEFLTX ;
  3621   "RTN","IBC NEKIT",213 ,0)
  3622    Q
  3623   "RTN","IBC NEKIT",214 ,0)
  3624    ;
  3625   "RTN","IBC NEKIT",215 ,0)
  3626   BEGDT ; Th is procedu re capture s the begi nning date  from the  user.
  3627   "RTN","IBC NEKIT",216 ,0)
  3628    NEW DIR,X ,Y,DTOUT,D UOUT,DIRUT ,DIROUT
  3629   "RTN","IBC NEKIT",217 ,0)
  3630    S DIR(0)= "DOA^"_BEG DT_":"_END DT_":AEX"
  3631   "RTN","IBC NEKIT",218 ,0)
  3632    S DIR("A" )="Enter t he purge b egin date:  "
  3633   "RTN","IBC NEKIT",219 ,0)
  3634    S DIR("B" )=$$FMTE^X LFDT(BEGDT ,"5Z")
  3635   "RTN","IBC NEKIT",220 ,0)
  3636    S DIR("?" )="This re sponse mus t be a dat e between  "_$$FMTE^X LFDT(BEGDT ,"5Z")_" a nd "_$$FMT E^XLFDT(EN DDT,"5Z")_ "."
  3637   "RTN","IBC NEKIT",221 ,0)
  3638    D ^DIR K  DIR
  3639   "RTN","IBC NEKIT",222 ,0)
  3640    I $D(DIRU T)!'Y S ST OP=1 G BEG DTX
  3641   "RTN","IBC NEKIT",223 ,0)
  3642    S BEGDT=Y
  3643   "RTN","IBC NEKIT",224 ,0)
  3644   BEGDTX ;
  3645   "RTN","IBC NEKIT",225 ,0)
  3646    Q
  3647   "RTN","IBC NEKIT",226 ,0)
  3648    ;
  3649   "RTN","IBC NEKIT",227 ,0)
  3650   ENDDT ; Th is procedu re capture s the endi ng date fr om the use r.
  3651   "RTN","IBC NEKIT",228 ,0)
  3652    NEW DIR,X ,Y,DTOUT,D UOUT,DIRUT ,DIROUT
  3653   "RTN","IBC NEKIT",229 ,0)
  3654    W !
  3655   "RTN","IBC NEKIT",230 ,0)
  3656    S DIR(0)= "DOA^"_BEG DT_":"_END DT_":AEX"
  3657   "RTN","IBC NEKIT",231 ,0)
  3658    S DIR("A" )="  Enter  the purge  end date:  "
  3659   "RTN","IBC NEKIT",232 ,0)
  3660    S DIR("B" )=$$FMTE^X LFDT(ENDDT ,"5Z")
  3661   "RTN","IBC NEKIT",233 ,0)
  3662    S DIR("?" )="This re sponse mus t be a dat e between  "_$$FMTE^X LFDT(BEGDT ,"5Z")_" a nd "_$$FMT E^XLFDT(EN DDT,"5Z")_ "."
  3663   "RTN","IBC NEKIT",234 ,0)
  3664    D ^DIR K  DIR
  3665   "RTN","IBC NEKIT",235 ,0)
  3666    I $D(DIRU T)!'Y S ST OP=1 G END DTX
  3667   "RTN","IBC NEKIT",236 ,0)
  3668    S ENDDT=Y
  3669   "RTN","IBC NEKIT",237 ,0)
  3670   ENDDTX ;
  3671   "RTN","IBC NEKIT",238 ,0)
  3672    Q
  3673   "RTN","IBC NEKIT",239 ,0)
  3674    ;
  3675   "RTN","IBC NEKIT",240 ,0)
  3676   CONFIRM ;  This proce dure displ ays a conf irmation m essage to  the user a nd
  3677   "RTN","IBC NEKIT",241 ,0)
  3678    ; asks if  it is OK  to proceed  with the  purge.
  3679   "RTN","IBC NEKIT",242 ,0)
  3680    NEW DIR,X ,Y,DTOUT,D UOUT,DIRUT ,DIROUT
  3681   "RTN","IBC NEKIT",243 ,0)
  3682    W !!!," Y ou want to  purge all  eIV data  created be tween "
  3683   "RTN","IBC NEKIT",244 ,0)
  3684    W $$FMTE^ XLFDT(BEGD T,"5Z"),"  and ",$$FM TE^XLFDT(E NDDT,"5Z") ,"."
  3685   "RTN","IBC NEKIT",245 ,0)
  3686    W !
  3687   "RTN","IBC NEKIT",246 ,0)
  3688    S DIR(0)= "YO",DIR(" A")=" OK t o continue "
  3689   "RTN","IBC NEKIT",247 ,0)
  3690    S DIR("B" )="NO"
  3691   "RTN","IBC NEKIT",248 ,0)
  3692    D ^DIR K  DIR
  3693   "RTN","IBC NEKIT",249 ,0)
  3694    I 'Y S ST OP=1
  3695   "RTN","IBC NEKIT",250 ,0)
  3696   CONFX ;
  3697   "RTN","IBC NEKIT",251 ,0)
  3698    Q
  3699   "RTN","IBC NEKIT",252 ,0)
  3700    ;
  3701   "RTN","IBC NEKIT",253 ,0)
  3702   QUEUE ; Th is procedu re queues  the purge  process fo r later at  night.
  3703   "RTN","IBC NEKIT",254 ,0)
  3704    ; The con cept for q ueuing the  purge cam e from the  insurance  buffer
  3705   "RTN","IBC NEKIT",255 ,0)
  3706    ; purge r outine, IB CNBPG.  Th at purge p rocess is  also hard- coded to
  3707   "RTN","IBC NEKIT",256 ,0)
  3708    ; be run  at 8:00 PM  just like  this one  is.
  3709   "RTN","IBC NEKIT",257 ,0)
  3710    ;
  3711   "RTN","IBC NEKIT",258 ,0)
  3712    NEW ZTRTN ,ZTDESC,ZT DTH,ZTIO,Z TUCI,ZTCPU ,ZTPRI,ZTS AVE,ZTKIL, ZTSYNC,ZTS K
  3713   "RTN","IBC NEKIT",259 ,0)
  3714    NEW DIR,X ,Y,DTOUT,D UOUT,DIRUT ,DIROUT
  3715   "RTN","IBC NEKIT",260 ,0)
  3716    ;
  3717   "RTN","IBC NEKIT",261 ,0)
  3718    ; IB*621/ DW Added l oop below  to assist  with testi ng
  3719   "RTN","IBC NEKIT",262 ,0)
  3720    I IBVER=1 ,('$$PROD^ XUPROD(1))  D  I Y D  PURGE^IBCN EKIT G QUE UEX
  3721   "RTN","IBC NEKIT",263 ,0)
  3722    . W !!!!, "*** TEST  System onl y - you ma y run this  immediate ly",!
  3723   "RTN","IBC NEKIT",264 ,0)
  3724    . S DIR(" A")="Do yo u want to  run this n ow instead  of taskin g it for 8 :00pm"
  3725   "RTN","IBC NEKIT",265 ,0)
  3726    . S DIR(0 )="Y",DIR( "B")="YES"
  3727   "RTN","IBC NEKIT",266 ,0)
  3728    . D ^DIR
  3729   "RTN","IBC NEKIT",267 ,0)
  3730    . I Y="^"  S STOP=1
  3731   "RTN","IBC NEKIT",268 ,0)
  3732    ;
  3733   "RTN","IBC NEKIT",269 ,0)
  3734    I STOP G  QUEUEX                ; IB*2.0*6 21
  3735   "RTN","IBC NEKIT",270 ,0)
  3736    S ZTRTN=" PURGE^IBCN EKIT"      ; TaskMan  task entry  point
  3737   "RTN","IBC NEKIT",271 ,0)
  3738    S ZTDESC= "Purge eIV  Data"     ; Task des cription
  3739   "RTN","IBC NEKIT",272 ,0)
  3740    S ZTDTH=D T_".20"               ; start it  at 8:00 P M tonight
  3741   "RTN","IBC NEKIT",273 ,0)
  3742    S ZTIO=""
  3743   "RTN","IBC NEKIT",274 ,0)
  3744    S ZTSAVE( "BEGDT")=" "
  3745   "RTN","IBC NEKIT",275 ,0)
  3746    S ZTSAVE( "ENDDT")=" "
  3747   "RTN","IBC NEKIT",276 ,0)
  3748    S ZTSAVE( "STATLIST" )=""
  3749   "RTN","IBC NEKIT",277 ,0)
  3750    D ^%ZTLOA D
  3751   "RTN","IBC NEKIT",278 ,0)
  3752    I IBVER=2  G QUEUEX
  3753   "RTN","IBC NEKIT",279 ,0)
  3754    I $G(ZTSK ) W !!," T ask# ",ZTS K," has be en schedul ed to purg e the eIV  data tonig ht at 8:00  PM."
  3755   "RTN","IBC NEKIT",280 ,0)
  3756    E  W !!,"  TaskManag er could n ot schedul e this tas k.",!," Co ntact IRM  for techni cal assist ance."
  3757   "RTN","IBC NEKIT",281 ,0)
  3758    W ! S DIR (0)="E" D  ^DIR K DIR
  3759   "RTN","IBC NEKIT",282 ,0)
  3760   QUEUEX ;
  3761   "RTN","IBC NEKIT",283 ,0)
  3762    Q
  3763   "RTN","IBC NEKIT",284 ,0)
  3764    ;
  3765   "RTN","IBC NEKIT",285 ,0)
  3766   CHKTRK(IBT Q1) ; IB*6 21, Evalua te associa ted record s for one  EICD trans action
  3767   "RTN","IBC NEKIT",286 ,0)
  3768    ; IBTQ1 =  EICD Iden tification  TQ IEN
  3769   "RTN","IBC NEKIT",287 ,0)
  3770    ;
  3771   "RTN","IBC NEKIT",288 ,0)
  3772    N FILE,HL IEN,IBTQIE N1,IBTQIEN 2,IBFIELDS ,IBPURGE,I BSKIP,IBTQ IEN,IBTQS
  3773   "RTN","IBC NEKIT",289 ,0)
  3774    N IBTRKIE N,PFLAG
  3775   "RTN","IBC NEKIT",290 ,0)
  3776    ;
  3777   "RTN","IBC NEKIT",291 ,0)
  3778    S (IBSKIP ,PFLAG)=0
  3779   "RTN","IBC NEKIT",292 ,0)
  3780    K IBPURGE
  3781   "RTN","IBC NEKIT",293 ,0)
  3782    S IBTQIEN 1=+$$FIND1 ^DIC(365.1 8,,"QX",IB TQ1,"B")
  3783   "RTN","IBC NEKIT",294 ,0)
  3784    Q:'IBTQIE N1  ; the  passed TQ  IEN is not  in the tr acking fil e
  3785   "RTN","IBC NEKIT",295 ,0)
  3786    S IBPURGE ("EICD",36 5.1,IBTQ1) =""                ;E ICD TQ for  identific ations
  3787   "RTN","IBC NEKIT",296 ,0)
  3788    S IBTQIEN =+$$GET1^D IQ(365.18, IBTQIEN1,. 06,"I") ;E ICD RESPON SE for ide ntificatio ns
  3789   "RTN","IBC NEKIT",297 ,0)
  3790    I IBTQIEN  S IBPURGE ("EICD",36 5,IBTQIEN) =""
  3791   "RTN","IBC NEKIT",298 ,0)
  3792    ; 
  3793   "RTN","IBC NEKIT",299 ,0)
  3794    ; loop th rough the  EICD verif ication en tries look ing for ex clusions  
  3795   "RTN","IBC NEKIT",300 ,0)
  3796    S IBTRKIE N=0 F  S I BTRKIEN=$O (^IBCN(365 .18,IBTQIE N1,"INS-FN D",IBTRKIE N)) Q:'IBT RKIEN  D   Q:IBSKIP
  3797   "RTN","IBC NEKIT",301 ,0)
  3798    . ;
  3799   "RTN","IBC NEKIT",302 ,0)
  3800    . ; check  the 1 nod e data for  associate d TQs & th eir respon ses
  3801   "RTN","IBC NEKIT",303 ,0)
  3802    . S IBTQI EN2=IBTRKI EN_","_IBT QIEN1_","
  3803   "RTN","IBC NEKIT",304 ,0)
  3804    . K IBFIE LDS D GETS ^DIQ(365.1 85,IBTQIEN 2,"1.01:1. 04","I","I BFIELDS")
  3805   "RTN","IBC NEKIT",305 ,0)
  3806    . ;
  3807   "RTN","IBC NEKIT",306 ,0)
  3808    . I IBFIE LDS(365.18 5,IBTQIEN2 ,1.02,"I") ="" Q                  ; No TQ w as created
  3809   "RTN","IBC NEKIT",307 ,0)
  3810    . I IBFIE LDS(365.18 5,IBTQIEN2 ,1.02,"I") >ENDDT S I BSKIP=1 Q   ; TQ not  old enough  
  3811   "RTN","IBC NEKIT",308 ,0)
  3812    . S IBTQI EN=+IBFIEL DS(365.185 ,IBTQIEN2, 1.01,"I")              ; EICD VE R INQ TQ
  3813   "RTN","IBC NEKIT",309 ,0)
  3814    . S IBTQS =+$$GET1^D IQ(365.1,I BTQIEN_"," ,.04,"I")              ; TQ Tran smission S tatus 
  3815   "RTN","IBC NEKIT",310 ,0)
  3816    . I IBTQS ,('$F(STAT LIST,","_I BTQS_","))  S IBSKIP= 1 Q         ; must be  in the li st
  3817   "RTN","IBC NEKIT",311 ,0)
  3818    . ;
  3819   "RTN","IBC NEKIT",312 ,0)
  3820    . ; Loop  thru all E ICD Verifi cations if  any are D O NOT PURG E then kil l
  3821   "RTN","IBC NEKIT",313 ,0)
  3822    . ; nothi ng associa ted with i t
  3823   "RTN","IBC NEKIT",314 ,0)
  3824    . S HLIEN =0
  3825   "RTN","IBC NEKIT",315 ,0)
  3826    . F  S HL IEN=$O(^IB CN(365.1,I BTQIEN,2,H LIEN)) Q:' HLIEN!PFLA G  D
  3827   "RTN","IBC NEKIT",316 ,0)
  3828    .. S DA=$ P($G(^IBCN (365.1,IBT QIEN,2,HLI EN,0)),U,3 ) Q:'DA
  3829   "RTN","IBC NEKIT",317 ,0)
  3830    .. I +$$G ET1^DIQ(36 5,DA_",",. 11,"I") S  PFLAG=1 Q   ;"DO NOT  PURGE"
  3831   "RTN","IBC NEKIT",318 ,0)
  3832    .. S IBPU RGE("EICD" ,365,DA)=" "  ; array  of Verifi cations to  purge (re sponses)
  3833   "RTN","IBC NEKIT",319 ,0)
  3834    . I PFLAG  Q
  3835   "RTN","IBC NEKIT",320 ,0)
  3836    . S IBPUR GE("EICD", 365.1,IBTQ IEN)="" ;  array of V erificatio ns to purg e (inquiri es)
  3837   "RTN","IBC NEKIT",321 ,0)
  3838    ;
  3839   "RTN","IBC NEKIT",322 ,0)
  3840    I PFLAG!I BSKIP K IB PURGE  ; D O NOT PURG E is set o r Not all  records ar e old enou gh
  3841   "RTN","IBC NEKIT",323 ,0)
  3842    ;
  3843   "RTN","IBC NEKIT",324 ,0)
  3844    I '$D(IBP URGE) Q  ;  No record s associat ed with th is entry t o purge
  3845   "RTN","IBC NEKIT",325 ,0)
  3846    S IBPURGE ("EICD",36 5.18,IBTQ1 )=""
  3847   "RTN","IBC NEKIT",326 ,0)
  3848    S FILE=""  F  S FILE =$O(IBPURG E("EICD",F ILE)) Q:'F ILE  D
  3849   "RTN","IBC NEKIT",327 ,0)
  3850    . S DIK=" ^IBCN("_FI LE_","
  3851   "RTN","IBC NEKIT",328 ,0)
  3852    . S DA=""  F  S DA=$ O(IBPURGE( "EICD",FIL E,DA)) Q:' DA  D
  3853   "RTN","IBC NEKIT",329 ,0)
  3854    .. D ^DIK
  3855   "RTN","IBC NEKIT",330 ,0)
  3856    K IBPURGE ,DA,DIK
  3857   "RTN","IBC NEKIT",331 ,0)
  3858    Q
  3859   "RTN","IBC NEKIT",332 ,0)
  3860    ;
  3861   "RTN","IBC NERP3")
  3862   0^4^B10212 8247^B7982 4613
  3863   "RTN","IBC NERP3",1,0 )
  3864   IBCNERP3 ; DAOU/BHS -  IBCNE eIV  RESPONSE  REPORT PRI NT ;03-JUN -2002
  3865   "RTN","IBC NERP3",2,0 )
  3866    ;;2.0;INT EGRATED BI LLING;**18 4,271,416, 528,602**; 21-MAR-94; Build 22
  3867   "RTN","IBC NERP3",3,0 )
  3868    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  3869   "RTN","IBC NERP3",4,0 )
  3870    ;
  3871   "RTN","IBC NERP3",5,0 )
  3872    ; eIV - I nsurance V erificatio n
  3873   "RTN","IBC NERP3",6,0 )
  3874    ;
  3875   "RTN","IBC NERP3",7,0 )
  3876    ; Called  by IBCNERP A
  3877   "RTN","IBC NERP3",8,0 )
  3878    ; Input f rom IBCNER P1/2:
  3879   "RTN","IBC NERP3",9,0 )
  3880    ;  IBCNER TN="IBCNER P1" - Driv er rtn
  3881   "RTN","IBC NERP3",10, 0)
  3882    ;  IBCNES PC("BEGDT" )=Start Dt ,  IBCNESP C("ENDDT") =End Dt
  3883   "RTN","IBC NERP3",11, 0)
  3884    ;  IBCNES PC("PYR")= Pyr IEN OR  "" for al l
  3885   "RTN","IBC NERP3",12, 0)
  3886    ;  IBCNES PC("PAT")= Pat IEN OR  "" for al l
  3887   "RTN","IBC NERP3",13, 0)
  3888    ;  IBCNES PC("TYPE") =A (All Re sponses) O R M (Most  Recent Res ponses) fo r
  3889   "RTN","IBC NERP3",14, 0)
  3890    ;   uniqu e Pyr/Pt p air
  3891   "RTN","IBC NERP3",15, 0)
  3892    ;  IBCNES PC("SORT") =1 (PyrNm)  OR 2 (Pat Nm)
  3893   "RTN","IBC NERP3",16, 0)
  3894    ;  IBCNES PC("TRCN") =Trace #^I EN, if non -null, all  params nu ll
  3895   "RTN","IBC NERP3",17, 0)
  3896    ;  IBCNES PC("RFLAG" )=Report F lag used t o indicate  which rep ort is bei ng
  3897   "RTN","IBC NERP3",18, 0)
  3898    ;   run.   Response  Report (0) , Inactive  Report (1 ), or Ambi guous
  3899   "RTN","IBC NERP3",19, 0)
  3900    ;   Repor t (2).
  3901   "RTN","IBC NERP3",20, 0)
  3902    ;  IBCNES PC("DTEXP" )=Expirati on date us ed in the  inactive p olicy repo rt
  3903   "RTN","IBC NERP3",21, 0)
  3904    ;  IBOUT= "R" for Re port forma t or "E" f or Excel f ormat
  3905   "RTN","IBC NERP3",22, 0)
  3906    ;
  3907   "RTN","IBC NERP3",23, 0)
  3908    ;  Based  on structu re of eIV  Response F ile (#365)
  3909   "RTN","IBC NERP3",24, 0)
  3910    ;  ^TMP($ J,IBCNERTN ,S1,S2,CT, 0) based o n ^IBCN(36 5,DA,0)
  3911   "RTN","IBC NERP3",25, 0)
  3912    ;    IBCN ERTN="IBCN ERP1", S1= PyrName(SO RT=1) or P atNm(SORT= 2),
  3913   "RTN","IBC NERP3",26, 0)
  3914    ;    S2=P atName(SOR T=1) or Py rName(SORT =2), CT=Se q ct
  3915   "RTN","IBC NERP3",27, 0)
  3916    ;  ^TMP($ J,IBCNERTN ,S1,S2,CT, 1) based o n ^IBCN(36 5,DA,1)
  3917   "RTN","IBC NERP3",28, 0)
  3918    ;  ^TMP($ J,IBCNERTN ,S1,S2,2,E BCT) based  on ^IBCN( 365,DA,2)
  3919   "RTN","IBC NERP3",29, 0)
  3920    ;    EBCT =E/B IEN ( 365.02)
  3921   "RTN","IBC NERP3",30, 0)
  3922    ;  ^TMP($ J,IBCNERTN ,S1,S2,2,E BCT,NTCT)= based on ^ IBCN(365,D A,2,EB,NT)
  3923   "RTN","IBC NERP3",31, 0)
  3924    ;   NTCT= Notes Ct,  may not be  Notes IEN , if line  wrapped (3 65.021)
  3925   "RTN","IBC NERP3",32, 0)
  3926    ;  ^TMP($ J,IBCNERTN ,S1,S2,2,C NCT) based  on ^IBCN( 365,DA,3)
  3927   "RTN","IBC NERP3",33, 0)
  3928    ;   CNCT= Cont Pers  IEN (365.0 3)
  3929   "RTN","IBC NERP3",34, 0)
  3930    ;  ^TMP($ J,IBCNERTN ,S1,S2,4,C T)= err tx t based on  ^IBCN(365 ,DA,4)
  3931   "RTN","IBC NERP3",35, 0)
  3932    ;   CT=1/ 2 if >60 c h long
  3933   "RTN","IBC NERP3",36, 0)
  3934    ;  ^TMP($ J,IBCNERTN ,S1,S2,5,C T)= based  on # lines  of commen ts reqd
  3935   "RTN","IBC NERP3",37, 0)
  3936    ;   CT=1  to display  future re transmissi on date
  3937   "RTN","IBC NERP3",38, 0)
  3938    ; Must ca ll at appr opriate ta g
  3939   "RTN","IBC NERP3",39, 0)
  3940    Q
  3941   "RTN","IBC NERP3",40, 0)
  3942    ;
  3943   "RTN","IBC NERP3",41, 0)
  3944   PRINT(RTN, BDT,EDT,PY R,PAT,TYP, SRT,PGC,PX T,MAX,CRT, TRC,EXP,IP RF,IBRDT,I BOUT) ; Pr int data
  3945   "RTN","IBC NERP3",42, 0)
  3946    ; Input:  RTN="IBCEN RP1", BDT= start dt,  EDT=end dt , PYR=pyr  ien,
  3947   "RTN","IBC NERP3",43, 0)
  3948    ;  PAT= p at ien, TY P=A/M, SRT =1/2, PGC= page ct, P XT=exit fl g,
  3949   "RTN","IBC NERP3",44, 0)
  3950    ; MAX=max  line ct/p g, CRT=1/0 , TRC=trc# , EXP=earl iest expir ation date ,IBRDT=tod ay's date/ time forma tted 
  3951   "RTN","IBC NERP3",45, 0)
  3952    N EORMSG, NONEMSG,SO RT1,SORT2, CNT,CNFLG, ERFLG,PRT1 ,PRT2,DISP DATA
  3953   "RTN","IBC NERP3",46, 0)
  3954    N OPRT1,O PRT2 ; Ori ginal valu es for PRT 1 and PRT2 , respecti vely
  3955   "RTN","IBC NERP3",47, 0)
  3956    S EORMSG= "*** END O F REPORT * **"
  3957   "RTN","IBC NERP3",48, 0)
  3958    S NONEMSG ="* * * N  O  D A T A   F O U N  D * * *"
  3959   "RTN","IBC NERP3",49, 0)
  3960    S (SORT1, SORT2)=""
  3961   "RTN","IBC NERP3",50, 0)
  3962    ;
  3963   "RTN","IBC NERP3",51, 0)
  3964    D PHDL:IB OUT="E" I  $G(ZTSTOP) !PXT G PRI NTX
  3965   "RTN","IBC NERP3",52, 0)
  3966    ;
  3967   "RTN","IBC NERP3",53, 0)
  3968    ; If glob al does no t exist -  display No  Data mess age
  3969   "RTN","IBC NERP3",54, 0)
  3970    I '$D(^TM P($J,RTN))  W !,?(80- $L(NONEMSG )\2),NONEM SG,!!
  3971   "RTN","IBC NERP3",55, 0)
  3972    ;
  3973   "RTN","IBC NERP3",56, 0)
  3974    F  S SORT 1=$O(^TMP( $J,RTN,SOR T1)) Q:SOR T1=""  D   Q:PXT!$G(Z TSTOP)
  3975   "RTN","IBC NERP3",57, 0)
  3976    . S (OPRT 1,PRT1)=$S (SORT1="~N O PAYER":" * No Payer  Identifie d",1:SORT1 )
  3977   "RTN","IBC NERP3",58, 0)
  3978    . S SORT2 ="" F  S S ORT2=$O(^T MP($J,RTN, SORT1,SORT 2)) Q:SORT 2=""  D  Q :PXT!$G(ZT STOP)
  3979   "RTN","IBC NERP3",59, 0)
  3980    . . S (OP RT2,PRT2)= $S(SORT2=" ~NO PAYER" :"* No Pay er Identif ied",1:SOR T2)
  3981   "RTN","IBC NERP3",60, 0)
  3982    . . S CNT ="" F  S C NT=$O(^TMP ($J,RTN,SO RT1,SORT2, CNT)) Q:CN T=""  D  Q :PXT!$G(ZT STOP)
  3983   "RTN","IBC NERP3",61, 0)
  3984    . . . I I BOUT="E" D  XLDATA Q
  3985   "RTN","IBC NERP3",62, 0)
  3986    . . . D S SDB ; add  SSN (from  ^DPT) and  DOB to pat ient heade r info
  3987   "RTN","IBC NERP3",63, 0)
  3988    . . . D H EADER
  3989   "RTN","IBC NERP3",64, 0)
  3990    . . . I $ G(ZTSTOP)! PXT Q
  3991   "RTN","IBC NERP3",65, 0)
  3992    . . . K D ISPDATA  ;  Init disp
  3993   "RTN","IBC NERP3",66, 0)
  3994    . . . D D ATA^IBCNER PE(.DISPDA TA),LINE(. DISPDATA)   ; build/d isplay dat a
  3995   "RTN","IBC NERP3",67, 0)
  3996    ;
  3997   "RTN","IBC NERP3",68, 0)
  3998    I $G(ZTST OP)!PXT G  PRINTX
  3999   "RTN","IBC NERP3",69, 0)
  4000    S (CNFLG, ERFLG)=0
  4001   "RTN","IBC NERP3",70, 0)
  4002    I $Y+1>MA X!('PGC) D  HEADER I  $G(ZTSTOP) !PXT G PRI NTX
  4003   "RTN","IBC NERP3",71, 0)
  4004    W !,?(80- $L(EORMSG) \2),EORMSG
  4005   "RTN","IBC NERP3",72, 0)
  4006   PRINTX ;
  4007   "RTN","IBC NERP3",73, 0)
  4008    Q
  4009   "RTN","IBC NERP3",74, 0)
  4010    ;
  4011   "RTN","IBC NERP3",75, 0)
  4012   XLDATA ; E xcel outpu t  ; 528
  4013   "RTN","IBC NERP3",76, 0)
  4014    N PYRNM,P TNM,DFN,PT SSN,PTDOB, REFQ,REFID ,RFIDSC,PR OCD,REFID2 ,PRIDC,MLI ST,EMPST,G OVAFL,DTMP ,SRVRNK,MD ESC,RPTDAT A
  4015   "RTN","IBC NERP3",77, 0)
  4016    M RPTDATA =^TMP($J,R TN,SORT1,S ORT2,CNT)
  4017   "RTN","IBC NERP3",78, 0)
  4018    S PYRNM=$ P(RPTDATA( 0),U,3),PY RNM=$$GET1 ^DIQ(365.1 2,PYRNM,.0 1)
  4019   "RTN","IBC NERP3",79, 0)
  4020    S DFN=$P( RPTDATA(0) ,U,2),PTNM =$$GET1^DI Q(2,DFN,.0 1)
  4021   "RTN","IBC NERP3",80, 0)
  4022    S PTSSN=$ E($$GETSSN ^IBCNEDE5( DFN),6,9), PTDOB=$$GE TDOB^IBCNE DEQ(DFN)
  4023   "RTN","IBC NERP3",81, 0)
  4024    W !,$S(SR T=1:PYRNM, 1:PTNM)_U_ $S(SRT=1:P TNM,1:PYRN M)_U_PTSSN _U_PTDOB_U _$P(RPTDAT A(13),U)_U _$P(RPTDAT A(13),U,2) _U_$P(RPTD ATA(1),U,2 )_U_$P(RPT DATA(1),U, 3)_U_$P(RP TDATA(1),U ,4)_U_$P(R PTDATA(14) ,U)_U_$P(R PTDATA(14) ,U,2)_U_$P (RPTDATA(1 ),U,8)
  4025   "RTN","IBC NERP3",82, 0)
  4026    W U_RPTDA TA(8)_U_$P (RPTDATA(1 ),U,18)_U_ $P(RPTDATA (1),U,13)_ U_$P(RPTDA TA(1),U,10 )_U_$P(RPT DATA(1),U, 16)_U_$P(R PTDATA(1), U,11)_U_$P (RPTDATA(1 ),U,17)
  4027   "RTN","IBC NERP3",83, 0)
  4028    W U_$P(RP TDATA(1),U ,12)_U_$P( RPTDATA(1) ,U,19)_U_$ P(RPTDATA( 0),U,7)_U_ $P(RPTDATA (0),U,9)_U _$P(RPTDAT A(1),U,20) _U
  4029   "RTN","IBC NERP3",84, 0)
  4030    D DATA^IB CNERPE(.DI SPDATA)    ; Build El ig. Ben. g lobal
  4031   "RTN","IBC NERP3",85, 0)
  4032    D GTDT
  4033   "RTN","IBC NERP3",86, 0)
  4034    W $G(REFQ )_U_$G(REF ID)_U_$G(R FIDSC)_U_$ G(PROCD)_U _$G(REFID2 )_U_$G(PRI DC)_U_$G(M LIST)_U_$G (EMPST)_U_ $G(GOVAFL) _U_$G(DTMP )_U_$G(SRV RNK)_U_$G( MDESC)
  4035   "RTN","IBC NERP3",87, 0)
  4036    Q
  4037   "RTN","IBC NERP3",88, 0)
  4038    ;
  4039   "RTN","IBC NERP3",89, 0)
  4040   GTDT ; Get  Eligibili ty/Group P lan Inform ation
  4041   "RTN","IBC NERP3",90, 0)
  4042    ;^TMP("EI V RESP. EB  DATA",$J, "DISP",1,0
  4043   "RTN","IBC NERP3",91, 0)
  4044    ;S SEL=$$ TRIM^XLFST R($E(Y(0), 1,30),"R")
  4045   "RTN","IBC NERP3",92, 0)
  4046    N LN,OUT, DATA
  4047   "RTN","IBC NERP3",93, 0)
  4048    S (REFID, REFQ,RFIDS C,PROCD,RE FID2,PRIDC ,EMPST,MLI ST,DTMP,GO VAFL,SRVRN K,MDESC)=" "
  4049   "RTN","IBC NERP3",94, 0)
  4050    S LN=0
  4051   "RTN","IBC NERP3",95, 0)
  4052    F  S LN=$ O(^TMP("EI V RESP. EB  DATA",$J, "DISP",LN) ) Q:LN=""   D
  4053   "RTN","IBC NERP3",96, 0)
  4054    . S OUT=$ G(^TMP("EI V RESP. EB  DATA",$J, "DISP",LN, 0))
  4055   "RTN","IBC NERP3",97, 0)
  4056    . ;
  4057   "RTN","IBC NERP3",98, 0)
  4058    . I OUT[" Reference  ID Qualifi er:" D
  4059   "RTN","IBC NERP3",99, 0)
  4060    . . S DAT A=$P(OUT," Reference  ID Qualifi er:",2)
  4061   "RTN","IBC NERP3",100 ,0)
  4062    . . S REF ID=$$TRIM^ XLFSTR($P( DATA,"Refe rence ID:" ,2),"R")
  4063   "RTN","IBC NERP3",101 ,0)
  4064    . . S REF Q=$$TRIM^X LFSTR($P(D ATA,"Refer ence ID:", 1),"R")
  4065   "RTN","IBC NERP3",102 ,0)
  4066    . I OUT[" Reference  ID descrip tion:" D
  4067   "RTN","IBC NERP3",103 ,0)
  4068    . . S DAT A=$P(OUT," Reference  ID descrip tion:",2)
  4069   "RTN","IBC NERP3",104 ,0)
  4070    . . S RFI DSC=$$TRIM ^XLFSTR(DA TA,"R")
  4071   "RTN","IBC NERP3",105 ,0)
  4072    . I OUT[" Provider C ode:" D
  4073   "RTN","IBC NERP3",106 ,0)
  4074    . . S DAT A=$P(OUT," Provider C ode:",2)
  4075   "RTN","IBC NERP3",107 ,0)
  4076    . . S PRO CD=$$TRIM^ XLFSTR(DAT A,"R")
  4077   "RTN","IBC NERP3",108 ,0)
  4078    . I OUT[" Reference  ID:" D
  4079   "RTN","IBC NERP3",109 ,0)
  4080    . . S DAT A=$P(OUT," Reference  ID:",2)
  4081   "RTN","IBC NERP3",110 ,0)
  4082    . . S REF ID2=$$TRIM ^XLFSTR(DA TA,"R")
  4083   "RTN","IBC NERP3",111 ,0)
  4084    . I OUT[" Primary Di agnosis Co de:" D
  4085   "RTN","IBC NERP3",112 ,0)
  4086    . . S DAT A=$P(OUT," Primary Di agnosis Co de:",2)
  4087   "RTN","IBC NERP3",113 ,0)
  4088    . . S PRI DC=$$TRIM^ XLFSTR(DAT A,"R")
  4089   "RTN","IBC NERP3",114 ,0)
  4090    . I OUT[" Military I nfo Status :" D
  4091   "RTN","IBC NERP3",115 ,0)
  4092    . . S DAT A=$P(OUT," Military I nfo Status :",2)
  4093   "RTN","IBC NERP3",116 ,0)
  4094    . . S EMP ST=$$TRIM^ XLFSTR($P( DATA,"Empl oyment Sta tus:",2)," R")
  4095   "RTN","IBC NERP3",117 ,0)
  4096    . . S MLI ST=$$TRIM^ XLFSTR($P( DATA,"Empl oyment Sta tus:",1)," R")
  4097   "RTN","IBC NERP3",118 ,0)
  4098    . I OUT[" Government  Affiliati on:" D
  4099   "RTN","IBC NERP3",119 ,0)
  4100    . . S DAT A=$P(OUT," Government  Affiliati on:",2)
  4101   "RTN","IBC NERP3",120 ,0)
  4102    . . S DTM P=$$TRIM^X LFSTR($P(D ATA,"Date  Time Perio d:",2),"R" )
  4103   "RTN","IBC NERP3",121 ,0)
  4104    . . S GOV AFL=$$TRIM ^XLFSTR($P (DATA,"Dat e Time Per iod:",1)," R")
  4105   "RTN","IBC NERP3",122 ,0)
  4106    . I OUT[" Service Ra nk:" D
  4107   "RTN","IBC NERP3",123 ,0)
  4108    . . S DAT A=$P(OUT," Service Ra nk:",2)
  4109   "RTN","IBC NERP3",124 ,0)
  4110    . . S SRV RNK=$$TRIM ^XLFSTR(DA TA,"R")
  4111   "RTN","IBC NERP3",125 ,0)
  4112    . I OUT[" Desc:" D
  4113   "RTN","IBC NERP3",126 ,0)
  4114    . . S DAT A=$P(OUT," Desc:",2)
  4115   "RTN","IBC NERP3",127 ,0)
  4116    . . S MDE SC=$$TRIM^ XLFSTR(DAT A,"R")
  4117   "RTN","IBC NERP3",128 ,0)
  4118    Q
  4119   "RTN","IBC NERP3",129 ,0)
  4120    ;
  4121   "RTN","IBC NERP3",130 ,0)
  4122   HEADER ; P rint hdr i nfo
  4123   "RTN","IBC NERP3",131 ,0)
  4124    N X,Y,DIR ,DTOUT,DUO UT,OFFSET, HDR,LIN,HD R
  4125   "RTN","IBC NERP3",132 ,0)
  4126    I CRT,PGC >0,'$D(ZTQ UEUED) D   I PXT G HE ADERX
  4127   "RTN","IBC NERP3",133 ,0)
  4128    . I MAX<5 1 F LIN=1: 1:(MAX-$Y)  W !
  4129   "RTN","IBC NERP3",134 ,0)
  4130    . S DIR(0 )="E" D ^D IR K DIR
  4131   "RTN","IBC NERP3",135 ,0)
  4132    . I $D(DT OUT)!($D(D UOUT)) S P XT=1 Q
  4133   "RTN","IBC NERP3",136 ,0)
  4134    I $D(ZTQU EUED),$$S^ %ZTLOAD()  S ZTSTOP=1  G HEADERX
  4135   "RTN","IBC NERP3",137 ,0)
  4136    ;
  4137   "RTN","IBC NERP3",138 ,0)
  4138    S PGC=PGC +1
  4139   "RTN","IBC NERP3",139 ,0)
  4140    W @IOF,!, ?1,$S($G(I PRF)=1:"eI V Inactive  Policy Re port",$G(I PRF)=2:"eI V Ambiguou s Policy R eport",1:" eIV Respon se Report" ) I TRC'=" " W " by T race #"
  4141   "RTN","IBC NERP3",140 ,0)
  4142    ;
  4143   "RTN","IBC NERP3",141 ,0)
  4144    S HDR=IBR DT_"  Page : "_PGC,OF FSET=79-$L (HDR)
  4145   "RTN","IBC NERP3",142 ,0)
  4146    W ?OFFSET ,HDR
  4147   "RTN","IBC NERP3",143 ,0)
  4148    ;
  4149   "RTN","IBC NERP3",144 ,0)
  4150    I TRC'=""  S HDR="Tr ace #: "_T RC,OFFSET= 80-$L(HDR) \2 W !,?OF FSET,HDR
  4151   "RTN","IBC NERP3",145 ,0)
  4152    I TRC=""  D
  4153   "RTN","IBC NERP3",146 ,0)
  4154    . W !,?1, "Sorted by : "_$S(SRT =1:"Payer" ,1:"Patien t")_" Name "
  4155   "RTN","IBC NERP3",147 ,0)
  4156    . S HDR=" Responses  Displayed:  "_$S(TYP= "M":"Most  Recent",1: "All")
  4157   "RTN","IBC NERP3",148 ,0)
  4158    . S OFFSE T=79-$L(HD R)
  4159   "RTN","IBC NERP3",149 ,0)
  4160    . W ?OFFS ET,HDR
  4161   "RTN","IBC NERP3",150 ,0)
  4162    . I $G(IP RF)=1 W !, ?1,"Earlie st Policy  Expiration  Date: ",$ $FMTE^XLFD T(EXP,"5Z" ),!
  4163   "RTN","IBC NERP3",151 ,0)
  4164    . S HDR=$ $FMTE^XLFD T(BDT,"5Z" )_" - "_$$ FMTE^XLFDT (EDT,"5Z")
  4165   "RTN","IBC NERP3",152 ,0)
  4166    . S OFFSE T=80-$L(HD R)\2
  4167   "RTN","IBC NERP3",153 ,0)
  4168    . W !,?OF FSET,HDR
  4169   "RTN","IBC NERP3",154 ,0)
  4170    . ; Disp  SORT1 rng
  4171   "RTN","IBC NERP3",155 ,0)
  4172    . S HDR=" "
  4173   "RTN","IBC NERP3",156 ,0)
  4174    . I SRT=1 ,PYR="" S  HDR="All P ayers"
  4175   "RTN","IBC NERP3",157 ,0)
  4176    . I SRT=2 ,PAT="" S  HDR="All P atients"
  4177   "RTN","IBC NERP3",158 ,0)
  4178    . I HDR=" " D
  4179   "RTN","IBC NERP3",159 ,0)
  4180    ..  I SRT =1 S HDR=$ P($G(^IBE( 365.12,PYR ,0)),U,1)  Q
  4181   "RTN","IBC NERP3",160 ,0)
  4182    ..  S HDR =$P($G(^DP T(PAT,0)), U,1)
  4183   "RTN","IBC NERP3",161 ,0)
  4184    . S OFFSE T=80-$L(HD R)\2
  4185   "RTN","IBC NERP3",162 ,0)
  4186    . W !,?OF FSET,HDR
  4187   "RTN","IBC NERP3",163 ,0)
  4188    . ; Disp  SORT2 rng
  4189   "RTN","IBC NERP3",164 ,0)
  4190    . S HDR=" "
  4191   "RTN","IBC NERP3",165 ,0)
  4192    . I SRT=1 ,PAT="" S  HDR="All P atients"
  4193   "RTN","IBC NERP3",166 ,0)
  4194    . I SRT=2 ,PYR="" S  HDR="All P ayers"
  4195   "RTN","IBC NERP3",167 ,0)
  4196    . I HDR=" " D
  4197   "RTN","IBC NERP3",168 ,0)
  4198    .. I SRT= 1 S HDR=$P ($G(^DPT(P AT,0)),U,1 ) Q
  4199   "RTN","IBC NERP3",169 ,0)
  4200    .. S HDR= $P($G(^IBE (365.12,PY R,0)),U,1)
  4201   "RTN","IBC NERP3",170 ,0)
  4202    . S OFFSE T=80-$L(HD R)\2
  4203   "RTN","IBC NERP3",171 ,0)
  4204    . W !,?OF FSET,HDR
  4205   "RTN","IBC NERP3",172 ,0)
  4206    W !
  4207   "RTN","IBC NERP3",173 ,0)
  4208    ; Build d isp
  4209   "RTN","IBC NERP3",174 ,0)
  4210    I SORT1'= "",SORT2'= "" D
  4211   "RTN","IBC NERP3",175 ,0)
  4212    . W !,?1, $$FO^IBCNE UT1($S(TRC '=""!(SRT= 1):"  Paye r: ",1:"Pa tient: "), 9)_$E(PRT1 ,1,69)
  4213   "RTN","IBC NERP3",176 ,0)
  4214    . W !,?1, $$FO^IBCNE UT1($S(TRC '=""!(SRT= 1):"Patien t: ",1:"   Payer: "), 9)_$E(PRT2 ,1,69)
  4215   "RTN","IBC NERP3",177 ,0)
  4216    . W !
  4217   "RTN","IBC NERP3",178 ,0)
  4218   HEADERX ;
  4219   "RTN","IBC NERP3",179 ,0)
  4220    Q
  4221   "RTN","IBC NERP3",180 ,0)
  4222    ;
  4223   "RTN","IBC NERP3",181 ,0)
  4224   LINE(DISPD ATA) ;  Pr int data
  4225   "RTN","IBC NERP3",182 ,0)
  4226    N LNCT,LN TOT,NWPG
  4227   "RTN","IBC NERP3",183 ,0)
  4228    S LNTOT=+ $O(DISPDAT A(""),-1)
  4229   "RTN","IBC NERP3",184 ,0)
  4230    S (CNFLG, ERFLG,NWPG )=0
  4231   "RTN","IBC NERP3",185 ,0)
  4232    F LNCT=1: 1:LNTOT D   Q:$G(ZTST OP)!PXT
  4233   "RTN","IBC NERP3",186 ,0)
  4234    . I $Y+1> MAX!('PGC)  D HEADER  S NWPG=1 I  $G(ZTSTOP )!PXT Q
  4235   "RTN","IBC NERP3",187 ,0)
  4236    . I DISPD ATA(LNCT)= "Contact I nformation :"!(DISPDA TA(LNCT)=" Error Info rmation:") ,$Y+3>MAX  S (CNFLG,E RFLG)=0 D  HEADER S N WPG=1 I $G (ZTSTOP)!P XT Q
  4237   "RTN","IBC NERP3",188 ,0)
  4238    . I CNFLG ,DISPDATA( LNCT)="",$ G(DISPDATA (LNCT+1))= "Error Inf ormation:"  S CNFLG=0
  4239   "RTN","IBC NERP3",189 ,0)
  4240    . I NWPG, CNFLG W !, ?1,"Contac t Informat ion: (cont 'd)",!
  4241   "RTN","IBC NERP3",190 ,0)
  4242    . I NWPG, ERFLG W !, ?1,"Error  Informatio n: (cont'd )",!
  4243   "RTN","IBC NERP3",191 ,0)
  4244    . I 'NWPG !(NWPG&(DI SPDATA(LNC T)'="")) W  !,?1,DISP DATA(LNCT)
  4245   "RTN","IBC NERP3",192 ,0)
  4246    . I NWPG  S NWPG=0
  4247   "RTN","IBC NERP3",193 ,0)
  4248    . I DISPD ATA(LNCT)[ "Contact I nformation :" S ERFLG =0,CNFLG=1
  4249   "RTN","IBC NERP3",194 ,0)
  4250    . I DISPD ATA(LNCT)[ "Error Inf ormation:"  S CNFLG=0 ,ERFLG=1
  4251   "RTN","IBC NERP3",195 ,0)
  4252    . Q
  4253   "RTN","IBC NERP3",196 ,0)
  4254    S (CNFLG, ERFLG)=0
  4255   "RTN","IBC NERP3",197 ,0)
  4256   LINEX ; 
  4257   "RTN","IBC NERP3",198 ,0)
  4258    Q
  4259   "RTN","IBC NERP3",199 ,0)
  4260    ;
  4261   "RTN","IBC NERP3",200 ,0)
  4262   SSDB ; Dis play last  4 digits o f SSN and  DOB to fac ilitate pt . identifi cation
  4263   "RTN","IBC NERP3",201 ,0)
  4264    ; $$SSN^I BCNEDEQ(DF N) returns  SSN follo wed by DOB
  4265   "RTN","IBC NERP3",202 ,0)
  4266    ;
  4267   "RTN","IBC NERP3",203 ,0)
  4268    N DFN
  4269   "RTN","IBC NERP3",204 ,0)
  4270    S DFN=$P( $G(^TMP($J ,RTN,SORT1 ,SORT2,CNT ,0)),U,2)
  4271   "RTN","IBC NERP3",205 ,0)
  4272    I DFN D
  4273   "RTN","IBC NERP3",206 ,0)
  4274    . I SRT=1 !TRC S PRT 2=OPRT2_$$ SSN^IBCNED EQ(DFN) Q
  4275   "RTN","IBC NERP3",207 ,0)
  4276    . S PRT1= OPRT1_$$SS N^IBCNEDEQ (DFN)
  4277   "RTN","IBC NERP3",208 ,0)
  4278    Q
  4279   "RTN","IBC NERP3",209 ,0)
  4280    ;
  4281   "RTN","IBC NERP3",210 ,0)
  4282   PHDL ; - P rint the h eader line  for the E xcel sprea dsheet  ;  528
  4283   "RTN","IBC NERP3",211 ,0)
  4284    N X
  4285   "RTN","IBC NERP3",212 ,0)
  4286    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets
  4287   "RTN","IBC NERP3",213 ,0)
  4288    S EHDR=$S ($G(IPRF)= 1:"eIV Ina ctive Poli cy Report" ,$G(IPRF)= 2:"eIV Amb iguous Pol icy Report ",1:"eIV R esponse Re port") I T RC'="" S E HDR=EHDR_" ^by Trace  #"
  4289   "RTN","IBC NERP3",214 ,0)
  4290    W !,EHDR_ "^"_$$FMTE ^XLFDT($$N OW^XLFDT,1 )
  4291   "RTN","IBC NERP3",215 ,0)
  4292    ;
  4293   "RTN","IBC NERP3",216 ,0)
  4294    I TRC'=""  S HDR="Tr ace #: "_T RC W !,HDR
  4295   "RTN","IBC NERP3",217 ,0)
  4296    I TRC=""  D
  4297   "RTN","IBC NERP3",218 ,0)
  4298    . S EHDR= "Sorted by : "_$S(SRT =1:"Payer" ,1:"Patien t")_" Name "
  4299   "RTN","IBC NERP3",219 ,0)
  4300    . S EHDR= EHDR_"^Res ponses Dis played: "_ $S(TYP="M" :"Most Rec ent",1:"Al l")
  4301   "RTN","IBC NERP3",220 ,0)
  4302    . W !,EHD R S EHDR=" "
  4303   "RTN","IBC NERP3",221 ,0)
  4304    . I $G(IP RF)=1 W !, "Earliest  Policy Exp iration Da te: ",$$FM TE^XLFDT(E XP,"5Z")
  4305   "RTN","IBC NERP3",222 ,0)
  4306    . S EHDR= $$FMTE^XLF DT(BDT,"5Z ")_" - "_$ $FMTE^XLFD T(EDT,"5Z" )
  4307   "RTN","IBC NERP3",223 ,0)
  4308    . W !,EHD R
  4309   "RTN","IBC NERP3",224 ,0)
  4310    . ; Disp  SORT1 rng
  4311   "RTN","IBC NERP3",225 ,0)
  4312    . S EHDR= ""
  4313   "RTN","IBC NERP3",226 ,0)
  4314    . I SRT=1 ,PYR="" S  EHDR="All  Payers"
  4315   "RTN","IBC NERP3",227 ,0)
  4316    . I SRT=2 ,PAT="" S  EHDR="All  Patients"
  4317   "RTN","IBC NERP3",228 ,0)
  4318    . I EHDR= "" D
  4319   "RTN","IBC NERP3",229 ,0)
  4320    .. I SRT= 1 S EHDR=$ P($G(^IBE( 365.12,PYR ,0)),U,1)  Q
  4321   "RTN","IBC NERP3",230 ,0)
  4322    .. S EHDR =$P($G(^DP T(PAT,0)), U,1)
  4323   "RTN","IBC NERP3",231 ,0)
  4324    . W !,EHD R
  4325   "RTN","IBC NERP3",232 ,0)
  4326    . ; Disp  SORT2 rng
  4327   "RTN","IBC NERP3",233 ,0)
  4328    . S EHDR= ""
  4329   "RTN","IBC NERP3",234 ,0)
  4330    . I SRT=1 ,PAT="" S  EHDR="All  Patients"
  4331   "RTN","IBC NERP3",235 ,0)
  4332    . I SRT=2 ,PYR="" S  EHDR="All  Payers"
  4333   "RTN","IBC NERP3",236 ,0)
  4334    . I EHDR= "" D
  4335   "RTN","IBC NERP3",237 ,0)
  4336    .. I SRT= 1 S EHDR=$ P($G(^DPT( PAT,0)),U, 1) Q
  4337   "RTN","IBC NERP3",238 ,0)
  4338    .. S EHDR =$P($G(^IB E(365.12,P YR,0)),U,1 )
  4339   "RTN","IBC NERP3",239 ,0)
  4340     . W !,EH DR
  4341   "RTN","IBC NERP3",240 ,0)
  4342    W !
  4343   "RTN","IBC NERP3",241 ,0)
  4344    ; Build d isp
  4345   "RTN","IBC NERP3",242 ,0)
  4346    I SORT1'= "",SORT2'= "" D
  4347   "RTN","IBC NERP3",243 ,0)
  4348    . W !,$$F O^IBCNEUT1 ($S(TRC'=" "!(SRT=1): " Payer: " ,1:"Patien t: "),9)_$ E(PRT1,1,6 9)
  4349   "RTN","IBC NERP3",244 ,0)
  4350    . W !,$$F O^IBCNEUT1 ($S(TRC'=" "!(SRT=1): "Patient:  ",1:" Paye r: "),9)_$ E(PRT2,1,6 9)
  4351   "RTN","IBC NERP3",245 ,0)
  4352    . W !
  4353   "RTN","IBC NERP3",246 ,0)
  4354    K EHDR
  4355   "RTN","IBC NERP3",247 ,0)
  4356    ; IB*602/ HN end
  4357   "RTN","IBC NERP3",248 ,0)
  4358    S PGC=1
  4359   "RTN","IBC NERP3",249 ,0)
  4360    S X=$S(SR T=1:"Payer ",1:"Patie nt")_U_$S( SRT=1:"Pat ient",1:"P ayer")_"^P atient SSN ^Patient D OB^Subscri ber^Subscr iber ID^Su bscriber D OB^Subscri ber SSN^Su bscriber S ex^Group N ame^Group  ID"
  4361   "RTN","IBC NERP3",250 ,0)
  4362    S X=X_"^W hose Insur ance^Pt Re lationship  to Subscr iber^Membe r ID^COB^S ervice Dat e^Date of  Death^Effe ctive Date ^Certifica tion Date^ Expiration  Date^Paye r Updated  Policy"
  4363   "RTN","IBC NERP3",251 ,0)
  4364    S X=X_"^R esponse Da te^Trace # ^Policy Nu mber^Refer ence ID Qu alifier^Re ference ID ^Reference  ID Descri ption^Prov ider Code^ Reference  ID^Primary  Diagnosis  Code^Mili tary Info  Status"
  4365   "RTN","IBC NERP3",252 ,0)
  4366    W X
  4367   "RTN","IBC NERP3",253 ,0)
  4368    S X="^Emp loyment St atus^Gover nment Affi liation^Da te Time Pe riod^Servi ce Rank^De sc"
  4369   "RTN","IBC NERP3",254 ,0)
  4370    W X
  4371   "RTN","IBC NERP3",255 ,0)
  4372    Q
  4373   "RTN","IBC NERPD")
  4374   0^5^B12652 3871^B1103 03722
  4375   "RTN","IBC NERPD",1,0 )
  4376   IBCNERPD ; DAOU/RO -  eIV PAYER  LINK REPOR T PRINT;AU G-2003
  4377   "RTN","IBC NERPD",2,0 )
  4378    ;;2.0;INT EGRATED BI LLING;**18 4,252,416, 521,528,59 5,602**;21 -MAR-94;Bu ild 22
  4379   "RTN","IBC NERPD",3,0 )
  4380    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  4381   "RTN","IBC NERPD",4,0 )
  4382    ;
  4383   "RTN","IBC NERPD",5,0 )
  4384    ; eIV - I nsurance V erificatio n
  4385   "RTN","IBC NERPD",6,0 )
  4386    ;
  4387   "RTN","IBC NERPD",7,0 )
  4388    ; Called  by IBCNERP B
  4389   "RTN","IBC NERPD",8,0 )
  4390    ; Input f rom IBCNER PB/C:
  4391   "RTN","IBC NERPD",9,0 )
  4392    ;  
  4393   "RTN","IBC NERPD",10, 0)
  4394    ;  ^TMP($ J,IBCNERTN ,S1,S2,CT, 0)
  4395   "RTN","IBC NERPD",11, 0)
  4396    ;    IBCN ERTN="IBCN ERPB", 
  4397   "RTN","IBC NERPD",12, 0)
  4398    ;    CT=S eq ct
  4399   "RTN","IBC NERPD",13, 0)
  4400    ;  ^TMP($ J,IBCNERTN ,S1,S2,CT, 1) 
  4401   "RTN","IBC NERPD",14, 0)
  4402    ;  IBOUT
  4403   "RTN","IBC NERPD",15, 0)
  4404    ;
  4405   "RTN","IBC NERPD",16, 0)
  4406   EN3(IBCNER TN,IBCNESP C) ; Entry  pt.  
  4407   "RTN","IBC NERPD",17, 0)
  4408    N IBTYP,I BSRT,CRT,M AXCNT,IBPX T
  4409   "RTN","IBC NERPD",18, 0)
  4410    N IBPGC,X ,Y,DIR,DTO UT,DUOUT,L IN,IBTRC,I BMAT,IBREP ,IBDET,IBP PYR,ZZ
  4411   "RTN","IBC NERPD",19, 0)
  4412    S IBREP=$ G(IBCNESPC ("REP"))
  4413   "RTN","IBC NERPD",20, 0)
  4414    S IBDET=$ G(IBCNESPC ("PDET"))
  4415   "RTN","IBC NERPD",21, 0)
  4416    S IBTYP=$ G(IBCNESPC ("PTYPE"))
  4417   "RTN","IBC NERPD",22, 0)
  4418    S IBSRT=$ G(IBCNESPC ("PSORT"))
  4419   "RTN","IBC NERPD",23, 0)
  4420    S IBPPYR= $G(IBCNESP C("PPYR"))
  4421   "RTN","IBC NERPD",24, 0)
  4422    ; Ins Rep ort
  4423   "RTN","IBC NERPD",25, 0)
  4424    I IBREP=2  D
  4425   "RTN","IBC NERPD",26, 0)
  4426    . S IBTYP =$G(IBCNES PC("ITYPE" ))
  4427   "RTN","IBC NERPD",27, 0)
  4428    . S IBSRT =$G(IBCNES PC("ISORT" ))
  4429   "RTN","IBC NERPD",28, 0)
  4430    . S IBMAT =$G(IBCNES PC("IMAT") )
  4431   "RTN","IBC NERPD",29, 0)
  4432    S (IBPXT, IBPGC)=0
  4433   "RTN","IBC NERPD",30, 0)
  4434    ; Determi ne IO para ms
  4435   "RTN","IBC NERPD",31, 0)
  4436    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  4437   "RTN","IBC NERPD",32, 0)
  4438    I IOST["C -" S MAXCN T=IOSL-3,C RT=1
  4439   "RTN","IBC NERPD",33, 0)
  4440    E  S MAXC NT=IOSL-6, CRT=0
  4441   "RTN","IBC NERPD",34, 0)
  4442    D PRINT(I BCNERTN,IB REP,IBDET, IBTYP,IBSR T,.IBPGC,. IBPXT,MAXC NT,CRT,IBO UT)
  4443   "RTN","IBC NERPD",35, 0)
  4444    I $G(ZTST OP)!IBPXT  G EXIT3
  4445   "RTN","IBC NERPD",36, 0)
  4446    I CRT,IBP GC>0,'$D(Z TQUEUED) D
  4447   "RTN","IBC NERPD",37, 0)
  4448    . I MAXCN T<51 F LIN =1:1:(MAXC NT-$Y) W !
  4449   "RTN","IBC NERPD",38, 0)
  4450    . S DIR(0 )="E" D ^D IR K DIR
  4451   "RTN","IBC NERPD",39, 0)
  4452   EXIT3 ; Ex it pt
  4453   "RTN","IBC NERPD",40, 0)
  4454    Q
  4455   "RTN","IBC NERPD",41, 0)
  4456    ;
  4457   "RTN","IBC NERPD",42, 0)
  4458   PRINT(RTN, REP,DET,TY P,SRT,PGC, PXT,MAX,CR T,IBOUT) ;  Print dat a
  4459   "RTN","IBC NERPD",43, 0)
  4460    ; Input:  RTN="IBCEN RPB", PGC= page ct,
  4461   "RTN","IBC NERPD",44, 0)
  4462    ;   PXT=e xit flg, M AX=max lin e ct/pg,
  4463   "RTN","IBC NERPD",45, 0)
  4464    ;  CRT=1/ 0, IBOUT=" R"/"E"
  4465   "RTN","IBC NERPD",46, 0)
  4466    N EORMSG, NONEMSG,SO RT1,SORT2, CNT,DASH
  4467   "RTN","IBC NERPD",47, 0)
  4468    S EORMSG= "*** END O F REPORT * **"
  4469   "RTN","IBC NERPD",48, 0)
  4470    S NONEMSG ="* * * N  O  D A T A   F O U N  D * * *"
  4471   "RTN","IBC NERPD",49, 0)
  4472    S (SORT1, SORT2)="", $P(DASH,"- ",133)=""
  4473   "RTN","IBC NERPD",50, 0)
  4474    ;
  4475   "RTN","IBC NERPD",51, 0)
  4476    ;Excel he ader
  4477   "RTN","IBC NERPD",52, 0)
  4478    I IBOUT=" E" D PHDL
  4479   "RTN","IBC NERPD",53, 0)
  4480    ;
  4481   "RTN","IBC NERPD",54, 0)
  4482    I '$D(^TM P($J,RTN))  D HEADER: (IBOUT="R" ) W !,?(80 -$L(NONEMS G)\2),NONE MSG,!!
  4483   "RTN","IBC NERPD",55, 0)
  4484    F  S SORT 1=$O(^TMP( $J,RTN,SOR T1)) Q:SOR T1=""  D   Q:PXT!$G(Z TSTOP)
  4485   "RTN","IBC NERPD",56, 0)
  4486    . S SORT2 ="" F  S S ORT2=$O(^T MP($J,RTN, SORT1,SORT 2)) Q:SORT 2=""  D  Q :PXT!$G(ZT STOP)
  4487   "RTN","IBC NERPD",57, 0)
  4488    . . S CNT ="" F  S C NT=$O(^TMP ($J,RTN,SO RT1,SORT2, CNT)) Q:CN T=""  D  Q :PXT!$G(ZT STOP)
  4489   "RTN","IBC NERPD",58, 0)
  4490    . . . K D ISPDATA  ;  Init disp
  4491   "RTN","IBC NERPD",59, 0)
  4492    . . . D D ATA(.DISPD ATA),LINE( .DISPDATA)   ; build/ display da ta
  4493   "RTN","IBC NERPD",60, 0)
  4494    ;
  4495   "RTN","IBC NERPD",61, 0)
  4496    I $G(ZTST OP)!PXT G  PRINTX
  4497   "RTN","IBC NERPD",62, 0)
  4498    I IBOUT=" R" D
  4499   "RTN","IBC NERPD",63, 0)
  4500    . I $Y+1> MAX!('PGC)  D HEADER  I $G(ZTSTO P)!PXT G P RINTX
  4501   "RTN","IBC NERPD",64, 0)
  4502    W !,?(80- $L(EORMSG) \2),EORMSG
  4503   "RTN","IBC NERPD",65, 0)
  4504   PRINTX ;
  4505   "RTN","IBC NERPD",66, 0)
  4506    Q
  4507   "RTN","IBC NERPD",67, 0)
  4508    ;
  4509   "RTN","IBC NERPD",68, 0)
  4510   HEADER ; P rint hdr i nfo
  4511   "RTN","IBC NERPD",69, 0)
  4512    N X,Y,DIR ,DTOUT,DUO UT,OFFSET, HDR,LIN,HD R
  4513   "RTN","IBC NERPD",70, 0)
  4514    I CRT,PGC >0,'$D(ZTQ UEUED) D   I PXT G HE ADERX
  4515   "RTN","IBC NERPD",71, 0)
  4516    . I MAX<5 1 F LIN=1: 1:(MAX-$Y)  W !
  4517   "RTN","IBC NERPD",72, 0)
  4518    . S DIR(0 )="E" D ^D IR K DIR
  4519   "RTN","IBC NERPD",73, 0)
  4520    . I $D(DT OUT)!($D(D UOUT)) S P XT=1 Q
  4521   "RTN","IBC NERPD",74, 0)
  4522    I $D(ZTQU EUED),$$S^ %ZTLOAD()  S ZTSTOP=1  G HEADERX
  4523   "RTN","IBC NERPD",75, 0)
  4524    S PGC=PGC +1
  4525   "RTN","IBC NERPD",76, 0)
  4526    W @IOF,!, ?1,"eIV Pa yer Link R eport"
  4527   "RTN","IBC NERPD",77, 0)
  4528    S HDR=$$F MTE^XLFDT( $$NOW^XLFD T,1)_"  Pa ge: "_PGC, OFFSET=131 -$L(HDR)
  4529   "RTN","IBC NERPD",78, 0)
  4530    W ?OFFSET ,HDR
  4531   "RTN","IBC NERPD",79, 0)
  4532    W !,?1,"R eport Opti on: "_$S(R EP=1:"Paye r List",1: "Insurance  Company L ist")
  4533   "RTN","IBC NERPD",80, 0)
  4534    I REP=1 D
  4535   "RTN","IBC NERPD",81, 0)
  4536    . S HDR=$ S(TYP=1:"U nlinked Pa yers Only" ,TYP=2:"Li nked Payer s Only",1: "All Payer s")
  4537   "RTN","IBC NERPD",82, 0)
  4538    . I TYP=3  S HDR=HDR _", "_$S(D ET=1:"With  Ins. Co.  Detail",1: "Without I ns. Co. De tail")
  4539   "RTN","IBC NERPD",83, 0)
  4540    I REP=2 D
  4541   "RTN","IBC NERPD",84, 0)
  4542    . S HDR=$ S(TYP=1:"U nlinked In surance Co mpanies On ly",TYP=2: "Linked In surance Co mpanies On ly",1:"All  Insurance  Companies ")
  4543   "RTN","IBC NERPD",85, 0)
  4544    S OFFSET= 79-$L(HDR)
  4545   "RTN","IBC NERPD",86, 0)
  4546    W ?OFFSET ,HDR
  4547   "RTN","IBC NERPD",87, 0)
  4548    ; IB*2.0* 521 add va lidated HP ID to repo rt
  4549   "RTN","IBC NERPD",88, 0)
  4550    I REP=2 W  !,"'*' in dicates th e Insuranc e Company  HPID/OEID  failed val idation ch ecks"
  4551   "RTN","IBC NERPD",89, 0)
  4552    I REP=1,D ET=1 W !," '*' indica tes the Li nked Insur ance Compa ny HPID/OE ID failed  validation  checks"
  4553   "RTN","IBC NERPD",90, 0)
  4554    W !
  4555   "RTN","IBC NERPD",91, 0)
  4556    I REP=1 D
  4557   "RTN","IBC NERPD",92, 0)
  4558    . I IBPPY R'="" W ?1 ,"For Sing le Payer:  ",$P(IBPPY R,"^",2)
  4559   "RTN","IBC NERPD",93, 0)
  4560    . ; IB*2. 0*528 add  Trusted fl ag to repo rt
  4561   "RTN","IBC NERPD",94, 0)
  4562    . ;W !?39 ,"National ",?54,"# L inked",?64 ,"National ly",?77,"L ocally",?8 7,"Prof.", ?104,"Inst ." W:DET=1  ?121,"HPI D/"
  4563   "RTN","IBC NERPD",95, 0)
  4564    . ;W !,"P ayer Name: ",?39,"Pay er ID",?54 ,"Ins. Co. ",?65,"Act ive?",?77, "Active?", ?87,"EDI#" ,?104,"EDI #" W:DET=1  ?121,"OEI D"
  4565   "RTN","IBC NERPD",96, 0)
  4566    . W !?31, "National" ,?46,"# Li nked",?56, "Nationall y",?69,"Lo cally",?78 ,"FSC",?87 ,"Prof.",? 104,"Inst. " W:DET=1  ?121,"HPID /"
  4567   "RTN","IBC NERPD",97, 0)
  4568    . W !,"Pa yer Name:" ,?31,"Paye r ID",?46, "Ins. Co." ,?57,"Acti ve?",?69," Active?",? 78,"Truste d?",?87,"E DI#",?104, "EDI#" W:D ET=1 ?121, "OEID"
  4569   "RTN","IBC NERPD",98, 0)
  4570    I REP=2 D
  4571   "RTN","IBC NERPD",99, 0)
  4572    . I IBMAT '="" W ?1, "Only Insu rance Comp anies that  match: ", IBMAT
  4573   "RTN","IBC NERPD",100 ,0)
  4574    . ; IB*2. 0*528 add  Trusted fl ag and Num ber of Act ive Groups  to report
  4575   "RTN","IBC NERPD",101 ,0)
  4576    . ;W !?56 ,"Nat.",?7 1,"Loc.",? 83,"Prof." ,?104,"Ins t.",?121," HPID/"
  4577   "RTN","IBC NERPD",102 ,0)
  4578    . ;W !,"I nsurance C ompany:",? 56,"Act?", ?71,"Act?" ,?83,"EDI# ",?104,"ED I#",?121," OEID"
  4579   "RTN","IBC NERPD",103 ,0)
  4580    . W !?32, "# Active" ,?56,"Nat. ",?66,"Loc .",?73,"FS C",?83,"Pr of.",?104, "Inst.",?1 21,"HPID/"
  4581   "RTN","IBC NERPD",104 ,0)
  4582    . W !,"In surance Co mpany:",?3 3,"Groups" ,?56,"Act? ",?66,"Act ?",?73,"Tr usted?",?8 3,"EDI#",? 104,"EDI#" ,?121,"OEI D"
  4583   "RTN","IBC NERPD",105 ,0)
  4584    . I TYP'= 1 W !,"    Payer:",?4 4,"VA ID"
  4585   "RTN","IBC NERPD",106 ,0)
  4586    W !,DASH
  4587   "RTN","IBC NERPD",107 ,0)
  4588   HEADERX ;
  4589   "RTN","IBC NERPD",108 ,0)
  4590    Q
  4591   "RTN","IBC NERPD",109 ,0)
  4592    ;
  4593   "RTN","IBC NERPD",110 ,0)
  4594   LINE(DISPD ATA) ;  Pr int data
  4595   "RTN","IBC NERPD",111 ,0)
  4596    N LNCT,LN TOT,NWPG
  4597   "RTN","IBC NERPD",112 ,0)
  4598    S LNTOT=+ $O(DISPDAT A(""),-1)
  4599   "RTN","IBC NERPD",113 ,0)
  4600    S NWPG=0
  4601   "RTN","IBC NERPD",114 ,0)
  4602    F LNCT=1: 1:LNTOT D   Q:$G(ZTST OP)!PXT
  4603   "RTN","IBC NERPD",115 ,0)
  4604    . I IBOUT ="R" D
  4605   "RTN","IBC NERPD",116 ,0)
  4606    . . I $Y+ 1>MAX!('PG C) D HEADE R S NWPG=1  I $G(ZTST OP)!PXT Q
  4607   "RTN","IBC NERPD",117 ,0)
  4608    . W ! W:I BOUT="R" ? 1 W DISPDA TA(LNCT) Q
  4609   "RTN","IBC NERPD",118 ,0)
  4610    . I 'NWPG !(NWPG&(DI SPDATA(LNC T)'="")) W  !,?1,DISP DATA(LNCT)
  4611   "RTN","IBC NERPD",119 ,0)
  4612    . I NWPG  S NWPG=0
  4613   "RTN","IBC NERPD",120 ,0)
  4614    . Q
  4615   "RTN","IBC NERPD",121 ,0)
  4616   LINEX Q
  4617   "RTN","IBC NERPD",122 ,0)
  4618    ;
  4619   "RTN","IBC NERPD",123 ,0)
  4620   DATA(DISPD ATA) ;  Bu ild disp l ines
  4621   "RTN","IBC NERPD",124 ,0)
  4622    N LCT,CT, CT2,RPTDAT A,WW,XX,YY ,ZZ,IBHPD
  4623   "RTN","IBC NERPD",125 ,0)
  4624    ; Merge i nto local  array
  4625   "RTN","IBC NERPD",126 ,0)
  4626    M RPTDATA =^TMP($J,R TN,SORT1,S ORT2,CNT)
  4627   "RTN","IBC NERPD",127 ,0)
  4628    ; Build
  4629   "RTN","IBC NERPD",128 ,0)
  4630    ;
  4631   "RTN","IBC NERPD",129 ,0)
  4632    ; PAYER R EPORT
  4633   "RTN","IBC NERPD",130 ,0)
  4634    I REP=1 D
  4635   "RTN","IBC NERPD",131 ,0)
  4636    . ; Excel  format
  4637   "RTN","IBC NERPD",132 ,0)
  4638    . I IBOUT ="E" D  Q
  4639   "RTN","IBC NERPD",133 ,0)
  4640    . . ; IB* 2*595/DM f or Excel,  properly d isplay the  locally a ctive stat us  
  4641   "RTN","IBC NERPD",134 ,0)
  4642    . . S LCT =0,DISPDAT A(1)=SORT2 _U_$P(RPTD ATA,U)_U_$ P(RPTDATA, U,6)_U_$S( $P(RPTDATA ,U,4)=1:"Y ES",1:"NO" )_U_$S($P( RPTDATA,U, 5)=1:"YES" ,1:"NO")_U _$P(RPTDAT A,U,7)_U_$ P(RPTDATA, U,2)_U_$P( RPTDATA,U, 3)
  4643   "RTN","IBC NERPD",135 ,0)
  4644    . . I DET =1 S WW=DI SPDATA(1)  D DET
  4645   "RTN","IBC NERPD",136 ,0)
  4646    . ;
  4647   "RTN","IBC NERPD",137 ,0)
  4648    . ; 1st l ine is pay er
  4649   "RTN","IBC NERPD",138 ,0)
  4650    . ; IB*2. 0*528 add  Trusted fl ag to repo rt
  4651   "RTN","IBC NERPD",139 ,0)
  4652    . ;S LCT= 1,DISPDATA (1)=$$FO^I BCNEUT1(SO RT2,35,"L" )_"   "_$$ FO^IBCNEUT 1($P(RPTDA TA,U,1),10 ,"L")_"      "_$$FO^I BCNEUT1($P (RPTDATA,U ,6),5,"R") _"         "_$$FO^IBC NEUT1($S($ P(RPTDATA, U,4)=1:"YE S",1:"NO") ,12,"L")
  4653   "RTN","IBC NERPD",140 ,0)
  4654    . ;S DISP DATA(1)=DI SPDATA(1)_ $$FO^IBCNE UT1($S($P( RPTDATA,U, 5)=1:"YES" ,1:"NO"),8 ,"L")_$$FO ^IBCNEUT1( $P(RPTDATA ,U,2),16," L")_" "_$$ FO^IBCNEUT 1($P(RPTDA TA,U,3),16 ,"L")
  4655   "RTN","IBC NERPD",141 ,0)
  4656    . S LCT=1 ,DISPDATA( 1)=$$FO^IB CNEUT1(SOR T2,27,"L") _"   "_$$F O^IBCNEUT1 ($P(RPTDAT A,U,1),10, "L")_"      "_$$FO^IB CNEUT1($P( RPTDATA,U, 6),5,"R")_ "        " _$$FO^IBCN EUT1($S($P (RPTDATA,U ,4)=1:"YES ",1:"NO"), 12,"L")
  4657   "RTN","IBC NERPD",142 ,0)
  4658    . S DISPD ATA(1)=DIS PDATA(1)_$ $FO^IBCNEU T1($S($P(R PTDATA,U,5 )=1:"YES", 1:"NO"),9, "L")_$$FO^ IBCNEUT1($ P(RPTDATA, U,7),7,"L" )_$$FO^IBC NEUT1($P(R PTDATA,U,2 ),16,"L")_ " "_$$FO^I BCNEUT1($P (RPTDATA,U ,3),16,"L" )
  4659   "RTN","IBC NERPD",143 ,0)
  4660    . ; See i f detail i s required
  4661   "RTN","IBC NERPD",144 ,0)
  4662    . I DET=1  D
  4663   "RTN","IBC NERPD",145 ,0)
  4664    . . I $O( RPTDATA("" ))'="" S L CT=LCT+1,D ISPDATA(LC T)="   Lin ked Insura nce Compan ies:"
  4665   "RTN","IBC NERPD",146 ,0)
  4666    . . S (XX ,YY,ZZ)=""  F  S XX=$ O(RPTDATA( XX)) Q:XX= ""  F  S Y Y=$O(RPTDA TA(XX,YY))  Q:YY=""   D
  4667   "RTN","IBC NERPD",147 ,0)
  4668    . . . S Z Z=RPTDATA( XX,YY)
  4669   "RTN","IBC NERPD",148 ,0)
  4670    . . . S L CT=LCT+1,D ISPDATA(LC T)="   "_$ $FO^IBCNEU T1(XX,35," L")_"  "_$ $FO^IBCNEU T1($P(ZZ,U ,1),20,"L" )_" "_$E($ P(ZZ,U,4), 1,15)
  4671   "RTN","IBC NERPD",149 ,0)
  4672    . . . ; d on't displ ay ','s if  no addres s/state on  file
  4673   "RTN","IBC NERPD",150 ,0)
  4674    . . . I $ P(ZZ,U,5)' ="" S DISP DATA(LCT)= DISPDATA(L CT)_", "_$ P($G(^DIC( 5,$P(ZZ,U, 5)+0,0)),U ,2)
  4675   "RTN","IBC NERPD",151 ,0)
  4676    . . . ; I B*2.0*521  add valida ted HPID t o report
  4677   "RTN","IBC NERPD",152 ,0)
  4678    . . . S I BHPD=$$HPD ^IBCNHUT1( YY,1)
  4679   "RTN","IBC NERPD",153 ,0)
  4680    . . . ;S  DISPDATA(L CT)=DISPDA TA(LCT)_$$ FO^IBCNEUT 1(" ",93-$ L(DISPDATA (LCT)),"L" )
  4681   "RTN","IBC NERPD",154 ,0)
  4682    . . . S D ISPDATA(LC T)=DISPDAT A(LCT)_$$F O^IBCNEUT1 (" ",86-$L (DISPDATA( LCT)),"L")
  4683   "RTN","IBC NERPD",155 ,0)
  4684    . . . ; d isplay EDI #'s
  4685   "RTN","IBC NERPD",156 ,0)
  4686    . . . ;S  DISPDATA(L CT)=DISPDA TA(LCT)_$$ FO^IBCNEUT 1($P(ZZ,U, 7),16,"L") _"     "_$ $FO^IBCNEU T1($P(ZZ,U ,8),16,"L" )
  4687   "RTN","IBC NERPD",157 ,0)
  4688    . . . S D ISPDATA(LC T)=DISPDAT A(LCT)_$$F O^IBCNEUT1 ($P(ZZ,U,7 ),16,"L")_ " "_$$FO^I BCNEUT1($P (ZZ,U,8),1 6,"L")_" " _IBHPD
  4689   "RTN","IBC NERPD",158 ,0)
  4690    ;
  4691   "RTN","IBC NERPD",159 ,0)
  4692    ; Insuran ce Company  Report
  4693   "RTN","IBC NERPD",160 ,0)
  4694    I REP=2 D
  4695   "RTN","IBC NERPD",161 ,0)
  4696    . ; Excel  format
  4697   "RTN","IBC NERPD",162 ,0)
  4698    . I IBOUT ="E" D  Q
  4699   "RTN","IBC NERPD",163 ,0)
  4700    . . ;S LC T=1,DISPDA TA(1)=SORT 2_U_$P(RPT DATA,U,1)_ U_$P(RPTDA TA,U,6)_U_ $S($P(RPTD ATA,U,4)=1 :"YES",1:" NO")_U_$S( $P(RPTDATA ,U,4)=1:"Y ES",1:"NO" )_U_$P(RPT DATA,U,7)_ U_$P(RPTDA TA,U,2)_U_ $P(RPTDATA ,U,3)
  4701   "RTN","IBC NERPD",164 ,0)
  4702    . . S LCT =1,DISPDAT A(1)=SORT2 _U_$P(RPTD ATA,U,10)_ U_$P(RPTDA TA,U,13)
  4703   "RTN","IBC NERPD",165 ,0)
  4704    . . I $P( RPTDATA,U, 14)'="" S  DISPDATA(1 )=DISPDATA (1)_", "_$ P($G(^DIC( 5,$P(RPTDA TA,U,14)+0 ,0)),U,2)_ " "_$P(RPT DATA,U,15)
  4705   "RTN","IBC NERPD",166 ,0)
  4706    . . S IBH PD=$$HPD^I BCNHUT1(CN T,1),ZZ=$P (RPTDATA," ~",2)
  4707   "RTN","IBC NERPD",167 ,0)
  4708    . . S DIS PDATA(1)=D ISPDATA(1) _U_$P(RPTD ATA,U,8)_U _$P(ZZ,U,2 )_U_$P(ZZ, U,4)_U_IBH PD_U
  4709   "RTN","IBC NERPD",168 ,0)
  4710    . . I $P( RPTDATA,U) ="" S:TYP' =1 DISPDAT A(1)=DISPD ATA(1)_"**  NOT CURRE NTLY LINKE D **" Q
  4711   "RTN","IBC NERPD",169 ,0)
  4712    . . S DIS PDATA(1)=D ISPDATA(1) _$P(RPTDAT A,U,1,2)_U _$S($P(RPT DATA,U,5)= 1:"YES",1: "NO")_U_$S ($P(RPTDAT A,U,6)=1:" YES",1:"NO ")_U_$P(RP TDATA,U,9) _U_$P(RPTD ATA,U,3,4)
  4713   "RTN","IBC NERPD",170 ,0)
  4714    . ;
  4715   "RTN","IBC NERPD",171 ,0)
  4716    . ; Ins c arrier
  4717   "RTN","IBC NERPD",172 ,0)
  4718    . ; IB*2. 0*528 add  number of  active gro ups to rep ort
  4719   "RTN","IBC NERPD",173 ,0)
  4720    . S DISPD ATA(1)=$$F O^IBCNEUT1 (SORT2,30, "L")_"  "_ $$FO^IBCNE UT1($P(RPT DATA,U,8), 5,"R")_$$F O^IBCNEUT1 (" ",45,"L ")
  4721   "RTN","IBC NERPD",174 ,0)
  4722    . ; Ins a ddress
  4723   "RTN","IBC NERPD",175 ,0)
  4724    . S IBHPD =$$HPD^IBC NHUT1(CNT, 1)
  4725   "RTN","IBC NERPD",176 ,0)
  4726    . S ZZ=$P (RPTDATA," ~",2),DISP DATA(1)=DI SPDATA(1)_ $$FO^IBCNE UT1($P(ZZ, U,2),16,"L ")_"     " _$$FO^IBCN EUT1($P(ZZ ,U,4),16," L")_" "_IB HPD
  4727   "RTN","IBC NERPD",177 ,0)
  4728    . S DISPD ATA(2)="         "_$P (RPTDATA,U ,10)_"  "_ $P(RPTDATA ,U,13)
  4729   "RTN","IBC NERPD",178 ,0)
  4730    . ; Add s tate/zip i f defined
  4731   "RTN","IBC NERPD",179 ,0)
  4732    . I $P(RP TDATA,U,14 )'="" S DI SPDATA(2)= DISPDATA(2 )_", "_$P( $G(^DIC(5, $P(RPTDATA ,U,14)+0,0 )),U,2)_"  "_$$FO^IBC NEUT1($P(R PTDATA,U,1 5),5,"L")
  4733   "RTN","IBC NERPD",180 ,0)
  4734    . ; if no  payer is  linked AND  displayin g payers
  4735   "RTN","IBC NERPD",181 ,0)
  4736    . I $P(RP TDATA,U)=" ",TYP'=1 S  DISPDATA( 3)="   **  NOT CURREN TLY LINKED  **",LCT=4 ,DISPDATA( 4)="  " Q
  4737   "RTN","IBC NERPD",182 ,0)
  4738    . ; if no  payer and  not displ aying then  quit
  4739   "RTN","IBC NERPD",183 ,0)
  4740    . I $P(RP TDATA,U)=" " S LCT=3, DISPDATA(3 )="  " Q
  4741   "RTN","IBC NERPD",184 ,0)
  4742    . ; Displ ay Payer I nfo Line
  4743   "RTN","IBC NERPD",185 ,0)
  4744    . S DISPD ATA(3)="   "_$$FO^IBC NEUT1($P(R PTDATA,U,1 ),35,"L")_ "      "_$ $FO^IBCNEU T1($P(RPTD ATA,U,2),1 2,"L")_$$F O^IBCNEUT1 ($S($P(RPT DATA,U,5)= 1:"YES",1: "NO"),10," L")
  4745   "RTN","IBC NERPD",186 ,0)
  4746    . ; IB*2. 0*528 add  Trusted fl ag to repo rt
  4747   "RTN","IBC NERPD",187 ,0)
  4748    . ;S DISP DATA(3)=DI SPDATA(3)_ $$FO^IBCNE UT1($S($P( RPTDATA,U, 6)=1:"YES" ,1:"NO"),1 2,"L")_$$F O^IBCNEUT1 ($P(RPTDAT A,U,4),16, "L")_"      "_$$FO^IB CNEUT1($P( RPTDATA,U, 4),16,"L")
  4749   "RTN","IBC NERPD",188 ,0)
  4750    . S DISPD ATA(3)=DIS PDATA(3)_$ $FO^IBCNEU T1($S($P(R PTDATA,U,6 )=1:"YES", 1:"NO"),7, "L")_$$FO^ IBCNEUT1($ P(RPTDATA, U,9),10,"L ")_$$FO^IB CNEUT1($P( RPTDATA,U, 3),16,"L") _"     "_$ $FO^IBCNEU T1($P(RPTD ATA,U,4),1 6,"L")
  4751   "RTN","IBC NERPD",189 ,0)
  4752    . S LCT=4 ,DISPDATA( 4)=" "
  4753   "RTN","IBC NERPD",190 ,0)
  4754    S LCT=LCT +1
  4755   "RTN","IBC NERPD",191 ,0)
  4756    Q
  4757   "RTN","IBC NERPD",192 ,0)
  4758    ;
  4759   "RTN","IBC NERPD",193 ,0)
  4760   DET ; - Pr int insura nce compan y detail i n Excel Pa yer report
  4761   "RTN","IBC NERPD",194 ,0)
  4762    S (XX,YY, ZZ)="" F   S XX=$O(RP TDATA(XX))  Q:XX=""   F  S YY=$O (RPTDATA(X X,YY)) Q:Y Y=""  D
  4763   "RTN","IBC NERPD",195 ,0)
  4764    . S ZZ=RP TDATA(XX,Y Y)
  4765   "RTN","IBC NERPD",196 ,0)
  4766    . S LCT=L CT+1,DISPD ATA(LCT)=W W_U_XX_U_$ P(ZZ,U,1)_ U_$P(ZZ,U, 4)
  4767   "RTN","IBC NERPD",197 ,0)
  4768    . I $P(ZZ ,U,5)'=""  S DISPDATA (LCT)=DISP DATA(LCT)_ ", "_$P($G (^DIC(5,$P (ZZ,U,5)+0 ,0)),U,2)
  4769   "RTN","IBC NERPD",198 ,0)
  4770    . S IBHPD =$$HPD^IBC NHUT1(YY,1 )
  4771   "RTN","IBC NERPD",199 ,0)
  4772    . S DISPD ATA(LCT)=D ISPDATA(LC T)_U_$P(ZZ ,U,7)_U_$P (ZZ,U,8)_U _IBHPD
  4773   "RTN","IBC NERPD",200 ,0)
  4774    Q
  4775   "RTN","IBC NERPD",201 ,0)
  4776    ;
  4777   "RTN","IBC NERPD",202 ,0)
  4778   PHDL ; - P rint the h eader line  for the E xcel sprea dsheet
  4779   "RTN","IBC NERPD",203 ,0)
  4780    N X
  4781   "RTN","IBC NERPD",204 ,0)
  4782    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets
  4783   "RTN","IBC NERPD",205 ,0)
  4784    S X="eIV  Payer Link  Report^"_ $$FMTE^XLF DT($$NOW^X LFDT,1)
  4785   "RTN","IBC NERPD",206 ,0)
  4786    W X
  4787   "RTN","IBC NERPD",207 ,0)
  4788    S X="Repo rt Option:  "_$S(REP= 1:"Payer L ist",1:"In surance Co mpany List ")
  4789   "RTN","IBC NERPD",208 ,0)
  4790    W !,X
  4791   "RTN","IBC NERPD",209 ,0)
  4792    I REP=1 D
  4793   "RTN","IBC NERPD",210 ,0)
  4794    . S HDR=$ S(TYP=1:"U nlinked Pa yers Only" ,TYP=2:"Li nked Payer s Only",1: "All Payer s")
  4795   "RTN","IBC NERPD",211 ,0)
  4796    . I TYP=3  S HDR=HDR _"^"_$S(DE T=1:"With  Ins. Co. D etail",1:" Without In s. Co. Det ail")
  4797   "RTN","IBC NERPD",212 ,0)
  4798    I REP=2 D
  4799   "RTN","IBC NERPD",213 ,0)
  4800    . S HDR=$ S(TYP=1:"U nlinked In surance Co mpanies On ly",TYP=2: "Linked In surance Co mpanies On ly",1:"All  Insurance  Companies ")
  4801   "RTN","IBC NERPD",214 ,0)
  4802    W "^"_HDR
  4803   "RTN","IBC NERPD",215 ,0)
  4804    I REP=2 W  !,"'*' in dicates th e Insuranc e Company  HPID/OEID  failed val idation ch ecks"
  4805   "RTN","IBC NERPD",216 ,0)
  4806    I REP=1,D ET=1 W !," '*' indica tes the Li nked Insur ance Compa ny HPID/OE ID failed  validation  checks"
  4807   "RTN","IBC NERPD",217 ,0)
  4808    I REP=1,I BPPYR'=""  W !,"For S ingle Paye r:"_"^"_$P (IBPPYR,"^ ",2)
  4809   "RTN","IBC NERPD",218 ,0)
  4810    I REP=2,I BMAT'="" W  !,"Only I nsurance C ompanies t hat match: "_"^"_IBMA T
  4811   "RTN","IBC NERPD",219 ,0)
  4812    ; IB*602/ HN end
  4813   "RTN","IBC NERPD",220 ,0)
  4814    I REP=1 D
  4815   "RTN","IBC NERPD",221 ,0)
  4816    .S X="Pay er Name^Na tional Pay er ID^# Li nked Ins.  Co.^Nation ally Activ e?^Locally  Active?^F SC Trusted ?^Professi onal EDI#^ Institutio nal EDI#"
  4817   "RTN","IBC NERPD",222 ,0)
  4818    .I DET=1  S X=X_"^Li nked Insur ance Compa ny Name^St reet Addre ss^City, S T^Professi onal EDI#^ Institutio nal EDI#^H PID/OEID"
  4819   "RTN","IBC NERPD",223 ,0)
  4820    I REP=2 D
  4821   "RTN","IBC NERPD",224 ,0)
  4822    .S X="Ins urance Com pany Name^ Street Add ress^City,  ST Zip^#  Active Gro ups^Profes sional EDI #^Institut ional EDI# ^HPID/OEID ^"
  4823   "RTN","IBC NERPD",225 ,0)
  4824    .S X=X_"L inked Paye r^VA ID^Na tionally A ctive?^Loc ally Activ e?^FSC Tru sted?^Prof essional E DI#^Instit utional ED I#"
  4825   "RTN","IBC NERPD",226 ,0)
  4826    W !,X
  4827   "RTN","IBC NERPD",227 ,0)
  4828    Q
  4829   "RTN","IBC NEUT5")
  4830   0^18^B6544 4390^B6325 2821
  4831   "RTN","IBC NEUT5",1,0 )
  4832   IBCNEUT5 ; DAOU/ALA -  eIV MISC.  UTILITIES  ;20-JUN-2 002
  4833   "RTN","IBC NEUT5",2,0 )
  4834    ;;2.0;INT EGRATED BI LLING;**18 4,284,271, 416,621,60 2**;21-MAR -94;Build  22
  4835   "RTN","IBC NEUT5",3,0 )
  4836    ;;Per VHA  Directive  6402, thi s routine  should not  be modifi ed.
  4837   "RTN","IBC NEUT5",4,0 )
  4838    ;
  4839   "RTN","IBC NEUT5",5,0 )
  4840    ;**Progra m Descript ion**
  4841   "RTN","IBC NEUT5",6,0 )
  4842    ;  This p rogram con tains some  general u tilities o r function s
  4843   "RTN","IBC NEUT5",7,0 )
  4844    ;
  4845   "RTN","IBC NEUT5",8,0 )
  4846    Q
  4847   "RTN","IBC NEUT5",9,0 )
  4848    ;
  4849   "RTN","IBC NEUT5",10, 0)
  4850   MSG(MGRP,X MSUB,XMTEX T,FROMFLAG ,XMY) ;  S end a Mail Man Messag e
  4851   "RTN","IBC NEUT5",11, 0)
  4852    ;
  4853   "RTN","IBC NEUT5",12, 0)
  4854    ;  Input  Parameters
  4855   "RTN","IBC NEUT5",13, 0)
  4856    ;   MGRP  = Mailgrou p Name (op tional)
  4857   "RTN","IBC NEUT5",14, 0)
  4858    ;   XMSUB  = Subject  Line (req uired)
  4859   "RTN","IBC NEUT5",15, 0)
  4860    ;   XMTEX T = Messag e Text Arr ay Name in  open form at:  "MSG( " (require d)
  4861   "RTN","IBC NEUT5",16, 0)
  4862    ;   FROMF LAG = Flag  indicatin g from who m the mess age is sen t (optiona l)
  4863   "RTN","IBC NEUT5",17, 0)
  4864    ;          false/und efined:  f rom the sp ecific, no n-human eI V user
  4865   "RTN","IBC NEUT5",18, 0)
  4866    ;                      true:  f rom the ac tual user  (DUZ)
  4867   "RTN","IBC NEUT5",19, 0)
  4868    ;   XMY =  recipient s array; p ass by ref erence (op tional)
  4869   "RTN","IBC NEUT5",20, 0)
  4870    ;          The possi ble recipi ents are t he sender,  the Mail  Group in t he
  4871   "RTN","IBC NEUT5",21, 0)
  4872    ;          first par ameter, an d anybody  else alrea dy defined  in the XM
  4873   "RTN","IBC NEUT5",22, 0)
  4874    ;          array whe n this par ameter is  used.
  4875   "RTN","IBC NEUT5",23, 0)
  4876    ;
  4877   "RTN","IBC NEUT5",24, 0)
  4878    ; New Mai lMan varia bles and a lso some F ileMan var iables.  T he FileMan
  4879   "RTN","IBC NEUT5",25, 0)
  4880    ; variabl es are use d and not  cleaned up  when send ing to ext ernal
  4881   "RTN","IBC NEUT5",26, 0)
  4882    ; interne t addresse s.
  4883   "RTN","IBC NEUT5",27, 0)
  4884    NEW DIFRO M,XMDUZ,XM DUN,XMZ,XM MG,XMSTRIP ,XMROU,XMY BLOB
  4885   "RTN","IBC NEUT5",28, 0)
  4886    NEW D0,D1 ,D2,DG,DIC ,DICR,DISY S,DIW
  4887   "RTN","IBC NEUT5",29, 0)
  4888    NEW TMPSU B,TMPTEXT, TMPY,XX
  4889   "RTN","IBC NEUT5",30, 0)
  4890    ;
  4891   "RTN","IBC NEUT5",31, 0)
  4892    I $G(FROM FLAG),$G(D UZ) S XMDU Z=DUZ
  4893   "RTN","IBC NEUT5",32, 0)
  4894    E  S XMDU Z="eIV INT ERFACE (IB )"
  4895   "RTN","IBC NEUT5",33, 0)
  4896    I $G(MGRP )'="" S XM Y("G."_MGR P)=""
  4897   "RTN","IBC NEUT5",34, 0)
  4898    ; If no r ecipients  are define d, send to  postmaste r
  4899   "RTN","IBC NEUT5",35, 0)
  4900    I '$D(XMY ) S XMY(.5 )=""
  4901   "RTN","IBC NEUT5",36, 0)
  4902    I $G(DUZ)  S XMY(DUZ )=""
  4903   "RTN","IBC NEUT5",37, 0)
  4904    ; Store o ff subject , array re ference an d array of  recipient s
  4905   "RTN","IBC NEUT5",38, 0)
  4906    S TMPSUB= XMSUB,TMPT EXT=XMTEXT
  4907   "RTN","IBC NEUT5",39, 0)
  4908    M TMPY=XM Y
  4909   "RTN","IBC NEUT5",40, 0)
  4910    D ^XMD
  4911   "RTN","IBC NEUT5",41, 0)
  4912    ;
  4913   "RTN","IBC NEUT5",42, 0)
  4914    ; Error l ogic
  4915   "RTN","IBC NEUT5",43, 0)
  4916    ; If ther e's an err or message  and the m essage was  not origi nally sent
  4917   "RTN","IBC NEUT5",44, 0)
  4918    ; to the  postmaster , then sen d a messag e to the p ostmaster  with this
  4919   "RTN","IBC NEUT5",45, 0)
  4920    ; error m essage.
  4921   "RTN","IBC NEUT5",46, 0)
  4922    ;
  4923   "RTN","IBC NEUT5",47, 0)
  4924    I $D(XMMG ),'$D(TMPY (.5)) D
  4925   "RTN","IBC NEUT5",48, 0)
  4926    . S XMY(. 5)=""
  4927   "RTN","IBC NEUT5",49, 0)
  4928    . S XMTEX T=TMPTEXT, XMSUB="Mai lMan Error "
  4929   "RTN","IBC NEUT5",50, 0)
  4930    . ; Add X MMG error  message as  the first  line of t he message
  4931   "RTN","IBC NEUT5",51, 0)
  4932    . S XX=99 9999
  4933   "RTN","IBC NEUT5",52, 0)
  4934    . F  S XX =$O(@(XMTE XT_"XX)"), -1) Q:'XX   S @(XMTEX T_"XX+3)") =@(XMTEXT_ "XX)")
  4935   "RTN","IBC NEUT5",53, 0)
  4936    . S @(XMT EXT_"1)")= "   MailMa n Error:   "_XMMG
  4937   "RTN","IBC NEUT5",54, 0)
  4938    . S @(XMT EXT_"2)")= "Original  Subject:   "_TMPSUB
  4939   "RTN","IBC NEUT5",55, 0)
  4940    . S @(XMT EXT_"3)")= "------Ori ginal Mess age------"
  4941   "RTN","IBC NEUT5",56, 0)
  4942    . D ^XMD
  4943   "RTN","IBC NEUT5",57, 0)
  4944    . Q
  4945   "RTN","IBC NEUT5",58, 0)
  4946    Q
  4947   "RTN","IBC NEUT5",59, 0)
  4948    ;
  4949   "RTN","IBC NEUT5",60, 0)
  4950    ;
  4951   "RTN","IBC NEUT5",61, 0)
  4952   BFEXIST(DF N,INSNAME)  ; Functio n returns  1 if an En tered Ins  Buffer Fil
  4953   "RTN","IBC NEUT5",62, 0)
  4954    ; entry e xists with  the same  DFN and IN SNAME, oth erwise it  returns a  0
  4955   "RTN","IBC NEUT5",63, 0)
  4956    ;
  4957   "RTN","IBC NEUT5",64, 0)
  4958    ; DFN - P atient DFN
  4959   "RTN","IBC NEUT5",65, 0)
  4960    ; INSNAME  - Insuran ce Company  Name File  36 - Fiel d .01
  4961   "RTN","IBC NEUT5",66, 0)
  4962    ;
  4963   "RTN","IBC NEUT5",67, 0)
  4964    NEW BUFFN AME,EXIST, IEN ; IB*2 .0*602
  4965   "RTN","IBC NEUT5",68, 0)
  4966    S EXIST=0
  4967   "RTN","IBC NEUT5",69, 0)
  4968    S INSNAME =$$UP^XLFS TR(INSNAME ),INSNAME= $$TRIM^XLF STR(INSNAM E)  ; trim med *IB*2. 0*602
  4969   "RTN","IBC NEUT5",70, 0)
  4970    I ('DFN)! (INSNAME=" ") G BFEXI T
  4971   "RTN","IBC NEUT5",71, 0)
  4972    ;
  4973   "RTN","IBC NEUT5",72, 0)
  4974    S IEN=0
  4975   "RTN","IBC NEUT5",73, 0)
  4976    F  S IEN= $O(^IBA(35 5.33,"C",D FN,IEN)) Q :'IEN!EXIS T  D
  4977   "RTN","IBC NEUT5",74, 0)
  4978    .  ; Quit  if status  is NOT 'E ntered'
  4979   "RTN","IBC NEUT5",75, 0)
  4980    .  I $P($ G(^IBA(355 .33,IEN,0) ),U,4)'="E " Q
  4981   "RTN","IBC NEUT5",76, 0)
  4982    .  ; Quit  if Ins Bu ffer Ins C o Name (tr immed) is  NOT EQUAL  to 
  4983   "RTN","IBC NEUT5",77, 0)
  4984    .  ;  the  Ins Co Na me paramet er (trimme d)
  4985   "RTN","IBC NEUT5",78, 0)
  4986    .  ; IB*2 .0*602 in  case the i nput templ ate for th at field c hanges in  the future  (TRIM & U P)
  4987   "RTN","IBC NEUT5",79, 0)
  4988    .  S BUFF NAME=$$TRI M^XLFSTR($ P($G(^IBA( 355.33,IEN ,20)),U))
  4989   "RTN","IBC NEUT5",80, 0)
  4990    .  I $$UP ^XLFSTR(BU FFNAME)'=I NSNAME Q
  4991   "RTN","IBC NEUT5",81, 0)
  4992    .  ; Matc h found
  4993   "RTN","IBC NEUT5",82, 0)
  4994    .  S EXIS T=1
  4995   "RTN","IBC NEUT5",83, 0)
  4996    .  Q
  4997   "RTN","IBC NEUT5",84, 0)
  4998   BFEXIT ;
  4999   "RTN","IBC NEUT5",85, 0)
  5000    Q EXIST
  5001   "RTN","IBC NEUT5",86, 0)
  5002    ;
  5003   "RTN","IBC NEUT5",87, 0)
  5004    ;
  5005   "RTN","IBC NEUT5",88, 0)
  5006   MGRP() ; G et the Mai l Group fo r the eIV  Interface  - IB Site  Parameters  (51.04)
  5007   "RTN","IBC NEUT5",89, 0)
  5008    Q $$GET1^ DIQ(350.9, "1,",51.04 ,"E")
  5009   "RTN","IBC NEUT5",90, 0)
  5010    ;
  5011   "RTN","IBC NEUT5",91, 0)
  5012    ;
  5013   "RTN","IBC NEUT5",92, 0)
  5014   PYRAPP(APP ,PAYERIEN)  ; Get the  Payer App lication m ultiple IE N
  5015   "RTN","IBC NEUT5",93, 0)
  5016    ; based o n the paye r applicat ion name a nd payer i en.
  5017   "RTN","IBC NEUT5",94, 0)
  5018    ;
  5019   "RTN","IBC NEUT5",95, 0)
  5020    NEW MIEN, APPIEN,DIS YS
  5021   "RTN","IBC NEUT5",96, 0)
  5022    S MIEN=""
  5023   "RTN","IBC NEUT5",97, 0)
  5024    S APPIEN= $$FIND1^DI C(365.13,, "X",APP,"B ")
  5025   "RTN","IBC NEUT5",98, 0)
  5026    I 'APPIEN  G PYRAPPX
  5027   "RTN","IBC NEUT5",99, 0)
  5028    I '$G(PAY ERIEN) G P YRAPPX
  5029   "RTN","IBC NEUT5",100 ,0)
  5030    S MIEN=$O (^IBE(365. 12,PAYERIE N,1,"B",AP PIEN,""))
  5031   "RTN","IBC NEUT5",101 ,0)
  5032   PYRAPPX ;
  5033   "RTN","IBC NEUT5",102 ,0)
  5034    Q MIEN
  5035   "RTN","IBC NEUT5",103 ,0)
  5036    ;
  5037   "RTN","IBC NEUT5",104 ,0)
  5038    ;
  5039   "RTN","IBC NEUT5",105 ,0)
  5040   ACTAPP(IEN ) ; Active  payer app lications
  5041   "RTN","IBC NEUT5",106 ,0)
  5042    ; This fu nction wil l return 1  if any of  the payer  applicati ons for 
  5043   "RTN","IBC NEUT5",107 ,0)
  5044    ; this pa yer (being  passed in  by the pa yer IEN) a re NOT dea ctivated.
  5045   "RTN","IBC NEUT5",108 ,0)
  5046    ; This sh ould not b e confused  with the  other paye r applicat ion fields
  5047   "RTN","IBC NEUT5",109 ,0)
  5048    ; such as  national  active or  local acti ve.  The d eactivated  field is
  5049   "RTN","IBC NEUT5",110 ,0)
  5050    ; the .11  field in  the payer  applicatio n multiple .
  5051   "RTN","IBC NEUT5",111 ,0)
  5052    ;
  5053   "RTN","IBC NEUT5",112 ,0)
  5054    ; This fu nction is  invoked by  the FileM an data di ctionary a s a screen
  5055   "RTN","IBC NEUT5",113 ,0)
  5056    ; for the  Payer fie ld (#3.1)  in the Ins urance com pany file  (#36).
  5057   "RTN","IBC NEUT5",114 ,0)
  5058    ;
  5059   "RTN","IBC NEUT5",115 ,0)
  5060    NEW APPIE N,ACTAPP,A PPDATA
  5061   "RTN","IBC NEUT5",116 ,0)
  5062    S APPIEN= 0,ACTAPP=" ",IEN=+$G( IEN)
  5063   "RTN","IBC NEUT5",117 ,0)
  5064    F  S APPI EN=$O(^IBE (365.12,IE N,1,APPIEN )) Q:'APPI EN  D  Q:A CTAPP
  5065   "RTN","IBC NEUT5",118 ,0)
  5066    . S APPDA TA=$G(^IBE (365.12,IE N,1,APPIEN ,0))
  5067   "RTN","IBC NEUT5",119 ,0)
  5068    . I $P(AP PDATA,U,11 ) Q
  5069   "RTN","IBC NEUT5",120 ,0)
  5070    . I $P(AP PDATA,U,12 ) Q
  5071   "RTN","IBC NEUT5",121 ,0)
  5072    . S ACTAP P=1
  5073   "RTN","IBC NEUT5",122 ,0)
  5074    . Q
  5075   "RTN","IBC NEUT5",123 ,0)
  5076    Q ACTAPP
  5077   "RTN","IBC NEUT5",124 ,0)
  5078    ;
  5079   "RTN","IBC NEUT5",125 ,0)
  5080   ADDTQ(DFN, PAYER,SRVD T,FDAYS,EI CDEXT) ; F unction  -  Returns f lag (0/1)
  5081   "RTN","IBC NEUT5",126 ,0)
  5082    ; 1 - TQ  File entry  can be ad ded as the  service d ate for th e patient 
  5083   "RTN","IBC NEUT5",127 ,0)
  5084    ;     and  payer >=  MAX TQ ser vice date  + Freshnes s Days
  5085   "RTN","IBC NEUT5",128 ,0)
  5086    ; 0 - oth erwise
  5087   "RTN","IBC NEUT5",129 ,0)
  5088    ;
  5089   "RTN","IBC NEUT5",130 ,0)
  5090    ; Input:
  5091   "RTN","IBC NEUT5",131 ,0)
  5092    ;  DFN    - Patient  DFN (File  #2)
  5093   "RTN","IBC NEUT5",132 ,0)
  5094    ;  PAYER  - Payer IE N (File #3 65.12)
  5095   "RTN","IBC NEUT5",133 ,0)
  5096    ;  SRVDT  - Service  dt for pot ential TQ  entry
  5097   "RTN","IBC NEUT5",134 ,0)
  5098    ;  FDAYS  - Freshnes s Days par am (by ext ract type)
  5099   "RTN","IBC NEUT5",135 ,0)
  5100    ;  EICDEX T - 1 OR 0  (Is this  from the E ICD extrac t?) ;IB*2. 0*621 - Re named para meter to E ICD extrac t
  5101   "RTN","IBC NEUT5",136 ,0)
  5102    ;
  5103   "RTN","IBC NEUT5",137 ,0)
  5104    N ADDTQ,M AXDT
  5105   "RTN","IBC NEUT5",138 ,0)
  5106    ; 
  5107   "RTN","IBC NEUT5",139 ,0)
  5108    S ADDTQ=1
  5109   "RTN","IBC NEUT5",140 ,0)
  5110    I ($G(DFN )="")!($G( SRVDT)="") !($G(FDAYS )="") S AD DTQ=0 G AD DTQX
  5111   "RTN","IBC NEUT5",141 ,0)
  5112    I ($G(EIC DEXT)="")! ($G(PAYER) ="") S ADD TQ=0 G ADD TQX
  5113   "RTN","IBC NEUT5",142 ,0)
  5114    ;
  5115   "RTN","IBC NEUT5",143 ,0)
  5116    ; MAX TQ  Service Da te
  5117   "RTN","IBC NEUT5",144 ,0)
  5118    S MAXDT=$ $TQMAXSV(D FN,$G(PAYE R),$G(EICD EXT))
  5119   "RTN","IBC NEUT5",145 ,0)
  5120    I MAXDT=" " G ADDTQX
  5121   "RTN","IBC NEUT5",146 ,0)
  5122    ; If Serv ice Date <  Max Servi ce Date +  Freshness  Days, do n ot add
  5123   "RTN","IBC NEUT5",147 ,0)
  5124    I SRVDT'> $$FMADD^XL FDT(MAXDT, FDAYS) S A DDTQ=0
  5125   "RTN","IBC NEUT5",148 ,0)
  5126    ;
  5127   "RTN","IBC NEUT5",149 ,0)
  5128   ADDTQX ; A DDTQ exit  pt
  5129   "RTN","IBC NEUT5",150 ,0)
  5130    Q ADDTQ
  5131   "RTN","IBC NEUT5",151 ,0)
  5132    ;
  5133   "RTN","IBC NEUT5",152 ,0)
  5134   TQUPDSV(DF N,PAYER,SR VDT) ; Upd ate servic e dates &  freshness  dates for  TQ
  5135   "RTN","IBC NEUT5",153 ,0)
  5136    ; entries  awaiting  transmissi on
  5137   "RTN","IBC NEUT5",154 ,0)
  5138    ;
  5139   "RTN","IBC NEUT5",155 ,0)
  5140    N SVDT,ST S,ERACT,CS RVDT,CSPAN ,SPAN,DA,H L7IEN,RIEN
  5141   "RTN","IBC NEUT5",156 ,0)
  5142    ;
  5143   "RTN","IBC NEUT5",157 ,0)
  5144    I ($G(DFN )="")!($G( PAYER)="") !($G(SRVDT )="") G TQ UPDSVX
  5145   "RTN","IBC NEUT5",158 ,0)
  5146    ;
  5147   "RTN","IBC NEUT5",159 ,0)
  5148    ; Loop th ru all inq uiries to  be transmi tted to up date the s ervice dat e
  5149   "RTN","IBC NEUT5",160 ,0)
  5150    ; Statuse s:  Ready  to Transmi t(1), Hold (4) and Re try(6)
  5151   "RTN","IBC NEUT5",161 ,0)
  5152    S SVDT=""
  5153   "RTN","IBC NEUT5",162 ,0)
  5154    F  S SVDT =$O(^IBCN( 365.1,"AD" ,DFN,PAYER ,SVDT)) Q: 'SVDT  D
  5155   "RTN","IBC NEUT5",163 ,0)
  5156    . S DA=0
  5157   "RTN","IBC NEUT5",164 ,0)
  5158    . F  S DA =$O(^IBCN( 365.1,"AD" ,DFN,PAYER ,SVDT,DA))  Q:'DA  D
  5159   "RTN","IBC NEUT5",165 ,0)
  5160    .. ; TQ S tatus
  5161   "RTN","IBC NEUT5",166 ,0)
  5162    .. S STS= $P($G(^IBC N(365.1,DA ,0)),U,4)
  5163   "RTN","IBC NEUT5",167 ,0)
  5164    .. ; Chec k to see i f record i s still sc heduled to  be transm itted.
  5165   "RTN","IBC NEUT5",168 ,0)
  5166    .. ; If s o, update  the servic e date if  the new se rvice date  and curre nt
  5167   "RTN","IBC NEUT5",169 ,0)
  5168    .. ; serv ice date a re both in  the past  or future  and the ne w service
  5169   "RTN","IBC NEUT5",170 ,0)
  5170    .. ; date  is closer  to Today.   Also, if  the curre nt service  date is i n
  5171   "RTN","IBC NEUT5",171 ,0)
  5172    .. ; the  future and  the new s ervice dat e is in th e past, up date with  the
  5173   "RTN","IBC NEUT5",172 ,0)
  5174    .. ; new  service da te.
  5175   "RTN","IBC NEUT5",173 ,0)
  5176    .. ; If n ot Ready t o Transmit (1), Hold( 4) and Ret ry(6), qui t
  5177   "RTN","IBC NEUT5",174 ,0)
  5178    .. I STS' =1,STS'=4, STS'=6 Q
  5179   "RTN","IBC NEUT5",175 ,0)
  5180    .. ; If H old and la st Respons e returned  Error Act ion - Plea se resubmi t
  5181   "RTN","IBC NEUT5",176 ,0)
  5182    .. ; Orig inal Trans action (P)  - do not  update
  5183   "RTN","IBC NEUT5",177 ,0)
  5184    .. I STS= 4 S ERACT= "" D  I ER ACT="P" Q
  5185   "RTN","IBC NEUT5",178 ,0)
  5186    .. . ; La st msg sen t
  5187   "RTN","IBC NEUT5",179 ,0)
  5188    .. . S HL 7IEN=$O(^I BCN(365.1, DA,2," "), -1) Q:'HL7 IEN
  5189   "RTN","IBC NEUT5",180 ,0)
  5190    .. . ; As soc eIV Re sponse IEN
  5191   "RTN","IBC NEUT5",181 ,0)
  5192    .. . S RI EN=$P($G(^ IBCN(365.1 ,DA,2,HL7I EN,0)),U,3 ) Q:'RIEN
  5193   "RTN","IBC NEUT5",182 ,0)
  5194    .. . ; Er ror Action  IEN (365. 018)
  5195   "RTN","IBC NEUT5",183 ,0)
  5196    .. . S ER ACT=$P($G( ^IBCN(365, RIEN,1)),U ,15) Q:'ER ACT
  5197   "RTN","IBC NEUT5",184 ,0)
  5198    .. . S ER ACT=$P($G( ^IBE(365.0 18,ERACT,0 )),U,1)
  5199   "RTN","IBC NEUT5",185 ,0)
  5200    .. ;
  5201   "RTN","IBC NEUT5",186 ,0)
  5202    .. ; Curr ent servic e date for  TQ entry
  5203   "RTN","IBC NEUT5",187 ,0)
  5204    .. S CSRV DT=$P($G(^ IBCN(365.1 ,DA,0)),U, 12)
  5205   "RTN","IBC NEUT5",188 ,0)
  5206    .. ; If c urrent ser vice date  is today ( DT), do no t update
  5207   "RTN","IBC NEUT5",189 ,0)
  5208    .. I CSRV DT=DT Q
  5209   "RTN","IBC NEUT5",190 ,0)
  5210    .. ; If n ew service  date is i n the futu re and cur rent servi ce date is  in
  5211   "RTN","IBC NEUT5",191 ,0)
  5212    .. ; the  past, do n ot update
  5213   "RTN","IBC NEUT5",192 ,0)
  5214    .. I SRVD T>DT,CSRVD T<DT Q
  5215   "RTN","IBC NEUT5",193 ,0)
  5216    .. ; If n ew service  date is t oday, upda te
  5217   "RTN","IBC NEUT5",194 ,0)
  5218    .. I SRVD T=DT D SAV ETQ^IBCNEU T2(DA,SRVD T),SAVFRSH (DA,+$$FMD IFF^XLFDT( SRVDT,CSRV DT,1)) Q
  5219   "RTN","IBC NEUT5",195 ,0)
  5220    .. ; If b oth curren t and new  service da tes are in  the past  or future,
  5221   "RTN","IBC NEUT5",196 ,0)
  5222    .. ; only  update, w hen new se rvice date  is closer  to today  (DT).
  5223   "RTN","IBC NEUT5",197 ,0)
  5224    .. I ((CS RVDT<DT)&( SRVDT<DT)) !((CSRVDT> DT)&(SRVDT >DT)) D  Q
  5225   "RTN","IBC NEUT5",198 ,0)
  5226    .. . S CS PAN=$$FMDI FF^XLFDT(C SRVDT,DT,1 ),SPAN=$$F MDIFF^XLFD T(SRVDT,DT ,1)
  5227   "RTN","IBC NEUT5",199 ,0)
  5228    .. . I CS PAN<0 S CS PAN=-CSPAN
  5229   "RTN","IBC NEUT5",200 ,0)
  5230    .. . I SP AN<0 S SPA N=-SPAN
  5231   "RTN","IBC NEUT5",201 ,0)
  5232    .. . I SP AN<CSPAN D  SAVETQ^IB CNEUT2(DA, SRVDT),SAV FRSH(DA,+$ $FMDIFF^XL FDT(SRVDT, CSRVDT,1))
  5233   "RTN","IBC NEUT5",202 ,0)
  5234    .. ; If n ew service  date is i n the past  and curre nt service  date is i n
  5235   "RTN","IBC NEUT5",203 ,0)
  5236    .. ; the  future, up date
  5237   "RTN","IBC NEUT5",204 ,0)
  5238    .. I SRVD T<CSRVDT D  SAVETQ^IB CNEUT2(DA, SRVDT),SAV FRSH(DA,+$ $FMDIFF^XL FDT(SRVDT, CSRVDT,1))  Q
  5239   "RTN","IBC NEUT5",205 ,0)
  5240    .. Q
  5241   "RTN","IBC NEUT5",206 ,0)
  5242   TQUPDSVX ;  TQUPDSV e xit pt
  5243   "RTN","IBC NEUT5",207 ,0)
  5244    Q
  5245   "RTN","IBC NEUT5",208 ,0)
  5246    ;
  5247   "RTN","IBC NEUT5",209 ,0)
  5248   TQMAXSV(DF N,PAYER,EI CDEXT) ; R eturns MAX (TQ Servic e Date) fo r Patient  & Payer
  5249   "RTN","IBC NEUT5",210 ,0)
  5250    ; Input: 
  5251   "RTN","IBC NEUT5",211 ,0)
  5252    ;  DFN      - Patien t DFN (2)
  5253   "RTN","IBC NEUT5",212 ,0)
  5254    ;  PAYER    - Payer  IEN (365.1 2) (If no  PAYER pass ed in, che ck them al l)
  5255   "RTN","IBC NEUT5",213 ,0)
  5256    ;  EICDEX T - 1 OR 0  (Is this  from the E ICD extrac t?)
  5257   "RTN","IBC NEUT5",214 ,0)
  5258    ;
  5259   "RTN","IBC NEUT5",215 ,0)
  5260    ; Output:
  5261   "RTN","IBC NEUT5",216 ,0)
  5262    ;  TQMAXS V - MAX (m ost recent ) service  date from  TQ entry f or Patient  &
  5263   "RTN","IBC NEUT5",217 ,0)
  5264    ;             Payer
  5265   "RTN","IBC NEUT5",218 ,0)
  5266    ;
  5267   "RTN","IBC NEUT5",219 ,0)
  5268    ; IB*621  reworked t his functi on to igno re TQ entr ies with s tatuses of
  5269   "RTN","IBC NEUT5",220 ,0)
  5270    ;  "Respo nse Receiv ed" for EI CD for whi ch the Res ponse indi cated a "C learinghou se Timeout "
  5271   "RTN","IBC NEUT5",221 ,0)
  5272    N TQMAXSV
  5273   "RTN","IBC NEUT5",222 ,0)
  5274    S TQMAXSV =""
  5275   "RTN","IBC NEUT5",223 ,0)
  5276    I $G(DFN) ="" G TQMA XSVX
  5277   "RTN","IBC NEUT5",224 ,0)
  5278    ;
  5279   "RTN","IBC NEUT5",225 ,0)
  5280    N ERTXT,I BSKIP,IBTQ S,IENS,LAS TBYP,STATL IST,TQIEN
  5281   "RTN","IBC NEUT5",226 ,0)
  5282    ; This is  the list  of statuse s that are  to be ign ored for E ICD extrac t only
  5283   "RTN","IBC NEUT5",227 ,0)
  5284    ;   3=Res ponse Rece ived
  5285   "RTN","IBC NEUT5",228 ,0)
  5286    S STATLIS T=",3,"
  5287   "RTN","IBC NEUT5",229 ,0)
  5288    ;
  5289   "RTN","IBC NEUT5",230 ,0)
  5290    S LASTBYP =""
  5291   "RTN","IBC NEUT5",231 ,0)
  5292    F  S LAST BYP=$O(^IB CN(365.1," AD",DFN,PA YER,LASTBY P)) Q:LAST BYP=""  D
  5293   "RTN","IBC NEUT5",232 ,0)
  5294    . S TQIEN =""
  5295   "RTN","IBC NEUT5",233 ,0)
  5296    . F  S TQ IEN=$O(^IB CN(365.1," AD",DFN,PA YER,LASTBY P,TQIEN))  Q:TQIEN=""   D
  5297   "RTN","IBC NEUT5",234 ,0)
  5298    .. S IBSK IP=0
  5299   "RTN","IBC NEUT5",235 ,0)
  5300    .. I EICD EXT D  Q:I BSKIP
  5301   "RTN","IBC NEUT5",236 ,0)
  5302    .. . S IB TQS=+$$GET 1^DIQ(365. 1,TQIEN_", ",.04,"I")     ; TQ T ransmissio n Status 
  5303   "RTN","IBC NEUT5",237 ,0)
  5304    .. . I IB TQS,'($F(S TATLIST,", "_IBTQS_", ")) Q
  5305   "RTN","IBC NEUT5",238 ,0)
  5306    .. . S IE NS="1,"_TQ IEN_",",RI EN=$$GET1^ DIQ(365.16 ,IENS,.03, "I")
  5307   "RTN","IBC NEUT5",239 ,0)
  5308    .. . S ER TXT=$$GET1 ^DIQ(365,R IEN_",",4. 01) I $$UP ^XLFSTR(ER TXT)["TIME OUT" S IBS KIP=1 ; ke ep looking
  5309   "RTN","IBC NEUT5",240 ,0)
  5310    .. I LAST BYP>TQMAXS V S TQMAXS V=LASTBYP
  5311   "RTN","IBC NEUT5",241 ,0)
  5312    ;
  5313   "RTN","IBC NEUT5",242 ,0)
  5314   TQMAXSVX ;  TQMAXSV e xit pt
  5315   "RTN","IBC NEUT5",243 ,0)
  5316    Q TQMAXSV
  5317   "RTN","IBC NEUT5",244 ,0)
  5318    ;
  5319   "RTN","IBC NEUT5",245 ,0)
  5320   SAVFRSH(TQ IEN,DTDIFF ) ; Update  TQ freshn ess date b ased on se rvice date  diff
  5321   "RTN","IBC NEUT5",246 ,0)
  5322    ;
  5323   "RTN","IBC NEUT5",247 ,0)
  5324    N DIE,DA, FDT,DR,D,D 0,DI,DIC,D Q,X
  5325   "RTN","IBC NEUT5",248 ,0)
  5326    I $G(TQIE N)="" Q
  5327   "RTN","IBC NEUT5",249 ,0)
  5328    S FDT=$P( $G(^IBCN(3 65.1,TQIEN ,0)),U,17)
  5329   "RTN","IBC NEUT5",250 ,0)
  5330    ; Note -  will only  update if  FDT > 0.
  5331   "RTN","IBC NEUT5",251 ,0)
  5332    S FDT=$$F MADD^XLFDT (FDT,+DTDI FF)
  5333   "RTN","IBC NEUT5",252 ,0)
  5334    S DIE="^I BCN(365.1, ",DA=TQIEN ,DR=".17// //"_FDT
  5335   "RTN","IBC NEUT5",253 ,0)
  5336    D ^DIE
  5337   "RTN","IBC NEUT5",254 ,0)
  5338    Q
  5339   "RTN","IBC NEUT5",255 ,0)
  5340    ;
  5341   "RTN","IBC NSMM")
  5342   0^12^B1943 8322^B1930 1339
  5343   "RTN","IBC NSMM",1,0)
  5344   IBCNSMM ;A LB/CMS -ME DICARE INS URANCE INT AKE ; 18-O CT-98
  5345   "RTN","IBC NSMM",2,0)
  5346    ;;2.0;INT EGRATED BI LLING;**10 3,133,184, 516,601,59 5,602**;21 -MAR-94;Bu ild 22
  5347   "RTN","IBC NSMM",3,0)
  5348    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5349   "RTN","IBC NSMM",4,0)
  5350    Q
  5351   "RTN","IBC NSMM",5,0)
  5352    ;
  5353   "RTN","IBC NSMM",6,0)
  5354   EN ; -- En try point  from Medic are Intake  Standalon e option
  5355   "RTN","IBC NSMM",7,0)
  5356    N DIC,DIR ,DA,%A,DFN ,X,Y,IBQUI T,IBCNSP,I BSOURCE
  5357   "RTN","IBC NSMM",8,0)
  5358    S (IBQUIT ,IBCNSP)=0  D GETWNR  I IBQUIT G  ENQ
  5359   "RTN","IBC NSMM",9,0)
  5360    ;
  5361   "RTN","IBC NSMM",10,0 )
  5362    ; - allow  the user  to enter t he Source  of Informa tion for t he policie s
  5363   "RTN","IBC NSMM",11,0 )
  5364    W !!,"You  may enter  the 'Sour ce of Info rmation' t hat will b e filed wi th all"
  5365   "RTN","IBC NSMM",12,0 )
  5366    W !,"Medi care insur ance cover age polici es that ar e created. ",!
  5367   "RTN","IBC NSMM",13,0 )
  5368    ;
  5369   "RTN","IBC NSMM",14,0 )
  5370    S DIR(0)= "2.312,1.0 9"
  5371   "RTN","IBC NSMM",15,0 )
  5372    S DIR("A" )="Enter S ource of I nformation "
  5373   "RTN","IBC NSMM",16,0 )
  5374    S DIR("B" )="INTERVI EW"
  5375   "RTN","IBC NSMM",17,0 )
  5376    D ^DIR K  DUOUT,DTOU T,DIRUT,DI ROUT,DIR
  5377   "RTN","IBC NSMM",18,0 )
  5378    S IBSOURC E=+Y I Y<1  G ENQ
  5379   "RTN","IBC NSMM",19,0 )
  5380    W !
  5381   "RTN","IBC NSMM",20,0 )
  5382    ;
  5383   "RTN","IBC NSMM",21,0 )
  5384    ; - loop  to select  patients
  5385   "RTN","IBC NSMM",22,0 )
  5386   ENA S DIC( 0)="AEQMN" ,DIC="^DPT (" D ^DIC
  5387   "RTN","IBC NSMM",23,0 )
  5388    I +Y<1 G  ENQ
  5389   "RTN","IBC NSMM",24,0 )
  5390    S DFN=+Y
  5391   "RTN","IBC NSMM",25,0 )
  5392    I $G(^DPT (DFN,.35))  W *7,!!,? 10,"Patien t Expired  on ",$$FMT E^XLFDT($P (^DPT(DFN, .35),U))
  5393   "RTN","IBC NSMM",26,0 )
  5394    W ! D DIS P^IBCNS W  !,?3 S X=" ",$P(X,"=" ,76)="" W  X
  5395   "RTN","IBC NSMM",27,0 )
  5396    D ENR(DFN ,IBSOURCE, 1) K DIC W  !! G ENA
  5397   "RTN","IBC NSMM",28,0 )
  5398    ;
  5399   "RTN","IBC NSMM",29,0 )
  5400   ENQ Q
  5401   "RTN","IBC NSMM",30,0 )
  5402    ;
  5403   "RTN","IBC NSMM",31,0 )
  5404    ;
  5405   "RTN","IBC NSMM",32,0 )
  5406   ENR(DFN,IB SOUR,IBOPT ) ; -- Ent ry point f rom IBCNBM E Patient  Registrati on or Pre- Registrati on
  5407   "RTN","IBC NSMM",33,0 )
  5408    ;    Inpu t Variable  DFN Requi red and IB SOUR =Sour ce of Info rmation
  5409   "RTN","IBC NSMM",34,0 )
  5410    ;                     IBOPT =1  if coming  from MII S tandalone  Option
  5411   "RTN","IBC NSMM",35,0 )
  5412    ;
  5413   "RTN","IBC NSMM",36,0 )
  5414    N D,DIE,D A,DIR,DIC, E,IBCPOL,I BCNSP,IBCD FN,IBQUIT, IBOK,IBC0, IBAD,IBGRP ,IBADPOL
  5415   "RTN","IBC NSMM",37,0 )
  5416    N IBNAME, IBHICN,IBA EFF,IBBEFF ,IBCOVP,IB GNA,IBGNU, IBBUF,IBNE W,IBP,X,Y
  5417   "RTN","IBC NSMM",38,0 )
  5418    N IBPOLA, IBPOLB,IBA RR,IBHIT,I BHITA,IBHI TB,IBCOB,I BCOBI
  5419   "RTN","IBC NSMM",39,0 )
  5420    ;
  5421   "RTN","IBC NSMM",40,0 )
  5422    ; IB*602  - IBHICN c ould also  be a Medic are Benefi ciary ID
  5423   "RTN","IBC NSMM",41,0 )
  5424    S (IBAEFF ,IBBEFF,IB CNSP,IBCDF N,IBNEW,IB QUIT)=0,IB ADPOL=1
  5425   "RTN","IBC NSMM",42,0 )
  5426    S (IBNAME ,IBHICN)=" "
  5427   "RTN","IBC NSMM",43,0 )
  5428    ;
  5429   "RTN","IBC NSMM",44,0 )
  5430    ; -- Get  Standard M edicare In surance Co mpany and  plans in I BCNSP
  5431   "RTN","IBC NSMM",45,0 )
  5432    D GETWNR  I IBQUIT G  ENRQ
  5433   "RTN","IBC NSMM",46,0 )
  5434    ;
  5435   "RTN","IBC NSMM",47,0 )
  5436    ; -- get  the patien t's Medica re policie s
  5437   "RTN","IBC NSMM",48,0 )
  5438    S (IBPOLA ,IBPOLB)=0
  5439   "RTN","IBC NSMM",49,0 )
  5440    S IBCDFN= 0 F  S IBC DFN=$O(^DP T(DFN,.312 ,"B",+IBCN SP,IBCDFN) ) Q:'IBCDF N  D
  5441   "RTN","IBC NSMM",50,0 )
  5442    .;IB*2.0* 516/TAZ -  Retrieve D ata from H IPAA compl iant field s.
  5443   "RTN","IBC NSMM",51,0 )
  5444    .;S IBCPO L=$G(^DPT( DFN,.312,I BCDFN,0))   ;516 - ba a
  5445   "RTN","IBC NSMM",52,0 )
  5446    .S IBCPOL =$$ZND^IBC NS1(DFN,IB CDFN)  ;51 6 - baa
  5447   "RTN","IBC NSMM",53,0 )
  5448    .;
  5449   "RTN","IBC NSMM",54,0 )
  5450    .; - is t he policy  for Part A ?
  5451   "RTN","IBC NSMM",55,0 )
  5452    .I $P(IBC NSP,U,3)=$ P(IBCPOL,U ,18) D  Q
  5453   "RTN","IBC NSMM",56,0 )
  5454    ..S IBPOL A=IBPOLA+1 ,IBARR("A" ,IBPOLA)=I BCDFN_"^"_ IBCPOL
  5455   "RTN","IBC NSMM",57,0 )
  5456    .;
  5457   "RTN","IBC NSMM",58,0 )
  5458    .; - is t he policy  for Part B ?
  5459   "RTN","IBC NSMM",59,0 )
  5460    .I $P(IBC NSP,U,5)=$ P(IBCPOL,U ,18) D
  5461   "RTN","IBC NSMM",60,0 )
  5462    ..S IBPOL B=IBPOLB+1 ,IBARR("B" ,IBPOLB)=I BCDFN_"^"_ IBCPOL
  5463   "RTN","IBC NSMM",61,0 )
  5464    ;
  5465   "RTN","IBC NSMM",62,0 )
  5466    ; - can't  edit here  if there  is more th an one pol icy
  5467   "RTN","IBC NSMM",63,0 )
  5468    I $D(IBAR R("A",2))  K IBARR("A ") D
  5469   "RTN","IBC NSMM",64,0 )
  5470    .W !!,"Th is patient  has more  than one P art A poli cy.  Pleas e edit in  Ins Mgmt."
  5471   "RTN","IBC NSMM",65,0 )
  5472    ;
  5473   "RTN","IBC NSMM",66,0 )
  5474    I $D(IBAR R("B",2))  K IBARR("B ") D
  5475   "RTN","IBC NSMM",67,0 )
  5476    .W !!,"Th is patient  has more  than one P art B poli cy.  Pleas e edit in  Ins Mgmt."
  5477   "RTN","IBC NSMM",68,0 )
  5478    ;
  5479   "RTN","IBC NSMM",69,0 )
  5480    I (IBPOLA !IBPOLB),' $D(IBARR)  G ENRQ
  5481   "RTN","IBC NSMM",70,0 )
  5482    ;
  5483   "RTN","IBC NSMM",71,0 )
  5484    ; -- Ask  for Medica re Insuran ce Card in formation
  5485   "RTN","IBC NSMM",72,0 )
  5486    ;    Retu rn IBNAME,  IBHICN, I BAEFF, IBB EFF, IBCOB /IBCOBI
  5487   "RTN","IBC NSMM",73,0 )
  5488    D MII^IBC NSMM2 I IB QUIT G ENR Q
  5489   "RTN","IBC NSMM",74,0 )
  5490    ;
  5491   "RTN","IBC NSMM",75,0 )
  5492    ; - if Pa rt A or B  exists, bu t no chang es, quit
  5493   "RTN","IBC NSMM",76,0 )
  5494    I $D(IBAR R("A",1))  D COM($P(I BARR("A",1 ),"^",2,99 ),"A") I I BHIT D
  5495   "RTN","IBC NSMM",77,0 )
  5496    .S IBHITA =1 W !,"   * No Part  A changes  made..."
  5497   "RTN","IBC NSMM",78,0 )
  5498    ;
  5499   "RTN","IBC NSMM",79,0 )
  5500    I $D(IBAR R("B",1))  D COM($P(I BARR("B",1 ),"^",2,99 ),"B") I I BHIT D
  5501   "RTN","IBC NSMM",80,0 )
  5502    .S IBHITB =1 W !,"   * No Part  B changes  made..."
  5503   "RTN","IBC NSMM",81,0 )
  5504    ;
  5505   "RTN","IBC NSMM",82,0 )
  5506    I $G(IBHI TA),$G(IBH ITB) G ENR Q
  5507   "RTN","IBC NSMM",83,0 )
  5508    I $G(IBHI TA),'$G(IB BEFF) G EN RQ
  5509   "RTN","IBC NSMM",84,0 )
  5510    I $G(IBHI TB),'$G(IB AEFF) G EN RQ
  5511   "RTN","IBC NSMM",85,0 )
  5512    ;
  5513   "RTN","IBC NSMM",86,0 )
  5514    ;IB*595 R emoved abi lity to fi le directl y into Ins urance Typ e File
  5515   "RTN","IBC NSMM",87,0 )
  5516    I IBAEFF, '$G(IBHITA ) D BUFF^I BCNSMM1("A ")
  5517   "RTN","IBC NSMM",88,0 )
  5518    I IBBEFF, '$G(IBHITB ) D BUFF^I BCNSMM1("B ")
  5519   "RTN","IBC NSMM",89,0 )
  5520    ;
  5521   "RTN","IBC NSMM",90,0 )
  5522    ; -- If u ser not ho lding key  set data i n Buffer F ile
  5523   "RTN","IBC NSMM",91,0 )
  5524    ;I '$D(^X USEC("IB I NSURANCE S UPERVISOR" ,DUZ)) D G  ENRQ
  5525   "RTN","IBC NSMM",92,0 )
  5526    ;.I IBAEF F,'$G(IBHI TA) D BUFF ^IBCNSMM1( "A")
  5527   "RTN","IBC NSMM",93,0 )
  5528    ;.I IBBEF F,'$G(IBHI TB) D BUFF ^IBCNSMM1( "B")
  5529   "RTN","IBC NSMM",94,0 )
  5530    ;
  5531   "RTN","IBC NSMM",95,0 )
  5532    ; -- Othe rwise, set  data into  permanent  files
  5533   "RTN","IBC NSMM",96,0 )
  5534    ;I IBAEFF ,'$G(IBHIT A) D
  5535   "RTN","IBC NSMM",97,0 )
  5536    ;.I IBPOL A,'$D(IBAR R("A")) Q  ; can't up date Part  A policy
  5537   "RTN","IBC NSMM",98,0 )
  5538    ;.I '$D(I BARR("A",1 )) D ADDP( "A") Q
  5539   "RTN","IBC NSMM",99,0 )
  5540    ;.S IBCDF N=+IBARR(" A",1) D SE TP^IBCNSMM 1("A")
  5541   "RTN","IBC NSMM",100, 0)
  5542    ;I IBBEFF ,'$G(IBHIT B) D
  5543   "RTN","IBC NSMM",101, 0)
  5544    ;.I IBPOL B,'$D(IBAR R("B")) Q  ; can't up date Part  B policy
  5545   "RTN","IBC NSMM",102, 0)
  5546    ;.I '$D(I BARR("B",1 )) D ADDP( "B") Q
  5547   "RTN","IBC NSMM",103, 0)
  5548    ;.S IBCDF N=+IBARR(" B",1) D SE TP^IBCNSMM 1("B")
  5549   "RTN","IBC NSMM",104, 0)
  5550    ;IB*595 E ND
  5551   "RTN","IBC NSMM",105, 0)
  5552    ;
  5553   "RTN","IBC NSMM",106, 0)
  5554   ENRQ W ! Q
  5555   "RTN","IBC NSMM",107, 0)
  5556    ;
  5557   "RTN","IBC NSMM",108, 0)
  5558    ;
  5559   "RTN","IBC NSMM",109, 0)
  5560    ;
  5561   "RTN","IBC NSMM",110, 0)
  5562   ADDP(IBP)  ; -- Creat e a new pa tient poli cy
  5563   "RTN","IBC NSMM",111, 0)
  5564    ;    Inpu t: DFN
  5565   "RTN","IBC NSMM",112, 0)
  5566    ;            IBCNSP= MED WNR IN S IEN^MEDI CARE (WNR)
  5567   "RTN","IBC NSMM",113, 0)
  5568    ;                    ^PART A IE N^PART A
  5569   "RTN","IBC NSMM",114, 0)
  5570    ;                    ^PART B IE N^PART A
  5571   "RTN","IBC NSMM",115, 0)
  5572    ;            IBP = " A" or "B"  for medica re part
  5573   "RTN","IBC NSMM",116, 0)
  5574    ;            IBSOUR  = Source o f Informat ion
  5575   "RTN","IBC NSMM",117, 0)
  5576    ;   Retur n: IBCDFN= -1 could n ot add OR  Policy ien
  5577   "RTN","IBC NSMM",118, 0)
  5578    ;            IBCOVP=  Covered b y Health I nsurance
  5579   "RTN","IBC NSMM",119, 0)
  5580    ;
  5581   "RTN","IBC NSMM",120, 0)
  5582    N X,Y,DO, DD,DA,DR,D IC,DIE,DIK ,DIR,DIRUT ,IBSPEC
  5583   "RTN","IBC NSMM",121, 0)
  5584    ; -- Crea te a New p atient pol icy
  5585   "RTN","IBC NSMM",122, 0)
  5586    S IBCOVP= $P($G(^DPT (DFN,.31)) ,U,11)
  5587   "RTN","IBC NSMM",123, 0)
  5588    ;
  5589   "RTN","IBC NSMM",124, 0)
  5590    D FIELD^D ID(2,.3121 ,"","SPECI FIER","IBS PEC")
  5591   "RTN","IBC NSMM",125, 0)
  5592    S DIC("DR ")="1.09// //"_IBSOUR _";1.05/// NOW;1.06// //"_DUZ,DI C("P")=$G( IBSPEC("SP ECIFIER"))
  5593   "RTN","IBC NSMM",126, 0)
  5594    K DD,DO S  DA(1)=DFN ,DIC="^DPT ("_DFN_",. 312,",DIC( 0)="L",X=+ IBCNSP,DLA YGO=2.312
  5595   "RTN","IBC NSMM",127, 0)
  5596    D FILE^DI CN K DD,DO ,DLAYGO,DI C
  5597   "RTN","IBC NSMM",128, 0)
  5598    S IBCDFN= +Y
  5599   "RTN","IBC NSMM",129, 0)
  5600    I IBCDFN< 1 W !!,*7, "  <Could  not create  new polic y at this  time.  Try  Later!>", ! G ADDPQ
  5601   "RTN","IBC NSMM",130, 0)
  5602    ;
  5603   "RTN","IBC NSMM",131, 0)
  5604    ; -- Set  Medicare p olicy data
  5605   "RTN","IBC NSMM",132, 0)
  5606    D SETP^IB CNSMM1(IBP )
  5607   "RTN","IBC NSMM",133, 0)
  5608   ADDPQ Q
  5609   "RTN","IBC NSMM",134, 0)
  5610    ;
  5611   "RTN","IBC NSMM",135, 0)
  5612    ;
  5613   "RTN","IBC NSMM",136, 0)
  5614   GETWNR ;
  5615   "RTN","IBC NSMM",137, 0)
  5616    ; -- Get  Medicare ( WNR) insur ance compa ny and pla n data
  5617   "RTN","IBC NSMM",138, 0)
  5618    ;    Retu rns IBCNSP  or IBQUIT
  5619   "RTN","IBC NSMM",139, 0)
  5620    ;    IBCN SP="Error:  Medicare  (WNR) ...  not setup  properly" 
  5621   "RTN","IBC NSMM",140, 0)
  5622    ;            if Medi care WNR e ntry or pl ans not se tup proper ly
  5623   "RTN","IBC NSMM",141, 0)
  5624    ;
  5625   "RTN","IBC NSMM",142, 0)
  5626    ;    IBCN SP=INS CO.  (36) IEN^ "MEDICARE  (WNR)"
  5627   "RTN","IBC NSMM",143, 0)
  5628    ;            ^PLAN ( 355.3) PAR TA IEN^"PA RT A"
  5629   "RTN","IBC NSMM",144, 0)
  5630    ;            ^PLAN ( 355.3) PAR TB IEN^"PA RT B"
  5631   "RTN","IBC NSMM",145, 0)
  5632    ;
  5633   "RTN","IBC NSMM",146, 0)
  5634    I 'IBCNSP  S IBCNSP= $$GETWNR^I BCNSMM1
  5635   "RTN","IBC NSMM",147, 0)
  5636    I 'IBCNSP  W !!,*7,? 3,IBCNSP S  IBQUIT=1
  5637   "RTN","IBC NSMM",148, 0)
  5638    Q
  5639   "RTN","IBC NSMM",149, 0)
  5640    ;
  5641   "RTN","IBC NSMM",150, 0)
  5642   VALHIC(X)  ; Edits fo r validati ng HIC #
  5643   "RTN","IBC NSMM",151, 0)
  5644    ; X = the  HIC # to  be validat ed
  5645   "RTN","IBC NSMM",152, 0)
  5646    ;IB*2.0*6 01 JRA Rem ove specia l HIC # va lidation -  use exist ing error  messages I B356/IB357 /IB358 whe n the
  5647   "RTN","IBC NSMM",153, 0)
  5648    ; Primary /Secondary /Tertiary  insurance  subscriber 's ID numb er is miss ing (as wi th other i nsurances) .
  5649   "RTN","IBC NSMM",154, 0)
  5650    ; 
  5651   "RTN","IBC NSMM",155, 0)
  5652    ;IB*2.0*6 01 JRA QUI T '1' to r emove spec ial valida tion for H IC #, whic h will pre vent the d isplay of  IB Error
  5653   "RTN","IBC NSMM",156, 0)
  5654    ; message  IB215 and  the HIC #  help text  at HLP^IB CNSM32.
  5655   "RTN","IBC NSMM",157, 0)
  5656    Q 1  ;IB* 2.0*601 JR A
  5657   "RTN","IBC NSMM",158, 0)
  5658    N VAL
  5659   "RTN","IBC NSMM",159, 0)
  5660    S VAL=1
  5661   "RTN","IBC NSMM",160, 0)
  5662    I X'?9N1A .1AN,X'?1. 3A6N,X'?1. 3A9N S VAL =0
  5663   "RTN","IBC NSMM",161, 0)
  5664    Q VAL
  5665   "RTN","IBC NSMM",162, 0)
  5666    ;
  5667   "RTN","IBC NSMM",163, 0)
  5668   COM(X,Y) ;  Compare X  with the  intake var iables.
  5669   "RTN","IBC NSMM",164, 0)
  5670    ;    Inpu t: X => 0t h node of  policy in  file #2.31 2
  5671   "RTN","IBC NSMM",165, 0)
  5672    ;            Y => A  (Part A) o r B (part  B)
  5673   "RTN","IBC NSMM",166, 0)
  5674    ;   Outpu t: IBHIT=1  (no chang es made)
  5675   "RTN","IBC NSMM",167, 0)
  5676    S IBHIT=0
  5677   "RTN","IBC NSMM",168, 0)
  5678    I $P(X,"^ ",17)'=IBN AME G COMQ
  5679   "RTN","IBC NSMM",169, 0)
  5680    I $P(X,"^ ",2)'=IBHI CN G COMQ
  5681   "RTN","IBC NSMM",170, 0)
  5682    I $P(X,"^ ",8)'=$S(Y ="A":IBAEF F,1:IBBEFF ) G COMQ
  5683   "RTN","IBC NSMM",171, 0)
  5684    I $P(X,"^ ",20)'=IBC OBI G COMQ
  5685   "RTN","IBC NSMM",172, 0)
  5686    ;
  5687   "RTN","IBC NSMM",173, 0)
  5688    S IBHIT=1
  5689   "RTN","IBC NSMM",174, 0)
  5690   COMQ Q
  5691   "RTN","IBC NSMM1")
  5692   0^16^B2778 8048^B2781 8840
  5693   "RTN","IBC NSMM1",1,0 )
  5694   IBCNSMM1 ; ALB/CMS -M EDICARE IN SURANCE IN TAKE (CONT ) ; 11/8/0 6 9:32am
  5695   "RTN","IBC NSMM1",2,0 )
  5696    ;;2.0;INT EGRATED BI LLING;**10 3,359,497, 602**;21-M AR-94;Buil d 22
  5697   "RTN","IBC NSMM1",3,0 )
  5698    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5699   "RTN","IBC NSMM1",4,0 )
  5700    ;;(THIS R OUTINE WAS  DEACTIVAT ED VIA PAT CH 497...A ND SHOULD  BE RESEARC HED
  5701   "RTN","IBC NSMM1",5,0 )
  5702    ;;IF REAC TIVATED... REFER TO F IELDS (40. 02, 40.03,  60.04, 60 .07 OF THE
  5703   "RTN","IBC NSMM1",6,0 )
  5704    ;;355.33  FILE.)
  5705   "RTN","IBC NSMM1",7,0 )
  5706    Q
  5707   "RTN","IBC NSMM1",8,0 )
  5708    ;
  5709   "RTN","IBC NSMM1",9,0 )
  5710   SETP(IBP)  ; -- Stuff  data fiel ds in pati ent policy
  5711   "RTN","IBC NSMM1",10, 0)
  5712    ;  Requir ed Input:
  5713   "RTN","IBC NSMM1",11, 0)
  5714    ;  IBP =A  for Part  A, B for P art B
  5715   "RTN","IBC NSMM1",12, 0)
  5716    ;  DFN =p t. ien
  5717   "RTN","IBC NSMM1",13, 0)
  5718    ;  IBCDFN  =patient  policy ien
  5719   "RTN","IBC NSMM1",14, 0)
  5720    ;  IBNAME  =Name of  Insured
  5721   "RTN","IBC NSMM1",15, 0)
  5722    ;  IBHICN  =Subscrib er ID - as  of IB*601  could als o be a MBI  Number
  5723   "RTN","IBC NSMM1",16, 0)
  5724    ;  IBAEFF  =Effectiv e Date of  Plan A
  5725   "RTN","IBC NSMM1",17, 0)
  5726    ;  IBBEFF  =Effectiv e Date of  Plan B
  5727   "RTN","IBC NSMM1",18, 0)
  5728    ;  IBCNSP  =Medicare  (WNR) ien  ^Part A i en ^Part B  ien
  5729   "RTN","IBC NSMM1",19, 0)
  5730    ;  IBCOBI  =Coordina tion of Be nefits (In ternal val ue)
  5731   "RTN","IBC NSMM1",20, 0)
  5732    ;
  5733   "RTN","IBC NSMM1",21, 0)
  5734    N D,DA,DI E,DR,IBBDA ,X,Y
  5735   "RTN","IBC NSMM1",22, 0)
  5736    I '$D(^DP T(DFN,.312 ,+IBCDFN,0 )) G SETPQ
  5737   "RTN","IBC NSMM1",23, 0)
  5738    ;
  5739   "RTN","IBC NSMM1",24, 0)
  5740    ; -- Stuf f the pt.  policy fie lds
  5741   "RTN","IBC NSMM1",25, 0)
  5742    ;   #2  * Group Numb er               #.18   Group Pl an
  5743   "RTN","IBC NSMM1",26, 0)
  5744    ;   #6  W hose Ins.                   #.2    COB
  5745   "RTN","IBC NSMM1",27, 0)
  5746    ;   #8  E ffective D ate of Pol icy   #7.0 2    Sub.  ID
  5747   "RTN","IBC NSMM1",28, 0)
  5748    ;   #15 * Group Name                  #7.0 1   Name o f Insured
  5749   "RTN","IBC NSMM1",29, 0)
  5750    ;   #16 P t. Relatio nship to I nsured
  5751   "RTN","IBC NSMM1",30, 0)
  5752    ;
  5753   "RTN","IBC NSMM1",31, 0)
  5754    S DIE="^D PT("_DFN_" ,.312,",DA =+IBCDFN,D A(1)=DFN
  5755   "RTN","IBC NSMM1",32, 0)
  5756    S DR="2// /"_$S(IBP= "A":$P(IBC NSP,U,4),I BP="B":$P( IBCNSP,U,6 ),1:"")
  5757   "RTN","IBC NSMM1",33, 0)
  5758    S DR=DR_" ;7.01///"_ IBNAME_";7 .02///"_IB HICN        ; IB*2.0* 497 (vd)
  5759   "RTN","IBC NSMM1",34, 0)
  5760    S DR=DR_" ;6///v;8// /"_$S(IBP= "A":$G(IBA EFF),IBP=" B":$G(IBBE FF),1:"")
  5761   "RTN","IBC NSMM1",35, 0)
  5762    S DR=DR_" ;.2////"_I BCOBI_";15 ///"_$S(IB P="A":"PAR T A",IBP=" B":"PART B ",1:"")
  5763   "RTN","IBC NSMM1",36, 0)
  5764    S DR=DR_" ;16///01;. 18////"_$S (IBP="A":+ $P(IBCNSP, U,3),IBP=" B":+$P(IBC NSP,U,5),1 :"")
  5765   "RTN","IBC NSMM1",37, 0)
  5766    D ^DIE
  5767   "RTN","IBC NSMM1",38, 0)
  5768    ;
  5769   "RTN","IBC NSMM1",39, 0)
  5770    ;  -- Upd ate Insura nce Event
  5771   "RTN","IBC NSMM1",40, 0)
  5772    S IBCOVP= $P($G(^DPT (DFN,.31)) ,U,11)
  5773   "RTN","IBC NSMM1",41, 0)
  5774    D BEFORE^ IBCNSEVT S  IBNEW=1
  5775   "RTN","IBC NSMM1",42, 0)
  5776    ;
  5777   "RTN","IBC NSMM1",43, 0)
  5778    ; -- Ask  to Verify  at this ti me
  5779   "RTN","IBC NSMM1",44, 0)
  5780    K DIR S D IR("A")="V erify Medi care (WNR)  Part "_IB P_" Covera ge Now"
  5781   "RTN","IBC NSMM1",45, 0)
  5782    S DIR("?" )="Enter ' No' to not  Verify Co verage at  this time. "
  5783   "RTN","IBC NSMM1",46, 0)
  5784    W ! S IBO K=0 D OK I  'IBOK G S ETEV
  5785   "RTN","IBC NSMM1",47, 0)
  5786    ;
  5787   "RTN","IBC NSMM1",48, 0)
  5788    ; -- Chec k to see i f Pt. Name  = name of  Insured
  5789   "RTN","IBC NSMM1",49, 0)
  5790    I IBNAME' =$P($G(^DP T(DFN,0)), U,1) D
  5791   "RTN","IBC NSMM1",50, 0)
  5792    .W !!,"WA RNING: Pat ient Name:  '"_$P($G( ^DPT(DFN,0 )),U,1)_"'   DOES NOT  MATCH"
  5793   "RTN","IBC NSMM1",51, 0)
  5794    .W !,"       Name of  Insured:  '"_IBNAME_ "'.",!
  5795   "RTN","IBC NSMM1",52, 0)
  5796    ;
  5797   "RTN","IBC NSMM1",53, 0)
  5798    ; -- veri fy policy
  5799   "RTN","IBC NSMM1",54, 0)
  5800    S DIE="^D PT("_DFN_" ,.312,",DA =IBCDFN,DA (1)=DFN
  5801   "RTN","IBC NSMM1",55, 0)
  5802    S DR="1.0 3///NOW;1. 04////"_DU Z D ^DIE
  5803   "RTN","IBC NSMM1",56, 0)
  5804    W !,"  PA RT "_IBP_"  COVERAGE  VERIFIED."
  5805   "RTN","IBC NSMM1",57, 0)
  5806    ;
  5807   "RTN","IBC NSMM1",58, 0)
  5808   SETEV ; --  Update In surance ev ent
  5809   "RTN","IBC NSMM1",59, 0)
  5810    N X,Y
  5811   "RTN","IBC NSMM1",60, 0)
  5812    D COVERED ^IBCNSM31( DFN,IBCOVP )
  5813   "RTN","IBC NSMM1",61, 0)
  5814    I $G(IBCD FN)>0,IBNE W=1 D AFTE R^IBCNSEVT ,^IBCNSEVT
  5815   "RTN","IBC NSMM1",62, 0)
  5816    ;
  5817   "RTN","IBC NSMM1",63, 0)
  5818   SETPQ Q
  5819   "RTN","IBC NSMM1",64, 0)
  5820    ;
  5821   "RTN","IBC NSMM1",65, 0)
  5822    ;
  5823   "RTN","IBC NSMM1",66, 0)
  5824   BUFF(IBP)  ; -- Set I BBUF array  with poli cy info fo r Buffer F ile
  5825   "RTN","IBC NSMM1",67, 0)
  5826    ; Return:  IBBUF arr ay
  5827   "RTN","IBC NSMM1",68, 0)
  5828    ;    IBBU F(355.33 f ield #s)=c orrespondi ng policy,  plan and  company da ta
  5829   "RTN","IBC NSMM1",69, 0)
  5830    ;    i.e.   IBBUF(20 .01)=Insur ance Compa ny Name
  5831   "RTN","IBC NSMM1",70, 0)
  5832    ;           IBBUF(90 .01)=Group  Name
  5833   "RTN","IBC NSMM1",71, 0)
  5834    ;           IBBUF(60 .01)=DFN
  5835   "RTN","IBC NSMM1",72, 0)
  5836    ;
  5837   "RTN","IBC NSMM1",73, 0)
  5838    ; Input:  DFN, IBCNS P, IBNAME,  IBHICN, I BAEFF, IBB EFF, IBCOB I
  5839   "RTN","IBC NSMM1",74, 0)
  5840    ;            
  5841   "RTN","IBC NSMM1",75, 0)
  5842    ; Auto st uff other  fields
  5843   "RTN","IBC NSMM1",76, 0)
  5844    ;
  5845   "RTN","IBC NSMM1",77, 0)
  5846    N IBP0 K  IBBUF S IB BUF=""
  5847   "RTN","IBC NSMM1",78, 0)
  5848    S IBBUF(. 03)=$G(IBS OUR)
  5849   "RTN","IBC NSMM1",79, 0)
  5850    S IBBUF(2 0.01)=$P(I BCNSP,U,2)
  5851   "RTN","IBC NSMM1",80, 0)
  5852    S IBBUF(9 0.01)=$S(I BP="A":$P( IBCNSP,U,4 ),IBP="B": $P(IBCNSP, U,6),1:"")    ; IB*2. 0*497 (vd)
  5853   "RTN","IBC NSMM1",81, 0)
  5854    S IBBUF(9 0.02)=IBBU F(90.01)            ;  IB*2.0*49 7 (vd)
  5855   "RTN","IBC NSMM1",82, 0)
  5856    S IBBUF(6 0.01)=+DFN
  5857   "RTN","IBC NSMM1",83, 0)
  5858    S IBBUF(6 0.02)=$S(I BP="A":IBA EFF,IBP="B ":IBBEFF,1 :"")
  5859   "RTN","IBC NSMM1",84, 0)
  5860    S IBBUF(9 0.03)=IBHI CN                  ;  IB*2.0*49 7 (vd)
  5861   "RTN","IBC NSMM1",85, 0)
  5862    S IBBUF(6 0.05)="v"
  5863   "RTN","IBC NSMM1",86, 0)
  5864    S IBBUF(6 0.06)="01"
  5865   "RTN","IBC NSMM1",87, 0)
  5866    S IBBUF(9 1.01)=IBNA ME                  ;  IB*2.0*49 7 (vd)
  5867   "RTN","IBC NSMM1",88, 0)
  5868    S IBBUF(6 0.12)=IBCO BI
  5869   "RTN","IBC NSMM1",89, 0)
  5870    S IBBDA=$ $ADDSTF^IB CNBES(1,DF N,.IBBUF)
  5871   "RTN","IBC NSMM1",90, 0)
  5872    I +IBBDA  W !,?3,$P( IBCNSP,U,2 )," PART " _IBP_" ent ry #"_+IBB DA_" added  to Insura nce Buffer  File."
  5873   "RTN","IBC NSMM1",91, 0)
  5874    I 'IBBDA  W !,*7,?3, "Warning:  Could not  add new po licy Part  "_IBP_" in  Buffer Fi le.",!,?13 ,"("_$P(IB BDA,U,2)_" )",!
  5875   "RTN","IBC NSMM1",92, 0)
  5876    Q
  5877   "RTN","IBC NSMM1",93, 0)
  5878    ;
  5879   "RTN","IBC NSMM1",94, 0)
  5880   OK ; -- as k okay
  5881   "RTN","IBC NSMM1",95, 0)
  5882    N DTOUT,D IROUT,DIRU T,DUOUT,X, Y
  5883   "RTN","IBC NSMM1",96, 0)
  5884    ; Returns :
  5885   "RTN","IBC NSMM1",97, 0)
  5886    ; IBQUIT= 1 Exit use r timedout
  5887   "RTN","IBC NSMM1",98, 0)
  5888    ;   IBOK= 1 Yes
  5889   "RTN","IBC NSMM1",99, 0)
  5890    ;   IBOK= 0 No
  5891   "RTN","IBC NSMM1",100 ,0)
  5892    S IBQUIT= 0,DIR(0)=" Y",DIR("B" )="YES" W  !
  5893   "RTN","IBC NSMM1",101 ,0)
  5894    I $G(DIR( "A"))="" S  DIR("A")= "Is this D ata Correc t"
  5895   "RTN","IBC NSMM1",102 ,0)
  5896    I $G(DIR( "?"))="" S  DIR("?")= "Enter 'No ' to edit  Medicare C ard inform ation"
  5897   "RTN","IBC NSMM1",103 ,0)
  5898    D ^DIR K  DIR
  5899   "RTN","IBC NSMM1",104 ,0)
  5900    I $D(DTOU T) S IBQUI T=1
  5901   "RTN","IBC NSMM1",105 ,0)
  5902    S IBOK=$G (Y) I IBOK ["^" S IBQ UIT=1
  5903   "RTN","IBC NSMM1",106 ,0)
  5904    Q
  5905   "RTN","IBC NSMM1",107 ,0)
  5906    ;
  5907   "RTN","IBC NSMM1",108 ,0)
  5908   GETWNR() ;  -- Find a nd return  the MEDICA RE (WNR) i en
  5909   "RTN","IBC NSMM1",109 ,0)
  5910    ;          -- Return s Error me ssage or
  5911   "RTN","IBC NSMM1",110 ,0)
  5912    ;             DIC(36  IEN ^"MED ICARE (WNR )"^IBA(355 .3 PART A  IEN ^"PART  A"^ IBA(3 55.3 PART  B IEN ^"PA RT B"
  5913   "RTN","IBC NSMM1",111 ,0)
  5914    ;
  5915   "RTN","IBC NSMM1",112 ,0)
  5916    N IBWNR,I B0,IBP0,IB Q,IBPQ,IBP X,IBX,IBY, IBPGN
  5917   "RTN","IBC NSMM1",113 ,0)
  5918    S IBY="ME DICARE (WN R)",IBQ=0
  5919   "RTN","IBC NSMM1",114 ,0)
  5920    S IBX=0 F   S IBX=$O (^DIC(36," B",IBY,IBX )) Q:('IBX )  D  Q:IB Q
  5921   "RTN","IBC NSMM1",115 ,0)
  5922    .S IB0=$G (^DIC(36,I BX,0))
  5923   "RTN","IBC NSMM1",116 ,0)
  5924    .K IBWNR( "INS")
  5925   "RTN","IBC NSMM1",117 ,0)
  5926    .I $P(IB0 ,U,1)'=IBY  Q  ;name
  5927   "RTN","IBC NSMM1",118 ,0)
  5928    .I $P(IB0 ,U,2)'="N"  Q  ;Reimb ?
  5929   "RTN","IBC NSMM1",119 ,0)
  5930    .;I '$P(I B0,U,3) Q   ;Sig Req.   --> remo ved edit,  cm, 5/18/9 9
  5931   "RTN","IBC NSMM1",120 ,0)
  5932    .I $P(IB0 ,U,5) Q  ; Inactive
  5933   "RTN","IBC NSMM1",121 ,0)
  5934    .I $P($G( ^IBE(355.2 ,+$P(IB0,U ,13),0)),U )'="MEDICA RE" Q  ;Ma jor Cat.
  5935   "RTN","IBC NSMM1",122 ,0)
  5936    .S IBWNR( "INS")=IBX _U_IBY
  5937   "RTN","IBC NSMM1",123 ,0)
  5938    .;
  5939   "RTN","IBC NSMM1",124 ,0)
  5940    .; -- Mus t have Act ive Group  Plan Categ ory Medica re Part A  and B
  5941   "RTN","IBC NSMM1",125 ,0)
  5942    .;
  5943   "RTN","IBC NSMM1",126 ,0)
  5944    .K IBWNR( "A"),IBWNR ("B")
  5945   "RTN","IBC NSMM1",127 ,0)
  5946    .S IBPX=0  F  S IBPX =$O(^IBA(3 55.3,"B",I BX,IBPX))  Q:('IBPX)! (IBQ)  D
  5947   "RTN","IBC NSMM1",128 ,0)
  5948    ..S IBP0= $G(^IBA(35 5.3,IBPX,0 ))
  5949   "RTN","IBC NSMM1",129 ,0)
  5950    ..I $P(IB P0,U,11) Q   ;Inactiv e
  5951   "RTN","IBC NSMM1",130 ,0)
  5952    ..I $P(IB P0,U,14)'= "A",$P(IBP 0,U,14)'=" B" Q  ;Not  Plan Cate gory Part  A or B 
  5953   "RTN","IBC NSMM1",131 ,0)
  5954    ..S IBPGN =$TR($P(IB P0,U,3),"a bcdefghijk lmnopqrstu vwxyz","AB CDEFGHIJKL MNOPQRSTUV WXYZ")
  5955   "RTN","IBC NSMM1",132 ,0)
  5956    ..I IBPGN '="PART A" ,IBPGN'="P ART B" Q   ;excludes  non PART A  and PART  B plans
  5957   "RTN","IBC NSMM1",133 ,0)
  5958    ..S IBWNR ($P(IBP0,U ,14))=IBPX _U_$P(IBP0 ,U,3)
  5959   "RTN","IBC NSMM1",134 ,0)
  5960    ..I $G(IB WNR("A")), $G(IBWNR(" B")) S IBQ =1
  5961   "RTN","IBC NSMM1",135 ,0)
  5962    ;
  5963   "RTN","IBC NSMM1",136 ,0)
  5964    S IBX=$G( IBWNR("INS "))_U_$G(I BWNR("A")) _U_$G(IBWN R("B"))
  5965   "RTN","IBC NSMM1",137 ,0)
  5966    I 'IBX S  IBX="Error : Standard  Medicare  (WNR) Insu rance Comp any not se tup proper ly." G GET WNRQ
  5967   "RTN","IBC NSMM1",138 ,0)
  5968    I '$P(IBX ,U,3) S IB X="Error:  Standard M edicare (W NR) plan P ART A not  setup prop erly." G G ETWNRQ
  5969   "RTN","IBC NSMM1",139 ,0)
  5970    I '$G(IBW NR("B")) S  IBX="Erro r: Standar d Medicare  (WNR) pla n PART B n ot setup p roperly."
  5971   "RTN","IBC NSMM1",140 ,0)
  5972   GETWNRQ Q  IBX
  5973   "RTN","IBC NSMM2")
  5974   0^14^B1523 4233^B1687 1457
  5975   "RTN","IBC NSMM2",1,0 )
  5976   IBCNSMM2 ; ALB/CMS -M EDICARE IN SURANCE IN TAKE (CONT ) ; 18-MAY -99
  5977   "RTN","IBC NSMM2",2,0 )
  5978    ;;2.0;INT EGRATED BI LLING;**10 3,133,602* *;21-MAR-9 4;Build 22
  5979   "RTN","IBC NSMM2",3,0 )
  5980    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  5981   "RTN","IBC NSMM2",4,0 )
  5982    Q
  5983   "RTN","IBC NSMM2",5,0 )
  5984    ;
  5985   "RTN","IBC NSMM2",6,0 )
  5986    ;
  5987   "RTN","IBC NSMM2",7,0 )
  5988   MII ; -- A sk Medicar e Insuranc e Card que stions
  5989   "RTN","IBC NSMM2",8,0 )
  5990    ;  
  5991   "RTN","IBC NSMM2",9,0 )
  5992    ;  Output  Variables :
  5993   "RTN","IBC NSMM2",10, 0)
  5994    ;  IBNAME  = Name of  Insured
  5995   "RTN","IBC NSMM2",11, 0)
  5996    ;  IBHICN  = Subscri ber ID as  of IB*601  could also  be a MBI  Number
  5997   "RTN","IBC NSMM2",12, 0)
  5998    ;  IBAEFF  = Effecti ve Date fo r Part A
  5999   "RTN","IBC NSMM2",13, 0)
  6000    ;  IBBEFF  = Effecti ve Date fo r Part B
  6001   "RTN","IBC NSMM2",14, 0)
  6002    ;  IBCOB/ IBCOBI = C oordinatio n of Benef its
  6003   "RTN","IBC NSMM2",15, 0)
  6004    ;  IBQUIT =1 User ti med-out or  entered ^
  6005   "RTN","IBC NSMM2",16, 0)
  6006    ;
  6007   "RTN","IBC NSMM2",17, 0)
  6008    N DIR,DTO UT,DUOUT,D IROUT,DIRU T,X,Y,IBX
  6009   "RTN","IBC NSMM2",18, 0)
  6010    ;
  6011   "RTN","IBC NSMM2",19, 0)
  6012   MIIA ; --  Ask user f or Informa tion
  6013   "RTN","IBC NSMM2",20, 0)
  6014    ;
  6015   "RTN","IBC NSMM2",21, 0)
  6016    W ! S DIR ("A")="NAM E OF BENEF ICIARY"
  6017   "RTN","IBC NSMM2",22, 0)
  6018    S IBX=$P( $G(IBARR(" A",1)),"^" ,18) I IBX ="" S IBX= $P($G(IBAR R("B",1)), "^",18)
  6019   "RTN","IBC NSMM2",23, 0)
  6020    S DIR("B" )=$S($G(IB NAME)'="": IBNAME,IBX '="":IBX,1 :$P(^DPT(D FN,0),U))
  6021   "RTN","IBC NSMM2",24, 0)
  6022    S DIR(0)= "F^3:30^K: X'?1E.E1"" ,"".1E.E X "
  6023   "RTN","IBC NSMM2",25, 0)
  6024    S DIR("?" )="Enter t he Name of  Beneficia ry (Last n ame, First ) from the  Medicare  Insurance  Card.  Thi s name sho uld be 3 t o 30 chara cters in l ength."
  6025   "RTN","IBC NSMM2",26, 0)
  6026    D ^DIR K  DIR
  6027   "RTN","IBC NSMM2",27, 0)
  6028    I $D(DTOU T)!$D(DUOU T) K DUOUT ,DTOUT,DIR OUT,DIRUT  S IBQUIT=1  G MIIQ
  6029   "RTN","IBC NSMM2",28, 0)
  6030    S IBNAME= Y
  6031   "RTN","IBC NSMM2",29, 0)
  6032    ;
  6033   "RTN","IBC NSMM2",30, 0)
  6034    S DIR("A" )="MEDICAR E CLAIM NU MBER"
  6035   "RTN","IBC NSMM2",31, 0)
  6036    S IBX=$P( $G(IBARR(" A",1)),"^" ,3) I IBX= "" S IBX=$ P($G(IBARR ("B",1))," ^",3)
  6037   "RTN","IBC NSMM2",32, 0)
  6038    I $G(IBHI CN)'="" S  DIR("B")=I BHICN
  6039   "RTN","IBC NSMM2",33, 0)
  6040    I IBX'="" ,'$D(DIR(" B")) S DIR ("B")=IBX
  6041   "RTN","IBC NSMM2",34, 0)
  6042    ;S DIR(0) ="F^7:15^I  '$$VALHIC ^IBCNSMM($ TR(X,""-"" )) K X" ;  IB*602
  6043   "RTN","IBC NSMM2",35, 0)
  6044    S DIR(0)= "F^3:20" ; IB*602
  6045   "RTN","IBC NSMM2",36, 0)
  6046    S DIR("?" )="^D HICH ^IBCNSMM2"
  6047   "RTN","IBC NSMM2",37, 0)
  6048    D ^DIR K  DIR
  6049   "RTN","IBC NSMM2",38, 0)
  6050    I $D(DTOU T)!$D(DUOU T) K DUOUT ,DTOUT,DIR OUT,DIRUT  S IBQUIT=1  G MIIQ
  6051   "RTN","IBC NSMM2",39, 0)
  6052    S IBHICN= $TR(Y,"-")  ; Strip o ff any '-'
  6053   "RTN","IBC NSMM2",40, 0)
  6054    ;
  6055   "RTN","IBC NSMM2",41, 0)
  6056    ; - don't  allow edi ting Part  A date if  more than  one policy
  6057   "RTN","IBC NSMM2",42, 0)
  6058    I IBPOLA, '$D(IBARR( "A",1)) G  MIIPB
  6059   "RTN","IBC NSMM2",43, 0)
  6060    S DIR("A" )="HOSPITA L INSURANC E (PART A)  EFFECTIVE  DATE"
  6061   "RTN","IBC NSMM2",44, 0)
  6062    S IBX=$P( $G(IBARR(" A",1)),"^" ,9)
  6063   "RTN","IBC NSMM2",45, 0)
  6064    I $G(IBAE FF) S Y=IB AEFF D D^D IQ S DIR(" B")=Y
  6065   "RTN","IBC NSMM2",46, 0)
  6066    I IBX'="" ,'$D(DIR(" B")) S Y=I BX D D^DIQ  S DIR("B" )=Y
  6067   "RTN","IBC NSMM2",47, 0)
  6068    S DIR(0)= "DO^::E"
  6069   "RTN","IBC NSMM2",48, 0)
  6070    S DIR("?" )="Enter P ART A Effe ctive Date  if shown  on Medicar e Insuranc e Card."
  6071   "RTN","IBC NSMM2",49, 0)
  6072    D ^DIR K  DIR
  6073   "RTN","IBC NSMM2",50, 0)
  6074    I $D(DTOU T)!$D(DUOU T) K DUOUT ,DTOUT,DIR OUT,DIRUT  S IBQUIT=1  G MIIQ
  6075   "RTN","IBC NSMM2",51, 0)
  6076    S IBAEFF= Y
  6077   "RTN","IBC NSMM2",52, 0)
  6078    ;
  6079   "RTN","IBC NSMM2",53, 0)
  6080   MIIPB ; -  don't allo w editing  Part B dat e if more  than one p olicy
  6081   "RTN","IBC NSMM2",54, 0)
  6082    I IBPOLB, '$D(IBARR( "B",1)) G  MIIC
  6083   "RTN","IBC NSMM2",55, 0)
  6084    S DIR("A" )="MEDICAL  INSURANCE  (PART B)  EFFECTIVE  DATE"
  6085   "RTN","IBC NSMM2",56, 0)
  6086    S IBX=$P( $G(IBARR(" B",1)),"^" ,9)
  6087   "RTN","IBC NSMM2",57, 0)
  6088    I $G(IBBE FF) S Y=IB BEFF D D^D IQ S DIR(" B")=Y
  6089   "RTN","IBC NSMM2",58, 0)
  6090    I IBX'="" ,'$D(DIR(" B")) S Y=I BX D D^DIQ  S DIR("B" )=Y
  6091   "RTN","IBC NSMM2",59, 0)
  6092    S DIR(0)= "DO^::E"
  6093   "RTN","IBC NSMM2",60, 0)
  6094    S DIR("?" )="Enter P ART B Effe ctive Date  if shown  on Medicar e Insuranc e Card."
  6095   "RTN","IBC NSMM2",61, 0)
  6096    D ^DIR K  DIR
  6097   "RTN","IBC NSMM2",62, 0)
  6098    I $D(DTOU T)!$D(DUOU T) K DUOUT ,DTOUT,DIR OUT,DIRUT  S IBQUIT=1  G MIIQ
  6099   "RTN","IBC NSMM2",63, 0)
  6100    S IBBEFF= Y
  6101   "RTN","IBC NSMM2",64, 0)
  6102    ;
  6103   "RTN","IBC NSMM2",65, 0)
  6104   MIIC ; - c heck effec tive dates  before CO B prompt
  6105   "RTN","IBC NSMM2",66, 0)
  6106    I '$G(IBA EFF),'$G(I BBEFF) S I BQUIT=1 D   G MIIQ
  6107   "RTN","IBC NSMM2",67, 0)
  6108    .W !!,*7, ?5,"No dat a can be f iled witho ut Part A  or B Effec tive Dates ."
  6109   "RTN","IBC NSMM2",68, 0)
  6110    ;
  6111   "RTN","IBC NSMM2",69, 0)
  6112    ; - Coord ination of  Benefits  prompt
  6113   "RTN","IBC NSMM2",70, 0)
  6114    S DIR("A" )="COORDIN ATION OF B ENEFITS: "
  6115   "RTN","IBC NSMM2",71, 0)
  6116    S IBX=$P( $G(IBARR(" A",1)),"^" ,21) I 'IB X S IBX=$P ($G(IBARR( "B",1)),"^ ",21)
  6117   "RTN","IBC NSMM2",72, 0)
  6118    I IBX S I BX=$S(IBX= 1:"PRIMARY ",IBX=2:"S ECONDARY", 3:"TERTIAR Y",1:"")
  6119   "RTN","IBC NSMM2",73, 0)
  6120    S DIR("B" )=$S($G(IB COB)'="":I BCOB,IBX'= "":IBX,1:" PRIMARY")
  6121   "RTN","IBC NSMM2",74, 0)
  6122    S DIR(0)= "SA^1:PRIM ARY;2:SECO NDARY;3:TE RTIARY"
  6123   "RTN","IBC NSMM2",75, 0)
  6124    S DIR("?" )="Enter t he Coordin ation of B enefits as  Primary,  Secondary,  or Tertia ry."
  6125   "RTN","IBC NSMM2",76, 0)
  6126    D ^DIR K  DIR
  6127   "RTN","IBC NSMM2",77, 0)
  6128    I $D(DTOU T)!$D(DUOU T) K DUOUT ,DTOUT,DIR OUT,DIRUT  S IBQUIT=1  G MIIQ
  6129   "RTN","IBC NSMM2",78, 0)
  6130    S IBCOBI= Y,IBCOB=$S (Y=3:"TERT IARY",Y=2: "SECONDARY ",1:"PRIMA RY")
  6131   "RTN","IBC NSMM2",79, 0)
  6132    ;
  6133   "RTN","IBC NSMM2",80, 0)
  6134    ; -- Ask  if Data Ok ay
  6135   "RTN","IBC NSMM2",81, 0)
  6136    S IBOK=0  K DIR D OK ^IBCNSMM1  I IBOK=0 K  DIR,Y G M IIA
  6137   "RTN","IBC NSMM2",82, 0)
  6138    I IBOK["^ " S IBQUIT =1
  6139   "RTN","IBC NSMM2",83, 0)
  6140   MIIQ Q
  6141   "RTN","IBC NSMM2",84, 0)
  6142    ;
  6143   "RTN","IBC NSMM2",85, 0)
  6144    ;
  6145   "RTN","IBC NSMM2",86, 0)
  6146   HICH ; Hel p text for  the HIC n umber prom pt.
  6147   "RTN","IBC NSMM2",87, 0)
  6148    W !,"Ente r the Medi care Claim  Number (S ubscriber  ID) exactl y as it ap pears" ; I B*602
  6149   "RTN","IBC NSMM2",88, 0)
  6150    W !,"on t he Medicar e Insuranc e Card, ex cluding sp ecial char acters."
  6151   "RTN","IBC NSMM2",89, 0)
  6152    W !,"Entr y must be  3-20 chara cters."
  6153   "RTN","IBC NSMM2",90, 0)
  6154    Q
  6155   "RTN","IBC NSP")
  6156   0^6^B77777 224^B77034 837
  6157   "RTN","IBC NSP",1,0)
  6158   IBCNSP ;AL B/AAS - IN SURANCE MA NAGEMENT -  EXPANDED  POLICY ;05 -MAR-1993
  6159   "RTN","IBC NSP",2,0)
  6160    ;;2.0;INT EGRATED BI LLING;**6, 28,43,52,8 5,251,363, 371,416,49 7,516,528, 549,602**; 21-MAR-94; Build 22
  6161   "RTN","IBC NSP",3,0)
  6162    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6163   "RTN","IBC NSP",4,0)
  6164   % ;
  6165   "RTN","IBC NSP",5,0)
  6166   EN ; -- ma in entry p oint for I BCNS EXPAN DED POLICY
  6167   "RTN","IBC NSP",6,0)
  6168    N IB1ST
  6169   "RTN","IBC NSP",7,0)
  6170    K VALMQUI T,IBPPOL,I BTOP
  6171   "RTN","IBC NSP",8,0)
  6172    S IBTOP=" IBCNSP"
  6173   "RTN","IBC NSP",9,0)
  6174    D EN^VALM ("IBCNS EX PANDED POL ICY")
  6175   "RTN","IBC NSP",10,0)
  6176    Q
  6177   "RTN","IBC NSP",11,0)
  6178    ;
  6179   "RTN","IBC NSP",12,0)
  6180   HDR ; -- h eader code
  6181   "RTN","IBC NSP",13,0)
  6182    N DOD,IBD OB,IBNAME, W,X,Y,Z                   ; IB*2 .0*549 Add ed DOD
  6183   "RTN","IBC NSP",14,0)
  6184    S IBNAME= ^DPT(DFN,0 )                         ; Dire ct global  read on fi le 2 suppo rted by IA  10035
  6185   "RTN","IBC NSP",15,0)
  6186    S IBDOB=$ P(IBNAME," ^",3)
  6187   "RTN","IBC NSP",16,0)
  6188    S IBNAME= $E($P(IBNA ME,U),1,20 )
  6189   "RTN","IBC NSP",17,0)
  6190    ;
  6191   "RTN","IBC NSP",18,0)
  6192    ; IB*2.0* 549 Shorte ned 'Expan ded Policy  Informati on For ' t o 'For: '  below
  6193   "RTN","IBC NSP",19,0)
  6194    S VALMHDR (1)="For:  "_IBNAME_"   "_$P($$P T^IBEFUNC( DFN),U,2)_ "  "_$$FMT E^XLFDT(IB DOB,"5DZ")
  6195   "RTN","IBC NSP",20,0)
  6196    ;
  6197   "RTN","IBC NSP",21,0)
  6198    ; IB*2.0* 549 Added  next 4 lin es
  6199   "RTN","IBC NSP",22,0)
  6200    S DOD=$$G ET1^DIQ(2, DFN_",",.3 51,"I")
  6201   "RTN","IBC NSP",23,0)
  6202    I DOD'=""  D
  6203   "RTN","IBC NSP",24,0)
  6204    . S DOD=$ $FMTE^XLFD T(DOD,"5DZ ")
  6205   "RTN","IBC NSP",25,0)
  6206    . ;IB*2.0 *602/DM di splay DoD  properly w ith long p atient nam e
  6207   "RTN","IBC NSP",26,0)
  6208    . S VALMH DR(1)=VALM HDR(1)_"    DoD: "_DO D
  6209   "RTN","IBC NSP",27,0)
  6210    S Z=$G(^D PT(DFN,.31 2,+$P(IBPP OL,U,4),0) )
  6211   "RTN","IBC NSP",28,0)
  6212    S W=$P($G (^IBA(355. 3,+$P(Z,U, 18),0)),U, 11)
  6213   "RTN","IBC NSP",29,0)
  6214    S Y=$E($P ($G(^DIC(3 6,+Z,0)),U ),1,20)_"  Insurance  Company"
  6215   "RTN","IBC NSP",30,0)
  6216    S X="** P lan Curren tly "_$S(W :"Ina",1:" A")_"ctive  **"
  6217   "RTN","IBC NSP",31,0)
  6218    S VALMHDR (2)=$$SETS TR^VALM1(X ,Y,48,29)
  6219   "RTN","IBC NSP",32,0)
  6220    Q
  6221   "RTN","IBC NSP",33,0)
  6222    ;
  6223   "RTN","IBC NSP",34,0)
  6224   INIT ; --  init varia bles and l ist array
  6225   "RTN","IBC NSP",35,0)
  6226    K VALMQUI T
  6227   "RTN","IBC NSP",36,0)
  6228    S VALMCNT =0,VALMBG= 1
  6229   "RTN","IBC NSP",37,0)
  6230    I '$D(IBP POL) D PPO L Q:$D(VAL MQUIT)
  6231   "RTN","IBC NSP",38,0)
  6232    D BLD,HDR
  6233   "RTN","IBC NSP",39,0)
  6234    Q
  6235   "RTN","IBC NSP",40,0)
  6236    ;
  6237   "RTN","IBC NSP",41,0)
  6238   BLD ; -- l ist builde r
  6239   "RTN","IBC NSP",42,0)
  6240    K ^TMP("I BCNSVP",$J ),^TMP("IB CNSVPDX",$ J)
  6241   "RTN","IBC NSP",43,0)
  6242    D KILL^VA LM10()
  6243   "RTN","IBC NSP",44,0)
  6244    N IBCDFND ,IBCDFND1, IBCDFND2,I BCDFND4,IB CDFND5,IBC DFND7
  6245   "RTN","IBC NSP",45,0)
  6246    S IBCDFND =$G(^DPT(D FN,.312,$P (IBPPOL,U, 4),0)),IBC DFND1=$G(^ (1)),IBCDF ND2=$G(^(2 )),IBCDFND 4=$G(^(4)) ,IBCDFND5= $G(^(5)),I BCDFND7=$G (^(7))
  6247   "RTN","IBC NSP",46,0)
  6248    ; MRD;IB* 2.0*516 -  Use $$ZND^ IBCNS1 to  pull zero  node of 2. 312.
  6249   "RTN","IBC NSP",47,0)
  6250    S IBCDFND =$$ZND^IBC NS1(DFN,$P (IBPPOL,U, 4))
  6251   "RTN","IBC NSP",48,0)
  6252    S IBCPOL= +$P(IBCDFN D,U,18),IB CNS=+IBCDF ND,IBCDFN= $P(IBPPOL, U,4)
  6253   "RTN","IBC NSP",49,0)
  6254    S IBCPOLD =$G(^IBA(3 55.3,+$P(I BCDFND,U,1 8),0)),IBC POLD1=$G(^ (1))
  6255   "RTN","IBC NSP",50,0)
  6256    S IBCPOLD 2=$G(^IBA( 355.3,+$G( IBCPOL),6) ) ;; Daou/ EEN adding  BIN and P CN
  6257   "RTN","IBC NSP",51,0)
  6258    S IBCPOLD L=$G(^IBA( 355.3,+$G( IBCPOL),2) )  ;IB*2*4 97  new gr oup name a nd group n umber loca tions
  6259   "RTN","IBC NSP",52,0)
  6260    ;
  6261   "RTN","IBC NSP",53,0)
  6262    D INS^IBC NSP0                        ; in surance co mpany
  6263   "RTN","IBC NSP",54,0)
  6264    D POLICY^ IBCNSP0                     ; pl an informa tion
  6265   "RTN","IBC NSP",55,0)
  6266    D UR                                  ; ut ilization  review inf o
  6267   "RTN","IBC NSP",56,0)
  6268    D EFFECT                              ; ef fective da tes & sour ce of info
  6269   "RTN","IBC NSP",57,0)
  6270    D SUBSC^I BCNSP01                     ; su bscriber i nfo
  6271   "RTN","IBC NSP",58,0)
  6272    D EMP                                 ; su bscriber's  employer  info
  6273   "RTN","IBC NSP",59,0)
  6274    D PRV^IBC NSP01                       ; su bscriber's  provider  contact in fo ;IB*2*4 97
  6275   "RTN","IBC NSP",60,0)
  6276    D SPON^IB CNSP0                       ; in sured pers on's info
  6277   "RTN","IBC NSP",61,0)
  6278    D ID^IBCN SP01                        ; in s co ID nu mbers (IB* 2*371)
  6279   "RTN","IBC NSP",62,0)
  6280    D PLIM                                ; pl an coverag e limitati ons
  6281   "RTN","IBC NSP",63,0)
  6282    D VER^IBC NSP01                       ; us er/verifie r/editor i nfo
  6283   "RTN","IBC NSP",64,0)
  6284    ;
  6285   "RTN","IBC NSP",65,0)
  6286    ;IB*2.0*5 49 Removed  next line
  6287   "RTN","IBC NSP",66,0)
  6288    ;D CONTAC T^IBCNSP0                    ; l ast insura nce contac t
  6289   "RTN","IBC NSP",67,0)
  6290    D COMMENT                             ; co mments - p olicy & pl an
  6291   "RTN","IBC NSP",68,0)
  6292    D RIDER^I BCNSP01                     ; po licy rider  info
  6293   "RTN","IBC NSP",69,0)
  6294    ;
  6295   "RTN","IBC NSP",70,0)
  6296    S VALMCNT =+$O(^TMP( "IBCNSVP", $J,""),-1)
  6297   "RTN","IBC NSP",71,0)
  6298    Q
  6299   "RTN","IBC NSP",72,0)
  6300    ;
  6301   "RTN","IBC NSP",73,0)
  6302   COMMENT ;  -- Comment  region
  6303   "RTN","IBC NSP",74,0)
  6304    ; Input:    DFN                   - IEN of  the curre ntly selec ted patien t
  6305   "RTN","IBC NSP",75,0)
  6306    ;           IBCPOL                -
  6307   "RTN","IBC NSP",76,0)
  6308    ;           IBPPOL                - O node  of the se lected Pat ient Polic y
  6309   "RTN","IBC NSP",77,0)
  6310    ;           ^TMP("IB CNSVP",$J)   - Curren t global A rray of di splay line s
  6311   "RTN","IBC NSP",78,0)
  6312    ; Output:   IB1ST("C OMMENT")     - 1st li ne of comm ents displ ay
  6313   "RTN","IBC NSP",79,0)
  6314    ;           ^TMP("IB CNSVP",$J)   - Update d global A rray of di splay line s
  6315   "RTN","IBC NSP",80,0)
  6316    ;
  6317   "RTN","IBC NSP",81,0)
  6318    ;IB*2.0*5 49 Moved G roup Plan  Comment ab ove Patien t Policy C omment. Ch anged
  6319   "RTN","IBC NSP",82,0)
  6320    ;            Patient  Policy Co mment to d isplay the  two most  recent com ments
  6321   "RTN","IBC NSP",83,0)
  6322    ;            in the  patient po licy comme nt multipl e (2.342,1 .18)
  6323   "RTN","IBC NSP",84,0)
  6324    N COMDT,C OMIEN,COMC TR,COMSTOP ,IBI,IBIIE N,IBL,OFFS ET,XX
  6325   "RTN","IBC NSP",85,0)
  6326    S IBL=$O( ^TMP("IBCN SVP",$J,"" ),-1)+1,OF FSET=2
  6327   "RTN","IBC NSP",86,0)
  6328    S IB1ST(" COMMENT")= IBL
  6329   "RTN","IBC NSP",87,0)
  6330    ;
  6331   "RTN","IBC NSP",88,0)
  6332    ; Display  Group Pla n Comment 
  6333   "RTN","IBC NSP",89,0)
  6334    D SET(IBL ,OFFSET,"  Comment --  Group Pla n ",IORVON ,IORVOFF)
  6335   "RTN","IBC NSP",90,0)
  6336    S IBI=0
  6337   "RTN","IBC NSP",91,0)
  6338    F  S IBI= $O(^IBA(35 5.3,+IBCPO L,11,IBI))  Q:IBI<1   D
  6339   "RTN","IBC NSP",92,0)
  6340    . S IBL=I BL+1
  6341   "RTN","IBC NSP",93,0)
  6342    . D SET(I BL,OFFSET, " "_$E($G( ^IBA(355.3 ,+IBCPOL,1 1,IBI,0)), 1,80))
  6343   "RTN","IBC NSP",94,0)
  6344    S IBL=IBL +1
  6345   "RTN","IBC NSP",95,0)
  6346    D SET(IBL ,OFFSET,"  ")
  6347   "RTN","IBC NSP",96,0)
  6348    ;
  6349   "RTN","IBC NSP",97,0)
  6350    ; Display  Last two  Patient Po licy Comme nts
  6351   "RTN","IBC NSP",98,0)
  6352    S IBIIEN= $P(IBPPOL, "^",4),IBL =IBL+1
  6353   "RTN","IBC NSP",99,0)
  6354    D SET(IBL ,OFFSET,"  Comment --  Patient P olicy ",IO RVON,IORVO FF)
  6355   "RTN","IBC NSP",100,0 )
  6356    S IBL=IBL +1,XX=" Dt  Entered   Entered By                  Meth od     Per son Contac ted"
  6357   "RTN","IBC NSP",101,0 )
  6358    S XX=XX_$ J("",78-$L (XX))
  6359   "RTN","IBC NSP",102,0 )
  6360    D SET(IBL ,OFFSET,XX ,IOUON,IOU OFF)
  6361   "RTN","IBC NSP",103,0 )
  6362    S COMDT=" ",(COMCTR, COMSTOP)=0
  6363   "RTN","IBC NSP",104,0 )
  6364    F  D  Q:( COMDT="")! COMSTOP
  6365   "RTN","IBC NSP",105,0 )
  6366    . S COMDT =$O(^DPT(D FN,.312,IB IIEN,13,"B ",COMDT),- 1)
  6367   "RTN","IBC NSP",106,0 )
  6368    . Q:COMDT =""
  6369   "RTN","IBC NSP",107,0 )
  6370    . S COMIE N=""
  6371   "RTN","IBC NSP",108,0 )
  6372    . F  D  Q :(COMIEN=" ")!COMSTOP
  6373   "RTN","IBC NSP",109,0 )
  6374    . . S COM IEN=$O(^DP T(DFN,.312 ,IBIIEN,13 ,"B",COMDT ,COMIEN),- 1)
  6375   "RTN","IBC NSP",110,0 )
  6376    . . Q:COM IEN=""
  6377   "RTN","IBC NSP",111,0 )
  6378    . . S COM CTR=COMCTR +1
  6379   "RTN","IBC NSP",112,0 )
  6380    . . I COM CTR>2 S CO MSTOP=1 Q
  6381   "RTN","IBC NSP",113,0 )
  6382    . . I COM CTR=2 D
  6383   "RTN","IBC NSP",114,0 )
  6384    . . . S I BL=IBL+1
  6385   "RTN","IBC NSP",115,0 )
  6386    . . . D S ET(IBL,OFF SET," ")
  6387   "RTN","IBC NSP",116,0 )
  6388    . . D DIS PPPC(.IBL, DFN,IBIIEN ,COMIEN)           ;  Display Pa tient Poli cy Comment
  6389   "RTN","IBC NSP",117,0 )
  6390    ;
  6391   "RTN","IBC NSP",118,0 )
  6392    ; Add two  blank lin es at end
  6393   "RTN","IBC NSP",119,0 )
  6394    S IBL=IBL +1
  6395   "RTN","IBC NSP",120,0 )
  6396    D SET(IBL ,OFFSET,"  ")
  6397   "RTN","IBC NSP",121,0 )
  6398    S IBL=IBL +1
  6399   "RTN","IBC NSP",122,0 )
  6400    D SET(IBL ,OFFSET,"  ")
  6401   "RTN","IBC NSP",123,0 )
  6402    Q
  6403   "RTN","IBC NSP",124,0 )
  6404    ;
  6405   "RTN","IBC NSP",125,0 )
  6406   DISPPPC(IB L,DFN,IBII EN,COMIEN)  ; Display  one Patie nt Policy  Comment
  6407   "RTN","IBC NSP",126,0 )
  6408    ;IB*2.0*5 49 - Added  sub-routi ne
  6409   "RTN","IBC NSP",127,0 )
  6410    ; Input:    IBL                   - Curren t Display  Line Count er
  6411   "RTN","IBC NSP",128,0 )
  6412    ;           DFN                   - IEN of  the curre ntly selec ted patien t
  6413   "RTN","IBC NSP",129,0 )
  6414    ;           IBIIEN                - ^DPT(D FN,.312,IB IIEN,0) Wh ere IBIIEN  is the
  6415   "RTN","IBC NSP",130,0 )
  6416    ;                                   multip le IEN of  the select ed patient  policy
  6417   "RTN","IBC NSP",131,0 )
  6418    ;           COMIEN                - ^DPT(D FN,.312,IB IIEN,13,CO MIEN,0) Wh ere 
  6419   "RTN","IBC NSP",132,0 )
  6420    ;                                   COMIEN  is the mu ltiple IEN  of the se lected
  6421   "RTN","IBC NSP",133,0 )
  6422    ;                                   Patien t Policy C omment
  6423   "RTN","IBC NSP",134,0 )
  6424    ;           ^TMP("IB CNSVP",$J)   - Curren t global A rray of di splay line s
  6425   "RTN","IBC NSP",135,0 )
  6426    ; Output:   IBL                   - Update d Display  Line Count er
  6427   "RTN","IBC NSP",136,0 )
  6428    ;           ^TMP("IB CNSVP",$J)   - Update d global A rray of di splay line s
  6429   "RTN","IBC NSP",137,0 )
  6430    N COMDATA ,LINE,XX,Z Z
  6431   "RTN","IBC NSP",138,0 )
  6432    S COMDATA =$$GETONEC ^IBCNCH2(D FN,IBIIEN, COMIEN,0,7 7,0,1)
  6433   "RTN","IBC NSP",139,0 )
  6434    S LINE=$P (COMDATA," ^",1)_"     "
  6435   "RTN","IBC NSP",140,0 )
  6436    S XX=$P(C OMDATA,"^" ,2),ZZ=$J( "",26-$L(X X))
  6437   "RTN","IBC NSP",141,0 )
  6438    S LINE=LI NE_XX_ZZ
  6439   "RTN","IBC NSP",142,0 )
  6440    S XX=$P(C OMDATA,"^" ,4),ZZ=$J( "",11-$L(X X))
  6441   "RTN","IBC NSP",143,0 )
  6442    S LINE=LI NE_XX_ZZ_$ P(COMDATA, "^",3),IBL =IBL+1
  6443   "RTN","IBC NSP",144,0 )
  6444    D SET(IBL ,OFFSET,LI NE)
  6445   "RTN","IBC NSP",145,0 )
  6446    S IBL=IBL +1,LINE="  "_$P(COMDA TA,"^",8)
  6447   "RTN","IBC NSP",146,0 )
  6448    D SET(IBL ,OFFSET,LI NE)
  6449   "RTN","IBC NSP",147,0 )
  6450    Q
  6451   "RTN","IBC NSP",148,0 )
  6452    ;
  6453   "RTN","IBC NSP",149,0 )
  6454   EFFECT ; - - Effectiv e date reg ion
  6455   "RTN","IBC NSP",150,0 )
  6456    N START,O FFSET
  6457   "RTN","IBC NSP",151,0 )
  6458    S START=$ O(^TMP("IB CNSVP",$J, ""),-1)-6   ;ib*2*497  lines nee d to be di splayed al ongside UR  region
  6459   "RTN","IBC NSP",152,0 )
  6460    S OFFSET= 45
  6461   "RTN","IBC NSP",153,0 )
  6462    D SET(STA RT,OFFSET- 4," Effect ive Dates  & Source " ,IORVON,IO RVOFF)
  6463   "RTN","IBC NSP",154,0 )
  6464    D SET(STA RT+1,OFFSE T," Effect ive Date:  "_$$DAT1^I BOUTL($P(I BCDFND,U,8 )))
  6465   "RTN","IBC NSP",155,0 )
  6466    D SET(STA RT+2,OFFSE T,"Expirat ion Date:  "_$$DAT1^I BOUTL($P(I BCDFND,U,4 )))
  6467   "RTN","IBC NSP",156,0 )
  6468    D SET(STA RT+3,OFFSE T," Source  of Info:  "_$$EXPAND ^IBTRE(2.3 12,1.09,$P ($G(IBCDFN D1),U,9)))
  6469   "RTN","IBC NSP",157,0 )
  6470    ;
  6471   "RTN","IBC NSP",158,0 )
  6472    ;IB*2.0*5 49 Changed  OFFSET-4  to OFFSET- 8
  6473   "RTN","IBC NSP",159,0 )
  6474    ;            Changed  'Policy N ot Billabl e' to 'Sto p Policy F rom Billin g'
  6475   "RTN","IBC NSP",160,0 )
  6476    D SET(STA RT+4,OFFSE T-9,"Stop  Policy Fro m Billing:  "_$S($P($ G(^DPT(DFN ,.312,IBCD FN,3)),"^" ,4):"YES", 1:"NO"))
  6477   "RTN","IBC NSP",161,0 )
  6478    Q
  6479   "RTN","IBC NSP",162,0 )
  6480    ;
  6481   "RTN","IBC NSP",163,0 )
  6482   UR ; -- UR  of insura nce region
  6483   "RTN","IBC NSP",164,0 )
  6484    N START,O FFSET
  6485   "RTN","IBC NSP",165,0 )
  6486    S START=$ O(^TMP("IB CNSVP",$J, ""),-1)+1, OFFSET=2   ;IB*2*497
  6487   "RTN","IBC NSP",166,0 )
  6488    D SET(STA RT,OFFSET, " Utilizat ion Review  Info ",IO RVON,IORVO FF)
  6489   "RTN","IBC NSP",167,0 )
  6490    D SET(STA RT+1,OFFSE T,"          Require  UR: "_$$EX PAND^IBTRE (355.3,.05 ,$P(IBCPOL D,U,5)))
  6491   "RTN","IBC NSP",168,0 )
  6492    D SET(STA RT+2,OFFSE T,"   Requ ire Amb Ce rt: "_$$EX PAND^IBTRE (355.3,.12 ,$P(IBCPOL D,U,12)))
  6493   "RTN","IBC NSP",169,0 )
  6494    D SET(STA RT+3,OFFSE T,"   Requ ire Pre-Ce rt: "_$$EX PAND^IBTRE (355.3,.06 ,$P(IBCPOL D,U,6)))
  6495   "RTN","IBC NSP",170,0 )
  6496    D SET(STA RT+4,OFFSE T,"   Excl ude Pre-Co nd: "_$$EX PAND^IBTRE (355.3,.07 ,$P(IBCPOL D,U,7)))
  6497   "RTN","IBC NSP",171,0 )
  6498    D SET(STA RT+5,OFFSE T,"Benefit s Assignab le: "_$$EX PAND^IBTRE (355.3,.08 ,$P(IBCPOL D,U,8)))
  6499   "RTN","IBC NSP",172,0 )
  6500    D SET(STA RT+6,2," " )
  6501   "RTN","IBC NSP",173,0 )
  6502    Q
  6503   "RTN","IBC NSP",174,0 )
  6504   EMP ; -- I nsurance E mployer Re gion   
  6505   "RTN","IBC NSP",175,0 )
  6506    ; ib*2*49 7 move emp loyer line s around
  6507   "RTN","IBC NSP",176,0 )
  6508    N OFFSET, START,IBAD D,COL2
  6509   "RTN","IBC NSP",177,0 )
  6510    S START=$ O(^TMP("IB CNSVP",$J, ""),-1)+1, OFFSET=2
  6511   "RTN","IBC NSP",178,0 )
  6512    D SET(STA RT,OFFSET, " Subscrib er's Emplo yer Inform ation ",IO RVON,IORVO FF)
  6513   "RTN","IBC NSP",179,0 )
  6514    D SET(STA RT+1,OFFSE T,$$RJ^XLF STR(" Empl oyment Sta tus: ",20) _$$EXPAND^ IBTRE(2.31 2,2.11,$P( IBCDFND2,U ,11)))
  6515   "RTN","IBC NSP",180,0 )
  6516    S COL2=ST ART+1
  6517   "RTN","IBC NSP",181,0 )
  6518    D SET(STA RT+2,OFFSE T,$$RJ^XLF STR("Emplo yer: ",20) _$P(IBCDFN D2,U,9))
  6519   "RTN","IBC NSP",182,0 )
  6520    D SET(STA RT+3,OFFSE T,$$RJ^XLF STR("Stree t: ",20)_$ P(IBCDFND2 ,U,2)) S I BADD=1
  6521   "RTN","IBC NSP",183,0 )
  6522    I $P(IBCD FND2,U,3)' ="" D SET( START+4,OF FSET,$$RJ^ XLFSTR("St reet 2: ", 20)_$P(IBC DFND2,U,3) ) S IBADD= 2
  6523   "RTN","IBC NSP",184,0 )
  6524    I $P(IBCD FND2,U,4)' ="" D SET( START+5,OF FSET,$$RJ^ XLFSTR("St reet 3: ", 20)_$P(IBC DFND2,U,4) ) S IBADD= 3
  6525   "RTN","IBC NSP",185,0 )
  6526    D SET(STA RT+3+IBADD ,OFFSET,$$ RJ^XLFSTR( "City/Stat e: ",20)_$ E($P(IBCDF ND2,U,5),1 ,15)_$S($P (IBCDFND2, U,5)="":"" ,1:", ")_$ P($G(^DIC( 5,+$P(IBCD FND2,U,6), 0)),U,2)_"  "_$E($P(I BCDFND2,U, 7),1,5))
  6527   "RTN","IBC NSP",186,0 )
  6528    D SET(STA RT+4+IBADD ,OFFSET,$$ RJ^XLFSTR( "Phone: ", 20)_$P(IBC DFND2,U,8) )
  6529   "RTN","IBC NSP",187,0 )
  6530    D SET(STA RT+5+IBADD ,OFFSET,"  ")  ; ib*2 *497  only  1 blank l ine to end  the secti on
  6531   "RTN","IBC NSP",188,0 )
  6532    ;
  6533   "RTN","IBC NSP",189,0 )
  6534    S START=C OL2,OFFSET =40
  6535   "RTN","IBC NSP",190,0 )
  6536    D SET(STA RT,OFFSET, "Emp Spons ored Plan:  "_$S(+$P( IBCDFND2,U ,10):"Yes" ,1:"No"))
  6537   "RTN","IBC NSP",191,0 )
  6538    D SET(STA RT+1,OFFSE T,"Claims  to Employe r: "_$S(+I BCDFND2:"Y es, Send t o Employer ",1:"No, S end to Ins urance Com pany"))
  6539   "RTN","IBC NSP",192,0 )
  6540    D SET(STA RT+2,OFFSE T,"   Reti rement Dat e: "_$$DAT 1^IBOUTL($ P(IBCDFND2 ,U,12)))
  6541   "RTN","IBC NSP",193,0 )
  6542    ;
  6543   "RTN","IBC NSP",194,0 )
  6544   EMPQ Q
  6545   "RTN","IBC NSP",195,0 )
  6546    ;
  6547   "RTN","IBC NSP",196,0 )
  6548   PLIM ; pla n coverage  limitatio ns/plan li mitation c ategory di splay
  6549   "RTN","IBC NSP",197,0 )
  6550    N START,E ND S START =$O(^TMP(" IBCNSVP",$ J,""),-1)+ 1
  6551   "RTN","IBC NSP",198,0 )
  6552    S IB1ST(" PLIM")=STA RT
  6553   "RTN","IBC NSP",199,0 )
  6554    D LIMBLD^ IBCNSC41(S TART,2)
  6555   "RTN","IBC NSP",200,0 )
  6556    S END=$O( ^TMP("IBCN SVP",$J,"" ),-1)  ; l ast line c onstructed
  6557   "RTN","IBC NSP",201,0 )
  6558    D SET(END +1,2," ")     ; 2 bla nk lines t o end this  section
  6559   "RTN","IBC NSP",202,0 )
  6560    D SET(END +2,2," ")
  6561   "RTN","IBC NSP",203,0 )
  6562   PLIMX ;
  6563   "RTN","IBC NSP",204,0 )
  6564    Q
  6565   "RTN","IBC NSP",205,0 )
  6566    ; 
  6567   "RTN","IBC NSP",206,0 )
  6568   HELP ; --  help code
  6569   "RTN","IBC NSP",207,0 )
  6570    S X="?" D  DISP^XQOR M1 W !!
  6571   "RTN","IBC NSP",208,0 )
  6572    Q
  6573   "RTN","IBC NSP",209,0 )
  6574    ;
  6575   "RTN","IBC NSP",210,0 )
  6576   EXIT ; --  exit code
  6577   "RTN","IBC NSP",211,0 )
  6578    K IBPPOL, VALMQUIT,I BCNS,IBCDF N,IBCPOL,I BCPOLD,IBC POLD1,IBCP OLD2,IBCPO LDL,IBCDFN D,IBCDFND1 ,IBCDFND2, IBVPCLBG,I BVPCLEN
  6579   "RTN","IBC NSP",212,0 )
  6580    D CLEAN^V ALM10,CLEA R^VALM1
  6581   "RTN","IBC NSP",213,0 )
  6582    Q
  6583   "RTN","IBC NSP",214,0 )
  6584    ;
  6585   "RTN","IBC NSP",215,0 )
  6586   EXPND ; --  expand co de
  6587   "RTN","IBC NSP",216,0 )
  6588    Q
  6589   "RTN","IBC NSP",217,0 )
  6590    ;
  6591   "RTN","IBC NSP",218,0 )
  6592   PPOL ; --  select pat ient, sele ct policy
  6593   "RTN","IBC NSP",219,0 )
  6594    I '$D(DFN ) D  G:$D( VALMQUIT)  PPOLQ
  6595   "RTN","IBC NSP",220,0 )
  6596    .S DIC="^ DPT(",DIC( 0)="AEQMN"  D ^DIC
  6597   "RTN","IBC NSP",221,0 )
  6598    .S DFN=+Y
  6599   "RTN","IBC NSP",222,0 )
  6600    I $G(DFN) <1 S VALMQ UIT="" G P POLQ
  6601   "RTN","IBC NSP",223,0 )
  6602    ;
  6603   "RTN","IBC NSP",224,0 )
  6604    I '$O(^DP T(DFN,.312 ,0)) W !!, "Patient d oesn't hav e Insuranc e" K DFN G  PPOL
  6605   "RTN","IBC NSP",225,0 )
  6606    ;
  6607   "RTN","IBC NSP",226,0 )
  6608    S DIC="^D PT("_DFN_" ,.312,",DI C(0)="AEQM N",DIC("A" )="Select  Patient Po licy: "
  6609   "RTN","IBC NSP",227,0 )
  6610    D ^DIC I  +Y<1 S VAL MQUIT=""
  6611   "RTN","IBC NSP",228,0 )
  6612    G:$D(VALM QUIT) PPOL Q
  6613   "RTN","IBC NSP",229,0 )
  6614    S IBPPOL= "^2^"_DFN_ U_+Y_U_$G( ^DPT(DFN,. 312,+Y,0))
  6615   "RTN","IBC NSP",230,0 )
  6616   PPOLQ K DI C Q
  6617   "RTN","IBC NSP",231,0 )
  6618    ;
  6619   "RTN","IBC NSP",232,0 )
  6620   BLANK(LINE ) ; -- Bui ld blank l ine
  6621   "RTN","IBC NSP",233,0 )
  6622    D SET^VAL M10(.LINE, $J("",80))
  6623   "RTN","IBC NSP",234,0 )
  6624    Q
  6625   "RTN","IBC NSP",235,0 )
  6626    ;
  6627   "RTN","IBC NSP",236,0 )
  6628   SET(LINE,C OL,TEXT,ON ,OFF) ; --  set displ ay info in  array
  6629   "RTN","IBC NSP",237,0 )
  6630    I '$D(@VA LMAR@(LINE ,0)) D BLA NK(.LINE)  S VALMCNT= $G(VALMCNT )+1
  6631   "RTN","IBC NSP",238,0 )
  6632    D SET^VAL M10(.LINE, $$SETSTR^V ALM1(.TEXT ,@VALMAR@( LINE,0),.C OL,$L(TEXT )))
  6633   "RTN","IBC NSP",239,0 )
  6634    D:$G(ON)] ""!($G(OFF )]"") CNTR L^VALM10(. LINE,.COL, $L(TEXT),$ G(ON),$G(O FF))
  6635   "RTN","IBC NSP",240,0 )
  6636    W:'(LINE# 5) "."
  6637   "RTN","IBC NSP",241,0 )
  6638    Q
  6639   "RTN","IBC NSP",242,0 )
  6640    ;
  6641   "RTN","IBC NSUR")
  6642   0^7^B13141 8993^B2478 2605
  6643   "RTN","IBC NSUR",1,0)
  6644   IBCNSUR ;A LB/CPM/CMS  - MOVE SU BSCRIBERS  TO DIFFERE NT PLAN ;0 9-SEP-96
  6645   "RTN","IBC NSUR",2,0)
  6646    ;;2.0;INT EGRATED BI LLING;**10 3,276,506, 516,549,60 2**;21-MAR -94;Build  22
  6647   "RTN","IBC NSUR",3,0)
  6648    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  6649   "RTN","IBC NSUR",4,0)
  6650    Q
  6651   "RTN","IBC NSUR",5,0)
  6652    ;
  6653   "RTN","IBC NSUR",6,0)
  6654   EN ; Entry  point fro m option.  Main proce ssing loop .
  6655   "RTN","IBC NSUR",7,0)
  6656    I $S('($D (DUZ)#2):1 ,'$D(^VA(2 00,+DUZ,0) ):1,1:0) W  !!?3,"The  variable  DUZ must b e set to a n active u ser code b efore cont inuing." G  ENQ
  6657   "RTN","IBC NSUR",8,0)
  6658    W !!,?5," MOVE SUBSC RIBERS OF  ONE PLAN T O ANOTHER  PLAN"
  6659   "RTN","IBC NSUR",9,0)
  6660    W !,?5,"T his option  may be us ed to move  subscribe rs from a  selected P lan"
  6661   "RTN","IBC NSUR",10,0 )
  6662    W !,?5,"t o a differ ent Plan.  The plans  may be ass ociated wi th the sam e"
  6663   "RTN","IBC NSUR",11,0 )
  6664    W !,?5,"I nsurance C ompany or  a differen t one. Pla n and Annu al Benefit "
  6665   "RTN","IBC NSUR",12,0 )
  6666    W !,?5,"i nformation  may be mo ved as wel l. Users o f this opt ion should "
  6667   "RTN","IBC NSUR",13,0 )
  6668    W !,?5,"b e knowledg eable of t he VistA P atient Ins urance man agement op tions."
  6669   "RTN","IBC NSUR",14,0 )
  6670    W !
  6671   "RTN","IBC NSUR",15,0 )
  6672    W !,?5,"T his option  also give s the user  the optio n to expir e the old  plan or"
  6673   "RTN","IBC NSUR",16,0 )
  6674    W !,?5,"r eplace it  completely  in the pa tient insu rance prof ile.  The  reason"
  6675   "RTN","IBC NSUR",17,0 )
  6676    W !,?5,"t o expire t he old pla n is inten ded for us e when Ins urance gro ups change "
  6677   "RTN","IBC NSUR",18,0 )
  6678    W !,?5,"P BMs for pr ocessing e lectronic  Pharmacy c laims.  By  leaving t he old"
  6679   "RTN","IBC NSUR",19,0 )
  6680    W !,?5,"p lan inform ation inta ct (i.e. d o not repl ace), the  user will  be able"
  6681   "RTN","IBC NSUR",20,0 )
  6682    W !,?5,"t o monitor  PBM change s  that af fect the e lectronic  Pharmacy c laims."
  6683   "RTN","IBC NSUR",21,0 )
  6684    ;
  6685   "RTN","IBC NSUR",22,0 )
  6686    W !!,$TR( $J("",75), " ","-")
  6687   "RTN","IBC NSUR",23,0 )
  6688    S IBSTOP= 0 F  D PRO C^IBCNSUR1  Q:IBSTOP
  6689   "RTN","IBC NSUR",24,0 )
  6690   ENQ K IBST OP
  6691   "RTN","IBC NSUR",25,0 )
  6692    Q
  6693   "RTN","IBC NSUR",26,0 )
  6694    ;
  6695   "RTN","IBC NSUR",27,0 )
  6696   PROC ; - P rocess con tinuation  from IBCNS UR1. 
  6697   "RTN","IBC NSUR",28,0 )
  6698    ; - displ ay old pla n attribut es; allow  new plan t o be edite d
  6699   "RTN","IBC NSUR",29,0 )
  6700    D PL^IBCN SUR2
  6701   "RTN","IBC NSUR",30,0 )
  6702    R !!,?10, "Press any  key to co ntinue.     ",IBX:DTI ME
  6703   "RTN","IBC NSUR",31,0 )
  6704    ;
  6705   "RTN","IBC NSUR",32,0 )
  6706    ; - displ ay coverag e limitati ons; allow  add/edit  of plan 2  limitation s
  6707   "RTN","IBC NSUR",33,0 )
  6708    D LIM^IBC NSUR2
  6709   "RTN","IBC NSUR",34,0 )
  6710    ;
  6711   "RTN","IBC NSUR",35,0 )
  6712    I $P($G(^ IBA(355.3, IBP1,0))," ^",11) W ! !,"Please  note that  ",IBC1N,"' s",!,"plan , subscrib ers were m oved from,  is alread y inactive ." G PROCD P
  6713   "RTN","IBC NSUR",36,0 )
  6714    ;
  6715   "RTN","IBC NSUR",37,0 )
  6716    ; - does  the user w ish to ina ctivate th e old plan ?
  6717   "RTN","IBC NSUR",38,0 )
  6718    W !! S DI R(0)="Y",D IR("A")="D o you wish  to inacti vate "_IBC 1N_"'s pla n subscrib ers were m oved from"
  6719   "RTN","IBC NSUR",39,0 )
  6720    S DIR("?" )="If you  wish to in activate t he old pla n, enter ' Yes' - oth erwise, en ter 'No.'"
  6721   "RTN","IBC NSUR",40,0 )
  6722    D ^DIR K  DIR I 'Y W  !," <The  old plan i s still ac tive>" G P ROCQ
  6723   "RTN","IBC NSUR",41,0 )
  6724    ;
  6725   "RTN","IBC NSUR",42,0 )
  6726    D IRACT^I BCNSJ(IBP1 ,1) W !!," The plan h as been in activated. "
  6727   "RTN","IBC NSUR",43,0 )
  6728    ;
  6729   "RTN","IBC NSUR",44,0 )
  6730   PROCDP ; -  does the  user wish  to delete  the old pl an?
  6731   "RTN","IBC NSUR",45,0 )
  6732    W !! S DI R(0)="Y",D IR("A")="D o you wish  to delete  this plan "
  6733   "RTN","IBC NSUR",46,0 )
  6734    S DIR("?" )="If you  wish to de lete the o ld plan, e nter 'Yes'  - otherwi se, enter  'No.'"
  6735   "RTN","IBC NSUR",47,0 )
  6736    D ^DIR K  DIR I 'Y G  PROCQ
  6737   "RTN","IBC NSUR",48,0 )
  6738    ;
  6739   "RTN","IBC NSUR",49,0 )
  6740    D DEL^IBC NSJ(IBP1)  W !!,"The  plan has b een delete d."
  6741   "RTN","IBC NSUR",50,0 )
  6742    ;
  6743   "RTN","IBC NSUR",51,0 )
  6744   PROCQ Q
  6745   "RTN","IBC NSUR",52,0 )
  6746    ;
  6747   "RTN","IBC NSUR",53,0 )
  6748    ;
  6749   "RTN","IBC NSUR",54,0 )
  6750   SEL(IBNP)  ; Select a  company a nd plan.
  6751   "RTN","IBC NSUR",55,0 )
  6752    ;   Input :     IBNP   --  If s et to 1, a llows addi ng a new p lan and
  6753   "RTN","IBC NSUR",56,0 )
  6754    ;                      --  Scre en Inactiv e Companie s
  6755   "RTN","IBC NSUR",57,0 )
  6756    ;                      --  If s et to 0, m ust have a t least on e group pl an
  6757   "RTN","IBC NSUR",58,0 )
  6758    ;  Output :   IBCNS   --  Point er to sele cted compa ny in file  #36
  6759   "RTN","IBC NSUR",59,0 )
  6760    ;            IBPLAN   --  Point er to sele cted/added  plan in f ile #355.3
  6761   "RTN","IBC NSUR",60,0 )
  6762    ;            IBQUIT   --  Set t o 1 if the  user want s to quit.
  6763   "RTN","IBC NSUR",61,0 )
  6764    ;
  6765   "RTN","IBC NSUR",62,0 )
  6766    N X,Y K D IC,DIR
  6767   "RTN","IBC NSUR",63,0 )
  6768    S DIC(0)= "QEAMZ",DI C="^DIC(36 ,"
  6769   "RTN","IBC NSUR",64,0 )
  6770    I 'IBNP S  DIC("S")= "I $$ANYGP ^IBCNSJ(+Y ,0,1)"
  6771   "RTN","IBC NSUR",65,0 )
  6772    I IBNP S  DIC("S")=" I '$P($G(^ DIC(36,+Y, 0)),U,5)"
  6773   "RTN","IBC NSUR",66,0 )
  6774    S DIC("A" )="Select  INSURANCE  COMPANY: "
  6775   "RTN","IBC NSUR",67,0 )
  6776    D ^DIC K  DIC S IBCN S=+Y
  6777   "RTN","IBC NSUR",68,0 )
  6778    I Y<0 W "    <No Ins urance Com pany selec ted>" S IB QUIT=1 G S ELQ
  6779   "RTN","IBC NSUR",69,0 )
  6780    ;
  6781   "RTN","IBC NSUR",70,0 )
  6782    ; - if a  new plan m ay be adde d, allow a dding
  6783   "RTN","IBC NSUR",71,0 )
  6784    I IBNP D   I (IBPLAN )!(IBQUIT)  G SELQ
  6785   "RTN","IBC NSUR",72,0 )
  6786    .W !!,"Yo u may add  a new Plan  at this t ime or sel ect an exi sting Plan ."
  6787   "RTN","IBC NSUR",73,0 )
  6788    .; IB*2.0 *506 added  IBKEY par ameter (4t h) to the  NEW^IBCNSJ 3 call (ch eck user's  security  keys)
  6789   "RTN","IBC NSUR",74,0 )
  6790    .D NEW^IB CNSJ3(IBCN S,.IBPLAN, 1,1)
  6791   "RTN","IBC NSUR",75,0 )
  6792    .I 'IBPLA N,'$$ANYGP ^IBCNSJ(+I BCNS,0,1)  W !!,*7,"I nsurance C ompany rec eiving sub scribers m ust have a  Plan." S  IBQUIT=1
  6793   "RTN","IBC NSUR",76,0 )
  6794    ;
  6795   "RTN","IBC NSUR",77,0 )
  6796    ; - see i f user wan ts to sele ct the pla n
  6797   "RTN","IBC NSUR",78,0 )
  6798    W !!,"You  may selec t an exist ing Plan f rom a list  or enter  a specific  Plan.",!
  6799   "RTN","IBC NSUR",79,0 )
  6800    S DIR(0)= "Y",DIR("B ")="YES",D IR("A")="D o you wish  to enter  a specific  plan"
  6801   "RTN","IBC NSUR",80,0 )
  6802    S DIR("?" )="The loo k-up facil ity to sel ect a grou p plan has  been enha nced to us e the List  Manager.   Enter 'NO ' if you w ish to sel ect a plan  from this  look-up,  or 'YES' t o directly  enter a p lan."
  6803   "RTN","IBC NSUR",81,0 )
  6804    D ^DIR K  DIR I $D(D IRUT) S IB QUIT=1 G S ELQ
  6805   "RTN","IBC NSUR",82,0 )
  6806    ;
  6807   "RTN","IBC NSUR",83,0 )
  6808    ; - invok e the plan  look-up
  6809   "RTN","IBC NSUR",84,0 )
  6810    I 'Y D  G  SELQ
  6811   "RTN","IBC NSUR",85,0 )
  6812    . N IBTIT LE
  6813   "RTN","IBC NSUR",86,0 )
  6814    . S IBTIT LE="Group  Plan Looku p"
  6815   "RTN","IBC NSUR",87,0 )
  6816    . W "   . .."
  6817   "RTN","IBC NSUR",88,0 )
  6818    . S IBPLA N=0
  6819   "RTN","IBC NSUR",89,0 )
  6820    . D LKP^I BCNSU2(IBC NS,0,0,.IB PLAN,0,1,I BTITLE)
  6821   "RTN","IBC NSUR",90,0 )
  6822    . I 'IBPL AN W !!,*7 ,"*  No pl an selecte d!",! S IB QUIT=1
  6823   "RTN","IBC NSUR",91,0 )
  6824    ;
  6825   "RTN","IBC NSUR",92,0 )
  6826    ; - allow  a FileMan  look-up
  6827   "RTN","IBC NSUR",93,0 )
  6828    ; MRD;IB* 2.0*516 -  Display ne w Group Na me and Num ber fields .
  6829   "RTN","IBC NSUR",94,0 )
  6830    S DIC("A" )="Select  a GROUP PL AN: "
  6831   "RTN","IBC NSUR",95,0 )
  6832    S DIC="^I BA(355.3," ,DIC(0)="A EQM",DIC(" S")="I +^( 0)=IBCNS,$ P(^(0),U,2 )"
  6833   "RTN","IBC NSUR",96,0 )
  6834    ;S DIC("W ")="N IBX  S IBX=$G(^ (0)) W ""    Name: "" ,$E($S($P( IBX,U,3)]" """:$P(IBX ,U,3),1:"" <none>"")_ $J("""",20 ),1,20),""    Number:  "",$S($P( IBX,U,4)]" """:$P(IBX ,U,4),1:"" <none>"")"
  6835   "RTN","IBC NSUR",97,0 )
  6836    S DIC("W" )="N IBX S  IBX=$G(^( 2)) W ""    Name: "", $E($S($P(I BX,U,1)]"" "":$P(IBX, U,1),1:""< none>"")_$ J("""",20) ,1,20),""    Number:  "",$E($S($ P(IBX,U,2) ]"""":$P(I BX,U,2),1: ""<none>"" ),1,14)"
  6837   "RTN","IBC NSUR",98,0 )
  6838    D ^DIC K  DIC S IBPL AN=+Y
  6839   "RTN","IBC NSUR",99,0 )
  6840    I Y<0 W ! !,*7,"*  N o plan sel ected!",!  S IBQUIT=1
  6841   "RTN","IBC NSUR",100, 0)
  6842    ;
  6843   "RTN","IBC NSUR",101, 0)
  6844   SELQ K DIR UT,DUOUT,D TOUT,DIROU T
  6845   "RTN","IBC NSUR",102, 0)
  6846    Q
  6847   "RTN","IBC NSUR",103, 0)
  6848    ;
  6849   "RTN","IBC NSUR",104, 0)
  6850   EXPGRP ; E P for [IBC N EXPIRE G ROUP SUBSC RIBERS]
  6851   "RTN","IBC NSUR",105, 0)
  6852    ; IB*2.0* 602/DM imp lement exp ire group  plan 
  6853   "RTN","IBC NSUR",106, 0)
  6854    N X,Y,DIC ,DIR,DTA,E RR,REF,IBL N,XMDUZ,XM TEXT,XMSUB ,XMY
  6855   "RTN","IBC NSUR",107, 0)
  6856    N IBQUIT, IBCNS,IBPL AN,IBSUB,I BEXP,DFN,I BIPOL,IBIE NWK
  6857   "RTN","IBC NSUR",108, 0)
  6858    N IBINSNM ,IBGRPNM,I BGRPNO,IBE XPOK,IBEXP ERR,IBSUPR ES,IBCBI
  6859   "RTN","IBC NSUR",109, 0)
  6860    ;
  6861   "RTN","IBC NSUR",110, 0)
  6862    W !!,?5," EXPIRE ALL  SUBSCRIBE RS WITHIN  A GROUP PL AN"
  6863   "RTN","IBC NSUR",111, 0)
  6864    W !,?5,"Y ou can use  this opti on to spec ify an exp iration da te for all  subscribe r"
  6865   "RTN","IBC NSUR",112, 0)
  6866    W !,?5,"p olicies in  a group p lan withou t moving t he subscri bers to an other grou p"
  6867   "RTN","IBC NSUR",113, 0)
  6868    W !,?5,"p lan. If th e group pl an status  is current ly ""activ e"", you c an also ch oose"
  6869   "RTN","IBC NSUR",114, 0)
  6870    W !,?5,"t o ""inacti vate"" the  group pla n."
  6871   "RTN","IBC NSUR",115, 0)
  6872    W !!,$TR( $J("",75), " ","-")
  6873   "RTN","IBC NSUR",116, 0)
  6874    S IBQUIT= 1
  6875   "RTN","IBC NSUR",117, 0)
  6876    ;
  6877   "RTN","IBC NSUR",118, 0)
  6878   NXTGRP ; E P for next  expire gr oup proces s
  6879   "RTN","IBC NSUR",119, 0)
  6880    K ^TMP($J ,"IBCNSUR" ) ; subscr ibers
  6881   "RTN","IBC NSUR",120, 0)
  6882    K ^TMP($J ,"IBCNSURB LL") ; bul letin  
  6883   "RTN","IBC NSUR",121, 0)
  6884    I 'IBQUIT  D
  6885   "RTN","IBC NSUR",122, 0)
  6886    . W !!,"= ========== ========== ========== ========== ="
  6887   "RTN","IBC NSUR",123, 0)
  6888    . W !,"EX PIRE ALL S UBSCRIBERS  WITHIN A  GROUP PLAN "
  6889   "RTN","IBC NSUR",124, 0)
  6890    . W !,"== ========== ========== ========== ========== ",!
  6891   "RTN","IBC NSUR",125, 0)
  6892    ; get ins co and pla n
  6893   "RTN","IBC NSUR",126, 0)
  6894    S IBQUIT= 0
  6895   "RTN","IBC NSUR",127, 0)
  6896    D SEL^IBC NSUR(0) I  IBQUIT Q
  6897   "RTN","IBC NSUR",128, 0)
  6898    ;
  6899   "RTN","IBC NSUR",129, 0)
  6900    ; Make su re plan ha s at least  one subsc riber
  6901   "RTN","IBC NSUR",130, 0)
  6902    I '$$SUBS ^IBCNSJ(IB CNS,IBPLAN ,0,,1) W ! !,?5,*7,"*  This grou p plan has  no subscr ibers!",!  G NXTGRP
  6903   "RTN","IBC NSUR",131, 0)
  6904    ;
  6905   "RTN","IBC NSUR",132, 0)
  6906    S IBINSNM =$$GET1^DI Q(36,IBCNS _",","NAME ")
  6907   "RTN","IBC NSUR",133, 0)
  6908    S IBGRPNM =$$GET1^DI Q(355.3,IB PLAN_","," GROUP NAME ")
  6909   "RTN","IBC NSUR",134, 0)
  6910    S IBGRPNO =$$GET1^DI Q(355.3,IB PLAN_","," GROUP NUMB ER")
  6911   "RTN","IBC NSUR",135, 0)
  6912    ;
  6913   "RTN","IBC NSUR",136, 0)
  6914    W !!,"Col lecting Su bscribers  ..."
  6915   "RTN","IBC NSUR",137, 0)
  6916    S IBSUB=$ $SUBS^IBCN SJ(IBCNS,I BPLAN,0,"^ TMP($J,""I BCNSUR"")" )
  6917   "RTN","IBC NSUR",138, 0)
  6918    W !!,"Thi s group pl an has "_+ IBSUB_" su bscribers.  All subsc ribers wil l be expir ed.",!
  6919   "RTN","IBC NSUR",139, 0)
  6920    S DIR(0)= "Y"
  6921   "RTN","IBC NSUR",140, 0)
  6922    S DIR("A" )="Do you  want to ex pire all s ubscribers ' policies  for this  plan"
  6923   "RTN","IBC NSUR",141, 0)
  6924    S DIR("?" ,1)="You w ill be ask ed for an  expiration  date to t erminate t he attache d policies ."
  6925   "RTN","IBC NSUR",142, 0)
  6926    S DIR("?" ,2)="You w ill have a n opportun ity to sto p if desir ed."
  6927   "RTN","IBC NSUR",143, 0)
  6928    S DIR("?" )="Enter ' Yes' to co ntinue, or  'No' to s top the pr ocess now. "
  6929   "RTN","IBC NSUR",144, 0)
  6930    D ^DIR K  DIR
  6931   "RTN","IBC NSUR",145, 0)
  6932    I 'Y!$D(D IRUT) G NX TGRP
  6933   "RTN","IBC NSUR",146, 0)
  6934    ;
  6935   "RTN","IBC NSUR",147, 0)
  6936    W !
  6937   "RTN","IBC NSUR",148, 0)
  6938    ; get the  expiratio n date
  6939   "RTN","IBC NSUR",149, 0)
  6940    S DIR(0)= "D",DIR("A ")="Enter  expiration  date (app lies to al l subscrib ers in thi s plan)"
  6941   "RTN","IBC NSUR",150, 0)
  6942    S DIR("?" )="Each ac tive polic y will be  expired wi th the exp iration da te entered ."
  6943   "RTN","IBC NSUR",151, 0)
  6944    D ^DIR K  DIR
  6945   "RTN","IBC NSUR",152, 0)
  6946    I 'Y!$D(D IRUT) G NX TGRP
  6947   "RTN","IBC NSUR",153, 0)
  6948    S IBEXP=Y
  6949   "RTN","IBC NSUR",154, 0)
  6950    ;
  6951   "RTN","IBC NSUR",155, 0)
  6952    W !!,"You  selected  to expire  "_+IBSUB_"  subscribe r(s) with  Expiration  Date "_$$ FMTE^XLFDT (IBEXP)_"  for:"
  6953   "RTN","IBC NSUR",156, 0)
  6954    W !,?5,"I nsurance C ompany "_I BINSNM
  6955   "RTN","IBC NSUR",157, 0)
  6956    W !,?5,"P lan Name " _IBGRPNM_"     Number  "_IBGRPNO
  6957   "RTN","IBC NSUR",158, 0)
  6958    W !!,"Ple ase Note t hat the po licy will  be EXPIRED  in the pa tient prof ile!!",!
  6959   "RTN","IBC NSUR",159, 0)
  6960    ; 
  6961   "RTN","IBC NSUR",160, 0)
  6962    S DIR(0)= "Y",DIR("A ")="Okay t o continue "
  6963   "RTN","IBC NSUR",161, 0)
  6964    S DIR("?" ,1)="If yo u wish to  expire the  policies  for these  subscriber s, enter ' Yes'."
  6965   "RTN","IBC NSUR",162, 0)
  6966    S DIR("?" )="Otherwi se, enter  'No' to ex it."
  6967   "RTN","IBC NSUR",163, 0)
  6968    D ^DIR K  DIR
  6969   "RTN","IBC NSUR",164, 0)
  6970    I 'Y!$D(D IRUT) G NX TGRP
  6971   "RTN","IBC NSUR",165, 0)
  6972    ;
  6973   "RTN","IBC NSUR",166, 0)
  6974    ; expire  the plan s ubscribers
  6975   "RTN","IBC NSUR",167, 0)
  6976    ; as we p rocess the  policies,  we'll set  the ^TMP  nodes to ' O'k or 'E' rror
  6977   "RTN","IBC NSUR",168, 0)
  6978    W !!,"Exp iring Poli cies...",!
  6979   "RTN","IBC NSUR",169, 0)
  6980    S IBSUPRE S=1 ; tell  COVERED^I BCNSM31 to  be quiet
  6981   "RTN","IBC NSUR",170, 0)
  6982    S (IBEXPO K,IBEXPERR )=0
  6983   "RTN","IBC NSUR",171, 0)
  6984    S DFN=0 F   S DFN=$O (^TMP($J," IBCNSUR",D FN)) Q:'DF N  D
  6985   "RTN","IBC NSUR",172, 0)
  6986    . S IBIPO L=0 F  S I BIPOL=$O(^ TMP($J,"IB CNSUR",DFN ,IBIPOL))  Q:IBIPOL=" "  D
  6987   "RTN","IBC NSUR",173, 0)
  6988    .. S IBIE NWK=IBIPOL _","_DFN_" ,"
  6989   "RTN","IBC NSUR",174, 0)
  6990    .. Q:$$GE T1^DIQ(2.3 12,IBIENWK ,"GROUP PL AN","I")'= IBPLAN
  6991   "RTN","IBC NSUR",175, 0)
  6992    .. Q:+$$G ET1^DIQ(2. 312,IBIENW K,"INSURAN CE EXPIRAT ION","I")
  6993   "RTN","IBC NSUR",176, 0)
  6994    .. I $$GE T1^DIQ(2.3 12,IBIENWK ,"EFFECTIV E DATE OF  POLICY","I ")>IBEXP S  ^TMP($J," IBCNSUR",D FN,IBIPOL) ="E",IBEXP ERR=IBEXPE RR+1 Q
  6995   "RTN","IBC NSUR",177, 0)
  6996    .. S IBCB I=$$GET1^D IQ(2,DFN_" ,","COVERE D BY HEALT H INSURANC E?","I")
  6997   "RTN","IBC NSUR",178, 0)
  6998    .. K DTA, ERR
  6999   "RTN","IBC NSUR",179, 0)
  7000    .. S DTA( 2.312,IBIE NWK,3)=IBE XP ; set t he expirat ion date
  7001   "RTN","IBC NSUR",180, 0)
  7002    .. S DTA( 2.312,IBIE NWK,1.05)= $$NOW^XLFD T() ; last  edited
  7003   "RTN","IBC NSUR",181, 0)
  7004    .. S DTA( 2.312,IBIE NWK,1.06)= DUZ ; by
  7005   "RTN","IBC NSUR",182, 0)
  7006    .. D FILE ^DIE("","D TA","ERR")
  7007   "RTN","IBC NSUR",183, 0)
  7008    .. I $D(E RR) S ^TMP ($J,"IBCNS UR",DFN,IB IPOL)="E", IBEXPERR=I BEXPERR+1  Q
  7009   "RTN","IBC NSUR",184, 0)
  7010    .. S ^TMP ($J,"IBCNS UR",DFN,IB IPOL)="O", IBEXPOK=IB EXPOK+1
  7011   "RTN","IBC NSUR",185, 0)
  7012    .. D COVE RED^IBCNSM 31(DFN,IBC BI) ; set  covered by  insurance  
  7013   "RTN","IBC NSUR",186, 0)
  7014    ;
  7015   "RTN","IBC NSUR",187, 0)
  7016    W !,"Done . "_IBEXPO K_" Subscr ibers' pol icies were  expired a s of "_$$F MTE^XLFDT( IBEXP)_"."
  7017   "RTN","IBC NSUR",188, 0)
  7018    W !,"A Bu lletin was  sent to y ou and mem bers of 'I B NEW INSU RANCE' Mai l Group."
  7019   "RTN","IBC NSUR",189, 0)
  7020    ;
  7021   "RTN","IBC NSUR",190, 0)
  7022    ; prepare  the bulle tin
  7023   "RTN","IBC NSUR",191, 0)
  7024    S IBLN=0, REF=$NA(^T MP($J,"IBC NSURBLL"))
  7025   "RTN","IBC NSUR",192, 0)
  7026    D ADD^IBC NSUR3(1,"E XPIRE ALL  SUBSCRIBER S WITHIN A  GROUP PLA N")
  7027   "RTN","IBC NSUR",193, 0)
  7028    D ADD^IBC NSUR3()
  7029   "RTN","IBC NSUR",194, 0)
  7030    D ADD^IBC NSUR3(1,"Y ou selecte d to expir e ",IBSUB, " subscrib er(s)")
  7031   "RTN","IBC NSUR",195, 0)
  7032    D ADD^IBC NSUR3()
  7033   "RTN","IBC NSUR",196, 0)
  7034    D ADD^IBC NSUR3(1,"F ROM Insura nce Compan y ",IBINSN M)
  7035   "RTN","IBC NSUR",197, 0)
  7036    D ADD^IBC NSUR3(1,"P lan Name " ,IBGRPNM,"     Number  ",IBGRPNO )
  7037   "RTN","IBC NSUR",198, 0)
  7038    D ADD^IBC NSUR3()
  7039   "RTN","IBC NSUR",199, 0)
  7040    D ADD^IBC NSUR3(1,"P olicies wi ll be expi red as of  ",$$FMTE^X LFDT(IBEXP ),".")
  7041   "RTN","IBC NSUR",200, 0)
  7042    D ADD^IBC NSUR3()
  7043   "RTN","IBC NSUR",201, 0)
  7044    ;
  7045   "RTN","IBC NSUR",202, 0)
  7046    I IBEXPER R D
  7047   "RTN","IBC NSUR",203, 0)
  7048    . D ADD^I BCNSUR3(1, "* These " ,IBEXPERR, " entries  could not  be process ed, they'l l need to  be adjuste d manually ")
  7049   "RTN","IBC NSUR",204, 0)
  7050    . W !!,@R EF@(IBLN)
  7051   "RTN","IBC NSUR",205, 0)
  7052    . D ADD^I BCNSUR3(1, "--------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ")
  7053   "RTN","IBC NSUR",206, 0)
  7054    . W !,@RE F@(IBLN)
  7055   "RTN","IBC NSUR",207, 0)
  7056    . D ADD^I BCNSUR3(1, "Patient N ame/ID              W hose    Em ployer                Effective    Expires" )
  7057   "RTN","IBC NSUR",208, 0)
  7058    . W !,@RE F@(IBLN),!
  7059   "RTN","IBC NSUR",209, 0)
  7060    . S DFN=0  F  S DFN= $O(^TMP($J ,"IBCNSUR" ,DFN)) Q:' DFN  D
  7061   "RTN","IBC NSUR",210, 0)
  7062    .. S IBIP OL=0 F  S  IBIPOL=$O( ^TMP($J,"I BCNSUR",DF N,IBIPOL))  Q:IBIPOL= ""  D
  7063   "RTN","IBC NSUR",211, 0)
  7064    ... I ^TM P($J,"IBCN SUR",DFN,I BIPOL)'="E " Q
  7065   "RTN","IBC NSUR",212, 0)
  7066    ... D ADS ^IBCNSUR3( DFN,IBIPOL )
  7067   "RTN","IBC NSUR",213, 0)
  7068    ... W !,@ REF@(IBLN)
  7069   "RTN","IBC NSUR",214, 0)
  7070    . D ADD^I BCNSUR3(1, "========= ========== =========" )
  7071   "RTN","IBC NSUR",215, 0)
  7072    . D ADD^I BCNSUR3()
  7073   "RTN","IBC NSUR",216, 0)
  7074    . W !!,"E xamine the  entries t hat could  not be pro cessed."
  7075   "RTN","IBC NSUR",217, 0)
  7076    ;
  7077   "RTN","IBC NSUR",218, 0)
  7078    I IBEXPOK  D
  7079   "RTN","IBC NSUR",219, 0)
  7080    . D ADD^I BCNSUR3(1, "These ",I BEXPOK," p olicies we re process ed success fully")
  7081   "RTN","IBC NSUR",220, 0)
  7082    . D ADD^I BCNSUR3(1, "--------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- ")
  7083   "RTN","IBC NSUR",221, 0)
  7084    . D ADD^I BCNSUR3(1, "Patient N ame/ID              W hose    Em ployer                Effective    Expires" )
  7085   "RTN","IBC NSUR",222, 0)
  7086    . S DFN=0  F  S DFN= $O(^TMP($J ,"IBCNSUR" ,DFN)) Q:' DFN  D
  7087   "RTN","IBC NSUR",223, 0)
  7088    .. S IBIP OL=0 F  S  IBIPOL=$O( ^TMP($J,"I BCNSUR",DF N,IBIPOL))  Q:IBIPOL= ""  D
  7089   "RTN","IBC NSUR",224, 0)
  7090    ... I ^TM P($J,"IBCN SUR",DFN,I BIPOL)'="O " Q
  7091   "RTN","IBC NSUR",225, 0)
  7092    ... D ADS ^IBCNSUR3( DFN,IBIPOL )
  7093   "RTN","IBC NSUR",226, 0)
  7094    . D ADD^I BCNSUR3(1, "========= ========== =========" )
  7095   "RTN","IBC NSUR",227, 0)
  7096    . D ADD^I BCNSUR3()
  7097   "RTN","IBC NSUR",228, 0)
  7098    ;
  7099   "RTN","IBC NSUR",229, 0)
  7100    I 'IBEXPO K,'IBEXPER R D
  7101   "RTN","IBC NSUR",230, 0)
  7102    . D ADD^I BCNSUR3(1, "========= ========== =========" )
  7103   "RTN","IBC NSUR",231, 0)
  7104    . D ADD^I BCNSUR3(1, "After pro cessing, n o changes  were neede d, no poli cies were  expired.")
  7105   "RTN","IBC NSUR",232, 0)
  7106    . W !!,@R EF@(IBLN)
  7107   "RTN","IBC NSUR",233, 0)
  7108    . D ADD^I BCNSUR3(1, "========= ========== =========" )
  7109   "RTN","IBC NSUR",234, 0)
  7110    . D ADD^I BCNSUR3()
  7111   "RTN","IBC NSUR",235, 0)
  7112    ;
  7113   "RTN","IBC NSUR",236, 0)
  7114    W !
  7115   "RTN","IBC NSUR",237, 0)
  7116    S DIR(0)= "EA",DIR(" A")="Press  RETURN to  continue. " D ^DIR K  DIR
  7117   "RTN","IBC NSUR",238, 0)
  7118    ;
  7119   "RTN","IBC NSUR",239, 0)
  7120    I +$$GET1 ^DIQ(355.3 ,IBPLAN_", ","INACTIV E","I") D   G NXTGRP
  7121   "RTN","IBC NSUR",240, 0)
  7122    . D ADD^I BCNSUR3(1, "Please no te the ",I BGRPNM," p lan is alr eady inact ive.")
  7123   "RTN","IBC NSUR",241, 0)
  7124    . W !!,@R EF@(IBLN), !
  7125   "RTN","IBC NSUR",242, 0)
  7126    . D SNDBU LL
  7127   "RTN","IBC NSUR",243, 0)
  7128    ;
  7129   "RTN","IBC NSUR",244, 0)
  7130    W !
  7131   "RTN","IBC NSUR",245, 0)
  7132    S DIR(0)= "Y",DIR("B ")="NO"
  7133   "RTN","IBC NSUR",246, 0)
  7134    I IBEXPER R D
  7135   "RTN","IBC NSUR",247, 0)
  7136    . S DIR(" A",1)="        ****** ********** ********** ********** ********** *"
  7137   "RTN","IBC NSUR",248, 0)
  7138    . S DIR(" A",2)="        *                     WARNIN G                     *"
  7139   "RTN","IBC NSUR",249, 0)
  7140    . S DIR(" A",3)="        *      There are  still acti ve subscri bers       *"
  7141   "RTN","IBC NSUR",250, 0)
  7142    . S DIR(" A",4)="        *   th at will ne ed to be a djusted ma nually     *"
  7143   "RTN","IBC NSUR",251, 0)
  7144    . S DIR(" A",5)="        ****** ********** ********** ********** ********** *"
  7145   "RTN","IBC NSUR",252, 0)
  7146    . S DIR(" A",6)=" "
  7147   "RTN","IBC NSUR",253, 0)
  7148    S DIR("A" )="Do you  wish to in activate p lan "_IBGR PNM
  7149   "RTN","IBC NSUR",254, 0)
  7150    D ^DIR K  DIR
  7151   "RTN","IBC NSUR",255, 0)
  7152    I 'Y!$D(D IRUT) D  G  NXTGRP
  7153   "RTN","IBC NSUR",256, 0)
  7154    . D ADD^I BCNSUR3(1, "The ",IBG RPNM," pla n is still  active.")
  7155   "RTN","IBC NSUR",257, 0)
  7156    . W !!,@R EF@(IBLN), !
  7157   "RTN","IBC NSUR",258, 0)
  7158    . D SNDBU LL
  7159   "RTN","IBC NSUR",259, 0)
  7160    ; inactiv ate the pl an
  7161   "RTN","IBC NSUR",260, 0)
  7162    S IBIENWK =IBPLAN_", "
  7163   "RTN","IBC NSUR",261, 0)
  7164    K DTA,ERR
  7165   "RTN","IBC NSUR",262, 0)
  7166    S DTA(355 .3,IBIENWK ,.11)=1 ;  inactive
  7167   "RTN","IBC NSUR",263, 0)
  7168    S DTA(355 .3,IBIENWK ,1.05)=$$N OW^XLFDT()  ; last ed ited
  7169   "RTN","IBC NSUR",264, 0)
  7170    S DTA(355 .3,IBIENWK ,1.06)=DUZ  ; by
  7171   "RTN","IBC NSUR",265, 0)
  7172    D FILE^DI E("","DTA" ,"ERR")
  7173   "RTN","IBC NSUR",266, 0)
  7174    I $D(ERR)  D  G NXTG RP
  7175   "RTN","IBC NSUR",267, 0)
  7176    . D ADD^I BCNSUR3(1, "There was  an issue  inactivati ng the ",I BGRPNM," p lan.")
  7177   "RTN","IBC NSUR",268, 0)
  7178    . W !!,@R EF@(IBLN), !
  7179   "RTN","IBC NSUR",269, 0)
  7180    . D SNDBU LL
  7181   "RTN","IBC NSUR",270, 0)
  7182    D ADD^IBC NSUR3(1,"T he ",IBGRP NM," plan  has been i nactivated .")
  7183   "RTN","IBC NSUR",271, 0)
  7184    W !!,@REF @(IBLN),!
  7185   "RTN","IBC NSUR",272, 0)
  7186    D SNDBULL
  7187   "RTN","IBC NSUR",273, 0)
  7188    G NXTGRP
  7189   "RTN","IBC NSUR",274, 0)
  7190    ;
  7191   "RTN","IBC NSUR",275, 0)
  7192   SNDBULL ;  send out t he bulleti
  7193   "RTN","IBC NSUR",276, 0)
  7194    I '$G(IBL N) Q
  7195   "RTN","IBC NSUR",277, 0)
  7196    D ADD^IBC NSUR3()
  7197   "RTN","IBC NSUR",278, 0)
  7198    D ADD^IBC NSUR3(1,"T HE PROCESS  COMPLETED  SUCCESSFU LLY ON "_$ $DAT1^IBOU TL($$NOW^X LFDT(),1))
  7199   "RTN","IBC NSUR",279, 0)
  7200    S XMSUB=" SUBSCRIPTI ON LIST FO R INACTIVA TED PLAN"
  7201   "RTN","IBC NSUR",280, 0)
  7202    S XMDUZ=" INTEGRATED  BILLING P ACKAGE",XM TEXT="^TMP ("_$J_","" IBCNSURBLL "","
  7203   "RTN","IBC NSUR",281, 0)
  7204    S XMY(DUZ )=""
  7205   "RTN","IBC NSUR",282, 0)
  7206    S XMY("G. IB NEW INS URANCE")=" "
  7207   "RTN","IBC NSUR",283, 0)
  7208    D ^XMD
  7209   "RTN","IBC NSUR",284, 0)
  7210    Q
  7211   "RTN","IBC OC1")
  7212   0^8^B24512 676^B21404 907
  7213   "RTN","IBC OC1",1,0)
  7214   IBCOC1 ;AL B/NLR - NE W, NOT VER IFIED INS.  ENTRIES ; 24-NOV-93
  7215   "RTN","IBC OC1",2,0)
  7216    ;;2.0;INT EGRATED BI LLING;**52 8,602**;21 -MAR-94;Bu ild 22
  7217   "RTN","IBC OC1",3,0)
  7218    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7219   "RTN","IBC OC1",4,0)
  7220    ;
  7221   "RTN","IBC OC1",5,0)
  7222   % ;
  7223   "RTN","IBC OC1",6,0)
  7224    N POP,ZTQ UEUED,ZTRE Q
  7225   "RTN","IBC OC1",7,0)
  7226    ; -- file man print  of new, no t verified  insurance  entries
  7227   "RTN","IBC OC1",8,0)
  7228    ;
  7229   "RTN","IBC OC1",9,0)
  7230    W !!,"Pri nt List of  New, Not  Verified I nsurance E ntries"
  7231   "RTN","IBC OC1",10,0)
  7232    ;
  7233   "RTN","IBC OC1",11,0)
  7234    ; Report  or Excel f ormat
  7235   "RTN","IBC OC1",12,0)
  7236    S IBOUT=$ $OUT G:IBO UT="" END
  7237   "RTN","IBC OC1",13,0)
  7238    I IBOUT=" E" G EXCEL
  7239   "RTN","IBC OC1",14,0)
  7240    ;
  7241   "RTN","IBC OC1",15,0)
  7242    W !!,"You  will need  a 132 col umn printe r for this  report!", !!
  7243   "RTN","IBC OC1",16,0)
  7244    ;
  7245   "RTN","IBC OC1",17,0)
  7246    S DIC="^D PT(",FLDS= "[IBNOTVER ]",BY="[IB NOTVER1]"
  7247   "RTN","IBC OC1",18,0)
  7248    D ASK G:$ G(IBQ)=1 E ND
  7249   "RTN","IBC OC1",19,0)
  7250    S DHD="RE PORT OF NE W, NOT VER IFIED INSU RANCE ENTR IES FROM:  "_FR(1)_"  TO: "_TO(1 )
  7251   "RTN","IBC OC1",20,0)
  7252    D EN1^DIP ,ASK^IBCOM C2
  7253   "RTN","IBC OC1",21,0)
  7254    ;
  7255   "RTN","IBC OC1",22,0)
  7256    I $D(ZTQU EUED) S ZT REQ="@" Q
  7257   "RTN","IBC OC1",23,0)
  7258    D ^%ZISC
  7259   "RTN","IBC OC1",24,0)
  7260   END K DIC, FLDS,BY,FR ,TO,IBOUT, IBQ,DHD
  7261   "RTN","IBC OC1",25,0)
  7262    Q
  7263   "RTN","IBC OC1",26,0)
  7264   ASK ;
  7265   "RTN","IBC OC1",27,0)
  7266    N IBBDT,I BEDT
  7267   "RTN","IBC OC1",28,0)
  7268    D DATE^IB OUTL
  7269   "RTN","IBC OC1",29,0)
  7270    I (IBBDT< 1)!(IBEDT< 1) S IBQ=1
  7271   "RTN","IBC OC1",30,0)
  7272    S FR=",," _IBBDT_",? ",TO=",,"_ IBEDT_",?"
  7273   "RTN","IBC OC1",31,0)
  7274    S FR(1)=$ $DAT1^IBOU TL(IBBDT), TO(1)=$$DA T1^IBOUTL( IBEDT)
  7275   "RTN","IBC OC1",32,0)
  7276    Q
  7277   "RTN","IBC OC1",33,0)
  7278    ;
  7279   "RTN","IBC OC1",34,0)
  7280   OUT() ;
  7281   "RTN","IBC OC1",35,0)
  7282    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  7283   "RTN","IBC OC1",36,0)
  7284    W !
  7285   "RTN","IBC OC1",37,0)
  7286    S DIR(0)= "SA^E:Exce l;R:Report "
  7287   "RTN","IBC OC1",38,0)
  7288    S DIR("A" )="(E)xcel  Format or  (R)eport  Format: "
  7289   "RTN","IBC OC1",39,0)
  7290    S DIR("B" )="Report"
  7291   "RTN","IBC OC1",40,0)
  7292    D ^DIR I  $D(DIRUT)  Q ""
  7293   "RTN","IBC OC1",41,0)
  7294    Q Y
  7295   "RTN","IBC OC1",42,0)
  7296    ;
  7297   "RTN","IBC OC1",43,0)
  7298   EXCEL ;
  7299   "RTN","IBC OC1",44,0)
  7300    ; Ask for  Date Ente red range
  7301   "RTN","IBC OC1",45,0)
  7302    N IBBDT,I BEDT,IBRF, IBRL,IBQUI T
  7303   "RTN","IBC OC1",46,0)
  7304    S IBQUIT= 0
  7305   "RTN","IBC OC1",47,0)
  7306    D DATE^IB OUTL
  7307   "RTN","IBC OC1",48,0)
  7308    I (IBBDT< 1)!(IBEDT< 1) G XLQUI T
  7309   "RTN","IBC OC1",49,0)
  7310    ;
  7311   "RTN","IBC OC1",50,0)
  7312    D NR G:IB QUIT XLQUI T
  7313   "RTN","IBC OC1",51,0)
  7314    ;
  7315   "RTN","IBC OC1",52,0)
  7316    W !! D QU E
  7317   "RTN","IBC OC1",53,0)
  7318    ;
  7319   "RTN","IBC OC1",54,0)
  7320   XLQUIT ;
  7321   "RTN","IBC OC1",55,0)
  7322    K IBBDT,I BEDT,IBRF, IBRL,IBOUT ,IBQUIT
  7323   "RTN","IBC OC1",56,0)
  7324    Q
  7325   "RTN","IBC OC1",57,0)
  7326    ;
  7327   "RTN","IBC OC1",58,0)
  7328   NR ; Ask N ame Range
  7329   "RTN","IBC OC1",59,0)
  7330    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  7331   "RTN","IBC OC1",60,0)
  7332   NRR S DIR( 0)="FO",DI R("B")="FI RST",DIR(" A")="       START WIT H NAME"
  7333   "RTN","IBC OC1",61,0)
  7334    D ^DIR I  ($D(DTOUT) )!($D(DUOU T)) S IBQU IT=1 Q
  7335   "RTN","IBC OC1",62,0)
  7336    S:Y="FIRS T" Y="A" S  IBRF=Y
  7337   "RTN","IBC OC1",63,0)
  7338    S DIR(0)= "FO",DIR(" B")="LAST" ,DIR("A")= "      GO  TO NAME"
  7339   "RTN","IBC OC1",64,0)
  7340    D ^DIR I  ($D(DTOUT) )!($D(DUOU T)) S IBQU IT=1 Q
  7341   "RTN","IBC OC1",65,0)
  7342    S:Y="LAST " Y="zzzzz z" S IBRL= Y
  7343   "RTN","IBC OC1",66,0)
  7344    I $G(IBRL )']$G(IBRF ) W !!,?5, "* The Go  to Patient  Name must  follow af ter the St art with N ame. *",!  G NRR
  7345   "RTN","IBC OC1",67,0)
  7346    Q
  7347   "RTN","IBC OC1",68,0)
  7348    ;
  7349   "RTN","IBC OC1",69,0)
  7350   QUE ; Ask  Device for  Excel Out put
  7351   "RTN","IBC OC1",70,0)
  7352    N %ZIS,ZT RTN,ZTSAVE ,ZTDESC
  7353   "RTN","IBC OC1",71,0)
  7354    S %ZIS="Q M" D ^%ZIS  G:POP QUE Q
  7355   "RTN","IBC OC1",72,0)
  7356    I $D(IO(" Q")) K IO( "Q") D  G  QUEQ
  7357   "RTN","IBC OC1",73,0)
  7358    .S ZTRTN= "COMPXL^IB COC1",ZTSA VE("IBRF") ="",ZTSAVE ("IBRL")=" "
  7359   "RTN","IBC OC1",74,0)
  7360    .S ZTSAVE ("IBBDT")= "",ZTSAVE( "IBEDT")=" "
  7361   "RTN","IBC OC1",75,0)
  7362    .S ZTDESC ="IB - Lis t New not  Verified P olicies"
  7363   "RTN","IBC OC1",76,0)
  7364    .D ^%ZTLO AD K ZTSK  D HOME^%ZI S
  7365   "RTN","IBC OC1",77,0)
  7366    ;
  7367   "RTN","IBC OC1",78,0)
  7368    U IO
  7369   "RTN","IBC OC1",79,0)
  7370    D COMPXL
  7371   "RTN","IBC OC1",80,0)
  7372    ;
  7373   "RTN","IBC OC1",81,0)
  7374   QUEQ ; Exi t clean-up
  7375   "RTN","IBC OC1",82,0)
  7376    W ! D ^%Z ISC K IBBD T,IBEDT,IB OUT,IBRF,I BRL,VA,VAE RR,VADM,VA PA,^TMP("I BCOC1",$J)
  7377   "RTN","IBC OC1",83,0)
  7378    Q
  7379   "RTN","IBC OC1",84,0)
  7380    ;
  7381   "RTN","IBC OC1",85,0)
  7382   COMPXL ; C ompile Exc el data
  7383   "RTN","IBC OC1",86,0)
  7384    ; Input v ariables:
  7385   "RTN","IBC OC1",87,0)
  7386    ; IBRF  -  Required.   Name Ran ge Start v alue
  7387   "RTN","IBC OC1",88,0)
  7388    ; IBRL  -  Required.   Name Ran ge Go To v alue
  7389   "RTN","IBC OC1",89,0)
  7390    ; IBBDT -  Required.   Begining  Entered D ate Range
  7391   "RTN","IBC OC1",90,0)
  7392    ; IBEDT -  Required.   Ending E ntered Dat e Range
  7393   "RTN","IBC OC1",91,0)
  7394    ;
  7395   "RTN","IBC OC1",92,0)
  7396    N IBC,IBC DA,IBCDA0, IBCDA1,IBS SN,IBINS,I BSUBID,IBE NDT,IBENUS R,DFN,VA,V ADM,VAERR, VAPA
  7397   "RTN","IBC OC1",93,0)
  7398    K ^TMP("I BCOC1",$J)
  7399   "RTN","IBC OC1",94,0)
  7400    S IBC=0 F   S IBC=$O (^DPT("AB" ,IBC)) Q:' IBC  D
  7401   "RTN","IBC OC1",95,0)
  7402    .S DFN=0  F  S DFN=$ O(^DPT("AB ",IBC,DFN) ) Q:'DFN   D
  7403   "RTN","IBC OC1",96,0)
  7404    ..K VA,VA DM,VAERR,V APA
  7405   "RTN","IBC OC1",97,0)
  7406    ..D DEM^V ADPT,ADD^V ADPT
  7407   "RTN","IBC OC1",98,0)
  7408    ..;
  7409   "RTN","IBC OC1",99,0)
  7410    ..;  I Pt . name out  of range  quit
  7411   "RTN","IBC OC1",100,0 )
  7412    ..S VADM( 1)=$P($G(V ADM(1)),U, 1) I VADM( 1)="" Q
  7413   "RTN","IBC OC1",101,0 )
  7414    ..I VADM( 1)]IBRL Q
  7415   "RTN","IBC OC1",102,0 )
  7416    ..I IBRF] VADM(1) Q
  7417   "RTN","IBC OC1",103,0 )
  7418    ..;
  7419   "RTN","IBC OC1",104,0 )
  7420    ..S IBCDA =0 F  S IB CDA=$O(^DP T("AB",IBC ,DFN,IBCDA )) Q:'IBCD A  D
  7421   "RTN","IBC OC1",105,0 )
  7422    ...S IBCD A0=$$ZND^I BCNS1(DFN, IBCDA)  ;5 16 - baa
  7423   "RTN","IBC OC1",106,0 )
  7424    ...;
  7425   "RTN","IBC OC1",107,0 )
  7426    ...;  I V erificatio n Date pop ulated qui t
  7427   "RTN","IBC OC1",108,0 )
  7428    ...S IBCD A1=$G(^DPT (DFN,.312, IBCDA,1))
  7429   "RTN","IBC OC1",109,0 )
  7430    ...I $P(I BCDA1,U,3)  Q
  7431   "RTN","IBC OC1",110,0 )
  7432    ...;
  7433   "RTN","IBC OC1",111,0 )
  7434    ...;  I E ntered Dat e out of r ange quit
  7435   "RTN","IBC OC1",112,0 )
  7436    ...I +$P( IBCDA1,U)> IBEDT Q
  7437   "RTN","IBC OC1",113,0 )
  7438    ...I +$P( IBCDA1,U)< IBBDT Q
  7439   "RTN","IBC OC1",114,0 )
  7440    ...;
  7441   "RTN","IBC OC1",115,0 )
  7442    ...;  Get  data fiel ds
  7443   "RTN","IBC OC1",116,0 )
  7444    ...S IBSS N=$$GET1^D IQ(2,DFN,. 09)
  7445   "RTN","IBC OC1",117,0 )
  7446    ...S IBIN S=$$GET1^D IQ(2.312,I BCDA_","_D FN_",",.01 )
  7447   "RTN","IBC OC1",118,0 )
  7448    ...S IBSU BID=$$GET1 ^DIQ(2.312 ,IBCDA_"," _DFN_",",7 .02)
  7449   "RTN","IBC OC1",119,0 )
  7450    ...S IBEN USR=$$GET1 ^DIQ(2.312 ,IBCDA_"," _DFN_",",1 .02)
  7451   "RTN","IBC OC1",120,0 )
  7452    ...S IBEN DT=$$FMTE^ XLFDT($P(I BCDA1,U),1 )
  7453   "RTN","IBC OC1",121,0 )
  7454    ...;
  7455   "RTN","IBC OC1",122,0 )
  7456    ...;  Set  global ar ray
  7457   "RTN","IBC OC1",123,0 )
  7458    ...S ^TMP ("IBCOC1", $J,VADM(1) ,IBCDA)=VA DM(1)_U_IB SSN_U_IBIN S_U_IBSUBI D_U_IBENUS R_U_IBENDT
  7459   "RTN","IBC OC1",124,0 )
  7460    ;
  7461   "RTN","IBC OC1",125,0 )
  7462    ;IB*2.0*6 02 Add tit le to Exce l Report
  7463   "RTN","IBC OC1",126,0 )
  7464    W "REPORT  OF NEW, N OT VERIFIE D INSURANC E ENTRIES  FROM: ",$$ DAT1^IBOUT L(IBBDT),"  TO: ",$$D AT1^IBOUTL (IBEDT)
  7465   "RTN","IBC OC1",127,0 )
  7466    W !,"NAME S RANGING  FROM ",$S( IBRF="A":" FIRST",1:I BRF)," TO  ",$S(IBRL= "zzzzzz":" LAST",1:IB RL)_"^"_$$ FMTE^XLFDT ($$NOW^XLF DT,"Z"),!  ; IB*2.0*6 02
  7467   "RTN","IBC OC1",128,0 )
  7468    ; IB*602/ HN end 
  7469   "RTN","IBC OC1",129,0 )
  7470    W "PATIEN T^PATIENT  ID^INSURAN CE CO^SUBS CRIBER ID^ WHO ENTERE D^DATE ENT ERED"
  7471   "RTN","IBC OC1",130,0 )
  7472    I '$D(^TM P("IBCOC1" ,$J)) W !! ,"** NO RE CORDS FOUN D **" D AS K^IBCOMC2  Q
  7473   "RTN","IBC OC1",131,0 )
  7474    D WRT,ASK ^IBCOMC2
  7475   "RTN","IBC OC1",132,0 )
  7476    ;
  7477   "RTN","IBC OC1",133,0 )
  7478    Q
  7479   "RTN","IBC OC1",134,0 )
  7480    ;
  7481   "RTN","IBC OC1",135,0 )
  7482   WRT ; Prin t Excel da ta
  7483   "RTN","IBC OC1",136,0 )
  7484    N IBPAT,I BINSTYP
  7485   "RTN","IBC OC1",137,0 )
  7486    S (IBPAT, IBINSTYP)= ""
  7487   "RTN","IBC OC1",138,0 )
  7488    F  S IBPA T=$O(^TMP( "IBCOC1",$ J,IBPAT))  Q:IBPAT=""   D
  7489   "RTN","IBC OC1",139,0 )
  7490    .F  S IBI NSTYP=$O(^ TMP("IBCOC 1",$J,IBPA T,IBINSTYP )) Q:'IBIN STYP  W !, ^TMP("IBCO C1",$J,IBP AT,IBINSTY P)
  7491   "RTN","IBC OC1",140,0 )
  7492    Q
  7493   "RTN","IBC OMD1")
  7494   0^9^B37249 446^B27677 991
  7495   "RTN","IBC OMD1",1,0)
  7496   IBCOMD1 ;A LB/CMS - G ENERATE IN SURANCE CO MPANY LIST INGS ;03-A UG-98
  7497   "RTN","IBC OMD1",2,0)
  7498    ;;2.0;INT EGRATED BI LLING;**10 3,528,602* *;21-MAR-9 4;Build 22
  7499   "RTN","IBC OMD1",3,0)
  7500    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7501   "RTN","IBC OMD1",4,0)
  7502    Q
  7503   "RTN","IBC OMD1",5,0)
  7504    ;
  7505   "RTN","IBC OMD1",6,0)
  7506   BEG ; Queu ed entry p oint.
  7507   "RTN","IBC OMD1",7,0)
  7508    ;  Input  variables:
  7509   "RTN","IBC OMD1",8,0)
  7510    ;
  7511   "RTN","IBC OMD1",9,0)
  7512    ;  IBCASE (n) = x ^  y ^ z  (Op tional), w here
  7513   "RTN","IBC OMD1",10,0 )
  7514    ;     n =  1-4  (1:N ame, 2:Str eet, 3:Cit y, 4:State )
  7515   "RTN","IBC OMD1",11,0 )
  7516    ;     x =  C (Contai ns), or R  (RANGE)
  7517   "RTN","IBC OMD1",12,0 )
  7518    ;     y =  Pointer t o the STAT E (#5) fil e, if n=4
  7519   "RTN","IBC OMD1",13,0 )
  7520    ;          The 'Cont ains' valu e, if x =  C
  7521   "RTN","IBC OMD1",14,0 )
  7522    ;          The 'Star t From' va lue, if x  = R
  7523   "RTN","IBC OMD1",15,0 )
  7524    ;     z =  The 'Go T o' value,  if x = R
  7525   "RTN","IBC OMD1",16,0 )
  7526    ;
  7527   "RTN","IBC OMD1",17,0 )
  7528    ;  IBFLD( n) = x  (R equired),  where
  7529   "RTN","IBC OMD1",18,0 )
  7530    ;     n =  1-4  (1:N ame, 2:Str eet, 3:Cit y, 4:State )
  7531   "RTN","IBC OMD1",19,0 )
  7532    ;     x =  NAME (n=1 ), STREET  (n=2), CIT Y (n=3), S TATE (n=4)
  7533   "RTN","IBC OMD1",20,0 )
  7534    ;
  7535   "RTN","IBC OMD1",21,0 )
  7536    ;  IBAIB  - Required .   Includ e Active I nsurance
  7537   "RTN","IBC OMD1",22,0 )
  7538    ;           1= Activ e Ins.   2 = Inactive  Ins. 3= B oth
  7539   "RTN","IBC OMD1",23,0 )
  7540    ;  IBOUT  - Required .   Output  format
  7541   "RTN","IBC OMD1",24,0 )
  7542    ;           "R"= rep ort format          " E"= Excel  format
  7543   "RTN","IBC OMD1",25,0 )
  7544    ;
  7545   "RTN","IBC OMD1",26,0 )
  7546    N IBDA,IB DA0,IBDA11 ,IBDA13,IB I,IBPAGE,I BTMP,IBX,X ,Y,IBJ,IBN OT
  7547   "RTN","IBC OMD1",27,0 )
  7548    ;
  7549   "RTN","IBC OMD1",28,0 )
  7550    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  7551   "RTN","IBC OMD1",29,0 )
  7552    K ^TMP("I BCOMD",$J)  S IBPAGE= 0
  7553   "RTN","IBC OMD1",30,0 )
  7554    ;
  7555   "RTN","IBC OMD1",31,0 )
  7556    ; - must  look at al l entries  in file #3 6
  7557   "RTN","IBC OMD1",32,0 )
  7558    S IBDA=0  F  S IBDA= $O(^DIC(36 ,IBDA)) Q: 'IBDA  S I BDA0=$G(^( IBDA,0)) D
  7559   "RTN","IBC OMD1",33,0 )
  7560    .;
  7561   "RTN","IBC OMD1",34,0 )
  7562    .; - scre en out act ive/inacti ve compani es
  7563   "RTN","IBC OMD1",35,0 )
  7564    .I IBAIB= 1,$P(IBDA0 ,U,5) Q
  7565   "RTN","IBC OMD1",36,0 )
  7566    .I IBAIB= 2,'$P(IBDA 0,U,5) Q
  7567   "RTN","IBC OMD1",37,0 )
  7568    .;
  7569   "RTN","IBC OMD1",38,0 )
  7570    .S IBDA11 =$G(^DIC(3 6,IBDA,.11 )),IBDA13= $G(^(.13))
  7571   "RTN","IBC OMD1",39,0 )
  7572    .;
  7573   "RTN","IBC OMD1",40,0 )
  7574    .; - scre en out ent ries based  on user-s elected fi eld screen s
  7575   "RTN","IBC OMD1",41,0 )
  7576    .S (IBJ,I BNOT)=0 F   S IBJ=$O( IBCASE(IBJ )) Q:'IBJ   D  Q:IBNO T
  7577   "RTN","IBC OMD1",42,0 )
  7578    ..N IBD,V AL S IBD=I BCASE(IBJ)
  7579   "RTN","IBC OMD1",43,0 )
  7580    ..;
  7581   "RTN","IBC OMD1",44,0 )
  7582    ..; - che ck state f irst
  7583   "RTN","IBC OMD1",45,0 )
  7584    ..I IBJ=4  S:$P(IBDA 11,"^",5)' =$P(IBD,"^ ",2) IBNOT =1 Q
  7585   "RTN","IBC OMD1",46,0 )
  7586    ..;
  7587   "RTN","IBC OMD1",47,0 )
  7588    ..; - fin d the fiel d value to  be evalua ted
  7589   "RTN","IBC OMD1",48,0 )
  7590    ..S VAL=$ S(IBJ=1:$P (IBDA0,"^" ),1:$P(IBD A11,"^",$S (IBJ=2:1,1 :4)))
  7591   "RTN","IBC OMD1",49,0 )
  7592    ..;
  7593   "RTN","IBC OMD1",50,0 )
  7594    ..; - che ck 'contai ns' values
  7595   "RTN","IBC OMD1",51,0 )
  7596    ..I $P(IB D,"^")="C"  S:VAL'[$P (IBD,"^",2 ) IBNOT=1  Q
  7597   "RTN","IBC OMD1",52,0 )
  7598    ..;
  7599   "RTN","IBC OMD1",53,0 )
  7600    ..; - che ck 'range'  values
  7601   "RTN","IBC OMD1",54,0 )
  7602    ..I VAL=" " S IBNOT= 1 Q  ; VAL  must have  a value i n a range
  7603   "RTN","IBC OMD1",55,0 )
  7604    ..I $P(IB D,"^",2)]V AL S IBNOT =1 Q  ; VA L doesn't  follow Sta rt value
  7605   "RTN","IBC OMD1",56,0 )
  7606    ..I VAL]$ P(IBD,"^", 3) S IBNOT =1 ;    VA L follows  the Go To  value
  7607   "RTN","IBC OMD1",57,0 )
  7608    .;
  7609   "RTN","IBC OMD1",58,0 )
  7610    .Q:IBNOT   ; entry d oes not me et criteri a
  7611   "RTN","IBC OMD1",59,0 )
  7612    .;
  7613   "RTN","IBC OMD1",60,0 )
  7614    .;
  7615   "RTN","IBC OMD1",61,0 )
  7616    .; - set  entry in g lobal
  7617   "RTN","IBC OMD1",62,0 )
  7618    .S IBTMP= $P(IBDA0,U ,1)_U
  7619   "RTN","IBC OMD1",63,0 )
  7620    .S IBX=$P (IBDA0,U,2 ) S $P(IBT MP,U,2)=$S (IBX]"":$E ($$EXPAND^ IBTRE(36,1 ,IBX),1,20 ),1:"")_U
  7621   "RTN","IBC OMD1",64,0 )
  7622    .F IBX=1: 1:6 S IBTM P=IBTMP_$P (IBDA11,U, IBX)_U
  7623   "RTN","IBC OMD1",65,0 )
  7624    .S IBX=$P (IBTMP,U,7 ) S $P(IBT MP,U,7)=$S (IBX]"":$$ STATE^IBCF 2(IBX),1:" ")_U
  7625   "RTN","IBC OMD1",66,0 )
  7626    .S $P(IBT MP,U,9)=$P (IBDA13,U, 1)
  7627   "RTN","IBC OMD1",67,0 )
  7628    .S ^TMP(" IBCOMD",$J ,+$P(IBDA0 ,U,5),$S($ P(IBDA0,U, 1)]"":$P(I BDA0,U,1), 1:"ZZZZ"), +IBDA)=IBT MP
  7629   "RTN","IBC OMD1",68,0 )
  7630    ;
  7631   "RTN","IBC OMD1",69,0 )
  7632    I '$D(^TM P("IBCOMD" ,$J)) D HD  W !!,"**  NO RECORDS  FOUND **"  D ASK G Q UEQ
  7633   "RTN","IBC OMD1",70,0 )
  7634    D HD:IBOU T="E",WRT
  7635   "RTN","IBC OMD1",71,0 )
  7636    ;
  7637   "RTN","IBC OMD1",72,0 )
  7638    ; Exit cl ean-UP
  7639   "RTN","IBC OMD1",73,0 )
  7640   QUEQ K IBA IB,IBCASE, IBFLD,IBOU T,IBQUIT,^ TMP("IBCOM D",$J)
  7641   "RTN","IBC OMD1",74,0 )
  7642    I $D(ZTQU EUED) S ZT REQ="@" Q
  7643   "RTN","IBC OMD1",75,0 )
  7644    W ! D ^%Z ISC
  7645   "RTN","IBC OMD1",76,0 )
  7646    Q
  7647   "RTN","IBC OMD1",77,0 )
  7648    ;
  7649   "RTN","IBC OMD1",78,0 )
  7650    ;
  7651   "RTN","IBC OMD1",79,0 )
  7652   HD ; Write  Heading
  7653   "RTN","IBC OMD1",80,0 )
  7654    S IBPAGE= IBPAGE+1
  7655   "RTN","IBC OMD1",81,0 )
  7656    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets
  7657   "RTN","IBC OMD1",82,0 )
  7658    I IBOUT=" E" D  Q
  7659   "RTN","IBC OMD1",83,0 )
  7660    .W !,"Gen erate Insu rance Comp any Listin gs^"_$$FMT E^XLFDT($$ NOW^XLFDT, 1)
  7661   "RTN","IBC OMD1",84,0 )
  7662    .W !,"Lis t of ",$S( IBAIB=1:"A ctive",IBA IB=2:"Inac tive",1:"A ll")," Ins urance Com panies"
  7663   "RTN","IBC OMD1",85,0 )
  7664    .;
  7665   "RTN","IBC OMD1",86,0 )
  7666    .; - disp lay defini tion of sc reens
  7667   "RTN","IBC OMD1",87,0 )
  7668    .I $D(IBC ASE) W "^w here" D
  7669   "RTN","IBC OMD1",88,0 )
  7670    ..N I,H
  7671   "RTN","IBC OMD1",89,0 )
  7672    ..S (H,I) =0 F  S I= $O(IBCASE( I)) Q:'I   D
  7673   "RTN","IBC OMD1",90,0 )
  7674    ...I H W  "^and"
  7675   "RTN","IBC OMD1",91,0 )
  7676    ...S H=1  W "^"_IBFL D(I)
  7677   "RTN","IBC OMD1",92,0 )
  7678    ...W $S(I =4:"^Equal s ",$P(IBC ASE(I),"^" )="C":"^Co ntains ",1 :"^Between  ")
  7679   "RTN","IBC OMD1",93,0 )
  7680    ...W $S(I =4:$P($G(^ DIC(5,+$P( IBCASE(I), "^",2),0)) ,"^"),$P(I BCASE(I)," ^",2)="":" ^'FIRST'", 1:$P(IBCAS E(I),"^",2 ))
  7681   "RTN","IBC OMD1",94,0 )
  7682    ...I $P(I BCASE(I)," ^")="R" W  "^and ",$S ($P(IBCASE (I),"^",3) ="zzzzzz": "^'LAST'", 1:$P(IBCAS E(I),"^",3 )) ; **IB* 2.0*602
  7683   "RTN","IBC OMD1",95,0 )
  7684    .;
  7685   "RTN","IBC OMD1",96,0 )
  7686    .W !,"Act ive/Inacti ve^Insuran ce Name^Re imburse?^S treet Addr ess 1^Stre et Address  2^Street  Address 3^ City^State ^ZIP^Phone  Number"
  7687   "RTN","IBC OMD1",97,0 )
  7688    ; IB*602/ HN end 
  7689   "RTN","IBC OMD1",98,0 )
  7690    ;
  7691   "RTN","IBC OMD1",99,0 )
  7692    I IBOUT=" E" W:($E(I OST,1,2)[" C-") ! W " Active/Ina ctive^Insu rance Name ^Reimburse ?^Street A ddress 1^S treet Addr ess 2^Stre et Address  3^City^St ate^ZIP^Ph one Number " Q
  7693   "RTN","IBC OMD1",100, 0)
  7694    W @IOF,"G enerate In surance Co mpany List ings",?50, $$FMTE^XLF DT($$NOW^X LFDT,"Z"), ?70," Page  ",IBPAGE
  7695   "RTN","IBC OMD1",101, 0)
  7696    W !,"List  of ",$S(I BAIB=1:"Ac tive",IBAI B=2:"Inact ive",1:"Al l")," Insu rance Comp anies"
  7697   "RTN","IBC OMD1",102, 0)
  7698    ;
  7699   "RTN","IBC OMD1",103, 0)
  7700    ; - displ ay definit ion of scr eens
  7701   "RTN","IBC OMD1",104, 0)
  7702    I $D(IBCA SE) W ", w here" D
  7703   "RTN","IBC OMD1",105, 0)
  7704    .N I,H
  7705   "RTN","IBC OMD1",106, 0)
  7706    .S (H,I)= 0 F  S I=$ O(IBCASE(I )) Q:'I  D
  7707   "RTN","IBC OMD1",107, 0)
  7708    ..W ! I H  W ?3,"and "
  7709   "RTN","IBC OMD1",108, 0)
  7710    ..S H=1 W  ?8,IBFLD( I)," "
  7711   "RTN","IBC OMD1",109, 0)
  7712    ..W $S(I= 4:"Equals  ",$P(IBCAS E(I),"^")= "C":"Conta ins ",1:"B etween ")
  7713   "RTN","IBC OMD1",110, 0)
  7714    ..W $S(I= 4:$P($G(^D IC(5,+$P(I BCASE(I)," ^",2),0)), "^"),$P(IB CASE(I),"^ ",2)="":"' FIRST'",1: $P(IBCASE( I),"^",2))
  7715   "RTN","IBC OMD1",111, 0)
  7716    ..I $P(IB CASE(I),"^ ")="R" W "  and ",$S( $P(IBCASE( I),"^",3)= "zzzzzz":" 'LAST'",1: $P(IBCASE( I),"^",3))
  7717   "RTN","IBC OMD1",112, 0)
  7718    ;
  7719   "RTN","IBC OMD1",113, 0)
  7720    W !,"Insu rance Name /Address", ?33,"Reimb urse?",?56 ,"Phone Nu mber"
  7721   "RTN","IBC OMD1",114, 0)
  7722    W ! F IBX =1:1:79 W  "="
  7723   "RTN","IBC OMD1",115, 0)
  7724    Q
  7725   "RTN","IBC OMD1",116, 0)
  7726    ;
  7727   "RTN","IBC OMD1",117, 0)
  7728   WRT ; Writ e data lin es
  7729   "RTN","IBC OMD1",118, 0)
  7730    N IBA,IBN A,IBOFF,IB ACT,X,Y S  IBQUIT=0
  7731   "RTN","IBC OMD1",119, 0)
  7732    S IBA=""  F  S IBA=$ O(^TMP("IB COMD",$J,I BA)) Q:(IB A="")!(IBQ UIT=1)  D
  7733   "RTN","IBC OMD1",120, 0)
  7734    .I IBPAGE ,(IBOUT="R ") D ASK I  IBQUIT=1  Q
  7735   "RTN","IBC OMD1",121, 0)
  7736    .; Excel  Output
  7737   "RTN","IBC OMD1",122, 0)
  7738    .I IBOUT= "E" S IBAC T=$S(IBA=1 :"Inactive ",1:"Activ e")
  7739   "RTN","IBC OMD1",123, 0)
  7740    .; Report  Output
  7741   "RTN","IBC OMD1",124, 0)
  7742    .I IBOUT= "R" D HD W  !,$S(IBA= 1:"Inactiv e Companie s",1:"Acti ve Compani es"),!
  7743   "RTN","IBC OMD1",125, 0)
  7744    .S IBNA=" " F  S IBN A=$O(^TMP( "IBCOMD",$ J,IBA,IBNA )) Q:(IBNA ="")!(IBQU IT=1)  D
  7745   "RTN","IBC OMD1",126, 0)
  7746    ..S IBDA= "" F  S IB DA=$O(^TMP ("IBCOMD", $J,IBA,IBN A,IBDA)) Q :('IBDA)!( IBQUIT=1)   D
  7747   "RTN","IBC OMD1",127, 0)
  7748    ...S IBTM P=^TMP("IB COMD",$J,I BA,IBNA,IB DA)
  7749   "RTN","IBC OMD1",128, 0)
  7750    ...S IBOF F=$S($P(IB TMP,U,4)]" "!($P(IBTM P,U,5)]"") :7,1:6)
  7751   "RTN","IBC OMD1",129, 0)
  7752    ...I ($Y+ IBOFF)>IOS L,(IBOUT=" R") D  I I BQUIT=1 Q
  7753   "RTN","IBC OMD1",130, 0)
  7754    ....D ASK  I IBQUIT= 1 Q
  7755   "RTN","IBC OMD1",131, 0)
  7756    ....D HD
  7757   "RTN","IBC OMD1",132, 0)
  7758    ...S IBTM P=^TMP("IB COMD",$J,I BA,IBNA,IB DA)
  7759   "RTN","IBC OMD1",133, 0)
  7760    ...; Exce l Output
  7761   "RTN","IBC OMD1",134, 0)
  7762    ...I IBOU T="E" W !, IBACT_U_IB TMP Q
  7763   "RTN","IBC OMD1",135, 0)
  7764    ...; Repo rt Output
  7765   "RTN","IBC OMD1",136, 0)
  7766    ...W !!,$ P(IBTMP,U, 1),?33,$P( IBTMP,U,2) ,?56,$P(IB TMP,U,9)
  7767   "RTN","IBC OMD1",137, 0)
  7768    ...I $P(I BTMP,U,3)] "" W !,$P( IBTMP,U,3)
  7769   "RTN","IBC OMD1",138, 0)
  7770    ...I $P(I BTMP,U,4)] ""!($P(IBT MP,U,5)]"" ) W !,$P(I BTMP,U,4)  W:$P(IBTMP ,U,4)]""&( $P(IBTMP,U ,5)]"") ",  " W $P(IB TMP,U,5)
  7771   "RTN","IBC OMD1",139, 0)
  7772    ...W !,$P (IBTMP,U,6 ) W:$P(IBT MP,U,6)]"" &($P(IBTMP ,U,7)]"")  ", " W $P( IBTMP,U,7) ,"  ",$P(I BTMP,U,8)
  7773   "RTN","IBC OMD1",140, 0)
  7774    I 'IBQUIT  D ASK
  7775   "RTN","IBC OMD1",141, 0)
  7776    Q
  7777   "RTN","IBC OMD1",142, 0)
  7778    ;
  7779   "RTN","IBC OMD1",143, 0)
  7780   ASK ; Ask  to Continu e with dis play
  7781   "RTN","IBC OMD1",144, 0)
  7782    ; Returns  IBQUIT=1  if user Ti med out or  entered ^
  7783   "RTN","IBC OMD1",145, 0)
  7784    I $E(IOST ,1,2)'["C- " Q
  7785   "RTN","IBC OMD1",146, 0)
  7786    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,IBI,X,Y
  7787   "RTN","IBC OMD1",147, 0)
  7788    S DIR(0)= "E" D ^DIR
  7789   "RTN","IBC OMD1",148, 0)
  7790    I ($D(DIR UT))!($D(D UOUT)) S I BQUIT=1
  7791   "RTN","IBC OMD1",149, 0)
  7792    Q
  7793   "RTN","IBC OMN1")
  7794   0^10^B1827 1189^B1429 8599
  7795   "RTN","IBC OMN1",1,0)
  7796   IBCOMN1 ;A LB/CMS - P ATIENTS NO  COVERAGE  VERIFIED R EPORT (CON 'T);10-09- 98
  7797   "RTN","IBC OMN1",2,0)
  7798    ;;2.0;INT EGRATED BI LLING;**10 3,528,602* *;21-MAR-9 4;Build 22
  7799   "RTN","IBC OMN1",3,0)
  7800    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7801   "RTN","IBC OMN1",4,0)
  7802    Q
  7803   "RTN","IBC OMN1",5,0)
  7804    ;
  7805   "RTN","IBC OMN1",6,0)
  7806   BEG ; Entr y to run P atients w/ no Coverag e Verifica tion Repor t
  7807   "RTN","IBC OMN1",7,0)
  7808    ; Input v ariables:
  7809   "RTN","IBC OMN1",8,0)
  7810    ; IBAIB -  Required.     How to  sort
  7811   "RTN","IBC OMN1",9,0)
  7812    ;          1= Patien t Name Ran ge      2=  Terminal  Digit Rang e
  7813   "RTN","IBC OMN1",10,0 )
  7814    ;
  7815   "RTN","IBC OMN1",11,0 )
  7816    ; IBRF  -  Required.   Name or  Terminal D igit Range  Start val ue
  7817   "RTN","IBC OMN1",12,0 )
  7818    ; IBRL  -  Required.   Name or  Terminal D igit Range  Go to val ue
  7819   "RTN","IBC OMN1",13,0 )
  7820    ; IBBDT -  Required.   Begining  Verificat ion Date R ange
  7821   "RTN","IBC OMN1",14,0 )
  7822    ; IBEDT -  Required.   Ending V erificatio n Date Ran ge
  7823   "RTN","IBC OMN1",15,0 )
  7824    ; IBOUT -  Required.   Output f ormat
  7825   "RTN","IBC OMN1",16,0 )
  7826    ;          "R"= repo rt format         "E" = Excel fo rmat
  7827   "RTN","IBC OMN1",17,0 )
  7828    ;
  7829   "RTN","IBC OMN1",18,0 )
  7830    N DFN,IBD T,IBGP,IBI ,IBQUIT,IB PAGE,IBTMP ,IBTD,IBX, VA,VADM,VA ERR,X,Y
  7831   "RTN","IBC OMN1",19,0 )
  7832    ;
  7833   "RTN","IBC OMN1",20,0 )
  7834    I "^R^E^" '[(U_$G(IB OUT)_U) S  IBOUT="R"
  7835   "RTN","IBC OMN1",21,0 )
  7836    K ^TMP("I BCOMN",$J)  S IBPAGE= 0,IBQUIT=0
  7837   "RTN","IBC OMN1",22,0 )
  7838    S IBDT=IB BDT F  S I BDT=$O(^IB A(354,"AVD T",IBDT))  Q:('IBDT)! (IBDT>IBED T)  D
  7839   "RTN","IBC OMN1",23,0 )
  7840    .S DFN=0  F  S DFN=$ O(^IBA(354 ,"AVDT",IB DT,DFN)) Q :'DFN  D
  7841   "RTN","IBC OMN1",24,0 )
  7842    ..K VA,VA DM,VAERR,V APA
  7843   "RTN","IBC OMN1",25,0 )
  7844    ..D DEM^V ADPT,ADD^V ADPT
  7845   "RTN","IBC OMN1",26,0 )
  7846    ..;
  7847   "RTN","IBC OMN1",27,0 )
  7848    ..;  I Pt . name out  of range  quit
  7849   "RTN","IBC OMN1",28,0 )
  7850    ..S VADM( 1)=$P($G(V ADM(1)),U, 1) I VADM( 1)="" Q
  7851   "RTN","IBC OMN1",29,0 )
  7852    ..I IBAIB =1,VADM(1) ]IBRL Q
  7853   "RTN","IBC OMN1",30,0 )
  7854    ..I IBAIB =1,IBRF]VA DM(1) Q
  7855   "RTN","IBC OMN1",31,0 )
  7856    ..;
  7857   "RTN","IBC OMN1",32,0 )
  7858    ..;  I Te rminal Dig it out of  range quit
  7859   "RTN","IBC OMN1",33,0 )
  7860    ..I IBAIB =2 S IBTD= $$TERMDG^I BCONS2(DFN ) I (+IBTD >IBRL)!(IB RF>+IBTD)  Q
  7861   "RTN","IBC OMN1",34,0 )
  7862    ..;
  7863   "RTN","IBC OMN1",35,0 )
  7864    ..; Fix s ubscript e rror if te rminal dig it is null
  7865   "RTN","IBC OMN1",36,0 )
  7866    ..I IBAIB =2,IBTD=""  S IBTD="  "
  7867   "RTN","IBC OMN1",37,0 )
  7868    ..;
  7869   "RTN","IBC OMN1",38,0 )
  7870    ..;   set  data line , set glob al * if de ceased
  7871   "RTN","IBC OMN1",39,0 )
  7872    ..;S IBTM P=PT NAME^ SSN^AGE^DO B^HOME PHO NE^VERIFIC ATION NO C OV
  7873   "RTN","IBC OMN1",40,0 )
  7874    ..S IBTMP =$S($G(VAD M(6)):"*", 1:"")_VADM (1)_U_$P($ P(VADM(2), U,2),"-",3 )_U_+VADM( 4)_U_$$FMT E^XLFDT(VA DM(3),"5ZD ")_U_$P(VA PA(8),U,1) _U_$$FMTE^ XLFDT(IBDT ,"5ZD")
  7875   "RTN","IBC OMN1",41,0 )
  7876    ..S ^TMP( "IBCOMN",$ J,$S(IBAIB =2:IBTD,1: VADM(1)),D FN)=IBTMP
  7877   "RTN","IBC OMN1",42,0 )
  7878    ..;
  7879   "RTN","IBC OMN1",43,0 )
  7880    ;
  7881   "RTN","IBC OMN1",44,0 )
  7882    I '$D(^TM P("IBCOMN" ,$J)) D HD  W !!,"**  NO RECORDS  FOUND **"  D ASK G Q UEQ
  7883   "RTN","IBC OMN1",45,0 )
  7884    D HD,WRT
  7885   "RTN","IBC OMN1",46,0 )
  7886    ;
  7887   "RTN","IBC OMN1",47,0 )
  7888   QUEQ ; Exi t clean-UP
  7889   "RTN","IBC OMN1",48,0 )
  7890    W ! D ^%Z ISC K IBTM P,IBAIB,IB OUT,IBRF,I BRL,VA,VAE RR,VADM,VA PA,^TMP("I BCOMN",$J)
  7891   "RTN","IBC OMN1",49,0 )
  7892    Q
  7893   "RTN","IBC OMN1",50,0 )
  7894    ;
  7895   "RTN","IBC OMN1",51,0 )
  7896   HD ;Write  Heading
  7897   "RTN","IBC OMN1",52,0 )
  7898    S IBPAGE= IBPAGE+1
  7899   "RTN","IBC OMN1",53,0 )
  7900    ; IB*602/ HN ; Add r eport head ers to Exc el Spreads heets 
  7901   "RTN","IBC OMN1",54,0 )
  7902    I IBOUT=" E" D  W:($ E(IOST,1,2 )["C-") !  W "Patient  Name^SSN^ Age^DOB^Ph one^Verifi ed" Q
  7903   "RTN","IBC OMN1",55,0 )
  7904    .W !,"Pat ients w/No  Coverage  Verificati on Date Re port^"_$$F MTE^XLFDT( $$NOW^XLFD T,"Z")
  7905   "RTN","IBC OMN1",56,0 )
  7906    .W !,"Ver ification  Date Range : "_$$FMTE ^XLFDT(IBB DT,"Z")_"  to "_$$FMT E^XLFDT(IB EDT,"Z")
  7907   "RTN","IBC OMN1",57,0 )
  7908    .W !," So rted by: " _$S(IBAIB= 1:"Patient  Name",1:" Terminal D igit")_" R ange: "_$S (IBRF="A": "FIRST",1: IBRF)_" to  "_$S(IBRL ="zzzzzz": "LAST",1:I BRL)
  7909   "RTN","IBC OMN1",58,0 )
  7910    .W !,"(*  - Patient  Deceased)"
  7911   "RTN","IBC OMN1",59,0 )
  7912    ; IB*602/ HN end 
  7913   "RTN","IBC OMN1",60,0 )
  7914    I IBOUT=" E" W:($E(I OST,1,2)[" C-") ! W " Patient Na me^SSN^Age ^DOB^Phone ^Verified"  Q
  7915   "RTN","IBC OMN1",61,0 )
  7916    W @IOF,!, "Patients  w/No Cover age Verifi cation Dat e Report", ?50,$$FMTE ^XLFDT($$N OW^XLFDT," Z"),?70,"  Page ",IBP AGE
  7917   "RTN","IBC OMN1",62,0 )
  7918    W !,?5,"V erificatio n Date Ran ge: "_$$FM TE^XLFDT(I BBDT,"Z")_ " to "_$$F MTE^XLFDT( IBEDT,"Z")
  7919   "RTN","IBC OMN1",63,0 )
  7920    W !,?5,"   Sorted by : "_$S(IBA IB=1:"Pati ent Name", 1:"Termina l Digit")_ "  Range:  "_$S(IBRF= "A":"FIRST ",1:IBRF)_ " to "_$S( IBRL="zzzz zz":"LAST" ,1:IBRL)
  7921   "RTN","IBC OMN1",64,0 )
  7922    W !,?20," (*  - Pati ent Deceas ed)"
  7923   "RTN","IBC OMN1",65,0 )
  7924    W !,"Pati ent Name", ?31,"SSN", ?38,"Age", ?43,"DOB", ?55,"Phone ",?70,"Ver ified"
  7925   "RTN","IBC OMN1",66,0 )
  7926    W ! F IBX =1:1:79 W  "="
  7927   "RTN","IBC OMN1",67,0 )
  7928    Q
  7929   "RTN","IBC OMN1",68,0 )
  7930    ;
  7931   "RTN","IBC OMN1",69,0 )
  7932   WRT ;Write  data line s
  7933   "RTN","IBC OMN1",70,0 )
  7934    N IBA,IBD FN,IBPT,X, Y S IBQUIT =0
  7935   "RTN","IBC OMN1",71,0 )
  7936    S IBA=""  F  S IBA=$ O(^TMP("IB COMN",$J,I BA)) Q:(IB A="")!(IBQ UIT=1)  D
  7937   "RTN","IBC OMN1",72,0 )
  7938    .S IBDFN= 0 F  S IBD FN=$O(^TMP ("IBCOMN", $J,IBA,IBD FN)) Q:('I BDFN)!(IBQ UIT=1)  D
  7939   "RTN","IBC OMN1",73,0 )
  7940    ..S IBPT= $G(^TMP("I BCOMN",$J, IBA,IBDFN) )
  7941   "RTN","IBC OMN1",74,0 )
  7942    ..;
  7943   "RTN","IBC OMN1",75,0 )
  7944    ..I ($Y+5 )>IOSL,(IB OUT="R") D   I IBQUIT =1 Q
  7945   "RTN","IBC OMN1",76,0 )
  7946    ...D ASK  I IBQUIT=1  Q
  7947   "RTN","IBC OMN1",77,0 )
  7948    ...D HD
  7949   "RTN","IBC OMN1",78,0 )
  7950    ..;
  7951   "RTN","IBC OMN1",79,0 )
  7952    ..; Excel  Output
  7953   "RTN","IBC OMN1",80,0 )
  7954    ..I IBOUT ="E" W !,$ P(IBPT,U,1 )_U_$E($P( IBPT,U,1), 1,1)_$P(IB PT,U,2)_U_ $P(IBPT,U, 3,6) Q
  7955   "RTN","IBC OMN1",81,0 )
  7956    ..; Repor t Output
  7957   "RTN","IBC OMN1",82,0 )
  7958    ..W !,$E( $P(IBPT,U, 1),1,30),? 31,$E($P(I BPT,U,1),1 ,1),$P(IBP T,U,2),?38 ,$J($P(IBP T,U,3),3), ?43,$P(IBP T,U,4),?55 ,$E($P(IBP T,U,5),1,1 5),?70,$P( IBPT,U,6)
  7959   "RTN","IBC OMN1",83,0 )
  7960    ..;
  7961   "RTN","IBC OMN1",84,0 )
  7962    I 'IBQUIT  D ASK
  7963   "RTN","IBC OMN1",85,0 )
  7964    Q
  7965   "RTN","IBC OMN1",86,0 )
  7966    ;
  7967   "RTN","IBC OMN1",87,0 )
  7968   ASK ; Ask  to Continu e with dis play
  7969   "RTN","IBC OMN1",88,0 )
  7970    I $E(IOST ,1,2)'["C- " Q
  7971   "RTN","IBC OMN1",89,0 )
  7972    N DIR,DIR OUT,DIRUT, DTOUT,DUOU T,X,Y
  7973   "RTN","IBC OMN1",90,0 )
  7974    S DIR(0)= "E" D ^DIR
  7975   "RTN","IBC OMN1",91,0 )
  7976    I ($D(DIR UT))!($D(D UOUT)) S I BQUIT=1
  7977   "RTN","IBC OMN1",92,0 )
  7978    Q
  7979   "RTN","IBY 602PO")
  7980   0^17^B4368 7115^n/a
  7981   "RTN","IBY 602PO",1,0 )
  7982   IBY602PO ; EDE/DM - P ost-Instal lation for  IB*2.8*60 2 ; 23-MAR -2018
  7983   "RTN","IBY 602PO",2,0 )
  7984    ;;2.0;INT EGRATED BI LLING;**60 2**;09-AUG -2018;Buil d 22
  7985   "RTN","IBY 602PO",3,0 )
  7986    ;;Per VA  Directive  6402, this  routine s hould not  be modifie d.
  7987   "RTN","IBY 602PO",4,0 )
  7988    ;
  7989   "RTN","IBY 602PO",5,0 )
  7990   POST ; POS T ROUTINE( S)
  7991   "RTN","IBY 602PO",6,0 )
  7992    N IBXPD,X PDIDTOT
  7993   "RTN","IBY 602PO",7,0 )
  7994    S XPDIDTO T=1
  7995   "RTN","IBY 602PO",8,0 )
  7996    ;
  7997   "RTN","IBY 602PO",9,0 )
  7998    ; Task FI XTQ  
  7999   "RTN","IBY 602PO",10, 0)
  8000    D TSKFIXT Q(1)
  8001   "RTN","IBY 602PO",11, 0)
  8002    ;
  8003   "RTN","IBY 602PO",12, 0)
  8004    ; Done...
  8005   "RTN","IBY 602PO",13, 0)
  8006    D MES^XPD UTL("")
  8007   "RTN","IBY 602PO",14, 0)
  8008    D MES^XPD UTL("POST- Install Co mpleted.")
  8009   "RTN","IBY 602PO",15, 0)
  8010    Q
  8011   "RTN","IBY 602PO",16, 0)
  8012    ;
  8013   "RTN","IBY 602PO",17, 0)
  8014   TSKFIXTQ(I BXPD) ; ta sk the FIX TQ routine
  8015   "RTN","IBY 602PO",18, 0)
  8016    D BMES^XP DUTL(" STE P "_IBXPD_ " of "_XPD IDTOT)
  8017   "RTN","IBY 602PO",19, 0)
  8018    D MES^XPD UTL("----- --------")
  8019   "RTN","IBY 602PO",20, 0)
  8020    D MES^XPD UTL("Taski ng Examine /Clean IIV  Response  & IIV Tran smission Q ueue ... " )
  8021   "RTN","IBY 602PO",21, 0)
  8022    N MSG,ZTD ESC,ZTRTN, ZTQUEUED
  8023   "RTN","IBY 602PO",22, 0)
  8024    S ZTQUEUE D=1
  8025   "RTN","IBY 602PO",23, 0)
  8026    S ZTDESC= "IBCN EXAM INE #365 &  #365.1 FI LES"
  8027   "RTN","IBY 602PO",24, 0)
  8028    S ZTRTN=" FIXTQ^IBY6 02PO"
  8029   "RTN","IBY 602PO",25, 0)
  8030    S MSG=$$T ASK("T@200 0",ZTDESC, ZTRTN)
  8031   "RTN","IBY 602PO",26, 0)
  8032    D MES^XPD UTL(MSG)
  8033   "RTN","IBY 602PO",27, 0)
  8034    Q
  8035   "RTN","IBY 602PO",28, 0)
  8036    ;
  8037   "RTN","IBY 602PO",29, 0)
  8038   TASK(X,ZTD ESC,ZTRTN)  ;bypass f or queued  task
  8039   "RTN","IBY 602PO",30, 0)
  8040    N Y,IDT,X DT,TSK,MSG ,ZTIO,ZTSK ,%DT
  8041   "RTN","IBY 602PO",31, 0)
  8042    S %DT="FR "
  8043   "RTN","IBY 602PO",32, 0)
  8044    D ^%DT
  8045   "RTN","IBY 602PO",33, 0)
  8046    S IDT=Y D  DD^%DT S  XDT=Y
  8047   "RTN","IBY 602PO",34, 0)
  8048    ;
  8049   "RTN","IBY 602PO",35, 0)
  8050    ;Check if  task alre ady schedu led for da te/time
  8051   "RTN","IBY 602PO",36, 0)
  8052    S TSK=$$G ETTASK(IDT )
  8053   "RTN","IBY 602PO",37, 0)
  8054    I TSK D   Q MSG
  8055   "RTN","IBY 602PO",38, 0)
  8056    . S Y=$P( TSK,U,2) D  DD^%DT
  8057   "RTN","IBY 602PO",39, 0)
  8058    . S MSG="  Task (#"_ +TSK_") al ready sche duled to r un on "_Y
  8059   "RTN","IBY 602PO",40, 0)
  8060    ;
  8061   "RTN","IBY 602PO",41, 0)
  8062    ;Schedule  the task
  8063   "RTN","IBY 602PO",42, 0)
  8064    S TSK=$$S CHED(IDT)
  8065   "RTN","IBY 602PO",43, 0)
  8066    ;
  8067   "RTN","IBY 602PO",44, 0)
  8068    ;Check fo r scheduli ng problem
  8069   "RTN","IBY 602PO",45, 0)
  8070    I '$G(TSK ) S MSG="  Task Could  Not Be Sc heduled" Q  MSG
  8071   "RTN","IBY 602PO",46, 0)
  8072    ;
  8073   "RTN","IBY 602PO",47, 0)
  8074    ;Send suc cessful sc hedule mes sage
  8075   "RTN","IBY 602PO",48, 0)
  8076    S MSG=" E xamine/Cle an IIV Tra nsmission  Queue Sche duled for  "_XDT
  8077   "RTN","IBY 602PO",49, 0)
  8078    Q MSG
  8079   "RTN","IBY 602PO",50, 0)
  8080    ;
  8081   "RTN","IBY 602PO",51, 0)
  8082   GETTASK(ID T) ;
  8083   "RTN","IBY 602PO",52, 0)
  8084    N TASK,TA SKNO,TDT,X USUCI,Y,ZT SK0
  8085   "RTN","IBY 602PO",53, 0)
  8086    ;
  8087   "RTN","IBY 602PO",54, 0)
  8088    ;Retrieve  UCI
  8089   "RTN","IBY 602PO",55, 0)
  8090    X ^%ZOSF( "UCI") S X USUCI=Y
  8091   "RTN","IBY 602PO",56, 0)
  8092    ; 
  8093   "RTN","IBY 602PO",57, 0)
  8094    S (TASK,T DT)=0,TASK NO=""
  8095   "RTN","IBY 602PO",58, 0)
  8096    F  S TASK =$O(^%ZTSK (TASK)) Q: 'TASK  D   Q:TASKNO
  8097   "RTN","IBY 602PO",59, 0)
  8098    .I $G(^%Z TSK(TASK,. 03))[ZTDES C D
  8099   "RTN","IBY 602PO",60, 0)
  8100    ..S ZTSK0 =$G(^%ZTSK (TASK,0))
  8101   "RTN","IBY 602PO",61, 0)
  8102    ..;
  8103   "RTN","IBY 602PO",62, 0)
  8104    ..;Exclud e tasks sc heduled by  TaskMan
  8105   "RTN","IBY 602PO",63, 0)
  8106    ..Q:ZTSK0 ["ZTSK^XQ1 "
  8107   "RTN","IBY 602PO",64, 0)
  8108    ..;
  8109   "RTN","IBY 602PO",65, 0)
  8110    ..;Exclud e tasks in  other uci s
  8111   "RTN","IBY 602PO",66, 0)
  8112    ..Q:(($P( ZTSK0,U,11 )_","_$P(Z TSK0,U,12) )'=XUSUCI)
  8113   "RTN","IBY 602PO",67, 0)
  8114    ..;
  8115   "RTN","IBY 602PO",68, 0)
  8116    ..;Check  for correc t date and  time
  8117   "RTN","IBY 602PO",69, 0)
  8118    ..S TDT=$ $HTFM^XLFD T($P(ZTSK0 ,"^",6))
  8119   "RTN","IBY 602PO",70, 0)
  8120    ..;I TDT= IDT S TASK NO=TASK
  8121   "RTN","IBY 602PO",71, 0)
  8122    Q TASKNO_ U_TDT
  8123   "RTN","IBY 602PO",72, 0)
  8124    ;
  8125   "RTN","IBY 602PO",73, 0)
  8126   SCHED(ZTDT H) ;
  8127   "RTN","IBY 602PO",74, 0)
  8128    N XUSUCI, ZTIO,ZTSK
  8129   "RTN","IBY 602PO",75, 0)
  8130    ;Retrieve  UCI
  8131   "RTN","IBY 602PO",76, 0)
  8132    X ^%ZOSF( "UCI") S X USUCI=Y
  8133   "RTN","IBY 602PO",77, 0)
  8134    S ZTIO=""
  8135   "RTN","IBY 602PO",78, 0)
  8136    D ^%ZTLOA D
  8137   "RTN","IBY 602PO",79, 0)
  8138    Q ZTSK
  8139   "RTN","IBY 602PO",80, 0)
  8140    ;
  8141   "RTN","IBY 602PO",81, 0)
  8142   FIXTQ(IBXP D) ; clean /report ab normal IIV  TRANSMISS ION QUEUE  (#365.1) r ecords
  8143   "RTN","IBY 602PO",82, 0)
  8144    N DA,DIK, HLIEN,DNP, TQIEN,ENDD T,WKDT,WKZ Z
  8145   "RTN","IBY 602PO",83, 0)
  8146    N STATLIS T,STAGE,TC NT,ACNT,MC NT,DONE
  8147   "RTN","IBY 602PO",84, 0)
  8148    N BAD,TQS ,TQD,TQQ,M SG,IBXMY
  8149   "RTN","IBY 602PO",85, 0)
  8150    ;
  8151   "RTN","IBY 602PO",86, 0)
  8152    S STATLIS T=","_$$FI ND1^DIC(36 5.14,,"B", "Response  Received")
  8153   "RTN","IBY 602PO",87, 0)
  8154    S STATLIS T=STATLIST _","_$$FIN D1^DIC(365 .14,,"B"," Communicat ion Failur e")
  8155   "RTN","IBY 602PO",88, 0)
  8156    S STATLIS T=STATLIST _","_$$FIN D1^DIC(365 .14,,"B"," Cancelled" )_","
  8157   "RTN","IBY 602PO",89, 0)
  8158    S (TQIEN, TCNT,STAGE ,ACNT,MCNT ,DONE)=0
  8159   "RTN","IBY 602PO",90, 0)
  8160    S MSG=""
  8161   "RTN","IBY 602PO",91, 0)
  8162    S ENDDT=$ $FMADD^XLF DT(DT,-182 ) ; about  6 months
  8163   "RTN","IBY 602PO",92, 0)
  8164    ; STAGE=0 , delete a bnormal <  T-182
  8165   "RTN","IBY 602PO",93, 0)
  8166    ; STAGE=1 , report a bnormal fr om T-182 t hrough T-3 2
  8167   "RTN","IBY 602PO",94, 0)
  8168    ;
  8169   "RTN","IBY 602PO",95, 0)
  8170    D FIXRESP
  8171   "RTN","IBY 602PO",96, 0)
  8172    ;
  8173   "RTN","IBY 602PO",97, 0)
  8174    F  S TQIE N=$O(^IBCN (365.1,TQI EN)) Q:'TQ IEN!DONE!$ G(ZTSTOP)   D
  8175   "RTN","IBY 602PO",98, 0)
  8176    . S TCNT= TCNT+1
  8177   "RTN","IBY 602PO",99, 0)
  8178    . I $D(ZT QUEUED),TC NT#100=0,$ $S^%ZTLOAD () S ZTSTO P=1 Q
  8179   "RTN","IBY 602PO",100 ,0)
  8180    . S TQD=$ $GET1^DIQ( 365.1,TQIE N_",",.06, "I") ; DAT E/TIME CRE ATED
  8181   "RTN","IBY 602PO",101 ,0)
  8182    . S WKDT= +$P(TQD,". ",1)
  8183   "RTN","IBY 602PO",102 ,0)
  8184    . I WKDT> ENDDT,STAG E S DONE=1  Q
  8185   "RTN","IBY 602PO",103 ,0)
  8186    . I WKDT> ENDDT S ST AGE=1,ENDD T=$$FMADD^ XLFDT(DT,- 32)
  8187   "RTN","IBY 602PO",104 ,0)
  8188    . I WKDT> ENDDT S DO NE=1 Q 
  8189   "RTN","IBY 602PO",105 ,0)
  8190    . ; check  for abnor mal 
  8191   "RTN","IBY 602PO",106 ,0)
  8192    . S BAD=0
  8193   "RTN","IBY 602PO",107 ,0)
  8194    . S TQS=$ $GET1^DIQ( 365.1,TQIE N_",",.04, "I") ; TRA NSMISSION  STATUS
  8195   "RTN","IBY 602PO",108 ,0)
  8196    . S TQQ=$ $GET1^DIQ( 365.1,TQIE N_",",.11, "I") ; QUE RY FLAG 
  8197   "RTN","IBY 602PO",109 ,0)
  8198    . ; If th e QUERY FL AG IS "I"  and not an  EICD Tran saction en try will p urge/repor t.
  8199   "RTN","IBY 602PO",110 ,0)
  8200    . S:TQQ=" I"&'$D(^IB CN(365.18, "B",TQIEN) ) BAD=1
  8201   "RTN","IBY 602PO",111 ,0)
  8202    . ; If th e QUERY FL AG is null  OR the DA TE/TIME CR EATED is n ull or 
  8203   "RTN","IBY 602PO",112 ,0)
  8204    . ; TRANS MISSION ST ATUS not i n STATLIST  entry wil l purge/re port
  8205   "RTN","IBY 602PO",113 ,0)
  8206    . S:(TQQ= "")!('TQD) !('$F(STAT LIST,","_T QS_",")) B AD=1
  8207   "RTN","IBY 602PO",114 ,0)
  8208    . Q:'BAD
  8209   "RTN","IBY 602PO",115 ,0)
  8210    . I STAGE =0 D
  8211   "RTN","IBY 602PO",116 ,0)
  8212    .. ; loop  through t he HL7 mes sages mult iple and k ill any re sponse
  8213   "RTN","IBY 602PO",117 ,0)
  8214    .. ; reco rds that a re found f or this tr ansmission  queue ent ry.
  8215   "RTN","IBY 602PO",118 ,0)
  8216    .. ; Pres erve the T Q and any  response t hat has DO  NOT PURGE  set to 1  (YES) 
  8217   "RTN","IBY 602PO",119 ,0)
  8218    .. S DNP= 0,HLIEN=0, DIK="^IBCN (365,"
  8219   "RTN","IBY 602PO",120 ,0)
  8220    .. F  S H LIEN=$O(^I BCN(365.1, TQIEN,2,HL IEN)) Q:'H LIEN  D
  8221   "RTN","IBY 602PO",121 ,0)
  8222    ... S DA= $P($G(^IBC N(365.1,TQ IEN,2,HLIE N,0)),U,3)  Q:'DA
  8223   "RTN","IBY 602PO",122 ,0)
  8224    ... I +$$ GET1^DIQ(3 65,DA_",", .11,"I") S  DNP=1 Q 
  8225   "RTN","IBY 602PO",123 ,0)
  8226    ... D ^DI K
  8227   "RTN","IBY 602PO",124 ,0)
  8228    ... Q
  8229   "RTN","IBY 602PO",125 ,0)
  8230    .. ; now  we can kil l the TQ e ntry itsel
  8231   "RTN","IBY 602PO",126 ,0)
  8232    .. ; as l ong as the re was no  DO NOT PUR GE respons es
  8233   "RTN","IBY 602PO",127 ,0)
  8234    .. I 'DNP  S DA=TQIE N,DIK="^IB CN(365.1,"  D ^DIK
  8235   "RTN","IBY 602PO",128 ,0)
  8236    .. Q
  8237   "RTN","IBY 602PO",129 ,0)
  8238    . Q:'STAG E  ; not r eporting a bnormal ye t
  8239   "RTN","IBY 602PO",130 ,0)
  8240    . S ACNT= ACNT+1 ; a bnormal co unt 
  8241   "RTN","IBY 602PO",131 ,0)
  8242    . Q:MCNT> 9  ; msg c ount, only  want 10
  8243   "RTN","IBY 602PO",132 ,0)
  8244    . S MCNT= MCNT+1
  8245   "RTN","IBY 602PO",133 ,0)
  8246    . ;exampl e of a det ail line o n the emai
  8247   "RTN","IBY 602PO",134 ,0)
  8248    . ;FEB 22 , 2017@10: 44:08 T#:x xxxxxxxxx  *xxxxxxxxx xxxxxxxxxx xx *NO QFL AG 
  8249   "RTN","IBY 602PO",135 ,0)
  8250    . I 'TQD  S $E(MSG(M CNT+2),1)= "*NO DATE"
  8251   "RTN","IBY 602PO",136 ,0)
  8252    . I TQD S  $E(MSG(MC NT+2),1)=$ $GET1^DIQ( 365.1,TQIE N_",",.06, "E") ;DATE /TIME CREA TED
  8253   "RTN","IBY 602PO",137 ,0)
  8254    . S $E(MS G(MCNT+2), 23)="T#:"_ TQIEN
  8255   "RTN","IBY 602PO",138 ,0)
  8256    . I '$F(S TATLIST,", "_TQS_",")  S $E(MSG( MCNT+2),40 )=" *"_$$G ET1^DIQ(36 5.1,TQIEN_ ",",.04,"E ")
  8257   "RTN","IBY 602PO",139 ,0)
  8258    . S WKZZ= ""
  8259   "RTN","IBY 602PO",140 ,0)
  8260    . I TQQ=" " S WKZZ="  *NO QUERY  FLAG"
  8261   "RTN","IBY 602PO",141 ,0)
  8262    . I TQQ=" I" S WKZZ= " *QUERY F LAG: 'I'"
  8263   "RTN","IBY 602PO",142 ,0)
  8264    . S $E(MS G(MCNT+2), 60)=WKZZ
  8265   "RTN","IBY 602PO",143 ,0)
  8266    ; send ma ilman msg
  8267   "RTN","IBY 602PO",144 ,0)
  8268    S WKDT=$$ SITE^VASIT E()
  8269   "RTN","IBY 602PO",145 ,0)
  8270    S MSG(1)= "Patch IB* 2.0*602 Po st Install  Issue Sum mary for s tation "_$ P(WKDT,U,3 )_":"_$P(W KDT,U,2)
  8271   "RTN","IBY 602PO",146 ,0)
  8272    S MSG(2)= "--------- ---------- ---------- ---------- ---------- ---------- ---------- ---------- "
  8273   "RTN","IBY 602PO",147 ,0)
  8274    I 'ACNT S  MSG(3)="  NO ISSUES  FOUND"
  8275   "RTN","IBY 602PO",148 ,0)
  8276    I ACNT D
  8277   "RTN","IBY 602PO",149 ,0)
  8278    . S MSG(M CNT+3)=""
  8279   "RTN","IBY 602PO",150 ,0)
  8280    . S MSG(M CNT+4)="TO TAL ISSUES  DETECTED:  "_ACNT
  8281   "RTN","IBY 602PO",151 ,0)
  8282    S IBXMY(" PII                      ")=""
  8283   "RTN","IBY 602PO",152 ,0)
  8284    D MSG^IBC NEUT5(,"Pa tch IB*2.0 *602 Post  Install Is sue Summar y ("_$P(WK DT,U,3)_") ","MSG(",, .IBXMY)
  8285   "RTN","IBY 602PO",153 ,0)
  8286    ; Tell Ta skManager  to delete  the task's  record
  8287   "RTN","IBY 602PO",154 ,0)
  8288    I $D(ZTQU EUED) S ZT REQ="@"
  8289   "RTN","IBY 602PO",155 ,0)
  8290    Q
  8291   "RTN","IBY 602PO",156 ,0)
  8292    ;
  8293   "RTN","IBY 602PO",157 ,0)
  8294   FIXRESP ;P opulate Re sponse ent ries with  null date/ time creat ed.
  8295   "RTN","IBY 602PO",158 ,0)
  8296    N DIE,DR, DTM,RDTM,R IEN,RPDTM
  8297   "RTN","IBY 602PO",159 ,0)
  8298    S RIEN=0, RPDTM=$$FM ADD^XLFDT( DT,-182)
  8299   "RTN","IBY 602PO",160 ,0)
  8300    F  S RIEN =$O(^IBCN( 365,RIEN))  Q:'RIEN   D
  8301   "RTN","IBY 602PO",161 ,0)
  8302    . S TCNT= TCNT+1
  8303   "RTN","IBY 602PO",162 ,0)
  8304    . I $D(ZT QUEUED),TC NT#100=0,$ $S^%ZTLOAD () S ZTSTO P=1 Q
  8305   "RTN","IBY 602PO",163 ,0)
  8306    . ;
  8307   "RTN","IBY 602PO",164 ,0)
  8308    . S DTM=$ $GET1^DIQ( 365,RIEN_" ,",.08,"I" ) I DTM Q
  8309   "RTN","IBY 602PO",165 ,0)
  8310    . S RDTM= $$GET1^DIQ (365,RIEN_ ",",.07,"I ")
  8311   "RTN","IBY 602PO",166 ,0)
  8312    . I RDTM> RPDTM D
  8313   "RTN","IBY 602PO",167 ,0)
  8314    .. S ACNT =ACNT+1
  8315   "RTN","IBY 602PO",168 ,0)
  8316    .. I MCNT <6 D
  8317   "RTN","IBY 602PO",169 ,0)
  8318    ... S MCN T=MCNT+1
  8319   "RTN","IBY 602PO",170 ,0)
  8320    ... S $E( MSG(MCNT+2 ),1)="*NO  DATE/TIME  CR"
  8321   "RTN","IBY 602PO",171 ,0)
  8322    ... S $E( MSG(MCNT+2 ),23)="R#: "_$$GET1^D IQ(365,RIE N_",",.01)   ;MESSAGE  CONTROL I D
  8323   "RTN","IBY 602PO",172 ,0)
  8324    ... S $E( MSG(MCNT+2 ),40)=" *" _$$GET1^DI Q(365,RIEN _",",.06)   ;TRANSMIS SION STATU S
  8325   "RTN","IBY 602PO",173 ,0)
  8326    ... S $E( MSG(MCNT+2 ),60)=" *" _$$GET1^DI Q(365,RIEN _",",.1) ; RESPONSE T YPE
  8327   "RTN","IBY 602PO",174 ,0)
  8328    . S DTM=$ S(RDTM:RDT M,1:"NOW")
  8329   "RTN","IBY 602PO",175 ,0)
  8330    . S DIE=3 65,DA=RIEN ,DR=".08// /"_DTM
  8331   "RTN","IBY 602PO",176 ,0)
  8332    . D ^DIE
  8333   "RTN","IBY 602PO",177 ,0)
  8334    Q
  8335   "RTN","IBY 602PO",178 ,0)
  8336    ;
  8337   "VER")
  8338   8.0^22.2
  8339   "BLD",1110 5,6)
  8340   12^
  8341   $END KID I B*2.0*602