source: FOIAVistA/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m@ 635

Last change on this file since 635 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 6.8 KB
Line 
1QACVEMPX ; OAKOIFO/TKW - Return Person Data, called by RPC ;9/25/07 14:14
2 ;;2.0;Patient Representative;**19,21**;07/25/1995;Build 5
3EN(PATSBY,LKUPVAL,PATSROWS,PATSFRM0,PATSFRM1) ; Lookup Employee by Name, then
4 ; Output XML formatted data from NEW PERSON file.
5 ; PATSBY contains the name of the output array (pass by reference)
6 ; LKUPVAL is the name of the person to be matched (LAST,FIRST), or
7 ; an array of Security Keys.
8 ; PATSROWS=Number of rows to return in each call
9 ; PATSFRM0=Employee Name value from previous call (empty on first call, pass by ref)
10 ; PATSFRM1=Employee IEN from previous call (empty on first call, pass by ref)
11 K ^TMP("DILIST",$J),^TMP("PatsPersonXml",$J)
12 N STDNAME,ULASTNM,NAMECOMP,IENS,PIECE,OUTCNT,TAGLIST,FROM,PART,SRVIEN,MAILCODE,TITLE,SRVRSTA,PATSMORE,PATSERR,DIERR,I,J,X,Y
13 ; If LKUPVAL exists, it contains an employee name, find partial matches.
14 I $G(LKUPVAL)]"" D
15 . S ULASTNM=$P(LKUPVAL,",")
16 . D LOOKUP1
17 . I (ULASTNM[" ")!(ULASTNM["'") D LOOKUP2
18 . Q
19 ; Else, it contains an array of Security Key values, find all
20 ; holders of those keys.
21 I $G(LKUPVAL)="" D
22 . D EN^QACVKHLD(.LKUPVAL,PATSROWS,.PATSFRM0,.PATSFRM1)
23 . S FROM(1)=$G(PATSFRM0),FROM(2)=$G(PATSFRM1)
24 . S PATSMORE=$S(FROM(1)="":0,1:1)
25 . Q
26 I '$D(^TMP("DILIST",$J)),'$D(^TMP("DIERR",$J)) Q
27 S PATSERR="" I $D(^TMP("DIERR",$J)) S PATSERR=$G(^TMP("DIERR",$J,1,"TEXT",1))
28 ; Get Station Number of Institution where server resides (IA #1518)
29 S SRVRSTA=$$STA^XUAF4(+$$GET1^DIQ(8989.3,1,217,"I"))
30 ; Set name of output array into output parameter.
31 S PATSBY=$NA(^TMP("PatsPersonXml",$J))
32 ; Now build the output.
33 D HDR
34 S OUTCNT=2
35 D EN2(.OUTCNT),FOOTER(.OUTCNT)
36 Q
37 ;
38 ;
39LOOKUP1 ; Use current routine to standardize the name (IA #3065)
40 ; (name may contain spaces or apostrophes).
41 S STDNAME=LKUPVAL
42 I '$G(PATSROWS) S PATSROWS=10
43 S PATSMORE=0
44 I STDNAME["," S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,,,,1)
45 E S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,0,,1,1)
46 ; If we've already found all matches to current standard, get out.
47 N QOUT S QOUT=0
48 I (ULASTNM[" ")!(ULASTNM["'") D Q:QOUT
49 . S X=$P($G(PATSFRM0),",")
50 . Q:X=""
51 . I (X[" ")!(X["'") Q
52 . S QOUT=1 Q
53 ; Get list of matching names.
54 D GETLIST(STDNAME,PATSROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
55 Q
56LOOKUP2 ; Use old routine to standardize the name (no punctuation
57 ; except hyphens).)
58 ; Quit if the maximum number of names has been found.
59 Q:PATSMORE
60 ; Convert user input using old standardization routine
61 S STDNAME=LKUPVAL
62 D STDNAME^XLFNAME(.STDNAME,"FG")
63 ; Find enough names to fill the list
64 N NEWROWS
65 S NEWROWS=PATSROWS-$P($G(^TMP("DILIST",$J,0)),"^")
66 ; If list is already full, see whether there are more names
67 ; using the old standardization, then quit.
68 I NEWROWS'>0 D Q
69 . I $D(^VA(200,"B",STDNAME)) S NEWROWS=1
70 . E S X=$O(^VA(200,"B",STDNAME)) I $E(X,1,$L(STDNAME))=STDNAME S NEWROWS=1
71 . I NEWROWS=1 S PATSMORE=1,FROM(1)=STDNAME,FROM(2)=""
72 . Q
73 ; Save off names found using current name standardization.
74 K ^TMP("QACOLD",$J)
75 I $D(^TMP("DILIST",$J)) D
76 . M ^TMP("QACOLD",$J)=^TMP("DILIST",$J)
77 . K ^TMP("QACOLD",$J,0) Q
78 K ^TMP("DILIST",$J)
79 ; Get new list of matching names.
80 D GETLIST(STDNAME,NEWROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
81 ; Merge the two lists into ^TMP("DILIST",$J).
82 S I=$O(^TMP("QACOLD",$J,PATSROWS+1),-1)
83 I I D
84 . S X=$P($G(^TMP("DILIST",$J,0)),"^")
85 . I X F J=1:1:X I $D(^TMP("DILIST",$J,J,0)) S ^TMP("QACOLD",$J,(I+J),0)=^TMP("DILIST",$J,J,0) K ^TMP("DILIST",$J,J,0)
86 . M ^TMP("DILIST",$J)=^TMP("QACOLD",$J)
87 . S $P(^TMP("DILIST",$J,0),"^")=X+I
88 . K ^TMP("QACOLD",$J)
89 . Q
90 Q
91GETLIST(STDNAME,PATSROWS,PATSFRM0,PATSFRM1,PATSMORE,FROM) ; Get a list of names matching STDNAME
92 N FIRST,LAST,LEN,SCR,CURRDT
93 S LAST=$P(STDNAME,","),FIRST=$P(STDNAME,",",2,99)
94 S CURRDT=$$DT^XLFDT()
95 ; Screen out terminated users.
96 S SCR="I ($P(^(0),""^"",11)=""""!(CURRDT<$P(^(0),""^"",11)))"
97 ; If first name was passed, check for it with a screen.
98 S LEN=$L(FIRST) I LEN>0 S SCR=SCR_",$E($P($P(^(0),""^""),"","",2,99),1,"_LEN_")="_""""_FIRST_""""
99 ; Set the starting values, and partial match values.
100 I $G(PATSFRM0)="" S FROM(1)=LAST,FROM(2)=""
101 E S FROM(1)=PATSFRM0,FROM(2)=$G(PATSFRM1)
102 S PART(1)=LAST
103 ; Return list of standard name pointer, title and mail code (IA #10060)
104 D LIST^DIC(200,,"@;8;28","MP",PATSROWS,.FROM,.PART,"B",SCR)
105 ; Set flag telling whether there are more entries to fetch).
106 S PATSMORE=$S(FROM(1)="":0,1:1)
107 Q
108 ;
109HDR ; Build header node
110 S ^TMP("PatsPersonXml",$J,1)="<?xml version=""1.0"" encoding=""utf-8""?>"
111 S ^TMP("PatsPersonXml",$J,2)="<PersonDataSet hasMore="""_PATSMORE_""" patsFrom0="""_FROM(1)_""" patsFrom1="""_FROM(2)_""" vistAError="""_PATSERR_""">"
112 Q
113 ;
114EN2(OUTCNT) ; Build output for individual persons.
115 N TAGLIST,IENS,TITLE,MAILCODE,NAMECOMP,I,J,X,Y
116 ; Build list of XML tags to use in output.
117 D BLDLST(.TAGLIST)
118 ; Read through lister results and build output
119 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I S X=$G(^(I,0)) D
120 . S OUTCNT=OUTCNT+1
121 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<PatsPerson>"
122 . S IENS=$P(X,"^") Q:IENS="" S IENS=IENS_","
123 . ; NOTE: removes reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153)
124 . S TITLE=$$SYMENC^MXMLUTL($E($P(X,"^",2),1,30))
125 . S MAILCODE=$$SYMENC^MXMLUTL($E($P(X,"^",3),1,30))
126 . ; Get the individual name components and add them to the output (IA #3065)
127 . K NAMECOMP
128 . S NAMECOMP=$P($G(^VA(200,+IENS,0)),"^")
129 . ; If name contains apostrophes or spaces, use current standardization
130 . I ($P(NAMECOMP,",")["'")!($P(NAMECOMP,",")[" ") D
131 .. S NAMECOMP=$$FORMAT^XLFNAME7(.NAMECOMP,1,35,,,,,2)
132 .. S NAMECOMP=NAMECOMP("FAMILY")_"^"_NAMECOMP("GIVEN")_"^"_NAMECOMP("MIDDLE")_"^"_NAMECOMP("SUFFIX")
133 .. Q
134 . ; Else, use old standardization routine.
135 . E D
136 .. K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
137 .. S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S")
138 . F J=1:1:6 D
139 .. S OUTCNT=OUTCNT+1
140 .. S Y=$P(NAMECOMP,"^",J)
141 .. S ^TMP("PatsPersonXml",$J,OUTCNT)="<"_TAGLIST(J)_">"_Y_"</"_TAGLIST(J)_">"
142 .. Q
143 . S OUTCNT=OUTCNT+1
144 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<Title>"_TITLE_"</Title>"
145 . S OUTCNT=OUTCNT+1
146 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<MailCode>"_MAILCODE_"</MailCode>"
147 . S OUTCNT=OUTCNT+1
148 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<VistaIen>"_$P(X,"^")_"</VistaIen>"
149 . S OUTCNT=OUTCNT+1
150 . S ^TMP("PatsPersonXml",$J,OUTCNT)="</PatsPerson>"
151 . Q
152 Q
153 ;
154FOOTER(OUTCNT) ; Add the footer
155 S ^TMP("PatsPersonXml",$J,OUTCNT+1)="</PersonDataSet>"
156 K ^TMP("DILIST",$J)
157 Q
158 ;
159CONV(NAMEPART) ; Convert a name part to mixed case
160 N LEN,TEMP,UPPER,I,X
161 S LEN=$L(NAMEPART),UPPER=1,TEMP=""
162 F I=1:1:LEN S X=$E(NAMEPART,I,I) D
163 . I UPPER=1 D
164 .. I X?1L S X=$C($A(X)-32)
165 .. S UPPER=0 Q
166 . E I X?1U S X=$C($A(X)+32)
167 . S TEMP=TEMP_X
168 . I X'?1L,X'?1U S UPPER=1
169 . Q
170 Q TEMP
171 ;
172BLDLST(TAGLIST) ; Build list of XML data tags
173 S TAGLIST(1)="LastName"
174 S TAGLIST(2)="FirstName"
175 S TAGLIST(3)="MiddleName"
176 S TAGLIST(4)="NameSuffix"
177 S TAGLIST(5)="NamePrefix"
178 S TAGLIST(6)="Degree"
179 Q
180 ;
Note: See TracBrowser for help on using the repository browser.