- XLFNAME7 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
- ;;8.0;KERNEL;**343**; Jul 10, 1995;
- ;
- FORMAT(XUNAME,XUMINL,XUMAXL,XUNOP,XUCOMA,XUAUDIT,XUFAM,XUDNC) ;Format name value
- ;Input: XUNAME=text value representing person name to transform
- ; XUMINL=minimum length (optional), default 3
- ; XUMAXL=maximum length (optional), default 30
- ; XUNOP=1 to standardize last name for 'NOP' x-ref
- ; (for the PAITNE file). (optional)
- ; XUCOMA=0 to not require a comma
- ; 1 to require a comma in the input value
- ; 2 to add a comma if none
- ; 3 to prohibit (remove) commas
- ; (optional) default if not specified is 1
- ;
- ; XUAUDIT=variable to return audit, pass by reference (optional),
- ; returned values:
- ; XUAUDIT=0 if no change was made
- ; 1 if name is changed
- ; 2 if name could not be converted
- ; XUAUDIT(1) defined if name contains no comma
- ; XUAUDIT(2) defined if parenthetical text is removed
- ; XUAUDIT(3) defined if value is unconvertible
- ; XUAUDIT(4) defined if characters are removed or changed
- ; XUFAM='1' if just the family name, '0' otherwise (optional)
- ; XUDNC='1' to prevent componentization (optional)
- ; ='2' to return components before standardize
- ;
- ;Output: XUNAME in specified format or null if length of transformed value is less than XUMINL
- ;
- N XUX,XUOX,XUOLDN,XUAX,XUI,XUNEWN
- ;Initialize variables
- K XUAUDIT
- S XUOLDN=XUNAME M XUX=XUNAME
- S XUDNC=$G(XUDNC) D COMP^XLFNAME8(.XUX,.XUDNC)
- S XUMINL=+$G(XUMINL) S:XUMINL<1 XUMINL=3
- S XUMAXL=+$G(XUMAXL) S:XUMAXL<XUMINL XUMAXL=30
- S XUNOP=$S($G(XUNOP)=1:"S",1:"")
- S:'$L($G(XUCOMA)) XUCOMA=1 S XUCOMA=+XUCOMA
- S XUFAM=$S($G(XUFAM)=1:"F",1:"")
- ;
- ;Check for comma
- I XUX'["," S XUAUDIT(1)=""
- I XUCOMA=1,XUX'["," S XUAUDIT=2,XUAUDIT(3)="" Q ""
- ;Clean input value
- F Q:'$$F1^XLFNAME8(.XUX,XUCOMA)
- I XUX'=XUOLDN S XUAUDIT(4)=""
- ;Add comma if necessary
- I XUCOMA=2,XUX'[" ",XUX'["," S XUX=XUX_","
- I XUX=XUOLDN K XUAUDIT(4)
- ;Quit if result is too short
- I $L(XUX)<XUMINL S XUAUDIT=2,XUAUDIT(3)="" K XUNAME Q ""
- S XUNAME=XUX I XUDNC'=1 D
- .;Parse the name
- .D STDNAME^XLFNAME(.XUX,XUFAM_"CP",.XUAX)
- .I $D(XUAX("STRIP")) S XUAUDIT(2)=""
- .I $D(XUAX("NM"))!$D(XUAX("PERIOD")) S XUAUDIT(4)=""
- .I $D(XUAX("PUNC"))!($D(XUAX("SPACE"))&'$L(XUFAM)) S XUAUDIT(4)=""
- .I $D(XUAX("SPACE")),$L(XUFAM),XUNAME'=$G(XUX("FAMILY")) S XUAUDIT(4)=""
- .;Standardize the suffix
- .S XUX("SUFFIX")=$$CLEANC^XLFNAME(XUX("SUFFIX"))
- .;Post-clean components
- .S XUI="" F S XUI=$O(XUX(XUI)) Q:XUI="" S XUX(XUI)=$$POSTC(XUX(XUI))
- .;Reconstruct name from components
- .S XUNAME=$$NAMEFMT^XLFNAME(.XUX,"F","CL"_XUMAXL_XUNOP)
- .;Adjust name for 'do not componentize'
- .;I XUDNC S XUNAME=XUX("FAMILY")
- ;Return comma for single value names
- I XUCOMA,XUCOMA'=3,XUNAME'["," S XUNAME=XUNAME_","
- ;Check length again
- I $L(XUNAME)<XUMINL S XUAUDIT=2,XUAUDIT(3)="" K XUNAME Q ""
- ;Enforce minimum 2 character last name rule
- ;I '$L(XUFAM),$L($P(XUNAME,","))<3,$P(XUNAME,",")'?2U D Q ""
- ;.S XUAUDIT=2,XUAUDIT(3)="" K XUNAME
- ;.Q
- ;Remove hyphens and apostrophes for 'NOP' x-ref
- S XUX=XUNAME I XUNOP="S" S XUNAME=$TR(XUNAME,"'-")
- I XUNAME'=XUX S XUAUDIT(4)=""
- I XUNAME=XUOLDN K XUAUDIT
- S XUAUDIT=XUNAME'=XUOLDN I XUAUDIT,$D(XUAUDIT)<10 S XUAUDIT(4)=""
- S XUNEWN=XUNAME M XUNAME=XUX S XUNAME=XUNEWN
- ;Return components before standardization if asked to
- I XUDNC=2 D
- . N XUNAMEC
- . S XUNAMEC=XUNAME
- . I XUOLDN["`" S XUOLDN=$TR(XUOLDN,"`","'")
- . D STDNAME^XLFNAME(.XUOLDN,"C")
- . M XUNAME=XUOLDN
- . S XUNAME=XUNAMEC
- Q XUNAME
- ;
- POSTC(XUX) ;Post-clean components
- ;Remove parenthesis if not removed by Kernel
- N XUI,XUXOLD
- S XUXOLD=XUX,XUX=$TR(XUX,"()[]{}")
- ;Check for numbers left behind by Kernel
- F XUI=0:1:9 S XUX=$TR(XUX,XUI)
- I XUX'=XUXOLD S XUAUDIT(4)=""
- Q XUX
- ;
- NOP(XUX) ;Produce 'NOP' x-ref value
- ;Input: XUX=name value to evaluate
- ;Output : Standardized name or null if the same as input value
- N XUNEWX
- S XUNEWX=$$FORMAT(XUX,3,30,1)
- Q $S(XUX=XUNEWX:"",1:XUNEWX)
- ;
- NARY(XU20NAME) ;Set up name array
- ;Input: XU20NAME=full name value
- ; XU20NAME(component_names)=corresponding value--if undefined,
- ; these will get set up
- ;
- N XUX M XUX=XU20NAME
- D STDNAME^XLFNAME(.XU20NAME,"FC")
- M XU20NAME=XUX
- S XU20NAME("NOTES")=$$NOTES^XLFNAME8()
- Q
- ;
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFNAME7 4608 printed Jan 18, 2025@03:04:11 Page 2
- XLFNAME7 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
- +1 ;;8.0;KERNEL;**343**; Jul 10, 1995;
- +2 ;
- FORMAT(XUNAME,XUMINL,XUMAXL,XUNOP,XUCOMA,XUAUDIT,XUFAM,XUDNC) ;Format name value
- +1 ;Input: XUNAME=text value representing person name to transform
- +2 ; XUMINL=minimum length (optional), default 3
- +3 ; XUMAXL=maximum length (optional), default 30
- +4 ; XUNOP=1 to standardize last name for 'NOP' x-ref
- +5 ; (for the PAITNE file). (optional)
- +6 ; XUCOMA=0 to not require a comma
- +7 ; 1 to require a comma in the input value
- +8 ; 2 to add a comma if none
- +9 ; 3 to prohibit (remove) commas
- +10 ; (optional) default if not specified is 1
- +11 ;
- +12 ; XUAUDIT=variable to return audit, pass by reference (optional),
- +13 ; returned values:
- +14 ; XUAUDIT=0 if no change was made
- +15 ; 1 if name is changed
- +16 ; 2 if name could not be converted
- +17 ; XUAUDIT(1) defined if name contains no comma
- +18 ; XUAUDIT(2) defined if parenthetical text is removed
- +19 ; XUAUDIT(3) defined if value is unconvertible
- +20 ; XUAUDIT(4) defined if characters are removed or changed
- +21 ; XUFAM='1' if just the family name, '0' otherwise (optional)
- +22 ; XUDNC='1' to prevent componentization (optional)
- +23 ; ='2' to return components before standardize
- +24 ;
- +25 ;Output: XUNAME in specified format or null if length of transformed value is less than XUMINL
- +26 ;
- +27 NEW XUX,XUOX,XUOLDN,XUAX,XUI,XUNEWN
- +28 ;Initialize variables
- +29 KILL XUAUDIT
- +30 SET XUOLDN=XUNAME
- MERGE XUX=XUNAME
- +31 SET XUDNC=$GET(XUDNC)
- DO COMP^XLFNAME8(.XUX,.XUDNC)
- +32 SET XUMINL=+$GET(XUMINL)
- if XUMINL<1
- SET XUMINL=3
- +33 SET XUMAXL=+$GET(XUMAXL)
- if XUMAXL<XUMINL
- SET XUMAXL=30
- +34 SET XUNOP=$SELECT($GET(XUNOP)=1:"S",1:"")
- +35 if '$LENGTH($GET(XUCOMA))
- SET XUCOMA=1
- SET XUCOMA=+XUCOMA
- +36 SET XUFAM=$SELECT($GET(XUFAM)=1:"F",1:"")
- +37 ;
- +38 ;Check for comma
- +39 IF XUX'[","
- SET XUAUDIT(1)=""
- +40 IF XUCOMA=1
- IF XUX'[","
- SET XUAUDIT=2
- SET XUAUDIT(3)=""
- QUIT ""
- +41 ;Clean input value
- +42 FOR
- if '$$F1^XLFNAME8(.XUX,XUCOMA)
- QUIT
- +43 IF XUX'=XUOLDN
- SET XUAUDIT(4)=""
- +44 ;Add comma if necessary
- +45 IF XUCOMA=2
- IF XUX'[" "
- IF XUX'[","
- SET XUX=XUX_","
- +46 IF XUX=XUOLDN
- KILL XUAUDIT(4)
- +47 ;Quit if result is too short
- +48 IF $LENGTH(XUX)<XUMINL
- SET XUAUDIT=2
- SET XUAUDIT(3)=""
- KILL XUNAME
- QUIT ""
- +49 SET XUNAME=XUX
- IF XUDNC'=1
- Begin DoDot:1
- +50 ;Parse the name
- +51 DO STDNAME^XLFNAME(.XUX,XUFAM_"CP",.XUAX)
- +52 IF $DATA(XUAX("STRIP"))
- SET XUAUDIT(2)=""
- +53 IF $DATA(XUAX("NM"))!$DATA(XUAX("PERIOD"))
- SET XUAUDIT(4)=""
- +54 IF $DATA(XUAX("PUNC"))!($DATA(XUAX("SPACE"))&'$LENGTH(XUFAM))
- SET XUAUDIT(4)=""
- +55 IF $DATA(XUAX("SPACE"))
- IF $LENGTH(XUFAM)
- IF XUNAME'=$GET(XUX("FAMILY"))
- SET XUAUDIT(4)=""
- +56 ;Standardize the suffix
- +57 SET XUX("SUFFIX")=$$CLEANC^XLFNAME(XUX("SUFFIX"))
- +58 ;Post-clean components
- +59 SET XUI=""
- FOR
- SET XUI=$ORDER(XUX(XUI))
- if XUI=""
- QUIT
- SET XUX(XUI)=$$POSTC(XUX(XUI))
- +60 ;Reconstruct name from components
- +61 SET XUNAME=$$NAMEFMT^XLFNAME(.XUX,"F","CL"_XUMAXL_XUNOP)
- +62 ;Adjust name for 'do not componentize'
- +63 ;I XUDNC S XUNAME=XUX("FAMILY")
- End DoDot:1
- +64 ;Return comma for single value names
- +65 IF XUCOMA
- IF XUCOMA'=3
- IF XUNAME'[","
- SET XUNAME=XUNAME_","
- +66 ;Check length again
- +67 IF $LENGTH(XUNAME)<XUMINL
- SET XUAUDIT=2
- SET XUAUDIT(3)=""
- KILL XUNAME
- QUIT ""
- +68 ;Enforce minimum 2 character last name rule
- +69 ;I '$L(XUFAM),$L($P(XUNAME,","))<3,$P(XUNAME,",")'?2U D Q ""
- +70 ;.S XUAUDIT=2,XUAUDIT(3)="" K XUNAME
- +71 ;.Q
- +72 ;Remove hyphens and apostrophes for 'NOP' x-ref
- +73 SET XUX=XUNAME
- IF XUNOP="S"
- SET XUNAME=$TRANSLATE(XUNAME,"'-")
- +74 IF XUNAME'=XUX
- SET XUAUDIT(4)=""
- +75 IF XUNAME=XUOLDN
- KILL XUAUDIT
- +76 SET XUAUDIT=XUNAME'=XUOLDN
- IF XUAUDIT
- IF $DATA(XUAUDIT)<10
- SET XUAUDIT(4)=""
- +77 SET XUNEWN=XUNAME
- MERGE XUNAME=XUX
- SET XUNAME=XUNEWN
- +78 ;Return components before standardization if asked to
- +79 IF XUDNC=2
- Begin DoDot:1
- +80 NEW XUNAMEC
- +81 SET XUNAMEC=XUNAME
- +82 IF XUOLDN["`"
- SET XUOLDN=$TRANSLATE(XUOLDN,"`","'")
- +83 DO STDNAME^XLFNAME(.XUOLDN,"C")
- +84 MERGE XUNAME=XUOLDN
- +85 SET XUNAME=XUNAMEC
- End DoDot:1
- +86 QUIT XUNAME
- +87 ;
- POSTC(XUX) ;Post-clean components
- +1 ;Remove parenthesis if not removed by Kernel
- +2 NEW XUI,XUXOLD
- +3 SET XUXOLD=XUX
- SET XUX=$TRANSLATE(XUX,"()[]{}")
- +4 ;Check for numbers left behind by Kernel
- +5 FOR XUI=0:1:9
- SET XUX=$TRANSLATE(XUX,XUI)
- +6 IF XUX'=XUXOLD
- SET XUAUDIT(4)=""
- +7 QUIT XUX
- +8 ;
- NOP(XUX) ;Produce 'NOP' x-ref value
- +1 ;Input: XUX=name value to evaluate
- +2 ;Output : Standardized name or null if the same as input value
- +3 NEW XUNEWX
- +4 SET XUNEWX=$$FORMAT(XUX,3,30,1)
- +5 QUIT $SELECT(XUX=XUNEWX:"",1:XUNEWX)
- +6 ;
- NARY(XU20NAME) ;Set up name array
- +1 ;Input: XU20NAME=full name value
- +2 ; XU20NAME(component_names)=corresponding value--if undefined,
- +3 ; these will get set up
- +4 ;
- +5 NEW XUX
- MERGE XUX=XU20NAME
- +6 DO STDNAME^XLFNAME(.XU20NAME,"FC")
- +7 MERGE XU20NAME=XUX
- +8 SET XU20NAME("NOTES")=$$NOTES^XLFNAME8()
- +9 QUIT
- +10 ;