- 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 Jan 18, 2025@03:04:04 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