Index: WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m
===================================================================
--- WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m	(revision 613)
+++ WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m	(revision 623)
@@ -1,180 +1,118 @@
-QACVEMPX	; OAKOIFO/TKW - Return Person Data, called by RPC ;9/25/07  14:14
-	;;2.0;Patient Representative;**19,21**;07/25/1995;Build 5
-EN(PATSBY,LKUPVAL,PATSROWS,PATSFRM0,PATSFRM1)	       ; Lookup Employee by Name, then
-	; Output XML formatted data from NEW PERSON file.
-	; PATSBY contains the name of the output array (pass by reference)
-	; LKUPVAL is the name of the person to be matched (LAST,FIRST), or
-	;         an array of Security Keys.
-	; PATSROWS=Number of rows to return in each call
-	; PATSFRM0=Employee Name value from previous call (empty on first call, pass by ref)
-	; PATSFRM1=Employee IEN from previous call (empty on first call, pass by ref)
-	K ^TMP("DILIST",$J),^TMP("PatsPersonXml",$J)
-	N STDNAME,ULASTNM,NAMECOMP,IENS,PIECE,OUTCNT,TAGLIST,FROM,PART,SRVIEN,MAILCODE,TITLE,SRVRSTA,PATSMORE,PATSERR,DIERR,I,J,X,Y
-	; If LKUPVAL exists, it contains an employee name, find partial matches.
-	I $G(LKUPVAL)]"" D
-	. S ULASTNM=$P(LKUPVAL,",")
-	. D LOOKUP1
-	. I (ULASTNM[" ")!(ULASTNM["'") D LOOKUP2
-	. Q
-	; Else, it contains an array of Security Key values, find all
-	; holders of those keys.
-	I $G(LKUPVAL)="" D
-	. D EN^QACVKHLD(.LKUPVAL,PATSROWS,.PATSFRM0,.PATSFRM1)
-	. S FROM(1)=$G(PATSFRM0),FROM(2)=$G(PATSFRM1)
-	. S PATSMORE=$S(FROM(1)="":0,1:1)
-	. Q
-	I '$D(^TMP("DILIST",$J)),'$D(^TMP("DIERR",$J)) Q
-	S PATSERR="" I $D(^TMP("DIERR",$J)) S PATSERR=$G(^TMP("DIERR",$J,1,"TEXT",1))
-	; Get Station Number of Institution where server resides (IA #1518)
-	S SRVRSTA=$$STA^XUAF4(+$$GET1^DIQ(8989.3,1,217,"I"))
-	; Set name of output array into output parameter.
-	S PATSBY=$NA(^TMP("PatsPersonXml",$J))
-	; Now build the output.
-	D HDR
-	S OUTCNT=2
-	D EN2(.OUTCNT),FOOTER(.OUTCNT)
-	Q
-	;
-	;
-LOOKUP1	; Use current routine to standardize the name (IA #3065)
-	; (name may contain spaces or apostrophes).
-	S STDNAME=LKUPVAL
-	I '$G(PATSROWS) S PATSROWS=10
-	S PATSMORE=0
-	I STDNAME["," S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,,,,1)
-	E  S STDNAME=$$FORMAT^XLFNAME7(.STDNAME,1,35,,0,,1,1)
-	; If we've already found all matches to current standard, get out.
-	N QOUT S QOUT=0
-	I (ULASTNM[" ")!(ULASTNM["'") D  Q:QOUT
-	. S X=$P($G(PATSFRM0),",")
-	. Q:X=""
-	. I (X[" ")!(X["'") Q
-	. S QOUT=1 Q
-	; Get list of matching names.
-	D GETLIST(STDNAME,PATSROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
-	Q
-LOOKUP2	; Use old routine to standardize the name (no punctuation
-	; except hyphens).)
-	; Quit if the maximum number of names has been found.
-	Q:PATSMORE
-	; Convert user input using old standardization routine
-	S STDNAME=LKUPVAL
-	D STDNAME^XLFNAME(.STDNAME,"FG")
-	; Find enough names to fill the list
-	N NEWROWS
-	S NEWROWS=PATSROWS-$P($G(^TMP("DILIST",$J,0)),"^")
-	; If list is already full, see whether there are more names
-	; using the old standardization, then quit.
-	I NEWROWS'>0 D  Q
-	. I $D(^VA(200,"B",STDNAME)) S NEWROWS=1
-	. E  S X=$O(^VA(200,"B",STDNAME)) I $E(X,1,$L(STDNAME))=STDNAME S NEWROWS=1
-	. I NEWROWS=1 S PATSMORE=1,FROM(1)=STDNAME,FROM(2)=""
-	. Q
-	; Save off names found using current name standardization.
-	K ^TMP("QACOLD",$J)
-	I $D(^TMP("DILIST",$J)) D
-	. M ^TMP("QACOLD",$J)=^TMP("DILIST",$J)
-	. K ^TMP("QACOLD",$J,0) Q
-	K ^TMP("DILIST",$J)
-	; Get new list of matching names.
-	D GETLIST(STDNAME,NEWROWS,.PATSFRM0,.PATSFRM1,.PATSMORE,.FROM)
-	; Merge the two lists into ^TMP("DILIST",$J).
-	S I=$O(^TMP("QACOLD",$J,PATSROWS+1),-1)
-	I I D
-	. S X=$P($G(^TMP("DILIST",$J,0)),"^")
-	. 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)
-	. M ^TMP("DILIST",$J)=^TMP("QACOLD",$J)
-	. S $P(^TMP("DILIST",$J,0),"^")=X+I
-	. K ^TMP("QACOLD",$J)
-	. Q
-	Q 
-GETLIST(STDNAME,PATSROWS,PATSFRM0,PATSFRM1,PATSMORE,FROM)	; Get a list of names matching STDNAME
-	N FIRST,LAST,LEN,SCR,CURRDT
-	S LAST=$P(STDNAME,","),FIRST=$P(STDNAME,",",2,99)
-	S CURRDT=$$DT^XLFDT()
-	; Screen out terminated users.
-	S SCR="I ($P(^(0),""^"",11)=""""!(CURRDT<$P(^(0),""^"",11)))"
-	; If first name was passed, check for it with a screen.
-	S LEN=$L(FIRST) I LEN>0 S SCR=SCR_",$E($P($P(^(0),""^""),"","",2,99),1,"_LEN_")="_""""_FIRST_""""
-	; Set the starting values, and partial match values.
-	I $G(PATSFRM0)="" S FROM(1)=LAST,FROM(2)=""
-	E  S FROM(1)=PATSFRM0,FROM(2)=$G(PATSFRM1)
-	S PART(1)=LAST
-	; Return list of standard name pointer, title and mail code (IA #10060)
-	D LIST^DIC(200,,"@;8;28","MP",PATSROWS,.FROM,.PART,"B",SCR)
-	; Set flag telling whether there are more entries to fetch).
-	S PATSMORE=$S(FROM(1)="":0,1:1)
-	Q
-	;
-HDR	; Build header node
-	S ^TMP("PatsPersonXml",$J,1)="<?xml version=""1.0"" encoding=""utf-8""?>"
-	S ^TMP("PatsPersonXml",$J,2)="<PersonDataSet hasMore="""_PATSMORE_""" patsFrom0="""_FROM(1)_""" patsFrom1="""_FROM(2)_""" vistAError="""_PATSERR_""">"
-	Q
-	;
-EN2(OUTCNT)	; Build output for individual persons.
-	N TAGLIST,IENS,TITLE,MAILCODE,NAMECOMP,I,J,X,Y
-	; Build list of XML tags to use in output.
-	D BLDLST(.TAGLIST)
-	; Read through lister results and build output
-	F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  S X=$G(^(I,0)) D
-	. S OUTCNT=OUTCNT+1
-	. S ^TMP("PatsPersonXml",$J,OUTCNT)="<PatsPerson>"
-	. S IENS=$P(X,"^") Q:IENS=""  S IENS=IENS_","
-	. ; NOTE: removes reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153)
-	. S TITLE=$$SYMENC^MXMLUTL($E($P(X,"^",2),1,30))
-	. S MAILCODE=$$SYMENC^MXMLUTL($E($P(X,"^",3),1,30))
-	. ; Get the individual name components and add them to the output (IA #3065)
-	. K NAMECOMP
-	. S NAMECOMP=$P($G(^VA(200,+IENS,0)),"^")
-	. ; If name contains apostrophes or spaces, use current standardization
-	. I ($P(NAMECOMP,",")["'")!($P(NAMECOMP,",")[" ") D
-	.. S NAMECOMP=$$FORMAT^XLFNAME7(.NAMECOMP,1,35,,,,,2)
-	.. S NAMECOMP=NAMECOMP("FAMILY")_"^"_NAMECOMP("GIVEN")_"^"_NAMECOMP("MIDDLE")_"^"_NAMECOMP("SUFFIX")
-	.. Q
-	. ; Else, use old standardization routine.
-	. E  D
-	.. K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
-	.. S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S")
-	. F J=1:1:6 D
-	.. S OUTCNT=OUTCNT+1
-	.. S Y=$P(NAMECOMP,"^",J)
-	.. S ^TMP("PatsPersonXml",$J,OUTCNT)="<"_TAGLIST(J)_">"_Y_"</"_TAGLIST(J)_">"
-	.. Q
-	. S OUTCNT=OUTCNT+1
-	. S ^TMP("PatsPersonXml",$J,OUTCNT)="<Title>"_TITLE_"</Title>"
-	. S OUTCNT=OUTCNT+1
-	. S ^TMP("PatsPersonXml",$J,OUTCNT)="<MailCode>"_MAILCODE_"</MailCode>"
-	. S OUTCNT=OUTCNT+1
-	. S ^TMP("PatsPersonXml",$J,OUTCNT)="<VistaIen>"_$P(X,"^")_"</VistaIen>"
-	. S OUTCNT=OUTCNT+1
-	. S ^TMP("PatsPersonXml",$J,OUTCNT)="</PatsPerson>"
-	. Q
-	Q
-	;
-FOOTER(OUTCNT)	; Add the footer
-	S ^TMP("PatsPersonXml",$J,OUTCNT+1)="</PersonDataSet>"
-	K ^TMP("DILIST",$J)
-	Q
-	;
-CONV(NAMEPART)	; Convert a name part to mixed case
-	N LEN,TEMP,UPPER,I,X
-	S LEN=$L(NAMEPART),UPPER=1,TEMP=""
-	F I=1:1:LEN S X=$E(NAMEPART,I,I) D
-	. I UPPER=1 D
-	.. I X?1L S X=$C($A(X)-32)
-	.. S UPPER=0 Q
-	. E  I X?1U S X=$C($A(X)+32)
-	. S TEMP=TEMP_X
-	. I X'?1L,X'?1U S UPPER=1
-	. Q
-	Q TEMP
-	;
-BLDLST(TAGLIST)	; Build list of XML data tags
-	S TAGLIST(1)="LastName"
-	S TAGLIST(2)="FirstName"
-	S TAGLIST(3)="MiddleName"
-	S TAGLIST(4)="NameSuffix"
-	S TAGLIST(5)="NamePrefix"
-	S TAGLIST(6)="Degree"
-	Q
-	;
+QACVEMPX ; Return Person Data using Value List Handler Pattern to update Patient Advocate PatsPerson table ;5/8/06  10:36
+ ;;2.0;Patient Representative;**19**;07/25/1995;Build 55
+EN(PATSBY,LKUPVAL,PATSROWS,PATSFRM0,PATSFRM1)        ; Lookup Employee by Name, then
+ ; Output XML formatted data from NEW PERSON file.
+ ; PATSBY contains the name of the output array (pass by reference)
+ ; LKUPVAL is the name of the person to be matched (LAST,FIRST), or
+ ;         an array of Security Keys.
+ ; PATSROWS=Number of rows to return in each call
+ ; PATSFRM0=Employee Name value from previous call (empty on first call)
+ ; PATSFRM1=Employee IEN from previous call (empty on first call)
+ K ^TMP("DILIST",$J),^TMP("PatsPersonXml",$J)
+ N STDNAME,NAMECOMP,IENS,PIECE,OUTCNT,TAGLIST,FROM,PART,SRVIEN,MAILCODE,TITLE,SRVRSTA,PATSMORE,PATSERR,DIERR,I,J,X,Y
+ ; If LKUPVAL exists, it contains an employee name. Else, it is
+ ;  an array of Security Key values and we want to find all holders
+ ;  of those keys.
+ ; Standardize the name, parse out last name and first name.
+ I $G(LKUPVAL)]"" S STDNAME=LKUPVAL D BYNAME
+ I $G(LKUPVAL)="" D
+ . D EN^QACVKHLD(.LKUPVAL,PATSROWS,.PATSFRM0,.PATSFRM1)
+ . S FROM(1)=$G(PATSFRM0),FROM(2)=$G(PATSFRM1)
+ . S PATSMORE=$S(FROM(1)="":0,1:1)
+ . Q
+ I '$D(^TMP("DILIST",$J)),'$D(^TMP("DIERR",$J)) Q
+ S PATSERR="" I $D(^TMP("DIERR",$J)) S PATSERR=$G(^TMP("DIERR",$J,1,"TEXT",1))
+ ; Get Station Number of Institution where server resides (IA #1518)
+ S SRVRSTA=$$STA^XUAF4(+$$GET1^DIQ(8989.3,1,217,"I"))
+ ; Set name of output array into output parameter.
+ S PATSBY=$NA(^TMP("PatsPersonXml",$J))
+ ; Now build the output.
+ D HDR
+ S OUTCNT=2
+ D EN2(.OUTCNT),FOOTER(.OUTCNT)
+ Q
+ ;
+ ;
+BYNAME ; Standardize the name, parse out last name and first name. (IA #3065)
+ D STDNAME^XLFNAME(.STDNAME,"FG")
+ N FIRST,LAST,LEN,SCR,CURRDT
+ S LAST=$P(STDNAME,","),FIRST=$P(STDNAME,",",2,99)
+ S CURRDT=$$DT^XLFDT()
+ ; Screen out terminated users.
+ S SCR="I ($P(^(0),""^"",11)=""""!(CURRDT<$P(^(0),""^"",11)))"
+ ; If first name was passed, check for it with a screen.
+ S LEN=$L(FIRST) I LEN>0 S SCR=SCR_",$E($P($P(^(0),""^""),"","",2,99),1,"_LEN_")="_""""_FIRST_""""
+ ; Set the starting values, and partial match values.
+ I $G(PATSFRM0)="" S FROM(1)=LAST,FROM(2)=""
+ E  S FROM(1)=PATSFRM0,FROM(2)=$G(PATSFRM1)
+ S PART(1)=LAST
+ I '$G(PATSROWS) S PATSROWS=10
+ ; Return list of standard name pointer, title and mail code (IA #10060)
+ D LIST^DIC(200,,"@;8;28","MP",PATSROWS,.FROM,.PART,"B",SCR)
+ ; Set flag telling whether there are more entries to fetch).
+ S PATSMORE=$S(FROM(1)="":0,1:1)
+ Q
+ ;
+HDR ; Build header node
+ S ^TMP("PatsPersonXml",$J,1)="<?xml version=""1.0"" encoding=""utf-8""?>"
+ S ^TMP("PatsPersonXml",$J,2)="<PersonDataSet hasMore="""_PATSMORE_""" patsFrom0="""_FROM(1)_""" patsFrom1="""_FROM(2)_""" vistAError="""_PATSERR_""">"
+ Q
+ ;
+EN2(OUTCNT) ; Build output for individual persons.
+ N TAGLIST,IENS,TITLE,MAILCODE,NAMECOMP,I,J,X,Y
+ ; Build list of XML tags to use in output.
+ D BLDLST(.TAGLIST)
+ ; Read through lister results and build output
+ F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I  S X=$G(^(I,0)) D
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("PatsPersonXml",$J,OUTCNT)="<PatsPerson>"
+ . S IENS=$P(X,"^") Q:IENS=""  S IENS=IENS_","
+ . ; NOTE: does not remove reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153)
+ . S TITLE=$E($P(X,"^",2),1,30)
+ . S MAILCODE=$E($P(X,"^",3),1,30)
+ . ; Get the individual name components and add them to the output (IA #3065)
+ . K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS
+ . S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S")
+ . F J=1:1:6 D
+ .. S OUTCNT=OUTCNT+1
+ .. S Y=$P(NAMECOMP,"^",J)
+ .. S ^TMP("PatsPersonXml",$J,OUTCNT)="<"_TAGLIST(J)_">"_Y_"</"_TAGLIST(J)_">"
+ .. Q
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("PatsPersonXml",$J,OUTCNT)="<Title>"_TITLE_"</Title>"
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("PatsPersonXml",$J,OUTCNT)="<MailCode>"_MAILCODE_"</MailCode>"
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("PatsPersonXml",$J,OUTCNT)="<VistaIen>"_$P(X,"^")_"</VistaIen>"
+ . S OUTCNT=OUTCNT+1
+ . S ^TMP("PatsPersonXml",$J,OUTCNT)="</PatsPerson>"
+ . Q
+ Q
+ ;
+FOOTER(OUTCNT) ; Add the footer
+ S ^TMP("PatsPersonXml",$J,OUTCNT+1)="</PersonDataSet>"
+ K ^TMP("DILIST",$J)
+ Q
+ ;
+CONV(NAMEPART) ; Convert a name part to mixed case
+ N LEN,TEMP,UPPER,I,X
+ S LEN=$L(NAMEPART),UPPER=1,TEMP=""
+ F I=1:1:LEN S X=$E(NAMEPART,I,I) D
+ . I UPPER=1 D
+ .. I X?1L S X=$C($A(X)-32)
+ .. S UPPER=0 Q
+ . E  I X?1U S X=$C($A(X)+32)
+ . S TEMP=TEMP_X
+ . I X'?1L,X'?1U S UPPER=1
+ . Q
+ Q TEMP
+ ;
+BLDLST(TAGLIST) ; Build list of XML data tags
+ S TAGLIST(1)="LastName"
+ S TAGLIST(2)="FirstName"
+ S TAGLIST(3)="MiddleName"
+ S TAGLIST(4)="NameSuffix"
+ S TAGLIST(5)="NamePrefix"
+ S TAGLIST(6)="Degree"
+ Q
+ ;