- IBCF21 ;ALB/ARH - HCFA 1500 19-90 DATA (gather insurance, cc) ; 12-JUN-93
- ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- ;;Per VHA Directive 10-93-142, this routine should not be modified.
- ;
- ;
- ; requires IBIFN
- INS F IBI=1,2 S IB("I"_IBI)=$G(^DGCR(399,IBIFN,("I"_IBI)))
- F IBI="I1","I2" 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
- INS1 G INS2:IB("I1")=""!('$D(^DIC(36,+IB("I1"),0)))
- F IBI=$P(IB("I1"),U,2),$P(IB("I1"),U,3) I IBI'="" S IBFLD("1A")=IBI Q ;policy number
- S IBFLD(4)=$S(IBRI1=1:"SAME",1:$P(IB("I1"),U,17)) ; insureds name
- S IBFLD(6)=$S('$P(IB("I1"),U,16):IBRI1,1:+$P(IB("I1"),U,16)) ; patient relationship to insured
- I IBRI1=1!(IBRI1=2) S IBFLD(7)="SAME" ; insured's address
- ;
- I $P(IB("I1"),U,2)'="" S IBFLD(11)=$P(IB("I1"),U,3) ; group number
- I +IBRI1=1,IBFLD("8E")="E" S VAOA("A")=5 D OAD^VADPT S IBFLD("11B")=VAOA(9) K VAOA ;employer
- I +IBRI1=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
- S IBFLD("11C")=$P(IB("I1"),U,15)
- ;
- INS2 G COND:IB("I2")=""!('$D(^DIC(36,+IB("I2"),0))) ; secondary insurance
- S IBFLD("11D")=1
- S IBFLD(9)=$P(IB("I2"),U,17) I IBFLD(9)'="",IBFLD(9)=$P(IB("I1"),U,17) S IBFLD(9)="SAME" ;secondary insureds nam
- F IBI=$P(IB("I2"),U,2),$P(IB("I2"),U,3) I IBI'="" S IBFLD("9A")=IBI Q ;policy number
- I +IBRI2=1 D
- . 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 +IBRI2=2 D
- . 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("I2"),U,3) S IBFLD("9D")=$P(IB("I2"),U,15) ;group name
- I IBFLD("9D")="" S IBFLD("9D")=$P($G(^DIC(36,+IB("I2"),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 I $G(^(IBI,0))="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^IBCF22($P(X,U,2)) ; see DATES+1^IBCF22
- ;
- K IBRI1,IBRI2
- D ^IBCF22
- Q
- IBCF21 ;ALB/ARH - HCFA 1500 19-90 DATA (gather insurance, cc) ; 12-JUN-93
- +1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
- +2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
- +3 ;
- +4 ;
- +5 ; requires IBIFN
- INS FOR IBI=1,2
- SET IB("I"_IBI)=$GET(^DGCR(399,IBIFN,("I"_IBI)))
- +1 ;pt's rel to insured
- FOR IBI="I1","I2"
- 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
- +2 ;vet is the patient
- IF $PIECE(IB(IBI),U,6)="v"
- IF '$DATA(VAEL)
- DO ELIG^VADPT
- IF +VAEL(4)
- SET IBX=1
- QUIT
- +3 ;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
- +4 ; else relationship of insured to patient unknown
- IF 'IBX
- SET IBX=9
- End DoDot:1
- SET @IBY=IBX
- +5 KILL VAEL
- INS1 IF IB("I1")=""!('$DATA(^DIC(36,+IB("I1"),0)))
- GOTO INS2
- +1 ;policy number
- FOR IBI=$PIECE(IB("I1"),U,2),$PIECE(IB("I1"),U,3)
- IF IBI'=""
- SET IBFLD("1A")=IBI
- QUIT
- +2 ; insureds name
- SET IBFLD(4)=$SELECT(IBRI1=1:"SAME",1:$PIECE(IB("I1"),U,17))
- +3 ; patient relationship to insured
- SET IBFLD(6)=$SELECT('$PIECE(IB("I1"),U,16):IBRI1,1:+$PIECE(IB("I1"),U,16))
- +4 ; insured's address
- IF IBRI1=1!(IBRI1=2)
- SET IBFLD(7)="SAME"
- +5 ;
- +6 ; group number
- IF $PIECE(IB("I1"),U,2)'=""
- SET IBFLD(11)=$PIECE(IB("I1"),U,3)
- +7 ;employer
- IF +IBRI1=1
- IF IBFLD("8E")="E"
- SET VAOA("A")=5
- DO OAD^VADPT
- SET IBFLD("11B")=VAOA(9)
- KILL VAOA
- +8 IF +IBRI1=2
- Begin DoDot:1
- +9 IF IBFLD("3X")'=""
- SET X="MFM"
- SET IBFLD("11AX")=$EXTRACT(X,$FIND(X,IBFLD("3X")))
- +10 ;spouses employer
- IF IBSPE="E"
- SET VAOA("A")=6
- DO OAD^VADPT
- SET IBFLD("11B")=VAOA(9)
- KILL VAOA
- End DoDot:1
- +11 SET IBFLD("11C")=$PIECE(IB("I1"),U,15)
- +12 ;
- INS2 ; secondary insurance
- IF IB("I2")=""!('$DATA(^DIC(36,+IB("I2"),0)))
- GOTO COND
- +1 SET IBFLD("11D")=1
- +2 ;secondary insureds nam
- SET IBFLD(9)=$PIECE(IB("I2"),U,17)
- IF IBFLD(9)'=""
- IF IBFLD(9)=$PIECE(IB("I1"),U,17)
- SET IBFLD(9)="SAME"
- +3 ;policy number
- FOR IBI=$PIECE(IB("I2"),U,2),$PIECE(IB("I2"),U,3)
- IF IBI'=""
- SET IBFLD("9A")=IBI
- QUIT
- +4 IF +IBRI2=1
- Begin DoDot:1
- +5 SET IBFLD("9BD")=IBFLD("3D")
- SET IBFLD("9BX")=IBFLD("3X")
- +6 ;employer
- IF IBFLD("8E")="E"
- SET VAOA("A")=5
- DO OAD^VADPT
- SET IBFLD("9C")=VAOA(9)
- KILL VAOA
- End DoDot:1
- +7 IF +IBRI2=2
- Begin DoDot:1
- +8 IF IBFLD("3X")'=""
- SET X="MFM"
- SET IBFLD("9BX")=$EXTRACT(X,$FIND(X,IBFLD("3X")))
- +9 ;spouses employer
- IF IBSPE="E"
- SET VAOA("A")=6
- DO OAD^VADPT
- SET IBFLD("9C")=VAOA(9)
- KILL VAOA
- End DoDot:1
- +10 ;group name
- IF IBFLD("9A")=$PIECE(IB("I2"),U,3)
- SET IBFLD("9D")=$PIECE(IB("I2"),U,15)
- +11 ;company name
- IF IBFLD("9D")=""
- SET IBFLD("9D")=$PIECE($GET(^DIC(36,+IB("I2"),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
- IF $GET(^(IBI,0))="02"
- SET IBFLD("10A")=1
- +2 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
- +3 SET Y=$GET(^DGCR(399.1,+X,0))
- IF Y=""
- QUIT
- +4 IF $PIECE(Y,U,9)=1
- SET IBFLD("10A")=1
- +5 IF $PIECE(Y,U,9)=2
- SET IBFLD("10B")=1
- SET X=$$STATE^IBCF2($PIECE(X,U,3))
- IF X'=""
- SET IBFLD("10BS")=X
- +6 IF $PIECE(Y,U,9)=3
- SET IBFLD("10C")=1
- +7 ; see DATES+1^IBCF22
- IF $PIECE(Y,U,1)="ONSET OF SYMPTOMS/ILLNESS"
- SET IBFLD(15)=$$DATE^IBCF22($PIECE(X,U,2))
- End DoDot:1
- +8 ;
- +9 KILL IBRI1,IBRI2
- +10 DO ^IBCF22
- +11 QUIT
