Changeset 636 for FOIAVistA/tag/r/PATIENT_REPRESENTATIVE-QAC

Timestamp:

Dec 4, 2009, 8:26:01 PM (15 years ago)

Author:

George Lilly

Message:

WorldVistAEHR overlayed on FOIAVistA

Location:

FOIAVistA/tag/r

Files:

• . (copied) (copied from FOIAVistA/trunk/r )
• PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m (modified) (5 diffs)

FOIAVistA/tag/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m

@@ -1 @@
-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
+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.
@@ -7 +7 @@
  ;         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)
+ ; 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,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.
+ 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)
@@ -37 +34 @@
  ;
  ;
-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
+BYNAME ; Standardize the name, parse out last name and first name. (IA #3065)
  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)
@@ -101 +47 @@
  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)
@@ -121 +68 @@
  . 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))
+ . ; 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=$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")
+ . 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