IBCEP2A ;ALB/TMP - EDI UTILITIES for provider ID ;25-APR-01
;;2.0;INTEGRATED BILLING;**137,232,320,348,349,400,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
ALT(IBPERF,IBSRC,IBALT,IBINS4,IBPTYP) ; set source level to next higher level
; or set the alternate type and source if performing provider id
; alternate type and source exist
; IBPERF = 1 if performing provider id is requested
; IBINS4 = '4' node of insurance co (file 36)
; Pass IBPTYP by reference to get alternate provider id type
; Pass IBALT by reference. Set to 1 if alternate id is to be used next
;
I '$G(IBPERF)!($P(IBINS4,U,3)=1) S IBSRC=IBSRC-1 G ALTQ
S IBSRC=""
I '$G(IBALT),$P(IBINS4,U,3)=2,$P(IBINS4,U,10),$P(IBINS4,U,11) S IBALT=1,IBSRC=$P(IBINS4,U,11),IBPTYP=$P(IBINS4,U,10) S:IBPTYP="" IBPTYP=$P(IBINS4,U)
;
ALTQ Q IBSRC
;
IDSET(IBPTYP,IBINS4,IBPERF,IBSPEC,IBSRC,IBUP) ; set variables for provider id type search
N Z
S IBSPEC=$G(^IBE(355.97,+IBPTYP,1))
S Z=$S($G(IBPERF):2,$P(IBSPEC,U,5):6,$P(IBSPEC,U,6):4,1:2)
S IBSRC=$P(IBINS4,U,Z),IBUP=$P(IBINS4,U,$S(IBSRC:Z+1,1:0))
Q
;
CAREST(IBIFN) ; Return state file ien of state where care was performed
; IBIFN = ien of bill in file 399
N STATE,IBU2,NVAFAC,IB0,EVDT,IBDIV,INST
S STATE=""
;
; non-VA care
S IBU2=$G(^DGCR(399,IBIFN,"U2"))
S NVAFAC=+$P(IBU2,U,10) ; non-VA facility
I NVAFAC S STATE=+$P($G(^IBA(355.93,NVAFAC,0)),U,7) G CARESTX
;
; VA care
S IB0=$G(^DGCR(399,IBIFN,0))
S EVDT=$P(IB0,U,3) ; claim event date
I 'EVDT S EVDT=DT ; - default today if undefined
S IBDIV=+$P(IB0,U,22) ; division ptr file 40.8
I 'IBDIV S IBDIV=$$PRIM^VASITE(EVDT) ; - default primary division as of event date
I IBDIV'>0 S IBDIV=$$PRIM^VASITE() ; - default main division as of today's date
S INST=+$$SITE^VASITE(EVDT,IBDIV) ; division institution ptr file 4
I INST'>0 S INST=+$$SITE^VASITE(DT,IBDIV) ; - default div as of today's date
I INST'>0 S INST=+$$SITE^VASITE ; - default main institution
S STATE=+$P($G(^DIC(4,INST,0)),U,2) ; state file ien from Institution file
;
CARESTX ;
Q STATE
;
RECALCA(IBIFN) ; Recalculate all performing provider id's on bill IBIFN
; IBIFN = ien of bill entry (file 399)
N IBZ,IBZ0,IBX,IBP,IBSEQ,DA,DIE,DR,DIR,X,Y
;
D EN^DDIOL("THIS FUNCTION HAS BEEN DISABLED",,"!") Q
;
S DA(1)=IBIFN
I '$D(^XUSEC("IB SUPERVISOR",DUZ)) D EN^DDIOL("YOU ARE NOT AUTHORIZED TO PERFORM THIS FUNCTION",,"!")
S IBZ=0 F S IBZ=$O(^DGCR(399,IBIFN,"PRV",IBZ)) Q:'IBZ S IBP=$G(^(IBZ,0)) I $P(IBP,U,2)'="" D
. S DA=IBZ
. F IBZ0=5:1:7 Q:'$G(^DGCR(399,IBIFN,"I"_(IBZ0-4))) D
.. S IBSEQ=$$EXPAND^IBTRE(399.0222,.01,+IBP)_" "_$P("PRIMARY^SECONDARY^TERTIARY",U,IBZ0-4)_" PROVIDER ID "
.. S IBX=$$RECALC(.DA,IBZ0-4,$P(IBP,U,IBZ0),1)
.. I IBX'="",IBX=$P(IBP,U,IBZ0) D EN^DDIOL(IBSEQ_"NO CHANGE NEEDED",,"!") Q
.. I IBX'="",IBX'=$P(IBP,U,IBZ0) D Q
... S DR=(IBZ0/100)_"////"_IBX,DIE="^DGCR(399,"_DA(1)_",""PRV""," D ^DIE
... D EN^DDIOL(IBSEQ_"CHANGED TO "_IBX,,"!")
.. D EN^DDIOL(IBSEQ_"NOT FOUND",,"!")
Q
;
RECALC(IBDA,IBSEQ,IBX,IBD) ; Recalculate id #, if possible - called
; from input transforms in subfile 399.0222, fields .05-.07
; IBDA = DA array of the provider entry (file 399.0222)
; IBSEQ = the numeric COB sequence of the provider id (1-3)
; IBX = the current value of the id in the subfile
; IBD = flag that if set to 1 will suppress the display text
;
N IBPN,IBZ
S IBPN=$P($G(^DGCR(399,IBDA(1),"PRV",IBDA,0)),U,2)
I IBPN="" D:'$G(IBD) EN^DDIOL(" CAN'T CALCULATE WITHOUT A PROVIDER NAME","","?0") G RECALCQ
S IBZ=$$GETID^IBCEP2(IBDA(1),2,IBPN,IBSEQ)
I IBZ="" D:'$G(IBD) EN^DDIOL(" ID COULD NOT BE DETERMINED","","?0") G RECALCQ
D:'$G(IBD) EN^DDIOL(" "_IBZ_$S(IBZ'=IBX:"",1:" (no change)"),"","?0")
S IBX=IBZ
;
RECALCQ Q IBX
;
PERFPRV(IBIFN) ; Returns the variable pointer of the 'performing provider'
; (attending or rendering) for a bill IBIFN
N IBP,IBPT,IBQ,Z
S Z=$$FT^IBCEF(IBIFN),IBPT=$S(Z=2:3,Z=3:4,1:0)
D GETPRV^IBCEU(IBIFN,IBPT,.IBP)
Q $P($G(IBP(IBPT,1)),U,3)
;
INSPAR(IBIFN,SEQ) ;
N Z,Z4,Z0
Q:$G(X)'="??"
S:'$G(SEQ) SEQ=$$COBN^IBCEF(IBIFN)
S Z=+$G(^DGCR(399,IBIFN,"I"_SEQ)),Z4=$G(^DIC(36,Z,4))
I Z D
. D EN^DDIOL(">"_$J("",20)_"-- PERFORMING PROVIDER ID PARAMETERS --",,"!")
. S Z0=$P(" PRIMARY^SECONDARY^ TERTIARY",U,SEQ)_" INSURANCE: "_$P($G(^DIC(36,Z,0)),U)
. D EN^DDIOL(">"_$J("",(80-$L(Z0))\2)_Z0,,"!")
. D EN^DDIOL("> Secondary Perf Prov ID Type (1500): "_$$EXPAND^IBTRE(36,4.01,+Z4),,"!")
. D EN^DDIOL("> Secondary Perf Prov ID Type (UB04): "_$$EXPAND^IBTRE(36,4.02,$P(Z4,U,2)),,"!")
. D EN^DDIOL("> Secondary Perf Prov IDs Required: "_$$EXPAND^IBTRE(36,4.03,$P(Z4,U,3)),,"!")
. D EN^DDIOL(" ",,"!")
Q
;
GETTYP(IBXIEN,IBCOBN,IBFUNC) ; Function returns provider id type for insurance co
; with COB of IBCOBN on claim ien IBXIEN in first ^ pc and 1 in second
; ^ piece if the id is required
;
; IBFUNC=1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER
;
N A,R,Z,Z0
S A="",R=0
S:'$G(IBCOBN)!(IBCOBN>3) IBCOBN=$$COBN^IBCEF(IBXIEN)
S Z=+$G(^DGCR(399,IBXIEN,"I"_+IBCOBN))
I Z D
. S Z0=$$FT^IBCEF(IBXIEN)
. ;JWS;IB*2.0*592;no secondary provider ID's for Dental
. I Z0=7 Q
. S A=+$P($G(^DIC(36,Z,4)),U,$S(Z0=2&($G(IBFUNC)=1):4,Z0=2:1,1:2))
. I A,$G(IBFUNC)'=1 S R=$P($G(^DIC(36,Z,4)),U,3),R=$S('R:0,R=3:1,R=1:Z0=2,R=2:Z0=3,1:0)
. I A,$G(IBFUNC)=1 S R=+$P($G(^DIC(36,Z,4)),U,5),R=$S('R:0,Z0'=2:0,1:1)
Q A_U_R
;
UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
;
; Start in file 355.9 (Specific Provider)
; IBPROV = (variable pointer syntax) provider on bill IBIFN
;
N Q,Z0,Z1,Z2,IBID,IBX
S IBID=""
S IBX=$P($G(^IBA(355.9,+IBCU,0)),U,3) S:"0"[IBX IBX="*N/A*"
S Z0=$$FT^IBCEF(IBIFN)
;JWS;IB*2.0*592;If Dental quit
I Z0=7 G UNIQ1Q
S Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
;
; Match all elements
F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
G:IBID'="" UNIQ1Q
;
; Match both form types,specific I/O element
F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
G:IBID'="" UNIQ1Q
;
; Match specific form type, both I/O element or Rx
F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
G:IBID'="" UNIQ1Q
;
; Match both form types, both I/O element or Rx
F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.9,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.9) Q
;
UNIQ1Q Q IBID
;
UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
;
; Start in file 355.91 (Specific Insurance)
;
N Q,Z0,Z1,Z2,IBID,IBX
S IBID="" S:"0"[$G(IBUNIT) IBUNIT="*N/A*"
S Z0=$$FT^IBCEF(IBIFN)
;JWS;IB*2.0*592;If Dental quit
I Z0=7 G UNIQ2Q
S Z0=$S(Z0=2:2,Z0=3:1,1:0),Z1=$$INPAT^IBCEF(IBIFN) S:'Z1 Z1=2 S Z2=$$ISRX^IBCEF1(IBIFN)
;
; Match all elements
F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
G:IBID'="" UNIQ2Q
;
; Match both form types,specific I/O element
F Q=$S(Z2:3,1:Z1),$S(Z2:Z1,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
G:IBID'="" UNIQ2Q
;
; Match specific form type, both I/O element or Rx
F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
G:IBID'="" UNIQ2Q
;
; Match both form types, both I/O elements or Rx
F Q=$S(Z2:3,1:0),$S(Z2:0,1:"") I Q'="",$D(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU)) S IBID=$P($G(^IBA(355.91,IBCU,0)),U,7),$P(IBT,U,2,3)=(IBCU_U_355.91) Q
;
UNIQ2Q Q IBID
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP2A 8520 printed Dec 13, 2024@02:11:33 Page 2
IBCEP2A ;ALB/TMP - EDI UTILITIES for provider ID ;25-APR-01
+1 ;;2.0;INTEGRATED BILLING;**137,232,320,348,349,400,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
ALT(IBPERF,IBSRC,IBALT,IBINS4,IBPTYP) ; set source level to next higher level
+1 ; or set the alternate type and source if performing provider id
+2 ; alternate type and source exist
+3 ; IBPERF = 1 if performing provider id is requested
+4 ; IBINS4 = '4' node of insurance co (file 36)
+5 ; Pass IBPTYP by reference to get alternate provider id type
+6 ; Pass IBALT by reference. Set to 1 if alternate id is to be used next
+7 ;
+8 IF '$GET(IBPERF)!($PIECE(IBINS4,U,3)=1)
SET IBSRC=IBSRC-1
GOTO ALTQ
+9 SET IBSRC=""
+10 IF '$GET(IBALT)
IF $PIECE(IBINS4,U,3)=2
IF $PIECE(IBINS4,U,10)
IF $PIECE(IBINS4,U,11)
SET IBALT=1
SET IBSRC=$PIECE(IBINS4,U,11)
SET IBPTYP=$PIECE(IBINS4,U,10)
if IBPTYP=""
SET IBPTYP=$PIECE(IBINS4,U)
+11 ;
ALTQ QUIT IBSRC
+1 ;
IDSET(IBPTYP,IBINS4,IBPERF,IBSPEC,IBSRC,IBUP) ; set variables for provider id type search
+1 NEW Z
+2 SET IBSPEC=$GET(^IBE(355.97,+IBPTYP,1))
+3 SET Z=$SELECT($GET(IBPERF):2,$PIECE(IBSPEC,U,5):6,$PIECE(IBSPEC,U,6):4,1:2)
+4 SET IBSRC=$PIECE(IBINS4,U,Z)
SET IBUP=$PIECE(IBINS4,U,$SELECT(IBSRC:Z+1,1:0))
+5 QUIT
+6 ;
CAREST(IBIFN) ; Return state file ien of state where care was performed
+1 ; IBIFN = ien of bill in file 399
+2 NEW STATE,IBU2,NVAFAC,IB0,EVDT,IBDIV,INST
+3 SET STATE=""
+4 ;
+5 ; non-VA care
+6 SET IBU2=$GET(^DGCR(399,IBIFN,"U2"))
+7 ; non-VA facility
SET NVAFAC=+$PIECE(IBU2,U,10)
+8 IF NVAFAC
SET STATE=+$PIECE($GET(^IBA(355.93,NVAFAC,0)),U,7)
GOTO CARESTX
+9 ;
+10 ; VA care
+11 SET IB0=$GET(^DGCR(399,IBIFN,0))
+12 ; claim event date
SET EVDT=$PIECE(IB0,U,3)
+13 ; - default today if undefined
IF 'EVDT
SET EVDT=DT
+14 ; division ptr file 40.8
SET IBDIV=+$PIECE(IB0,U,22)
+15 ; - default primary division as of event date
IF 'IBDIV
SET IBDIV=$$PRIM^VASITE(EVDT)
+16 ; - default main division as of today's date
IF IBDIV'>0
SET IBDIV=$$PRIM^VASITE()
+17 ; division institution ptr file 4
SET INST=+$$SITE^VASITE(EVDT,IBDIV)
+18 ; - default div as of today's date
IF INST'>0
SET INST=+$$SITE^VASITE(DT,IBDIV)
+19 ; - default main institution
IF INST'>0
SET INST=+$$SITE^VASITE
+20 ; state file ien from Institution file
SET STATE=+$PIECE($GET(^DIC(4,INST,0)),U,2)
+21 ;
CARESTX ;
+1 QUIT STATE
+2 ;
RECALCA(IBIFN) ; Recalculate all performing provider id's on bill IBIFN
+1 ; IBIFN = ien of bill entry (file 399)
+2 NEW IBZ,IBZ0,IBX,IBP,IBSEQ,DA,DIE,DR,DIR,X,Y
+3 ;
+4 DO EN^DDIOL("THIS FUNCTION HAS BEEN DISABLED",,"!")
QUIT
+5 ;
+6 SET DA(1)=IBIFN
+7 IF '$DATA(^XUSEC("IB SUPERVISOR",DUZ))
DO EN^DDIOL("YOU ARE NOT AUTHORIZED TO PERFORM THIS FUNCTION",,"!")
+8 SET IBZ=0
FOR
SET IBZ=$ORDER(^DGCR(399,IBIFN,"PRV",IBZ))
if 'IBZ
QUIT
SET IBP=$GET(^(IBZ,0))
IF $PIECE(IBP,U,2)'=""
Begin DoDot:1
+9 SET DA=IBZ
+10 FOR IBZ0=5:1:7
if '$GET(^DGCR(399,IBIFN,"I"_(IBZ0-4)))
QUIT
Begin DoDot:2
+11 SET IBSEQ=$$EXPAND^IBTRE(399.0222,.01,+IBP)_" "_$PIECE("PRIMARY^SECONDARY^TERTIARY",U,IBZ0-4)_" PROVIDER ID "
+12 SET IBX=$$RECALC(.DA,IBZ0-4,$PIECE(IBP,U,IBZ0),1)
+13 IF IBX'=""
IF IBX=$PIECE(IBP,U,IBZ0)
DO EN^DDIOL(IBSEQ_"NO CHANGE NEEDED",,"!")
QUIT
+14 IF IBX'=""
IF IBX'=$PIECE(IBP,U,IBZ0)
Begin DoDot:3
+15 SET DR=(IBZ0/100)_"////"_IBX
SET DIE="^DGCR(399,"_DA(1)_",""PRV"","
DO ^DIE
+16 DO EN^DDIOL(IBSEQ_"CHANGED TO "_IBX,,"!")
End DoDot:3
QUIT
+17 DO EN^DDIOL(IBSEQ_"NOT FOUND",,"!")
End DoDot:2
End DoDot:1
+18 QUIT
+19 ;
RECALC(IBDA,IBSEQ,IBX,IBD) ; Recalculate id #, if possible - called
+1 ; from input transforms in subfile 399.0222, fields .05-.07
+2 ; IBDA = DA array of the provider entry (file 399.0222)
+3 ; IBSEQ = the numeric COB sequence of the provider id (1-3)
+4 ; IBX = the current value of the id in the subfile
+5 ; IBD = flag that if set to 1 will suppress the display text
+6 ;
+7 NEW IBPN,IBZ
+8 SET IBPN=$PIECE($GET(^DGCR(399,IBDA(1),"PRV",IBDA,0)),U,2)
+9 IF IBPN=""
if '$GET(IBD)
DO EN^DDIOL(" CAN'T CALCULATE WITHOUT A PROVIDER NAME","","?0")
GOTO RECALCQ
+10 SET IBZ=$$GETID^IBCEP2(IBDA(1),2,IBPN,IBSEQ)
+11 IF IBZ=""
if '$GET(IBD)
DO EN^DDIOL(" ID COULD NOT BE DETERMINED","","?0")
GOTO RECALCQ
+12 if '$GET(IBD)
DO EN^DDIOL(" "_IBZ_$SELECT(IBZ'=IBX:"",1:" (no change)"),"","?0")
+13 SET IBX=IBZ
+14 ;
RECALCQ QUIT IBX
+1 ;
PERFPRV(IBIFN) ; Returns the variable pointer of the 'performing provider'
+1 ; (attending or rendering) for a bill IBIFN
+2 NEW IBP,IBPT,IBQ,Z
+3 SET Z=$$FT^IBCEF(IBIFN)
SET IBPT=$SELECT(Z=2:3,Z=3:4,1:0)
+4 DO GETPRV^IBCEU(IBIFN,IBPT,.IBP)
+5 QUIT $PIECE($GET(IBP(IBPT,1)),U,3)
+6 ;
INSPAR(IBIFN,SEQ) ;
+1 NEW Z,Z4,Z0
+2 if $GET(X)'="??"
QUIT
+3 if '$GET(SEQ)
SET SEQ=$$COBN^IBCEF(IBIFN)
+4 SET Z=+$GET(^DGCR(399,IBIFN,"I"_SEQ))
SET Z4=$GET(^DIC(36,Z,4))
+5 IF Z
Begin DoDot:1
+6 DO EN^DDIOL(">"_$JUSTIFY("",20)_"-- PERFORMING PROVIDER ID PARAMETERS --",,"!")
+7 SET Z0=$PIECE(" PRIMARY^SECONDARY^ TERTIARY",U,SEQ)_" INSURANCE: "_$PIECE($GET(^DIC(36,Z,0)),U)
+8 DO EN^DDIOL(">"_$JUSTIFY("",(80-$LENGTH(Z0))\2)_Z0,,"!")
+9 DO EN^DDIOL("> Secondary Perf Prov ID Type (1500): "_$$EXPAND^IBTRE(36,4.01,+Z4),,"!")
+10 DO EN^DDIOL("> Secondary Perf Prov ID Type (UB04): "_$$EXPAND^IBTRE(36,4.02,$PIECE(Z4,U,2)),,"!")
+11 DO EN^DDIOL("> Secondary Perf Prov IDs Required: "_$$EXPAND^IBTRE(36,4.03,$PIECE(Z4,U,3)),,"!")
+12 DO EN^DDIOL(" ",,"!")
End DoDot:1
+13 QUIT
+14 ;
GETTYP(IBXIEN,IBCOBN,IBFUNC) ; Function returns provider id type for insurance co
+1 ; with COB of IBCOBN on claim ien IBXIEN in first ^ pc and 1 in second
+2 ; ^ piece if the id is required
+3 ;
+4 ; IBFUNC=1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER
+5 ;
+6 NEW A,R,Z,Z0
+7 SET A=""
SET R=0
+8 if '$GET(IBCOBN)!(IBCOBN>3)
SET IBCOBN=$$COBN^IBCEF(IBXIEN)
+9 SET Z=+$GET(^DGCR(399,IBXIEN,"I"_+IBCOBN))
+10 IF Z
Begin DoDot:1
+11 SET Z0=$$FT^IBCEF(IBXIEN)
+12 ;JWS;IB*2.0*592;no secondary provider ID's for Dental
+13 IF Z0=7
QUIT
+14 SET A=+$PIECE($GET(^DIC(36,Z,4)),U,$SELECT(Z0=2&($GET(IBFUNC)=1):4,Z0=2:1,1:2))
+15 IF A
IF $GET(IBFUNC)'=1
SET R=$PIECE($GET(^DIC(36,Z,4)),U,3)
SET R=$SELECT('R:0,R=3:1,R=1:Z0=2,R=2:Z0=3,1:0)
+16 IF A
IF $GET(IBFUNC)=1
SET R=+$PIECE($GET(^DIC(36,Z,4)),U,5)
SET R=$SELECT('R:0,Z0'=2:0,1:1)
End DoDot:1
+17 QUIT A_U_R
+18 ;
UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IBCU,IBT) ; Match most-least specific
+1 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
+2 ;
+3 ; Start in file 355.9 (Specific Provider)
+4 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
+5 ;
+6 NEW Q,Z0,Z1,Z2,IBID,IBX
+7 SET IBID=""
+8 SET IBX=$PIECE($GET(^IBA(355.9,+IBCU,0)),U,3)
if "0"[IBX
SET IBX="*N/A*"
+9 SET Z0=$$FT^IBCEF(IBIFN)
+10 ;JWS;IB*2.0*592;If Dental quit
+11 IF Z0=7
GOTO UNIQ1Q
+12 SET Z0=$SELECT(Z0=2:2,Z0=3:1,1:0)
SET Z1=$$INPAT^IBCEF(IBIFN)
if 'Z1
SET Z1=2
SET Z2=$$ISRX^IBCEF1(IBIFN)
+13 ;
+14 ; Match all elements
+15 FOR Q=$SELECT(Z2:3,1:Z1),$SELECT(Z2:Z1,1:"")
IF Q'=""
IF $DATA(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.9,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.9)
QUIT
+16 if IBID'=""
GOTO UNIQ1Q
+17 ;
+18 ; Match both form types,specific I/O element
+19 FOR Q=$SELECT(Z2:3,1:Z1),$SELECT(Z2:Z1,1:"")
IF Q'=""
IF $DATA(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.9,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.9)
QUIT
+20 if IBID'=""
GOTO UNIQ1Q
+21 ;
+22 ; Match specific form type, both I/O element or Rx
+23 FOR Q=$SELECT(Z2:3,1:0),$SELECT(Z2:0,1:"")
IF Q'=""
IF $DATA(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,Z0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.9,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.9)
QUIT
+24 if IBID'=""
GOTO UNIQ1Q
+25 ;
+26 ; Match both form types, both I/O element or Rx
+27 FOR Q=$SELECT(Z2:3,1:0),$SELECT(Z2:0,1:"")
IF Q'=""
IF $DATA(^IBA(355.9,"AUNIQ",IBPROV,IBINS,IBX,0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.9,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.9)
QUIT
+28 ;
UNIQ1Q QUIT IBID
+1 ;
UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
+1 ; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
+2 ;
+3 ; Start in file 355.91 (Specific Insurance)
+4 ;
+5 NEW Q,Z0,Z1,Z2,IBID,IBX
+6 SET IBID=""
if "0"[$GET(IBUNIT)
SET IBUNIT="*N/A*"
+7 SET Z0=$$FT^IBCEF(IBIFN)
+8 ;JWS;IB*2.0*592;If Dental quit
+9 IF Z0=7
GOTO UNIQ2Q
+10 SET Z0=$SELECT(Z0=2:2,Z0=3:1,1:0)
SET Z1=$$INPAT^IBCEF(IBIFN)
if 'Z1
SET Z1=2
SET Z2=$$ISRX^IBCEF1(IBIFN)
+11 ;
+12 ; Match all elements
+13 FOR Q=$SELECT(Z2:3,1:Z1),$SELECT(Z2:Z1,1:"")
IF Q'=""
IF $DATA(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.91,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.91)
QUIT
+14 if IBID'=""
GOTO UNIQ2Q
+15 ;
+16 ; Match both form types,specific I/O element
+17 FOR Q=$SELECT(Z2:3,1:Z1),$SELECT(Z2:Z1,1:"")
IF Q'=""
IF $DATA(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.91,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.91)
QUIT
+18 if IBID'=""
GOTO UNIQ2Q
+19 ;
+20 ; Match specific form type, both I/O element or Rx
+21 FOR Q=$SELECT(Z2:3,1:0),$SELECT(Z2:0,1:"")
IF Q'=""
IF $DATA(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,Z0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.91,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.91)
QUIT
+22 if IBID'=""
GOTO UNIQ2Q
+23 ;
+24 ; Match both form types, both I/O elements or Rx
+25 FOR Q=$SELECT(Z2:3,1:0),$SELECT(Z2:0,1:"")
IF Q'=""
IF $DATA(^IBA(355.91,"AUNIQ",IBINS,IBUNIT,0,Q,IBPTYP,IBCU))
SET IBID=$PIECE($GET(^IBA(355.91,IBCU,0)),U,7)
SET $PIECE(IBT,U,2,3)=(IBCU_U_355.91)
QUIT
+26 ;
UNIQ2Q QUIT IBID
+1 ;
