IBCNOR3 ;AITC/DTG - IBCN EDI PAYER ID REPT ;10/18/23
;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
;;Per VA Directive 6402, this routine should not be modified.
;
; Reference to EN^XUTMDEVQ in ICR #1519
;
Q
;
EN ; entry point
;
N DIR,IBAR,IBCK,IBCNT,IBI,IBID,IBOK,IBOUT,IBSTOP,IBXSAV,POP,X,Y
K ^TMP("IBCNOR3",$J) S ^TMP("IBCNOR3",$J,0)=""
W:$G(IOF)'="" @IOF W:$G(IOF)="" !
W !,"This report allows the user to identify Insurance Companies with a specific",!,"EDI Payer ID."
; get edi number
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
ENRK ; come here if continue from ^ response
K ^TMP("IBCNOR3",$J) S ^TMP("IBCNOR3",$J,0)=""
ENR ; ask question return point.
W !
S IBCNT=0
S DIR(0)="F^1:30"
S DIR("A")="Please Enter an EDI Payer ID"
S DIR("?",1)="Enter an EDI Payer ID (Includes: PROFESSIONAL, INSTITUTIONAL, and/or"
S DIR("?")="DENTAL Number) from 1 to 30 characters or '^' to quit."
S IBOK=0
ENAQ ;
D ^DIR
I $E(Y,1)=" " S IBOK=0 D I 'IBOK S Y="" W !,"This is a required response. Enter '^' to exit" G ENAQ
. F IBI=1:1:$L(Y) I $E(Y,IBI)'=" " S IBOK=1 Q
I $E(Y)=U!$D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S Y="^"
D ISET
I $E(Y)=U G EXIT
;
S IBSTOP=0 D OUT I IBSTOP G:$$STOP EXIT G ENRK
;
D DEVICE
G EXIT
;
ISET ; if item save and set flag
;
N IBA,IBC,IBD,IBE
I Y=""!($E(Y)=U) Q ; leave IBOK 0 in order to stop
S IBOK=1,IBFND=0
S IBA=$G(^TMP("IBCNOR3",$J,1,Y))
I IBA W *7," EDI Payer ID already selected" Q
S ^TMP("IBCNOR3",$J,1,Y)=1,IBCNT=IBCNT+1,^TMP("IBCNOR3",$J,0)=IBCNT
Q
;
;
OUT ; Prompt to allow users to select output format
; Returns: E - Output to excel
; R - Output to report
; IBSTOP=1 - No Selection made
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
W !
S DIR(0)="SA^E:Excel;R:Report"
S DIR("A")="(E)xcel Format or (R)eport Format: "
S DIR("B")="Report"
S DIR("?",1)="Select 'E' to create CSV output for import into Excel."
S DIR("?")="Select 'R' to create a standard report."
D ^DIR K DIR
I $D(DIROUT)!$D(DIRUT)!$D(DTOUT)!$D(DUOUT) S IBSTOP=1 G OUTQ
S IBOUT=Y
Q
OUTQ ;
;
Q
;
EXIT ; quit point
;
K ^TMP("IBCNOR3",$J)
Q
;
DEVICE ;
N DIR,IBB,IBC,IBJOB,POP,ZTDESC,ZTRTN,ZTSAVE
I IBOUT="R" W !!,"You will need a 132 column printer for this report.",!
I IBOUT="E" D
. W !!,"For CSV output, turn logging or capture on now.",!
. W "To avoid undesired wrapping of the data, please"
. W !," enter '0;256;99999'.",!
K IBXSAV M IBXSAV=^TMP("IBCNOR3",$J)
S ZTRTN="COMPILE^IBCNOR3"
S ZTDESC="EP - EDI Payer ID Report"
F IBB="IBOUT","IBC","IBXSAV(" S ZTSAVE(IBB)=""
D EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q") ; ICR # 1519
;
Q
;
;
COMPILE ; build output of payers
;
N %,IB36,IBADDR,IBARY,IBCHK,IBCTY,IBCRT,IBDASHES,IBEORMSG,IBFILTER,IBHDR
N IBHDRDATE,IBHDRNAME,IBINDX,IBITM,IBL,IBLOOK,IBLNC,IBMAXCNT,IBNM,IBNONEMSG
N IBPGC,IBSPACES,IBST,IBSTAB,IBSTOP,IBSTREET,IBUN,IBW,IBXTFEED,IBZIP
;
S IBOUT=$G(IBOUT),IBC=$G(IBC)
S IBCHK=0
S IBMAXCNT=IOSL-3,IBXTFEED=21,IBCRT=1,IBLNC=0
I IOST'["C-" S IBMAXCNT=IOSL-6,IBXTFEED=50,IBCRT=0
S IBEORMSG="*** End of Report ***"
S IBNONEMSG="* * * N o D a t a F o u n d * * *"
S IBHDRNAME="EDI PAYER ID REPORT"
D NOW^%DTC
S IBHDRDATE=$$DAT2^IBOUTL($E(%,1,12))
S $P(IBDASHES,"-",132)=""
S $P(IBSPACES," ",80)=""
S IBHDR="HDR"_$S(IBOUT="E":"E",1:"R")
K ^TMP($J,"IBCNOR3")
K ^TMP($J,"IBCNOR3-1")
K IBFND
M ^TMP($J,"IBCNOR3")=IBXSAV
;
;compile
;
I IBCRT W !,"Checking Insurance Companies for the EDI Payer number(s)",!
S IBFILTER="SELECTED: "
S IBLOOK="",IBCHK=0
; get ID add to display and make uppercase
F S IBLOOK=$O(^TMP($J,"IBCNOR3",1,IBLOOK)) Q:IBLOOK="" D S IBCHK=IBCHK+1
. S IBFILTER=IBFILTER_($S('+IBCHK:"",1:", "))_IBLOOK,IBUN=$$UP^XLFSTR(IBLOOK),^TMP($J,"IBCNOR3",2,IBUN)=1
D WALK
;
PRINT ; out put the compile in insurance co name order
;
N IBFIL
S IBFIL="," S:$G(IBOUT)="R" IBFIL=IBFIL_" "
K IBW,IBARY
S IBPGC=0
I '+$G(^TMP($J,"IBCNOR3-1",2)) D NOD G EXITC
D:IBOUT="E" HDRE D:IBOUT="R" HDRR
S IBSTOP=0,IBNM="" F S IBNM=$O(^TMP($J,"IBCNOR3-1",1,IBNM)) Q:IBNM="" D Q:IBSTOP
. S IBSTREET="" F S IBSTREET=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET)) Q:IBSTREET="" D Q:IBSTOP
.. S IBCTY="" F S IBCTY=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY)) Q:IBCTY="" D Q:IBSTOP
... S IBSTAB="" F S IBSTAB=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB)) Q:IBSTAB="" D Q:IBSTOP
.... S IBZIP="" F S IBZIP=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP)) Q:IBZIP="" D Q:IBSTOP
..... S IB36="" F S IB36=$O(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36)) Q:'IB36 D Q:IBSTOP
...... S IBW=$G(^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36))
...... S IBADDR=$S(IBSTREET'=" ":IBSTREET,1:"")_IBFIL_$S(IBCTY'=" ":IBCTY,1:"")_IBFIL
...... S IBADDR=IBADDR_$S(IBSTAB'=" ":IBSTAB,1:"")_IBFIL_$S(IBZIP'=" ":IBZIP,1:"")
...... I IBOUT="E" D Q
....... W !,IBNM,U,IBADDR,U,IBW
...... I IBOUT="R" D
....... W !,IBNM,?32,$P(IBW,U,1),?64,$P(IBW,U,2),?96,$P(IBW,U,3),?128,$P(IBW,U,4)
....... W !," ",IBADDR
....... S IBLNC=IBLNC+2 I (IBPGC>0),(IBLNC+2>IBMAXCNT) D
........ D QLINE Q:IBSTOP
........ D:IBOUT="E" HDRE D:IBOUT="R" HDRR
I IBSTOP G EXITC
W !,IBEORMSG
D QLINE
G EXITC
;
NOD ; no info to print
;
D:IBOUT="E" HDRE D:IBOUT="R" HDRR
W !,IBNONEMSG,!,IBEORMSG
D QLINE
Q
;
QLINE ; cr to continue
;
N DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN
W !
I 'IBCRT Q
S DIR(0)="E" D ^DIR K DIR
I $D(DTOUT)!$D(DUOUT) S IBSTOP=1
Q
;
WALK ; walk the indexes
;
N IB36,IBARY,IBCHK,IBCK,IBCKA,IBCTY,IBI,IBNM,IBS,IBST,IBSTAB,IIBSTREET,IBW,IBZIP
S IB36=0,IBCHK=0 F S IB36=$O(^DIC(36,IB36)) Q:'IB36 D
. S IBCHK=IBCHK+1 I IBCRT&(IBCHK#500=0) W "."
. I '$D(^DIC(36,IB36,0)) Q ; zero record not found
. I $D(^TMP($J,"IBCNOR3-1",0,IB36)) Q ; already picked up. the same edi number can be used multiple times
. K IBARY D GETS^DIQ(36,IB36_",",".01;.05;.111;.114;.115;.116;3.02;3.04;3.15","IE","IBARY")
. K IBW M IBW=IBARY(36,IB36_",")
. ; check if in array
. S IBCKA=0
. F IBI=$G(IBW(3.02,"I")),$G(IBW(3.04,"I")),$G(IBW(3.15,"I")) D Q:IBCKA
.. I IBI=""!(IBI=" ") Q
.. S IBCK=$$UP^XLFSTR(IBI)
.. I '$D(^TMP($J,"IBCNOR3",2,IBCK)) Q
.. S ^TMP($J,"IBCNOR3-1",0,IB36)=1
.. S IBNM=$G(IBW(.01,"E")),IBSTREET=$G(IBW(.111,"E")),IBCTY=$G(IBW(.114,"E"))
.. S IBST=$G(IBW(.115,"I")),IBZIP=$G(IBW(.116,"E"))
.. S IBSTAB="" I IBST S IBSTAB=$$GET1^DIQ(5,IBST_",","1","I")
.. S:IBNM="" IBNM=" " S:IBSTREET="" IBSTREET=" "
.. S:IBCTY="" IBCTY=" " S:IBSTAB="" IBSTAB=" " S:IBZIP="" IBZIP=" "
.. S IBS=$G(IBW(3.02,"I"))_U_$G(IBW(3.04,"I"))_U_$G(IBW(3.15,"I"))_U_$S('$G(IBW(.05,"I")):"A",1:"I")
.. S ^TMP($J,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36)=IBS
.. S ^TMP($J,"IBCNOR3-1",2)=$G(^TMP($J,"IBCNOR3-1",2))+1
.. S IBCKA=1
Q
;
HDRE ; excel header
;
W !,IBHDRNAME,U,IBHDRDATE
W !,IBFILTER
W !,"INSURANCE COMPANY"_U_"ADDRESS"_U_"PROFESSIONAL ID"_U_"INSTITUTIONAL ID"_U_"DENTAL ID"_U_"A/I"
;
Q
;
HDRR ; report header
;
N IBA,IBF,IBG
S IBPGC=$G(IBPGC)+1 I IBCRT W:$G(IOF)'="" @IOF W:$G(IOF)="" !
I 'IBCRT W !
S IBA=$E(IBSPACES,1,(6-$L(IBPGC)))_IBPGC,IBLNC=6
W IBHDRNAME,?90,IBHDRDATE,?119,"Page: ",IBA,!
S IBLNC=5 W IBFILTER,!!
W "INSURANCE COMPANY",?32,"PROFESSIONAL ID",?64,"INSTITUTIONAL ID",?96,"DENTAL ID",?128,"A/I"
W !,$E(IBDASHES,1,132)
Q
;
EXITC ; compile section exit
;
K ^TMP($J,"IBCNOR3-1")
K ^TMP($J,"IBCNOR3")
Q
;
STOP() ; Determine if user wants to exit out of the whole option
; Initialize Variables
N DIR,DIRUT,X,Y
W !
S DIR(0)="Y"
S DIR("A")="Do you want to exit out of this option entirely"
S DIR("B")="YES"
S DIR("?",1)=" Enter YES to immediately exit out of this option."
S DIR("?")=" Enter NO to return to the previous question."
D ^DIR K DIR
I $D(DIRUT)!$D(DIROUT)!$D(DTOUT)!$D(DUOUT) S (IBSTOP,Y)=1 G STOPX
I 'Y S IBSTOP=0
STOPX ; STOP Exit Point
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNOR3 8063 printed Sep 23, 2025@19:52:20 Page 2
IBCNOR3 ;AITC/DTG - IBCN EDI PAYER ID REPT ;10/18/23
+1 ;;2.0;INTEGRATED BILLING;**778**;21-MAR-94;Build 28
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; Reference to EN^XUTMDEVQ in ICR #1519
+5 ;
+6 QUIT
+7 ;
EN ; entry point
+1 ;
+2 NEW DIR,IBAR,IBCK,IBCNT,IBI,IBID,IBOK,IBOUT,IBSTOP,IBXSAV,POP,X,Y
+3 KILL ^TMP("IBCNOR3",$JOB)
SET ^TMP("IBCNOR3",$JOB,0)=""
+4 if $GET(IOF)'=""
WRITE @IOF
if $GET(IOF)=""
WRITE !
+5 WRITE !,"This report allows the user to identify Insurance Companies with a specific",!,"EDI Payer ID."
+6 ; get edi number
+7 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
ENRK ; come here if continue from ^ response
+1 KILL ^TMP("IBCNOR3",$JOB)
SET ^TMP("IBCNOR3",$JOB,0)=""
ENR ; ask question return point.
+1 WRITE !
+2 SET IBCNT=0
+3 SET DIR(0)="F^1:30"
+4 SET DIR("A")="Please Enter an EDI Payer ID"
+5 SET DIR("?",1)="Enter an EDI Payer ID (Includes: PROFESSIONAL, INSTITUTIONAL, and/or"
+6 SET DIR("?")="DENTAL Number) from 1 to 30 characters or '^' to quit."
+7 SET IBOK=0
ENAQ ;
+1 DO ^DIR
+2 IF $EXTRACT(Y,1)=" "
SET IBOK=0
Begin DoDot:1
+3 FOR IBI=1:1:$LENGTH(Y)
IF $EXTRACT(Y,IBI)'=" "
SET IBOK=1
QUIT
End DoDot:1
IF 'IBOK
SET Y=""
WRITE !,"This is a required response. Enter '^' to exit"
GOTO ENAQ
+4 IF $EXTRACT(Y)=U!$DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET Y="^"
+5 DO ISET
+6 IF $EXTRACT(Y)=U
GOTO EXIT
+7 ;
+8 SET IBSTOP=0
DO OUT
IF IBSTOP
if $$STOP
GOTO EXIT
GOTO ENRK
+9 ;
+10 DO DEVICE
+11 GOTO EXIT
+12 ;
ISET ; if item save and set flag
+1 ;
+2 NEW IBA,IBC,IBD,IBE
+3 ; leave IBOK 0 in order to stop
IF Y=""!($EXTRACT(Y)=U)
QUIT
+4 SET IBOK=1
SET IBFND=0
+5 SET IBA=$GET(^TMP("IBCNOR3",$JOB,1,Y))
+6 IF IBA
WRITE *7," EDI Payer ID already selected"
QUIT
+7 SET ^TMP("IBCNOR3",$JOB,1,Y)=1
SET IBCNT=IBCNT+1
SET ^TMP("IBCNOR3",$JOB,0)=IBCNT
+8 QUIT
+9 ;
+10 ;
OUT ; Prompt to allow users to select output format
+1 ; Returns: E - Output to excel
+2 ; R - Output to report
+3 ; IBSTOP=1 - No Selection made
+4 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,Y
+5 WRITE !
+6 SET DIR(0)="SA^E:Excel;R:Report"
+7 SET DIR("A")="(E)xcel Format or (R)eport Format: "
+8 SET DIR("B")="Report"
+9 SET DIR("?",1)="Select 'E' to create CSV output for import into Excel."
+10 SET DIR("?")="Select 'R' to create a standard report."
+11 DO ^DIR
KILL DIR
+12 IF $DATA(DIROUT)!$DATA(DIRUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET IBSTOP=1
GOTO OUTQ
+13 SET IBOUT=Y
+14 QUIT
OUTQ ;
+1 ;
+2 QUIT
+3 ;
EXIT ; quit point
+1 ;
+2 KILL ^TMP("IBCNOR3",$JOB)
+3 QUIT
+4 ;
DEVICE ;
+1 NEW DIR,IBB,IBC,IBJOB,POP,ZTDESC,ZTRTN,ZTSAVE
+2 IF IBOUT="R"
WRITE !!,"You will need a 132 column printer for this report.",!
+3 IF IBOUT="E"
Begin DoDot:1
+4 WRITE !!,"For CSV output, turn logging or capture on now.",!
+5 WRITE "To avoid undesired wrapping of the data, please"
+6 WRITE !," enter '0;256;99999'.",!
End DoDot:1
+7 KILL IBXSAV
MERGE IBXSAV=^TMP("IBCNOR3",$JOB)
+8 SET ZTRTN="COMPILE^IBCNOR3"
+9 SET ZTDESC="EP - EDI Payer ID Report"
+10 FOR IBB="IBOUT","IBC","IBXSAV("
SET ZTSAVE(IBB)=""
+11 ; ICR # 1519
DO EN^XUTMDEVQ(ZTRTN,ZTDESC,.ZTSAVE,"Q")
+12 ;
+13 QUIT
+14 ;
+15 ;
COMPILE ; build output of payers
+1 ;
+2 NEW %,IB36,IBADDR,IBARY,IBCHK,IBCTY,IBCRT,IBDASHES,IBEORMSG,IBFILTER,IBHDR
+3 NEW IBHDRDATE,IBHDRNAME,IBINDX,IBITM,IBL,IBLOOK,IBLNC,IBMAXCNT,IBNM,IBNONEMSG
+4 NEW IBPGC,IBSPACES,IBST,IBSTAB,IBSTOP,IBSTREET,IBUN,IBW,IBXTFEED,IBZIP
+5 ;
+6 SET IBOUT=$GET(IBOUT)
SET IBC=$GET(IBC)
+7 SET IBCHK=0
+8 SET IBMAXCNT=IOSL-3
SET IBXTFEED=21
SET IBCRT=1
SET IBLNC=0
+9 IF IOST'["C-"
SET IBMAXCNT=IOSL-6
SET IBXTFEED=50
SET IBCRT=0
+10 SET IBEORMSG="*** End of Report ***"
+11 SET IBNONEMSG="* * * N o D a t a F o u n d * * *"
+12 SET IBHDRNAME="EDI PAYER ID REPORT"
+13 DO NOW^%DTC
+14 SET IBHDRDATE=$$DAT2^IBOUTL($EXTRACT(%,1,12))
+15 SET $PIECE(IBDASHES,"-",132)=""
+16 SET $PIECE(IBSPACES," ",80)=""
+17 SET IBHDR="HDR"_$SELECT(IBOUT="E":"E",1:"R")
+18 KILL ^TMP($JOB,"IBCNOR3")
+19 KILL ^TMP($JOB,"IBCNOR3-1")
+20 KILL IBFND
+21 MERGE ^TMP($JOB,"IBCNOR3")=IBXSAV
+22 ;
+23 ;compile
+24 ;
+25 IF IBCRT
WRITE !,"Checking Insurance Companies for the EDI Payer number(s)",!
+26 SET IBFILTER="SELECTED: "
+27 SET IBLOOK=""
SET IBCHK=0
+28 ; get ID add to display and make uppercase
+29 FOR
SET IBLOOK=$ORDER(^TMP($JOB,"IBCNOR3",1,IBLOOK))
if IBLOOK=""
QUIT
Begin DoDot:1
+30 SET IBFILTER=IBFILTER_($SELECT('+IBCHK:"",1:", "))_IBLOOK
SET IBUN=$$UP^XLFSTR(IBLOOK)
SET ^TMP($JOB,"IBCNOR3",2,IBUN)=1
End DoDot:1
SET IBCHK=IBCHK+1
+31 DO WALK
+32 ;
PRINT ; out put the compile in insurance co name order
+1 ;
+2 NEW IBFIL
+3 SET IBFIL=","
if $GET(IBOUT)="R"
SET IBFIL=IBFIL_" "
+4 KILL IBW,IBARY
+5 SET IBPGC=0
+6 IF '+$GET(^TMP($JOB,"IBCNOR3-1",2))
DO NOD
GOTO EXITC
+7 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+8 SET IBSTOP=0
SET IBNM=""
FOR
SET IBNM=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM))
if IBNM=""
QUIT
Begin DoDot:1
+9 SET IBSTREET=""
FOR
SET IBSTREET=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET))
if IBSTREET=""
QUIT
Begin DoDot:2
+10 SET IBCTY=""
FOR
SET IBCTY=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY))
if IBCTY=""
QUIT
Begin DoDot:3
+11 SET IBSTAB=""
FOR
SET IBSTAB=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB))
if IBSTAB=""
QUIT
Begin DoDot:4
+12 SET IBZIP=""
FOR
SET IBZIP=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP))
if IBZIP=""
QUIT
Begin DoDot:5
+13 SET IB36=""
FOR
SET IB36=$ORDER(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36))
if 'IB36
QUIT
Begin DoDot:6
+14 SET IBW=$GET(^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36))
+15 SET IBADDR=$SELECT(IBSTREET'=" ":IBSTREET,1:"")_IBFIL_$SELECT(IBCTY'=" ":IBCTY,1:"")_IBFIL
+16 SET IBADDR=IBADDR_$SELECT(IBSTAB'=" ":IBSTAB,1:"")_IBFIL_$SELECT(IBZIP'=" ":IBZIP,1:"")
+17 IF IBOUT="E"
Begin DoDot:7
+18 WRITE !,IBNM,U,IBADDR,U,IBW
End DoDot:7
QUIT
+19 IF IBOUT="R"
Begin DoDot:7
+20 WRITE !,IBNM,?32,$PIECE(IBW,U,1),?64,$PIECE(IBW,U,2),?96,$PIECE(IBW,U,3),?128,$PIECE(IBW,U,4)
+21 WRITE !," ",IBADDR
+22 SET IBLNC=IBLNC+2
IF (IBPGC>0)
IF (IBLNC+2>IBMAXCNT)
Begin DoDot:8
+23 DO QLINE
if IBSTOP
QUIT
+24 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
End DoDot:8
End DoDot:7
End DoDot:6
if IBSTOP
QUIT
End DoDot:5
if IBSTOP
QUIT
End DoDot:4
if IBSTOP
QUIT
End DoDot:3
if IBSTOP
QUIT
End DoDot:2
if IBSTOP
QUIT
End DoDot:1
if IBSTOP
QUIT
+25 IF IBSTOP
GOTO EXITC
+26 WRITE !,IBEORMSG
+27 DO QLINE
+28 GOTO EXITC
+29 ;
NOD ; no info to print
+1 ;
+2 if IBOUT="E"
DO HDRE
if IBOUT="R"
DO HDRR
+3 WRITE !,IBNONEMSG,!,IBEORMSG
+4 DO QLINE
+5 QUIT
+6 ;
QLINE ; cr to continue
+1 ;
+2 NEW DIR,DIROUT,DIRUT,DTOUT,DUOUT,LIN
+3 WRITE !
+4 IF 'IBCRT
QUIT
+5 SET DIR(0)="E"
DO ^DIR
KILL DIR
+6 IF $DATA(DTOUT)!$DATA(DUOUT)
SET IBSTOP=1
+7 QUIT
+8 ;
WALK ; walk the indexes
+1 ;
+2 NEW IB36,IBARY,IBCHK,IBCK,IBCKA,IBCTY,IBI,IBNM,IBS,IBST,IBSTAB,IIBSTREET,IBW,IBZIP
+3 SET IB36=0
SET IBCHK=0
FOR
SET IB36=$ORDER(^DIC(36,IB36))
if 'IB36
QUIT
Begin DoDot:1
+4 SET IBCHK=IBCHK+1
IF IBCRT&(IBCHK#500=0)
WRITE "."
+5 ; zero record not found
IF '$DATA(^DIC(36,IB36,0))
QUIT
+6 ; already picked up. the same edi number can be used multiple times
IF $DATA(^TMP($JOB,"IBCNOR3-1",0,IB36))
QUIT
+7 KILL IBARY
DO GETS^DIQ(36,IB36_",",".01;.05;.111;.114;.115;.116;3.02;3.04;3.15","IE","IBARY")
+8 KILL IBW
MERGE IBW=IBARY(36,IB36_",")
+9 ; check if in array
+10 SET IBCKA=0
+11 FOR IBI=$GET(IBW(3.02,"I")),$GET(IBW(3.04,"I")),$GET(IBW(3.15,"I"))
Begin DoDot:2
+12 IF IBI=""!(IBI=" ")
QUIT
+13 SET IBCK=$$UP^XLFSTR(IBI)
+14 IF '$DATA(^TMP($JOB,"IBCNOR3",2,IBCK))
QUIT
+15 SET ^TMP($JOB,"IBCNOR3-1",0,IB36)=1
+16 SET IBNM=$GET(IBW(.01,"E"))
SET IBSTREET=$GET(IBW(.111,"E"))
SET IBCTY=$GET(IBW(.114,"E"))
+17 SET IBST=$GET(IBW(.115,"I"))
SET IBZIP=$GET(IBW(.116,"E"))
+18 SET IBSTAB=""
IF IBST
SET IBSTAB=$$GET1^DIQ(5,IBST_",","1","I")
+19 if IBNM=""
SET IBNM=" "
if IBSTREET=""
SET IBSTREET=" "
+20 if IBCTY=""
SET IBCTY=" "
if IBSTAB=""
SET IBSTAB=" "
if IBZIP=""
SET IBZIP=" "
+21 SET IBS=$GET(IBW(3.02,"I"))_U_$GET(IBW(3.04,"I"))_U_$GET(IBW(3.15,"I"))_U_$SELECT('$GET(IBW(.05,"I")):"A",1:"I")
+22 SET ^TMP($JOB,"IBCNOR3-1",1,IBNM,IBSTREET,IBCTY,IBSTAB,IBZIP,IB36)=IBS
+23 SET ^TMP($JOB,"IBCNOR3-1",2)=$GET(^TMP($JOB,"IBCNOR3-1",2))+1
+24 SET IBCKA=1
End DoDot:2
if IBCKA
QUIT
End DoDot:1
+25 QUIT
+26 ;
HDRE ; excel header
+1 ;
+2 WRITE !,IBHDRNAME,U,IBHDRDATE
+3 WRITE !,IBFILTER
+4 WRITE !,"INSURANCE COMPANY"_U_"ADDRESS"_U_"PROFESSIONAL ID"_U_"INSTITUTIONAL ID"_U_"DENTAL ID"_U_"A/I"
+5 ;
+6 QUIT
+7 ;
HDRR ; report header
+1 ;
+2 NEW IBA,IBF,IBG
+3 SET IBPGC=$GET(IBPGC)+1
IF IBCRT
if $GET(IOF)'=""
WRITE @IOF
if $GET(IOF)=""
WRITE !
+4 IF 'IBCRT
WRITE !
+5 SET IBA=$EXTRACT(IBSPACES,1,(6-$LENGTH(IBPGC)))_IBPGC
SET IBLNC=6
+6 WRITE IBHDRNAME,?90,IBHDRDATE,?119,"Page: ",IBA,!
+7 SET IBLNC=5
WRITE IBFILTER,!!
+8 WRITE "INSURANCE COMPANY",?32,"PROFESSIONAL ID",?64,"INSTITUTIONAL ID",?96,"DENTAL ID",?128,"A/I"
+9 WRITE !,$EXTRACT(IBDASHES,1,132)
+10 QUIT
+11 ;
EXITC ; compile section exit
+1 ;
+2 KILL ^TMP($JOB,"IBCNOR3-1")
+3 KILL ^TMP($JOB,"IBCNOR3")
+4 QUIT
+5 ;
STOP() ; Determine if user wants to exit out of the whole option
+1 ; Initialize Variables
+2 NEW DIR,DIRUT,X,Y
+3 WRITE !
+4 SET DIR(0)="Y"
+5 SET DIR("A")="Do you want to exit out of this option entirely"
+6 SET DIR("B")="YES"
+7 SET DIR("?",1)=" Enter YES to immediately exit out of this option."
+8 SET DIR("?")=" Enter NO to return to the previous question."
+9 DO ^DIR
KILL DIR
+10 IF $DATA(DIRUT)!$DATA(DIROUT)!$DATA(DTOUT)!$DATA(DUOUT)
SET (IBSTOP,Y)=1
GOTO STOPX
+11 IF 'Y
SET IBSTOP=0
STOPX ; STOP Exit Point
+1 QUIT Y
+2 ;
