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