IBCEF76 ;ALB/WCJ - Provider ID functions ;13 Feb 2006
;;2.0;INTEGRATED BILLING;**320,349,400,432,516,592**;21-MAR-94;Build 58
;;Per VA Directive 6402, this routine should not be modified.
;
G AWAY
AWAY Q
;
LFIDS(IBIFN,IDS,IBSTRIP,SEG) ;
; Pass in the the internal claim number and return the array of IDS.
; IDS("C"urrent or "O"ther, Order of Insurance within subscript 1, order of ID within subscript 2)
; IDS("C",1)="P"
; IDS("C",1,0)=Qualifier^Primary ID
; IDS("C",1,1)=Qualifier^Sec ID #1
; IDS("C",1,2)=Qualifier^Sec ID #2
;
N DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,OUTFAC,MAIN,IBCCOB,TMPIDS,COB,IBSORT1,IBSORT2,IBLIMIT,IBLF
;
S DAT=$G(^DGCR(399,IBIFN,0))
;JWS;IB*2.0*592;Dental claim form 7
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 OUTFAC=$P($G(^DGCR(399,IBIFN,"U2")),U,10)
S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
;
S IBCCOB=$$COBN^IBCEF(IBIFN)
F COB=1:1:3 D
. S IBSORT1=$S(COB=IBCCOB:"C",1:"O")
. S IBSORT2=$S(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
. S IBLIMIT=$S(IBSORT1="C":5,1:3) ; Limit secondary IDs
. S DAT=$G(^DGCR(399,IBIFN,"I"_COB))
. ;
. S IBINS=$P(DAT,U) ; insurance PTR 36
. Q:IBINS=""
. ;
. ; 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
. S IBLF=$$B^IBCEF79(IBIFN,COB) ; billing provider/service facility function
. I $P(IBLF,U,3)="" Q ; no service facility data at this COB, don't build this "LAB/FAC" area
. ;
. I OUTFAC]"" D Q
.. D NONVALF(IBIFN,OUTFAC_";IBA(355.93,",IBINS,IBFRMTYP,IBCARE,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
. ;
. I OUTFAC="" D
.. ;
.. ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
.. ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
.. ; that function and INSFLGS^^IBCEF79 for more information.
.. ;
.. ; if ins co flag says to not send svc fac data and we're sending an EDI claim, then get out
.. ;I '$$SENDSF^IBCEF79(IBIFN,COB),$G(^TMP("IBTX",$J,IBIFN)) Q
.. ;
.. ;IB*2.0*432/TAZ Moved Taxid setup inside VALF look to send as secondary ID for Medicare claims.
.. ;S IDS("LAB/FAC",IBIFN,IBSORT1,IBSORT2,0)=$$STRIP($$TAXID^IBCEF75(),1,U,IBSTRIP)
.. D VALF(IBIFN,IBINS,IBFRMTYP,IBDIV,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
Q
;
VALF(IBIFN,INS,FT,DIV,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get VA Lab/Fac Secondary IDs
; Pass in INS - IEN to file 36
; FT - 1 = UB 2 = 1500, 7 = J430D
; DIV - PTR to 40.8
;
N Z,Z0,ID,QUAL,MAIN,IDTBL,CNT,Z,IBMCR
S MAIN=$$MAIN^IBCEP2B() ; get the IEN for main Division
S Z=0 F S Z=$O(^IBA(355.92,"B",INS,Z)) Q:'Z D
. ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
. I $$FT^IBCEF(IBIFN)=7 Q
. S Z0=$G(^IBA(355.92,Z,0))
. Q:$P(Z0,U,8)'="LF" ; Screen out anything other than Lab or Facility
. 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
. S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
. S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
. Q:QUAL="" ; Needs a qualifier
. S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
. I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
. I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
. 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
. I $P(Z0,U,5)=DIV S IDTBL("DIV",QUAL)=ID ; set up default for division
S CNT=0
S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)
;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID ; only if it's not a printed form
S IBMCR=""
;JWS;IB*2.0*592;Dental
I '(($G(IBXFORM)=2)!($G(IBXFORM)=3)!($G(IBXFORM)=7)) S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
I IBMCR S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($P($$TAXID^IBCEF75(),U,2),1,U,IBSTRIP)
I $D(IDTBL("DIV")) D Q
. S Z="" F S Z=$O(IDTBL("DIV",Z)) Q:Z="" D
.. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
.. I IBMCR,(Z=24) Q
.. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DIV",Z) Q:CNT=IBLIMIT
I $D(IDTBL("DEF")) D Q
. S Z="" F S Z=$O(IDTBL("DEF",Z)) Q:Z="" D
.. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
.. I IBMCR,(Z=24) Q
.. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DEF",Z) Q:CNT=IBLIMIT
Q
;
NONVALF(IBIFN,PRV,INS,FT,PT,IDS,SORT1,SORT2,COB,IBLIMIT,IBSTRIP,SEG) ; Get Non VA Lab/Fac Secondary IDs
; Pass in PRV - VPTR - PTR to 355.93 (in format of variabel pointer IEN;IBA(355.93,
; Pass in INS - PTR to 36 of null (not provide by insurance company)
; FT - 1 = UB 2 = 1500 7 = J430D
; PT - Patient Type - 1 inpatient 2 outpatient
; IDS array being returned
; SORT1 - "C"urrent or "O"ther
; SORT2 - 1 if current or (1 or 2 if other)
N Z,Z0,ID,QUAL,IDTBL,CNT,IBMCR
S Z=0 F S Z=$O(^IBA(355.9,"B",PRV,Z)) Q:'Z D
. ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
. I $$FT^IBCEF(IBIFN)=7 Q
. S Z0=$G(^IBA(355.9,Z,0))
. 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
. 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
. I INS]"",$P(Z0,U,2)]"",INS'=$P(Z0,U,2) Q
. S ID=$$STRIP($P(Z0,U,7),1,,IBSTRIP)
. Q:ID=""
. S QUAL=$$STRIP($P(Z0,U,6),1,,IBSTRIP)
. Q:QUAL="" ; Needs a qualifier
. S QUAL=$P($G(^IBE(355.97,QUAL,0)),U,3)
. Q:QUAL=""
. I FT=1,SORT1="O" Q:$$OP3^IBCEF73(FT)'[(U_QUAL_U) ; Institutional
. I FT=2,SORT1="O" Q:$$OP7^IBCEF73(FT)'[(U_QUAL_U) ; Professional
. I $G(SEG)="SUB1" Q:$$SUB1^IBCEF73(FT)'[(U_QUAL_U)
. I $P(Z0,U,2)="" S IDTBL("OWN",QUAL)=ID ; set up default of lab or facilities own ids
. I $P(Z0,U,2)=INS S IDTBL("INS",QUAL)=ID ; set up default for division
;
S CNT=0
S IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$E("PST",COB)_U_PRV
S IDS("LAB/FAC",IBIFN,SORT1,SORT2,"CONTACT")=$G(^IBA(355.93,+PRV,1))
; get primary
S Z0=$G(^IBA(355.93,+PRV,0))
;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID
S IBMCR=""
;JWS;IB*2.0*592;Dental
I '(($G(IBXFORM)=2)!($G(IBXFORM)=3)!($G(IBXFORM)=7)) S IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
;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)
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)
; get secondarys in order
I $D(IDTBL("INS")) D
. N Z S Z="" F S Z=$O(IDTBL("INS",Z)) Q:Z="" D
.. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
.. I IBMCR,(Z=24) Q
.. S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("INS",Z) Q:CNT=IBLIMIT
I $D(IDTBL("OWN")),CNT'=IBLIMIT D
. N Z S Z="" F S Z=$O(IDTBL("OWN",Z)) Q:Z="" D
.. ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
.. I IBMCR,(Z=24) Q
.. I '$D(IDTBL("INS",Z)) S CNT=CNT+1,IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("OWN",Z) Q:CNT=IBLIMIT
Q
;
STRIP(X,SPACE,EXC,IBSTRIP) ;
; Strip punctuation from data in X
; SPACE = flag if 1 strip SPACES
; EXC = list of punct not to strip
;
Q:'$G(IBSTRIP) X
Q $$NOPUNCT^IBCEF(X,$G(SPACE),$G(EXC))
;
OTH(IBIFN,IBXSAVE,IBXDATA,COND,SEG) ; Procedure used in piece 2 of some output
; formatter segments for other insurance
; COND = 0/1 value passed in that determines whether or not to call the
; provider ID function
; SEG = name of segment for use in calling ID^IBCEF2 (4 characters)
;
N Z
;*432/TAZ - Changed Clean up and Setup routines to IBCEFP*
;D CLEANUP^IBCEF75(.IBXSAVE)
;I COND D ALLIDS^IBCEF75(IBIFN,.IBXSAVE,1)
D CLEANUP^IBCEFP1(.IBXSAVE)
I COND D ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
;
; Special Check: if Other Insurance #2 has secondary ID's while Other
; Insurance #1 does not, then move up #2 to be #1 here. This is to
; ensure the output formatter IBXDATA array is built properly.
;
I $O(IBXSAVE("LAB/FAC",IBIFN,"O",2,0)),'$O(IBXSAVE("LAB/FAC",IBIFN,"O",1,0)) D
. K IBXSAVE("LAB/FAC",IBIFN,"O",1)
. M IBXSAVE("LAB/FAC",IBIFN,"O",1)=IBXSAVE("LAB/FAC",IBIFN,"O",2)
. K IBXSAVE("LAB/FAC",IBIFN,"O",2)
. Q
;
K IBXDATA
S Z=0
F S Z=$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z)) Q:'Z D
. I '$O(IBXSAVE("LAB/FAC",IBIFN,"O",Z,0)) Q
. S IBXDATA(Z)=$P($G(IBXSAVE("LAB/FAC",IBIFN,"O",Z)),U,1)
. I Z>1 D ID^IBCEF2(Z,SEG)
. Q
OTHX ;
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCEF76 8676 printed Apr 09, 2024@21:03:09 Page 2
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
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 GOTO AWAY
AWAY QUIT
+1 ;
LFIDS(IBIFN,IDS,IBSTRIP,SEG) ;
+1 ; Pass in the the internal claim number and return the array of IDS.
+2 ; IDS("C"urrent or "O"ther, Order of Insurance within subscript 1, order of ID within subscript 2)
+3 ; IDS("C",1)="P"
+4 ; IDS("C",1,0)=Qualifier^Primary ID
+5 ; IDS("C",1,1)=Qualifier^Sec ID #1
+6 ; IDS("C",1,2)=Qualifier^Sec ID #2
+7 ;
+8 NEW DAT,IBFRMTYP,IBCARE,IBDIV,IBINS,OUTFAC,MAIN,IBCCOB,TMPIDS,COB,IBSORT1,IBSORT2,IBLIMIT,IBLF
+9 ;
+10 SET DAT=$GET(^DGCR(399,IBIFN,0))
+11 ;JWS;IB*2.0*592;Dental claim form 7
+12 SET IBFRMTYP=$$FT^IBCEF(IBIFN)
SET IBFRMTYP=$SELECT(IBFRMTYP=2:2,IBFRMTYP=3:1,IBFRMTYP=7:7,1:0)
+13 ;if an Rx refill bill
SET IBCARE=$SELECT($$ISRX^IBCEF1(IBIFN):3,1:0)
+14 ;1-inp,2-out
if IBCARE=0
SET IBCARE=$$INPAT^IBCEF(IBIFN)
if 'IBCARE
SET IBCARE=2
+15 SET IBDIV=+$PIECE(DAT,U,22)
+16 SET OUTFAC=$PIECE($GET(^DGCR(399,IBIFN,"U2")),U,10)
+17 ; get the IEN for main Division
SET MAIN=$$MAIN^IBCEP2B()
+18 ;
+19 SET IBCCOB=$$COBN^IBCEF(IBIFN)
+20 FOR COB=1:1:3
Begin DoDot:1
+21 SET IBSORT1=$SELECT(COB=IBCCOB:"C",1:"O")
+22 SET IBSORT2=$SELECT(IBSORT1="C":1,COB=1:1,COB=2&(IBCCOB=1):1,1:2)
+23 ; Limit secondary IDs
SET IBLIMIT=$SELECT(IBSORT1="C":5,1:3)
+24 SET DAT=$GET(^DGCR(399,IBIFN,"I"_COB))
+25 ;
+26 ; insurance PTR 36
SET IBINS=$PIECE(DAT,U)
+27 if IBINS=""
QUIT
+28 ;
+29 ; 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
+30 ; billing provider/service facility function
SET IBLF=$$B^IBCEF79(IBIFN,COB)
+31 ; no service facility data at this COB, don't build this "LAB/FAC" area
IF $PIECE(IBLF,U,3)=""
QUIT
+32 ;
+33 IF OUTFAC]""
Begin DoDot:2
+34 DO NONVALF(IBIFN,OUTFAC_";IBA(355.93,",IBINS,IBFRMTYP,IBCARE,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
End DoDot:2
QUIT
+35 ;
+36 IF OUTFAC=""
Begin DoDot:2
+37 ;
+38 ; MRD;IB*2.0*516 - Due to fields being marked for deletion, the
+39 ; function $$SENDSF^IBCEF79 will always return '1'. Refer to
+40 ; that function and INSFLGS^^IBCEF79 for more information.
+41 ;
+42 ; if ins co flag says to not send svc fac data and we're sending an EDI claim, then get out
+43 ;I '$$SENDSF^IBCEF79(IBIFN,COB),$G(^TMP("IBTX",$J,IBIFN)) Q
+44 ;
+45 ;IB*2.0*432/TAZ Moved Taxid setup inside VALF look to send as secondary ID for Medicare claims.
+46 ;S IDS("LAB/FAC",IBIFN,IBSORT1,IBSORT2,0)=$$STRIP($$TAXID^IBCEF75(),1,U,IBSTRIP)
+47 DO VALF(IBIFN,IBINS,IBFRMTYP,IBDIV,.IDS,IBSORT1,IBSORT2,COB,IBLIMIT,IBSTRIP,SEG)
End DoDot:2
End DoDot:1
+48 QUIT
+49 ;
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
+2 ; FT - 1 = UB 2 = 1500, 7 = J430D
+3 ; DIV - PTR to 40.8
+4 ;
+5 NEW Z,Z0,ID,QUAL,MAIN,IDTBL,CNT,Z,IBMCR
+6 ; get the IEN for main Division
SET MAIN=$$MAIN^IBCEP2B()
+7 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.92,"B",INS,Z))
if 'Z
QUIT
Begin DoDot:1
+8 ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
+9 IF $$FT^IBCEF(IBIFN)=7
QUIT
+10 SET Z0=$GET(^IBA(355.92,Z,0))
+11 ; Screen out anything other than Lab or Facility
if $PIECE(Z0,U,8)'="LF"
QUIT
+12 ; Form type must match that passed in or be a 0 which allows both
IF +$PIECE(Z0,U,4)
if $PIECE(Z0,U,4)'=FT
QUIT
+13 SET ID=$$STRIP($PIECE(Z0,U,7),1,,IBSTRIP)
+14 SET QUAL=$$STRIP($PIECE(Z0,U,6),1,,IBSTRIP)
+15 ; Needs a qualifier
if QUAL=""
QUIT
+16 SET QUAL=$PIECE($GET(^IBE(355.97,QUAL,0)),U,3)
+17 ; Institutional
IF FT=1
IF SORT1="O"
if $$OP3^IBCEF73(FT)'[(U_QUAL_U)
QUIT
+18 ; Professional
IF FT=2
IF SORT1="O"
if $$OP7^IBCEF73(FT)'[(U_QUAL_U)
QUIT
+19 ; set up default for main division
IF $PIECE(Z0,U,5)=""!($PIECE(Z0,U,5)=0)!($PIECE(Z0,U,5)=MAIN)
SET IDTBL("DEF",QUAL)=ID
+20 ; set up default for division
IF $PIECE(Z0,U,5)=DIV
SET IDTBL("DIV",QUAL)=ID
End DoDot:1
+21 SET CNT=0
+22 SET IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$EXTRACT("PST",COB)
+23 ;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID ; only if it's not a printed form
+24 SET IBMCR=""
+25 ;JWS;IB*2.0*592;Dental
+26 IF '(($GET(IBXFORM)=2)!($GET(IBXFORM)=3)!($GET(IBXFORM)=7))
SET IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
+27 IF IBMCR
SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($PIECE($$TAXID^IBCEF75(),U,2),1,U,IBSTRIP)
+28 IF $DATA(IDTBL("DIV"))
Begin DoDot:1
+29 SET Z=""
FOR
SET Z=$ORDER(IDTBL("DIV",Z))
if Z=""
QUIT
Begin DoDot:2
+30 ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
+31 IF IBMCR
IF (Z=24)
QUIT
+32 SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DIV",Z)
if CNT=IBLIMIT
QUIT
End DoDot:2
End DoDot:1
QUIT
+33 IF $DATA(IDTBL("DEF"))
Begin DoDot:1
+34 SET Z=""
FOR
SET Z=$ORDER(IDTBL("DEF",Z))
if Z=""
QUIT
Begin DoDot:2
+35 ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
+36 IF IBMCR
IF (Z=24)
QUIT
+37 SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("DEF",Z)
if CNT=IBLIMIT
QUIT
End DoDot:2
End DoDot:1
QUIT
+38 QUIT
+39 ;
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,
+2 ; Pass in INS - PTR to 36 of null (not provide by insurance company)
+3 ; FT - 1 = UB 2 = 1500 7 = J430D
+4 ; PT - Patient Type - 1 inpatient 2 outpatient
+5 ; IDS array being returned
+6 ; SORT1 - "C"urrent or "O"ther
+7 ; SORT2 - 1 if current or (1 or 2 if other)
+8 NEW Z,Z0,ID,QUAL,IDTBL,CNT,IBMCR
+9 SET Z=0
FOR
SET Z=$ORDER(^IBA(355.9,"B",PRV,Z))
if 'Z
QUIT
Begin DoDot:1
+10 ;JWS;IB*2.0*592 - if a Dental Claim, skip, no secondary IDs for Dental
+11 IF $$FT^IBCEF(IBIFN)=7
QUIT
+12 SET Z0=$GET(^IBA(355.9,Z,0))
+13 ; Form type must match that passed in or be a 0 which allows both UB and 1500
IF +$PIECE(Z0,U,4)
if $PIECE(Z0,U,4)'=FT
QUIT
+14 ; Patient type must match that passed in or be a 0 which allows both in patient and outpatient
IF +$PIECE(Z0,U,5)
if $PIECE(Z0,U,5)'=PT
QUIT
+15 IF INS]""
IF $PIECE(Z0,U,2)]""
IF INS'=$PIECE(Z0,U,2)
QUIT
+16 SET ID=$$STRIP($PIECE(Z0,U,7),1,,IBSTRIP)
+17 if ID=""
QUIT
+18 SET QUAL=$$STRIP($PIECE(Z0,U,6),1,,IBSTRIP)
+19 ; Needs a qualifier
if QUAL=""
QUIT
+20 SET QUAL=$PIECE($GET(^IBE(355.97,QUAL,0)),U,3)
+21 if QUAL=""
QUIT
+22 ; Institutional
IF FT=1
IF SORT1="O"
if $$OP3^IBCEF73(FT)'[(U_QUAL_U)
QUIT
+23 ; Professional
IF FT=2
IF SORT1="O"
if $$OP7^IBCEF73(FT)'[(U_QUAL_U)
QUIT
+24 IF $GET(SEG)="SUB1"
if $$SUB1^IBCEF73(FT)'[(U_QUAL_U)
QUIT
+25 ; set up default of lab or facilities own ids
IF $PIECE(Z0,U,2)=""
SET IDTBL("OWN",QUAL)=ID
+26 ; set up default for division
IF $PIECE(Z0,U,2)=INS
SET IDTBL("INS",QUAL)=ID
End DoDot:1
+27 ;
+28 SET CNT=0
+29 SET IDS("LAB/FAC",IBIFN,SORT1,SORT2)=$EXTRACT("PST",COB)_U_PRV
+30 SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,"CONTACT")=$GET(^IBA(355.93,+PRV,1))
+31 ; get primary
+32 SET Z0=$GET(^IBA(355.93,+PRV,0))
+33 ;IB*2.0*432/TAZ If Medicare send Tax ID as 1st Secondary ID
+34 SET IBMCR=""
+35 ;JWS;IB*2.0*592;Dental
+36 IF '(($GET(IBXFORM)=2)!($GET(IBXFORM)=3)!($GET(IBXFORM)=7))
SET IBMCR=$$MCRONBIL^IBEFUNC(IBIFN)
+37 ;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)
+38 IF $PIECE(Z0,U,9)]""
IF $PIECE(Z0,U,13)]""
IF IBMCR
SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)="LU"_U_$$STRIP($PIECE(Z0,U,9),1,U,IBSTRIP)
+39 ; get secondarys in order
+40 IF $DATA(IDTBL("INS"))
Begin DoDot:1
+41 NEW Z
SET Z=""
FOR
SET Z=$ORDER(IDTBL("INS",Z))
if Z=""
QUIT
Begin DoDot:2
+42 ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
+43 IF IBMCR
IF (Z=24)
QUIT
+44 SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("INS",Z)
if CNT=IBLIMIT
QUIT
End DoDot:2
End DoDot:1
+45 IF $DATA(IDTBL("OWN"))
IF CNT'=IBLIMIT
Begin DoDot:1
+46 NEW Z
SET Z=""
FOR
SET Z=$ORDER(IDTBL("OWN",Z))
if Z=""
QUIT
Begin DoDot:2
+47 ;IB*2.0*432/TAZ If Medicare, screen out Tax ID
+48 IF IBMCR
IF (Z=24)
QUIT
+49 IF '$DATA(IDTBL("INS",Z))
SET CNT=CNT+1
SET IDS("LAB/FAC",IBIFN,SORT1,SORT2,CNT)=Z_U_IDTBL("OWN",Z)
if CNT=IBLIMIT
QUIT
End DoDot:2
End DoDot:1
+50 QUIT
+51 ;
STRIP(X,SPACE,EXC,IBSTRIP) ;
+1 ; Strip punctuation from data in X
+2 ; SPACE = flag if 1 strip SPACES
+3 ; EXC = list of punct not to strip
+4 ;
+5 if '$GET(IBSTRIP)
QUIT X
+6 QUIT $$NOPUNCT^IBCEF(X,$GET(SPACE),$GET(EXC))
+7 ;
OTH(IBIFN,IBXSAVE,IBXDATA,COND,SEG) ; Procedure used in piece 2 of some output
+1 ; formatter segments for other insurance
+2 ; COND = 0/1 value passed in that determines whether or not to call the
+3 ; provider ID function
+4 ; SEG = name of segment for use in calling ID^IBCEF2 (4 characters)
+5 ;
+6 NEW Z
+7 ;*432/TAZ - Changed Clean up and Setup routines to IBCEFP*
+8 ;D CLEANUP^IBCEF75(.IBXSAVE)
+9 ;I COND D ALLIDS^IBCEF75(IBIFN,.IBXSAVE,1)
+10 DO CLEANUP^IBCEFP1(.IBXSAVE)
+11 IF COND
DO ALLIDS^IBCEFP(IBIFN,.IBXSAVE,1)
+12 ;
+13 ; Special Check: if Other Insurance #2 has secondary ID's while Other
+14 ; Insurance #1 does not, then move up #2 to be #1 here. This is to
+15 ; ensure the output formatter IBXDATA array is built properly.
+16 ;
+17 IF $ORDER(IBXSAVE("LAB/FAC",IBIFN,"O",2,0))
IF '$ORDER(IBXSAVE("LAB/FAC",IBIFN,"O",1,0))
Begin DoDot:1
+18 KILL IBXSAVE("LAB/FAC",IBIFN,"O",1)
+19 MERGE IBXSAVE("LAB/FAC",IBIFN,"O",1)=IBXSAVE("LAB/FAC",IBIFN,"O",2)
+20 KILL IBXSAVE("LAB/FAC",IBIFN,"O",2)
+21 QUIT
End DoDot:1
+22 ;
+23 KILL IBXDATA
+24 SET Z=0
+25 FOR
SET Z=$ORDER(IBXSAVE("LAB/FAC",IBIFN,"O",Z))
if 'Z
QUIT
Begin DoDot:1
+26 IF '$ORDER(IBXSAVE("LAB/FAC",IBIFN,"O",Z,0))
QUIT
+27 SET IBXDATA(Z)=$PIECE($GET(IBXSAVE("LAB/FAC",IBIFN,"O",Z)),U,1)
+28 IF Z>1
DO ID^IBCEF2(Z,SEG)
+29 QUIT
End DoDot:1
OTHX ;
+1 QUIT
+2 ;
