VADPT1 ;ALB/MRL,MJK,ERC,TDM,CLT,ARF - PATIENT VARIABLES ;05 May 2017 1:41 PM
;;5.3;Registration;**415,489,516,614,688,754,887,941,1059,1067,1071,1064**;Aug 13, 1993;Build 41
;
; NOTE: When setting up subscripts in the return array, the top level subscript must always be defined
; - (e.g. Inpatient Meds uses this API and assumes the top level subscript is defined)
;
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))
;
; -- 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
;
; -- current pt preferred language [13 - LG]
N VALANGDT,VAPRFLAN,VALANG0,VAY,VALANGDA,X,Y
S VALANGDT=9999999,(VAPRFLAN,VALANG0)=""
S VALANGDT=$O(^DPT(DFN,.207,"B",VALANGDT),-1)
I VALANGDT="" S @VAV@($P(VAS,"^",13))="",@VAV@($P(VAS,"^",13),1)=""
I VALANGDT'="" D
.S VALANGDA=$O(^DPT(DFN,.207,"B",VALANGDT,0))
.S VALANG0=$G(^DPT(DFN,.207,VALANGDA,0)),Y=$P(VALANG0,U),VAPRFLAN=$P(VALANG0,U,2)
.S (VAY,Y)=VALANGDT X ^DD("DD") S VALANGDT=Y
.S @VAV@($P(VAS,"^",13))=VAY_"^"_VALANGDT ; FM version^human readable
.S @VAV@($P(VAS,"^",13),1)=VALANGDA_"^"_VAPRFLAN ; Pointer^human readable
;
;**1059 Adding Sexual Orientation, Sexual Orientation Description, Pronoun, Pronoun Description, SIGI [14 - SOGI]
;**1071 VAMPI-13755 (jfw) - Display Additional SO Info
N SOC,CNTR,PRO,SIGI,SIGIN,VAREF
S @VAV@($P(VAS,"^",14))=""
;Sexual Orientation #.025 multiple
S CNTR=1,X=0 F S X=$O(^DPT(DFN,.025,X)) Q:'X!(X="") D
.N VASOI D GETS^DIQ(2.025,X_","_DFN,"*","EI","VASOI")
.;External^Internal values: SO, Status, Date Created, Date Last Updated, TIU Document
.S VAREF="VASOI(2.025,"""_X_","_DFN_","")",@VAV@($P(VAS,"^",14),1,CNTR)=$P($G(^DG(47.77,@VAREF@(.01,"I"),0)),"^",1,2)
.N VAI F VAI=.02,.03,.04,.05 S @VAV@($P(VAS,"^",14),1,CNTR,(VAI*100-1))=@VAREF@(VAI,"E")_"^"_@VAREF@(VAI,"I")
.S CNTR=CNTR+1
S @VAV@($P(VAS,"^",14),1)=CNTR-1
;Sexual Orientatin Description #.241
S @VAV@($P(VAS,"^",14),2)=$P($G(^DPT(DFN,.241)),"^")
;Pronoun #.2406 multiple
K CNTR,X
S CNTR=1,X=0 F S X=$O(^DPT(DFN,.2406,X)) Q:'X!(X="") D
.S PRO=$G(^DPT(DFN,.2406,X,0))
.S @VAV@($P(VAS,"^",14),3,CNTR)=$G(^DG(47.78,PRO,0)),CNTR=CNTR+1 ;NAME ^ CODE
S @VAV@($P(VAS,"^",14),3)=CNTR-1
;Pronoun Description #.24061
S @VAV@($P(VAS,"^",14),4)=$P($G(^DPT(DFN,.241)),"^",2)
;SELF IDENTIFIED GENDER #.024
S SIGI=$P($G(^DPT(DFN,.24)),"^",4),SIGIN=$$GET1^DIQ(2,DFN_",",.024)
S @VAV@($P(VAS,"^",14),5)=SIGIN_"^"_SIGI ;NAME ^ CODE
; DG*5.3*1064; Adding INDIAN SELF IDENTIFICATION, INDIAN ATTESTATION DATE, INDIAN START DATE, INDIAN END DATE [15 - IND]
; The top level subscript must always be defined (see NOTE above)
S @VAV@($P(VAS,"^",15))=""
N DGINDARR
D GETS^DIQ(2,DFN,".571:.574","I","DGINDARR")
S @VAV@($P(VAS,"^",15),1)=$G(DGINDARR(2,DFN_",",.571,"I"))
S @VAV@($P(VAS,"^",15),2)=$G(DGINDARR(2,DFN_",",.572,"I"))
S @VAV@($P(VAS,"^",15),3)=$G(DGINDARR(2,DFN_",",.573,"I"))
S @VAV@($P(VAS,"^",15),4)=$G(DGINDARR(2,DFN_",",.574,"I"))
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
; JAM, Go to Residential Address if no Conf address- VADPT ICR 10061 ;DG*5.3*941
I '$D(^DPT(DFN,.141)) G RES
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)
RES ;Residential address
;CLT, Add Residential Address to VADPT ICR 10061 ;DG*5.3*941
I '$D(^DPT(DFN,.115)) G Q3
N DGAR
S DGAR=$G(^DPT(DFN,.115))
F I=1:1:7 S @VAV@(29+I)=$P(DGAR,U,I)
I @VAV@(34)'="",@VAV@(36)'="" I $D(^DIC(5,@VAV@(34),1,@VAV@(36),0)) S VAZ=$P(^DIC(5,@VAV@(34),1,@VAV@(36),0),"^",1),@VAV@(36)=@VAV@(36)_"^"_VAZ
I @VAV@(34)'="" S:$D(^DIC(5,@VAV@(34),0)) @VAV@(34)=@VAV@(34)_"^"_$P(^DIC(5,@VAV@(34),0),U,1)
S @VAV@(37)=$P(DGAR,"^",10)
I @VAV@(37)'="" D
. S VACNTRY=@VAV@(37)
. S VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
. S $P(@VAV@(37),U,2)=VACNTRY
S @VAV@(38)=$P(DGAR,"^",8)
S @VAV@(39)=$P(DGAR,"^",9)
;
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))=""
;DG*5.3*1067 store the RELATION TYPE field, from the PATIENT CONTACT RELATION file(#12.11)file, into node 10
;and move RELATIONSHIP TO PATIENT to node 12 only for the Emergency Contacts, Next of Kins, and Designees options.
I (+VAOA("A")'=5)&(+VAOA("A")'=6) S @VAV@($P(VAS,"^",10))=$$GET1^DIQ(12.11,$P(VAX,"^",15)_",",.02),@VAV@($P(VAS,"^",12))=$P(VAX,"^",2)
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVADPT1 10760 printed Sep 23, 2025@20:37:06 Page 2
VADPT1 ;ALB/MRL,MJK,ERC,TDM,CLT,ARF - PATIENT VARIABLES ;05 May 2017 1:41 PM
+1 ;;5.3;Registration;**415,489,516,614,688,754,887,941,1059,1067,1071,1064**;Aug 13, 1993;Build 41
+2 ;
+3 ; NOTE: When setting up subscripts in the return array, the top level subscript must always be defined
+4 ; - (e.g. Inpatient Meds uses this API and assumes the top level subscript is defined)
+5 ;
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 ;
+15 ; -- expired date [6 - EX]
+16 SET (Y,Z)=W
if Y]""
XECUTE ^DD("DD")
if Z]""
SET @VAV@($PIECE(VAS,"^",6))=Z_"^"_Y
+17 ;
+18 ; -- sex [5 - SX]
+19 SET Z=$PIECE(VAX,"^",2)
if Z]""
SET @VAV@($PIECE(VAS,"^",5))=Z_"^"_$SELECT(Z="M":"MALE",Z="F":"FEMALE",1:"")
KILL Z
+20 ;
+21 ; -- remarks [7 - RE]
+22 SET @VAV@($PIECE(VAS,"^",7))=$PIECE(VAX,"^",10)
+23 ;
+24 ; -- historic race [8 - RA]
+25 SET Z=$PIECE(VAX,"^",6)
SET @VAV@($PIECE(VAS,"^",8))=Z_$SELECT($DATA(^DIC(10,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+26 ;
+27 ; -- religion [9 - RP]
+28 SET Z=$PIECE(VAX,"^",8)
SET @VAV@($PIECE(VAS,"^",9))=Z_$SELECT($DATA(^DIC(13,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+29 ;
+30 ; -- marital status [10 - MS]
+31 SET Z=$PIECE(VAX,"^",5)
SET @VAV@($PIECE(VAS,"^",10))=Z_$SELECT($DATA(^DIC(11,+Z,0)):"^"_$PIECE(^(0),"^"),1:"")
+32 ;
+33 ; -- ethnicity [11 - ET]
+34 SET X=0
FOR Y=1:1
SET X=+$ORDER(^DPT(DFN,.06,X))
if 'X
QUIT
Begin DoDot:1
+35 SET NODE=$GET(^DPT(DFN,.06,X,0))
SET Z=$PIECE(NODE,"^",1)
IF Z
Begin DoDot:2
+36 SET @VAV@($PIECE(VAS,"^",11),Y)=Z_"^"_$PIECE($GET(^DIC(10.2,Z,0)),"^",1)
+37 ; -- collection method
+38 SET Z=$PIECE(NODE,"^",2)
IF Z
Begin DoDot:3
+39 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
+40 SET @VAV@($PIECE(VAS,"^",11))=Y-1
+41 ;
+42 ; -- race [12 - RC]
+43 SET X=0
FOR Y=1:1
SET X=+$ORDER(^DPT(DFN,.02,X))
if 'X
QUIT
Begin DoDot:1
+44 SET NODE=$GET(^DPT(DFN,.02,X,0))
SET Z=$PIECE(NODE,"^",1)
IF Z
Begin DoDot:2
+45 SET @VAV@($PIECE(VAS,"^",12),Y)=Z_"^"_$PIECE($GET(^DIC(10,Z,0)),"^",1)
+46 ; -- collection method
+47 SET Z=$PIECE(NODE,"^",2)
IF Z
Begin DoDot:3
+48 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
+49 SET @VAV@($PIECE(VAS,"^",12))=Y-1
+50 ;
+51 ; -- current pt preferred language [13 - LG]
+52 NEW VALANGDT,VAPRFLAN,VALANG0,VAY,VALANGDA,X,Y
+53 SET VALANGDT=9999999
SET (VAPRFLAN,VALANG0)=""
+54 SET VALANGDT=$ORDER(^DPT(DFN,.207,"B",VALANGDT),-1)
+55 IF VALANGDT=""
SET @VAV@($PIECE(VAS,"^",13))=""
SET @VAV@($PIECE(VAS,"^",13),1)=""
+56 IF VALANGDT'=""
Begin DoDot:1
+57 SET VALANGDA=$ORDER(^DPT(DFN,.207,"B",VALANGDT,0))
+58 SET VALANG0=$GET(^DPT(DFN,.207,VALANGDA,0))
SET Y=$PIECE(VALANG0,U)
SET VAPRFLAN=$PIECE(VALANG0,U,2)
+59 SET (VAY,Y)=VALANGDT
XECUTE ^DD("DD")
SET VALANGDT=Y
+60 ; FM version^human readable
SET @VAV@($PIECE(VAS,"^",13))=VAY_"^"_VALANGDT
+61 ; Pointer^human readable
SET @VAV@($PIECE(VAS,"^",13),1)=VALANGDA_"^"_VAPRFLAN
End DoDot:1
+62 ;
+63 ;**1059 Adding Sexual Orientation, Sexual Orientation Description, Pronoun, Pronoun Description, SIGI [14 - SOGI]
+64 ;**1071 VAMPI-13755 (jfw) - Display Additional SO Info
+65 NEW SOC,CNTR,PRO,SIGI,SIGIN,VAREF
+66 SET @VAV@($PIECE(VAS,"^",14))=""
+67 ;Sexual Orientation #.025 multiple
+68 SET CNTR=1
SET X=0
FOR
SET X=$ORDER(^DPT(DFN,.025,X))
if 'X!(X="")
QUIT
Begin DoDot:1
+69 NEW VASOI
DO GETS^DIQ(2.025,X_","_DFN,"*","EI","VASOI")
+70 ;External^Internal values: SO, Status, Date Created, Date Last Updated, TIU Document
+71 SET VAREF="VASOI(2.025,"""_X_","_DFN_","")"
SET @VAV@($PIECE(VAS,"^",14),1,CNTR)=$PIECE($GET(^DG(47.77,@VAREF@(.01,"I"),0)),"^",1,2)
+72 NEW VAI
FOR VAI=.02,.03,.04,.05
SET @VAV@($PIECE(VAS,"^",14),1,CNTR,(VAI*100-1))=@VAREF@(VAI,"E")_"^"_@VAREF@(VAI,"I")
+73 SET CNTR=CNTR+1
End DoDot:1
+74 SET @VAV@($PIECE(VAS,"^",14),1)=CNTR-1
+75 ;Sexual Orientatin Description #.241
+76 SET @VAV@($PIECE(VAS,"^",14),2)=$PIECE($GET(^DPT(DFN,.241)),"^")
+77 ;Pronoun #.2406 multiple
+78 KILL CNTR,X
+79 SET CNTR=1
SET X=0
FOR
SET X=$ORDER(^DPT(DFN,.2406,X))
if 'X!(X="")
QUIT
Begin DoDot:1
+80 SET PRO=$GET(^DPT(DFN,.2406,X,0))
+81 ;NAME ^ CODE
SET @VAV@($PIECE(VAS,"^",14),3,CNTR)=$GET(^DG(47.78,PRO,0))
SET CNTR=CNTR+1
End DoDot:1
+82 SET @VAV@($PIECE(VAS,"^",14),3)=CNTR-1
+83 ;Pronoun Description #.24061
+84 SET @VAV@($PIECE(VAS,"^",14),4)=$PIECE($GET(^DPT(DFN,.241)),"^",2)
+85 ;SELF IDENTIFIED GENDER #.024
+86 SET SIGI=$PIECE($GET(^DPT(DFN,.24)),"^",4)
SET SIGIN=$$GET1^DIQ(2,DFN_",",.024)
+87 ;NAME ^ CODE
SET @VAV@($PIECE(VAS,"^",14),5)=SIGIN_"^"_SIGI
+88 ; DG*5.3*1064; Adding INDIAN SELF IDENTIFICATION, INDIAN ATTESTATION DATE, INDIAN START DATE, INDIAN END DATE [15 - IND]
+89 ; The top level subscript must always be defined (see NOTE above)
+90 SET @VAV@($PIECE(VAS,"^",15))=""
+91 NEW DGINDARR
+92 DO GETS^DIQ(2,DFN,".571:.574","I","DGINDARR")
+93 SET @VAV@($PIECE(VAS,"^",15),1)=$GET(DGINDARR(2,DFN_",",.571,"I"))
+94 SET @VAV@($PIECE(VAS,"^",15),2)=$GET(DGINDARR(2,DFN_",",.572,"I"))
+95 SET @VAV@($PIECE(VAS,"^",15),3)=$GET(DGINDARR(2,DFN_",",.573,"I"))
+96 SET @VAV@($PIECE(VAS,"^",15),4)=$GET(DGINDARR(2,DFN_",",.574,"I"))
+97 QUIT
+98 ;
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 ; JAM, Go to Residential Address if no Conf address- VADPT ICR 10061 ;DG*5.3*941
+2 IF '$DATA(^DPT(DFN,.141))
GOTO RES
+3 NEW VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
+4 SET VAX=$SELECT($DATA(^DPT(DFN,.141)):^(.141),1:"")
+5 SET VAACTDT=$SELECT($DATA(VAPA("CD")):VAPA("CD"),1:DT)
+6 FOR I=1:1:6
SET VAZ=$PIECE(VAX,"^",I)
SET @VAV@($PIECE(VAS,"^",I+12))=VAZ
Begin DoDot:1
+7 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
+8 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
+9 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
+10 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
+11 SET VABEG=$PIECE(VAX,"^",7)
SET VAEND=$PIECE(VAX,"^",8)
+12 SET @VAV@($PIECE(VAS,"^",12))=1
+13 IF 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT))
SET @VAV@($PIECE(VAS,"^",12))=0
+14 IF $DATA(^DPT(DFN,.14))
Begin DoDot:1
+15 SET VACAN=""
FOR
SET VACAN=$ORDER(^DPT(DFN,.14,VACAN))
if VACAN=""
QUIT
Begin DoDot:2
+16 if '$DATA(^DPT(DFN,.14,VACAN,0))
QUIT
+17 SET VATYP=$PIECE(^DPT(DFN,.14,VACAN,0),"^",1)
SET VAACT=$PIECE(^DPT(DFN,.14,VACAN,0),"^",2)
+18 SET VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
+19 SET VATYPNAM=""
FOR I=1:1
SET VATYPNAM=$PIECE(VACAT,";",I)
if VATYPNAM=""
QUIT
Begin DoDot:3
+20 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
+21 ;foreign address fields for the confidential address
+22 FOR I=1:1:3
SET @VAV@($PIECE(VAS,U,I+25))=$PIECE(VAX,U,I+13)
+23 IF @VAV@($PIECE(VAS,U,28))]""
Begin DoDot:1
+24 IF '$DATA(^HL(779.004,$PIECE(VAX,U,16),0))
QUIT
+25 SET $PIECE(@VAV@($PIECE(VAS,U,28)),U,2)=$$CNTRYI^DGADDUTL($PIECE(VAX,U,16))
End DoDot:1
+26 ; -- CONFIDENTIAL PHONE NUMBER [29 - CPN]
+27 IF $DATA(^DPT(DFN,.13))
SET @VAV@($PIECE(VAS,"^",29))=$PIECE(^(.13),"^",15)
RES ;Residential address
+1 ;CLT, Add Residential Address to VADPT ICR 10061 ;DG*5.3*941
+2 IF '$DATA(^DPT(DFN,.115))
GOTO Q3
+3 NEW DGAR
+4 SET DGAR=$GET(^DPT(DFN,.115))
+5 FOR I=1:1:7
SET @VAV@(29+I)=$PIECE(DGAR,U,I)
+6 IF @VAV@(34)'=""
IF @VAV@(36)'=""
IF $DATA(^DIC(5,@VAV@(34),1,@VAV@(36),0))
SET VAZ=$PIECE(^DIC(5,@VAV@(34),1,@VAV@(36),0),"^",1)
SET @VAV@(36)=@VAV@(36)_"^"_VAZ
+7 IF @VAV@(34)'=""
if $DATA(^DIC(5,@VAV@(34),0))
SET @VAV@(34)=@VAV@(34)_"^"_$PIECE(^DIC(5,@VAV@(34),0),U,1)
+8 SET @VAV@(37)=$PIECE(DGAR,"^",10)
+9 IF @VAV@(37)'=""
Begin DoDot:1
+10 SET VACNTRY=@VAV@(37)
+11 SET VACNTRY=$$CNTRYI^DGADDUTL(VACNTRY)
+12 SET $PIECE(@VAV@(37),U,2)=VACNTRY
End DoDot:1
+13 SET @VAV@(38)=$PIECE(DGAR,"^",8)
+14 SET @VAV@(39)=$PIECE(DGAR,"^",9)
+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 ;DG*5.3*1067 store the RELATION TYPE field, from the PATIENT CONTACT RELATION file(#12.11)file, into node 10
+10 ;and move RELATIONSHIP TO PATIENT to node 12 only for the Emergency Contacts, Next of Kins, and Designees options.
+11 IF (+VAOA("A")'=5)&(+VAOA("A")'=6)
SET @VAV@($PIECE(VAS,"^",10))=$$GET1^DIQ(12.11,$PIECE(VAX,"^",15)_",",.02)
SET @VAV@($PIECE(VAS,"^",12))=$PIECE(VAX,"^",2)
+12 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)
+13 SET VAZIP4=$PIECE($GET(^DPT(DFN,.22)),U,VAOA("A"))
+14 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))
+15 QUIT
