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

Last change on this file since 636 was 636, checked in by George Lilly, 14 years ago

WorldVistAEHR overlayed on FOIAVistA
File size: 7.2 KB
Line 
1VADPT1 ;ALB/MRL/MJK - PATIENT VARIABLES ;1/27/07 15:00
2 ;;5.3;Registration;**415,489,516,614,634**;Aug 13, 1993;Build 28
3 ; Modified from FOIA VISTA,
4 ; Copyright (C) 2007 WorldVistA
5 ;
6 ; This program is free software; you can redistribute it and/or modify
7 ; it under the terms of the GNU General Public License as published by
8 ; the Free Software Foundation; either version 2 of the License, or
9 ; (at your option) any later version.
10 ;
11 ; This program is distributed in the hope that it will be useful,
12 ; but WITHOUT ANY WARRANTY; without even the implied warranty of
13 ; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
14 ; GNU General Public License for more details.
15 ;
16 ; You should have received a copy of the GNU General Public License
17 ; along with this program; if not, write to the Free Software
18 ; Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA
191 ;Demographic [DEM]
20 N W,Z,NODE
21 ;
22 ; -- name [1 - NM]
23 S VAX=^DPT(DFN,0),@VAV@($P(VAS,"^",1))=$P(VAX,"^")
24 ;
25 ; -- ssn [2 - SS]
26 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:"")
27 ;
28 ; -- date of birth [2 - DB]
29 S Z=$P(VAX,"^",3),Y=Z I Y]"" X ^DD("DD") S @VAV@($P(VAS,"^",3))=Z_"^"_Y
30 ;
31 ; -- age [4 - AG]
32 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))
33 ;
34 ; Added for VOE to support pediatrics
35 ;
36 I @VAV@($P(VAS,"^",4))<2 D ;IHS/ANMC/CLS 01/20/2005
37 .N X,X1,X2,X3
38 .S X1=$S('$G(^DPT(DFN,.35)):DT,1:+^(.35))
39 .S X2=$P(VAX,"^",3) Q:'X1!('X2)
40 .D ^%DTC S X3=X\365.25,X=$S(X3>2:X3,X<31:X_" DYS",1:X\30_" MOS")
41 .S @VAV@($P(VAS,"^",4))=X Q
42 ;
43 ; End VOE addition
44 ;
45 ;
46 ; -- expired date [6 - EX]
47 S (Y,Z)=W X:Y]"" ^DD("DD") S:Z]"" @VAV@($P(VAS,"^",6))=Z_"^"_Y
48 ;
49 ; -- sex [5 - SX]
50 S Z=$P(VAX,"^",2) S:Z]"" @VAV@($P(VAS,"^",5))=Z_"^"_$S(Z="M":"MALE",Z="F":"FEMALE",1:"") K Z
51 ;
52 ; -- remarks [7 - RE]
53 S @VAV@($P(VAS,"^",7))=$P(VAX,"^",10)
54 ;
55 ; -- historic race [8 - RA]
56 S Z=$P(VAX,"^",6),@VAV@($P(VAS,"^",8))=Z_$S($D(^DIC(10,+Z,0)):"^"_$P(^(0),"^"),1:"")
57 ;
58 ; -- religion [9 - RP]
59 S Z=$P(VAX,"^",8),@VAV@($P(VAS,"^",9))=Z_$S($D(^DIC(13,+Z,0)):"^"_$P(^(0),"^"),1:"")
60 ;
61 ; -- marital status [10 - MS]
62 S Z=$P(VAX,"^",5),@VAV@($P(VAS,"^",10))=Z_$S($D(^DIC(11,+Z,0)):"^"_$P(^(0),"^"),1:"")
63 ;
64 ; -- ethnicity [11 - ET]
65 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.06,X)) Q:'X D
66 .S NODE=$G(^DPT(DFN,.06,X,0)),Z=$P(NODE,"^",1) I Z D
67 ..S @VAV@($P(VAS,"^",11),Y)=Z_"^"_$P($G(^DIC(10.2,Z,0)),"^",1)
68 ..; -- collection method
69 ..S Z=$P(NODE,"^",2) I Z D
70 ...S @VAV@($P(VAS,"^",11),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
71 S @VAV@($P(VAS,"^",11))=Y-1
72 ;
73 ; -- race [12 - RC]
74 S X=0 F Y=1:1 S X=+$O(^DPT(DFN,.02,X)) Q:'X D
75 .S NODE=$G(^DPT(DFN,.02,X,0)),Z=$P(NODE,"^",1) I Z D
76 ..S @VAV@($P(VAS,"^",12),Y)=Z_"^"_$P($G(^DIC(10,Z,0)),"^",1)
77 ..; -- collection method
78 ..S Z=$P(NODE,"^",2) I Z D
79 ...S @VAV@($P(VAS,"^",12),Y,1)=Z_"^"_$P($G(^DIC(10.3,Z,0)),"^",1)
80 S @VAV@($P(VAS,"^",12))=Y-1
81 Q
82 ;
83 ; Added for VOE to support pediatrics
84 ;
85PAGE ; -- IHS printable age ;IHS/ITSC/CLS 01/14/2005
86 N X,X1,X2,Y,AUX
87 S X1=$S('$D(^DPT(DFN,.35)):DT,1:+^(.35))
88 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")
89 S @VAV@($P(VAS,"^",4))=X Q
90 ;
91 ; End addition for VOE & IHS
92 ;
932 ;Other Patient Variables [OPD]
94 N W,Z
95 S VAX=^DPT(DFN,0)
96 ;
97 ; -- city of birth [1 - BC]
98 S @VAV@($P(VAS,"^",1))=$P(VAX,"^",11)
99 ;
100 ; -- state of birth [2 - BS]
101 S Z=$P(VAX,"^",12),@VAV@($P(VAS,"^",2))=Z_$S($D(^DIC(5,+Z,0)):"^"_$P(^(0),"^",1),1:"")
102 ;
103 ; -- occupation [6 - OC]
104 S @VAV@($P(VAS,"^",6))=$P(VAX,"^",7)
105 ;
106 ; -- names
107 S VAX=$S($D(^DPT(DFN,.24)):^(.24),1:"")
108 S @VAV@($P(VAS,"^",3))=$P(VAX,"^",1) ; father's [3 - FN]
109 S @VAV@($P(VAS,"^",4))=$P(VAX,"^",2) ; mother's [4 - MN]
110 S @VAV@($P(VAS,"^",5))=$P(VAX,"^",3) ; mother's maiden [5 - MM]
111 ;
112 ; -- employment status [7 - ES]
113 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"
114 S Z=$P(VAX,"^",15),@VAV@($P(VAS,"^",7))=Z_$S(Z:"^"_$P(W,"^",Z),1:"")
115 Q
116 ;
1173 ;Address [ADD]
118 S VABEG=$S($D(VATEST("ADD",9)):VATEST("ADD",9),1:DT),VAEND=$S($D(VATEST("ADD",10)):VATEST("ADD",10),1:DT)
119 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
120 E S VAX=$S($D(^DPT(DFN,.121)):^(.121),1:""),VAX(1)=1
121 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
122 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
123 S VAZIP4=$P(VAX,U,12)
124 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))
125 ;DG*5.3*516
126 I $D(^DPT(DFN,.13)) S @VAV@($P(VAS,"^",8))=$P(^(.13),"^",1)
127 I 'VAX(1) G CA
128 S @VAV@($P(VAS,"^",8))=$P(VAX,"^",10)
129 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+2))=VAZ_"^"_Y
130CA ;Confidential Address
131 I '$D(^DPT(DFN,.141)) G Q3
132 N VACAT,VAACT,VAACTDT,VATYP,VATYPNAM,VACAN
133 S VAX=$S($D(^DPT(DFN,.141)):^(.141),1:"")
134 S VAACTDT=$S($D(VAPA("CD")):VAPA("CD"),1:DT)
135 F I=1:1:6 S VAZ=$P(VAX,"^",I),@VAV@($P(VAS,"^",I+12))=VAZ D
136 .I I=5,$D(^DIC(5,+VAZ,0)) S VAZ=$P(^(0),"^"),@VAV@($P(VAS,"^",I+12))=@VAV@($P(VAS,"^",I+12))_"^"_VAZ Q
137 .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))
138 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
139 F I=7,8 S VAZ=$P(VAX,"^",I),Y=VAZ X:Y]"" ^DD("DD") S @VAV@($P(VAS,"^",I+13))=VAZ_"^"_Y
140 S VABEG=$P(VAX,"^",7),VAEND=$P(VAX,"^",8)
141 S @VAV@($P(VAS,"^",12))=1
142 I 'VABEG!(VABEG>VAACTDT)!(VAEND&(VAEND<VAACTDT)) S @VAV@($P(VAS,"^",12))=0
143 I $D(^DPT(DFN,.14)) D
144 .S VACAN="" F S VACAN=$O(^DPT(DFN,.14,VACAN)) Q:VACAN="" D
145 ..Q:'$D(^DPT(DFN,.14,VACAN,0))
146 ..S VATYP=$P(^DPT(DFN,.14,VACAN,0),"^",1),VAACT=$P(^DPT(DFN,.14,VACAN,0),"^",2)
147 ..S VACAT=$$GET1^DID(2.141,.01,"","POINTER","","DGERR")
148 ..S VATYPNAM="" F I=1:1 S VATYPNAM=$P(VACAT,";",I) Q:VATYPNAM="" D
149 ...I +VATYPNAM[VATYP S VATYPNAM=$P(VATYPNAM,":",2),@VAV@($P(VAS,"^",22),VATYP)=VATYP_"^"_VATYPNAM_"^"_VAACT
150Q3 K VABEG,VAEND,VAZIP4 Q
151 ;
1524 ;Other Address [OAD]
153 N VAZIP4
154 I $S('$D(VAOA("A")):1,VAOA("A")<1:1,VAOA("A")>6:1,1:0) S VAX=.21,VAOA("A")=7
155 E S VAX="."_$P("33^34^211^331^311^25","^",+VAOA("A"))
156 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)
157 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)
158 S @VAV@($P(VAS,"^",7))="",@VAV@($P(VAS,"^",8))=$P(VAX,"^",9),VAX(2)=8
159 F I=1,2 S VAX(2)=VAX(2)+1,@VAV@($P(VAS,"^",VAX(2)))=$P(VAX,"^",I)
160 I "^.311^.25"[("^"_VAX(1)_"^") S @VAV@($P(VAS,"^",10))=""
161 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)
162 S VAZIP4=$P($G(^DPT(DFN,.22)),U,VAOA("A"))
163 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))
164 Q
Note: See TracBrowser for help on using the repository browser.