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

IBCEF76.m

Go to the documentation of this file.
  1. IBCEF76 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
  1. ;;2.0;INTEGRATED BILLING;**320,349,400,432,516,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. LFIDS(IBIFN,IDS,IBSTRIP,SEG) ;
  1. ; Pass in the the internal claim number and return the array of IDS.
  1. ; IDS("C"urrent or "O"ther, Order of Insurance within subscript 1, order of ID within subscript 2)
  1. ; IDS("C",1)="P"
  1. ; IDS("C",1,0)=Qualifier^Primary ID
  1. ; IDS("C",1,1)=Qualifier^Sec ID #1
  1. ; IDS("C",1,2)=Qualifier^Sec ID #2
  1. ;
  1. N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,OUTFAC,MAIN,IBCCOB,TMPIDS,COB,IBSORT1,IBSORT2,IBLIMIT,IBLF
  1. ;
  1. S DAT=$G(^DGCR(399,IBIFN,0))
  1. ;JWS;IB*2.0*592;Dental claim form 7
  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 OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
  1. S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
  1. ;
  1. S IBCCOB=$$COBN^IBCEF(IBIFN)
  1. F COB=1:1:3 D
  1. . S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
  1. . S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
  1. . S IBLIMIT=$S(IBSORT1="C":5,1:3) ; Limit secondary IDs
  1. . S DAT=$G(^DGCR(399,IBIFN,"I"_COB))
  1. . ;
  1. . S IBINS=$P(DAT,U) ; insurance PTR 36
  1. . Q:IBINS=""
  1. . ;
  1. . ; IB*2*400 - esg - 9/24/08, 2/24/09 - if there is no service facility for this claim at this COB, then get out
  1. . S IBLF=$$B^IBCEF79(IBIFN,COB) ; billing provider/service facility function
  1. . I $P(IBLF,U,3)="" Q ; no service facility data at this COB, don't build this "LAB/FAC" area
  1. . ;
  1. . I OUTFAC]"" D Q
  1. .. D NONVALF(IBIFN,OUTFAC_";IBA(355.93,",IBINS,IBFRMTYP,IBCARE,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
  1. . ;
  1. . I OUTFAC="" D
  1. .. ;
  1. .. ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
  1. .. ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
  1. .. ; that function and INSFLGS^^IBCEF79 for more information.
  1. .. ;
  1. .. ; if ins co flag says to not send svc fac data and we're sending an EDI claim, then get out
  1. .. ;I '$$SENDSF^IBCEF79(IBIFN,COB),$G(^TMP("IBTX",$J,IBIFN)) Q
  1. .. ;
  1. .. ;IB*2.0*432/TAZ Moved Taxid setup inside VALF look to send as secondary ID for Medicare claims.
  1. .. ;S IDS("LAB/FAC",IBIFN,IBSORT1,IBSORT2,0)=$$STRIP($$TAXID^IBCEF75(),1,U,IBSTRIP)
  1. .. D VALF(IBIFN,IBINS,IBFRMTYP,IBDIV,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
  1. Q
  1. ;
  1. VALF(IBIFN,INS,FT,DIV,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get VA Lab/Fac Secondary IDs
  1. ; Pass in INS - IEN to file 36
  1. ; FT - 1 = UB 2 = 1500, 7 = J430D
  1. ; DIV - PTR to 40.8
  1. ;
  1. N Z,Z0,ID,QUAL,MAIN,IDTBL,CNT,Z,IBMCR
  1. S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
  1. S Z=0 F S Z=$O(^IBA(355.92,"B",INS,Z)) Q:'Z D
  1. . ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
  1. . I $$FT^IBCEF(IBIFN)=7 Q
  1. . S Z0=$G(^IBA(355.92,Z,0))
  1. . Q:$P(Z0,U,8)'="LF" ; Screen out anything other than Lab or Facility
  1. . I +$P(Z0,U,4) Q:$P(Z0,U,4)'=FT ; Form type must match that passed in or be a 0 which allows both
  1. . S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
  1. . S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
  1. . Q:QUAL="" ; Needs a qualifier
  1. . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
  1. . I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
  1. . I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
  1. . I $P(Z0,U,5)=""!($P(Z0,U,5)=0)!($P(Z0,U,5)=MAIN) S IDTBL("DEF",QUAL)=ID ; set up default for main division
  1. . I $P(Z0,U,5)=DIV S IDTBL("DIV",QUAL)=ID ; set up default for division
  1. S CNT=0
  1. S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)
  1. ;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID ; only if it's not a printed form
  1. S IBMCR=""
  1. ;JWS;IB*2.0*592;Dental
  1. I '(($G(IBXFORM)=2)!($G(IBXFORM)=3)!($G(IBXFORM)=7)) S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
  1. I IBMCR S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($P($$TAXID^IBCEF75(),U,2),1,U,IBSTRIP)
  1. I $D(IDTBL("DIV")) D Q
  1. . S Z="" F S Z=$O(IDTBL("DIV",Z)) Q:Z="" D
  1. .. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
  1. .. I IBMCR,(Z=24) Q
  1. .. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DIV",Z) Q:CNT=IBLIMIT
  1. I $D(IDTBL("DEF")) D Q
  1. . S Z="" F S Z=$O(IDTBL("DEF",Z)) Q:Z="" D
  1. .. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
  1. .. I IBMCR,(Z=24) Q
  1. .. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DEF",Z) Q:CNT=IBLIMIT
  1. Q
  1. ;
  1. NONVALF(IBIFN,PRV,INS,FT,PT,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get Non VA Lab/Fac Secondary IDs
  1. ; Pass in PRV - VPTR - PTR to 355.93 (in format of variabel pointer IEN;IBA(355.93,
  1. ; Pass in INS - PTR to 36 of null (not provide by insurance company)
  1. ; FT - 1 = UB 2 = 1500 7 = J430D
  1. ; PT - Patient Type - 1 inpatient 2 outpatient
  1. ; IDS array being returned
  1. ; SORT1 - "C"urrent or "O"ther
  1. ; SORT2 - 1 if current or (1 or 2 if other)
  1. N Z,Z0,ID,QUAL,IDTBL,CNT,IBMCR
  1. S Z=0 F S Z=$O(^IBA(355.9,"B",PRV,Z)) Q:'Z D
  1. . ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
  1. . I $$FT^IBCEF(IBIFN)=7 Q
  1. . S Z0=$G(^IBA(355.9,Z,0))
  1. . I +$P(Z0,U,4) Q:$P(Z0,U,4)'=FT ; Form type must match that passed in or be a 0 which allows both UB and 1500
  1. . I +$P(Z0,U,5) Q:$P(Z0,U,5)'=PT ; Patient type must match that passed in or be a 0 which allows both in patient and outpatient
  1. . I INS]"",$P(Z0,U,2)]"",INS'=$P(Z0,U,2) Q
  1. . S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
  1. . Q:ID=""
  1. . S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
  1. . Q:QUAL="" ; Needs a qualifier
  1. . S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
  1. . Q:QUAL=""
  1. . I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
  1. . I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
  1. . I $G(SEG)="SUB1" Q:$$SUB1^IBCEF73(FT)'[(U_QUAL_U)
  1. . I $P(Z0,U,2)="" S IDTBL("OWN",QUAL)=ID ; set up default of lab or facilities own ids
  1. . I $P(Z0,U,2)=INS S IDTBL("INS",QUAL)=ID ; set up default for division
  1. ;
  1. S CNT=0
  1. S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)_U_PRV
  1. S IDS("LAB/FAC",IBIFN,SORT1,SORT2,"CONTACT")=$G(^IBA(355.93,+PRV,1))
  1. ; get primary
  1. S Z0=$G(^IBA(355.93,+PRV,0))
  1. ;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID
  1. S IBMCR=""
  1. ;JWS;IB*2.0*592;Dental
  1. I '(($G(IBXFORM)=2)!($G(IBXFORM)=3)!($G(IBXFORM)=7)) S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
  1. ;I $P(Z0,U,9)]"",$P(Z0,U,13)]"",IBMCR S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($P($G(^IBE(355.97,$P(Z0,U,13),0)),U,3)_U_$P(Z0,U,9),1,U,IBSTRIP)
  1. I $P(Z0,U,9)]"",$P(Z0,U,13)]"",IBMCR S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($P(Z0,U,9),1,U,IBSTRIP)
  1. ; get secondarys in order
  1. I $D(IDTBL("INS")) D
  1. . N Z S Z="" F S Z=$O(IDTBL("INS",Z)) Q:Z="" D
  1. .. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
  1. .. I IBMCR,(Z=24) Q
  1. .. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("INS",Z) Q:CNT=IBLIMIT
  1. I $D(IDTBL("OWN")),CNT'=IBLIMIT D
  1. . N Z S Z="" F S Z=$O(IDTBL("OWN",Z)) Q:Z="" D
  1. .. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
  1. .. I IBMCR,(Z=24) Q
  1. .. I '$D(IDTBL("INS",Z)) S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("OWN",Z) Q:CNT=IBLIMIT
  1. Q
  1. ;
  1. STRIP(X,SPACE,EXC,IBSTRIP) ;
  1. ; Strip punctuation from data in X
  1. ; SPACE = flag if 1 strip SPACES
  1. ; EXC = list of punct not to strip
  1. ;
  1. Q:'$G(IBSTRIP) X
  1. Q $$NOPUNCT^IBCEF(X,$G(SPACE),$G(EXC))
  1. ;
  1. OTH(IBIFN,IBXSAVE,IBXDATA,COND,SEG) ; Procedure used in piece 2 of some output
  1. ; formatter segments for other insurance
  1. ; COND = 0/1 value passed in that determines whether or not to call the
  1. ; provider ID function
  1. ; SEG = name of segment for use in calling ID^IBCEF2 (4 characters)
  1. ;
  1. N Z
  1. ;*432/TAZ - Changed Clean up and Setup routines to IBCEFP*
  1. ;D CLEANUP^IBCEF75(.IBXSAVE)
  1. ;I COND D ALLIDS^IBCEF75(IBIFN,.IBXSAVE,1)
  1. D CLEANUP^IBCEFP1(.IBXSAVE)
  1. I COND D ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
  1. ;
  1. ; Special Check: if Other Insurance #2 has secondary ID's while Other
  1. ; Insurance #1 does not, then move up #2 to be #1 here. This is to
  1. ; ensure the output formatter IBXDATA array is built properly.
  1. ;
  1. I $O(IBXSAVE("LAB/FAC",IBIFN,"O",2,0)),'$O(IBXSAVE("LAB/FAC",IBIFN,"O",1,0)) D
  1. . K IBXSAVE("LAB/FAC",IBIFN,"O",1)
  1. . M IBXSAVE("LAB/FAC",IBIFN,"O",1)=IBXSAVE("LAB/FAC",IBIFN,"O",2)
  1. . K IBXSAVE("LAB/FAC",IBIFN,"O",2)
  1. . Q
  1. ;
  1. K IBXDATA
  1. S Z=0
  1. F S Z=$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z)) Q:'Z D
  1. . I '$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z,0)) Q
  1. . S IBXDATA(Z)=$P($G(IBXSAVE("LAB/FAC",IBIFN,"O",Z)),U,1)
  1. . I Z>1 D ID^IBCEF2(Z,SEG)
  1. . Q
  1. OTHX ;
  1. Q
  1. ;