source: WorldVistAEHR/trunk/r/REGISTRATION-DGQE-DG-DPT-GRPX-VAD-VAF-VAS-VAT-VAU--VA-VIC--DGBT--DGJ--DGYA--VALM/VADPT1.m@ 1351

VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07  15:00
 ;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 28
 ; Modified from FOIA VISTA,
 ; Copyright (C) 2007 WorldVistA
 ;
 ; This program is free software; you can redistribute it and/or modify
 ; it under the terms of the GNU General Public License as published by
 ; the Free Software Foundation; either version 2 of the License, or
 ; (at your option) any later version.
 ;
 ; This program is distributed in the hope that it will be useful,
 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 ; GNU General Public License for more details.
 ;
 ; You should have received a copy of the GNU General Public License
 ; along with this program; if not, write to the Free Software
 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301 USA
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))
 ;
 ; Added for VOE to support pediatrics
 ;
 I @VAV@($P(VAS,"^",4))<2 D  ;IHS/ANMC/CLS 01/20/2005
 .N X,X1,X2,X3
 .S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
 .S X2=$P(VAX,"^",3) Q:'X1!('X2)
 .D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
 .S @VAV@($P(VAS,"^",4))=X Q
 ;
 ; End VOE addition
 ;
 ;
 ; -- 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
 ;
 ; Added for VOE to support pediatrics
 ;
PAGE ; -- IHS printable age  ;IHS/ITSC/CLS 01/14/2005
 N X,X1,X2,Y,AUX
 S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
 S X2=$P(VAX,"^",3) D:X2 ^%DTC:X1 S AUX=X\365.25,X=$S(AUX>2:AUX_" YRS",X<31:X_" DYS",1:X\30_" MOS")
 S @VAV@($P(VAS,"^",4))=X Q
 ;
 ; End addition for VOE & IHS
 ;
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:"")
 Q
 ;
3 ;Address [ADD]
 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
 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)
 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
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