[628] | 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 | ;
|
---|