VADPT1.m

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))]""