XLFNAME8 ;BPOIFO/KEITH/DW - NAME STANDARDIZATION ; 12 Aug 2002@20:20
;;8.0;KERNEL;**343**; Jul 10, 1995;
;
FAMILY ;Family name help text
S XUM("LENGTH")="1-35"
Q
;
GIVEN ;Given name help text
S XUM("LENGTH")="1-25"
Q
;
MIDDLE ;Middle name help text
S XUM("LENGTH")="1-25"
Q
;
PREFIX ;Name prefix help text
S XUM("LENGTH")="1-10"
Q
;
SUFFIX ;Name suffix help text
S XUM("LENGTH")="1-10"
Q
;
DEGREE ;Name degree help text
S XUM("LENGTH")="1-10"
Q
;
CVALID(XUC,XUX,XUM) ;Name component validation
; Input: XUC=name component (e.g. FAMILY, GIVEN, etc.)
; XUX=input value to validate
; XUM=array to return results and errors (pass by reference)
;
;Output: XUM array in the format:
; XUM("ERROR",n)=error text (if any)
; XUM("HELP",n)=help text
; XUM("LENGTH")=field length in length (e.g. 3-30)
; XUM("RESULT")=transformed name value (null if invalid entry)
;
N XUL,XUF,XUI,XUR,XUMSG,DIERR
S XUF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
S XUF=$P(XUF,XUC),XUF=$L(XUF,U)
D @XUC ;Set up length and help text
S XUL=+$P(XUM("LENGTH"),"-")_U_+$P(XUM("LENGTH"),"-",2)
;Transform suffixes
I XUC="SUFFIX" S XUX=$$CLEANC^XLFNAME(XUX)
;Clean/format input value
S XUX=$$FORMAT^XLFNAME7(XUX,$P(XUL,U),$P(XUL,U,2),,3,,1,1)
;Validate against file 20
D CHK^DIE(20,XUF,"E",XUX,.XUR,"XUMSG")
I $D(XUMSG("DIERR","E",701)) D
.S XUI=$O(XUMSG("DIERR","E",701,""))
.M XUM("ERROR")=XUMSG("DIERR",XUI,"TEXT")
.Q
S XUM("RESULT")=$S(XUR=U:"",1:XUR)
Q
;
NOTES() ;Produce value for the file #20 NOTES ABOUT NAME field
;Output: string representing when, who and how editing occurred
;
N XUWHEN,XUWHO,XUHOW
S XUWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
S XUWHO=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
S XUWHO=XUWHO_" ("_$G(DUZ)_")"
S XUHOW=$P($G(XQY0),U)
Q "Edited: "_XUWHEN_" By: "_XUWHO_" With: "_XUHOW
;
COMP(XUX,XUDNC) ;Use existing name array
;Input: XUX=name array (pass by reference)
; XUDNC='do not componentize' flag (pass by reference)
;
N XUY,XUI,XUZ
Q:$D(XUX)<10 Q:(XUDNC=0)!(XUDNC=2)
S XUDNC=1,XUY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
F XUI=1:1:6 S XUZ=$P(XUY,U,XUI) S:'$D(XUX(XUZ)) XUX(XUZ)=""
Q
;
F1(XUX,XUCOMA) ;Transform text value
;Input: XUX=text value to transform (pass by reference)
; XUCOMA=comma indicator
;Output: 1 if changed, 0 otherwise
;
N XUI,XUII,XUC,XUY,XUZ,XUOLDX S XUOLDX=XUX
;Transform accent grave to apostrophe
S XUX=$TR(XUX,"`","'")
;Transform single characters
F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:$$FC1(.XUC,XUCOMA)
.S XUX=$E(XUX,0,XUI-1)_XUC_$E(XUX,XUI+1,999)
.Q
;Transform double character combinations
S XUY=" ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
S XUZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
F XUI=1:1 S XUC=$P(XUY,U,XUI) Q:XUC="" D
.Q:XUX'[XUC
.F XUII=1:1:$L(XUX,XUC)-1 D
..S XUX=$P(XUX,XUC,0,XUII)_$P(XUZ,U,XUI)_$P(XUX,XUC,XUII+1,999)
..Q
.Q
;Remove NMI and NMN
F XUY="NMI","NMN" I XUX[XUY,XUCOMA=3 D
.S XUC=$F(XUX,XUY)
.I " ,"[$E(XUX,(XUC-4))," ,"[$E(XUX,XUC) D
..S XUX=$E(XUX,0,(XUC-4))_$E(XUX,(XUC),999)
..F XUY=" ",",," I XUX[XUY D
...S XUC=$F(XUX,XUY) S XUX=$E(XUX,0,(XUC-3))_$E(XUX,(XUC-1),999) Q
..F XUZ=" ","," F XUC=1,$L(XUX) D
...I $E(XUX,XUC)=XUZ S XUX=$E(XUX,0,(XUC-1))_$E(XUX,(XUC+1),999) Q
..Q
.Q
;Clean up numerics
I XUX?.E1N.E D
.S XUY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
.F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:XUC?1N
..I XUC," ,"[$E(XUX,XUI-1),$E(XUX,XUI,XUI+2)=$P(XUY,U,XUC)," ,"[$E(XUX,XUI+3) Q
..I XUC=1," ,"[$E(XUX,XUI-1),$E(XUX,XUI,XUI+3)="10TH"," ,"[$E(XUX,XUI+4) S XUI=XUI+1 Q
..S XUX=$E(XUX,0,XUI-1)_$E(XUX,XUI+1,999)
..Q
.Q
;Check for dangling apostrophes
I XUX["'" F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:XUC?1"'"
.I $E(XUX,(XUI-1))?1U,$E(XUX,(XUI+1))?1U Q
.S XUX=$E(XUX,0,(XUI-1))_$E(XUX,(XUI+1),99),XUI=1
.Q
;Remove parenthetical text from name value
N XUCH S XUOLDX(2)=XUX,XUCH=1 F Q:'XUCH D
.S XUCH=0,XUOLDX(1)=XUX,XUY="()[]{}" D
..F XUI=1,3,5 S XUC(1)=$E(XUY,XUI),XUC(2)=$E(XUY,XUI+1) D
...S XUZ(1)=$$CLAST(XUX,XUC(1)) Q:'XUZ(1) S XUZ(2)=$F(XUX,XUC(2),XUZ(1))
...I XUZ(2)>XUZ(1) S XUX=$E(XUX,0,(XUZ(1)-2))_$E(XUX,XUZ(2),999)
...S XUCH=(XUX'=XUOLDX(1)) Q
..Q
.Q
S:XUX'=XUOLDX(2) XUAUDIT(2)=""
F XUI=1:1:6 S XUC=$E(XUY,XUI) D
.F Q:XUX'[XUC S XUX=$P(XUX,XUC)_$P(XUX,XUC,2,999)
.Q
;Insure value begins and ends with an alpha character
F Q:'$L(XUX)!($E(XUX,1)?1A) S XUX=$E(XUX,2,999)
F Q:'$L(XUX)!($E(XUX,$L(XUX))?1A) Q:($L(XUX,",")=2)&($E(XUX,$L(XUX))=",") S XUX=$E(XUX,1,($L(XUX)-1))
Q XUX'=XUOLDX
;
CLAST(XUX,XUC) ;Find last instance of character
N XUY,XUZ
S XUZ=$F(XUX,XUC) Q:'XUZ XUZ
F S XUY=$F(XUX,XUC,XUZ) Q:'XUY S XUZ=XUY
Q XUZ
;
FC1(XUC,XUCOMA) ;Transform single character
;Input: XUC=character to transform (pass by reference)
; XUCOMA=comma indicator
;Output: 1 if value is changed, 0 otherwise
;
S XUC=$E(XUC) Q:'$L(XUC) 0
;See if comma stays
I XUCOMA'=3,XUC?1"," Q 0
;Retain uppercase, numeric, hyphen, apostrophe and space
Q:XUC?1U!(XUC?1N)!(XUC?1"-")!(XUC?1"'")!(XUC?1" ") 0
;Retain parenthesis, bracket and brace characters
Q:XUC?1"("!(XUC?1")")!(XUC?1"[")!(XUC?1"]")!(XUC?1"{")!(XUC?1"}") 0
;Transform lowercase to uppercase
I XUC?1L S XUC=$C($A(XUC)-32) Q 1
;Set all other characters to space
S XUC=" " Q 1
;
CMP(XUNC) ;Cleanup name components
;
N XUCOM,XUI,XUCOMP,XUM
;
S XUCOM="FAMILY^GIVEN^MIDDLE^SUFFIX"
F XUI=1:1:4 D
. S XUCOMP=$P(XUCOM,U,XUI)
. D CVALID^XLFNAME8(XUCOMP,$G(XUNC(XUCOMP)),.XUM)
. S XUNC(XUCOMP)=$G(XUM("RESULT"))
Q
;
BLDNAME(XUNC,XUMAX) ;Build standard name from components
;Called by XU forms
;Modified version of BLDNAME^XLFNAME
;
D CMP(.XUNC)
Q $$NAMEFMT^XLFNAME(.XUNC,"F","CL"_+$G(XUMAX))
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXLFNAME8 5919 printed Dec 13, 2024@02:03 Page 2
XLFNAME8 ;BPOIFO/KEITH/DW - NAME STANDARDIZATION ; 12 Aug 2002@20:20
+1 ;;8.0;KERNEL;**343**; Jul 10, 1995;
+2 ;
FAMILY ;Family name help text
+1 SET XUM("LENGTH")="1-35"
+2 QUIT
+3 ;
GIVEN ;Given name help text
+1 SET XUM("LENGTH")="1-25"
+2 QUIT
+3 ;
MIDDLE ;Middle name help text
+1 SET XUM("LENGTH")="1-25"
+2 QUIT
+3 ;
PREFIX ;Name prefix help text
+1 SET XUM("LENGTH")="1-10"
+2 QUIT
+3 ;
SUFFIX ;Name suffix help text
+1 SET XUM("LENGTH")="1-10"
+2 QUIT
+3 ;
DEGREE ;Name degree help text
+1 SET XUM("LENGTH")="1-10"
+2 QUIT
+3 ;
CVALID(XUC,XUX,XUM) ;Name component validation
+1 ; Input: XUC=name component (e.g. FAMILY, GIVEN, etc.)
+2 ; XUX=input value to validate
+3 ; XUM=array to return results and errors (pass by reference)
+4 ;
+5 ;Output: XUM array in the format:
+6 ; XUM("ERROR",n)=error text (if any)
+7 ; XUM("HELP",n)=help text
+8 ; XUM("LENGTH")=field length in length (e.g. 3-30)
+9 ; XUM("RESULT")=transformed name value (null if invalid entry)
+10 ;
+11 NEW XUL,XUF,XUI,XUR,XUMSG,DIERR
+12 SET XUF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
+13 SET XUF=$PIECE(XUF,XUC)
SET XUF=$LENGTH(XUF,U)
+14 ;Set up length and help text
DO @XUC
+15 SET XUL=+$PIECE(XUM("LENGTH"),"-")_U_+$PIECE(XUM("LENGTH"),"-",2)
+16 ;Transform suffixes
+17 IF XUC="SUFFIX"
SET XUX=$$CLEANC^XLFNAME(XUX)
+18 ;Clean/format input value
+19 SET XUX=$$FORMAT^XLFNAME7(XUX,$PIECE(XUL,U),$PIECE(XUL,U,2),,3,,1,1)
+20 ;Validate against file 20
+21 DO CHK^DIE(20,XUF,"E",XUX,.XUR,"XUMSG")
+22 IF $DATA(XUMSG("DIERR","E",701))
Begin DoDot:1
+23 SET XUI=$ORDER(XUMSG("DIERR","E",701,""))
+24 MERGE XUM("ERROR")=XUMSG("DIERR",XUI,"TEXT")
+25 QUIT
End DoDot:1
+26 SET XUM("RESULT")=$SELECT(XUR=U:"",1:XUR)
+27 QUIT
+28 ;
NOTES() ;Produce value for the file #20 NOTES ABOUT NAME field
+1 ;Output: string representing when, who and how editing occurred
+2 ;
+3 NEW XUWHEN,XUWHO,XUHOW
+4 SET XUWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
+5 SET XUWHO=$SELECT($GET(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
+6 SET XUWHO=XUWHO_" ("_$GET(DUZ)_")"
+7 SET XUHOW=$PIECE($GET(XQY0),U)
+8 QUIT "Edited: "_XUWHEN_" By: "_XUWHO_" With: "_XUHOW
+9 ;
COMP(XUX,XUDNC) ;Use existing name array
+1 ;Input: XUX=name array (pass by reference)
+2 ; XUDNC='do not componentize' flag (pass by reference)
+3 ;
+4 NEW XUY,XUI,XUZ
+5 if $DATA(XUX)<10
QUIT
if (XUDNC=0)!(XUDNC=2)
QUIT
+6 SET XUDNC=1
SET XUY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
+7 FOR XUI=1:1:6
SET XUZ=$PIECE(XUY,U,XUI)
if '$DATA(XUX(XUZ))
SET XUX(XUZ)=""
+8 QUIT
+9 ;
F1(XUX,XUCOMA) ;Transform text value
+1 ;Input: XUX=text value to transform (pass by reference)
+2 ; XUCOMA=comma indicator
+3 ;Output: 1 if changed, 0 otherwise
+4 ;
+5 NEW XUI,XUII,XUC,XUY,XUZ,XUOLDX
SET XUOLDX=XUX
+6 ;Transform accent grave to apostrophe
+7 SET XUX=$TRANSLATE(XUX,"`","'")
+8 ;Transform single characters
+9 FOR XUI=1:1:$LENGTH(XUX)
SET XUC=$EXTRACT(XUX,XUI)
if $$FC1(.XUC,XUCOMA)
Begin DoDot:1
+10 SET XUX=$EXTRACT(XUX,0,XUI-1)_XUC_$EXTRACT(XUX,XUI+1,999)
+11 QUIT
End DoDot:1
+12 ;Transform double character combinations
+13 SET XUY=" ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
+14 SET XUZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
+15 FOR XUI=1:1
SET XUC=$PIECE(XUY,U,XUI)
if XUC=""
QUIT
Begin DoDot:1
+16 if XUX'[XUC
QUIT
+17 FOR XUII=1:1:$LENGTH(XUX,XUC)-1
Begin DoDot:2
+18 SET XUX=$PIECE(XUX,XUC,0,XUII)_$PIECE(XUZ,U,XUI)_$PIECE(XUX,XUC,XUII+1,999)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;Remove NMI and NMN
+22 FOR XUY="NMI","NMN"
IF XUX[XUY
IF XUCOMA=3
Begin DoDot:1
+23 SET XUC=$FIND(XUX,XUY)
+24 IF " ,"[$EXTRACT(XUX,(XUC-4))
IF " ,"[$EXTRACT(XUX,XUC)
Begin DoDot:2
+25 SET XUX=$EXTRACT(XUX,0,(XUC-4))_$EXTRACT(XUX,(XUC),999)
+26 FOR XUY=" ",",,"
IF XUX[XUY
Begin DoDot:3
+27 SET XUC=$FIND(XUX,XUY)
SET XUX=$EXTRACT(XUX,0,(XUC-3))_$EXTRACT(XUX,(XUC-1),999)
QUIT
End DoDot:3
+28 FOR XUZ=" ",","
FOR XUC=1,$LENGTH(XUX)
Begin DoDot:3
+29 IF $EXTRACT(XUX,XUC)=XUZ
SET XUX=$EXTRACT(XUX,0,(XUC-1))_$EXTRACT(XUX,(XUC+1),999)
QUIT
End DoDot:3
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;Clean up numerics
+33 IF XUX?.E1N.E
Begin DoDot:1
+34 SET XUY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
+35 FOR XUI=1:1:$LENGTH(XUX)
SET XUC=$EXTRACT(XUX,XUI)
if XUC?1N
Begin DoDot:2
+36 IF XUC
IF " ,"[$EXTRACT(XUX,XUI-1)
IF $EXTRACT(XUX,XUI,XUI+2)=$PIECE(XUY,U,XUC)
IF " ,"[$EXTRACT(XUX,XUI+3)
QUIT
+37 IF XUC=1
IF " ,"[$EXTRACT(XUX,XUI-1)
IF $EXTRACT(XUX,XUI,XUI+3)="10TH"
IF " ,"[$EXTRACT(XUX,XUI+4)
SET XUI=XUI+1
QUIT
+38 SET XUX=$EXTRACT(XUX,0,XUI-1)_$EXTRACT(XUX,XUI+1,999)
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 ;Check for dangling apostrophes
+42 IF XUX["'"
FOR XUI=1:1:$LENGTH(XUX)
SET XUC=$EXTRACT(XUX,XUI)
if XUC?1"'"
Begin DoDot:1
+43 IF $EXTRACT(XUX,(XUI-1))?1U
IF $EXTRACT(XUX,(XUI+1))?1U
QUIT
+44 SET XUX=$EXTRACT(XUX,0,(XUI-1))_$EXTRACT(XUX,(XUI+1),99)
SET XUI=1
+45 QUIT
End DoDot:1
+46 ;Remove parenthetical text from name value
+47 NEW XUCH
SET XUOLDX(2)=XUX
SET XUCH=1
FOR
if 'XUCH
QUIT
Begin DoDot:1
+48 SET XUCH=0
SET XUOLDX(1)=XUX
SET XUY="()[]{}"
Begin DoDot:2
+49 FOR XUI=1,3,5
SET XUC(1)=$EXTRACT(XUY,XUI)
SET XUC(2)=$EXTRACT(XUY,XUI+1)
Begin DoDot:3
+50 SET XUZ(1)=$$CLAST(XUX,XUC(1))
if 'XUZ(1)
QUIT
SET XUZ(2)=$FIND(XUX,XUC(2),XUZ(1))
+51 IF XUZ(2)>XUZ(1)
SET XUX=$EXTRACT(XUX,0,(XUZ(1)-2))_$EXTRACT(XUX,XUZ(2),999)
+52 SET XUCH=(XUX'=XUOLDX(1))
QUIT
End DoDot:3
+53 QUIT
End DoDot:2
+54 QUIT
End DoDot:1
+55 if XUX'=XUOLDX(2)
SET XUAUDIT(2)=""
+56 FOR XUI=1:1:6
SET XUC=$EXTRACT(XUY,XUI)
Begin DoDot:1
+57 FOR
if XUX'[XUC
QUIT
SET XUX=$PIECE(XUX,XUC)_$PIECE(XUX,XUC,2,999)
+58 QUIT
End DoDot:1
+59 ;Insure value begins and ends with an alpha character
+60 FOR
if '$LENGTH(XUX)!($EXTRACT(XUX,1)?1A)
QUIT
SET XUX=$EXTRACT(XUX,2,999)
+61 FOR
if '$LENGTH(XUX)!($EXTRACT(XUX,$LENGTH(XUX))?1A)
QUIT
if ($LENGTH(XUX,",")=2)&($EXTRACT(XUX,$LENGTH(XUX))=",")
QUIT
SET XUX=$EXTRACT(XUX,1,($LENGTH(XUX)-1))
+62 QUIT XUX'=XUOLDX
+63 ;
CLAST(XUX,XUC) ;Find last instance of character
+1 NEW XUY,XUZ
+2 SET XUZ=$FIND(XUX,XUC)
if 'XUZ
QUIT XUZ
+3 FOR
SET XUY=$FIND(XUX,XUC,XUZ)
if 'XUY
QUIT
SET XUZ=XUY
+4 QUIT XUZ
+5 ;
FC1(XUC,XUCOMA) ;Transform single character
+1 ;Input: XUC=character to transform (pass by reference)
+2 ; XUCOMA=comma indicator
+3 ;Output: 1 if value is changed, 0 otherwise
+4 ;
+5 SET XUC=$EXTRACT(XUC)
if '$LENGTH(XUC)
QUIT 0
+6 ;See if comma stays
+7 IF XUCOMA'=3
IF XUC?1","
QUIT 0
+8 ;Retain uppercase, numeric, hyphen, apostrophe and space
+9 if XUC?1U!(XUC?1N)!(XUC?1"-")!(XUC?1"'")!(XUC?1" ")
QUIT 0
+10 ;Retain parenthesis, bracket and brace characters
+11 if XUC?1"("!(XUC?1")")!(XUC?1"[")!(XUC?1"]")!(XUC?1"{")!(XUC?1"}")
QUIT 0
+12 ;Transform lowercase to uppercase
+13 IF XUC?1L
SET XUC=$CHAR($ASCII(XUC)-32)
QUIT 1
+14 ;Set all other characters to space
+15 SET XUC=" "
QUIT 1
+16 ;
CMP(XUNC) ;Cleanup name components
+1 ;
+2 NEW XUCOM,XUI,XUCOMP,XUM
+3 ;
+4 SET XUCOM="FAMILY^GIVEN^MIDDLE^SUFFIX"
+5 FOR XUI=1:1:4
Begin DoDot:1
+6 SET XUCOMP=$PIECE(XUCOM,U,XUI)
+7 DO CVALID^XLFNAME8(XUCOMP,$GET(XUNC(XUCOMP)),.XUM)
+8 SET XUNC(XUCOMP)=$GET(XUM("RESULT"))
End DoDot:1
+9 QUIT
+10 ;
BLDNAME(XUNC,XUMAX) ;Build standard name from components
+1 ;Called by XU forms
+2 ;Modified version of BLDNAME^XLFNAME
+3 ;
+4 DO CMP(.XUNC)
+5 QUIT $$NAMEFMT^XLFNAME(.XUNC,"F","CL"_+$GET(XUMAX))
+6 ;
