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

XLFNAME8.m

Go to the documentation of this file. 
  1. XLFNAME8 ;BPOIFO/KEITH/DW - NAME STANDARDIZATION ; 12 Aug 2002@20:20
  1.  ;;8.0;KERNEL;**343**; Jul 10, 1995;
  1.  ;
  1. FAMILY ;Family name help text
  1.  S XUM("LENGTH")="1-35"
  1.  Q
  1.        ;
  1. GIVEN ;Given name help text
  1.  S XUM("LENGTH")="1-25"
  1.  Q
  1.  ;
  1. MIDDLE ;Middle name help text
  1.  S XUM("LENGTH")="1-25"
  1.  Q
  1.  ;
  1. PREFIX ;Name prefix help text
  1.  S XUM("LENGTH")="1-10"
  1.  Q
  1.  ;
  1. SUFFIX ;Name suffix help text
  1.  S XUM("LENGTH")="1-10"
  1.  Q
  1.  ;
  1. DEGREE ;Name degree help text
  1.  S XUM("LENGTH")="1-10"
  1.  Q
  1.  ;
  1. CVALID(XUC,XUX,XUM) ;Name component validation
  1.  ; Input: XUC=name component (e.g. FAMILY, GIVEN, etc.)
  1.  ;        XUX=input value to validate
  1.  ;        XUM=array to return results and errors (pass by reference)
  1.  ;
  1.  ;Output: XUM array in the format:
  1.  ;       XUM("ERROR",n)=error text (if any) 
  1.  ;       XUM("HELP",n)=help text          
  1.  ;       XUM("LENGTH")=field length in length (e.g. 3-30) 
  1.  ;       XUM("RESULT")=transformed name value (null if invalid entry)
  1.  ; 
  1.  N XUL,XUF,XUI,XUR,XUMSG,DIERR
  1.  S XUF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1.  S XUF=$P(XUF,XUC),XUF=$L(XUF,U)
  1.  D @XUC  ;Set up length and help text 
  1.  S XUL=+$P(XUM("LENGTH"),"-")_U_+$P(XUM("LENGTH"),"-",2)
  1.  ;Transform suffixes
  1.  I XUC="SUFFIX" S XUX=$$CLEANC^XLFNAME(XUX)
  1.  ;Clean/format input value 
  1.  S XUX=$$FORMAT^XLFNAME7(XUX,$P(XUL,U),$P(XUL,U,2),,3,,1,1)
  1.  ;Validate against file 20 
  1.  D CHK^DIE(20,XUF,"E",XUX,.XUR,"XUMSG")
  1.  I $D(XUMSG("DIERR","E",701)) D
  1.  .S XUI=$O(XUMSG("DIERR","E",701,""))
  1.  .M XUM("ERROR")=XUMSG("DIERR",XUI,"TEXT")
  1.  .Q
  1.  S XUM("RESULT")=$S(XUR=U:"",1:XUR)
  1.  Q
  1.  ;
  1. NOTES() ;Produce value for the file #20 NOTES ABOUT NAME field
  1.  ;Output: string representing when, who and how editing occurred
  1.  ;
  1.  N XUWHEN,XUWHO,XUHOW
  1.  S XUWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
  1.  S XUWHO=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
  1.  S XUWHO=XUWHO_" ("_$G(DUZ)_")"
  1.  S XUHOW=$P($G(XQY0),U)
  1.  Q "Edited: "_XUWHEN_" By: "_XUWHO_" With: "_XUHOW
  1.  ;
  1. COMP(XUX,XUDNC) ;Use existing name array
  1.  ;Input: XUX=name array (pass by reference)
  1.  ;     XUDNC='do not componentize' flag (pass by reference)
  1.  ;
  1.  N XUY,XUI,XUZ
  1.  Q:$D(XUX)<10  Q:(XUDNC=0)!(XUDNC=2)
  1.  S XUDNC=1,XUY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1.  F XUI=1:1:6 S XUZ=$P(XUY,U,XUI) S:'$D(XUX(XUZ)) XUX(XUZ)=""
  1.  Q
  1.  ;
  1. F1(XUX,XUCOMA)  ;Transform text value
  1.  ;Input: XUX=text value to transform (pass by reference)
  1.  ;    XUCOMA=comma indicator
  1.  ;Output: 1 if changed, 0 otherwise
  1.  ;
  1.  N XUI,XUII,XUC,XUY,XUZ,XUOLDX S XUOLDX=XUX
  1.  ;Transform accent grave to apostrophe
  1.  S XUX=$TR(XUX,"`","'")
  1.  ;Transform single characters
  1.  F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:$$FC1(.XUC,XUCOMA)
  1.  .S XUX=$E(XUX,0,XUI-1)_XUC_$E(XUX,XUI+1,999)
  1.  .Q
  1.  ;Transform double character combinations
  1.  S XUY="  ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
  1.  S XUZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
  1.  F XUI=1:1 S XUC=$P(XUY,U,XUI) Q:XUC=""  D
  1.  .Q:XUX'[XUC
  1.  .F XUII=1:1:$L(XUX,XUC)-1 D
  1.  ..S XUX=$P(XUX,XUC,0,XUII)_$P(XUZ,U,XUI)_$P(XUX,XUC,XUII+1,999)
  1.  ..Q
  1.  .Q
  1.  ;Remove NMI and NMN
  1.  F XUY="NMI","NMN" I XUX[XUY,XUCOMA=3 D
  1.  .S XUC=$F(XUX,XUY)
  1.  .I " ,"[$E(XUX,(XUC-4))," ,"[$E(XUX,XUC) D
  1.  ..S XUX=$E(XUX,0,(XUC-4))_$E(XUX,(XUC),999)
  1.  ..F XUY="  ",",," I XUX[XUY D
  1.  ...S XUC=$F(XUX,XUY) S XUX=$E(XUX,0,(XUC-3))_$E(XUX,(XUC-1),999) Q
  1.  ..F XUZ=" ","," F XUC=1,$L(XUX) D
  1.  ...I $E(XUX,XUC)=XUZ S XUX=$E(XUX,0,(XUC-1))_$E(XUX,(XUC+1),999) Q
  1.  ..Q
  1.  .Q
  1.  ;Clean up numerics
  1.  I XUX?.E1N.E D
  1.  .S XUY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
  1.  .F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:XUC?1N
  1.  ..I XUC," ,"[$E(XUX,XUI-1),$E(XUX,XUI,XUI+2)=$P(XUY,U,XUC)," ,"[$E(XUX,XUI+3) Q
  1.  ..I XUC=1," ,"[$E(XUX,XUI-1),$E(XUX,XUI,XUI+3)="10TH"," ,"[$E(XUX,XUI+4) S XUI=XUI+1 Q
  1.  ..S XUX=$E(XUX,0,XUI-1)_$E(XUX,XUI+1,999)
  1.  ..Q
  1.  .Q
  1.  ;Check for dangling apostrophes
  1.  I XUX["'" F XUI=1:1:$L(XUX) S XUC=$E(XUX,XUI) D:XUC?1"'"
  1.  .I $E(XUX,(XUI-1))?1U,$E(XUX,(XUI+1))?1U Q
  1.  .S XUX=$E(XUX,0,(XUI-1))_$E(XUX,(XUI+1),99),XUI=1
  1.  .Q
  1.  ;Remove parenthetical text from name value
  1.  N XUCH S XUOLDX(2)=XUX,XUCH=1 F  Q:'XUCH  D
  1.  .S XUCH=0,XUOLDX(1)=XUX,XUY="()[]{}" D
  1.  ..F XUI=1,3,5 S XUC(1)=$E(XUY,XUI),XUC(2)=$E(XUY,XUI+1) D
  1.  ...S XUZ(1)=$$CLAST(XUX,XUC(1)) Q:'XUZ(1)  S XUZ(2)=$F(XUX,XUC(2),XUZ(1))
  1.  ...I XUZ(2)>XUZ(1) S XUX=$E(XUX,0,(XUZ(1)-2))_$E(XUX,XUZ(2),999)
  1.  ...S XUCH=(XUX'=XUOLDX(1)) Q
  1.  ..Q
  1.  .Q
  1.  S:XUX'=XUOLDX(2) XUAUDIT(2)=""
  1.  F XUI=1:1:6 S XUC=$E(XUY,XUI) D
  1.  .F  Q:XUX'[XUC  S XUX=$P(XUX,XUC)_$P(XUX,XUC,2,999)
  1.  .Q
  1.  ;Insure value begins and ends with an alpha character
  1.  F  Q:'$L(XUX)!($E(XUX,1)?1A)  S XUX=$E(XUX,2,999)
  1.  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))
  1.  Q XUX'=XUOLDX
  1.  ;
  1. CLAST(XUX,XUC) ;Find last instance of character
  1.  N XUY,XUZ
  1.  S XUZ=$F(XUX,XUC) Q:'XUZ XUZ
  1.  F  S XUY=$F(XUX,XUC,XUZ) Q:'XUY  S XUZ=XUY
  1.  Q XUZ
  1.  ;
  1. FC1(XUC,XUCOMA) ;Transform single character
  1.  ;Input: XUC=character to transform (pass by reference)
  1.  ;    XUCOMA=comma indicator
  1.  ;Output: 1 if value is changed, 0 otherwise
  1.  ;
  1.  S XUC=$E(XUC) Q:'$L(XUC) 0
  1.  ;See if comma stays
  1.  I XUCOMA'=3,XUC?1"," Q 0
  1.  ;Retain uppercase, numeric, hyphen, apostrophe and space
  1.  Q:XUC?1U!(XUC?1N)!(XUC?1"-")!(XUC?1"'")!(XUC?1" ") 0
  1.  ;Retain parenthesis, bracket and brace characters
  1.  Q:XUC?1"("!(XUC?1")")!(XUC?1"[")!(XUC?1"]")!(XUC?1"{")!(XUC?1"}") 0
  1.  ;Transform lowercase to uppercase
  1.  I XUC?1L S XUC=$C($A(XUC)-32) Q 1
  1.  ;Set all other characters to space
  1.  S XUC=" " Q 1
  1.  ;
  1. CMP(XUNC) ;Cleanup name components
  1.  ;
  1.  N XUCOM,XUI,XUCOMP,XUM
  1.  ;
  1.  S XUCOM="FAMILY^GIVEN^MIDDLE^SUFFIX"
  1.  F XUI=1:1:4 D
  1.  . S XUCOMP=$P(XUCOM,U,XUI)
  1.  . D CVALID^XLFNAME8(XUCOMP,$G(XUNC(XUCOMP)),.XUM)
  1.  . S XUNC(XUCOMP)=$G(XUM("RESULT"))
  1.  Q
  1.  ;
  1. BLDNAME(XUNC,XUMAX) ;Build standard name from components
  1.  ;Called by XU forms
  1.  ;Modified version of BLDNAME^XLFNAME
  1.  ;
  1.  D CMP(.XUNC)
  1.  Q $$NAMEFMT^XLFNAME(.XUNC,"F","CL"_+$G(XUMAX))
  1.  ;