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

DPTNAME1.m

Go to the documentation of this file. 
  1. DPTNAME1 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 12 Aug 2002@20:20
  1.  ;;5.3;Registration;**244,620,720,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. NCEVAL(DGC,DGX) ;Evaluate name component entry values
  1.  ;Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
  1.  ;       DGX=input value for name
  1.  ;
  1.  Q:DGX="@"
  1.  N DGM,DGL,DGI
  1.  I DGX=""!($E(DGX)=U) Q
  1.  D CVALID(DGC,DGX,.DGM)
  1.  M DIR("?")=DGM("HELP") S DGI=$O(DIR("?",""),-1) I DGI D
  1.  .S DIR("?")=DIR("?",DGI) K DIR("?",DGI)
  1.  .Q
  1.  I "???"[DGX Q
  1.  I DGM("RESULT")="" D  Q
  1.  .S DGI="" F  S DGI=$O(DGM("ERROR",DGI)) Q:DGI=""  D
  1.  ..I DGM("ERROR",DGI)["''" S $P(DGM("ERROR",DGI),"'",2)=DGX
  1.  ..W:DGI=1 ! W !,DGM("ERROR",DGI)
  1.  ..Q
  1.  .K DGX
  1.  .Q
  1.  I DGM("RESULT")'=DGX W "   (",DGM("RESULT"),")"
  1.  S DGX=DGM("RESULT")
  1.  Q
  1.  ;
  1. NOTES()  ;Produce value for the file #20 NOTES ABOUT NAME field ihs/cmi/maw 04/07/2012 PATCH 1015 put back in
  1.  ;Output: string representing when, who and how editing occurred
  1.  ;
  1.  N DGWHEN,DGWHO,DGHOW
  1.  S DGWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
  1.  S DGWHO=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
  1.  S DGWHO=DGWHO_" ("_$G(DUZ)_")"
  1.  S DGHOW=$P($G(XQY0),U)
  1.  Q "Edited: "_DGWHEN_" By: "_DGWHO_" With: "_DGHOW
  1.  ;
  1. FAMILY ;Family name help text
  1.  S DGM("LENGTH")="1-35"
  1.  D HTEXT("family (last) name.",DGM("LENGTH"))
  1.  S DGM("HELP",4)="Input values less than 3 characters in length must be all alpha characters."
  1.  Q
  1.  ;
  1. GIVEN ;Given name help text
  1.  S DGM("LENGTH")="1-25"
  1.  D HTEXT("given (first) name.",DGM("LENGTH"))
  1.  Q
  1.  ;
  1. MIDDLE ;Middle name help text
  1.  S DGM("LENGTH")="1-25"
  1.  D HTEXT("middle name.",DGM("LENGTH"))
  1.  S DGM("HELP",4)="Middle names of 'NMI' and 'NMN' are prohibited."
  1.  Q
  1.  ;
  1. PREFIX ;Name prefix help text
  1.  S DGM("LENGTH")="1-10"
  1.  D HTEXT("name prefix, such as MR or MS.",DGM("LENGTH"))
  1.  Q
  1.  ;
  1. SUFFIX ;Name suffix help text
  1.  S DGM("LENGTH")="1-10"
  1.  D HTEXT("suffix(es), such as JR, SR, II, or III.",DGM("LENGTH"))
  1.  Q
  1.  ;
  1. DEGREE ;Name degree help text
  1.  S DGM("LENGTH")="1-10"
  1.  D HTEXT("academic degree, such as BS, BA, MD, or PHD.",DGM("LENGTH"))
  1.  Q
  1.  ;
  1. CVALID(DGC,DGX,DGM) ;Name component validation
  1.  ; Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
  1.  ;        DGX=input value to validate
  1.  ;        DGM=array to return results and errors (pass by reference)
  1.  ;
  1.  ;Output: DGM array in the format:
  1.  ;       DGM("ERROR",n)=error text (if any) 
  1.  ;       DGM("HELP",n)=help text          
  1.  ;       DGM("LENGTH")=field length in length (e.g. 3-30) 
  1.  ;       DGM("RESULT")=transformed name value (null if invalid entry)
  1.  ; 
  1.  N DGL,DGF,DGI,DGR,DGMSG
  1.  S DGF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1.  S DGF=$P(DGF,DGC),DGF=$L(DGF,U)
  1.  D @DGC  ;Set up length and help text 
  1.  S DGL=+$P(DGM("LENGTH"),"-")_U_+$P(DGM("LENGTH"),"-",2)
  1.  D CVALID^XLFNAME8(DGC,DGX,.DGM)
  1.  Q
  1.  ;
  1. HTEXT(DGF,DGL) ;Generic help text
  1.  ;Input: DGF=field name
  1.  ;       DGL=field length
  1.  S DGM("HELP",1)="Answer with this persons "_DGF
  1.  S DGM("HELP",2)="The response must be "_DGL_" characters in length and may only contain"
  1.  S DGM("HELP",3)="uppercase alpha characters, spaces, hyphens and apostrophes."
  1.  Q
  1.  ;
  1. JUMP(DGI) ;Evaluate request to jump fields
  1.  N DGX,DGY S DGX=$P($E(X,2,99)," ")
  1.  I (U_DGCOM)'[(U_DGX) D  Q
  1.  .W !,"While editing name components, only jumping to other components is allowed!",$C(7)
  1.  .Q
  1.  I (U_DGCOM_U)[(U_DGX_U) S DGI=$O(DGC(DGX,0)) Q
  1.  S DGI=$O(DGC($O(DGC(DGX)),0))
  1.  S DGY=$P(DGCOM,U,DGI)_$P(DGCX,U,DGI) W $P(DGY,DGX,2)
  1.  Q
  1.  ;
  1. COMP(DGX,DGDNC) ;Use existing name array
  1.  ;Input: DGX=name array (pass by reference)
  1.  ;     DGDNC='do not componentize' flag (pass by reference)
  1.  ;
  1.  N DGY,DGI,DGZ
  1.  Q:$D(DGX)<10  Q:DGDNC=0
  1.  S DGDNC=1,DGY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1.  F DGI=1:1:6 S DGZ=$P(DGY,U,DGI) S:'$D(DGX(DGZ)) DGX(DGZ)=""
  1.  Q
  1.  ;
  1. F1(DGX,DGCOMA)  ;Transform text value
  1.  ;Input: DGX=text value to transform (pass by reference)
  1.  ;    DGCOMA=comma indicator
  1.  ;Output: 1 if changed, 0 otherwise
  1.  ;
  1.  N DGI,DGII,DGC,DGY,DGZ,DGOLDX S DGOLDX=DGX
  1.  ;Transform accent grave to apostrophe
  1.  S DGX=$TR(DGX,"`","'")
  1.  ;Transform single characters
  1.  F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:$$FC1(.DGC,DGCOMA)
  1.  .S DGX=$E(DGX,0,DGI-1)_DGC_$E(DGX,DGI+1,999)
  1.  .Q
  1.  ;Transform double character combinations
  1.  S DGY="  ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
  1.  S DGZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
  1.  F DGI=1:1 S DGC=$P(DGY,U,DGI) Q:DGC=""  D
  1.  .Q:DGX'[DGC
  1.  .F DGII=1:1:$L(DGX,DGC)-1 D
  1.  ..S DGX=$P(DGX,DGC,0,DGII)_$P(DGZ,U,DGI)_$P(DGX,DGC,DGII+1,999)
  1.  ..Q
  1.  .Q
  1.  ;Remove NMI and NMN
  1.  F DGY="NMI","NMN" I DGX[DGY,DGCOMA=3 D
  1.  .S DGC=$F(DGX,DGY)
  1.  .I " ,"[$E(DGX,(DGC-4))," ,"[$E(DGX,DGC) D
  1.  ..S DGX=$E(DGX,0,(DGC-4))_$E(DGX,(DGC),999)
  1.  ..F DGY="  ",",," I DGX[DGY D
  1.  ...S DGC=$F(DGX,DGY) S DGX=$E(DGX,0,(DGC-3))_$E(DGX,(DGC-1),999) Q
  1.  ..F DGZ=" ","," F DGC=1,$L(DGX) D
  1.  ...I $E(DGX,DGC)=DGZ S DGX=$E(DGX,0,(DGC-1))_$E(DGX,(DGC+1),999) Q
  1.  ..Q
  1.  .Q
  1.  ;Clean up numerics
  1.  I DGX?.E1N.E D
  1.  .S DGY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
  1.  .F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:DGC?1N
  1.  ..I DGC," ,"[$E(DGX,DGI-1),$E(DGX,DGI,DGI+2)=$P(DGY,U,DGC)," ,"[$E(DGX,DGI+3) Q
  1.  ..I DGC=1," ,"[$E(DGX,DGI-1),$E(DGX,DGI,DGI+3)="10TH"," ,"[$E(DGX,DGI+4) S DGI=DGI+1 Q
  1.  ..S DGX=$E(DGX,0,DGI-1)_$E(DGX,DGI+1,999)
  1.  ..Q
  1.  .Q
  1.  ;Check for dangling apostrophes
  1.  I DGX["'" F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:DGC?1"'"
  1.  .I $E(DGX,(DGI-1))?1U,$E(DGX,(DGI+1))?1U Q
  1.  .S DGX=$E(DGX,0,(DGI-1))_$E(DGX,(DGI+1),99),DGI=1
  1.  .Q
  1.  ;Remove parenthetical text from name value
  1.  N DGCH S DGOLDX(2)=DGX,DGCH=1 F  Q:'DGCH  D
  1.  .S DGCH=0,DGOLDX(1)=DGX,DGY="()[]{}" D
  1.  ..F DGI=1,3,5 S DGC(1)=$E(DGY,DGI),DGC(2)=$E(DGY,DGI+1) D
  1.  ...S DGZ(1)=$$CLAST(DGX,DGC(1)) Q:'DGZ(1)  S DGZ(2)=$F(DGX,DGC(2),DGZ(1))
  1.  ...I DGZ(2)>DGZ(1) S DGX=$E(DGX,0,(DGZ(1)-2))_$E(DGX,DGZ(2),999)
  1.  ...S DGCH=(DGX'=DGOLDX(1)) Q
  1.  ..Q
  1.  .Q
  1.  S:DGX'=DGOLDX(2) DGAUDIT(2)=""
  1.  F DGI=1:1:6 S DGC=$E(DGY,DGI) D
  1.  .F  Q:DGX'[DGC  S DGX=$P(DGX,DGC)_$P(DGX,DGC,2,999)
  1.  .Q
  1.  ;Insure value begins and ends with an alpha character
  1.  F  Q:'$L(DGX)!($E(DGX,1)?1A)  S DGX=$E(DGX,2,999)
  1.  F  Q:'$L(DGX)!($E(DGX,$L(DGX))?1A)  Q:($L(DGX,",")=2)&($E(DGX,$L(DGX))=",")  S DGX=$E(DGX,1,($L(DGX)-1))
  1.  Q DGX'=DGOLDX
  1.  ;
  1. CLAST(DGX,DGC) ;Find last instance of character
  1.  N DGY,DGZ
  1.  S DGZ=$F(DGX,DGC) Q:'DGZ DGZ
  1.  F  S DGY=$F(DGX,DGC,DGZ) Q:'DGY  S DGZ=DGY
  1.  Q DGZ
  1.  ;
  1. FC1(DGC,DGCOMA) ;Transform single character
  1.  ;Input: DGC=character to transform (pass by reference)
  1.  ;    DGCOMA=comma indicator
  1.  ;Output: 1 if value is changed, 0 otherwise
  1.  ;
  1.  S DGC=$E(DGC) Q:'$L(DGC) 0
  1.  ;See if comma stays
  1.  I DGCOMA'=3,DGC?1"," Q 0
  1.  ;Retain uppercase, numeric, hyphen, apostrophe and space
  1.  Q:DGC?1U!(DGC?1N)!(DGC?1"-")!(DGC?1"'")!(DGC?1" ") 0
  1.  ;Retain parenthesis, bracket and brace characters
  1.  Q:DGC?1"("!(DGC?1")")!(DGC?1"[")!(DGC?1"]")!(DGC?1"{")!(DGC?1"}") 0
  1.  ;Transform lowercase to uppercase
  1.  I DGC?1L S DGC=$C($A(DGC)-32) Q 1
  1.  ;Set all other characters to space
  1.  S DGC=" " Q 1
  1.  ;