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
;
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 ;
