IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
;;Per VHA Directive 10-93-142, this routine should not be modified.
;
EN ;This routine requires prior execution of ibcf3.
;Field locators 22-62 are addressed here.
;
S IBMAIL1=$G(^DGCR(399,IBIFN,"M1"))
;
22 ;patient status
S IBFL(22)="" I +IBINPAT,$P(IBSTATE,U,12) S IBX=$P(IBSTATE,U,12),IBFL(22)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
23 ;medical/health record number ssn
S IBFL(23)=$P(VADM(2),U,2)
;
24 ;condition codes 24-30
S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"CC",IBX)) Q:'IBX S IBI=IBI+1,IBFL(24,IBI)=$G(^(IBX,0))
S IBFL(24)=IBI_U_0
;
S IBX=$P(IBCUF3,U,3) D SPLIT^IBCF3(31,2,6,IBX) ; set IBFL(31)
32 ;occurrence codes/span and dates 32-35 ,36
;S (IBI,IBJ,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBC=$G(^DGCR(399.1,+IBY,0)) I IBC'="" D
;. I +$P(IBC,U,10) S IBJ=IBJ+1,IBFL(36,IBJ)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
;S IBFL(32)=IBI_U_0
;S IBFL(36)=IBJ_U_0
D 32^IBCF32
;
F IBI=1:1:3 S IBFL(37,IBI)=$P(IBCUF3,U,(IBI+3))
;
38 ;responsible party with name and address
S IBFL(38,1)="" I $P(IBPMAILN,U,4)'="" S IBJ=0 D
. F IBI=4,5,6 I $P(IBPMAILN,U,IBI)'="" S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,IBI)
. S IBX=$P(IBMAIL1,U,1) I IBX'="" S IBJ=IBJ+1,IBFL(38,IBJ)=IBX
. S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,7)_", "_$$STATE(+$P(IBPMAILN,U,8))_" "_$P(IBPMAILN,U,9)
;
;
39 ;value codes, 39-41
S (IBI,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"CV",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBJ=$G(^DGCR(399.1,+IBY,0)) I IBJ'="" D
. S IBI=IBI+1,IBFL(39,IBI)=$P(IBJ,U,2)_U_$P(IBY,U,2)_U_$P(IBJ,U,12)
S IBFL(39)=IBI_U_0
;
S IBFL(57)=$P(IBCUF31,U,1),IBX=$P(IBCUF3,U,7) D SPLIT^IBCF3(56,5,14,IBX) ; set IBFL(56)
;
50 F IBI=1:1:3 F IBJ=50:1:53,58:1:66 S IBFL(IBJ,IBI)=""
I '$D(^DGCR(399,IBIFN,"AIC")) D G 80
. S IBFL(52,1)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
. S IBFL(53,1)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ; assign of benifits
. S IBFL(63,1)=$P(IBSTATE,U,13) ; tx auth cd
. I $P($G(^DGCR(399.3,+$P(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD" D
.. S IBFL(50,1)="MEDICARE ESRD",IBFL(51,1)=$P(IBSIGN,U,21),IBFL(58,1)=VADM(1),IBFL(59,1)="01",IBFL(60,1)=$P(VADM(2),U,2)
;
INS ;list the primary, secondary .. insurance companies
F IBI=1:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D
. S IBY=$G(^DIC(36,+IBX,0)) Q:IBY=""
. S IBFL(50,IBI)=$P(IBY,U,1) ; payer
. S IBFL(51,IBI)=$P(IBMAIL1,U,(IBI+1)) ; provider #
. S IBFL(52,IBI)=$S(+$P(IBSTATE,U,5):"R",1:"Y") ; roi
. S IBFL(53,IBI)=$S("Nn0"[$P(IBSTATE,U,6)&($P(IBSTATE,U,6)'=""):"N",1:"Y") ;assign of benifits
. S IBFL(58,IBI)=$P(IBX,U,17) ; insureds name
. S IBFL(59,IBI)=$P(IBX,U,16) ; pt. rel to insured
. S IBFL(60,IBI)=$P(IBX,U,2) ; insurance number
. S IBFL(61,IBI)=$P(IBX,U,15) ; insurance group name
. S IBFL(62,IBI)=$P(IBX,U,3) ; insurance group number
. S IBFL(63,IBI)="" I IBI=1 S IBFL(63,IBI)=$P(IBSTATE,U,13) ; tx auth cd
. I $P(IBX,U,6)="v" D
.. D OPD^VADPT S IBFL(64,IBI)=$P(VAPD(7),U,1) K VAPD I ",3,9,"[+IBFL(64,IBI) Q
.. S VAOA("A")=5 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2) K VAOA
. I $P(IBX,U,6)="s" D
.. S IBFL(64,IBI)=$P($G(^DPT(DFN,.25)),U,15) I ",3,9,"[+IBFL(64,IBI) Q
.. S VAOA("A")=6 D OAD^VADPT S IBFL(65,IBI)=VAOA(9),IBFL(66,IBI)=VAOA(4)_$S(VAOA(4)'="":", ",1:"")_$P(VAOA(5),U,2)
. I 'IBFL(64,IBI) S IBFL(64,IBI)=9
;
80 ;procedure field locator 80
K IBPROC
D PROC^IBCVA1 S IBFL(80)=IBPROC_U_0_U_1,IBFL(80,1)=""
I +IBPROC S (IBI,IBX)=0 F S IBX=$O(IBPROC(IBX)) Q:'IBX D
. I $P(IBPROC(IBX),U,1)["ICPT(" S IBY=$P($G(^ICPT(+IBPROC(IBX),0)),U,1)
. I $P(IBPROC(IBX),U,1)["ICD0(" S IBY=$P($G(^ICD0(+IBPROC(IBX),0)),U,1)
. S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
K IBPROC,I,J
;
Q
;
STATE(X) ;returns 2 letter abbreviation for state pointer
Q $P($G(^DIC(5,+$G(X),0)),U,2)
IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
+1 ;;Version 2.0 ; INTEGRATED BILLING ;; 21-MAR-94
+2 ;;Per VHA Directive 10-93-142, this routine should not be modified.
+3 ;
EN ;This routine requires prior execution of ibcf3.
+1 ;Field locators 22-62 are addressed here.
+2 ;
+3 SET IBMAIL1=$GET(^DGCR(399,IBIFN,"M1"))
+4 ;
22 ;patient status
+1 SET IBFL(22)=""
IF +IBINPAT
IF $PIECE(IBSTATE,U,12)
SET IBX=$PIECE(IBSTATE,U,12)
SET IBFL(22)=$PIECE($GET(^DGCR(399.1,+IBX,0)),U,2)
23 ;medical/health record number ssn
+1 SET IBFL(23)=$PIECE(VADM(2),U,2)
+2 ;
24 ;condition codes 24-30
+1 SET (IBI,IBX)=0
FOR
SET IBX=$ORDER(^DGCR(399,+IBIFN,"CC",IBX))
IF 'IBX
QUIT
SET IBI=IBI+1
SET IBFL(24,IBI)=$GET(^(IBX,0))
+2 SET IBFL(24)=IBI_U_0
+3 ;
+4 ; set IBFL(31)
SET IBX=$PIECE(IBCUF3,U,3)
DO SPLIT^IBCF3(31,2,6,IBX)
32 ;occurrence codes/span and dates 32-35 ,36
+1 ;S (IBI,IBJ,IBX)=0 F S IBX=$O(^DGCR(399,+IBIFN,"OC",IBX)) Q:'IBX S IBY=$G(^(IBX,0)),IBC=$G(^DGCR(399.1,+IBY,0)) I IBC'="" D
+2 ;. I +$P(IBC,U,10) S IBJ=IBJ+1,IBFL(36,IBJ)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))_U_$$DATE^IBCF3($P(IBY,U,4)) Q
+3 ;. S IBI=IBI+1,IBFL(32,IBI)=$P(IBC,U,2)_U_$$DATE^IBCF3($P(IBY,U,2))
+4 ;S IBFL(32)=IBI_U_0
+5 ;S IBFL(36)=IBJ_U_0
+6 DO 32^IBCF32
+7 ;
+8 FOR IBI=1:1:3
SET IBFL(37,IBI)=$PIECE(IBCUF3,U,(IBI+3))
+9 ;
38 ;responsible party with name and address
+1 SET IBFL(38,1)=""
IF $PIECE(IBPMAILN,U,4)'=""
SET IBJ=0
Begin DoDot:1
+2 FOR IBI=4,5,6
IF $PIECE(IBPMAILN,U,IBI)'=""
SET IBJ=IBJ+1
SET IBFL(38,IBJ)=$PIECE(IBPMAILN,U,IBI)
+3 SET IBX=$PIECE(IBMAIL1,U,1)
IF IBX'=""
SET IBJ=IBJ+1
SET IBFL(38,IBJ)=IBX
+4 SET IBJ=IBJ+1
SET IBFL(38,IBJ)=$PIECE(IBPMAILN,U,7)_", "_$$STATE(+$PIECE(IBPMAILN,U,8))_" "_$PIECE(IBPMAILN,U,9)
End DoDot:1
+5 ;
+6 ;
39 ;value codes, 39-41
+1 SET (IBI,IBX)=0
FOR
SET IBX=$ORDER(^DGCR(399,+IBIFN,"CV",IBX))
IF 'IBX
QUIT
SET IBY=$GET(^(IBX,0))
SET IBJ=$GET(^DGCR(399.1,+IBY,0))
IF IBJ'=""
Begin DoDot:1
+2 SET IBI=IBI+1
SET IBFL(39,IBI)=$PIECE(IBJ,U,2)_U_$PIECE(IBY,U,2)_U_$PIECE(IBJ,U,12)
End DoDot:1
+3 SET IBFL(39)=IBI_U_0
+4 ;
+5 ; set IBFL(56)
SET IBFL(57)=$PIECE(IBCUF31,U,1)
SET IBX=$PIECE(IBCUF3,U,7)
DO SPLIT^IBCF3(56,5,14,IBX)
+6 ;
50 FOR IBI=1:1:3
FOR IBJ=50:1:53,58:1:66
SET IBFL(IBJ,IBI)=""
+1 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
Begin DoDot:1
+2 ; roi
SET IBFL(52,1)=$SELECT(+$PIECE(IBSTATE,U,5):"R",1:"Y")
+3 ; assign of benifits
SET IBFL(53,1)=$SELECT("Nn0"[$PIECE(IBSTATE,U,6)&($PIECE(IBSTATE,U,6)'=""):"N",1:"Y")
+4 ; tx auth cd
SET IBFL(63,1)=$PIECE(IBSTATE,U,13)
+5 IF $PIECE($GET(^DGCR(399.3,+$PIECE(IBCBILL,U,7),0)),U,1)["MEDICARE ESRD"
Begin DoDot:2
+6 SET IBFL(50,1)="MEDICARE ESRD"
SET IBFL(51,1)=$PIECE(IBSIGN,U,21)
SET IBFL(58,1)=VADM(1)
SET IBFL(59,1)="01"
SET IBFL(60,1)=$PIECE(VADM(2),U,2)
End DoDot:2
End DoDot:1
GOTO 80
+7 ;
INS ;list the primary, secondary .. insurance companies
+1 FOR IBI=1:1:3
SET IBJ="I"_IBI
SET IBX=$GET(^DGCR(399,IBIFN,IBJ))
IF IBX'=""
Begin DoDot:1
+2 SET IBY=$GET(^DIC(36,+IBX,0))
IF IBY=""
QUIT
+3 ; payer
SET IBFL(50,IBI)=$PIECE(IBY,U,1)
+4 ; provider #
SET IBFL(51,IBI)=$PIECE(IBMAIL1,U,(IBI+1))
+5 ; roi
SET IBFL(52,IBI)=$SELECT(+$PIECE(IBSTATE,U,5):"R",1:"Y")
+6 ;assign of benifits
SET IBFL(53,IBI)=$SELECT("Nn0"[$PIECE(IBSTATE,U,6)&($PIECE(IBSTATE,U,6)'=""):"N",1:"Y")
+7 ; insureds name
SET IBFL(58,IBI)=$PIECE(IBX,U,17)
+8 ; pt. rel to insured
SET IBFL(59,IBI)=$PIECE(IBX,U,16)
+9 ; insurance number
SET IBFL(60,IBI)=$PIECE(IBX,U,2)
+10 ; insurance group name
SET IBFL(61,IBI)=$PIECE(IBX,U,15)
+11 ; insurance group number
SET IBFL(62,IBI)=$PIECE(IBX,U,3)
+12 ; tx auth cd
SET IBFL(63,IBI)=""
IF IBI=1
SET IBFL(63,IBI)=$PIECE(IBSTATE,U,13)
+13 IF $PIECE(IBX,U,6)="v"
Begin DoDot:2
+14 DO OPD^VADPT
SET IBFL(64,IBI)=$PIECE(VAPD(7),U,1)
KILL VAPD
IF ",3,9,"[+IBFL(64,IBI)
QUIT
+15 SET VAOA("A")=5
DO OAD^VADPT
SET IBFL(65,IBI)=VAOA(9)
SET IBFL(66,IBI)=VAOA(4)_$SELECT(VAOA(4)'="":", ",1:"")_$PIECE(VAOA(5),U,2)
KILL VAOA
End DoDot:2
+16 IF $PIECE(IBX,U,6)="s"
Begin DoDot:2
+17 SET IBFL(64,IBI)=$PIECE($GET(^DPT(DFN,.25)),U,15)
IF ",3,9,"[+IBFL(64,IBI)
QUIT
+18 SET VAOA("A")=6
DO OAD^VADPT
SET IBFL(65,IBI)=VAOA(9)
SET IBFL(66,IBI)=VAOA(4)_$SELECT(VAOA(4)'="":", ",1:"")_$PIECE(VAOA(5),U,2)
End DoDot:2
+19 IF 'IBFL(64,IBI)
SET IBFL(64,IBI)=9
End DoDot:1
+20 ;
80 ;procedure field locator 80
+1 KILL IBPROC
+2 DO PROC^IBCVA1
SET IBFL(80)=IBPROC_U_0_U_1
SET IBFL(80,1)=""
+3 IF +IBPROC
SET (IBI,IBX)=0
FOR
SET IBX=$ORDER(IBPROC(IBX))
IF 'IBX
QUIT
Begin DoDot:1
+4 IF $PIECE(IBPROC(IBX),U,1)["ICPT("
SET IBY=$PIECE($GET(^ICPT(+IBPROC(IBX),0)),U,1)
+5 IF $PIECE(IBPROC(IBX),U,1)["ICD0("
SET IBY=$PIECE($GET(^ICD0(+IBPROC(IBX),0)),U,1)
+6 SET IBI=IBI+1
SET IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($PIECE(IBPROC(IBX),U,2))
End DoDot:1
+7 KILL IBPROC,I,J
+8 ;
+9 QUIT
+10 ;
STATE(X) ;returns 2 letter abbreviation for state pointer
+1 QUIT $PIECE($GET(^DIC(5,+$GET(X),0)),U,2)
