IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
;;2.0;INTEGRATED BILLING;**320,371,400,432,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
G AWAY
AWAY Q
;
ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
I '$D(IBSTRIP) S IBSTRIP=0
I '$D(SEG) S SEG=""
N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
;
S IBXIEN=IBIFN
D ALLPROV^IBCEF7 ; Get the Person ID's (Returns IBXSAVE)
S DAT=$$PROVID^IBCEF73(IBIFN)
S DAT("QUAL")=IBXSAVE("ID") ; this value was also passed back by above function
S SORT1="" F S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1="" D
. S SORT2=0 F S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2="" D
.. S SORT3=0 F S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3)) Q:SORT3="" D
... ;*432/TAZ - Primary node now points to NPI
... N IBPRVPTR,IBNPI
... S IBPRVPTR=IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3),IBNPI=$$GETNPI^IBCEF73A(IBPRVPTR)
... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I)) D
.... S $P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($P(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
;
D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs
;
S IBFRMTYP=$$FT^IBCEF(IBIFN)
;JWS;IB*2.0*592; Dental form 7
S ARIEN=$S(IBFRMTYP=2:3,IBFRMTYP=7:3,1:4)
S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
F COB=1:1:3 D
. S SORT1=$S(COB=IBCCOB:"C",1:"O")
. S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
. S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
. ;
. D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
Q
;
BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
;
S DAT=$G(^DGCR(399,IBIFN,0))
;JWS;IB*2.0*592
S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN) S:'IBCARE IBCARE=2 ;1-inp,2-out
S IBDIV=+$P(DAT,U,22)
S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
Q:IBINS=""
;
S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
;
; Primary ID
S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
;
; Secondary #1 - This is the ID Emdeon uses for sorting
S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
;
; Check if this is a plan type which gets no secondary IDs
S M1=$G(^DGCR(399,IBIFN,"M1"))
; the following check is the current value of the flag, not when the claim was created.
S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q
;
; Secondary #2
; If there is a ID send with quailifer (stored or computed)
I $TR($P(M1,U,COB+1)," ")]"" D
. S QUAL=""
. S DAT=$P(M1,U,COB+9)
. I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
. ; the null check is needed to be backwards compatible
. I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
. S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
;
;WCJ;IB*2.0*432;START
;I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
;
I $G(IB2)]"",$P(IB2,U)]"",$P(IB2,U,2)]"" D ;TAZ - Changed $G(IB2) to $G(IB2)]""
. S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
. ;S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
. S USED($P(IB2,U))=""
;WCJ;IB*2.0*432
;
S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
S IBLIMIT=8
S IEN=0 F S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN="" D Q:CNT>IBLIMIT
. S DAT=$G(^IBA(355.92,IEN,0))
. Q:$P(DAT,U,8)'="A" ; only allow additional IDs
. Q:$P(DAT,U,7)="" ; No Provider ID
. Q:$P(DAT,U,6)="" ; No ID Qualifier
. I IBFRMTYP=1 Q:$P(DAT,U,4)=2
. I IBFRMTYP=2 Q:$P(DAT,U,4)=1
. ;JWS;IB*2.0*592;Dental form
. I IBFRMTYP=7 Q
. ;
. ; Check if we already have one of these
. S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
. S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
. Q:QUAL=""
. Q:$D(USED(QUAL))
. ;
. S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
. S CNT=CNT+1,USED(QUAL)=""
;
Q
;
OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim.
; It's based on the plan type. This is used for Billing Provider Secondary ID #2
N PLANTYPE
S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
;
BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
N DATA
S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$PRIM^VASITE(DT))),U,3)
S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
Q "G5"_U_DATA
;
TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
N DATA
S DATA=$P($G(^IBE(350.9,1,1)),U,5)
S DATA=$$NOPUNCT^IBCEF(DATA,1)
Q 24_U_DATA
;
CLEANUP(IBXSAVE) ; Clean up
K IBXSAVE("PROVINF")
K IBXSAVE("LAB/FAC")
K IBXSAVE("BILLING PRV")
K IBXSAVE("ID")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF75 5741 printed Oct 16, 2024@18:10:58 Page 2
IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
+1 ;;2.0;INTEGRATED BILLING;**320,371,400,432,592**;21-MAR-94;Build 58
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 GOTO AWAY
AWAY QUIT
+1 ;
ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
+1 IF '$DATA(IBSTRIP)
SET IBSTRIP=0
+2 IF '$DATA(SEG)
SET SEG=""
+3 NEW IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
+4 ;
+5 SET IBXIEN=IBIFN
+6 ; Get the Person ID's (Returns IBXSAVE)
DO ALLPROV^IBCEF7
+7 SET DAT=$$PROVID^IBCEF73(IBIFN)
+8 ; this value was also passed back by above function
SET DAT("QUAL")=IBXSAVE("ID")
+9 SET SORT1=""
FOR
SET SORT1=$ORDER(IBXSAVE("PROVINF",IBIFN,SORT1))
if SORT1=""
QUIT
Begin DoDot:1
+10 SET SORT2=0
FOR
SET SORT2=$ORDER(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2))
if SORT2=""
QUIT
Begin DoDot:2
+11 SET SORT3=0
FOR
SET SORT3=$ORDER(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3))
if SORT3=""
QUIT
Begin DoDot:3
+12 ;*432/TAZ - Primary node now points to NPI
+13 NEW IBPRVPTR,IBNPI
+14 SET IBPRVPTR=IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3)
SET IBNPI=$$GETNPI^IBCEF73A(IBPRVPTR)
+15 SET IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($SELECT(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
+16 FOR I=1:1
if '$DATA(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I))
QUIT
Begin DoDot:4
+17 SET $PIECE(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4)=$$STRIP^IBCEF76($PIECE(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I),U,3,4),1,U,IBSTRIP)
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+18 ;
+19 ; Get the Lab/Facility IDs
DO LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG)
+20 ;
+21 SET IBFRMTYP=$$FT^IBCEF(IBIFN)
+22 ;JWS;IB*2.0*592; Dental form 7
+23 SET ARIEN=$SELECT(IBFRMTYP=2:3,IBFRMTYP=7:3,1:4)
+24 ; Current Insurance
SET IBCCOB=$$COBN^IBCEF(IBIFN)
+25 FOR COB=1:1:3
Begin DoDot:1
+26 SET SORT1=$SELECT(COB=IBCCOB:"C",1:"O")
+27 SET SORT2=$SELECT(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
+28 SET ARINFO=$GET(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
+29 ;
+30 DO BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
End DoDot:1
+31 QUIT
+32 ;
BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
+1 NEW DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
+2 ;
+3 SET DAT=$GET(^DGCR(399,IBIFN,0))
+4 ;JWS;IB*2.0*592
+5 SET IBFRMTYP=$$FT^IBCEF(IBIFN)
SET IBFRMTYP=$SELECT(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
+6 ;if an Rx refill bill
SET IBCARE=$SELECT($$ISRX^IBCEF1(IBIFN):3,1:0)
+7 ;1-inp,2-out
if IBCARE=0
SET IBCARE=$$INPAT^IBCEF(IBIFN)
if 'IBCARE
SET IBCARE=2
+8 SET IBDIV=+$PIECE(DAT,U,22)
+9 ; get the IEN for main Division
SET MAIN=$$MAIN^IBCEP2B()
+10 ; Current Insurance
SET IBCCOB=$$COBN^IBCEF(IBIFN)
+11 SET IBINS=$PIECE($GET(^DGCR(399,IBIFN,"I"_COB)),U)
+12 if IBINS=""
QUIT
+13 ;
+14 SET IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$EXTRACT("PST",COB)
+15 ;
+16 ; Primary ID
+17 SET IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
+18 SET USED($PIECE(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
+19 ;
+20 ; Secondary #1 - This is the ID Emdeon uses for sorting
+21 SET IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
+22 SET USED($PIECE(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
+23 ;
+24 ; Check if this is a plan type which gets no secondary IDs
+25 SET M1=$GET(^DGCR(399,IBIFN,"M1"))
+26 ; the following check is the current value of the flag, not when the claim was created.
+27 SET PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
+28 IF PLANTYPE]""
IF $DATA(^DIC(36,IBINS,13,"B",PLANTYPE))
QUIT
+29 ;
+30 ; Secondary #2
+31 ; If there is a ID send with quailifer (stored or computed)
+32 IF $TRANSLATE($PIECE(M1,U,COB+1)," ")]""
Begin DoDot:1
+33 SET QUAL=""
+34 SET DAT=$PIECE(M1,U,COB+9)
+35 IF DAT
SET QUAL=$$STRIP^IBCEF76($PIECE($GET(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
+36 ; the null check is needed to be backwards compatible
+37 IF QUAL=""!(QUAL="1J")
SET QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
+38 SET IB2=QUAL_U_$$STRIP^IBCEF76($PIECE(M1,U,COB+1),1,,IBSTRIP)
End DoDot:1
+39 ;
+40 ;WCJ;IB*2.0*432;START
+41 ;I $TR($P(M1,U,COB+1)," ")="" S IB2=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)_U_$$STRIP^IBCEF76($$GET1^DIQ(350.9,1,1.05),1,,IBSTRIP)
+42 ;
+43 ;TAZ - Changed $G(IB2) to $G(IB2)]""
IF $GET(IB2)]""
IF $PIECE(IB2,U)]""
IF $PIECE(IB2,U,2)]""
Begin DoDot:1
+44 SET IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
+45 ;S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
+46 SET USED($PIECE(IB2,U))=""
End DoDot:1
+47 ;WCJ;IB*2.0*432
+48 ;
+49 SET CNT=$SELECT('$DATA(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
+50 SET IBLIMIT=8
+51 SET IEN=0
FOR
SET IEN=$ORDER(^IBA(355.92,"B",IBINS,IEN))
if IEN=""
QUIT
Begin DoDot:1
+52 SET DAT=$GET(^IBA(355.92,IEN,0))
+53 ; only allow additional IDs
if $PIECE(DAT,U,8)'="A"
QUIT
+54 ; No Provider ID
if $PIECE(DAT,U,7)=""
QUIT
+55 ; No ID Qualifier
if $PIECE(DAT,U,6)=""
QUIT
+56 IF IBFRMTYP=1
if $PIECE(DAT,U,4)=2
QUIT
+57 IF IBFRMTYP=2
if $PIECE(DAT,U,4)=1
QUIT
+58 ;JWS;IB*2.0*592;Dental form
+59 IF IBFRMTYP=7
QUIT
+60 ;
+61 ; Check if we already have one of these
+62 SET QUAL=$$STRIP^IBCEF76($PIECE(DAT,U,6),1,,IBSTRIP)
+63 SET QUAL=$PIECE($GET(^IBE(355.97,QUAL,0)),U,3)
+64 if QUAL=""
QUIT
+65 if $DATA(USED(QUAL))
QUIT
+66 ;
+67 SET IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($PIECE(DAT,U,7),1,,IBSTRIP)
+68 SET CNT=CNT+1
SET USED(QUAL)=""
End DoDot:1
if CNT>IBLIMIT
QUIT
+69 ;
+70 QUIT
+71 ;
OLDWAY(IBIFN,COB) ; Figure out the qualifier the old way if it's not stored with the claim.
+1 ; It's based on the plan type. This is used for Billing Provider Secondary ID #2
+2 NEW PLANTYPE
+3 SET PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
+4 QUIT $$SOP^IBCEP2B(IBIFN,PLANTYPE)
+5 ;
BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
+1 NEW DATA
+2 SET DATA=$PIECE($$SITE^VASITE(DT,$SELECT(DIV:DIV,1:+$$PRIM^VASITE(DT))),U,3)
+3 SET DATA=$EXTRACT("0000",1,7-$LENGTH(DATA))_$EXTRACT(DATA,4,7)
+4 QUIT "G5"_U_DATA
+5 ;
TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
+1 NEW DATA
+2 SET DATA=$PIECE($GET(^IBE(350.9,1,1)),U,5)
+3 SET DATA=$$NOPUNCT^IBCEF(DATA,1)
+4 QUIT 24_U_DATA
+5 ;
CLEANUP(IBXSAVE) ; Clean up
+1 KILL IBXSAVE("PROVINF")
+2 KILL IBXSAVE("LAB/FAC")
+3 KILL IBXSAVE("BILLING PRV")
+4 KILL IBXSAVE("ID")
+5 QUIT
