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

XLFNAME1 ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;9:25 AM  29 Jan 2003
 ;;8.0;KERNEL;**134,240**;Jul 10, 1995
 ;
REMDBL(X,S) ;For each char in S, remove double chars
 N I,J
 F I=1:1:$L(S) S C=$E(S,I) D
 . F  S J=$F(X,C_C) Q:'J  S $E(X,J-1)=""
 Q X
 ;
REMBE(X,S) ;Remove each char in S from the beg and end of X
 N I
 F I=1:1:$L(X) Q:S'[$E(X,I)
 S X=$E(X,I,999)
 F I=$L(X):-1:1 Q:S'[$E(X,I)
 S X=$E(X,1,I)
 Q X
 ;
ROMAN(X) ; Replace numeric suffixes to Roman Numeral equivalents
 Q:X'?.E1.N.E X
 N IN,OUT
 ;
 S IN="^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"
 S OUT="I^II^III^IV^V^VI^VII^VIII^IX^X"
 S:IN[(U_X_U) X=$P(OUT,U,$L($P(IN,U_X_U),U))
 Q X
 ;
CHKSUF(X) ;Return X if it looks like a suffix; otherwise, return null
 N V
 Q:"^I^II^III^IV^V^VI^VII^VIII^IX^X^JR^SR^DR^MD^ESQ^DDS^RN^"[(U_X_U) X
 Q:"^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U) X
 I $L(X)>1,X'[" ",X'="NMN" D  I V="" S XUAUD("SUFFIX")="" Q X
 . F V="A","E","I","O","U","Y","" Q:X[V
 Q ""
 ;
CHKSUF1(X) ; Return X if it looks like a suffix, but not I, V, X
 N V
 Q:"^II^III^IV^VI^VII^VIII^IX^JR^SR^DR^MD^ESQ^DDS^RN^"[(U_X_U) X
 Q:"^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U) X
 Q ""
 ;
PERIOD(X) ; Change X so that there is a space after every period
 Q:X'["." X
 N I
 S I=0 F  S I=$F(X,".",I) Q:'I!(I'<$L(X))  D
 . S:$E(X,I)'=" " X=$E(X,1,I-1)_" "_$E(X,I,999)
 Q X
 ;
PARENS(X) ;Strip parenthetical part(s) from X
 N C,DONE,LEV,P,P1,P2
 F  Q:X'?.E1(1"(",1"[",1"{").E  D  Q:'P2
 . S (DONE,LEV,P1,P2)=0
 . F P=1:1:$L(X) D  Q:DONE
 .. S C=$E(X,P)
 .. I C?1(1"(",1"[",1"{") S:'LEV P1=P S LEV=LEV+1
 .. E  I P1,C?1(1")",1"]",1"}") S P2=P,LEV=LEV-1 S:'LEV DONE=1
 . S:P2 X=$E(X,1,P1-1)_$E(X,P2+1,999)
 Q X
 ;
SUFEND(XUN,XUNO,XUNM,XUOUT,XUAUD) ;Look for suffixes at end of XUN
 ;Put in XUNM("SUFFIX")
 ;Remove those suffixes from XUN and XUNO
 N XUI,XUSUF,XUSUFO,XUSUFFIX,XUX
 S XUSUF="" S:XUOUT XUSUFO=""
 ;
 F XUI=$L(XUN," "):-1:2 D  Q:XUSUFFIX=""
 . S XUX=$P(XUN," ",XUI)
 . S XUSUFFIX=$$CHKSUF(XUX) Q:XUSUFFIX=""
 . S XUSUF=$$JOIN($$ROMAN(XUSUFFIX),XUSUF)
 . S XUN=$P(XUN," ",1,XUI-1)
 . D:XUOUT
 .. S XUSUFO=$P(XUNO," ",XUI)_$E(" ",XUSUFO]"")_XUSUFO
 .. S XUNO=$P(XUNO," ",1,XUI-1)
 ;
 I XUSUF]"" S XUNM("SUFFIX")=XUSUF S:XUOUT XUOUT("SUFFIX")=XUSUFO
 Q
 ;
CLEANC(XUPART,XUFLAG,XUAUD) ; Component standardization
CLEANCX ; Entry point from CLEANC^XLFNAME
 Q:$G(XUPART)="" ""
 N XUX,I
 S XUFLAG=$G(XUFLAG)
 ;
 S:XUPART?.E1.L.E XUPART=$$UP^XLFSTR(XUPART)
 ;
 S XUX=$S(XUFLAG["F":"-",1:" ")
 S I=XUPART,XUPART=$TR(XUPART,",:;",XUX_XUX_XUX)
 S:XUPART'=I XUAUD("PUNC")=""
 ;
 Q:XUFLAG["O" $$REMBE($$REMDBL($$PERIOD(XUPART),"- "),"- ")
 ;
 I XUPART["." S XUPART=$TR(XUPART,"."," "),XUAUD("PERIOD")=""
 ;
 I XUFLAG'["I" D
 . F I=1:1:$L(XUPART," ") S $P(XUPART," ",I)=$$ROMAN($P(XUPART," ",I))
 . S:XUPART?.E1N.E XUAUD("NUMBER")=""
 ;
 S I=XUPART,XUPART=$TR(XUPART,"!""#$%&'()*+,./:;<=>?@[\]^_`{|}~")
 S:XUPART'=I XUAUD("PUNC")=""
 ;
 ;Remove all spaces and double hyphens from Family Name
 I XUFLAG["F",XUFLAG'["I" D  Q $$REMBE($$REMDBL(XUPART,"-"),"-")
 . S:XUPART?." "1.ANP1." "1.ANP." " XUAUD("SPACE")=""
 . S XUPART=$TR(XUPART," ")
 ;
 Q $$REMBE($$REMDBL(XUPART,"- "),"- ")
 ;
NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ; Name formatting routine (extrinsic)
NAMEFMTX ;
 ; XUNAME: Input name components array or Name Components Key fields
 ; XUFMT:  F=Family name first,G=Given name first,H=HL7 (default G)
 ; XUFLAG: P=Include prefix,D=Include degree,S=Standardize components,M=Mixed case
 ; XUDLM:  Delimiter if HL7 message (def = ^)
 N XUBLD,XUI,XULEN,XUN,XUSTEP
 ;
 ;Set defaults
 S XUFMT=$G(XUFMT) S:XUFMT="" XUFMT="G"
 S XUFLAG=$G(XUFLAG)
 S:$G(XUDLM)="" XUDLM=U
 S:XUFLAG["L" XULEN=+$P(XUFLAG,"L",2) S:$G(XULEN)<1 XULEN=256
 ;
 ;Get XUN (name array)
 ;If a name (no array) is passed in
 I $D(XUNAME)<10 D
 . S XUN=$G(XUNAME) Q:XUN=""
 . D STDNAME^XLFNAME(.XUN,"CP")
 ;
 ;Else, if a file, field, iens passed in
 E  I $G(XUNAME("FILE")),$G(XUNAME("FIELD")),$G(XUNAME("IENS"))]"" D
 . N IEN,IENS
 . S IENS=$G(XUNAME("IENS")) S:IENS'?.E1"," IENS=IENS_","
 . S IEN=$O(^VA(20,"BB",+XUNAME("FILE"),+$G(XUNAME("FIELD")),IENS,0))
 . I IEN D
 .. N I
 .. S I=0 F XUI="FAMILY","GIVEN","MIDDLE","PREFIX","SUFFIX","DEGREE" D
 ... S I=I+1,XUN(XUI)=$P($G(^VA(20,IEN,1)),U,I)
 . E  D
 .. N MSG,NAM,DIERR
 .. S NAM=$$GET1^DIQ(+XUNAME("FILE"),IENS,+$G(XUNAME("FIELD")),"I","MSG")
 .. I NAM]"" S XUN=NAM D STDNAME^XLFNAME(.XUN,"CP")
 ;
 ;Else, components passed in
 E  M XUN=XUNAME
 ;
 ;Standardize
 F XUI="FAMILY","GIVEN","MIDDLE","SUFFIX","PREFIX","DEGREE" D
 . S XUN(XUI)=$G(XUN(XUI))
 . I XUFLAG["S",XUN(XUI)]"" S XUN(XUI)=$$CLEANC(XUN(XUI),$E("F",XUI="FAMILY"))
 Q:$G(XUN("FAMILY"))="" ""
 ;
 ; Return in mixed case
 I XUFLAG["M" D
 . N XUCMP,X
 . F XUCMP="FAMILY","GIVEN","MIDDLE","PREFIX" I XUN(XUCMP)]"" S XUN(XUCMP)=$$MIX(XUN(XUCMP))
 . I XUN("DEGREE")]"" S XUN("DEGREE")=$$MIX2(XUN("DEGREE"))
 . I XUN("SUFFIX")]"" S XUN("SUFFIX")=$$MIX2(XUN("SUFFIX"))
 . Q
 ;
 ;Build formatted name, truncate if necessary
 S XUBLD=1 F XUSTEP=0:1 D  Q:$L(XUN)'>XULEN
 . ;Build formatted name
 . I XUBLD S XUBLD=0 D  Q:$L(XUN)'>XULEN
 .. I XUFMT["H" S XUN=$$H(.XUN,XUDLM) Q
 .. I XUFMT["O" S XUN=$$O(.XUN) Q
 .. I XUFMT["G" S XUN=$$G(.XUN,XUFLAG) Q
 .. S XUN=$$F(.XUN,XUFLAG) Q
 . ;
 . ;Truncation steps
 . Q:'XUSTEP
 . I XUSTEP=1 S:XUN("DEGREE")]"" XUN("DEGREE")="",XUBLD=1 Q
 . I XUSTEP=2 S:XUN("PREFIX")]"" XUN("PREFIX")="",XUBLD=1 Q
 . I XUSTEP=3 S:XUN("MIDDLE")]"" XUN("MIDDLE")=$$TRUNC(XUN("MIDDLE"),$L(XUN)-XULEN),XUBLD=1 Q
 . I XUSTEP=4 S:XUN("SUFFIX")]"" XUN("SUFFIX")="",XUBLD=1 Q
 . I XUSTEP=5 S:XUN("GIVEN")]"" XUN("GIVEN")=$$TRUNC(XUN("GIVEN"),$L(XUN)-XULEN),XUBLD=1 Q
 . I XUSTEP=6 S:XUN("FAMILY")]"" XUN("FAMILY")=$$TRUNC(XUN("FAMILY"),$L(XUN)-XULEN),XUBLD=1 Q
 . I XUSTEP=7 S XUN=$E(XUN,1,XULEN) F  Q:XUN'?.E1" "  S XUN=$E(XUN,1,$L(XUN)-1)
 Q XUN
 ;
MIX(X) ; Return name part with only first letter upper-case
 N %,L
 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
 Q X
 ;
MIX2(XUN) ; Properly capitalize suffixes, degrees
 N P,I,L,DIOUT
 F P="DR","PHD","JR","SR","ESQ" S I=$F(XUN,P) I I D
 . Q:$E(XUN,I)?1A
 . I P="PHD" Q:$E(XUN,I-4)?1A  S $E(XUN,I-3,I-1)="PhD" Q
 . S L=$L(P) Q:$E(XUN,I-(L+1))?1A
 . S X=$$MIX($E(XUN,I-L,I-1)),$E(XUN,I-L,I-1)=X
 . Q
 I XUN?.E1.N1.U.E S DIOUT=0 F P=1:1:10 S I=$F(XUN,P) I I D  Q:DIOUT
 . S L=$S(P=1:"ST",P=2:"ND",P=3:"RD",1:"TH")
 . I $E(XUN,I,I+1)'=L Q
 . S $E(XUN,I,I+1)=$S(P=1:"st",P=2:"nd",P=3:"rd",1:"th")
 . S DIOUT=1 Q
 Q XUN
 ;
O(N) ;O format
 Q N("FAMILY")
 ;
F(N,F) ;F format
 N NAM
 S NAM=N("FAMILY")_$S(F["C":",",1:" ")_N("GIVEN")_$E(" ",N("MIDDLE")]"")_N("MIDDLE")
 S NAM=$$SPD(NAM,.N,F)
 S:NAM?.E1(1",",1" ") NAM=$E(NAM,1,$L(NAM)-1)
 Q NAM
 ;
G(N,F) ;G format
 N NAM,I
 S NAM="" F I="GIVEN","MIDDLE","FAMILY" S NAM=$$JOIN(NAM,N(I))
 Q $$SPD(NAM,.N,F)
 ;
H(N,D) ;H format
 N NAM
 S NAM=N("FAMILY")_D_N("GIVEN")_D_N("MIDDLE")_D_N("SUFFIX")_D_N("PREFIX")_D_N("DEGREE")
 F  Q:$E(NAM,$L(NAM))'=D  S NAM=$E(NAM,1,$L(NAM)-1)
 Q NAM
 ;
SPD(NAM,N,F) ;Add Suffix, Prefix, and Degree
 S NAM=$$JOIN(NAM,N("SUFFIX"),$E(",",F["Xc")_" ")
 S:F["P" NAM=$$JOIN(N("PREFIX"),NAM)
 S:F["D" NAM=$$JOIN(NAM,N("DEGREE"),$E(",",F["Dc")_" ")
 Q NAM
 ;
JOIN(S1,S2,D) ;Return S1 joined with S2 (separate by D)
 S:$G(D)="" D=" "
 Q S1_$S($L(S1)&$L(S2):D,1:"")_S2
 ;
TRUNC(NC,OVR) ;Truncate component
 S NC=$E(NC,1,$S($L(NC)>OVR:$L(NC)-OVR,1:1))
 F  Q:NC'?.E1" "  S NC=$E(NC,1,$L(NC)-1)
 Q NC