source: VWGUIRegistration/trunk/VWREGITX.m@ 1791

Last change on this file since 1791 was 1779, checked in by Jim B., 8 years ago
File size: 11.9 KB
RevLine 
[1779]1VWREGITX ;VWEHR/BFProd-Jim Bell, et al - World VistA GUI Pat Reg Utility
2 ;;;;;;Build 2
3 ;;1.0;WORLD VISTA;**LOCAL **;;Build 26
4 ;
5 ;This routine utility is for patient specific fields and
6 ;is used to build input templates for registration
7 ;
8 ;GNU License: See WVLIC.txt
9 ;Modified FOIA VISTA,
10 ;Copyright 2013 WorldVistA. Licensed under the terms of the GNU
11 Q
12 ;
131 ;CallerID = HRN; value is at $P($P(CALLERID,":",2),"^")
14 S HRN=$P($P(CALLERID,":",2),"^")
15 S HRN=$$HRN(HRN)
16 I HRN="" S RESULT(0)="The Health Record Number (HRN) does not exist in this database"_$C(13,10)_"Please use NAME, DOB, or PHONE#."
17 Q
18 ;
192 ;CallerID = NAME; in ^2@+CALLERID
20 K AR,ARR
21 N HRN,PHONE,DOB,N
22 S NAME=$P(CALLERID,"^",+CALLERID)
23 S XNAME=NAME F S XNAME=$O(^DPT("B",XNAME)) Q:XNAME'[NAME D
24 . S N=0 F S N=$O(^DPT("B",XNAME,N)) Q:'+N S AR($O(AR(" "),-1)+1)=N
25 I $O(AR(" "),-1)=1 D Q
26 . S DFN=AR(1)
27 . S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
28 . S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
29 . S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
30 . S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
31 S N=0 F S N=$O(AR(N)) Q:'+N S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
32 S X="ARR" F S X=$Q(@X) Q:X="" S DFN=@X D
33 . S HRN=$$HRN(DFN),HRN=$S($L(HRN):HRN,'$L(HRN):"ID-"_$P($G(^DPT(DFN,.36)),"^",3),1:"------------")
34 . S DOB=$P(^DPT(DFN,0),"^",3),DOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$E(DOB,2,3)
35 . S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE):PHONE,1:"<No entry>")
36 . S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")^"_DOB_"^"_PHONE
37 K AR,ARR
38 Q
39 ;
403 ;CallerID = DOB; in ^3@CALLERID
41 S X=$P(CALLERID,"^",+CALLERID)
42 K %DT,Y,AR
43 N HRN,PHONE,N
44 D ^%DT
45 S N=0 F S N=$O(^DPT("ADOB",Y,N)) Q:'+N S AR($O(AR(" "),-1)+1)=N_"^"_Y
46 I $O(AR(" "),-1)=1 D Q ;Only one find
47 . K RESULT
48 . S DFN=+AR(1)
49 . S HRN=$$HRN(DFN)
50 . I '$L(HRN) S HRN="ID-"_$P($G(^DPT(DFN,.36)),"^",3)
51 . I '$L(HRN) S HRN="------------"
52 . S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
53 . S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
54 K ARR S N=0 F S N=$O(AR(N)) Q:'+N S ARR($P(^DPT(+AR(N),0),"^"),N)=+AR(N)
55 S X="ARR" F S X=$Q(@X) Q:X="" S DFN=@X D
56 . S HRN=$$HRN(DFN)
57 . I '$L(HRN) S HRN=$P($G(^DPT(DFN,.36)),"^",3)_"(ID)"
58 . I '$L(HRN)!(HRN="(ID)") S HRN="------------"
59 . S PHONE=$P($G(^DPT(DFN,.131)),"^"),PHONE=$S($L(PHONE)>0:PHONE,1:"<No entry>")
60 . S RESULT($$INR)=HRN_"^"_$P(^DPT(DFN,0),"^")_"("_DFN_")"_"^"_$P(CALLERID,"^",+CALLERID)_"^"_PHONE
61 K ARR,AR
62 Q
63 ;
644 ;CallerID = PHONE; IN ^4@+CALLERID
65 S CALLERID=$TR(CALLERID,"- ()","")
66 Q
67 ;
685 ;CallerID = space-bar; IN ^2@+CALLERID
69 S X=$P(CALLERID,"^",+CALLERID)
70 S DFN=$G(^DISV(DUZ,"^DPT("))
71 I 'DFN S RESULT(0)="Patient-Client not found" Q
72 S AR(1)=DFN G 2+6 ;Direct call
73 Q
74 ;
75DE(RESULT,DATA) ;Forced hard error
76 ;W "
77 Q
78 ;
79HRN(IEN) ;Health Record #s from IHS PATIENT
80 N N,HRNIEN,I
81 S HRNIEN=""
82 Q:'$D(^AUPNPAT(IEN)) HRNIEN
83 S N=0 F I=1:1 S N=$O(^AUPNPAT(IEN,41,N)) Q:'+N S HRNIEN=HRNIEN_$P($G(^AUPNPAT(IEN,41,N,0)),"^",2)_"|"
84 I $E(HRNIEN,$L(HRNIEN))="|" S HRNIEN=$E(HRNIEN,1,$L(HRNIEN)-1)
85 Q HRNIEN
86 ;
87ALIST(RESULT,ALPHA,CALLERID) ;Alpha request from client
88 ;*****************************************************
89 ;* ALPHA_____Letter to look up *
90 ;* CALLERID__PIECE#:HRN^NAME(IEN)^DOB^PHONE look up *
91 ;* RETURN____HRN^NAME^DOB^PHONE(Field .131 in File 2)*
92 ;*****************************************************
93 I '$L(ALPHA),'+CALLERID S RESULT(0)="No Alphabetical letter or HRN,Name,DOB,Phone selection..." Q
94 S CALLERID=$$UP^XLFSTR(CALLERID) ;Upcase EVERYTHING
95 I +CALLERID G @+CALLERID
96 N X,I,ANAME,HRN,ADOB,APHONE,Y
97 K RESULT,AR,ARR
98 S X="^DPT(""B"""_","_""""_ALPHA_""")"
99 F I=1:1 S X=$Q(@X) Q:$S($L(ALPHA)>1:$P(X,"""",4)'[ALPHA,1:$E($P(X,"""",4))'=ALPHA) S AR(I)=+$P(X,",",$L(X,","))
100 S ARN=0 F S ARN=$O(AR(ARN)) Q:'+ARN D
101 . S HRN=$$HRN(ARN)
102 . S:'$L(HRN) HRN="--- "
103 . F JJ=$L(HRN):1:15 S HRN=HRN_" "
104 . S ANAME=$P(^DPT(AR(ARN),0),"^")
105 . S Y=$P(^(0),"^",3)_$S($G(^DPT(AR(ARN),540000)):^(540000),1:"")
106 . D DD^%DT S ADOB=Y
107 . S APHONE=$P($G(^DPT(AR(ARN),.13)),"^")
108 . S ARR(ANAME,ARN)=HRN_"^"_ANAME_"("_AR(ARN)_")^"_ADOB_"^"_APHONE
109 S X="ARR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
110 Q
111 ;
112PLID(IEN) ;Primary Long ID, used with or in absence of HRN.
113 Q $P($G(^DPT(IEN,.36)),"^",3)
114 ;
115INR() Q $O(RESULT(" "),-1)+1
116 ;
117
118FIXNAME ;
119 N N,X,Y,XIEN,NLENGTH,I
120 S NLENGTH=0,X="AR" F S X=$Q(@X) Q:X="" D
121 . S Y=@X,N=$P(Y,"(")_"("_+$P(Y,"(",2)_")",STR=$P(Y,")",2)
122 . S NLENGTH=$S($L(N)>NLENGTH:$L(N),1:NLENGTH)
123 . F I=NLENGTH:-1:$L(N) S N=N_" "
124 . S Y=N_" "_STR
125 . S @X=Y
126 Q
127GPL(RESULT,IDDATA) ;Partial patient lists
128 ;***********************************************
129 ;* IDDATA_____Contains Start^Stop alpha chars *
130 ;* RESULT_____Return of results *
131 ;***********************************************
132 K RESULT,AR
133 N N,DFN,SSN,DOB,START,STOP,NAME,XDOB ;; ,NL
134 ;;Get user's last patient ID
135 S DFN=$G(^DISV(DUZ,"^DPT(")) D:DFN
136 . S NAME=$P(^DPT(DFN,0),"^")
137 . ;S SSN=$P(^(0),"^",9)
138 . S HRN="HRN: "_$$HRN(DFN) ;Health record number
139 . S PLID="ID: "_$$PLID(DFN) ;Primary Long ID
140 . S DOB=$P(^(0),"^",3)
141 . S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
142 . S AR(0)=NAME_"("_DFN_")"_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
143 S START=$P(IDDATA,"^")
144 S STOP=$P(IDDATA,"^",2)
145 S STOP=STOP_"z"
146 S STOP=$E($O(^DPT("B",STOP)))
147 S STOP=$S('$L(STOP):$P(IDDATA,"^",2)_"z",1:STOP)
148 S NL=0
149 S N=START F S N=$O(^DPT("B",N)) Q:N=""!($E(N)=STOP) D
150 . S DFN=$O(^(N,0))
151 . S NAME=$P(^DPT(DFN,0),"^")_"("_DFN_")"
152 . ;S SSN=$P(^(0),"^",9),SSN=$S('$L(SSN):" ????",1:SSN)
153 . S HRN="HRN: "_$$HRN(DFN)
154 . S PLID="ID: "_$$PLID(DFN) ;Primary Long ID
155 . S DOB=$P(^DPT(DFN,0),"^",3)
156 . S XDOB=$E(DOB,4,5)_"/"_$E(DOB,6,7)_"/"_$S($E(DOB)<3:19,1:20)_$E(DOB,2,3)
157 . ;W !,$J(DFN,5)," ",$J($E(NAME,1,12),12)," ",$J(SSN,10)," ",XDOB
158 . S AR(NAME,DFN)=NAME_" "_XDOB_" "_$S($L($P(HRN,": ",2)):HRN,$L($P(PLID,": ",2)):PLID,1:"<NO ID ON FILE>")
159 . S (DFN,NAME,SSN,DOB,XDOB)=""
160 D FIXNAME
161 S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
162 K AR
163 Q
164 ;
165REJECT(FIELD,IEN,SUBDIC) ;Reject Asterisked,Amis,Computed fields,VA specific fields
166 ;This subroutine left in for possible future use
167 I $L(IEN),$D(^DIZ(64850001,IEN)) Q 1 ;VA specific data field
168 I FIELD["COMPONENT" Q 1 ;Pain in the butt!
169 I FIELD["(VA)"!(FIELD["(CIVIL)") Q 1 ;VA fields
170 I FIELD["AMIS",FIELD["SEGMENT" Q 1
171 I FIELD["ELIG VERIF" Q 1
172 I FIELD["ENCOUNTER CONVERSION" Q 1
173 I FIELD["PROGRAMMERS U" Q 1
174 I FIELD["WHO " Q 1
175 I FIELD["SC AT"!(FIELD["SC%") Q 1
176 I $E(FIELD)="*" Q 1 ;field marked for deletion
177 I FIELD["10-10" Q 1
178 I $L(IEN),$E($P($G(^DD(2,IEN,0)),"^",2))="C" Q 1 ;computed field
179 I $L($G(SUBDIC)),$E($P($G(^DD(SUBDIC,IEN,0)),"^",2))="C" Q 1 ;computet in sub-dic
180 Q 0 ;Passed
181 ;
182LF(RESULT,FTYPE) ;List of assumed civilian type fields from
183 ; Patient file(#2)
184 ;*******************************************************************
185 ;*The author (me) arbitarily selected fields from the patient file *
186 ;* that he (me) considers to be usable by civilian VistA/CPRS users*
187 ;* the field count is 284 out of the 700+ fields available in the *
188 ;* full patient DD. File is located at ^DIZ(64850002, *
189 ;*******************************************************************
190 ;
191 S FTYPE=$TR(FTYPE,"*&^%$#@!:;>?/., ","") ;TMenuItem inclusions/jeb
192 ;S:$L(FTYPE) FTYPE=$P(^DIZ(64850003,+$P(FTYPE,"(",2),0),"^")
193 S FTYPE=$$UP^XLFSTR(FTYPE)
194 K RESULT
195 N N,X,FIELD,FLDNO,FGRP,M,MX,MF,MFNO,MFGP,MN
196 G FG:$L(FTYPE)
197 ; Add patient file fields
198 S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N D
199 . S X=^(N,0)
200 . S FIELD=$P(X,"^")
201 . S FLDNO=$P(X,"^",2)
202 . S FGRP=$P(X,"^",3)
203 . S RESULT($$INR)=FIELD_"("_FLDNO_")"_":"_FGRP
204 . I $O(^DIZ(64850002,N,"M",0)) D
205 .. S M=0 F S M=$O(^DIZ(64850002,N,"M",M)) Q:'+M D
206 ... S MX=^(M,0)
207 ... S MF=$P(MX,"^")
208 ... S MFNO=$P(MX,"^",2)
209 ... S MFGP=$P(MX,"^",3)
210 ... S RESULT($$INR)=" SF "_MF_"("_MFNO_")"_":"_MFGP
211 S X="RESULT" F I=1:1 S X=$Q(@X) Q:X=""
212 S RESULT(0)="Field count: "_(I-1)
213 Q
214 ;
215FG ;Fields by GROUP
216 Q:'$L(FTYPE)
217 K RESULT,AHF N LABEL,F,N,I
218 S N=$S(+$P(FTYPE,"(",2):+$P(FTYPE,"(",2),1:$O(^DIZ(64850003,"B",FTYPE,0)))
219 I 'N S RESULT($$INR)="Group not found." G FGX
220 S F=0 F I=1:1 S F=$O(^DIZ(64850003,N,"F","B",F)) Q:'+F S RESULT($$INR)=$P(^DD(2,F,0),"^")_"("_F_")"
221FGX Q
222 ;
223FGNA(RESULT,KIND) ;Fields by sort designator
224 ;**********************************
225 ;* KIND *
226 ;* G____Group,Field *
227 ;* N____Field# *
228 ;* A____Alphabetical (Default) *
229 ;* RESULT__Returned array *
230 ;**********************************
231 K RESULT
232 I KIND="G" D G FGNAX
233 . K AR
234 . S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
235 .. S GRP=$P(X,"^",3)
236 .. S FN=$P(X,"^",2)
237 .. S FIELD=$P(X,"^")
238 .. S AR(GRP,FN)=FIELD_"("_FN_")"
239 .. I $O(^DIZ(64850002,N,"M",0)) D
240 ... S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
241 .... S MX=^(MN,0)
242 .... S MFN=+$P(MX,"^",2)
243 .... S MFLD=$P(MX,"^")
244 .... S AR(GRP,FN,MFN)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
245 . S G="" F S G=$O(AR(G)) Q:G="" S RESULT($$INR)="--- "_G_" ---" D
246 .. S FN=0 F S FN=$O(AR(G,FN)) Q:'+FN S X=AR(G,FN),RESULT($$INR)=$P(X,"^") I $O(AR(G,FN,0)) S SFN=0 F S SFN=$O(AR(G,FN,SFN)) Q:'+SFN S RESULT($$INR)=AR(G,FN,SFN)
247 I KIND="N" D G FGNAX
248 . K AR,RESULT
249 . S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
250 .. S GRP=$P(X,"^",3)
251 .. S FN=$P(X,"^",2)
252 .. S FIELD=$P(X,"^")
253 .. S AR(FN)=FIELD_"("_FN_")"
254 .. I $O(^DIZ(64850002,N,"M",0)) D
255 ... S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
256 .... S MX=^(MN,0)
257 .... S MFN=+$P(MX,"^",2)
258 .... S MFLD=$P(MX,"^")
259 .... S AR(FN,MFN)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
260 . S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
261 ;Kind = alphabetical
262 S N=0 F S N=$O(^DIZ(64850002,N)) Q:'+N S X=^(N,0) D
263 . S AR($P(X,"^"))=$P(X,"^")_"("_$P(X,"^",2)_")"
264 . I $O(^DIZ(64850002,N,"M",0)) D
265 .. S MN=0 F S MN=$O(^DIZ(64850002,N,"M",MN)) Q:'+MN D
266 ... S MX=^(MN,0)
267 ... S MFN=+$P(MX,"^",2)
268 ... S MFLD=$P(MX,"^")
269 ... S AR($P(X,"^"),MFLD)=" SF "_$P(MX,"^")_"("_$P(MX,"^",2)_")"
270 S X="AR" F S X=$Q(@X) Q:X="" S RESULT($$INR)=@X
271FGNAX ;K AR
272 Q
273 ;
274RETGRP(RESULT) ;Return Group IDs
275 K RESULT
276 S N=0 F S N=$O(^DIZ(64850003,N)) Q:'+N S RESULT($$INR)=$P(^(N,0),"^",2)_"("_N_")"
277 Q
278 ;
279AHF(RESULT,AHF) ;Ad hoc field selection "Finished" pressed/jeb
280 ;*****************************************************
281 ;* AFH ARRAY: *
282 ;* AHF(0)____DFN *
283 ;* AHF ARRAY_FIELD(NO) OR FIELD(NO;SUB-DIC) *
284 ;*****************************************************
285 ;W " ;the END
286 K ^DIZ("AHF") M ^DIZ("AHF")=AHF
287 K RESULT
288 N FIELD,FNO,DFNDR
289 S DFNDR=""
290 S DFN=+AHF(0) K AHF(0)
291 S X="AHF" F S X=$Q(@X) Q:X="" S Y=@X D
292 . S FIELD=$P(Y,"(")
293 . S FNO=+$P(Y,"(",2)
294 . D GFA(FNO)
295 . S RESULT($$INR)=FIELD_"^"_FNO_"^^"_FHELP_"^"_FPSC_"^"_$$MF(FNO)
296 . S DFNDR=DFNDR_FNO_";"
297 I DFN D
298 . K AR N N,Y,F
299 . D GETS^DIQ(2,DFN_",",DFNDR,"E","AR","ERR")
300 . S X="AR" F S X=$Q(@X) Q:X="" D
301 .. S Y=@X
302 .. S F=+$P(X,",",$L(X,",")-1)
303 .. S N=0 F S N=$O(RESULT(N)) Q:'+N I $P(RESULT(N),"^",2)=F S $P(RESULT(N),"^",3)=Y
304 ;ToDo: write fill in for the multiple fields
305 K FHELP,FPSC
306 Q
307 ;
308GFA(FNO) ;Get field attributes at piece3 and help
309 S (FHELP,FPSC)=""
310 S FHELP=$G(^DD(2,FNO,3))
311 I FNO'=27.02 S N=0 F S N=$O(^DD(2,FNO,21,N)) Q:'+N S FHELP=FHELP_^(N,0)
312 S FHELP=$TR(FHELP,"'","`")
313 S FPSC=$P(^DD(2,FNO,0),"^",3)
314 Q
315 ;
316MF(X) ;Check for multiple field
317 ;*****************************************************
318 ;* Reminder: This data set is Patient file only (#2) *
319 ;* MYESNO____=1 is a parent *
320 ;* =0 is a primary field *
321 ;*****************************************************
322 ;
323 S MYESNO=$S(+$P(^DD(2,X,0),"^",2):1,1:0)
324 Q MYESNO
325 ;
326
Note: See TracBrowser for help on using the repository browser.