XLFNAME1 ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;05/05/2010
;;8.0;KERNEL;**134,240,535**;Jul 10, 1995;Build 5
;;Per VHA Directive 2004-038, this routine should not be modified.
;
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
;*p535-added "ARNP,DO,PA" to the list.-REM
N V
Q:"^I^II^III^IV^V^VI^VII^VIII^IX^X^JR^SR^DR^MD^ESQ^DDS^RN^ARNP^DO^PA^"[(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
;*p535-added "ARNP,DO,PA" to the list.-REM
N V
Q:"^II^III^IV^VI^VII^VIII^IX^JR^SR^DR^MD^ESQ^DDS^RN^ARNP^DO^PA^"[(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
XLFNAME1 ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;05/05/2010
+1 ;;8.0;KERNEL;**134,240,535**;Jul 10, 1995;Build 5
+2 ;;Per VHA Directive 2004-038, this routine should not be modified.
+3 ;
REMDBL(X,S) ;For each char in S, remove double chars
+1 NEW I,J
+2 FOR I=1:1:$LENGTH(S)
SET C=$EXTRACT(S,I)
Begin DoDot:1
+3 FOR
SET J=$FIND(X,C_C)
IF 'J
QUIT
SET $EXTRACT(X,J-1)=""
End DoDot:1
+4 QUIT X
+5 ;
REMBE(X,S) ;Remove each char in S from the beg and end of X
+1 NEW I
+2 FOR I=1:1:$LENGTH(X)
IF S'[$EXTRACT(X,I)
QUIT
+3 SET X=$EXTRACT(X,I,999)
+4 FOR I=$LENGTH(X):-1:1
IF S'[$EXTRACT(X,I)
QUIT
+5 SET X=$EXTRACT(X,1,I)
+6 QUIT X
+7 ;
ROMAN(X) ; Replace numeric suffixes to Roman Numeral equivalents
+1 IF X'?.E1.N.E
QUIT X
+2 NEW IN,OUT
+3 ;
+4 SET IN="^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"
+5 SET OUT="I^II^III^IV^V^VI^VII^VIII^IX^X"
+6 IF IN[(U_X_U)
SET X=$PIECE(OUT,U,$LENGTH($PIECE(IN,U_X_U),U))
+7 QUIT X
+8 ;
CHKSUF(X) ;Return X if it looks like a suffix; otherwise, return null
+1 ;*p535-added "ARNP,DO,PA" to the list.-REM
+2 NEW V
+3 IF "^I^II^III^IV^V^VI^VII^VIII^IX^X^JR^SR^DR^MD^ESQ^DDS^RN^ARNP^DO^PA^"[(U_X_U)
QUIT X
+4 IF "^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U)
QUIT X
+5 IF $LENGTH(X)>1
IF X'[" "
IF X'="NMN"
Begin DoDot:1
+6 FOR V="A","E","I","O","U","Y",""
IF X[V
QUIT
End DoDot:1
IF V=""
SET XUAUD("SUFFIX")=""
QUIT X
+7 QUIT ""
+8 ;
CHKSUF1(X) ; Return X if it looks like a suffix, but not I, V, X
+1 ;*p535-added "ARNP,DO,PA" to the list.-REM
+2 NEW V
+3 IF "^II^III^IV^VI^VII^VIII^IX^JR^SR^DR^MD^ESQ^DDS^RN^ARNP^DO^PA^"[(U_X_U)
QUIT X
+4 IF "^1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH^10TH^"[(U_X_U)
QUIT X
+5 QUIT ""
+6 ;
PERIOD(X) ; Change X so that there is a space after every period
+1 IF X'["."
QUIT X
+2 NEW I
+3 SET I=0
FOR
SET I=$FIND(X,".",I)
IF 'I!(I'<$LENGTH(X))
QUIT
Begin DoDot:1
+4 IF $EXTRACT(X,I)'=" "
SET X=$EXTRACT(X,1,I-1)_" "_$EXTRACT(X,I,999)
End DoDot:1
+5 QUIT X
+6 ;
PARENS(X) ;Strip parenthetical part(s) from X
+1 NEW C,DONE,LEV,P,P1,P2
+2 FOR
IF X'?.E1(1"(",1"[",1"{").E
QUIT
Begin DoDot:1
+3 SET (DONE,LEV,P1,P2)=0
+4 FOR P=1:1:$LENGTH(X)
Begin DoDot:2
+5 SET C=$EXTRACT(X,P)
+6 IF C?1(1"(",1"[",1"{")
IF 'LEV
SET P1=P
SET LEV=LEV+1
+7 IF '$TEST
IF P1
IF C?1(1")",1"]",1"}")
SET P2=P
SET LEV=LEV-1
IF 'LEV
SET DONE=1
End DoDot:2
IF DONE
QUIT
+8 IF P2
SET X=$EXTRACT(X,1,P1-1)_$EXTRACT(X,P2+1,999)
End DoDot:1
IF 'P2
QUIT
+9 QUIT X
+10 ;
SUFEND(XUN,XUNO,XUNM,XUOUT,XUAUD) ;Look for suffixes at end of XUN
+1 ;Put in XUNM("SUFFIX")
+2 ;Remove those suffixes from XUN and XUNO
+3 NEW XUI,XUSUF,XUSUFO,XUSUFFIX,XUX
+4 SET XUSUF=""
IF XUOUT
SET XUSUFO=""
+5 ;
+6 FOR XUI=$LENGTH(XUN," "):-1:2
Begin DoDot:1
+7 SET XUX=$PIECE(XUN," ",XUI)
+8 SET XUSUFFIX=$$CHKSUF(XUX)
IF XUSUFFIX=""
QUIT
+9 SET XUSUF=$$JOIN($$ROMAN(XUSUFFIX),XUSUF)
+10 SET XUN=$PIECE(XUN," ",1,XUI-1)
+11 IF XUOUT
Begin DoDot:2
+12 SET XUSUFO=$PIECE(XUNO," ",XUI)_$EXTRACT(" ",XUSUFO]"")_XUSUFO
+13 SET XUNO=$PIECE(XUNO," ",1,XUI-1)
End DoDot:2
End DoDot:1
IF XUSUFFIX=""
QUIT
+14 ;
+15 IF XUSUF]""
SET XUNM("SUFFIX")=XUSUF
IF XUOUT
SET XUOUT("SUFFIX")=XUSUFO
+16 QUIT
+17 ;
CLEANC(XUPART,XUFLAG,XUAUD) ; Component standardization
CLEANCX ; Entry point from CLEANC^XLFNAME
+1 IF $GET(XUPART)=""
QUIT ""
+2 NEW XUX,I
+3 SET XUFLAG=$GET(XUFLAG)
+4 ;
+5 IF XUPART?.E1.L.E
SET XUPART=$$UP^XLFSTR(XUPART)
+6 ;
+7 SET XUX=$SELECT(XUFLAG["F":"-",1:" ")
+8 SET I=XUPART
SET XUPART=$TRANSLATE(XUPART,",:;",XUX_XUX_XUX)
+9 IF XUPART'=I
SET XUAUD("PUNC")=""
+10 ;
+11 IF XUFLAG["O"
QUIT $$REMBE($$REMDBL($$PERIOD(XUPART),"- "),"- ")
+12 ;
+13 IF XUPART["."
SET XUPART=$TRANSLATE(XUPART,"."," ")
SET XUAUD("PERIOD")=""
+14 ;
+15 IF XUFLAG'["I"
Begin DoDot:1
+16 FOR I=1:1:$LENGTH(XUPART," ")
SET $PIECE(XUPART," ",I)=$$ROMAN($PIECE(XUPART," ",I))
+17 IF XUPART?.E1N.E
SET XUAUD("NUMBER")=""
End DoDot:1
+18 ;
+19 SET I=XUPART
SET XUPART=$TRANSLATE(XUPART,"!""#$%&'()*+,./:;<=>?@[\]^_`{|}~")
+20 IF XUPART'=I
SET XUAUD("PUNC")=""
+21 ;
+22 ;Remove all spaces and double hyphens from Family Name
+23 IF XUFLAG["F"
IF XUFLAG'["I"
Begin DoDot:1
+24 IF XUPART?." "1.ANP1." "1.ANP." "
SET XUAUD("SPACE")=""
+25 SET XUPART=$TRANSLATE(XUPART," ")
End DoDot:1
QUIT $$REMBE($$REMDBL(XUPART,"-"),"-")
+26 ;
+27 QUIT $$REMBE($$REMDBL(XUPART,"- "),"- ")
+28 ;
NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ; Name formatting routine (extrinsic)
NAMEFMTX ;
+1 ; XUNAME: Input name components array or Name Components Key fields
+2 ; XUFMT: F=Family name first,G=Given name first,H=HL7 (default G)
+3 ; XUFLAG: P=Include prefix,D=Include degree,S=Standardize components,M=Mixed case
+4 ; XUDLM: Delimiter if HL7 message (def = ^)
+5 NEW XUBLD,XUI,XULEN,XUN,XUSTEP
+6 ;
+7 ;Set defaults
+8 SET XUFMT=$GET(XUFMT)
IF XUFMT=""
SET XUFMT="G"
+9 SET XUFLAG=$GET(XUFLAG)
+10 IF $GET(XUDLM)=""
SET XUDLM=U
+11 IF XUFLAG["L"
SET XULEN=+$PIECE(XUFLAG,"L",2)
IF $GET(XULEN)<1
SET XULEN=256
+12 ;
+13 ;Get XUN (name array)
+14 ;If a name (no array) is passed in
+15 IF $DATA(XUNAME)<10
Begin DoDot:1
+16 SET XUN=$GET(XUNAME)
IF XUN=""
QUIT
+17 DO STDNAME^XLFNAME(.XUN,"CP")
End DoDot:1
+18 ;
+19 ;Else, if a file, field, iens passed in
+20 IF '$TEST
IF $GET(XUNAME("FILE"))
IF $GET(XUNAME("FIELD"))
IF $GET(XUNAME("IENS"))]""
Begin DoDot:1
+21 NEW IEN,IENS
+22 SET IENS=$GET(XUNAME("IENS"))
IF IENS'?.E1","
SET IENS=IENS_","
+23 SET IEN=$ORDER(^VA(20,"BB",+XUNAME("FILE"),+$GET(XUNAME("FIELD")),IENS,0))
+24 IF IEN
Begin DoDot:2
+25 NEW I
+26 SET I=0
FOR XUI="FAMILY","GIVEN","MIDDLE","PREFIX","SUFFIX","DEGREE"
Begin DoDot:3
+27 SET I=I+1
SET XUN(XUI)=$PIECE($GET(^VA(20,IEN,1)),U,I)
End DoDot:3
End DoDot:2
+28 IF '$TEST
Begin DoDot:2
+29 NEW MSG,NAM,DIERR
+30 SET NAM=$$GET1^DIQ(+XUNAME("FILE"),IENS,+$GET(XUNAME("FIELD")),"I","MSG")
+31 IF NAM]""
SET XUN=NAM
DO STDNAME^XLFNAME(.XUN,"CP")
End DoDot:2
End DoDot:1
+32 ;
+33 ;Else, components passed in
+34 IF '$TEST
MERGE XUN=XUNAME
+35 ;
+36 ;Standardize
+37 FOR XUI="FAMILY","GIVEN","MIDDLE","SUFFIX","PREFIX","DEGREE"
Begin DoDot:1
+38 SET XUN(XUI)=$GET(XUN(XUI))
+39 IF XUFLAG["S"
IF XUN(XUI)]""
SET XUN(XUI)=$$CLEANC(XUN(XUI),$EXTRACT("F",XUI="FAMILY"))
End DoDot:1
+40 IF $GET(XUN("FAMILY"))=""
QUIT ""
+41 ;
+42 ; Return in mixed case
+43 IF XUFLAG["M"
Begin DoDot:1
+44 NEW XUCMP,X
+45 FOR XUCMP="FAMILY","GIVEN","MIDDLE","PREFIX"
IF XUN(XUCMP)]""
SET XUN(XUCMP)=$$MIX(XUN(XUCMP))
+46 IF XUN("DEGREE")]""
SET XUN("DEGREE")=$$MIX2(XUN("DEGREE"))
+47 IF XUN("SUFFIX")]""
SET XUN("SUFFIX")=$$MIX2(XUN("SUFFIX"))
+48 QUIT
End DoDot:1
+49 ;
+50 ;Build formatted name, truncate if necessary
+51 SET XUBLD=1
FOR XUSTEP=0:1
Begin DoDot:1
+52 ;Build formatted name
+53 IF XUBLD
SET XUBLD=0
Begin DoDot:2
+54 IF XUFMT["H"
SET XUN=$$H(.XUN,XUDLM)
QUIT
+55 IF XUFMT["O"
SET XUN=$$O(.XUN)
QUIT
+56 IF XUFMT["G"
SET XUN=$$G(.XUN,XUFLAG)
QUIT
+57 SET XUN=$$F(.XUN,XUFLAG)
QUIT
End DoDot:2
IF $LENGTH(XUN)'>XULEN
QUIT
+58 ;
+59 ;Truncation steps
+60 IF 'XUSTEP
QUIT
+61 IF XUSTEP=1
IF XUN("DEGREE")]""
SET XUN("DEGREE")=""
SET XUBLD=1
QUIT
+62 IF XUSTEP=2
IF XUN("PREFIX")]""
SET XUN("PREFIX")=""
SET XUBLD=1
QUIT
+63 IF XUSTEP=3
IF XUN("MIDDLE")]""
SET XUN("MIDDLE")=$$TRUNC(XUN("MIDDLE"),$LENGTH(XUN)-XULEN)
SET XUBLD=1
QUIT
+64 IF XUSTEP=4
IF XUN("SUFFIX")]""
SET XUN("SUFFIX")=""
SET XUBLD=1
QUIT
+65 IF XUSTEP=5
IF XUN("GIVEN")]""
SET XUN("GIVEN")=$$TRUNC(XUN("GIVEN"),$LENGTH(XUN)-XULEN)
SET XUBLD=1
QUIT
+66 IF XUSTEP=6
IF XUN("FAMILY")]""
SET XUN("FAMILY")=$$TRUNC(XUN("FAMILY"),$LENGTH(XUN)-XULEN)
SET XUBLD=1
QUIT
+67 IF XUSTEP=7
SET XUN=$EXTRACT(XUN,1,XULEN)
FOR
IF XUN'?.E1" "
QUIT
SET XUN=$EXTRACT(XUN,1,$LENGTH(XUN)-1)
End DoDot:1
IF $LENGTH(XUN)'>XULEN
QUIT
+68 QUIT XUN
+69 ;
MIX(X) ; Return name part with only first letter upper-case
+1 NEW %,L
+2 FOR %=2:1:$LENGTH(X)
IF $EXTRACT(X,%)?1U
IF $EXTRACT(X,%-1)?1A
SET L=$EXTRACT(X,%)
SET L=$CHAR($ASCII(L)+32)
SET $EXTRACT(X,%)=L
+3 QUIT X
+4 ;
MIX2(XUN) ; Properly capitalize suffixes, degrees
+1 NEW P,I,L,DIOUT
+2 FOR P="DR","PHD","JR","SR","ESQ"
SET I=$FIND(XUN,P)
IF I
Begin DoDot:1
+3 IF $EXTRACT(XUN,I)?1A
QUIT
+4 IF P="PHD"
IF $EXTRACT(XUN,I-4)?1A
QUIT
SET $EXTRACT(XUN,I-3,I-1)="PhD"
QUIT
+5 SET L=$LENGTH(P)
IF $EXTRACT(XUN,I-(L+1))?1A
QUIT
+6 SET X=$$MIX($EXTRACT(XUN,I-L,I-1))
SET $EXTRACT(XUN,I-L,I-1)=X
+7 QUIT
End DoDot:1
+8 IF XUN?.E1.N1.U.E
SET DIOUT=0
FOR P=1:1:10
SET I=$FIND(XUN,P)
IF I
Begin DoDot:1
+9 SET L=$SELECT(P=1:"ST",P=2:"ND",P=3:"RD",1:"TH")
+10 IF $EXTRACT(XUN,I,I+1)'=L
QUIT
+11 SET $EXTRACT(XUN,I,I+1)=$SELECT(P=1:"st",P=2:"nd",P=3:"rd",1:"th")
+12 SET DIOUT=1
QUIT
End DoDot:1
IF DIOUT
QUIT
+13 QUIT XUN
+14 ;
O(N) ;O format
+1 QUIT N("FAMILY")
+2 ;
F(N,F) ;F format
+1 NEW NAM
+2 SET NAM=N("FAMILY")_$SELECT(F["C":",",1:" ")_N("GIVEN")_$EXTRACT(" ",N("MIDDLE")]"")_N("MIDDLE")
+3 SET NAM=$$SPD(NAM,.N,F)
+4 IF NAM?.E1(1",",1" ")
SET NAM=$EXTRACT(NAM,1,$LENGTH(NAM)-1)
+5 QUIT NAM
+6 ;
G(N,F) ;G format
+1 NEW NAM,I
+2 SET NAM=""
FOR I="GIVEN","MIDDLE","FAMILY"
SET NAM=$$JOIN(NAM,N(I))
+3 QUIT $$SPD(NAM,.N,F)
+4 ;
H(N,D) ;H format
+1 NEW NAM
+2 SET NAM=N("FAMILY")_D_N("GIVEN")_D_N("MIDDLE")_D_N("SUFFIX")_D_N("PREFIX")_D_N("DEGREE")
+3 FOR
IF $EXTRACT(NAM,$LENGTH(NAM))'=D
QUIT
SET NAM=$EXTRACT(NAM,1,$LENGTH(NAM)-1)
+4 QUIT NAM
+5 ;
SPD(NAM,N,F) ;Add Suffix, Prefix, and Degree
+1 SET NAM=$$JOIN(NAM,N("SUFFIX"),$EXTRACT(",",F["Xc")_" ")
+2 IF F["P"
SET NAM=$$JOIN(N("PREFIX"),NAM)
+3 IF F["D"
SET NAM=$$JOIN(NAM,N("DEGREE"),$EXTRACT(",",F["Dc")_" ")
+4 QUIT NAM
+5 ;
JOIN(S1,S2,D) ;Return S1 joined with S2 (separate by D)
+1 IF $GET(D)=""
SET D=" "
+2 QUIT S1_$SELECT($LENGTH(S1)&$LENGTH(S2):D,1:"")_S2
+3 ;
TRUNC(NC,OVR) ;Truncate component
+1 SET NC=$EXTRACT(NC,1,$SELECT($LENGTH(NC)>OVR:$LENGTH(NC)-OVR,1:1))
+2 FOR
IF NC'?.E1" "
QUIT
SET NC=$EXTRACT(NC,1,$LENGTH(NC)-1)
+3 QUIT NC
