- IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97
- ;;2.0;INTEGRATED BILLING;**82,184,263,438,497**;21-MAR-94;Build 120
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- BUFFER(DFN) ; returns IFN of first buffer entry found for the patient, 0 otherwise
- Q +$O(^IBA(355.33,"C",+$G(DFN),0))
- ;
- SELINS() ; user select an insurance company
- N IBX,DIE,DTOUT,DUOUT,DIC,X,Y S IBX=0
- S DIC="^DIC(36,",DIC(0)="AEQ",DIC("A")="Select INSURANCE COMPANY: ",DIC("S")="I '$P(^(0),U,5)" D ^DIC
- I +Y>0 S IBX=Y
- Q IBX
- ;
- SELGRP(IBINSDA) ; given a specific insurance company, allow user to choose a group/plan
- N IBX,DIE,DTOUT,DUOUT,DIC,X,Y,IBINSNM S IBX=0
- S IBINSNM=$P($G(^DIC(36,+IBINSDA,0)),U,1)
- W !,IBINSNM
- S X=IBINSNM,DIC="^IBA(355.3,",DIC(0)="EQ",DIC("S")="I +^(0)="_+IBINSDA_"&('$P(^(0),U,11))" D ^DIC
- I +Y>0 S IBX=Y
- Q IBX
- ;
- SELEXT(DFN) ; user select existing ins co, group, and if the patient is a member of the group also return the policy
- N IBX,IBINSDA,IBGRPDA,IBPOLDA S (IBINSDA,IBGRPDA,IBPOLDA)=""
- S IBINSDA=$$SELINS() S IBX=+IBINSDA
- I +IBINSDA S IBGRPDA=$$SELGRP(+IBINSDA) I +IBGRPDA S IBX=IBX_U_+IBGRPDA
- I +IBGRPDA,+$G(DFN) S IBPOLDA=$$PTGRP(DFN,IBINSDA,IBGRPDA) I +IBPOLDA S IBX=IBX_U_+IBPOLDA
- Q IBX
- ;
- PTGRP(DFN,IBINSDA,IBGRPDA) ; return policy ifn if patient is a member of this group plan
- N IBX,IBY S IBX=0,DFN=+$G(DFN),IBINSDA=+$G(IBINSDA),IBGRPDA=+$G(IBGRPDA)
- S IBY=0 F S IBY=$O(^DPT(DFN,.312,"B",IBINSDA,IBY)) Q:'IBY I +$P($G(^DPT(DFN,.312,IBY,0)),U,18)=IBGRPDA S IBX=IBY
- Q IBX
- ;
- DISPBUF(IBBUFDA) ; display summary info on a buffer entry
- ;
- Q:'$G(IBBUFDA)
- N IB0,IB60,IB90 S IB0=$G(^IBA(355.33,IBBUFDA,0)) Q:IB0=""
- S IB60=$G(^IBA(355.33,IBBUFDA,60)),IB90=$G(^IBA(355.33,IBBUFDA,90)) ;WCJ;IB*2*497 used new fields for SUB ID and GROUP#
- ;
- W !,"--------------------------------------------------------------------------------"
- W !,?2,"Entered: ",?15,$$FMTE^XLFDT(+IB0,2),?50,"Source: ",?60,$$EXPAND^IBTRE(355.33,.03,$P(IB0,U,3))
- W !,?2,"Entered By: ",?15,$$EXPAND^IBTRE(355.33,.02,+$P(IB0,U,2)),?50,"Verified: ",?60,$$FMTE^XLFDT($P(IB0,U,10),2)
- I +$P(IB0,U,10) W !,?50,"Verif By: ",?60,$E($$EXPAND^IBTRE(355.33,.11,$P(IB0,U,11)),1,20)
- W !!,?2,"Patient: ",?15,$$EXPAND^IBTRE(355.33,60.01,$P(IB60,U,1)),?50,"Sub Id: ",?60,$E($P(IB90,U,3),1,19)
- W !,?2,"Insurance: ",?15,$P($G(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$E($P(IB90,U,2),1,19)
- W !,?15,$P($G(^IBA(355.33,+IBBUFDA,21)),U,1)
- W !,"--------------------------------------------------------------------------------"
- Q
- ;
- LOCK(IBBUFDA,DISP,TO) ; return true if able to lock the buffer entry, if not an DISP is true then will display a message
- ; TO - lock attempt time out & hang time in seconds, default to 4
- N IBX S IBX=0
- S TO=$G(TO,4)
- I +$G(IBBUFDA) L +^IBA(355.33,+IBBUFDA):TO I +$T S IBX=1
- I 'IBX,+$G(DISP) W !!,"Another user is currently editing/processing this entry, please try again later.",! H TO
- I IBX D
- .; eIV real time inquiries temp. global
- .K ^TMP("IBCNERTQ",$J,+IBBUFDA)
- .S ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")=1
- .Q
- Q IBX
- ;
- UNLOCK(IBBUFDA) ; unlock a Buffer entry
- K ^TMP("IBCNERTQ",$J,+IBBUFDA,"LOCK")
- I $G(^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER"))=1 D
- .; eIV real time inquiry
- .N TQIEN,RESPONSE,DIE,DA,DR,X,Y
- .S RESPONSE=0
- .; create an entry in eIV transmision queue
- .S TQIEN=$$IBE^IBCNERTQ(+IBBUFDA)
- .; Load and Send HL7 Message
- .I TQIEN S RESPONSE=$$PROCSEND^IBCNERTQ(TQIEN)
- .; set field 355.33/.16 (real time verification)
- .S DIE="^IBA(355.33,",DA=+IBBUFDA,DR=".16////^S X=RESPONSE" D ^DIE
- .K ^TMP("IBCNERTQ",$J,+IBBUFDA,"TRIGGER")
- .Q
- L -^IBA(355.33,+IBBUFDA)
- Q
- ;
- DICINS(INSNAME,IBSCACT,IBLISTN) ; user search/selection of existing Insurance Company Names, does not list duplicates, based on names and synonyms
- ;
- ; Input parameters
- ; INSNAME - user input; partial name match of insurance company
- ; IBSCACT - 0/1 flag indicating if inactive insurance companies
- ; should get screened out during the list building
- ; Default is 0 (no screen)
- ; IBLISTN - number of entries to display in the lister before
- ; giving the user a chance to select. Default is 4.
- ; Output
- ; returns Ins name, or -1 if ^, or 0 if none selected
- ;
- S IBSCACT=$G(IBSCACT,0) ; flag to screen out inactive ins
- S IBLISTN=$G(IBLISTN,4) ; number of list entries before user selection
- ;
- N IBX,IBINB,IBCX,IBSEL,IBXRF,IBNAME,IBSYNM,IBCNT,IBC1,IBINSIEN,IBLINE
- S IBSEL=0 K ^TMP($J,"IBINSS"),^TMP($J,"IBINSSB") I INSNAME="" G DINSQ
- ;
- S INSNAME=$$UP^XLFSTR(INSNAME),IBX=$L(INSNAME),IBINB=$E(INSNAME,1,(IBX-1))_$C($A($E(INSNAME,IBX))-1)_"~"
- ;
- F IBCX="C","B" S IBXRF=IBINB D
- . F S IBXRF=$O(^DIC(36,IBCX,IBXRF)) Q:IBXRF=""!($E(IBXRF,1,IBX)'=INSNAME) D
- .. S IBINSIEN=0
- .. F S IBINSIEN=+$O(^DIC(36,IBCX,IBXRF,IBINSIEN)) Q:'IBINSIEN D
- ... I '$D(^DIC(36,IBINSIEN,0)) Q ; bad xref entry?
- ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,0)),U,5) Q ; inactive
- ... I IBSCACT,$P($G(^DIC(36,IBINSIEN,5)),U,1) Q ; scheduled for deletion
- ... S IBNAME=$P($G(^DIC(36,IBINSIEN,0)),U,1)
- ... I IBNAME="" Q
- ... I $D(^TMP($J,"IBINSSB",IBNAME)) Q
- ... S ^TMP($J,"IBINSSB",IBNAME)=$S(IBNAME=IBXRF:"",1:IBXRF)
- ... Q
- ;
- S IBCNT=0,IBX="" F S IBX=$O(^TMP($J,"IBINSSB",IBX)) Q:IBX="" S IBCNT=IBCNT+1,^TMP($J,"IBINSS",IBCNT)=IBX
- ;
- S (IBCNT,IBC1)=0 F S IBCNT=$O(^TMP($J,"IBINSS",IBCNT)) Q:'IBCNT D I +IBSEL Q
- . S IBNAME=^TMP($J,"IBINSS",IBCNT) Q:IBNAME="" S IBSYNM=$G(^TMP($J,"IBINSSB",IBNAME))
- . S IBLINE=$J(IBCNT,7)_" "_$$FO^IBCNEUT1(IBNAME,40)_IBSYNM
- . DO EN^DDIOL(IBLINE)
- . S IBC1=IBC1+1 I '(IBCNT#IBLISTN) S IBSEL=$$DIR(IBC1)
- . Q
- ;
- I 'IBSEL,+(IBC1#IBLISTN) S IBSEL=$$DIR(IBC1)
- ;
- I IBSEL>0 S IBSEL=$G(^TMP($J,"IBINSS",IBSEL))
- ;
- DINSQ K ^TMP($J,"IBINSS"),^TMP($J,"IBCNSSB")
- Q IBSEL
- ;
- DIR(MAX) ; DIR call for DICINS search for insurance company name
- N DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y S IBX=0,DIR(0)="LOA^1:"_MAX_"^K:X'>0!(X>"_MAX_") X",DIR("A")="CHOOSE 1-"_MAX_": "
- I $G(MAX)>0 D ^DIR K DIR S IBX=$S($D(DTOUT)!$D(DUOUT):-1,+Y:+Y,1:0)
- Q IBX
- ;
- DICBUF(INSNAME,DFN,IBDUZ) ; display list of editable buffer entries based on insurance name, may specify patient and/or enterer
- ; (non-MCCR people: only the person that created an entry should be able to edit it, everyone else should create new ones)
- N X,Y,IBX,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,D S IBX=0
- ;
- S DIC("W")="W "" "",$P($G(^(20)),U,1),"" "",$P($G(^(21)),U,1)"
- S DIC("S")="I $P(^(0),U,4)=""E""&('$P(^(0),U,10))" S:+$G(IBDUZ) DIC("S")=DIC("S")_"&(+$P(^(0),U,2)="_IBDUZ_")" S:+$G(DFN) DIC("S")=DIC("S")_"&(+$G(^(60))="_DFN_")"
- S DIC="^IBA(355.33,",DIC(0)="EM",X=$$UP^XLFSTR($G(INSNAME)),D="D" D IX^DIC I '$D(DTOUT),'$D(DUOUT),+Y>0 S IBX=+Y
- Q IBX
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCNBU1 6831 printed Jan 18, 2025@03:15:28 Page 2
- IBCNBU1 ;ALB/ARH-Ins Buffer: Utilities ;1 Jun 97
- +1 ;;2.0;INTEGRATED BILLING;**82,184,263,438,497**;21-MAR-94;Build 120
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- BUFFER(DFN) ; returns IFN of first buffer entry found for the patient, 0 otherwise
- +1 QUIT +$ORDER(^IBA(355.33,"C",+$GET(DFN),0))
- +2 ;
- SELINS() ; user select an insurance company
- +1 NEW IBX,DIE,DTOUT,DUOUT,DIC,X,Y
- SET IBX=0
- +2 SET DIC="^DIC(36,"
- SET DIC(0)="AEQ"
- SET DIC("A")="Select INSURANCE COMPANY: "
- SET DIC("S")="I '$P(^(0),U,5)"
- DO ^DIC
- +3 IF +Y>0
- SET IBX=Y
- +4 QUIT IBX
- +5 ;
- SELGRP(IBINSDA) ; given a specific insurance company, allow user to choose a group/plan
- +1 NEW IBX,DIE,DTOUT,DUOUT,DIC,X,Y,IBINSNM
- SET IBX=0
- +2 SET IBINSNM=$PIECE($GET(^DIC(36,+IBINSDA,0)),U,1)
- +3 WRITE !,IBINSNM
- +4 SET X=IBINSNM
- SET DIC="^IBA(355.3,"
- SET DIC(0)="EQ"
- SET DIC("S")="I +^(0)="_+IBINSDA_"&('$P(^(0),U,11))"
- DO ^DIC
- +5 IF +Y>0
- SET IBX=Y
- +6 QUIT IBX
- +7 ;
- SELEXT(DFN) ; user select existing ins co, group, and if the patient is a member of the group also return the policy
- +1 NEW IBX,IBINSDA,IBGRPDA,IBPOLDA
- SET (IBINSDA,IBGRPDA,IBPOLDA)=""
- +2 SET IBINSDA=$$SELINS()
- SET IBX=+IBINSDA
- +3 IF +IBINSDA
- SET IBGRPDA=$$SELGRP(+IBINSDA)
- IF +IBGRPDA
- SET IBX=IBX_U_+IBGRPDA
- +4 IF +IBGRPDA
- IF +$GET(DFN)
- SET IBPOLDA=$$PTGRP(DFN,IBINSDA,IBGRPDA)
- IF +IBPOLDA
- SET IBX=IBX_U_+IBPOLDA
- +5 QUIT IBX
- +6 ;
- PTGRP(DFN,IBINSDA,IBGRPDA) ; return policy ifn if patient is a member of this group plan
- +1 NEW IBX,IBY
- SET IBX=0
- SET DFN=+$GET(DFN)
- SET IBINSDA=+$GET(IBINSDA)
- SET IBGRPDA=+$GET(IBGRPDA)
- +2 SET IBY=0
- FOR
- SET IBY=$ORDER(^DPT(DFN,.312,"B",IBINSDA,IBY))
- if 'IBY
- QUIT
- IF +$PIECE($GET(^DPT(DFN,.312,IBY,0)),U,18)=IBGRPDA
- SET IBX=IBY
- +3 QUIT IBX
- +4 ;
- DISPBUF(IBBUFDA) ; display summary info on a buffer entry
- +1 ;
- +2 if '$GET(IBBUFDA)
- QUIT
- +3 NEW IB0,IB60,IB90
- SET IB0=$GET(^IBA(355.33,IBBUFDA,0))
- if IB0=""
- QUIT
- +4 ;WCJ;IB*2*497 used new fields for SUB ID and GROUP#
- SET IB60=$GET(^IBA(355.33,IBBUFDA,60))
- SET IB90=$GET(^IBA(355.33,IBBUFDA,90))
- +5 ;
- +6 WRITE !,"--------------------------------------------------------------------------------"
- +7 WRITE !,?2,"Entered: ",?15,$$FMTE^XLFDT(+IB0,2),?50,"Source: ",?60,$$EXPAND^IBTRE(355.33,.03,$PIECE(IB0,U,3))
- +8 WRITE !,?2,"Entered By: ",?15,$$EXPAND^IBTRE(355.33,.02,+$PIECE(IB0,U,2)),?50,"Verified: ",?60,$$FMTE^XLFDT($PIECE(IB0,U,10),2)
- +9 IF +$PIECE(IB0,U,10)
- WRITE !,?50,"Verif By: ",?60,$EXTRACT($$EXPAND^IBTRE(355.33,.11,$PIECE(IB0,U,11)),1,20)
- +10 WRITE !!,?2,"Patient: ",?15,$$EXPAND^IBTRE(355.33,60.01,$PIECE(IB60,U,1)),?50,"Sub Id: ",?60,$EXTRACT($PIECE(IB90,U,3),1,19)
- +11 WRITE !,?2,"Insurance: ",?15,$PIECE($GET(^IBA(355.33,+IBBUFDA,20)),U,1),?50,"Group #: ",?60,$EXTRACT($PIECE(IB90,U,2),1,19)
- +12 WRITE !,?15,$PIECE($GET(^IBA(355.33,+IBBUFDA,21)),U,1)
- +13 WRITE !,"--------------------------------------------------------------------------------"
- +14 QUIT
- +15 ;
- LOCK(IBBUFDA,DISP,TO) ; return true if able to lock the buffer entry, if not an DISP is true then will display a message
- +1 ; TO - lock attempt time out & hang time in seconds, default to 4
- +2 NEW IBX
- SET IBX=0
- +3 SET TO=$GET(TO,4)
- +4 IF +$GET(IBBUFDA)
- LOCK +^IBA(355.33,+IBBUFDA):TO
- IF +$TEST
- SET IBX=1
- +5 IF 'IBX
- IF +$GET(DISP)
- WRITE !!,"Another user is currently editing/processing this entry, please try again later.",!
- HANG TO
- +6 IF IBX
- Begin DoDot:1
- +7 ; eIV real time inquiries temp. global
- +8 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA)
- +9 SET ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"LOCK")=1
- +10 QUIT
- End DoDot:1
- +11 QUIT IBX
- +12 ;
- UNLOCK(IBBUFDA) ; unlock a Buffer entry
- +1 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"LOCK")
- +2 IF $GET(^TMP("IBCNERTQ",$JOB,+IBBUFDA,"TRIGGER"))=1
- Begin DoDot:1
- +3 ; eIV real time inquiry
- +4 NEW TQIEN,RESPONSE,DIE,DA,DR,X,Y
- +5 SET RESPONSE=0
- +6 ; create an entry in eIV transmision queue
- +7 SET TQIEN=$$IBE^IBCNERTQ(+IBBUFDA)
- +8 ; Load and Send HL7 Message
- +9 IF TQIEN
- SET RESPONSE=$$PROCSEND^IBCNERTQ(TQIEN)
- +10 ; set field 355.33/.16 (real time verification)
- +11 SET DIE="^IBA(355.33,"
- SET DA=+IBBUFDA
- SET DR=".16////^S X=RESPONSE"
- DO ^DIE
- +12 KILL ^TMP("IBCNERTQ",$JOB,+IBBUFDA,"TRIGGER")
- +13 QUIT
- End DoDot:1
- +14 LOCK -^IBA(355.33,+IBBUFDA)
- +15 QUIT
- +16 ;
- DICINS(INSNAME,IBSCACT,IBLISTN) ; user search/selection of existing Insurance Company Names, does not list duplicates, based on names and synonyms
- +1 ;
- +2 ; Input parameters
- +3 ; INSNAME - user input; partial name match of insurance company
- +4 ; IBSCACT - 0/1 flag indicating if inactive insurance companies
- +5 ; should get screened out during the list building
- +6 ; Default is 0 (no screen)
- +7 ; IBLISTN - number of entries to display in the lister before
- +8 ; giving the user a chance to select. Default is 4.
- +9 ; Output
- +10 ; returns Ins name, or -1 if ^, or 0 if none selected
- +11 ;
- +12 ; flag to screen out inactive ins
- SET IBSCACT=$GET(IBSCACT,0)
- +13 ; number of list entries before user selection
- SET IBLISTN=$GET(IBLISTN,4)
- +14 ;
- +15 NEW IBX,IBINB,IBCX,IBSEL,IBXRF,IBNAME,IBSYNM,IBCNT,IBC1,IBINSIEN,IBLINE
- +16 SET IBSEL=0
- KILL ^TMP($JOB,"IBINSS"),^TMP($JOB,"IBINSSB")
- IF INSNAME=""
- GOTO DINSQ
- +17 ;
- +18 SET INSNAME=$$UP^XLFSTR(INSNAME)
- SET IBX=$LENGTH(INSNAME)
- SET IBINB=$EXTRACT(INSNAME,1,(IBX-1))_$CHAR($ASCII($EXTRACT(INSNAME,IBX))-1)_"~"
- +19 ;
- +20 FOR IBCX="C","B"
- SET IBXRF=IBINB
- Begin DoDot:1
- +21 FOR
- SET IBXRF=$ORDER(^DIC(36,IBCX,IBXRF))
- if IBXRF=""!($EXTRACT(IBXRF,1,IBX)'=INSNAME)
- QUIT
- Begin DoDot:2
- +22 SET IBINSIEN=0
- +23 FOR
- SET IBINSIEN=+$ORDER(^DIC(36,IBCX,IBXRF,IBINSIEN))
- if 'IBINSIEN
- QUIT
- Begin DoDot:3
- +24 ; bad xref entry?
- IF '$DATA(^DIC(36,IBINSIEN,0))
- QUIT
- +25 ; inactive
- IF IBSCACT
- IF $PIECE($GET(^DIC(36,IBINSIEN,0)),U,5)
- QUIT
- +26 ; scheduled for deletion
- IF IBSCACT
- IF $PIECE($GET(^DIC(36,IBINSIEN,5)),U,1)
- QUIT
- +27 SET IBNAME=$PIECE($GET(^DIC(36,IBINSIEN,0)),U,1)
- +28 IF IBNAME=""
- QUIT
- +29 IF $DATA(^TMP($JOB,"IBINSSB",IBNAME))
- QUIT
- +30 SET ^TMP($JOB,"IBINSSB",IBNAME)=$SELECT(IBNAME=IBXRF:"",1:IBXRF)
- +31 QUIT
- End DoDot:3
- End DoDot:2
- End DoDot:1
- +32 ;
- +33 SET IBCNT=0
- SET IBX=""
- FOR
- SET IBX=$ORDER(^TMP($JOB,"IBINSSB",IBX))
- if IBX=""
- QUIT
- SET IBCNT=IBCNT+1
- SET ^TMP($JOB,"IBINSS",IBCNT)=IBX
- +34 ;
- +35 SET (IBCNT,IBC1)=0
- FOR
- SET IBCNT=$ORDER(^TMP($JOB,"IBINSS",IBCNT))
- if 'IBCNT
- QUIT
- Begin DoDot:1
- +36 SET IBNAME=^TMP($JOB,"IBINSS",IBCNT)
- if IBNAME=""
- QUIT
- SET IBSYNM=$GET(^TMP($JOB,"IBINSSB",IBNAME))
- +37 SET IBLINE=$JUSTIFY(IBCNT,7)_" "_$$FO^IBCNEUT1(IBNAME,40)_IBSYNM
- +38 DO EN^DDIOL(IBLINE)
- +39 SET IBC1=IBC1+1
- IF '(IBCNT#IBLISTN)
- SET IBSEL=$$DIR(IBC1)
- +40 QUIT
- End DoDot:1
- IF +IBSEL
- QUIT
- +41 ;
- +42 IF 'IBSEL
- IF +(IBC1#IBLISTN)
- SET IBSEL=$$DIR(IBC1)
- +43 ;
- +44 IF IBSEL>0
- SET IBSEL=$GET(^TMP($JOB,"IBINSS",IBSEL))
- +45 ;
- DINSQ KILL ^TMP($JOB,"IBINSS"),^TMP($JOB,"IBCNSSB")
- +1 QUIT IBSEL
- +2 ;
- DIR(MAX) ; DIR call for DICINS search for insurance company name
- +1 NEW DIR,DIRUT,DTOUT,DUOUT,IBX,X,Y
- SET IBX=0
- SET DIR(0)="LOA^1:"_MAX_"^K:X'>0!(X>"_MAX_") X"
- SET DIR("A")="CHOOSE 1-"_MAX_": "
- +2 IF $GET(MAX)>0
- DO ^DIR
- KILL DIR
- SET IBX=$SELECT($DATA(DTOUT)!$DATA(DUOUT):-1,+Y:+Y,1:0)
- +3 QUIT IBX
- +4 ;
- DICBUF(INSNAME,DFN,IBDUZ) ; display list of editable buffer entries based on insurance name, may specify patient and/or enterer
- +1 ; (non-MCCR people: only the person that created an entry should be able to edit it, everyone else should create new ones)
- +2 NEW X,Y,IBX,DIC,DA,DR,DIR,DIRUT,DTOUT,DUOUT,D
- SET IBX=0
- +3 ;
- +4 SET DIC("W")="W "" "",$P($G(^(20)),U,1),"" "",$P($G(^(21)),U,1)"
- +5 SET DIC("S")="I $P(^(0),U,4)=""E""&('$P(^(0),U,10))"
- if +$GET(IBDUZ)
- SET DIC("S")=DIC("S")_"&(+$P(^(0),U,2)="_IBDUZ_")"
- if +$GET(DFN)
- SET DIC("S")=DIC("S")_"&(+$G(^(60))="_DFN_")"
- +6 SET DIC="^IBA(355.33,"
- SET DIC(0)="EM"
- SET X=$$UP^XLFSTR($GET(INSNAME))
- SET D="D"
- DO IX^DIC
- IF '$DATA(DTOUT)
- IF '$DATA(DUOUT)
- IF +Y>0
- SET IBX=+Y
- +7 QUIT IBX