VADPT1 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLES ; 7/28/09 1:54pm
;;5.3;PIMS;**415,489,516,614,1015,1016**;JUN 30, 2012;Build 20
;IHS/ANMC/CLS 10/15/94 added IHS printable age
;IHS/OIT/LJF 11/10/2005 PATCH 1004 included for sites where it has been overwritten
1 ;Demographic [DEM]
N W,Z,NODE
;
; -- name [1 - NM]
S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
;
; -- ssn [2 - SS]
S Z=$P(VAX,"^",9) S:Z]"" @VAV@($P(VAS,"^",2))=Z_$S(Z]"":"^"_$E(Z,1,3)_"-"_$E(Z,4,5)_"-"_$E(Z,6,10),1:"")
;
; -- date of birth [2 - DB]
S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
;
; -- age [4 - AG]
S W=$S('$D(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35)) S Y=$S('W:DT,1:W) S:Z]"" @VAV@($P(VAS,"^",4))=$E(Y,1,3)-$E(Z,1,3)-($E(Y,4,7)<$E(Z,4,7))
;IHS/ITSC/WAR 8/11/03 Q8 - Next line per Chris
I @VAV@($P(VAS,"^",4))<2 D PAGE ;IHS/ANMC/CLS 10/15/94
;
; -- expired date [6 - EX]
S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
;
; -- sex [5 - SX]
S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
;
; -- remarks [7 - RE]
S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
;
; -- historic race [8 - RA]
S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- religion [9 - RP]
S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- marital status [10 - MS]
S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
;
; -- ethnicity [11 - ET]
S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D
.S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
..; -- collection method
..S Z=$P(NODE,"^",2) I Z D
...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
S @VAV@($P(VAS,"^",11))=Y-1
;
; -- race [12 - RC]
S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D
.S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
..; -- collection method
..S Z=$P(NODE,"^",2) I Z D
...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
S @VAV@($P(VAS,"^",12))=Y-1
Q
;
;IHS/ITSC/WAR 8/11/03 Q8 - Next section added per Chris
PAGE ; -- IHS printable age ;IHS/ANMC/CLS 10/15/94
N X,X1,X2,Y,AUX,D0
S D0=DFN X ^DD(9000001,1102.98,9.3) S X=$P(Y(9000001,1102.98,101),U,3),Y=X,X=Y(9000001,1102.98,1),X=X,X1=X,X2=Y,X="" D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS") K AUX S D0=Y(9000001,1102.98,80)
S @VAV@($P(VAS,"^",4))=X Q
;
2 ;Other Patient Variables [OPD]
N W,Z
S VAX=^DPT(DFN,0)
;
; -- city of birth [1 - BC]
S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
;
; -- state of birth [2 - BS]
S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
;
; -- occupation [6 - OC]
S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
;
; -- names
S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN]
S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN]
S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
;
; -- employment status [7 - ES]
S VAX=$S($D(^DPT(DFN,.311)):^(.311),1:""),W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
;
; -- PHONE NUMBER [WORK] [8 - WP]
I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",2)
Q
;
3 ;Address [ADD]
N VAFOR
S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
I $S($D(VAPA("P")):1,'$D(^DPT(DFN,.121)):1,$P(^(.121),"^",9)'="Y":1,'$P(^(.121),"^",7):1,$P(^(.121),"^",7)>VABEG:1,'$P(^(.121),"^",8):0,1:$P(^(.121),"^",8)<VAEND) S VAX=$S($D(^DPT(DFN,.11)):^(.11),1:""),VAX(1)=0
E S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
;set the foreign address fields into local variables for later
I 'VAX(1) S VAFOR=$P(VAX,U,8,10)
I VAX(1) D
. I '$D(^DPT(DFN,.122)) S VAFOR="" Q
. S VAFOR=$P(^DPT(DFN,.122),U,1,3)
F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I))=VAZ I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",5))=@VAV@($P(VAS,"^",5))_"^"_VAZ
S VAZ=$S('VAX(1):$P(VAX,"^",7),1:$P(VAX,"^",11)) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",7))=VAZ
S VAZIP4=$P(VAX,U,12)
S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
;DG*5.3*516
I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
;foreign address fields
F I=1:1:3 S VAZ=$P(VAFOR,U,I) S @VAV@($P(VAS,U,I+22))=VAZ
;
I $P($G(VAFOR),U,3)]"" D
. S VACNTRY=$P(VAFOR,U,3)
. S VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
. S $P(@VAV@($P(VAS,U,25)),U,2)=VACNTRY
I 'VAX(1) G CA
S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
CA ;Confidential Address
I '$D(^DPT(DFN,.141)) G Q3
N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
.I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
.I I=6,($G(VAZ)]"") S @VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_$S(($L(VAZ)=5):VAZ,1:$E(VAZ,1,5)_"-"_$E(VAZ,6,9))
S VAZ=$P(VAX,"^",11) S:$D(^DIC(5,+$P(VAX,"^",5),1,+VAZ,0)) VAZ=VAZ_"^"_$P(^(0),"^",1) S @VAV@($P(VAS,"^",19))=VAZ
F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
S @VAV@($P(VAS,"^",12))=1
I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
I $D(^DPT(DFN,.14)) D
.S VACAN="" F S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN="" D
..Q:'$D(^DPT(DFN,.14,VACAN,0))
..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM="" D
...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
;foreign address fields for the confidential address
F I=1:1:3 S @VAV@($P(VAS,U,I+25))=$P(VAX,U,I+13)
I @VAV@($P(VAS,U,28))]"" D
. I '$D(^HL(779.004,$P(VAX,U,16),0)) Q
. S $P(@VAV@($P(VAS,U,28)),U,2)=$$CNTRYI^DGADDUTL($P(VAX,U,16))
; -- CONFIDENTIAL PHONE NUMBER [29 - CPN]
I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",29))=$P(^(.13),"^",15)
Q3 K VABEG,VAEND,VAZIP4 Q
;
4 ;Other Address [OAD]
N VAZIP4
I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
S VAX(1)=VAX,VAX=$S($D(^DPT(DFN,VAX(1))):^(VAX(1)),1:"") I VAX(1)=.25 S VAX=$P(VAX,"^",1)_"^^"_$P(VAX,"^",2,99)
S VAX(2)=0 F I=3,4,5,6,7,8 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
S VAZ=@VAV@($P(VAS,"^",5)) I VAZ,$D(^DIC(5,+VAZ,0)) S VAZ(1)=$P(^(0),"^",1),@VAV@($P(VAS,"^",5))=VAZ_"^"_VAZ(1)
S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
S @VAV@($P(VAS,U,11))=VAZIP4_$S('$G(VAZIP4):"",($L(VAZIP4)=5):U_VAZIP4,1:U_$E(VAZIP4,1,5)_"-"_$E(VAZIP4,6,9))
Q
VADPT1 ;ALB/MRL/MJK,ERC,TDM - PATIENT VARIABLES ; 7/28/09 1:54pm
+1 ;;5.3;PIMS;**415,489,516,614,1015,1016**;JUN 30, 2012;Build 20
+2 ;IHS/ANMC/CLS 10/15/94 added IHS printable age
+3 ;IHS/OIT/LJF 11/10/2005 PATCH 1004 included for sites where it has been overwritten
1 ;Demographic [DEM]
+1 NEW W,Z,NODE
+2 ;
+3 ; -- name [1 - NM]
+4 SET VAX=^DPT(DFN,0)
SET @VAV@($PIECE(VAS,"^",1))=$PIECE(VAX,"^")
+5 ;
+6 ; -- ssn [2 - SS]
+7 SET Z=$PIECE(VAX,"^",9)
IF Z]""
SET @VAV@($PIECE(VAS,"^",2))=Z_$SELECT(Z]"":"^"_$EXTRACT(Z,1,3)_"-"_$EXTRACT(Z,4,5)_"-"_$EXTRACT(Z,6,10),1:"")
+8 ;
+9 ; -- date of birth [2 - DB]
+10 SET Z=$PIECE(VAX,"^",3)
SET Y=Z
IF Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",3))=Z_"^"_Y
+11 ;
+12 ; -- age [4 - AG]
+13 SET W=$SELECT('$DATA(^DPT(DFN,.35)):"",'^(.35):"",1:+^(.35))
SET Y=$SELECT('W:DT,1:W)
IF Z]""
SET @VAV@($PIECE(VAS,"^",4))=$EXTRACT(Y,1,3)-$EXTRACT(Z,1,3)-($EXTRACT(Y,4,7)<$EXTRACT(Z,4,7))
+14 ;IHS/ITSC/WAR 8/11/03 Q8 - Next line per Chris
+15 ;IHS/ANMC/CLS 10/15/94
IF @VAV@($PIECE(VAS,"^",4))<2
DO PAGE
+16 ;
+17 ; -- expired date [6 - EX]
+18 SET (Y,Z)=W
IF Y]""
XECUTE ^DD("DD")
IF Z]""
SET @VAV@($PIECE(VAS,"^",6))=Z_"^"_Y
+19 ;
+20 ; -- sex [5 - SX]
+21 SET Z=$PIECE(VAX,"^",2)
IF Z]""
SET @VAV@($PIECE(VAS,"^",5))=Z_"^"_$SELECT(Z="M":"MALE",Z="F":"FEMALE",1:"")
KILL Z
+22 ;
+23 ; -- remarks [7 - RE]
+24 SET @VAV@($PIECE(VAS,"^",7))=$PIECE(VAX,"^",10)
+25 ;
+26 ; -- historic race [8 - RA]
+27 SET Z=$PIECE(VAX,"^",6)
SET @VAV@($PIECE(VAS,"^",8))=Z_$SELECT($DATA(^DIC(10,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+28 ;
+29 ; -- religion [9 - RP]
+30 SET Z=$PIECE(VAX,"^",8)
SET @VAV@($PIECE(VAS,"^",9))=Z_$SELECT($DATA(^DIC(13,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+31 ;
+32 ; -- marital status [10 - MS]
+33 SET Z=$PIECE(VAX,"^",5)
SET @VAV@($PIECE(VAS,"^",10))=Z_$SELECT($DATA(^DIC(11,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+34 ;
+35 ; -- ethnicity [11 - ET]
+36 SET X=0
FOR Y=1:1
SET X=+$ORDER(^DPT(DFN,.06,X))
IF 'X
QUIT
Begin DoDot:1
+37 SET NODE=$GET(^DPT(DFN,.06,X,0))
SET Z=$PIECE(NODE,"^",1)
IF Z
Begin DoDot:2
+38 SET @VAV@($PIECE(VAS,"^",11),Y)=Z_"^"_$PIECE($GET(^DIC(10.2,Z,0)),"^",1)
+39 ; -- collection method
+40 SET Z=$PIECE(NODE,"^",2)
IF Z
Begin DoDot:3
+41 SET @VAV@($PIECE(VAS,"^",11),Y,1)=Z_"^"_$PIECE($GET(^DIC(10.3,Z,0)),"^",1)
End DoDot:3
End DoDot:2
End DoDot:1
+42 SET @VAV@($PIECE(VAS,"^",11))=Y-1
+43 ;
+44 ; -- race [12 - RC]
+45 SET X=0
FOR Y=1:1
SET X=+$ORDER(^DPT(DFN,.02,X))
IF 'X
QUIT
Begin DoDot:1
+46 SET NODE=$GET(^DPT(DFN,.02,X,0))
SET Z=$PIECE(NODE,"^",1)
IF Z
Begin DoDot:2
+47 SET @VAV@($PIECE(VAS,"^",12),Y)=Z_"^"_$PIECE($GET(^DIC(10,Z,0)),"^",1)
+48 ; -- collection method
+49 SET Z=$PIECE(NODE,"^",2)
IF Z
Begin DoDot:3
+50 SET @VAV@($PIECE(VAS,"^",12),Y,1)=Z_"^"_$PIECE($GET(^DIC(10.3,Z,0)),"^",1)
End DoDot:3
End DoDot:2
End DoDot:1
+51 SET @VAV@($PIECE(VAS,"^",12))=Y-1
+52 QUIT
+53 ;
+54 ;IHS/ITSC/WAR 8/11/03 Q8 - Next section added per Chris
PAGE ; -- IHS printable age ;IHS/ANMC/CLS 10/15/94
+1 NEW X,X1,X2,Y,AUX,D0
+2 SET D0=DFN
XECUTE ^DD(9000001,1102.98,9.3)
SET X=$PIECE(Y(9000001,1102.98,101),U,3)
SET Y=X
SET X=Y(9000001,1102.98,1)
SET X=X
SET X1=X
SET X2=Y
SET X=""
IF X2
IF X1
DO ^%DTC
SET AUX=X\365.25
SET X=$SELECT(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
KILL AUX
SET D0=Y(9000001,1102.98,80)
+3 SET @VAV@($PIECE(VAS,"^",4))=X
QUIT
+4 ;
2 ;Other Patient Variables [OPD]
+1 NEW W,Z
+2 SET VAX=^DPT(DFN,0)
+3 ;
+4 ; -- city of birth [1 - BC]
+5 SET @VAV@($PIECE(VAS,"^",1))=$PIECE(VAX,"^",11)
+6 ;
+7 ; -- state of birth [2 - BS]
+8 SET Z=$PIECE(VAX,"^",12)
SET @VAV@($PIECE(VAS,"^",2))=Z_$SELECT($DATA(^DIC(5,+Z,0)):"^"_$PIECE(^(0),"^",1),1:"")
+9 ;
+10 ; -- occupation [6 - OC]
+11 SET @VAV@($PIECE(VAS,"^",6))=$PIECE(VAX,"^",7)
+12 ;
+13 ; -- names
+14 SET VAX=$SELECT($DATA(^DPT(DFN,.24)):^(.24),1:"")
+15 ; father's [3 - FN]
SET @VAV@($PIECE(VAS,"^",3))=$PIECE(VAX,"^",1)
+16 ; mother's [4 - MN]
SET @VAV@($PIECE(VAS,"^",4))=$PIECE(VAX,"^",2)
+17 ; mother's maiden [5 - MM]
SET @VAV@($PIECE(VAS,"^",5))=$PIECE(VAX,"^",3)
+18 ;
+19 ; -- employment status [7 - ES]
+20 SET VAX=$SELECT($DATA(^DPT(DFN,.311)):^(.311),1:"")
SET W="EMPLOYED FULL TIME^EMPLOYED PART TIME^NOT EMPLOYED^SELF EMPLOYED^RETIRED^ACTIVE MILITARY DUTY^UNKNOWN"
+21 SET Z=$PIECE(VAX,"^",15)
SET @VAV@($PIECE(VAS,"^",7))=Z_$SELECT(Z:"^"_$PIECE(W,"^",Z),1:"")
+22 ;
+23 ; -- PHONE NUMBER [WORK] [8 - WP]
+24 IF $DATA(^DPT(DFN,.13))
SET @VAV@($PIECE(VAS,"^",8))=$PIECE(^(.13),"^",2)
+25 QUIT
+26 ;
3 ;Address [ADD]
+1 NEW VAFOR
+2 SET VABEG=$SELECT($DATA(VATEST("ADD",9)):VATEST("ADD",9),1:DT)
SET VAEND=$SELECT($DATA(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
+3 IF $SELECT($DATA(VAPA("P")):1,'$DATA(^DPT(DFN,.121)):1,$PIECE(^(.121),"^",9)'="Y":1,'$PIECE(^(.121),"^",7):1,$PIECE(^(.121),"^",7)>VABEG:1,'$PIECE(^(.121),"^",8):0,1:$PIECE(^(.121),"^",8)<VAEND)
SET VAX=$SELECT($DATA(^DPT(DFN,.11)):^(.11),1:"")
SET VAX(1)=0
+4 IF '$TEST
SET VAX=$SELECT($DATA(^DPT(DFN,.121)):^(.121),1:"")
SET VAX(1)=1
+5 ;set the foreign address fields into local variables for later
+6 IF 'VAX(1)
SET VAFOR=$PIECE(VAX,U,8,10)
+7 IF VAX(1)
Begin DoDot:1
+8 IF '$DATA(^DPT(DFN,.122))
SET VAFOR=""
QUIT
+9 SET VAFOR=$PIECE(^DPT(DFN,.122),U,1,3)
End DoDot:1
+10 FOR I=1:1:6
SET VAZ=$PIECE(VAX,"^",I)
SET @VAV@($PIECE(VAS,"^",I))=VAZ
IF I=5
IF $DATA(^DIC(5,+VAZ,0))
SET VAZ=$PIECE(^(0),"^")
SET @VAV@($PIECE(VAS,"^",5))=@VAV@($PIECE(VAS,"^",5))_"^"_VAZ
+11 SET VAZ=$SELECT('VAX(1):$PIECE(VAX,"^",7),1:$PIECE(VAX,"^",11))
IF $DATA(^DIC(5,+$PIECE(VAX,"^",5),1,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",7))=VAZ
+12 SET VAZIP4=$PIECE(VAX,U,12)
+13 SET @VAV@($PIECE(VAS,U,11))=VAZIP4_$SELECT('$GET(VAZIP4):"",($LENGTH(VAZIP4)=5):U_VAZIP4,1:U_$EXTRACT(VAZIP4,1,5)_"-"_$EXTRACT(VAZIP4,6,9))
+14 ;DG*5.3*516
+15 IF $DATA(^DPT(DFN,.13))
SET @VAV@($PIECE(VAS,"^",8))=$PIECE(^(.13),"^",1)
+16 ;foreign address fields
+17 FOR I=1:1:3
SET VAZ=$PIECE(VAFOR,U,I)
SET @VAV@($PIECE(VAS,U,I+22))=VAZ
+18 ;
+19 IF $PIECE($GET(VAFOR),U,3)]""
Begin DoDot:1
+20 SET VACNTRY=$PIECE(VAFOR,U,3)
+21 SET VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
+22 SET $PIECE(@VAV@($PIECE(VAS,U,25)),U,2)=VACNTRY
End DoDot:1
+23 IF 'VAX(1)
GOTO CA
+24 SET @VAV@($PIECE(VAS,"^",8))=$PIECE(VAX,"^",10)
+25 FOR I=7,8
SET VAZ=$PIECE(VAX,"^",I)
SET Y=VAZ
IF Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",I+2))=VAZ_"^"_Y
CA ;Confidential Address
+1 IF '$DATA(^DPT(DFN,.141))
GOTO Q3
+2 NEW VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
+3 SET VAX=$SELECT($DATA(^DPT(DFN,.141)):^(.141),1:"")
+4 SET VAACTDT=$SELECT($DATA(VAPA("CD")):VAPA("CD"),1:DT)
+5 FOR I=1:1:6
SET VAZ=$PIECE(VAX,"^",I)
SET @VAV@($PIECE(VAS,"^",I+12))=VAZ
Begin DoDot:1
+6 IF I=5
IF $DATA(^DIC(5,+VAZ,0))
SET VAZ=$PIECE(^(0),"^")
SET @VAV@($PIECE(VAS,"^",I+12))=@VAV@($PIECE(VAS,"^",I+12))_"^"_VAZ
QUIT
+7 IF I=6
IF ($GET(VAZ)]"")
SET @VAV@($PIECE(VAS,"^",I+12))=@VAV@($PIECE(VAS,"^",I+12))_"^"_$SELECT(($LENGTH(VAZ)=5):VAZ,1:$EXTRACT(VAZ,1,5)_"-"_$EXTRACT(VAZ,6,9))
End DoDot:1
+8 SET VAZ=$PIECE(VAX,"^",11)
IF $DATA(^DIC(5,+$PIECE(VAX,"^",5),1,+VAZ,0))
SET VAZ=VAZ_"^"_$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",19))=VAZ
+9 FOR I=7,8
SET VAZ=$PIECE(VAX,"^",I)
SET Y=VAZ
IF Y]""
XECUTE ^DD("DD")
SET @VAV@($PIECE(VAS,"^",I+13))=VAZ_"^"_Y
+10 SET VABEG=$PIECE(VAX,"^",7)
SET VAEND=$PIECE(VAX,"^",8)
+11 SET @VAV@($PIECE(VAS,"^",12))=1
+12 IF 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT))
SET @VAV@($PIECE(VAS,"^",12))=0
+13 IF $DATA(^DPT(DFN,.14))
Begin DoDot:1
+14 SET VACAN=""
FOR
SET VACAN=$ORDER(^DPT(DFN,.14,VACAN))
IF VACAN=""
QUIT
Begin DoDot:2
+15 IF '$DATA(^DPT(DFN,.14,VACAN,0))
QUIT
+16 SET VATYP=$PIECE(^DPT(DFN,.14,VACAN,0),"^",1)
SET VAACT=$PIECE(^DPT(DFN,.14,VACAN,0),"^",2)
+17 SET VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
+18 SET VATYPNAM=""
FOR I=1:1
SET VATYPNAM=$PIECE(VACAT,";",I)
IF VATYPNAM=""
QUIT
Begin DoDot:3
+19 IF +VATYPNAM[VATYP
SET VATYPNAM=$PIECE(VATYPNAM,":",2)
SET @VAV@($PIECE(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
End DoDot:3
End DoDot:2
End DoDot:1
+20 ;foreign address fields for the confidential address
+21 FOR I=1:1:3
SET @VAV@($PIECE(VAS,U,I+25))=$PIECE(VAX,U,I+13)
+22 IF @VAV@($PIECE(VAS,U,28))]""
Begin DoDot:1
+23 IF '$DATA(^HL(779.004,$PIECE(VAX,U,16),0))
QUIT
+24 SET $PIECE(@VAV@($PIECE(VAS,U,28)),U,2)=$$CNTRYI^DGADDUTL($PIECE(VAX,U,16))
End DoDot:1
+25 ; -- CONFIDENTIAL PHONE NUMBER [29 - CPN]
+26 IF $DATA(^DPT(DFN,.13))
SET @VAV@($PIECE(VAS,"^",29))=$PIECE(^(.13),"^",15)
Q3 KILL VABEG,VAEND,VAZIP4
QUIT
+1 ;
4 ;Other Address [OAD]
+1 NEW VAZIP4
+2 IF $SELECT('$DATA(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0)
SET VAX=.21
SET VAOA("A")=7
+3 IF '$TEST
SET VAX="."_$PIECE("33^34^211^331^311^25","^",+VAOA("A"))
+4 SET VAX(1)=VAX
SET VAX=$SELECT($DATA(^DPT(DFN,VAX(1))):^(VAX(1)),1:"")
IF VAX(1)=.25
SET VAX=$PIECE(VAX,"^",1)_"^^"_$PIECE(VAX,"^",2,99)
+5 SET VAX(2)=0
FOR I=3,4,5,6,7,8
SET VAX(2)=VAX(2)+1
SET @VAV@($PIECE(VAS,"^",VAX(2)))=$PIECE(VAX,"^",I)
+6 SET @VAV@($PIECE(VAS,"^",7))=""
SET @VAV@($PIECE(VAS,"^",8))=$PIECE(VAX,"^",9)
SET VAX(2)=8
+7 FOR I=1,2
SET VAX(2)=VAX(2)+1
SET @VAV@($PIECE(VAS,"^",VAX(2)))=$PIECE(VAX,"^",I)
+8 IF "^.311^.25"[("^"_VAX(1)_"^")
SET @VAV@($PIECE(VAS,"^",10))=""
+9 SET VAZ=@VAV@($PIECE(VAS,"^",5))
IF VAZ
IF $DATA(^DIC(5,+VAZ,0))
SET VAZ(1)=$PIECE(^(0),"^",1)
SET @VAV@($PIECE(VAS,"^",5))=VAZ_"^"_VAZ(1)
+10 SET VAZIP4=$PIECE($GET(^DPT(DFN,.22)),U,VAOA("A"))
+11 SET @VAV@($PIECE(VAS,U,11))=VAZIP4_$SELECT('$GET(VAZIP4):"",($LENGTH(VAZIP4)=5):U_VAZIP4,1:U_$EXTRACT(VAZIP4,1,5)_"-"_$EXTRACT(VAZIP4,6,9))
+12 QUIT
