| 1 | XLFNAME1 ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;9:25 AM 29 Jan 2003
|
|---|
| 2 | ;;8.0;KERNEL;**134,240**;Jul 10, 1995
|
|---|
| 3 | ;
|
|---|
| 4 | REMDBL(X,S) ;For each char in S, remove double chars
|
|---|
| 5 | N I,J
|
|---|
| 6 | F I=1:1:$L(S) S C=$E(S,I) D
|
|---|
| 7 | . F S J=$F(X,C_C) Q:'J S $E(X,J-1)=""
|
|---|
| 8 | Q X
|
|---|
| 9 | ;
|
|---|
| 10 | REMBE(X,S) ;Remove each char in S from the beg and end of X
|
|---|
| 11 | N I
|
|---|
| 12 | F I=1:1:$L(X) Q:S'[$E(X,I)
|
|---|
| 13 | S X=$E(X,I,999)
|
|---|
| 14 | F I=$L(X):-1:1 Q:S'[$E(X,I)
|
|---|
| 15 | S X=$E(X,1,I)
|
|---|
| 16 | Q X
|
|---|
| 17 | ;
|
|---|
| 18 | ROMAN(X) ; Replace numeric suffixes to Roman Numeral equivalents
|
|---|
| 19 | Q:X'?.E1.N.E X
|
|---|
| 20 | N IN,OUT
|
|---|
| 21 | ;
|
|---|
| 22 | S IN="^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"
|
|---|
| 23 | S OUT="I^II^III^IV^V^VI^VII^VIII^IX^X"
|
|---|
| 24 | S:IN[(U_X_U) X=$P(OUT,U,$L($P(IN,U_X_U),U))
|
|---|
| 25 | Q X
|
|---|
| 26 | ;
|
|---|
| 27 | CHKSUF(X) ;Return X if it looks like a suffix; otherwise, return null
|
|---|
| 28 | N V
|
|---|
| 29 | Q:"^I^II^III^IV^V^VI^VII^VIII^IX^X^JR^SR^DR^MD^ESQ^DDS^RN^"[(U_X_U) X
|
|---|
| 30 | Q:"^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U) X
|
|---|
| 31 | I $L(X)>1,X'[" ",X'="NMN" D I V="" S XUAUD("SUFFIX")="" Q X
|
|---|
| 32 | . F V="A","E","I","O","U","Y","" Q:X[V
|
|---|
| 33 | Q ""
|
|---|
| 34 | ;
|
|---|
| 35 | CHKSUF1(X) ; Return X if it looks like a suffix, but not I, V, X
|
|---|
| 36 | N V
|
|---|
| 37 | Q:"^II^III^IV^VI^VII^VIII^IX^JR^SR^DR^MD^ESQ^DDS^RN^"[(U_X_U) X
|
|---|
| 38 | Q:"^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U) X
|
|---|
| 39 | Q ""
|
|---|
| 40 | ;
|
|---|
| 41 | PERIOD(X) ; Change X so that there is a space after every period
|
|---|
| 42 | Q:X'["." X
|
|---|
| 43 | N I
|
|---|
| 44 | S I=0 F S I=$F(X,".",I) Q:'I!(I'<$L(X)) D
|
|---|
| 45 | . S:$E(X,I)'=" " X=$E(X,1,I-1)_" "_$E(X,I,999)
|
|---|
| 46 | Q X
|
|---|
| 47 | ;
|
|---|
| 48 | PARENS(X) ;Strip parenthetical part(s) from X
|
|---|
| 49 | N C,DONE,LEV,P,P1,P2
|
|---|
| 50 | F Q:X'?.E1(1"(",1"[",1"{").E D Q:'P2
|
|---|
| 51 | . S (DONE,LEV,P1,P2)=0
|
|---|
| 52 | . F P=1:1:$L(X) D Q:DONE
|
|---|
| 53 | .. S C=$E(X,P)
|
|---|
| 54 | .. I C?1(1"(",1"[",1"{") S:'LEV P1=P S LEV=LEV+1
|
|---|
| 55 | .. E I P1,C?1(1")",1"]",1"}") S P2=P,LEV=LEV-1 S:'LEV DONE=1
|
|---|
| 56 | . S:P2 X=$E(X,1,P1-1)_$E(X,P2+1,999)
|
|---|
| 57 | Q X
|
|---|
| 58 | ;
|
|---|
| 59 | SUFEND(XUN,XUNO,XUNM,XUOUT,XUAUD) ;Look for suffixes at end of XUN
|
|---|
| 60 | ;Put in XUNM("SUFFIX")
|
|---|
| 61 | ;Remove those suffixes from XUN and XUNO
|
|---|
| 62 | N XUI,XUSUF,XUSUFO,XUSUFFIX,XUX
|
|---|
| 63 | S XUSUF="" S:XUOUT XUSUFO=""
|
|---|
| 64 | ;
|
|---|
| 65 | F XUI=$L(XUN," "):-1:2 D Q:XUSUFFIX=""
|
|---|
| 66 | . S XUX=$P(XUN," ",XUI)
|
|---|
| 67 | . S XUSUFFIX=$$CHKSUF(XUX) Q:XUSUFFIX=""
|
|---|
| 68 | . S XUSUF=$$JOIN($$ROMAN(XUSUFFIX),XUSUF)
|
|---|
| 69 | . S XUN=$P(XUN," ",1,XUI-1)
|
|---|
| 70 | . D:XUOUT
|
|---|
| 71 | .. S XUSUFO=$P(XUNO," ",XUI)_$E(" ",XUSUFO]"")_XUSUFO
|
|---|
| 72 | .. S XUNO=$P(XUNO," ",1,XUI-1)
|
|---|
| 73 | ;
|
|---|
| 74 | I XUSUF]"" S XUNM("SUFFIX")=XUSUF S:XUOUT XUOUT("SUFFIX")=XUSUFO
|
|---|
| 75 | Q
|
|---|
| 76 | ;
|
|---|
| 77 | CLEANC(XUPART,XUFLAG,XUAUD) ; Component standardization
|
|---|
| 78 | CLEANCX ; Entry point from CLEANC^XLFNAME
|
|---|
| 79 | Q:$G(XUPART)="" ""
|
|---|
| 80 | N XUX,I
|
|---|
| 81 | S XUFLAG=$G(XUFLAG)
|
|---|
| 82 | ;
|
|---|
| 83 | S:XUPART?.E1.L.E XUPART=$$UP^XLFSTR(XUPART)
|
|---|
| 84 | ;
|
|---|
| 85 | S XUX=$S(XUFLAG["F":"-",1:" ")
|
|---|
| 86 | S I=XUPART,XUPART=$TR(XUPART,",:;",XUX_XUX_XUX)
|
|---|
| 87 | S:XUPART'=I XUAUD("PUNC")=""
|
|---|
| 88 | ;
|
|---|
| 89 | Q:XUFLAG["O" $$REMBE($$REMDBL($$PERIOD(XUPART),"- "),"- ")
|
|---|
| 90 | ;
|
|---|
| 91 | I XUPART["." S XUPART=$TR(XUPART,"."," "),XUAUD("PERIOD")=""
|
|---|
| 92 | ;
|
|---|
| 93 | I XUFLAG'["I" D
|
|---|
| 94 | . F I=1:1:$L(XUPART," ") S $P(XUPART," ",I)=$$ROMAN($P(XUPART," ",I))
|
|---|
| 95 | . S:XUPART?.E1N.E XUAUD("NUMBER")=""
|
|---|
| 96 | ;
|
|---|
| 97 | S I=XUPART,XUPART=$TR(XUPART,"!""#$%&'()*+,./:;<=>?@[\]^_`{|}~")
|
|---|
| 98 | S:XUPART'=I XUAUD("PUNC")=""
|
|---|
| 99 | ;
|
|---|
| 100 | ;Remove all spaces and double hyphens from Family Name
|
|---|
| 101 | I XUFLAG["F",XUFLAG'["I" D Q $$REMBE($$REMDBL(XUPART,"-"),"-")
|
|---|
| 102 | . S:XUPART?." "1.ANP1." "1.ANP." " XUAUD("SPACE")=""
|
|---|
| 103 | . S XUPART=$TR(XUPART," ")
|
|---|
| 104 | ;
|
|---|
| 105 | Q $$REMBE($$REMDBL(XUPART,"- "),"- ")
|
|---|
| 106 | ;
|
|---|
| 107 | NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ; Name formatting routine (extrinsic)
|
|---|
| 108 | NAMEFMTX ;
|
|---|
| 109 | ; XUNAME: Input name components array or Name Components Key fields
|
|---|
| 110 | ; XUFMT: F=Family name first,G=Given name first,H=HL7 (default G)
|
|---|
| 111 | ; XUFLAG: P=Include prefix,D=Include degree,S=Standardize components,M=Mixed case
|
|---|
| 112 | ; XUDLM: Delimiter if HL7 message (def = ^)
|
|---|
| 113 | N XUBLD,XUI,XULEN,XUN,XUSTEP
|
|---|
| 114 | ;
|
|---|
| 115 | ;Set defaults
|
|---|
| 116 | S XUFMT=$G(XUFMT) S:XUFMT="" XUFMT="G"
|
|---|
| 117 | S XUFLAG=$G(XUFLAG)
|
|---|
| 118 | S:$G(XUDLM)="" XUDLM=U
|
|---|
| 119 | S:XUFLAG["L" XULEN=+$P(XUFLAG,"L",2) S:$G(XULEN)<1 XULEN=256
|
|---|
| 120 | ;
|
|---|
| 121 | ;Get XUN (name array)
|
|---|
| 122 | ;If a name (no array) is passed in
|
|---|
| 123 | I $D(XUNAME)<10 D
|
|---|
| 124 | . S XUN=$G(XUNAME) Q:XUN=""
|
|---|
| 125 | . D STDNAME^XLFNAME(.XUN,"CP")
|
|---|
| 126 | ;
|
|---|
| 127 | ;Else, if a file, field, iens passed in
|
|---|
| 128 | E I $G(XUNAME("FILE")),$G(XUNAME("FIELD")),$G(XUNAME("IENS"))]"" D
|
|---|
| 129 | . N IEN,IENS
|
|---|
| 130 | . S IENS=$G(XUNAME("IENS")) S:IENS'?.E1"," IENS=IENS_","
|
|---|
| 131 | . S IEN=$O(^VA(20,"BB",+XUNAME("FILE"),+$G(XUNAME("FIELD")),IENS,0))
|
|---|
| 132 | . I IEN D
|
|---|
| 133 | .. N I
|
|---|
| 134 | .. S I=0 F XUI="FAMILY","GIVEN","MIDDLE","PREFIX","SUFFIX","DEGREE" D
|
|---|
| 135 | ... S I=I+1,XUN(XUI)=$P($G(^VA(20,IEN,1)),U,I)
|
|---|
| 136 | . E D
|
|---|
| 137 | .. N MSG,NAM,DIERR
|
|---|
| 138 | .. S NAM=$$GET1^DIQ(+XUNAME("FILE"),IENS,+$G(XUNAME("FIELD")),"I","MSG")
|
|---|
| 139 | .. I NAM]"" S XUN=NAM D STDNAME^XLFNAME(.XUN,"CP")
|
|---|
| 140 | ;
|
|---|
| 141 | ;Else, components passed in
|
|---|
| 142 | E M XUN=XUNAME
|
|---|
| 143 | ;
|
|---|
| 144 | ;Standardize
|
|---|
| 145 | F XUI="FAMILY","GIVEN","MIDDLE","SUFFIX","PREFIX","DEGREE" D
|
|---|
| 146 | . S XUN(XUI)=$G(XUN(XUI))
|
|---|
| 147 | . I XUFLAG["S",XUN(XUI)]"" S XUN(XUI)=$$CLEANC(XUN(XUI),$E("F",XUI="FAMILY"))
|
|---|
| 148 | Q:$G(XUN("FAMILY"))="" ""
|
|---|
| 149 | ;
|
|---|
| 150 | ; Return in mixed case
|
|---|
| 151 | I XUFLAG["M" D
|
|---|
| 152 | . N XUCMP,X
|
|---|
| 153 | . F XUCMP="FAMILY","GIVEN","MIDDLE","PREFIX" I XUN(XUCMP)]"" S XUN(XUCMP)=$$MIX(XUN(XUCMP))
|
|---|
| 154 | . I XUN("DEGREE")]"" S XUN("DEGREE")=$$MIX2(XUN("DEGREE"))
|
|---|
| 155 | . I XUN("SUFFIX")]"" S XUN("SUFFIX")=$$MIX2(XUN("SUFFIX"))
|
|---|
| 156 | . Q
|
|---|
| 157 | ;
|
|---|
| 158 | ;Build formatted name, truncate if necessary
|
|---|
| 159 | S XUBLD=1 F XUSTEP=0:1 D Q:$L(XUN)'>XULEN
|
|---|
| 160 | . ;Build formatted name
|
|---|
| 161 | . I XUBLD S XUBLD=0 D Q:$L(XUN)'>XULEN
|
|---|
| 162 | .. I XUFMT["H" S XUN=$$H(.XUN,XUDLM) Q
|
|---|
| 163 | .. I XUFMT["O" S XUN=$$O(.XUN) Q
|
|---|
| 164 | .. I XUFMT["G" S XUN=$$G(.XUN,XUFLAG) Q
|
|---|
| 165 | .. S XUN=$$F(.XUN,XUFLAG) Q
|
|---|
| 166 | . ;
|
|---|
| 167 | . ;Truncation steps
|
|---|
| 168 | . Q:'XUSTEP
|
|---|
| 169 | . I XUSTEP=1 S:XUN("DEGREE")]"" XUN("DEGREE")="",XUBLD=1 Q
|
|---|
| 170 | . I XUSTEP=2 S:XUN("PREFIX")]"" XUN("PREFIX")="",XUBLD=1 Q
|
|---|
| 171 | . I XUSTEP=3 S:XUN("MIDDLE")]"" XUN("MIDDLE")=$$TRUNC(XUN("MIDDLE"),$L(XUN)-XULEN),XUBLD=1 Q
|
|---|
| 172 | . I XUSTEP=4 S:XUN("SUFFIX")]"" XUN("SUFFIX")="",XUBLD=1 Q
|
|---|
| 173 | . I XUSTEP=5 S:XUN("GIVEN")]"" XUN("GIVEN")=$$TRUNC(XUN("GIVEN"),$L(XUN)-XULEN),XUBLD=1 Q
|
|---|
| 174 | . I XUSTEP=6 S:XUN("FAMILY")]"" XUN("FAMILY")=$$TRUNC(XUN("FAMILY"),$L(XUN)-XULEN),XUBLD=1 Q
|
|---|
| 175 | . I XUSTEP=7 S XUN=$E(XUN,1,XULEN) F Q:XUN'?.E1" " S XUN=$E(XUN,1,$L(XUN)-1)
|
|---|
| 176 | Q XUN
|
|---|
| 177 | ;
|
|---|
| 178 | MIX(X) ; Return name part with only first letter upper-case
|
|---|
| 179 | N %,L
|
|---|
| 180 | F %=2:1:$L(X) I $E(X,%)?1U,$E(X,%-1)?1A S L=$E(X,%),L=$C($A(L)+32),$E(X,%)=L
|
|---|
| 181 | Q X
|
|---|
| 182 | ;
|
|---|
| 183 | MIX2(XUN) ; Properly capitalize suffixes, degrees
|
|---|
| 184 | N P,I,L,DIOUT
|
|---|
| 185 | F P="DR","PHD","JR","SR","ESQ" S I=$F(XUN,P) I I D
|
|---|
| 186 | . Q:$E(XUN,I)?1A
|
|---|
| 187 | . I P="PHD" Q:$E(XUN,I-4)?1A S $E(XUN,I-3,I-1)="PhD" Q
|
|---|
| 188 | . S L=$L(P) Q:$E(XUN,I-(L+1))?1A
|
|---|
| 189 | . S X=$$MIX($E(XUN,I-L,I-1)),$E(XUN,I-L,I-1)=X
|
|---|
| 190 | . Q
|
|---|
| 191 | I XUN?.E1.N1.U.E S DIOUT=0 F P=1:1:10 S I=$F(XUN,P) I I D Q:DIOUT
|
|---|
| 192 | . S L=$S(P=1:"ST",P=2:"ND",P=3:"RD",1:"TH")
|
|---|
| 193 | . I $E(XUN,I,I+1)'=L Q
|
|---|
| 194 | . S $E(XUN,I,I+1)=$S(P=1:"st",P=2:"nd",P=3:"rd",1:"th")
|
|---|
| 195 | . S DIOUT=1 Q
|
|---|
| 196 | Q XUN
|
|---|
| 197 | ;
|
|---|
| 198 | O(N) ;O format
|
|---|
| 199 | Q N("FAMILY")
|
|---|
| 200 | ;
|
|---|
| 201 | F(N,F) ;F format
|
|---|
| 202 | N NAM
|
|---|
| 203 | S NAM=N("FAMILY")_$S(F["C":",",1:" ")_N("GIVEN")_$E(" ",N("MIDDLE")]"")_N("MIDDLE")
|
|---|
| 204 | S NAM=$$SPD(NAM,.N,F)
|
|---|
| 205 | S:NAM?.E1(1",",1" ") NAM=$E(NAM,1,$L(NAM)-1)
|
|---|
| 206 | Q NAM
|
|---|
| 207 | ;
|
|---|
| 208 | G(N,F) ;G format
|
|---|
| 209 | N NAM,I
|
|---|
| 210 | S NAM="" F I="GIVEN","MIDDLE","FAMILY" S NAM=$$JOIN(NAM,N(I))
|
|---|
| 211 | Q $$SPD(NAM,.N,F)
|
|---|
| 212 | ;
|
|---|
| 213 | H(N,D) ;H format
|
|---|
| 214 | N NAM
|
|---|
| 215 | S NAM=N("FAMILY")_D_N("GIVEN")_D_N("MIDDLE")_D_N("SUFFIX")_D_N("PREFIX")_D_N("DEGREE")
|
|---|
| 216 | F Q:$E(NAM,$L(NAM))'=D S NAM=$E(NAM,1,$L(NAM)-1)
|
|---|
| 217 | Q NAM
|
|---|
| 218 | ;
|
|---|
| 219 | SPD(NAM,N,F) ;Add Suffix, Prefix, and Degree
|
|---|
| 220 | S NAM=$$JOIN(NAM,N("SUFFIX"),$E(",",F["Xc")_" ")
|
|---|
| 221 | S:F["P" NAM=$$JOIN(N("PREFIX"),NAM)
|
|---|
| 222 | S:F["D" NAM=$$JOIN(NAM,N("DEGREE"),$E(",",F["Dc")_" ")
|
|---|
| 223 | Q NAM
|
|---|
| 224 | ;
|
|---|
| 225 | JOIN(S1,S2,D) ;Return S1 joined with S2 (separate by D)
|
|---|
| 226 | S:$G(D)="" D=" "
|
|---|
| 227 | Q S1_$S($L(S1)&$L(S2):D,1:"")_S2
|
|---|
| 228 | ;
|
|---|
| 229 | TRUNC(NC,OVR) ;Truncate component
|
|---|
| 230 | S NC=$E(NC,1,$S($L(NC)>OVR:$L(NC)-OVR,1:1))
|
|---|
| 231 | F Q:NC'?.E1" " S NC=$E(NC,1,$L(NC)-1)
|
|---|
| 232 | Q NC
|
|---|
