- 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 Jan 18, 2025@03:11:30 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