XLFNAME ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;03/31/15 09:30
;;8.0;KERNEL;**134,211,240,655**;Jul 10, 1995;Build 16
;Per VA Directive 6402, this routine should not be modified.
;
STDNAME(XUNAME,XUFLAG,XUAUD) ;Standardize name XUNAME
; XUNAME - In, name to be standardized. Out, standardized name
; XUFLAG - In, "C" : return components in XUNAME array
; "F" : Assume input is in general form
; Family,Given Middle Suffix
; "G" : Don't return XUAUD("GIVEN")
; "P" : Remove parenthetical text
;.XUAUD - Out:
; XUAUD = original name passed in
; XUAUD(subsc)="" if problems
;
N I,XUFAM,XUNM,XUOUT,XUMOV,XUREST,XUSP
S XUOUT=$G(XUFLAG)["C"
N:XUOUT XUFAMO,XURESTO
S XUNAME=$TR(XUNAME,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
K XUAUD S XUAUD=XUNAME
;
F I="FAMILY","GIVEN","MIDDLE","SUFFIX" S XUNM(I)="" S:XUOUT XUOUT(I)=""
S:XUNAME?.E1" TEST" XUNAME=$E(XUNAME,1,$L(XUNAME)-5)
;
I $G(XUFLAG)["P",XUNAME?.E1(1"(",1"[",1"{").E D
. S XUNAME=$$PARENS^XLFNAME1(XUNAME)
. S:XUAUD'=XUNAME XUAUD("STRIP")=""
;
S:XUNAME?1"EEE".E!(XUNAME?.E1" FEE")!(XUNAME?1A1"-".E) XUAUD("NOTE")=""
;
;If no comma, assume given name first (also no "F")
I XUNAME'[",",$G(XUFLAG)'["F" G GIVFRST
;
;Standardize Family
;(don't remove internal spaces or convert suffixes yet)
I $E(XUNAME,1,3)="ST." S XUAUD("FAMILY")=""
S XUFAM=$$CLEANC^XLFNAME1($P(XUNAME,","),"FI",.XUAUD)
S XUFAM=$$PUNC(XUFAM,.XUAUD)
D:XUOUT
. S XUFAMO=$$CLEANC^XLFNAME1($P(XUNAME,","),"FO",.XUAUD)
. S XUFAMO=$$PUNC(XUFAMO,.XUAUD)
;
;Look for suffixes at end of Family
D SUFEND^XLFNAME1(.XUFAM,.XUFAMO,.XUNM,.XUOUT,.XUAUD)
S:XUNM("SUFFIX")]"" XUAUD("SUFFIX")=""
S XUNM("FAMILY")=XUFAM S:XUOUT XUOUT("FAMILY")=XUFAMO
;
;Parse rest of name
S XUREST=$P(XUNAME,",",2,999)
S XUSP=XUREST?1" "1.E
D:XUOUT
. S XURESTO=$$CLEANC^XLFNAME1(XUREST,"O",.XUAUD)
. S XURESTO=$$PUNC(XUREST,.XUAUD)
S XUREST=$$CLEANC^XLFNAME1(XUREST,"I",.XUAUD)
S XUREST=$$PUNC(XUREST,.XUAUD)
D MOVSUF(.XUREST,.XUOUT,.XURESTO,.XUAUD,.XUMOV)
D N2(XUREST,.XUNM,.XUOUT,$G(XURESTO),.XUAUD)
;
;Account for names that look like only Family and Suffix(es)
I XUNM("MIDDLE")="",$$CHKSUF^XLFNAME1(XUNM("GIVEN"))]"" D
. N XUCNT,XUSUF1,XUSUF2
. I 'XUSP Q:$E(XUNM("GIVEN"))'?1N
. S XUCNT=$L(XUNM("SUFFIX")," ")
. S XUSUF1=$P(XUNM("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
. S XUSUF2=$P(XUNM("SUFFIX")," ",1,XUCNT-XUMOV)
. S XUNM("SUFFIX")=$$JOIN($$JOIN(XUSUF1,$$ROMAN^XLFNAME1(XUNM("GIVEN"))),XUSUF2)
. S XUNM("GIVEN")=""
. D:XUOUT
.. S XUSUF1=$P(XUOUT("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
.. S XUSUF2=$P(XUOUT("SUFFIX")," ",1,XUCNT-XUMOV)
.. S XUOUT("SUFFIX")=$$JOIN($$JOIN(XUSUF1,XUOUT("GIVEN")),XUSUF2)
.. S XUOUT("GIVEN")=""
;
D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
K:$G(XUFLAG)["G" XUAUD("GIVEN")
Q
;
BLDSTD(XUNAME,XUNM,XUOUT,XUAUD) ;Build standard name in XUNAME
;Put components in XUNAME array
N I,J
K XUNAME M:XUOUT XUNAME=XUOUT
;
S XUNAME=XUNM("FAMILY")_","
S:XUNAME[" " XUNAME=$TR(XUNAME," "),XUAUD("SPACE")=""
;
I XUNM("GIVEN")]"" S XUNAME=XUNAME_XUNM("GIVEN")
E S XUAUD("GIVEN")=""
S:XUNM("MIDDLE")]"" XUNAME=XUNAME_" "_XUNM("MIDDLE")
S:XUNM("SUFFIX")]"" XUNAME=XUNAME_" "_XUNM("SUFFIX")
S:XUNAME?.E1"," XUNAME=$E(XUNAME,1,$L(XUNAME)-1)
S:XUNAME?.E1N.E XUAUD("NUMBER")=""
;
;Remove spaces after periods, and ~ and ^, in name components
I XUOUT S I="" F S I=$O(XUNAME(I)) Q:I="" D
. S XUNAME(I)=$TR(XUNAME(I),"`^") Q:XUNAME(I)'[". "
. N J S J=0 F S J=$F(XUNAME(I),". ",J) Q:'J S $E(XUNAME(I),J-1)=""
Q
;
GIVFRST ;Come here if name has no comma.
N XUCNT,XUNAM,XUNAMO
;
;Do initial standardizing
S XUNAM=$$CLEANC^XLFNAME1(XUNAME,"I",.XUAUD)
S XUNAM=$$PUNC(XUNAME,.XUAUD)
D:XUOUT
. S XUNAMO=$$CLEANC^XLFNAME1(XUNAME,"O",.XUAUD)
. S XUNAMO=$$PUNC(XUNAMO,.XUAUD)
;
;Look for suffixes at end
D SUFEND^XLFNAME1(.XUNAM,.XUNAMO,.XUNM,.XUOUT,.XUAUD)
S XUCNT=$L(XUNAM," ")
;
;If name contains only suffixes, make first suffix the Family Name
I XUCNT=0 D Q
. S XUNM("FAMILY")=$P(XUNM("SUFFIX")," ")
. S XUNM("SUFFIX")=$P(XUNM("SUFFIX")," ",2,999)
. S:$G(XUFLAG)'["G" XUAUD("GIVEN")=""
. D:XUOUT
.. S XUOUT("FAMILY")=$P(XUOUT("SUFFIX")," ")
.. S XUOUT("SUFFIX")=$P(XUOUT("SUFFIX")," ",2,999)
. D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
;
;Set Family and rest of name
S XUNM("FAMILY")=$P(XUNAM," ",XUCNT),XUREST=$P(XUNAM," ",1,XUCNT-1)
S:XUOUT XUOUT("FAMILY")=$P(XUNAMO," ",XUCNT),XURESTO=$P(XUNAMO," ",1,XUCNT-1)
;
;Process rest of name (don't look for suffixes)
D N2(XUREST,.XUNM,.XUOUT,$G(XURESTO),.XUAUD,"s")
D BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
K:$G(XUFLAG)["G" XUAUD("GIVEN")
Q
;
NAMECOMP(XUNM) ;Build components from standard name
S XUNM("FAMILY")=$P(XUNM,",")
D N2($P(XUNM,",",2,999),.XUNM)
S XUNM("MIDDLE")=$G(XUNM("MIDDLE"))
S XUNM("SUFFIX")=$G(XUNM("SUFFIX"))
Q
;
MOVSUF(XUREST,XUOUT,XURESTO,XUAUD,XUMOV) ;Move suffixes immediately in front to the end
N XUI,XUCNT
S XUCNT=$L(XUREST," "),XUMOV=0
F XUI=1:1:XUCNT I $$CHKSUF1^XLFNAME1($P(XUREST," ",XUI))="" S XUI=XUI-1 Q
I XUI,XUI<XUCNT D
. S XUMOV=XUI
. S XUREST=$P(XUREST," ",XUI+1,999)_" "_$P(XUREST," ",1,XUI)
. S:XUOUT XURESTO=$P(XURESTO," ",XUI+1,999)_" "_$P(XURESTO," ",1,XUI)
. S XUAUD("SUFFIX")=""
Q
;
PUNC(XUNAME,XUAUD) ;Remove name pieces that are purely punctuation
N XUC,XUI,XUNEW
S XUNEW=""
F XUI=1:1:$L(XUNAME," ") D
. S XUC=$P(XUNAME," ",XUI)
. I XUC?1.P S:XUC'?1."." XUAUD("PUNC")="" Q
. S XUNEW=$$JOIN(XUNEW,XUC)
Q XUNEW
;
N2(XUREST,XUNM,XUOUT,XURESTO,XUAUD,XUFLAG) ;Build components from non-family name
N XUCNT,XUGIVEN,XUI,XUMIDDLE,XUSUF,XUSUFFIX,XUX,X
S XUOUT=$G(XUOUT) N:XUOUT XUGIVENO,XUMIDO,XUSUFO,XUXO
S XUCNT=$L(XUREST," ")
;
;Get Given from 1st space-piece, quit if only name
S XUNM("GIVEN")=$P(XUREST," ") S:XUOUT XUOUT("GIVEN")=$P(XURESTO," ")
Q:XUCNT<2
;
S (XUSUF,XUMIDDLE,XUGIVEN)="" S:XUOUT (XUSUFO,XUMIDO,XUGIVENO)=""
;
F XUI=XUCNT:-1:2 D
. S XUX=$P(XUREST," ",XUI)
. S:XUOUT XUXO=$P(XURESTO," ",XUI)
. ;
. ;If no middle yet, check for suffix
. I XUMIDDLE="",$G(XUFLAG)'["s" D Q:XUSUFFIX]""
.. S XUSUFFIX=""
.. I XUI=2,"I^V^X"[XUX S XUAUD("SUFFIX")="" Q
.. I XUI>2,XUX="D",$P(XUREST," ",XUI-1)="M" S XUAUD("SUFFIX")="" Q
.. S XUSUFFIX=$$CHKSUF^XLFNAME1(XUX) Q:XUSUFFIX=""
.. S X=XUSUFFIX,XUSUFFIX=$$ROMAN^XLFNAME1(XUSUFFIX)
.. I XUI=2,X=XUSUFFIX S XUAUD("SUFFIX")=""
.. S XUSUF=$$JOIN(XUSUFFIX,XUSUF)
.. S:XUOUT XUSUFO=$$JOIN(XUXO,XUSUFO)
. ;
. ;If not suffix, and no middle, set middle
. I XUMIDDLE="" S XUMIDDLE=XUX S:XUOUT XUMIDO=XUXO Q
. ;
. ;Otherwise, put in Given
. S:XUI=2 XUAUD("MIDDLE")=""
. S XUGIVEN=$$JOIN(XUX,XUGIVEN)
. S:XUOUT XUGIVENO=$$JOIN(XUXO,XUGIVENO)
;
D:XUSUF]""
. S XUNM("SUFFIX")=$$JOIN($G(XUNM("SUFFIX")),XUSUF)
. S:XUOUT XUOUT("SUFFIX")=$$JOIN($G(XUOUT("SUFFIX")),XUSUFO)
;
S XUNM("MIDDLE")=XUMIDDLE
S:XUOUT XUOUT("MIDDLE")=XUMIDO
D:"^NMI^NMN^"[(U_XUNM("MIDDLE")_U)
. S XUNM("MIDDLE")="" S:XUOUT XUOUT("MIDDLE")=""
. S XUAUD("NM")=""
;
D:XUGIVEN]""
. S XUNM("GIVEN")=XUNM("GIVEN")_" "_XUGIVEN
. S:XUOUT XUOUT("GIVEN")=XUOUT("GIVEN")_" "_XUGIVENO
Q
;
JOIN(S1,S2) ;Return S1 joined with S2 (separate by a space)
Q $G(S1)_$E(" ",$G(S1)]""&($G(S2)]""))_$G(S2)
;
NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ;Name formatting routine
G NAMEFMTX^XLFNAME1
;
CLEANC(XUPART,XUFLAG,XUAUD) ;Component standardization
G CLEANCX^XLFNAME1
;
BLDNAME(XUNC,XUMAX) ;Build standard name from components
Q $$NAMEFMT(.XUNC,"F","CSL"_+$G(XUMAX))
;
HLNAME(XUNAME,XUFLAG,XUDLM) ;Convert name to HL7 format
N XUF
S XUF=$E("S",$G(XUFLAG)["S")
S:$G(XUFLAG)["L" XUF=XUF_"L"_+$P(XUFLAG,"L",2)
Q $$NAMEFMT^XLFNAME(.XUNAME,"H",XUF,$G(XUDLM))
;
FMNAME(XUNAME,XUFLAG,XUDLM) ;Convert HL7 name string to standard name or name components
G F^XLFNAME6
;
PRE ;Pre-install for patch XU*8.0*134
G PRE^XLFNAME3
;
POST ;Post-install for XU*8.0*134 (conversion)
G POST^XLFNAME3
;
GENERATE ;Generate information in ^XTMP about changes that will take
;place when CONVERT^XLFNAME is run
G GENERATE^XLFNAME5
;
PRINT ;Print the information in ^XTMP
G PRINT^XLFNAME4
;
CONVERT ;Convert the Names in the New Person file
G CONVERT^XLFNAME5
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFNAME 8452 printed Dec 13, 2024@02:02:52 Page 2
XLFNAME ;CIOFO-SF/TKW,MKO-Utilities for person name fields ;03/31/15 09:30
+1 ;;8.0;KERNEL;**134,211,240,655**;Jul 10, 1995;Build 16
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
STDNAME(XUNAME,XUFLAG,XUAUD) ;Standardize name XUNAME
+1 ; XUNAME - In, name to be standardized. Out, standardized name
+2 ; XUFLAG - In, "C" : return components in XUNAME array
+3 ; "F" : Assume input is in general form
+4 ; Family,Given Middle Suffix
+5 ; "G" : Don't return XUAUD("GIVEN")
+6 ; "P" : Remove parenthetical text
+7 ;.XUAUD - Out:
+8 ; XUAUD = original name passed in
+9 ; XUAUD(subsc)="" if problems
+10 ;
+11 NEW I,XUFAM,XUNM,XUOUT,XUMOV,XUREST,XUSP
+12 SET XUOUT=$GET(XUFLAG)["C"
+13 if XUOUT
NEW XUFAMO,XURESTO
+14 SET XUNAME=$TRANSLATE(XUNAME,"abcdefghijklmnopqrstuvwxyz","ABCDEFGHIJKLMNOPQRSTUVWXYZ")
+15 KILL XUAUD
SET XUAUD=XUNAME
+16 ;
+17 FOR I="FAMILY","GIVEN","MIDDLE","SUFFIX"
SET XUNM(I)=""
if XUOUT
SET XUOUT(I)=""
+18 if XUNAME?.E1" TEST"
SET XUNAME=$EXTRACT(XUNAME,1,$LENGTH(XUNAME)-5)
+19 ;
+20 IF $GET(XUFLAG)["P"
IF XUNAME?.E1(1"(",1"[",1"{").E
Begin DoDot:1
+21 SET XUNAME=$$PARENS^XLFNAME1(XUNAME)
+22 if XUAUD'=XUNAME
SET XUAUD("STRIP")=""
End DoDot:1
+23 ;
+24 if XUNAME?1"EEE".E!(XUNAME?.E1" FEE")!(XUNAME?1A1"-".E)
SET XUAUD("NOTE")=""
+25 ;
+26 ;If no comma, assume given name first (also no "F")
+27 IF XUNAME'[","
IF $GET(XUFLAG)'["F"
GOTO GIVFRST
+28 ;
+29 ;Standardize Family
+30 ;(don't remove internal spaces or convert suffixes yet)
+31 IF $EXTRACT(XUNAME,1,3)="ST."
SET XUAUD("FAMILY")=""
+32 SET XUFAM=$$CLEANC^XLFNAME1($PIECE(XUNAME,","),"FI",.XUAUD)
+33 SET XUFAM=$$PUNC(XUFAM,.XUAUD)
+34 if XUOUT
Begin DoDot:1
+35 SET XUFAMO=$$CLEANC^XLFNAME1($PIECE(XUNAME,","),"FO",.XUAUD)
+36 SET XUFAMO=$$PUNC(XUFAMO,.XUAUD)
End DoDot:1
+37 ;
+38 ;Look for suffixes at end of Family
+39 DO SUFEND^XLFNAME1(.XUFAM,.XUFAMO,.XUNM,.XUOUT,.XUAUD)
+40 if XUNM("SUFFIX")]""
SET XUAUD("SUFFIX")=""
+41 SET XUNM("FAMILY")=XUFAM
if XUOUT
SET XUOUT("FAMILY")=XUFAMO
+42 ;
+43 ;Parse rest of name
+44 SET XUREST=$PIECE(XUNAME,",",2,999)
+45 SET XUSP=XUREST?1" "1.E
+46 if XUOUT
Begin DoDot:1
+47 SET XURESTO=$$CLEANC^XLFNAME1(XUREST,"O",.XUAUD)
+48 SET XURESTO=$$PUNC(XUREST,.XUAUD)
End DoDot:1
+49 SET XUREST=$$CLEANC^XLFNAME1(XUREST,"I",.XUAUD)
+50 SET XUREST=$$PUNC(XUREST,.XUAUD)
+51 DO MOVSUF(.XUREST,.XUOUT,.XURESTO,.XUAUD,.XUMOV)
+52 DO N2(XUREST,.XUNM,.XUOUT,$GET(XURESTO),.XUAUD)
+53 ;
+54 ;Account for names that look like only Family and Suffix(es)
+55 IF XUNM("MIDDLE")=""
IF $$CHKSUF^XLFNAME1(XUNM("GIVEN"))]""
Begin DoDot:1
+56 NEW XUCNT,XUSUF1,XUSUF2
+57 IF 'XUSP
if $EXTRACT(XUNM("GIVEN"))'?1N
QUIT
+58 SET XUCNT=$LENGTH(XUNM("SUFFIX")," ")
+59 SET XUSUF1=$PIECE(XUNM("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
+60 SET XUSUF2=$PIECE(XUNM("SUFFIX")," ",1,XUCNT-XUMOV)
+61 SET XUNM("SUFFIX")=$$JOIN($$JOIN(XUSUF1,$$ROMAN^XLFNAME1(XUNM("GIVEN"))),XUSUF2)
+62 SET XUNM("GIVEN")=""
+63 if XUOUT
Begin DoDot:2
+64 SET XUSUF1=$PIECE(XUOUT("SUFFIX")," ",XUCNT-XUMOV+1,XUCNT)
+65 SET XUSUF2=$PIECE(XUOUT("SUFFIX")," ",1,XUCNT-XUMOV)
+66 SET XUOUT("SUFFIX")=$$JOIN($$JOIN(XUSUF1,XUOUT("GIVEN")),XUSUF2)
+67 SET XUOUT("GIVEN")=""
End DoDot:2
End DoDot:1
+68 ;
+69 DO BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
+70 if $GET(XUFLAG)["G"
KILL XUAUD("GIVEN")
+71 QUIT
+72 ;
BLDSTD(XUNAME,XUNM,XUOUT,XUAUD) ;Build standard name in XUNAME
+1 ;Put components in XUNAME array
+2 NEW I,J
+3 KILL XUNAME
if XUOUT
MERGE XUNAME=XUOUT
+4 ;
+5 SET XUNAME=XUNM("FAMILY")_","
+6 if XUNAME[" "
SET XUNAME=$TRANSLATE(XUNAME," ")
SET XUAUD("SPACE")=""
+7 ;
+8 IF XUNM("GIVEN")]""
SET XUNAME=XUNAME_XUNM("GIVEN")
+9 IF '$TEST
SET XUAUD("GIVEN")=""
+10 if XUNM("MIDDLE")]""
SET XUNAME=XUNAME_" "_XUNM("MIDDLE")
+11 if XUNM("SUFFIX")]""
SET XUNAME=XUNAME_" "_XUNM("SUFFIX")
+12 if XUNAME?.E1","
SET XUNAME=$EXTRACT(XUNAME,1,$LENGTH(XUNAME)-1)
+13 if XUNAME?.E1N.E
SET XUAUD("NUMBER")=""
+14 ;
+15 ;Remove spaces after periods, and ~ and ^, in name components
+16 IF XUOUT
SET I=""
FOR
SET I=$ORDER(XUNAME(I))
if I=""
QUIT
Begin DoDot:1
+17 SET XUNAME(I)=$TRANSLATE(XUNAME(I),"`^")
if XUNAME(I)'[". "
QUIT
+18 NEW J
SET J=0
FOR
SET J=$FIND(XUNAME(I),". ",J)
if 'J
QUIT
SET $EXTRACT(XUNAME(I),J-1)=""
End DoDot:1
+19 QUIT
+20 ;
GIVFRST ;Come here if name has no comma.
+1 NEW XUCNT,XUNAM,XUNAMO
+2 ;
+3 ;Do initial standardizing
+4 SET XUNAM=$$CLEANC^XLFNAME1(XUNAME,"I",.XUAUD)
+5 SET XUNAM=$$PUNC(XUNAME,.XUAUD)
+6 if XUOUT
Begin DoDot:1
+7 SET XUNAMO=$$CLEANC^XLFNAME1(XUNAME,"O",.XUAUD)
+8 SET XUNAMO=$$PUNC(XUNAMO,.XUAUD)
End DoDot:1
+9 ;
+10 ;Look for suffixes at end
+11 DO SUFEND^XLFNAME1(.XUNAM,.XUNAMO,.XUNM,.XUOUT,.XUAUD)
+12 SET XUCNT=$LENGTH(XUNAM," ")
+13 ;
+14 ;If name contains only suffixes, make first suffix the Family Name
+15 IF XUCNT=0
Begin DoDot:1
+16 SET XUNM("FAMILY")=$PIECE(XUNM("SUFFIX")," ")
+17 SET XUNM("SUFFIX")=$PIECE(XUNM("SUFFIX")," ",2,999)
+18 if $GET(XUFLAG)'["G"
SET XUAUD("GIVEN")=""
+19 if XUOUT
Begin DoDot:2
+20 SET XUOUT("FAMILY")=$PIECE(XUOUT("SUFFIX")," ")
+21 SET XUOUT("SUFFIX")=$PIECE(XUOUT("SUFFIX")," ",2,999)
End DoDot:2
+22 DO BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
End DoDot:1
QUIT
+23 ;
+24 ;Set Family and rest of name
+25 SET XUNM("FAMILY")=$PIECE(XUNAM," ",XUCNT)
SET XUREST=$PIECE(XUNAM," ",1,XUCNT-1)
+26 if XUOUT
SET XUOUT("FAMILY")=$PIECE(XUNAMO," ",XUCNT)
SET XURESTO=$PIECE(XUNAMO," ",1,XUCNT-1)
+27 ;
+28 ;Process rest of name (don't look for suffixes)
+29 DO N2(XUREST,.XUNM,.XUOUT,$GET(XURESTO),.XUAUD,"s")
+30 DO BLDSTD(.XUNAME,.XUNM,.XUOUT,.XUAUD)
+31 if $GET(XUFLAG)["G"
KILL XUAUD("GIVEN")
+32 QUIT
+33 ;
NAMECOMP(XUNM) ;Build components from standard name
+1 SET XUNM("FAMILY")=$PIECE(XUNM,",")
+2 DO N2($PIECE(XUNM,",",2,999),.XUNM)
+3 SET XUNM("MIDDLE")=$GET(XUNM("MIDDLE"))
+4 SET XUNM("SUFFIX")=$GET(XUNM("SUFFIX"))
+5 QUIT
+6 ;
MOVSUF(XUREST,XUOUT,XURESTO,XUAUD,XUMOV) ;Move suffixes immediately in front to the end
+1 NEW XUI,XUCNT
+2 SET XUCNT=$LENGTH(XUREST," ")
SET XUMOV=0
+3 FOR XUI=1:1:XUCNT
IF $$CHKSUF1^XLFNAME1($PIECE(XUREST," ",XUI))=""
SET XUI=XUI-1
QUIT
+4 IF XUI
IF XUI<XUCNT
Begin DoDot:1
+5 SET XUMOV=XUI
+6 SET XUREST=$PIECE(XUREST," ",XUI+1,999)_" "_$PIECE(XUREST," ",1,XUI)
+7 if XUOUT
SET XURESTO=$PIECE(XURESTO," ",XUI+1,999)_" "_$PIECE(XURESTO," ",1,XUI)
+8 SET XUAUD("SUFFIX")=""
End DoDot:1
+9 QUIT
+10 ;
PUNC(XUNAME,XUAUD) ;Remove name pieces that are purely punctuation
+1 NEW XUC,XUI,XUNEW
+2 SET XUNEW=""
+3 FOR XUI=1:1:$LENGTH(XUNAME," ")
Begin DoDot:1
+4 SET XUC=$PIECE(XUNAME," ",XUI)
+5 IF XUC?1.P
if XUC'?1."."
SET XUAUD("PUNC")=""
QUIT
+6 SET XUNEW=$$JOIN(XUNEW,XUC)
End DoDot:1
+7 QUIT XUNEW
+8 ;
N2(XUREST,XUNM,XUOUT,XURESTO,XUAUD,XUFLAG) ;Build components from non-family name
+1 NEW XUCNT,XUGIVEN,XUI,XUMIDDLE,XUSUF,XUSUFFIX,XUX,X
+2 SET XUOUT=$GET(XUOUT)
if XUOUT
NEW XUGIVENO,XUMIDO,XUSUFO,XUXO
+3 SET XUCNT=$LENGTH(XUREST," ")
+4 ;
+5 ;Get Given from 1st space-piece, quit if only name
+6 SET XUNM("GIVEN")=$PIECE(XUREST," ")
if XUOUT
SET XUOUT("GIVEN")=$PIECE(XURESTO," ")
+7 if XUCNT<2
QUIT
+8 ;
+9 SET (XUSUF,XUMIDDLE,XUGIVEN)=""
if XUOUT
SET (XUSUFO,XUMIDO,XUGIVENO)=""
+10 ;
+11 FOR XUI=XUCNT:-1:2
Begin DoDot:1
+12 SET XUX=$PIECE(XUREST," ",XUI)
+13 if XUOUT
SET XUXO=$PIECE(XURESTO," ",XUI)
+14 ;
+15 ;If no middle yet, check for suffix
+16 IF XUMIDDLE=""
IF $GET(XUFLAG)'["s"
Begin DoDot:2
+17 SET XUSUFFIX=""
+18 IF XUI=2
IF "I^V^X"[XUX
SET XUAUD("SUFFIX")=""
QUIT
+19 IF XUI>2
IF XUX="D"
IF $PIECE(XUREST," ",XUI-1)="M"
SET XUAUD("SUFFIX")=""
QUIT
+20 SET XUSUFFIX=$$CHKSUF^XLFNAME1(XUX)
if XUSUFFIX=""
QUIT
+21 SET X=XUSUFFIX
SET XUSUFFIX=$$ROMAN^XLFNAME1(XUSUFFIX)
+22 IF XUI=2
IF X=XUSUFFIX
SET XUAUD("SUFFIX")=""
+23 SET XUSUF=$$JOIN(XUSUFFIX,XUSUF)
+24 if XUOUT
SET XUSUFO=$$JOIN(XUXO,XUSUFO)
End DoDot:2
if XUSUFFIX]""
QUIT
+25 ;
+26 ;If not suffix, and no middle, set middle
+27 IF XUMIDDLE=""
SET XUMIDDLE=XUX
if XUOUT
SET XUMIDO=XUXO
QUIT
+28 ;
+29 ;Otherwise, put in Given
+30 if XUI=2
SET XUAUD("MIDDLE")=""
+31 SET XUGIVEN=$$JOIN(XUX,XUGIVEN)
+32 if XUOUT
SET XUGIVENO=$$JOIN(XUXO,XUGIVENO)
End DoDot:1
+33 ;
+34 if XUSUF]""
Begin DoDot:1
+35 SET XUNM("SUFFIX")=$$JOIN($GET(XUNM("SUFFIX")),XUSUF)
+36 if XUOUT
SET XUOUT("SUFFIX")=$$JOIN($GET(XUOUT("SUFFIX")),XUSUFO)
End DoDot:1
+37 ;
+38 SET XUNM("MIDDLE")=XUMIDDLE
+39 if XUOUT
SET XUOUT("MIDDLE")=XUMIDO
+40 if "^NMI^NMN^"[(U_XUNM("MIDDLE")_U)
Begin DoDot:1
+41 SET XUNM("MIDDLE")=""
if XUOUT
SET XUOUT("MIDDLE")=""
+42 SET XUAUD("NM")=""
End DoDot:1
+43 ;
+44 if XUGIVEN]""
Begin DoDot:1
+45 SET XUNM("GIVEN")=XUNM("GIVEN")_" "_XUGIVEN
+46 if XUOUT
SET XUOUT("GIVEN")=XUOUT("GIVEN")_" "_XUGIVENO
End DoDot:1
+47 QUIT
+48 ;
JOIN(S1,S2) ;Return S1 joined with S2 (separate by a space)
+1 QUIT $GET(S1)_$EXTRACT(" ",$GET(S1)]""&($GET(S2)]""))_$GET(S2)
+2 ;
NAMEFMT(XUNAME,XUFMT,XUFLAG,XUDLM) ;Name formatting routine
+1 GOTO NAMEFMTX^XLFNAME1
+2 ;
CLEANC(XUPART,XUFLAG,XUAUD) ;Component standardization
+1 GOTO CLEANCX^XLFNAME1
+2 ;
BLDNAME(XUNC,XUMAX) ;Build standard name from components
+1 QUIT $$NAMEFMT(.XUNC,"F","CSL"_+$GET(XUMAX))
+2 ;
HLNAME(XUNAME,XUFLAG,XUDLM) ;Convert name to HL7 format
+1 NEW XUF
+2 SET XUF=$EXTRACT("S",$GET(XUFLAG)["S")
+3 if $GET(XUFLAG)["L"
SET XUF=XUF_"L"_+$PIECE(XUFLAG,"L",2)
+4 QUIT $$NAMEFMT^XLFNAME(.XUNAME,"H",XUF,$GET(XUDLM))
+5 ;
FMNAME(XUNAME,XUFLAG,XUDLM) ;Convert HL7 name string to standard name or name components
+1 GOTO F^XLFNAME6
+2 ;
PRE ;Pre-install for patch XU*8.0*134
+1 GOTO PRE^XLFNAME3
+2 ;
POST ;Post-install for XU*8.0*134 (conversion)
+1 GOTO POST^XLFNAME3
+2 ;
GENERATE ;Generate information in ^XTMP about changes that will take
+1 ;place when CONVERT^XLFNAME is run
+2 GOTO GENERATE^XLFNAME5
+3 ;
PRINT ;Print the information in ^XTMP
+1 GOTO PRINT^XLFNAME4
+2 ;
CONVERT ;Convert the Names in the New Person file
+1 GOTO CONVERT^XLFNAME5
