source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XLFNAME.m@ 949

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

initial load of FOIAVistA 6/30/08 version
File size: 7.9 KB
Line 
1XLFNAME ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;10:12 AM 29 Jan 2003
2 ;;8.0;KERNEL;**134,211,240**;Jul 10, 1995
3 ;
4STDNAME(XUNAME,XUFLAG,XUAUD) ;Standardize name XUNAME
5 ; XUNAME - In, name to be standardized. Out, standardized name
6 ; XUFLAG - In, "C" : return components in XUNAME array
7 ; "F" : Assume input is in general form
8 ; Family,Given Middle Suffix
9 ; "G" : Don't return XUAUD("GIVEN")
10 ; "P" : Remove parenthetical text
11 ;.XUAUD - Out:
12 ; XUAUD = original name passed in
13 ; XUAUD(subsc)="" if problems
14 ;
15 N I,XUFAM,XUNM,XUOUT,XUMOV,XUREST,XUSP
16 S XUOUT=$G(XUFLAG)["C"
17 N:XUOUT XUFAMO,XURESTO
18 K XUAUD S XUAUD=XUNAME
19 ;
20 F I="FAMILY","GIVEN","MIDDLE","SUFFIX" S XUNM(I)="" S:XUOUT XUOUT(I)=""
21 S:XUNAME?.E1" TEST" XUNAME=$E(XUNAME,1,$L(XUNAME)-5)
22 ;
23 I $G(XUFLAG)["P",XUNAME?.E1(1"(",1"[",1"{").E D
24 . S XUNAME=$$PARENS^XLFNAME1(XUNAME)
25 . S:XUAUD'=XUNAME XUAUD("STRIP")=""
26 ;
27 S:XUNAME?1"EEE".E!(XUNAME?.E1" FEE")!(XUNAME?1A1"-".E) XUAUD("NOTE")=""
28 ;
29 ;If no comma, assume given name first
30 I XUNAME'[",",$G(XUFLAG)'["F" G GIVFRST
31 ;
32 ;Standardize Family
33 ;(don't remove internal spaces or convert suffixes yet)
34 I $E(XUNAME,1,3)="ST." S XUAUD("FAMILY")=""
35 S XUFAM=$$CLEANC^XLFNAME1($P(XUNAME,","),"FI",.XUAUD)
36 S XUFAM=$$PUNC(XUFAM,.XUAUD)
37 D:XUOUT
38 . S XUFAMO=$$CLEANC^XLFNAME1($P(XUNAME,","),"FO",.XUAUD)
39 . S XUFAMO=$$PUNC(XUFAMO,.XUAUD)
40 ;
41 ;Look for suffixes at end of Family
42 D SUFEND^XLFNAME1(.XUFAM,.XUFAMO,.XUNM,.XUOUT,.XUAUD)
43 S:XUNM("SUFFIX")]"" XUAUD("SUFFIX")=""
44 S XUNM("FAMILY")=XUFAM S:XUOUT XUOUT("FAMILY")=XUFAMO
45 ;
46 ;Parse rest of name
47 S XUREST=$P(XUNAME,",",2,999)
48 S XUSP=XUREST?1" "1.E
49 D:XUOUT
50 . S XURESTO=$$CLEANC^XLFNAME1(XUREST,"O",.XUAUD)
51 . S XURESTO=$$PUNC(XUREST,.XUAUD)
52 S XUREST=$$CLEANC^XLFNAME1(XUREST,"I",.XUAUD)
53 S XUREST=$$PUNC(XUREST,.XUAUD)
54 D MOVSUF(.XUREST,.XUOUT,.XURESTO,.XUAUD,.XUMOV)
55 D N2(XUREST,.XUNM,.XUOUT,$G(XURESTO),.XUAUD)
56 ;
57 ;Account for names that look like only Family and Suffix(es)
58 I XUNM("MIDDLE")="",$$CHKSUF^XLFNAME1(XUNM("GIVEN"))]"" D
59 . N XUCNT,XUSUF1,XUSUF2
60 . I 'XUSP Q:$E(XUNM("GIVEN"))'?1N
61 . S XUCNT=$L(XUNM("SUFFIX")," ")
62 . S XUSUF1=$P(XUNM("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
63 . S XUSUF2=$P(XUNM("SUFFIX")," ",1,XUCNT-XUMOV)
64 . S XUNM("SUFFIX")=$$JOIN($$JOIN(XUSUF1,$$ROMAN^XLFNAME1(XUNM("GIVEN"))),XUSUF2)
65 . S XUNM("GIVEN")=""
66 . D:XUOUT
67 .. S XUSUF1=$P(XUOUT("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
68 .. S XUSUF2=$P(XUOUT("SUFFIX")," ",1,XUCNT-XUMOV)
69 .. S XUOUT("SUFFIX")=$$JOIN($$JOIN(XUSUF1,XUOUT("GIVEN")),XUSUF2)
70 .. S XUOUT("GIVEN")=""
71 ;
72 D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
73 K:$G(XUFLAG)["G" XUAUD("GIVEN")
74 Q
75 ;
76BLDSTD(XUNAME,XUNM,XUOUT,XUAUD) ;Build standard name in XUNAME
77 ;Put components in XUNAME array
78 N I,J
79 K XUNAME M:XUOUT XUNAME=XUOUT
80 ;
81 S XUNAME=XUNM("FAMILY")_","
82 S:XUNAME[" " XUNAME=$TR(XUNAME," "),XUAUD("SPACE")=""
83 ;
84 I XUNM("GIVEN")]"" S XUNAME=XUNAME_XUNM("GIVEN")
85 E S XUAUD("GIVEN")=""
86 S:XUNM("MIDDLE")]"" XUNAME=XUNAME_" "_XUNM("MIDDLE")
87 S:XUNM("SUFFIX")]"" XUNAME=XUNAME_" "_XUNM("SUFFIX")
88 S:XUNAME?.E1"," XUNAME=$E(XUNAME,1,$L(XUNAME)-1)
89 S:XUNAME?.E1N.E XUAUD("NUMBER")=""
90 ;
91 ;Remove spaces after periods, and ~ and ^, in name components
92 I XUOUT S I="" F S I=$O(XUNAME(I)) Q:I="" D
93 . S XUNAME(I)=$TR(XUNAME(I),"`^") Q:XUNAME(I)'[". "
94 . N J S J=0 F S J=$F(XUNAME(I),". ",J) Q:'J S $E(XUNAME(I),J-1)=""
95 Q
96 ;
97GIVFRST ;Come here if name has no comma.
98 N XUCNT,XUNAM,XUNAMO
99 ;
100 ;Do initial standardizing
101 S XUNAM=$$CLEANC^XLFNAME1(XUNAME,"I",.XUAUD)
102 S XUNAM=$$PUNC(XUNAME,.XUAUD)
103 D:XUOUT
104 . S XUNAMO=$$CLEANC^XLFNAME1(XUNAME,"O",.XUAUD)
105 . S XUNAMO=$$PUNC(XUNAMO,.XUAUD)
106 ;
107 ;Look for suffixes at end
108 D SUFEND^XLFNAME1(.XUNAM,.XUNAMO,.XUNM,.XUOUT,.XUAUD)
109 S XUCNT=$L(XUNAM," ")
110 ;
111 ;If name contains only suffixes, make first suffix the Family Name
112 I XUCNT=0 D Q
113 . S XUNM("FAMILY")=$P(XUNM("SUFFIX")," ")
114 . S XUNM("SUFFIX")=$P(XUNM("SUFFIX")," ",2,999)
115 . S:$G(XUFLAG)'["G" XUAUD("GIVEN")=""
116 . D:XUOUT
117 .. S XUOUT("FAMILY")=$P(XUOUT("SUFFIX")," ")
118 .. S XUOUT("SUFFIX")=$P(XUOUT("SUFFIX")," ",2,999)
119 . D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
120 ;
121 ;Set Family and rest of name
122 S XUNM("FAMILY")=$P(XUNAM," ",XUCNT),XUREST=$P(XUNAM," ",1,XUCNT-1)
123 S:XUOUT XUOUT("FAMILY")=$P(XUNAMO," ",XUCNT),XURESTO=$P(XUNAMO," ",1,XUCNT-1)
124 ;
125 ;Process rest of name (don't look for suffixes)
126 D N2(XUREST,.XUNM,.XUOUT,$G(XURESTO),.XUAUD,"s")
127 D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
128 K:$G(XUFLAG)["G" XUAUD("GIVEN")
129 Q
130 ;
131NAMECOMP(XUNM) ;Build components from standard name
132 S XUNM("FAMILY")=$P(XUNM,",")
133 D N2($P(XUNM,",",2,999),.XUNM)
134 S XUNM("MIDDLE")=$G(XUNM("MIDDLE"))
135 S XUNM("SUFFIX")=$G(XUNM("SUFFIX"))
136 Q
137 ;
138MOVSUF(XUREST,XUOUT,XURESTO,XUAUD,XUMOV) ;Move suffixes immediately in front to the end
139 N XUI,XUCNT
140 S XUCNT=$L(XUREST," "),XUMOV=0
141 F XUI=1:1:XUCNT I $$CHKSUF1^XLFNAME1($P(XUREST," ",XUI))="" S XUI=XUI-1 Q
142 I XUI,XUI<XUCNT D
143 . S XUMOV=XUI
144 . S XUREST=$P(XUREST," ",XUI+1,999)_" "_$P(XUREST," ",1,XUI)
145 . S:XUOUT XURESTO=$P(XURESTO," ",XUI+1,999)_" "_$P(XURESTO," ",1,XUI)
146 . S XUAUD("SUFFIX")=""
147 Q
148 ;
149PUNC(XUNAME,XUAUD) ;Remove name pieces that are purely punctuation
150 N XUC,XUI,XUNEW
151 S XUNEW=""
152 F XUI=1:1:$L(XUNAME," ") D
153 . S XUC=$P(XUNAME," ",XUI)
154 . I XUC?1.P S:XUC'?1."." XUAUD("PUNC")="" Q
155 . S XUNEW=$$JOIN(XUNEW,XUC)
156 Q XUNEW
157 ;
158N2(XUREST,XUNM,XUOUT,XURESTO,XUAUD,XUFLAG) ;Build components from non-family name
159 N XUCNT,XUGIVEN,XUI,XUMIDDLE,XUSUF,XUSUFFIX,XUX,X
160 S XUOUT=$G(XUOUT) N:XUOUT XUGIVENO,XUMIDO,XUSUFO,XUXO
161 S XUCNT=$L(XUREST," ")
162 ;
163 ;Get Given from 1st space-piece, quit if only name
164 S XUNM("GIVEN")=$P(XUREST," ") S:XUOUT XUOUT("GIVEN")=$P(XURESTO," ")
165 Q:XUCNT<2
166 ;
167 S (XUSUF,XUMIDDLE,XUGIVEN)="" S:XUOUT (XUSUFO,XUMIDO,XUGIVENO)=""
168 ;
169 F XUI=XUCNT:-1:2 D
170 . S XUX=$P(XUREST," ",XUI)
171 . S:XUOUT XUXO=$P(XURESTO," ",XUI)
172 . ;
173 . ;If no middle yet, check for suffix
174 . I XUMIDDLE="",$G(XUFLAG)'["s" D Q:XUSUFFIX]""
175 .. S XUSUFFIX=""
176 .. I XUI=2,"I^V^X"[XUX S XUAUD("SUFFIX")="" Q
177 .. I XUI>2,XUX="D",$P(XUREST," ",XUI-1)="M" S XUAUD("SUFFIX")="" Q
178 .. S XUSUFFIX=$$CHKSUF^XLFNAME1(XUX) Q:XUSUFFIX=""
179 .. S X=XUSUFFIX,XUSUFFIX=$$ROMAN^XLFNAME1(XUSUFFIX)
180 .. I XUI=2,X=XUSUFFIX S XUAUD("SUFFIX")=""
181 .. S XUSUF=$$JOIN(XUSUFFIX,XUSUF)
182 .. S:XUOUT XUSUFO=$$JOIN(XUXO,XUSUFO)
183 . ;
184 . ;If not suffix, and no middle, set middle
185 . I XUMIDDLE="" S XUMIDDLE=XUX S:XUOUT XUMIDO=XUXO Q
186 . ;
187 . ;Otherwise, put in Given
188 . S:XUI=2 XUAUD("MIDDLE")=""
189 . S XUGIVEN=$$JOIN(XUX,XUGIVEN)
190 . S:XUOUT XUGIVENO=$$JOIN(XUXO,XUGIVENO)
191 ;
192 D:XUSUF]""
193 . S XUNM("SUFFIX")=$$JOIN($G(XUNM("SUFFIX")),XUSUF)
194 . S:XUOUT XUOUT("SUFFIX")=$$JOIN($G(XUOUT("SUFFIX")),XUSUFO)
195 ;
196 S XUNM("MIDDLE")=XUMIDDLE
197 S:XUOUT XUOUT("MIDDLE")=XUMIDO
198 D:"^NMI^NMN^"[(U_XUNM("MIDDLE")_U)
199 . S XUNM("MIDDLE")="" S:XUOUT XUOUT("MIDDLE")=""
200 . S XUAUD("NM")=""
201 ;
202 D:XUGIVEN]""
203 . S XUNM("GIVEN")=XUNM("GIVEN")_" "_XUGIVEN
204 . S:XUOUT XUOUT("GIVEN")=XUOUT("GIVEN")_" "_XUGIVENO
205 Q
206 ;
207JOIN(S1,S2) ;Return S1 joined with S2 (separate by a space)
208 Q $G(S1)_$E(" ",$G(S1)]""&($G(S2)]""))_$G(S2)
209 ;
210NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ;Name formatting routine
211 G NAMEFMTX^XLFNAME1
212 ;
213CLEANC(XUPART,XUFLAG,XUAUD) ;Component standardization
214 G CLEANCX^XLFNAME1
215 ;
216BLDNAME(XUNC,XUMAX) ;Build standard name from components
217 Q $$NAMEFMT(.XUNC,"F","CSL"_+$G(XUMAX))
218 ;
219HLNAME(XUNAME,XUFLAG,XUDLM) ;Convert name to HL7 format
220 N XUF
221 S XUF=$E("S",$G(XUFLAG)["S")
222 S:$G(XUFLAG)["L" XUF=XUF_"L"_+$P(XUFLAG,"L",2)
223 Q $$NAMEFMT^XLFNAME(.XUNAME,"H",XUF,$G(XUDLM))
224 ;
225FMNAME(XUNAME,XUFLAG,XUDLM) ;Convert HL7 name string to standard name or name components
226 G F^XLFNAME6
227 ;
228PRE ;Pre-install for patch XU*8.0*134
229 G PRE^XLFNAME3
230 ;
231POST ;Post-install for XU*8.0*134 (conversion)
232 G POST^XLFNAME3
233 ;
234GENERATE ;Generate information in ^XTMP about changes that will take
235 ;place when CONVERT^XLFNAME is run
236 G GENERATE^XLFNAME5
237 ;
238PRINT ;Print the information in ^XTMP
239 G PRINT^XLFNAME4
240 ;
241CONVERT ;Convert the Names in the New Person file
242 G CONVERT^XLFNAME5
Note: See TracBrowser for help on using the repository browser.