IBCF21 ;ALB/ARH - HCFA 1500 19-90 DATA (gather insurance, cc) ;12-JUN-93
;;2.0;INTEGRATED BILLING;**8,80,51,488,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
; requires IBIFN
INS S IBFLD("11AD")=""
;IB*2.0*516/BAA - Call $$POLICY^IBCEF to insert HIPAA compliant fields into variable IBDI1. Data will
;continue to be extracted from IBDI1 original location.
;F IBI=1,2,3 S IB("I"_IBI)=$G(^DGCR(399,IBIFN,("I"_IBI))) ; 516 - baa
F IBI=1,2,3 S IB("I"_IBI)=$$POLICY^IBCEF(IBIFN,,IBI) ; 516 - baa
F IBI="I1","I2","I3" I IB(IBI)'="" S IBX=+$P(IB(IBI),U,16),IBY="IBR"_IBI,@IBY=IBX I IBX'=1,IBX'=2 D S @IBY=IBX ;pt's rel to insured
. I $P(IB(IBI),U,6)="v" D:'$D(VAEL) ELIG^VADPT I +VAEL(4) S IBX=1 Q ;vet is the patient
. I $P(IB(IBI),U,6)="s" D:'$D(VAEL) ELIG^VADPT I +VAEL(4) S IBX=2 Q ;vet is pt, so vets spouse is pt's spouse
. I 'IBX S IBX=9 ; else relationship of insured to patient unknown
K VAEL
;
S IBCOB=$P($G(^DGCR(399,IBIFN,0)),U,21),IBPRIM="I1",IBRIP=$G(IBRI1),IBSECD="I2",IBRIS=$G(IBRI2)
I IBCOB="S" S IBPRIM="I2",IBRIP=$G(IBRI2),IBSECD="I1",IBRIS=$G(IBRI1)
I IBCOB="T" S IBPRIM="I3",IBRIP=$G(IBRI3),IBSECD="I1",IBRIS=$G(IBRI1)
;
INS1 G INS2:IB(IBPRIM)=""!('$D(^DIC(36,+IB(IBPRIM),0)))
F IBI=$P(IB(IBPRIM),U,2),$P(IB(IBPRIM),U,3) I IBI'="" S IBFLD("1A")=IBI Q ;policy number
S IBFLD(4)=$S(IBRIP=1:"SAME",1:$P(IB(IBPRIM),U,17)) ; insureds name
S IBFLD(6)=$S('$P(IB(IBPRIM),U,16):IBRIP,1:+$P(IB(IBPRIM),U,16)) ; patient relationship to insured
I IBRIP=1!(IBRIP=2) S IBFLD(7)="SAME" ; insured's address
;
I $P(IB(IBPRIM),U,2)'="" S IBFLD(11)=$P(IB(IBPRIM),U,3) ; group number
I IBRIP=1 S IBFLD("11AD")=IBFLD("3D"),IBFLD("11AX")=IBFLD("3X")
;I +IBRIP=1,IBFLD("8E")="E" S VAOA("A")=5 D OAD^VADPT S IBFLD("11B")=VAOA(9) K VAOA ;employer *488*
I +IBRIP=2 D
. I IBFLD("3X")'="" S X="MFM",IBFLD("11AX")=$E(X,$F(X,IBFLD("3X")))
. ;I IBSPE="E" S VAOA("A")=6 D OAD^VADPT S IBFLD("11B")=VAOA(9) K VAOA ;spouses employer *488*
S IBFLD("11C")=$P(IB(IBPRIM),U,15)
;
INS2 G COND:IB(IBSECD)=""!('$D(^DIC(36,+IB(IBSECD),0))) ; secondary insurance
S IBFLD("11D")=1
S IBFLD(9)=$P(IB(IBSECD),U,17) I IBFLD(9)'="",IBFLD(9)=$P(IB(IBPRIM),U,17) S IBFLD(9)="SAME" ;secondary insureds nam
F IBI=$P(IB(IBSECD),U,2),$P(IB(IBSECD),U,3) I IBI'="" S IBFLD("9A")=IBI Q ;policy number
I +IBRIS=1 D ;box 9b & 9c no longer used *488*
. ;S IBFLD("9BD")=IBFLD("3D"),IBFLD("9BX")=IBFLD("3X")
. ;I IBFLD("8E")="E" S VAOA("A")=5 D OAD^VADPT S IBFLD("9C")=VAOA(9) K VAOA ;employer
I +IBRIS=2 D ;box 9b & 9c no longer used *488*
. ;I IBFLD("3X")'="" S X="MFM",IBFLD("9BX")=$E(X,$F(X,IBFLD("3X")))
. ;I IBSPE="E" S VAOA("A")=6 D OAD^VADPT S IBFLD("9C")=VAOA(9) K VAOA ;spouses employer
I IBFLD("9A")=$P(IB(IBSECD),U,3) S IBFLD("9D")=$P(IB(IBSECD),U,15) ;group name
I IBFLD("9D")="" S IBFLD("9D")=$P($G(^DIC(36,+IB(IBSECD),0)),U) ;company name
;
COND ;condition related to employment, auto accident (place), other accident
S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"CC",IBI)) Q:'IBI S X=$G(^(IBI,0)) I +X D
. S Y=$G(^DGCR(399.1,+X,0)) Q:Y="" I $P(Y,U,2)="02" S IBFLD("10A")=1
S IBI=0 F S IBI=$O(^DGCR(399,IBIFN,"OC",IBI)) Q:'IBI S X=$G(^(IBI,0)) I +X D
. S Y=$G(^DGCR(399.1,+X,0)) Q:Y=""
. I $P(Y,U,9)=1 S IBFLD("10A")=1
. I $P(Y,U,9)=2 S IBFLD("10B")=1 S X=$$STATE^IBCF2($P(X,U,3)) I X'="" S IBFLD("10BS")=X
. I $P(Y,U,9)=3 S IBFLD("10C")=1
. ;I $P(Y,U,1)="ONSET OF SYMPTOMS/ILLNESS" S IBFLD(15)=$$DATE^IBCF2($P(X,U,2),1) ; see DATES+1^IBCF22
;
BX10D ; box 10D now condition codes *488*
S IBFLD("10D")=$$CLMCDS(IBIFN)
;
BX11B ; box 11b now property/casualty claim number *488*
N BX11B
S BX11B=$P($G(^DGCR(399,IBIFN,"U4")),U,2) S IBFLD("11B")=$S(BX11B'="":"Y4 "_BX11B,1:"")
;
K IBRI1,IBRI2,IBRI3,IBCOB,IBPRIM,IBSECD,IBRIP,IBRIS,BX11B
D ^IBCF22
Q
;
CLMCDS(IBIFN) ; Claim codes for box 10D. Add with *488*
N IBI,DEL,IBXDATA,CLMCDS,CLCD
S IBI=0,DEL=" ",CLMCDS=""
K IBXDATA D F^IBCEF("N-CONDITION CODES",,,IBIFN)
; Build data
S IBI=0 F S IBI=$O(IBXDATA(IBI)) Q:'IBI D
.S CLCD=IBXDATA(IBI)
.I $L(CLMCDS_DEL_CLCD)<20 S CLMCDS=CLMCDS_$S(CLMCDS="":"",1:DEL)_CLCD
Q CLMCDS
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF21 4224 printed Sep 23, 2025@19:49:05 Page 2
IBCF21 ;ALB/ARH - HCFA 1500 19-90 DATA (gather insurance, cc) ;12-JUN-93
+1 ;;2.0;INTEGRATED BILLING;**8,80,51,488,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ; requires IBIFN
INS SET IBFLD("11AD")=""
+1 ;IB*2.0*516/BAA - Call $$POLICY^IBCEF to insert HIPAA compliant fields into variable IBDI1. Data will
+2 ;continue to be extracted from IBDI1 original location.
+3 ;F IBI=1,2,3 S IB("I"_IBI)=$G(^DGCR(399,IBIFN,("I"_IBI))) ; 516 - baa
+4 ; 516 - baa
FOR IBI=1,2,3
SET IB("I"_IBI)=$$POLICY^IBCEF(IBIFN,,IBI)
+5 ;pt's rel to insured
FOR IBI="I1","I2","I3"
IF IB(IBI)'=""
SET IBX=+$PIECE(IB(IBI),U,16)
SET IBY="IBR"_IBI
SET @IBY=IBX
IF IBX'=1
IF IBX'=2
Begin DoDot:1
+6 ;vet is the patient
IF $PIECE(IB(IBI),U,6)="v"
if '$DATA(VAEL)
DO ELIG^VADPT
IF +VAEL(4)
SET IBX=1
QUIT
+7 ;vet is pt, so vets spouse is pt's spouse
IF $PIECE(IB(IBI),U,6)="s"
if '$DATA(VAEL)
DO ELIG^VADPT
IF +VAEL(4)
SET IBX=2
QUIT
+8 ; else relationship of insured to patient unknown
IF 'IBX
SET IBX=9
End DoDot:1
SET @IBY=IBX
+9 KILL VAEL
+10 ;
+11 SET IBCOB=$PIECE($GET(^DGCR(399,IBIFN,0)),U,21)
SET IBPRIM="I1"
SET IBRIP=$GET(IBRI1)
SET IBSECD="I2"
SET IBRIS=$GET(IBRI2)
+12 IF IBCOB="S"
SET IBPRIM="I2"
SET IBRIP=$GET(IBRI2)
SET IBSECD="I1"
SET IBRIS=$GET(IBRI1)
+13 IF IBCOB="T"
SET IBPRIM="I3"
SET IBRIP=$GET(IBRI3)
SET IBSECD="I1"
SET IBRIS=$GET(IBRI1)
+14 ;
INS1 if IB(IBPRIM)=""!('$DATA(^DIC(36,+IB(IBPRIM),0)))
GOTO INS2
+1 ;policy number
FOR IBI=$PIECE(IB(IBPRIM),U,2),$PIECE(IB(IBPRIM),U,3)
IF IBI'=""
SET IBFLD("1A")=IBI
QUIT
+2 ; insureds name
SET IBFLD(4)=$SELECT(IBRIP=1:"SAME",1:$PIECE(IB(IBPRIM),U,17))
+3 ; patient relationship to insured
SET IBFLD(6)=$SELECT('$PIECE(IB(IBPRIM),U,16):IBRIP,1:+$PIECE(IB(IBPRIM),U,16))
+4 ; insured's address
IF IBRIP=1!(IBRIP=2)
SET IBFLD(7)="SAME"
+5 ;
+6 ; group number
IF $PIECE(IB(IBPRIM),U,2)'=""
SET IBFLD(11)=$PIECE(IB(IBPRIM),U,3)
+7 IF IBRIP=1
SET IBFLD("11AD")=IBFLD("3D")
SET IBFLD("11AX")=IBFLD("3X")
+8 ;I +IBRIP=1,IBFLD("8E")="E" S VAOA("A")=5 D OAD^VADPT S IBFLD("11B")=VAOA(9) K VAOA ;employer *488*
+9 IF +IBRIP=2
Begin DoDot:1
+10 IF IBFLD("3X")'=""
SET X="MFM"
SET IBFLD("11AX")=$EXTRACT(X,$FIND(X,IBFLD("3X")))
+11 ;I IBSPE="E" S VAOA("A")=6 D OAD^VADPT S IBFLD("11B")=VAOA(9) K VAOA ;spouses employer *488*
End DoDot:1
+12 SET IBFLD("11C")=$PIECE(IB(IBPRIM),U,15)
+13 ;
INS2 ; secondary insurance
if IB(IBSECD)=""!('$DATA(^DIC(36,+IB(IBSECD),0)))
GOTO COND
+1 SET IBFLD("11D")=1
+2 ;secondary insureds nam
SET IBFLD(9)=$PIECE(IB(IBSECD),U,17)
IF IBFLD(9)'=""
IF IBFLD(9)=$PIECE(IB(IBPRIM),U,17)
SET IBFLD(9)="SAME"
+3 ;policy number
FOR IBI=$PIECE(IB(IBSECD),U,2),$PIECE(IB(IBSECD),U,3)
IF IBI'=""
SET IBFLD("9A")=IBI
QUIT
+4 ;box 9b & 9c no longer used *488*
IF +IBRIS=1
Begin DoDot:1
+5 ;S IBFLD("9BD")=IBFLD("3D"),IBFLD("9BX")=IBFLD("3X")
+6 ;I IBFLD("8E")="E" S VAOA("A")=5 D OAD^VADPT S IBFLD("9C")=VAOA(9) K VAOA ;employer
End DoDot:1
+7 ;box 9b & 9c no longer used *488*
IF +IBRIS=2
Begin DoDot:1
+8 ;I IBFLD("3X")'="" S X="MFM",IBFLD("9BX")=$E(X,$F(X,IBFLD("3X")))
+9 ;I IBSPE="E" S VAOA("A")=6 D OAD^VADPT S IBFLD("9C")=VAOA(9) K VAOA ;spouses employer
End DoDot:1
+10 ;group name
IF IBFLD("9A")=$PIECE(IB(IBSECD),U,3)
SET IBFLD("9D")=$PIECE(IB(IBSECD),U,15)
+11 ;company name
IF IBFLD("9D")=""
SET IBFLD("9D")=$PIECE($GET(^DIC(36,+IB(IBSECD),0)),U)
+12 ;
COND ;condition related to employment, auto accident (place), other accident
+1 SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"CC",IBI))
if 'IBI
QUIT
SET X=$GET(^(IBI,0))
IF +X
Begin DoDot:1
+2 SET Y=$GET(^DGCR(399.1,+X,0))
if Y=""
QUIT
IF $PIECE(Y,U,2)="02"
SET IBFLD("10A")=1
End DoDot:1
+3 SET IBI=0
FOR
SET IBI=$ORDER(^DGCR(399,IBIFN,"OC",IBI))
if 'IBI
QUIT
SET X=$GET(^(IBI,0))
IF +X
Begin DoDot:1
+4 SET Y=$GET(^DGCR(399.1,+X,0))
if Y=""
QUIT
+5 IF $PIECE(Y,U,9)=1
SET IBFLD("10A")=1
+6 IF $PIECE(Y,U,9)=2
SET IBFLD("10B")=1
SET X=$$STATE^IBCF2($PIECE(X,U,3))
IF X'=""
SET IBFLD("10BS")=X
+7 IF $PIECE(Y,U,9)=3
SET IBFLD("10C")=1
+8 ;I $P(Y,U,1)="ONSET OF SYMPTOMS/ILLNESS" S IBFLD(15)=$$DATE^IBCF2($P(X,U,2),1) ; see DATES+1^IBCF22
End DoDot:1
+9 ;
BX10D ; box 10D now condition codes *488*
+1 SET IBFLD("10D")=$$CLMCDS(IBIFN)
+2 ;
BX11B ; box 11b now property/casualty claim number *488*
+1 NEW BX11B
+2 SET BX11B=$PIECE($GET(^DGCR(399,IBIFN,"U4")),U,2)
SET IBFLD("11B")=$SELECT(BX11B'="":"Y4 "_BX11B,1:"")
+3 ;
+4 KILL IBRI1,IBRI2,IBRI3,IBCOB,IBPRIM,IBSECD,IBRIP,IBRIS,BX11B
+5 DO ^IBCF22
+6 QUIT
+7 ;
CLMCDS(IBIFN) ; Claim codes for box 10D. Add with *488*
+1 NEW IBI,DEL,IBXDATA,CLMCDS,CLCD
+2 SET IBI=0
SET DEL=" "
SET CLMCDS=""
+3 KILL IBXDATA
DO F^IBCEF("N-CONDITION CODES",,,IBIFN)
+4 ; Build data
+5 SET IBI=0
FOR
SET IBI=$ORDER(IBXDATA(IBI))
if 'IBI
QUIT
Begin DoDot:1
+6 SET CLCD=IBXDATA(IBI)
+7 IF $LENGTH(CLMCDS_DEL_CLCD)<20
SET CLMCDS=CLMCDS_$SELECT(CLMCDS="":"",1:DEL)_CLCD
End DoDot:1
+8 QUIT CLMCDS
