IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
;;2.0;INTEGRATED BILLING;**17,52,80,51,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
EN ;This routine requires prior execution of ibcf3.
; OUTPUT FORMATTER DOES NOT USE THIS ROUTINE - MAY BE OBSOLETE
;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,IBJ)=0 F S IBJ=$O(^DGCR(399,+IBIFN,"CC",IBJ)) Q:'IBJ S IBX=+$G(^(IBJ,0)),IBI=IBI+1,IBFL(24,IBI)=$P($G(^DGCR(399.1,+IBX,0)),U,2)
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
. K Y S Y=$P(IBPMAILN,U,9) D ZIPOUT^VAFADDR
. S IBJ=IBJ+1,IBFL(38,IBJ)=$P(IBPMAILN,U,7)_", "_$$STATE(+$P(IBPMAILN,U,8))_" "_Y K Y
;
;
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)
S IBX=$P(IBCUF3,U,7) D SPLIT^IBCF3(56,5,14,IBX) ; set IBFL(56)
I IBX="" F IBI=2,3,4 S IBX=+$P(IBMAIL1,U,(IBI+3)) I +IBX S IBFL(56,IBI)=$$BN1^PRCAFN(IBX) ; use prior bills
;
50 F IBI=1:1:3 F IBJ=50:1:54,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
;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:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D ; 516 - baa
F IBI=1:1:3 S IBX=$$POLICY^IBCEF(IBIFN,,IBI) I IBX'="" D ; 516 - baa
. 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(54,IBI)=$P(IBCU2,U,3+IBI) ;prior payment
. 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
. S IBY=$P($$PRCD^IBCEF1($P(IBPROC(IBX),U)),U)
. S IBI=IBI+1,IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($P(IBPROC(IBX),U,2))
. I $P(IBPROC(IBX),U,15)'="" S IBM=$P(IBPROC(IBX),U,15) D
.. F I=1:1:$L(IBM,",") I $P(IBM,",",I)'="" S IBY=$P($$MOD^ICPTMOD($P(IBM,",",I),"I"),U,4) I IBY'="" 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)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCF31 4820 printed Dec 13, 2024@02:12:58 Page 2
IBCF31 ;ALB/BGA -UB92 HCFA-1450 (GATHER CODES) ;25-AUG-1993
+1 ;;2.0;INTEGRATED BILLING;**17,52,80,51,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
EN ;This routine requires prior execution of ibcf3.
+1 ; OUTPUT FORMATTER DOES NOT USE THIS ROUTINE - MAY BE OBSOLETE
+2 ;Field locators 22-62 are addressed here.
+3 ;
+4 SET IBMAIL1=$GET(^DGCR(399,IBIFN,"M1"))
+5 ;
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,IBJ)=0
FOR
SET IBJ=$ORDER(^DGCR(399,+IBIFN,"CC",IBJ))
if 'IBJ
QUIT
SET IBX=+$GET(^(IBJ,0))
SET IBI=IBI+1
SET IBFL(24,IBI)=$PIECE($GET(^DGCR(399.1,+IBX,0)),U,2)
+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 KILL Y
SET Y=$PIECE(IBPMAILN,U,9)
DO ZIPOUT^VAFADDR
+5 SET IBJ=IBJ+1
SET IBFL(38,IBJ)=$PIECE(IBPMAILN,U,7)_", "_$$STATE(+$PIECE(IBPMAILN,U,8))_" "_Y
KILL Y
End DoDot:1
+6 ;
+7 ;
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(57)=$PIECE(IBCUF31,U,1)
+6 ; set IBFL(56)
SET IBX=$PIECE(IBCUF3,U,7)
DO SPLIT^IBCF3(56,5,14,IBX)
+7 ; use prior bills
IF IBX=""
FOR IBI=2,3,4
SET IBX=+$PIECE(IBMAIL1,U,(IBI+3))
IF +IBX
SET IBFL(56,IBI)=$$BN1^PRCAFN(IBX)
+8 ;
50 FOR IBI=1:1:3
FOR IBJ=50:1:54,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 ;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:1:3 S IBJ="I"_IBI S IBX=$G(^DGCR(399,IBIFN,IBJ)) I IBX'="" D ; 516 - baa
+4 ; 516 - baa
FOR IBI=1:1:3
SET IBX=$$POLICY^IBCEF(IBIFN,,IBI)
IF IBX'=""
Begin DoDot:1
+5 SET IBY=$GET(^DIC(36,+IBX,0))
if IBY=""
QUIT
+6 ; payer
SET IBFL(50,IBI)=$PIECE(IBY,U,1)
+7 ; provider #
SET IBFL(51,IBI)=$PIECE(IBMAIL1,U,(IBI+1))
+8 ; roi
SET IBFL(52,IBI)=$SELECT(+$PIECE(IBSTATE,U,5):"R",1:"Y")
+9 ;assign of benifits
SET IBFL(53,IBI)=$SELECT("Nn0"[$PIECE(IBSTATE,U,6)&($PIECE(IBSTATE,U,6)'=""):"N",1:"Y")
+10 ;prior payment
SET IBFL(54,IBI)=$PIECE(IBCU2,U,3+IBI)
+11 ; insureds name
SET IBFL(58,IBI)=$PIECE(IBX,U,17)
+12 ; pt. rel to insured
SET IBFL(59,IBI)=$PIECE(IBX,U,16)
+13 ; insurance number
SET IBFL(60,IBI)=$PIECE(IBX,U,2)
+14 ; insurance group name
SET IBFL(61,IBI)=$PIECE(IBX,U,15)
+15 ; insurance group number
SET IBFL(62,IBI)=$PIECE(IBX,U,3)
+16 ; tx auth cd
SET IBFL(63,IBI)=""
IF IBI=1
SET IBFL(63,IBI)=$PIECE(IBSTATE,U,13)
+17 IF $PIECE(IBX,U,6)="v"
Begin DoDot:2
+18 DO OPD^VADPT
SET IBFL(64,IBI)=$PIECE(VAPD(7),U,1)
KILL VAPD
IF ",3,9,"[+IBFL(64,IBI)
QUIT
+19 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
+20 IF $PIECE(IBX,U,6)="s"
Begin DoDot:2
+21 SET IBFL(64,IBI)=$PIECE($GET(^DPT(DFN,.25)),U,15)
IF ",3,9,"[+IBFL(64,IBI)
QUIT
+22 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
+23 IF 'IBFL(64,IBI)
SET IBFL(64,IBI)=9
End DoDot:1
+24 ;
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 SET IBY=$PIECE($$PRCD^IBCEF1($PIECE(IBPROC(IBX),U)),U)
+5 SET IBI=IBI+1
SET IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($PIECE(IBPROC(IBX),U,2))
+6 IF $PIECE(IBPROC(IBX),U,15)'=""
SET IBM=$PIECE(IBPROC(IBX),U,15)
Begin DoDot:2
+7 FOR I=1:1:$LENGTH(IBM,",")
IF $PIECE(IBM,",",I)'=""
SET IBY=$PIECE($$MOD^ICPTMOD($PIECE(IBM,",",I),"I"),U,4)
IF IBY'=""
SET IBI=IBI+1
SET IBFL(80,IBI)=IBY_U_$$DATE^IBCF3($PIECE(IBPROC(IBX),U,2))
End DoDot:2
End DoDot:1
+8 KILL IBPROC,I,J
+9 ;
+10 QUIT
+11 ;
STATE(X) ;returns 2 letter abbreviation for state pointer
+1 QUIT $PIECE($GET(^DIC(5,+$GET(X),0)),U,2)
