IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02
;;2.0;INTEGRATED BILLING;**52,361,371,516**;21-MAR-94;Build 123
;;Per VA Directive 6402, this routine should not be modified.
;
;MAP TO DGCRVA0
;
Q
ALL I $D(DFN) S IBDPT=^DPT(DFN,0) D ADDR ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA
;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
S IBBNO=$P(IB(0),"^"),IBDT=$P(IB(0),"^",3)
D 2^VADPT
;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y
Q
1 ;Demographic variables set
D Q1^IBCVA
EN1 Q:'$D(DFN) S IBMAR=$S($P(IBDPT,U,5)'="":$P(IBDPT,U,5),1:"U") I IBMAR'="U" S IBMAR=$S(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
I $D(^DPT(DFN,.121)) S IBTADD=^DPT(DFN,.121),IBTST=$P(IBTADD,U,5),IBTST=$S(IBTST'="":$P(^DIC(5,IBTST,0),U,2),1:"") I $P(IBTADD,U)="" S IBT1="NO TEMPORARY ADDRESS"
Q
2 ;Employment variables set
D Q1^IBCVA,Q2^IBCVA
EN2 S:'$D(^DPT(DFN,.311)) IBEMPD="" I $D(^DPT(DFN,.311)) I ^DPT(DFN,.311)'="" S IBEMPD=$P(^(.311),U)_"^"_$P(^(.311),U,6)_"^"_$S($P(^(.311),U,7)'="":$P(^(.311),U,7),1:"")_"^"_$P($G(^DPT(DFN,.22)),U,5)_"^"_$P(IB(0),U,9)_"^"_$P(IB(0),U,8)
I $D(IBEMPD) S:IBEMPD'="" IBEC=$P(^DPT(DFN,.311),"^",15)
I $D(^DPT(DFN,.25)) S:$P(^DPT(DFN,.25),U,6)'="" IBSEST=$P(^(.25),U,6),IBSEST=$P(^DIC(5,IBSEST,0),U,2)
Q
3 ;Insurance variables set
EN3 D 123^IBCVA
EN31 ; -IBdd(i) = value of ins node in dpt
I '$D(^DGCR(399,IBIFN,"AIC")) S IBINDT=$S(+$G(IB("U")):+IB("U"),+$G(^DGCR(399,IBIFN,"U")):+$G(^("U")),1:DT) D ALL^IBCNS1(DFN,"IBDD",1,IBINDT) S I="" F S I=$O(IBDD(I)) Q:'I D INS
;
; MRD;IB*2.0*516 - Due to the introduction of the new "In7" nodes
; on file# 399, this line must be modified to work correctly.
;I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
I $D(^DGCR(399,IBIFN,"AIC")) F I=1:1:3 S IBIN="I"_I Q:'$D(^DGCR(399,IBIFN,IBIN)) S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
Q
INS I $P(IBDD(I,0),U,6)="v" S IBISEX(I)=$P(^DPT(DFN,0),U,2)
E S IBISEX(I)=$P($G(^DPT(DFN,.312,+$P($G(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12) ; *361 replaces old calculation of insured's sex
S IBISEX(I)=$S(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
S IBIRN(I)=$P(IBDD(I,0),U,16)
S IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I))
Q
ADDR ;SET ADDRESS
S IBADD1="" I $D(^DGCR(399,IBIFN,"M")),$P(^("M"),"^",10)]"" Q
S X=$S($D(^DPT(DFN,.11)):^(.11),1:"") F I=1:1:4 I $P(X,"^",I)]"" S IBADD1=IBADD1_$P(X,"^",I)_","
I $D(^DIC(5,+$P(X,"^",5),0)) S IBADD1=IBADD1_$P(^(0),"^",2),IBST=$P(^(0),"^",2)
S:$P(X,"^",12)]"" IBADD1=IBADD1_" "_$P(X,"^",12) Q
;IBCVA0
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HIBCVA0 2795 printed Dec 13, 2024@02:21:04 Page 2
IBCVA0 ;ALB/MJB - SET MCCR VARIABLES CONT. ;04 AUG 88 03:02
+1 ;;2.0;INTEGRATED BILLING;**52,361,371,516**;21-MAR-94;Build 123
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;MAP TO DGCRVA0
+5 ;
+6 QUIT
ALL ;I IBADD1]"",$L(IBADD1)'>47 S DIE="^DGCR(399,",(DA,Y)=+IBIFN,DR="110///"_IBADD1 D ^DIE K DIE,DR,DA
IF $DATA(DFN)
SET IBDPT=^DPT(DFN,0)
DO ADDR
+1 ;I $D(^DPT(DFN,.11)) S IBST=$P(^(.11),U,5),IBST=$S(IBST'="":$P(^DIC(5,IBST,0),U,2),1:"")
+2 SET IBBNO=$PIECE(IB(0),"^")
SET IBDT=$PIECE(IB(0),"^",3)
+3 DO 2^VADPT
+4 ;I $P(IB(0),U,5)<3 S Y=0 F I=1:1 S Y=$O(^DGPM("APTT1",DFN,Y)) Q:'Y S:$E(Y,1,7)=IBDT IBDA=Y
+5 QUIT
1 ;Demographic variables set
+1 DO Q1^IBCVA
EN1 if '$DATA(DFN)
QUIT
SET IBMAR=$SELECT($PIECE(IBDPT,U,5)'="":$PIECE(IBDPT,U,5),1:"U")
IF IBMAR'="U"
SET IBMAR=$SELECT(IBMAR=6:"S",IBMAR=2:"M",IBMAR=1:"D",IBMAR=4:"W",IBMAR=5:"X",1:"U")
+1 IF $DATA(^DPT(DFN,.121))
SET IBTADD=^DPT(DFN,.121)
SET IBTST=$PIECE(IBTADD,U,5)
SET IBTST=$SELECT(IBTST'="":$PIECE(^DIC(5,IBTST,0),U,2),1:"")
IF $PIECE(IBTADD,U)=""
SET IBT1="NO TEMPORARY ADDRESS"
+2 QUIT
2 ;Employment variables set
+1 DO Q1^IBCVA
DO Q2^IBCVA
EN2 if '$DATA(^DPT(DFN,.311))
SET IBEMPD=""
IF $DATA(^DPT(DFN,.311))
IF ^DPT(DFN,.311)'=""
SET IBEMPD=$PIECE(^(.311),U)_"^"_$PIECE(^(.311),U,6)_"^"_$SELECT($PIECE(^(.311),U,7)'="":$PIECE(^(.311),U,7),1:"")_"^"_$PIECE($GET(^DPT(DFN,.22)),U,5)_"^"_$PIECE(IB(0),U,9)_"^"_$PIECE(IB(0),U,8)
+1 IF $DATA(IBEMPD)
if IBEMPD'=""
SET IBEC=$PIECE(^DPT(DFN,.311),"^",15)
+2 IF $DATA(^DPT(DFN,.25))
if $PIECE(^DPT(DFN,.25),U,6)'=""
SET IBSEST=$PIECE(^(.25),U,6)
SET IBSEST=$PIECE(^DIC(5,IBSEST,0),U,2)
+3 QUIT
3 ;Insurance variables set
EN3 DO 123^IBCVA
EN31 ; -IBdd(i) = value of ins node in dpt
+1 IF '$DATA(^DGCR(399,IBIFN,"AIC"))
SET IBINDT=$SELECT(+$GET(IB("U")):+IB("U"),+$GET(^DGCR(399,IBIFN,"U")):+$GET(^("U")),1:DT)
DO ALL^IBCNS1(DFN,"IBDD",1,IBINDT)
SET I=""
FOR
SET I=$ORDER(IBDD(I))
if 'I
QUIT
DO INS
+2 ;
+3 ; MRD;IB*2.0*516 - Due to the introduction of the new "In7" nodes
+4 ; on file# 399, this line must be modified to work correctly.
+5 ;I $D(^DGCR(399,IBIFN,"AIC")) S IBIN="I" F I=1:1:3 S IBIN=$O(^DGCR(399,IBIFN,IBIN)) Q:IBIN'?1"I".N S IBDD(I,0)=^DGCR(399,IBIFN,IBIN) D INS
+6 IF $DATA(^DGCR(399,IBIFN,"AIC"))
FOR I=1:1:3
SET IBIN="I"_I
if '$DATA(^DGCR(399,IBIFN,IBIN))
QUIT
SET IBDD(I,0)=^DGCR(399,IBIFN,IBIN)
DO INS
+7 QUIT
INS IF $PIECE(IBDD(I,0),U,6)="v"
SET IBISEX(I)=$PIECE(^DPT(DFN,0),U,2)
+1 ; *361 replaces old calculation of insured's sex
IF '$TEST
SET IBISEX(I)=$PIECE($GET(^DPT(DFN,.312,+$PIECE($GET(^DGCR(399,IBIFN,"M")),U,I+11),3)),U,12)
+2 SET IBISEX(I)=$SELECT(IBISEX(I)="M":"MALE",IBISEX(I)="F":"FEMALE",1:"UNSPECIFIED")
+3 SET IBIRN(I)=$PIECE(IBDD(I,0),U,16)
+4 SET IBIR(I)=$$EXTERNAL^DILFD(2.312,16,,IBIRN(I))
+5 QUIT
ADDR ;SET ADDRESS
+1 SET IBADD1=""
IF $DATA(^DGCR(399,IBIFN,"M"))
IF $PIECE(^("M"),"^",10)]""
QUIT
+2 SET X=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
FOR I=1:1:4
IF $PIECE(X,"^",I)]""
SET IBADD1=IBADD1_$PIECE(X,"^",I)_","
+3 IF $DATA(^DIC(5,+$PIECE(X,"^",5),0))
SET IBADD1=IBADD1_$PIECE(^(0),"^",2)
SET IBST=$PIECE(^(0),"^",2)
+4 if $PIECE(X,"^",12)]""
SET IBADD1=IBADD1_" "_$PIECE(X,"^",12)
QUIT
+5 ;IBCVA0
