IBCEP2 ;ALB/TMP - EDI UTILITIES for provider ID ;13-DEC-99
;;2.0;INTEGRATED BILLING;**137,181,232,280,320,349,432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
; DBIA for access to fields 53.2,54.1,54.2 in file 200: 224
;
GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1,IBFUNC) ; Extract IBTYPE id for the bill
; IBIFN = bill ien (file 399)
; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted)
; IBSEQ = numeric COB sequence of the insurance on bill
; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER;
; Returns IBT = ien of the provider id type^ien of entry^file # for id
;
S IBT=0
Q:IBTYPE'=2 ""
N IBID,IBPTYP
S IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT,$G(IBFUNC))
I IBID="" S IBT=""
;
Q IBID
;
IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT,IBFUNC) ;Loop thru source levels
; (if id definition allows) to find correct ID
; IBIFN = bill ien (file 399)
; IBPTYP = ien of the provider id type in file 355.97 or if null,
; the default performing provider ID type for the ins co. in
; COB sequence IBSEQ will be calculated
; IBPROV = (variable pointer syntax) provider on bill IBIFN
; IBSEQ = numeric COB sequence of the bill
; IBPERF = 1 if the performing provider id is needed
; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
; Returns IBT = ptr to file 355.97^entry #^file #
;
S IBT=+$G(IBPTYP)
Q:'$G(IBPERF)!'$G(IBPROV) ""
N IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z
I $G(IBSEQ)="" S IBSEQ=+$$COBN^IBCEF(IBIFN) ; Default to current COB seq
S IBINS=+$P($G(^DGCR(399,IBIFN,"I"_IBSEQ)),U),IBINS4=$G(^DIC(36,+IBINS,4))
;JRA IB*2.0*592 Same logic for Dental Form 7 as for CMS-1500
;S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592 ';'
N FT S FT=$$FT^IBCEF(IBIFN) ;JRA IB*2.0*592 Added 'FT'
S IBPROF=(FT=2!(FT=7)) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592
; form type is CMS-1500 or J430D (prof)=1, UB-04 (inst)=2
;JWS;IB*2.0*592; No Dental default ID
I $G(IBPTYP)="",FT=7,$G(IBFUNC)=1,IBPROF=1 S (IBT,IBPTYP)=0 Q ""
I $G(IBPTYP)="",$G(IBFUNC)=1,IBPROF=1 S (IBT,IBPTYP)=+$P(IBINS4,U,4) ; Referring Default ID on CMS-1500
I $G(IBPTYP)="" S (IBT,IBPTYP)=+$P(IBINS4,U,IBPROF) ; Def to perf prv typ for form
I 'IBPTYP Q "" ; No default id type
S IBSPEC=$G(^IBE(355.97,IBPTYP,1)),IBSRC=$P($G(^IBE(355.97,+IBPTYP,0)),U,2),IBSRC=$S('IBSRC:5,1:IBSRC),IBUP=1
S IBALT=0
;
F D Q:'IBUP!($G(IBID)'="") S IBSRC=IBSRC-1 Q:'IBSRC
. ;
. I IBSRC=1,$TR($P(IBSPEC,U,1,3),"^0")'="" D Q ; Indiv prov default
.. N IBSTATE
.. I $P(IBSPEC,U,2) D Q ; Federal DEA # from field 53.2 file 200
... S IBID=$P($G(^VA(200,+IBPROV,"PS")),U,2) ; DBIA224
... S $P(IBT,U,2,3)=(IBPROV_U_200)
.. S IBSTATE=+$$CAREST^IBCEP2A(IBIFN)
.. I $P(IBSPEC,U) D Q ; State issued DEA # needed
... Q:'IBSTATE
... ; Extract the state issuing DEA # from field 54.2 file 200
... S Z=+$O(^VA(200,+IBPROV,"PS2","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS2",Z,0)),U,2) ; DBIA224
... S $P(IBT,U,2,3)=(+IBPROV_";"_Z_U_200)
.. I $P(IBSPEC,U,3) D Q ; State license # needed
... Q:'IBSTATE
... ; Extract the state license # from field 54.1 file 200
... I IBPROV["VA(200" S Z=+$O(^VA(200,+IBPROV,"PS1","B",IBSTATE,0)),IBID=$P($G(^VA(200,+IBPROV,"PS1",Z,0)),U,2),$P(IBT,U,2,3)=(+IBPROV_";"_IBSTATE_U_200) ; DBIA224
... I IBPROV["IBA(355.93" S IBID=$P($G(^IBA(355.93,+IBPROV,0)),U,12),$P(IBT,U,2,3)=(+IBPROV_U_355.93)
. ;
. I IBSRC=2,$P(IBSPEC,U,4) D Q ; FACILITY FED TAX ID #
.. N IBXDATA
.. D F^IBCEF("N-FEDERAL TAX ID",,,IBIFN)
.. S IBID=IBXDATA,$P(IBT,U,2,3)=(U_350.9)
. ;
. I IBSRC=1 S IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV,.IBT) Q
. ;
. I IBSRC=2 S IBID=$$SRC2(IBPTYP,.IBT) Q
. ;
. I IBSRC=3 S IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT) Q
. ;
. I IBSRC=4 S IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,.IBT) Q
. ;
. I IBSRC=5 S IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.IBT,$G(IBFUNC)) Q
. ;
. I IBSRC=6 S IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,.IBT) Q
;
Q $G(IBID)
;
GETALL(IBTYPE,IBIFN,IBPROV,IBPID) ; Extract all performing prov id's for a
; provider (IBPROV - vp format) on bill IBIFN
; IBTYPE = type of ID to return (see GETID above)
;
; Returns array IBPID(COB SEQ #)=id (pass by reference) AND
; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97)
; IBPID = current insurance co's id
;
N Z,COB,Z1,IBT
S COB=$$COBN^IBCEF(IBIFN)
F Z=1:1:3 Q:'$D(^DGCR(399,IBIFN,"I"_Z)) S IBPID(Z)=$$GETID(IBTYPE,IBIFN,IBPROV,Z,.IBT),IBPID(Z,1)=IBT I Z=COB S Z1=IBPID(Z)
Q $G(Z1)
;
SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't issued # - provider specific
; Parameter definitions for SRC1, SRC3, SRC4, SRC5, SRC6:
; IBIFN = ien of bill (file 399)
; IBINS = ien of insurance co (file 36) or *ALL* for all insurance
; (always *ALL* for SRC1)
; IBPTYP = ien of the provider id type in file 355.97
; IBPROV = (variable pointer syntax) provider on bill IBIFN
; IBT = returned as type ien^file ien^file #
;
N IBID,IB,IBRX,IBIDSV
S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
. S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB)
. I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
I IBID="",IBIDSV'="" S IBID=IBIDSV
Q IBID
;
SRC2(IB35597,IBT) ; Facility default - all providers
; IB35597 = ien of the provider id type entry in file 355.97
; IBT = returned as type ien^file ien^file #
;
S $P(IBT,U,2,3)=(+IB35597_U_355.97)
Q $P($G(^IBE(355.97,+IB35597,0)),U,4)
;
SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers
; See SRC1 for parameter definitions
N IB,IBID,IBRX,IBIDSV
S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
F S IB=$O(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*",IB)) Q:'IB D Q:IBID'=""
. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT)
. I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
I IBID="",IBIDSV'="" S IBID=IBIDSV
Q IBID
;
SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/individual provider
; See SRC1 for parameter definitions
;
N IBID,IB,IBRX,IBIDSV
S IBID="",IB=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
I $G(IBPROV) F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
. S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT)
. I IBRX,$P($G(^IBA(355.9,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
I IBID="",IBIDSV'="" S IBID=IBIDSV
Q IBID
;
SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT,IBFUNC) ; Ins co/all providers/care unit
; See SRC1 for missing parameter definitions
; IBSEQ = the numeric COB sequence of the insurance on the bill
;
Q "" ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
N IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX
S IBID="",Z=0,IBRX=$$ISRX^IBCEF1(IBIFN),IBIDSV=""
; DEM;432 - IBLNPRV variable is a flag to indicate if user input
; is claim level provider or line level provider user input.
; DEM;432 - Line provider interested in fuction 1 and 3, referring and rendering respectively.
I '$G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"PRV","B",$S($G(IBFUNC)=1:1,$$FT^IBCEF(IBIFN)=3:4,1:3),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
I $G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$S($G(IBFUNC)=1:1,1:3),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
I IBUNIT'="" F S Z=$O(^IBA(355.96,"AC",IBINS,IBPTYP,Z)) Q:'Z D Q:IBID'=""
. S IB=0 F S IB=$O(^IBA(355.91,"ACARE",Z,IB)) Q:'IB D Q:IBID'=""
.. S IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT)
.. I IBRX,$P($G(^IBA(355.91,IB,0)),U,5)'=3 S:IBIDSV="" IBIDSV=IBID S IBID="" ; Save 1st 'match' if no rx specific id
I IBID="",IBIDSV'="" S IBID=IBIDSV
Q IBID
;
SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind provider/care unit
; See SRC1 for missing parameter definitions
; IBSEQ = the numeric COB sequence of the insurance on the bill
;
Q "" ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
N IBUNIT,IBP,IBID,IB
S IBID="",IB=0
I '$G(IBLNPRV) S IBP=+$O(^DGCR(399,"PRV","B",$S($$FT^IBCEF(IBIFN)=3:3,1:4),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
I $G(IBLNPRV) S IBP=+$O(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$S($$FT^IBCEF(IBIFN)=3:3,1:4),0)),IBUNIT=$P($G(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
I $G(IBPROV),IBUNIT'="" F S IB=$O(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB)) Q:'IB D Q:IBID'=""
. S IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB,.IBT)
Q IBID
;
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
;
Q $$UNIQ1^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBPROV),$G(IBUNIT),$G(IBCU),$G(IBT))
;
UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IBCU,IBT) ; Match on most-least specific
; *** SEE PARAMETER DEFINITIONS IN IBCEP3 ***
;
; Start in file 355.91 (Specific Insurance)
;
Q $$UNIQ2^IBCEP2A($G(IBIFN),$G(IBINS),$G(IBPTYP),$G(IBUNIT),$G(IBCU),$G(IBT))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEP2 9529 printed Sep 11, 2024@02:31:29 Page 2
IBCEP2 ;ALB/TMP - EDI UTILITIES for provider ID ;13-DEC-99
+1 ;;2.0;INTEGRATED BILLING;**137,181,232,280,320,349,432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ; DBIA for access to fields 53.2,54.1,54.2 in file 200: 224
+4 ;
GETID(IBIFN,IBTYPE,IBPROV,IBSEQ,IBT,IBT1,IBFUNC) ; Extract IBTYPE id for the bill
+1 ; IBIFN = bill ien (file 399)
+2 ; IBTYPE = 2:PERFORMING PROVIDER ID (1 and 3 deleted)
+3 ; IBSEQ = numeric COB sequence of the insurance on bill
+4 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;6:ASSISTANT SURGEON;9:OTHER;
+5 ; Returns IBT = ien of the provider id type^ien of entry^file # for id
+6 ;
+7 SET IBT=0
+8 if IBTYPE'=2
QUIT ""
+9 NEW IBID,IBPTYP
+10 SET IBID=$$IDFIND(IBIFN,"",IBPROV,IBSEQ,1,.IBT,$GET(IBFUNC))
+11 IF IBID=""
SET IBT=""
+12 ;
+13 QUIT IBID
+14 ;
IDFIND(IBIFN,IBPTYP,IBPROV,IBSEQ,IBPERF,IBT,IBFUNC) ;Loop thru source levels
+1 ; (if id definition allows) to find correct ID
+2 ; IBIFN = bill ien (file 399)
+3 ; IBPTYP = ien of the provider id type in file 355.97 or if null,
+4 ; the default performing provider ID type for the ins co. in
+5 ; COB sequence IBSEQ will be calculated
+6 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
+7 ; IBSEQ = numeric COB sequence of the bill
+8 ; IBPERF = 1 if the performing provider id is needed
+9 ; IBFUNC = 1:REFERRING;2:OPERATING;3:RENDERING;4:ATTENDING;5:SUPERVISING;9:OTHER;
+10 ; Returns IBT = ptr to file 355.97^entry #^file #
+11 ;
+12 SET IBT=+$GET(IBPTYP)
+13 if '$GET(IBPERF)!'$GET(IBPROV)
QUIT ""
+14 NEW IBSPEC,IBINS,IBINS4,IBSRC,IBUP,IBID,IBALT,IBPROF,Z
+15 ; Default to current COB seq
IF $GET(IBSEQ)=""
SET IBSEQ=+$$COBN^IBCEF(IBIFN)
+16 SET IBINS=+$PIECE($GET(^DGCR(399,IBIFN,"I"_IBSEQ)),U)
SET IBINS4=$GET(^DIC(36,+IBINS,4))
+17 ;JRA IB*2.0*592 Same logic for Dental Form 7 as for CMS-1500
+18 ;S IBPROF=($$FT^IBCEF(IBIFN)=2) S:'IBPROF IBPROF=2 ;JRA IB*2.0*592 ';'
+19 ;JRA IB*2.0*592 Added 'FT'
NEW FT
SET FT=$$FT^IBCEF(IBIFN)
+20 ;JRA IB*2.0*592
SET IBPROF=(FT=2!(FT=7))
if 'IBPROF
SET IBPROF=2
+21 ; form type is CMS-1500 or J430D (prof)=1, UB-04 (inst)=2
+22 ;JWS;IB*2.0*592; No Dental default ID
+23 IF $GET(IBPTYP)=""
IF FT=7
IF $GET(IBFUNC)=1
IF IBPROF=1
SET (IBT,IBPTYP)=0
QUIT ""
+24 ; Referring Default ID on CMS-1500
IF $GET(IBPTYP)=""
IF $GET(IBFUNC)=1
IF IBPROF=1
SET (IBT,IBPTYP)=+$PIECE(IBINS4,U,4)
+25 ; Def to perf prv typ for form
IF $GET(IBPTYP)=""
SET (IBT,IBPTYP)=+$PIECE(IBINS4,U,IBPROF)
+26 ; No default id type
IF 'IBPTYP
QUIT ""
+27 SET IBSPEC=$GET(^IBE(355.97,IBPTYP,1))
SET IBSRC=$PIECE($GET(^IBE(355.97,+IBPTYP,0)),U,2)
SET IBSRC=$SELECT('IBSRC:5,1:IBSRC)
SET IBUP=1
+28 SET IBALT=0
+29 ;
+30 FOR
Begin DoDot:1
+31 ;
+32 ; Indiv prov default
IF IBSRC=1
IF $TRANSLATE($PIECE(IBSPEC,U,1,3),"^0")'=""
Begin DoDot:2
+33 NEW IBSTATE
+34 ; Federal DEA # from field 53.2 file 200
IF $PIECE(IBSPEC,U,2)
Begin DoDot:3
+35 ; DBIA224
SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS")),U,2)
+36 SET $PIECE(IBT,U,2,3)=(IBPROV_U_200)
End DoDot:3
QUIT
+37 SET IBSTATE=+$$CAREST^IBCEP2A(IBIFN)
+38 ; State issued DEA # needed
IF $PIECE(IBSPEC,U)
Begin DoDot:3
+39 if 'IBSTATE
QUIT
+40 ; Extract the state issuing DEA # from field 54.2 file 200
+41 ; DBIA224
SET Z=+$ORDER(^VA(200,+IBPROV,"PS2","B",IBSTATE,0))
SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS2",Z,0)),U,2)
+42 SET $PIECE(IBT,U,2,3)=(+IBPROV_";"_Z_U_200)
End DoDot:3
QUIT
+43 ; State license # needed
IF $PIECE(IBSPEC,U,3)
Begin DoDot:3
+44 if 'IBSTATE
QUIT
+45 ; Extract the state license # from field 54.1 file 200
+46 ; DBIA224
IF IBPROV["VA(200"
SET Z=+$ORDER(^VA(200,+IBPROV,"PS1","B",IBSTATE,0))
SET IBID=$PIECE($GET(^VA(200,+IBPROV,"PS1",Z,0)),U,2)
SET $PIECE(IBT,U,2,3)=(+IBPROV_";"_IBSTATE_U_200)
+47 IF IBPROV["IBA(355.93"
SET IBID=$PIECE($GET(^IBA(355.93,+IBPROV,0)),U,12)
SET $PIECE(IBT,U,2,3)=(+IBPROV_U_355.93)
End DoDot:3
QUIT
End DoDot:2
QUIT
+48 ;
+49 ; FACILITY FED TAX ID #
IF IBSRC=2
IF $PIECE(IBSPEC,U,4)
Begin DoDot:2
+50 NEW IBXDATA
+51 DO F^IBCEF("N-FEDERAL TAX ID",,,IBIFN)
+52 SET IBID=IBXDATA
SET $PIECE(IBT,U,2,3)=(U_350.9)
End DoDot:2
QUIT
+53 ;
+54 IF IBSRC=1
SET IBID=$$SRC1(IBIFN,"*ALL*",IBPTYP,IBPROV,.IBT)
QUIT
+55 ;
+56 IF IBSRC=2
SET IBID=$$SRC2(IBPTYP,.IBT)
QUIT
+57 ;
+58 IF IBSRC=3
SET IBID=$$SRC3(IBIFN,IBINS,IBPTYP,.IBT)
QUIT
+59 ;
+60 IF IBSRC=4
SET IBID=$$SRC4(IBIFN,IBINS,IBPTYP,IBPROV,.IBT)
QUIT
+61 ;
+62 IF IBSRC=5
SET IBID=$$SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,.IBT,$GET(IBFUNC))
QUIT
+63 ;
+64 IF IBSRC=6
SET IBID=$$SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,.IBT)
QUIT
End DoDot:1
if 'IBUP!($GET(IBID)'="")
QUIT
SET IBSRC=IBSRC-1
if 'IBSRC
QUIT
+65 ;
+66 QUIT $GET(IBID)
+67 ;
GETALL(IBTYPE,IBIFN,IBPROV,IBPID) ; Extract all performing prov id's for a
+1 ; provider (IBPROV - vp format) on bill IBIFN
+2 ; IBTYPE = type of ID to return (see GETID above)
+3 ;
+4 ; Returns array IBPID(COB SEQ #)=id (pass by reference) AND
+5 ; IBPID(COB SEQ #,1)=ien of id type (ptr to 355.97)
+6 ; IBPID = current insurance co's id
+7 ;
+8 NEW Z,COB,Z1,IBT
+9 SET COB=$$COBN^IBCEF(IBIFN)
+10 FOR Z=1:1:3
if '$DATA(^DGCR(399,IBIFN,"I"_Z))
QUIT
SET IBPID(Z)=$$GETID(IBTYPE,IBIFN,IBPROV,Z,.IBT)
SET IBPID(Z,1)=IBT
IF Z=COB
SET Z1=IBPID(Z)
+11 QUIT $GET(Z1)
+12 ;
SRC1(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Licensing/gov't issued # - provider specific
+1 ; Parameter definitions for SRC1, SRC3, SRC4, SRC5, SRC6:
+2 ; IBIFN = ien of bill (file 399)
+3 ; IBINS = ien of insurance co (file 36) or *ALL* for all insurance
+4 ; (always *ALL* for SRC1)
+5 ; IBPTYP = ien of the provider id type in file 355.97
+6 ; IBPROV = (variable pointer syntax) provider on bill IBIFN
+7 ; IBT = returned as type ien^file ien^file #
+8 ;
+9 NEW IBID,IB,IBRX,IBIDSV
+10 SET IBID=""
SET IB=0
SET IBRX=$$ISRX^IBCEF1(IBIFN)
SET IBIDSV=""
+11 IF $GET(IBPROV)
FOR
SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
if 'IB
QUIT
Begin DoDot:1
+12 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB)
+13 ; Save 1st 'match' if no rx specific id
IF IBRX
IF $PIECE($GET(^IBA(355.9,IB,0)),U,5)'=3
if IBIDSV=""
SET IBIDSV=IBID
SET IBID=""
End DoDot:1
if IBID'=""
QUIT
+14 IF IBID=""
IF IBIDSV'=""
SET IBID=IBIDSV
+15 QUIT IBID
+16 ;
SRC2(IB35597,IBT) ; Facility default - all providers
+1 ; IB35597 = ien of the provider id type entry in file 355.97
+2 ; IBT = returned as type ien^file ien^file #
+3 ;
+4 SET $PIECE(IBT,U,2,3)=(+IB35597_U_355.97)
+5 QUIT $PIECE($GET(^IBE(355.97,+IB35597,0)),U,4)
+6 ;
SRC3(IBIFN,IBINS,IBPTYP,IBT) ; Ins co/all providers
+1 ; See SRC1 for parameter definitions
+2 NEW IB,IBID,IBRX,IBIDSV
+3 SET IBID=""
SET IB=0
SET IBRX=$$ISRX^IBCEF1(IBIFN)
SET IBIDSV=""
+4 FOR
SET IB=$ORDER(^IBA(355.91,"AC",IBINS,IBPTYP,"*N/A*",IB))
if 'IB
QUIT
Begin DoDot:1
+5 SET IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,"",IB,.IBT)
+6 ; Save 1st 'match' if no rx specific id
IF IBRX
IF $PIECE($GET(^IBA(355.91,IB,0)),U,5)'=3
if IBIDSV=""
SET IBIDSV=IBID
SET IBID=""
End DoDot:1
if IBID'=""
QUIT
+7 IF IBID=""
IF IBIDSV'=""
SET IBID=IBIDSV
+8 QUIT IBID
+9 ;
SRC4(IBIFN,IBINS,IBPTYP,IBPROV,IBT) ; Insurance co/individual provider
+1 ; See SRC1 for parameter definitions
+2 ;
+3 NEW IBID,IB,IBRX,IBIDSV
+4 SET IBID=""
SET IB=0
SET IBRX=$$ISRX^IBCEF1(IBIFN)
SET IBIDSV=""
+5 IF $GET(IBPROV)
FOR
SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
if 'IB
QUIT
Begin DoDot:1
+6 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,"",IB,.IBT)
+7 ; Save 1st 'match' if no rx specific id
IF IBRX
IF $PIECE($GET(^IBA(355.9,IB,0)),U,5)'=3
if IBIDSV=""
SET IBIDSV=IBID
SET IBID=""
End DoDot:1
if IBID'=""
QUIT
+8 IF IBID=""
IF IBIDSV'=""
SET IBID=IBIDSV
+9 QUIT IBID
+10 ;
SRC5(IBIFN,IBINS,IBPTYP,IBSEQ,IBT,IBFUNC) ; Ins co/all providers/care unit
+1 ; See SRC1 for missing parameter definitions
+2 ; IBSEQ = the numeric COB sequence of the insurance on the bill
+3 ;
+4 ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
QUIT ""
+5 NEW IBP,IBUNIT,IBID,IB,Z,IBIDSV,IBRX
+6 SET IBID=""
SET Z=0
SET IBRX=$$ISRX^IBCEF1(IBIFN)
SET IBIDSV=""
+7 ; DEM;432 - IBLNPRV variable is a flag to indicate if user input
+8 ; is claim level provider or line level provider user input.
+9 ; DEM;432 - Line provider interested in fuction 1 and 3, referring and rendering respectively.
+10 IF '$GET(IBLNPRV)
SET IBP=+$ORDER(^DGCR(399,IBIFN,"PRV","B",$SELECT($GET(IBFUNC)=1:1,$$FT^IBCEF(IBIFN)=3:4,1:3),0))
SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
+11 IF $GET(IBLNPRV)
SET IBP=+$ORDER(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$SELECT($GET(IBFUNC)=1:1,1:3),0))
SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
+12 IF IBUNIT'=""
FOR
SET Z=$ORDER(^IBA(355.96,"AC",IBINS,IBPTYP,Z))
if 'Z
QUIT
Begin DoDot:1
+13 SET IB=0
FOR
SET IB=$ORDER(^IBA(355.91,"ACARE",Z,IB))
if 'IB
QUIT
Begin DoDot:2
+14 SET IBID=$$UNIQ2(IBIFN,IBINS,IBPTYP,IBUNIT,IB,.IBT)
+15 ; Save 1st 'match' if no rx specific id
IF IBRX
IF $PIECE($GET(^IBA(355.91,IB,0)),U,5)'=3
if IBIDSV=""
SET IBIDSV=IBID
SET IBID=""
End DoDot:2
if IBID'=""
QUIT
End DoDot:1
if IBID'=""
QUIT
+16 IF IBID=""
IF IBIDSV'=""
SET IBID=IBIDSV
+17 QUIT IBID
+18 ;
SRC6(IBIFN,IBINS,IBPTYP,IBPROV,IBSEQ,IBT) ; Ins co/ind provider/care unit
+1 ; See SRC1 for missing parameter definitions
+2 ; IBSEQ = the numeric COB sequence of the insurance on the bill
+3 ;
+4 ;DEM;432 - Pieces 9, 10, and 11 were deleted in 2006. So, code doesn't do anything other than return NULL.
QUIT ""
+5 NEW IBUNIT,IBP,IBID,IB
+6 SET IBID=""
SET IB=0
+7 IF '$GET(IBLNPRV)
SET IBP=+$ORDER(^DGCR(399,"PRV","B",$SELECT($$FT^IBCEF(IBIFN)=3:3,1:4),0))
SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"PRV",IBP,0)),U,8+IBSEQ)
+8 IF $GET(IBLNPRV)
SET IBP=+$ORDER(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV","B",$SELECT($$FT^IBCEF(IBIFN)=3:3,1:4),0))
SET IBUNIT=$PIECE($GET(^DGCR(399,IBIFN,"CP",IBLNPRV("PROCIEN"),"LNPRV",IBP,0)),U,8+IBSEQ)
+9 IF $GET(IBPROV)
IF IBUNIT'=""
FOR
SET IB=$ORDER(^IBA(355.9,"AD",IBPTYP,IBPROV,IBINS,IB))
if 'IB
QUIT
Begin DoDot:1
+10 SET IBID=$$UNIQ1(IBIFN,IBINS,IBPTYP,IBPROV,IBUNIT,IB,.IBT)
End DoDot:1
if IBID'=""
QUIT
+11 QUIT IBID
+12 ;
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 QUIT $$UNIQ1^IBCEP2A($GET(IBIFN),$GET(IBINS),$GET(IBPTYP),$GET(IBPROV),$GET(IBUNIT),$GET(IBCU),$GET(IBT))
+7 ;
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 QUIT $$UNIQ2^IBCEP2A($GET(IBIFN),$GET(IBINS),$GET(IBPTYP),$GET(IBUNIT),$GET(IBCU),$GET(IBT))
