Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XLFNAME1

XLFNAME1.m

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