source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XLFNAME7.m@ 1582

Last change on this file since 1582 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 4.4 KB
Line 
1XLFNAME7 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
2 ;;8.0;KERNEL;**343**; Jul 10, 1995;
3 ;
4FORMAT(XUNAME,XUMINL,XUMAXL,XUNOP,XUCOMA,XUAUDIT,XUFAM,XUDNC) ;Format name value
5 ;Input: XUNAME=text value representing person name to transform
6 ; XUMINL=minimum length (optional), default 3
7 ; XUMAXL=maximum length (optional), default 30
8 ; XUNOP=1 to standardize last name for 'NOP' x-ref
9 ; (for the PAITNE file). (optional)
10 ; XUCOMA=0 to not require a comma
11 ; 1 to require a comma in the input value
12 ; 2 to add a comma if none
13 ; 3 to prohibit (remove) commas
14 ; (optional) default if not specified is 1
15 ;
16 ; XUAUDIT=variable to return audit, pass by reference (optional),
17 ; returned values:
18 ; XUAUDIT=0 if no change was made
19 ; 1 if name is changed
20 ; 2 if name could not be converted
21 ; XUAUDIT(1) defined if name contains no comma
22 ; XUAUDIT(2) defined if parenthetical text is removed
23 ; XUAUDIT(3) defined if value is unconvertible
24 ; XUAUDIT(4) defined if characters are removed or changed
25 ; XUFAM='1' if just the family name, '0' otherwise (optional)
26 ; XUDNC='1' to prevent componentization (optional)
27 ; ='2' to return components before standardize
28 ;
29 ;Output: XUNAME in specified format or null if length of transformed value is less than XUMINL
30 ;
31 N XUX,XUOX,XUOLDN,XUAX,XUI,XUNEWN
32 ;Initialize variables
33 K XUAUDIT
34 S XUOLDN=XUNAME M XUX=XUNAME
35 S XUDNC=$G(XUDNC) D COMP^XLFNAME8(.XUX,.XUDNC)
36 S XUMINL=+$G(XUMINL) S:XUMINL<1 XUMINL=3
37 S XUMAXL=+$G(XUMAXL) S:XUMAXL<XUMINL XUMAXL=30
38 S XUNOP=$S($G(XUNOP)=1:"S",1:"")
39 S:'$L($G(XUCOMA)) XUCOMA=1 S XUCOMA=+XUCOMA
40 S XUFAM=$S($G(XUFAM)=1:"F",1:"")
41 ;
42 ;Check for comma
43 I XUX'["," S XUAUDIT(1)=""
44 I XUCOMA=1,XUX'["," S XUAUDIT=2,XUAUDIT(3)="" Q ""
45 ;Clean input value
46 F Q:'$$F1^XLFNAME8(.XUX,XUCOMA)
47 I XUX'=XUOLDN S XUAUDIT(4)=""
48 ;Add comma if necessary
49 I XUCOMA=2,XUX'[" ",XUX'["," S XUX=XUX_","
50 I XUX=XUOLDN K XUAUDIT(4)
51 ;Quit if result is too short
52 I $L(XUX)<XUMINL S XUAUDIT=2,XUAUDIT(3)="" K XUNAME Q ""
53 S XUNAME=XUX I XUDNC'=1 D
54 .;Parse the name
55 .D STDNAME^XLFNAME(.XUX,XUFAM_"CP",.XUAX)
56 .I $D(XUAX("STRIP")) S XUAUDIT(2)=""
57 .I $D(XUAX("NM"))!$D(XUAX("PERIOD")) S XUAUDIT(4)=""
58 .I $D(XUAX("PUNC"))!($D(XUAX("SPACE"))&'$L(XUFAM)) S XUAUDIT(4)=""
59 .I $D(XUAX("SPACE")),$L(XUFAM),XUNAME'=$G(XUX("FAMILY")) S XUAUDIT(4)=""
60 .;Standardize the suffix
61 .S XUX("SUFFIX")=$$CLEANC^XLFNAME(XUX("SUFFIX"))
62 .;Post-clean components
63 .S XUI="" F S XUI=$O(XUX(XUI)) Q:XUI="" S XUX(XUI)=$$POSTC(XUX(XUI))
64 .;Reconstruct name from components
65 .S XUNAME=$$NAMEFMT^XLFNAME(.XUX,"F","CL"_XUMAXL_XUNOP)
66 .;Adjust name for 'do not componentize'
67 .;I XUDNC S XUNAME=XUX("FAMILY")
68 ;Return comma for single value names
69 I XUCOMA,XUCOMA'=3,XUNAME'["," S XUNAME=XUNAME_","
70 ;Check length again
71 I $L(XUNAME)<XUMINL S XUAUDIT=2,XUAUDIT(3)="" K XUNAME Q ""
72 ;Enforce minimum 2 character last name rule
73 ;I '$L(XUFAM),$L($P(XUNAME,","))<3,$P(XUNAME,",")'?2U D Q ""
74 ;.S XUAUDIT=2,XUAUDIT(3)="" K XUNAME
75 ;.Q
76 ;Remove hyphens and apostrophes for 'NOP' x-ref
77 S XUX=XUNAME I XUNOP="S" S XUNAME=$TR(XUNAME,"'-")
78 I XUNAME'=XUX S XUAUDIT(4)=""
79 I XUNAME=XUOLDN K XUAUDIT
80 S XUAUDIT=XUNAME'=XUOLDN I XUAUDIT,$D(XUAUDIT)<10 S XUAUDIT(4)=""
81 S XUNEWN=XUNAME M XUNAME=XUX S XUNAME=XUNEWN
82 ;Return components before standardization if asked to
83 I XUDNC=2 D
84 . N XUNAMEC
85 . S XUNAMEC=XUNAME
86 . I XUOLDN["`" S XUOLDN=$TR(XUOLDN,"`","'")
87 . D STDNAME^XLFNAME(.XUOLDN,"C")
88 . M XUNAME=XUOLDN
89 . S XUNAME=XUNAMEC
90 Q XUNAME
91 ;
92POSTC(XUX) ;Post-clean components
93 ;Remove parenthesis if not removed by Kernel
94 N XUI,XUXOLD
95 S XUXOLD=XUX,XUX=$TR(XUX,"()[]{}")
96 ;Check for numbers left behind by Kernel
97 F XUI=0:1:9 S XUX=$TR(XUX,XUI)
98 I XUX'=XUXOLD S XUAUDIT(4)=""
99 Q XUX
100 ;
101NOP(XUX) ;Produce 'NOP' x-ref value
102 ;Input: XUX=name value to evaluate
103 ;Output : Standardized name or null if the same as input value
104 N XUNEWX
105 S XUNEWX=$$FORMAT(XUX,3,30,1)
106 Q $S(XUX=XUNEWX:"",1:XUNEWX)
107 ;
108NARY(XU20NAME) ;Set up name array
109 ;Input: XU20NAME=full name value
110 ; XU20NAME(component_names)=corresponding value--if undefined,
111 ; these will get set up
112 ;
113 N XUX M XUX=XU20NAME
114 D STDNAME^XLFNAME(.XU20NAME,"FC")
115 M XU20NAME=XUX
116 S XU20NAME("NOTES")=$$NOTES^XLFNAME8()
117 Q
118 ;
Note: See TracBrowser for help on using the repository browser.