- 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 Mar 13, 2025@22:05:55 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
