Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: IBCEF75

IBCEF75.m

Go to the documentation of this file.
  1. IBCEF75 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
  1. ;;2.0;INTEGRATED BILLING;**320,371,400,432,592**;21-MAR-94;Build 58
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. G AWAY
  1. AWAY Q
  1. ;
  1. ALLIDS(IBIFN,IBXSAVE,IBSTRIP,SEG) ; Return all of the Provider IDS
  1. I '$D(IBSTRIP) S IBSTRIP=0
  1. I '$D(SEG) S SEG=""
  1. N IBXIEN,ARINFO,ARID,ARQ,IBFRMTYP,ARIEN,ARINS,Z0,DAT,I,SORT1,SORT2,SORT3,COB,IBCCOB
  1. ;
  1. S IBXIEN=IBIFN
  1. D ALLPROV^IBCEF7 ; Get the Person ID's (Returns IBXSAVE)
  1. S DAT=$$PROVID^IBCEF73(IBIFN)
  1. S DAT("QUAL")=IBXSAVE("ID") ; this value was also passed back by above function
  1. S SORT1="" F S SORT1=$O(IBXSAVE("PROVINF",IBIFN,SORT1)) Q:SORT1="" D
  1. . S SORT2=0 F S SORT2=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2)) Q:SORT2="" D
  1. .. S SORT3=0 F S SORT3=$O(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3)) Q:SORT3="" D
  1. ... ;*432/TAZ - Primary node now points to NPI
  1. ... N IBPRVPTR,IBNPI
  1. ... S IBPRVPTR=IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3),IBNPI=$$GETNPI^IBCEF73A(IBPRVPTR)
  1. ... S IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,0)="PRIMARY"_U_U_$$STRIP^IBCEF76($S(IBNPI]"":"XX",1:"")_U_IBNPI,1,U,IBSTRIP)
  1. ... F I=1:1 Q:'$D(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,SORT3,I)) D
  1. .... 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)
  1. ;
  1. D LFIDS^IBCEF76(IBIFN,.IBXSAVE,IBSTRIP,SEG) ; Get the Lab/Facility IDs
  1. ;
  1. S IBFRMTYP=$$FT^IBCEF(IBIFN)
  1. ;JWS;IB*2.0*592; Dental form 7
  1. S ARIEN=$S(IBFRMTYP=2:3,IBFRMTYP=7:3,1:4)
  1. S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
  1. F COB=1:1:3 D
  1. . S SORT1=$S(COB=IBCCOB:"C",1:"O")
  1. . S SORT2=$S(SORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
  1. . S ARINFO=$G(IBXSAVE("PROVINF",IBIFN,SORT1,SORT2,ARIEN,1))
  1. . ;
  1. . D BPIDS(IBIFN,.IBXSAVE,SORT1,SORT2,COB,IBSTRIP,SEG)
  1. Q
  1. ;
  1. BPIDS(IBIFN,IDS,SORT1,SORT2,COB,IBSTRIP,SEG) ; Get all the billing provider IDs and qualifiers from the claim and file 355.92
  1. N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,MAIN,IBCCOB,USED,PLANTYPE,I,CNT,QUAL,ARF,M1,DEF,IDDIV,IBLIMIT,IEN,ID,IB2
  1. ;
  1. S DAT=$G(^DGCR(399,IBIFN,0))
  1. ;JWS;IB*2.0*592
  1. S IBFRMTYP=$$FT^IBCEF(IBIFN),IBFRMTYP=$S(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
  1. S IBCARE=$S($$ISRX^IBCEF1(IBIFN):3,1:0) ;if an Rx refill bill
  1. S:IBCARE=0 IBCARE=$$INPAT^IBCEF(IBIFN) S:'IBCARE IBCARE=2 ;1-inp,2-out
  1. S IBDIV=+$P(DAT,U,22)
  1. S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
  1. S IBCCOB=$$COBN^IBCEF(IBIFN) ; Current Insurance
  1. S IBINS=$P($G(^DGCR(399,IBIFN,"I"_COB)),U)
  1. Q:IBINS=""
  1. ;
  1. S IDS("BILLING PRV",IBIFN,SORT1,SORT2)=$E("PST",COB)
  1. ;
  1. ; Primary ID
  1. S IDS("BILLING PRV",IBIFN,SORT1,SORT2,0)=$$STRIP^IBCEF76($$TAXID(),1,U,IBSTRIP)
  1. S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,0),U))=""
  1. ;
  1. ; Secondary #1 - This is the ID Emdeon uses for sorting
  1. S IDS("BILLING PRV",IBIFN,SORT1,SORT2,1)=$$STRIP^IBCEF76($$BPSID1(IBDIV),1,U,IBSTRIP)
  1. S USED($P(IDS("BILLING PRV",IBIFN,SORT1,SORT2,1),U))=""
  1. ;
  1. ; Check if this is a plan type which gets no secondary IDs
  1. S M1=$G(^DGCR(399,IBIFN,"M1"))
  1. ; the following check is the current value of the flag, not when the claim was created.
  1. S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
  1. I PLANTYPE]"",$D(^DIC(36,IBINS,13,"B",PLANTYPE)) Q
  1. ;
  1. ; Secondary #2
  1. ; If there is a ID send with quailifer (stored or computed)
  1. I $TR($P(M1,U,COB+1)," ")]"" D
  1. . S QUAL=""
  1. . S DAT=$P(M1,U,COB+9)
  1. . I DAT S QUAL=$$STRIP^IBCEF76($P($G(^IBE(355.97,DAT,0)),U,3),1,,IBSTRIP)
  1. . ; the null check is needed to be backwards compatible
  1. . I QUAL=""!(QUAL="1J") S QUAL=$$STRIP^IBCEF76($$OLDWAY(IBIFN,COB),1,,IBSTRIP)
  1. . S IB2=QUAL_U_$$STRIP^IBCEF76($P(M1,U,COB+1),1,,IBSTRIP)
  1. ;
  1. ;WCJ;IB*2.0*432;START
  1. ;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)
  1. ;
  1. I $G(IB2)]"",$P(IB2,U)]"",$P(IB2,U,2)]"" D ;TAZ - Changed $G(IB2) to $G(IB2)]""
  1. . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)=IB2
  1. . ;S IDS("BILLING PRV",IBIFN,SORT1,SORT2,2,"PTQ")=$$OLDWAY(IBIFN,COB)
  1. . S USED($P(IB2,U))=""
  1. ;WCJ;IB*2.0*432
  1. ;
  1. S CNT=$S('$D(IDS("BILLING PRV",IBIFN,SORT1,SORT2,2)):2,1:3)
  1. S IBLIMIT=8
  1. S IEN=0 F S IEN=$O(^IBA(355.92,"B",IBINS,IEN)) Q:IEN="" D Q:CNT>IBLIMIT
  1. . S DAT=$G(^IBA(355.92,IEN,0))
  1. . Q:$P(DAT,U,8)'="A" ; only allow additional IDs
  1. . Q:$P(DAT,U,7)="" ; No Provider ID
  1. . Q:$P(DAT,U,6)="" ; No ID Qualifier
  1. . I IBFRMTYP=1 Q:$P(DAT,U,4)=2
  1. . I IBFRMTYP=2 Q:$P(DAT,U,4)=1
  1. . ;JWS;IB*2.0*592;Dental form
  1. . I IBFRMTYP=7 Q
  1. . ;
  1. . ; Check if we already have one of these
  1. . S QUAL=$$STRIP^IBCEF76($P(DAT,U,6),1,,IBSTRIP)
  1. . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
  1. . Q:QUAL=""
  1. . Q:$D(USED(QUAL))
  1. . ;
  1. . S IDS("BILLING PRV",IBIFN,SORT1,SORT2,CNT)=QUAL_U_$$STRIP^IBCEF76($P(DAT,U,7),1,,IBSTRIP)
  1. . S CNT=CNT+1,USED(QUAL)=""
  1. ;
  1. Q
  1. ;
  1. 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
  1. N PLANTYPE
  1. S PLANTYPE=$$POLTYP^IBCEF3(IBIFN,COB)
  1. Q $$SOP^IBCEP2B(IBIFN,PLANTYPE)
  1. ;
  1. BPSID1(DIV) ; Return the Billing Provider Secondary ID #1 and qualifier which Emdeon uses to sort IBIFNs
  1. N DATA
  1. S DATA=$P($$SITE^VASITE(DT,$S(DIV:DIV,1:+$$PRIM^VASITE(DT))),U,3)
  1. S DATA=$E("0000",1,7-$L(DATA))_$E(DATA,4,7)
  1. Q "G5"_U_DATA
  1. ;
  1. TAXID() ; Return the Billing Provider Primary ID and qualifier which is the TAXID for the site and also the qualifier
  1. N DATA
  1. S DATA=$P($G(^IBE(350.9,1,1)),U,5)
  1. S DATA=$$NOPUNCT^IBCEF(DATA,1)
  1. Q 24_U_DATA
  1. ;
  1. CLEANUP(IBXSAVE) ; Clean up
  1. K IBXSAVE("PROVINF")
  1. K IBXSAVE("LAB/FAC")
  1. K IBXSAVE("BILLING PRV")
  1. K IBXSAVE("ID")
  1. Q