- 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 Feb 18, 2025@23:39:15 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