source: VWGUIRegistration/trunk/VWREGITX.m

Last change on this file was 1806, checked in by Jim B., 22 months ago
File size: 12.1 KB
Line 
1VWREGITX        ;Portland,OR/Jim Bell, et al - World VistA GUI Pat Reg Utility
2        ;;2.0;WORLD VISTA;**LOCAL **;;Build 26
3        ;*****************************************************************
4        ;* Licensed under GNU 2.0 or greater - see license.txt file      *
5        ;* Program/application is for the management of input templates  *
6        ;* owned by the user (DUZ).                                      *
7        ;* REMINDER: All template fields pertain only to the Patient File*
8        ;*  (#2)!                                                        *
9        ;*****************************************************************
10        ;No fall thru
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.