Changeset 623 for WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (15 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/PATIENT_REPRESENTATIVE-QAC/QACVEMPX.m
r613 r623 1 QACVEMPX ; 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 3 EN(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 ; 39 LOOKUP1 ; 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 56 LOOKUP2 ; 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 91 GETLIST(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 ; 109 HDR ; 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 ; 114 EN2(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 ; 154 FOOTER(OUTCNT) ; Add the footer 155 S ^TMP("PatsPersonXml",$J,OUTCNT+1)="</PersonDataSet>" 156 K ^TMP("DILIST",$J) 157 Q 158 ; 159 CONV(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 ; 172 BLDLST(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 ; 1 QACVEMPX ; Return Person Data using Value List Handler Pattern to update Patient Advocate PatsPerson table ;5/8/06 10:36 2 ;;2.0;Patient Representative;**19**;07/25/1995;Build 55 3 EN(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) 10 ; PATSFRM1=Employee IEN from previous call (empty on first call) 11 K ^TMP("DILIST",$J),^TMP("PatsPersonXml",$J) 12 N STDNAME,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. Else, it is 14 ; an array of Security Key values and we want to find all holders 15 ; of those keys. 16 ; Standardize the name, parse out last name and first name. 17 I $G(LKUPVAL)]"" S STDNAME=LKUPVAL D BYNAME 18 I $G(LKUPVAL)="" D 19 . D EN^QACVKHLD(.LKUPVAL,PATSROWS,.PATSFRM0,.PATSFRM1) 20 . S FROM(1)=$G(PATSFRM0),FROM(2)=$G(PATSFRM1) 21 . S PATSMORE=$S(FROM(1)="":0,1:1) 22 . Q 23 I '$D(^TMP("DILIST",$J)),'$D(^TMP("DIERR",$J)) Q 24 S PATSERR="" I $D(^TMP("DIERR",$J)) S PATSERR=$G(^TMP("DIERR",$J,1,"TEXT",1)) 25 ; Get Station Number of Institution where server resides (IA #1518) 26 S SRVRSTA=$$STA^XUAF4(+$$GET1^DIQ(8989.3,1,217,"I")) 27 ; Set name of output array into output parameter. 28 S PATSBY=$NA(^TMP("PatsPersonXml",$J)) 29 ; Now build the output. 30 D HDR 31 S OUTCNT=2 32 D EN2(.OUTCNT),FOOTER(.OUTCNT) 33 Q 34 ; 35 ; 36 BYNAME ; Standardize the name, parse out last name and first name. (IA #3065) 37 D STDNAME^XLFNAME(.STDNAME,"FG") 38 N FIRST,LAST,LEN,SCR,CURRDT 39 S LAST=$P(STDNAME,","),FIRST=$P(STDNAME,",",2,99) 40 S CURRDT=$$DT^XLFDT() 41 ; Screen out terminated users. 42 S SCR="I ($P(^(0),""^"",11)=""""!(CURRDT<$P(^(0),""^"",11)))" 43 ; If first name was passed, check for it with a screen. 44 S LEN=$L(FIRST) I LEN>0 S SCR=SCR_",$E($P($P(^(0),""^""),"","",2,99),1,"_LEN_")="_""""_FIRST_"""" 45 ; Set the starting values, and partial match values. 46 I $G(PATSFRM0)="" S FROM(1)=LAST,FROM(2)="" 47 E S FROM(1)=PATSFRM0,FROM(2)=$G(PATSFRM1) 48 S PART(1)=LAST 49 I '$G(PATSROWS) S PATSROWS=10 50 ; Return list of standard name pointer, title and mail code (IA #10060) 51 D LIST^DIC(200,,"@;8;28","MP",PATSROWS,.FROM,.PART,"B",SCR) 52 ; Set flag telling whether there are more entries to fetch). 53 S PATSMORE=$S(FROM(1)="":0,1:1) 54 Q 55 ; 56 HDR ; Build header node 57 S ^TMP("PatsPersonXml",$J,1)="<?xml version=""1.0"" encoding=""utf-8""?>" 58 S ^TMP("PatsPersonXml",$J,2)="<PersonDataSet hasMore="""_PATSMORE_""" patsFrom0="""_FROM(1)_""" patsFrom1="""_FROM(2)_""" vistAError="""_PATSERR_""">" 59 Q 60 ; 61 EN2(OUTCNT) ; Build output for individual persons. 62 N TAGLIST,IENS,TITLE,MAILCODE,NAMECOMP,I,J,X,Y 63 ; Build list of XML tags to use in output. 64 D BLDLST(.TAGLIST) 65 ; Read through lister results and build output 66 F I=0:0 S I=$O(^TMP("DILIST",$J,I)) Q:'I S X=$G(^(I,0)) D 67 . S OUTCNT=OUTCNT+1 68 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<PatsPerson>" 69 . S IENS=$P(X,"^") Q:IENS="" S IENS=IENS_"," 70 . ; NOTE: does not remove reserved XML characters (see $$SYMENC^MXMLUTL, IA#4153) 71 . S TITLE=$E($P(X,"^",2),1,30) 72 . S MAILCODE=$E($P(X,"^",3),1,30) 73 . ; Get the individual name components and add them to the output (IA #3065) 74 . K NAMECOMP S NAMECOMP("FILE")=200,NAMECOMP("FIELD")=.01,NAMECOMP("IENS")=IENS 75 . S NAMECOMP=$$HLNAME^XLFNAME(.NAMECOMP,"S") 76 . F J=1:1:6 D 77 .. S OUTCNT=OUTCNT+1 78 .. S Y=$P(NAMECOMP,"^",J) 79 .. S ^TMP("PatsPersonXml",$J,OUTCNT)="<"_TAGLIST(J)_">"_Y_"</"_TAGLIST(J)_">" 80 .. Q 81 . S OUTCNT=OUTCNT+1 82 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<Title>"_TITLE_"</Title>" 83 . S OUTCNT=OUTCNT+1 84 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<MailCode>"_MAILCODE_"</MailCode>" 85 . S OUTCNT=OUTCNT+1 86 . S ^TMP("PatsPersonXml",$J,OUTCNT)="<VistaIen>"_$P(X,"^")_"</VistaIen>" 87 . S OUTCNT=OUTCNT+1 88 . S ^TMP("PatsPersonXml",$J,OUTCNT)="</PatsPerson>" 89 . Q 90 Q 91 ; 92 FOOTER(OUTCNT) ; Add the footer 93 S ^TMP("PatsPersonXml",$J,OUTCNT+1)="</PersonDataSet>" 94 K ^TMP("DILIST",$J) 95 Q 96 ; 97 CONV(NAMEPART) ; Convert a name part to mixed case 98 N LEN,TEMP,UPPER,I,X 99 S LEN=$L(NAMEPART),UPPER=1,TEMP="" 100 F I=1:1:LEN S X=$E(NAMEPART,I,I) D 101 . I UPPER=1 D 102 .. I X?1L S X=$C($A(X)-32) 103 .. S UPPER=0 Q 104 . E I X?1U S X=$C($A(X)+32) 105 . S TEMP=TEMP_X 106 . I X'?1L,X'?1U S UPPER=1 107 . Q 108 Q TEMP 109 ; 110 BLDLST(TAGLIST) ; Build list of XML data tags 111 S TAGLIST(1)="LastName" 112 S TAGLIST(2)="FirstName" 113 S TAGLIST(3)="MiddleName" 114 S TAGLIST(4)="NameSuffix" 115 S TAGLIST(5)="NamePrefix" 116 S TAGLIST(6)="Degree" 117 Q 118 ;
Note:
See TracChangeset
for help on using the changeset viewer.
