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

DPTNAME.m

Go to the documentation of this file. 
  1. DPTNAME ;BPOIFO/KEITH - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
  1.  ;;5.3;Registration;**244,620,1015**;Aug 13, 1993;Build 21
  1.  ;
  1. NARY(DG20NAME) ;Set up name array  ihs/cmi/maw 04/07/2012 PATCH 1015 put back in
  1.  ;Input: DG20NAME=full name value
  1.  ;       DG20NAME(component_names)=corresponding value--if undefined,
  1.  ;                these will get set up
  1.  ;
  1.  N DGX M DGX=DG20NAME
  1.  D STDNAME^XLFNAME(.DG20NAME,"FC")
  1.  M DG20NAME=DGX
  1.  S DG20NAME("NOTES")=$$NOTES^DPTNAME1()
  1.  Q
  1.  ;
  1. POSTC(DGX) ;Post-clean components
  1.  ;Remove parenthesis if not removed by Kernel
  1.  N DGI,DGXOLD
  1.  S DGXOLD=DGX,DGX=$TR(DGX,"()[]{}")
  1.  ;Check for numbers left behind by Kernel
  1.  F DGI=0:1:9 S DGX=$TR(DGX,DGI)
  1.  I DGX'=DGXOLD S DGAUDIT(4)=""
  1.  Q DGX
  1.  ;
  1. NOP(DGX) ;Produce 'NOP' x-ref value
  1.  ;Input: DGX=name value to evaluate
  1.  ;Output : Standardized name or null if the same as input value
  1.  N DGNEWX
  1.  S DGNEWX=$$FORMAT(DGX,3,30,1)
  1.  Q $S(DGX=DGNEWX:"",1:DGNEWX)
  1.  ;
  1. FORMAT(DGNAME,DGMINL,DGMAXL,DGNOP,DGCOMA,DGAUDIT,DGFAM,DGDNC) ;Format name value
  1.  ;Input: DGNAME=text value representing person name to transform
  1.  ;       DGMINL=minimum length (optional), default 3
  1.  ;       DGMAXL=maximum length (optional), default 30
  1.  ;        DGNOP=1 to standardize last name for 'NOP' x-ref. (optional)
  1.  ;       DGCOMA=0 to not require a comma
  1.  ;              1 to require a comma in the input value
  1.  ;              2 to add a comma if none
  1.  ;              3 to prohibit (remove) commas
  1.  ;              (optional) default if not specified is 1
  1.  ;
  1.  ;      DGAUDIT=variable to return audit, pass by reference (optional),
  1.  ;              returned values:  
  1.  ;              DGAUDIT=0 if no change was made
  1.  ;                      1 if name is changed
  1.  ;                      2 if name could not be converted
  1.  ;             DGAUDIT(1) defined if name contains no comma
  1.  ;             DGAUDIT(2) defined if parenthetical text is removed
  1.  ;             DGAUDIT(3) defined if value is unconvertible
  1.  ;             DGAUDIT(4) defined if characters are removed or changed
  1.  ;        DGFAM='1' if just the family name, '0' otherwise (optional)
  1.  ;        DGDNC='1' to prevent componentization (optional)
  1.  ;
  1.  ;Output: DGNAME in specified format or null if length of transformed value is less than DGMINL
  1.  ;
  1.  N DGX,DGOX,DGOLDN,DGAX,DGI,DGNEWN
  1.  ;Initialize variables
  1.  K DGAUDIT
  1.  S DGOLDN=DGNAME M DGX=DGNAME
  1.  S DGDNC=$G(DGDNC) D COMP^DPTNAME1(.DGX,.DGDNC)
  1.  S DGMINL=+$G(DGMINL) S:DGMINL<1 DGMINL=3
  1.  S DGMAXL=+$G(DGMAXL) S:DGMAXL<DGMINL DGMAXL=30
  1.  S DGNOP=$S($G(DGNOP)=1:"S",1:"")
  1.  S:'$L($G(DGCOMA)) DGCOMA=1 S DGCOMA=+DGCOMA
  1.  S DGFAM=$S($G(DGFAM)=1:"F",1:"")
  1.  ;
  1.  ;Check for comma
  1.  I DGX'["," S DGAUDIT(1)=""
  1.  I DGCOMA=1,DGX'["," S DGAUDIT=2,DGAUDIT(3)=""  Q ""
  1.  ;Clean input value
  1.  F  Q:'$$F1^DPTNAME1(.DGX,DGCOMA)
  1.  I DGX'=DGOLDN S DGAUDIT(4)=""
  1.  ;Add comma if necessary
  1.  I DGCOMA=2,DGX'[" ",DGX'["," S DGX=DGX_","
  1.  I DGX=DGOLDN K DGAUDIT(4)
  1.  ;Quit if result is too short
  1.  I $L(DGX)<DGMINL S DGAUDIT=2,DGAUDIT(3)="" K DGNAME Q ""
  1.  S DGNAME=DGX I 'DGDNC D
  1.  .;Parse the name
  1.  .D STDNAME^XLFNAME(.DGX,DGFAM_"CP",.DGAX)
  1.  .I $D(DGAX("STRIP")) S DGAUDIT(2)=""
  1.  .I $D(DGAX("NM"))!$D(DGAX("PERIOD")) S DGAUDIT(4)=""
  1.  .I $D(DGAX("PUNC"))!($D(DGAX("SPACE"))&'$L(DGFAM)) S DGAUDIT(4)=""
  1.  .I $D(DGAX("SPACE")),$L(DGFAM),DGNAME'=$G(DGX("FAMILY")) S DGAUDIT(4)=""
  1.  .;Standardize the suffix
  1.  .S DGX("SUFFIX")=$$CLEANC^XLFNAME(DGX("SUFFIX"))
  1.  .;Post-clean components
  1.  .S DGI="" F  S DGI=$O(DGX(DGI)) Q:DGI=""  S DGX(DGI)=$$POSTC(DGX(DGI))
  1.  .;Reconstruct name from components
  1.  .S DGNAME=$$NAMEFMT^XLFNAME(.DGX,"F","CL"_DGMAXL_DGNOP)
  1.  .;Adjust name for 'do not componentize'
  1.  .;I DGDNC S DGNAME=DGX("FAMILY")
  1.  ;Return comma for single value names
  1.  I DGCOMA,DGCOMA'=3,DGNAME'["," S DGNAME=DGNAME_","
  1.  ;Check length again
  1.  I $L(DGNAME)<DGMINL S DGAUDIT=2,DGAUDIT(3)="" K DGNAME Q ""
  1.  ;Enforce minimum 2 character last name rule
  1.  ;I '$L(DGFAM),$L($P(DGNAME,","))<3,$P(DGNAME,",")'?2U D  Q ""
  1.  ;.S DGAUDIT=2,DGAUDIT(3)="" K DGNAME
  1.  ;.Q
  1.  ;Remove hyphens and apostrophes for 'NOP' x-ref
  1.  S DGX=DGNAME I DGNOP="S" S DGNAME=$TR(DGNAME,"'-")
  1.  I DGNAME'=DGX S DGAUDIT(4)=""
  1.  I DGNAME=DGOLDN K DGAUDIT
  1.  S DGAUDIT=DGNAME'=DGOLDN I DGAUDIT,$D(DGAUDIT)<10 S DGAUDIT(4)=""
  1.  S DGNEWN=DGNAME M DGNAME=DGX S DGNAME=DGNEWN
  1.  Q DGNAME
  1.  ;
  1. NCEDIT(DFN,DGHDR,DG20NAME) ;Edit name components
  1.  ;Input: DFN=patient ifn
  1.  ;     DGHDR=1 to write components header (optional)
  1.  ;  DG20NAME=array of name components (optional)
  1.  ;Output: formatted name and DG20NAME components array if the user
  1.  ;        specifies filing, DG20NAME=null otherwise
  1.  ;
  1.  N DIR,X,Y,DGCOMP,DGC,DGI,DGX,DGY,DGCOM
  1.  N DGCL,DGCX,DGOUT,DGEDIT,%,DIE,DR,DA
  1.  ;Initialize variables
  1. START S DFN=+DFN,(DGOUT,DGEDIT)=0,DGCOMP=$D(DG20NAME)>9
  1.  S DGCOM="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
  1.  S DGCX=" (LAST) NAME^ (FIRST) NAME^ NAME"
  1.  S DGCL="1:35^1:25^1:25^1:10^1:10^1:10"
  1.  ;Get patient name
  1.  S DGX=$P($G(^DPT(DFN,0)),U) Q:DGX=""
  1.  ;Get name component values from file #20
  1.  I 'DGCOMP S DGCOMP=+$G(^DPT(DFN,"NAME"))_"," I DGCOMP D
  1.  .D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
  1.  .I '$D(DGCOMP(20,DGCOMP)) S DGCOMP=0 Q
  1.  .F DGI=1:1:6 S DGX($P(DGCOM,U,DGI))=DGCOMP(20,DGCOMP,DGI)
  1.  .Q
  1.  ;Parse name components from name value
  1.  I 'DGCOMP D
  1.  .D STDNAME^XLFNAME(.DGX,"C") S DGEDIT=1
  1.  .S DGX("SUFFIX")=$$CLEANC^XLFNAME(DGX("SUFFIX"))
  1.  .Q
  1.  ;Prompt for name component edits
  1.  N DTOUT,DUOUT,DIRUT,DGCOUT
  1.  S DGCOUT=0 M DG20NAME=DGX
  1.  S DIR("PRE")="D:X'=""@"" NCEVAL^DPTNAME1(DGCOMP,.X)"
  1.  I $G(DGHDR) W !,"Patient name components--"
  1.  F DGI=1:1:6 S DGC($P(DGCOM,U,DGI),DGI)=""
  1.  F DGI=1:1:6 Q:DGOUT  D
  1. AGAIN .S DGCOMP=$P(DGCOM,U,DGI)
  1.  .S DIR("A")=DGCOMP_$P(DGCX,U,DGI)
  1.  .S DIR(0)="FO^"_$P(DGCL,U,DGI)
  1.  .S DIR("PRE")="D NCEVAL^DPTNAME1(DGCOMP,.X)"
  1.  .S DIR("B")=$S($D(DG20NAME(DGCOMP)):DG20NAME(DGCOMP),1:$G(DGX(DGCOMP)))
  1.  .K:'$L(DIR("B")) DIR("B")
  1. ASK .D ^DIR I $D(DTOUT)!(X=U) S:(X=U) DGCOUT=1 S DGOUT=1 Q
  1.  .I $A(X)=94 D JUMP^DPTNAME1(.DGI) G AGAIN
  1.  .I X="@",DGI=1 W !,$C(7),"Family name cannot be deleted!" G ASK
  1.  .I X="@" D  Q
  1.  ..W "  (deletion indicated)" S DG20NAME(DGCOMP)=""
  1.  ..S:DG20NAME(DGCOMP)'=$G(DGX(DGCOMP)) DGEDIT=1
  1.  ..Q
  1.  .Q:'$L(X)
  1.  .S DG20NAME=X
  1.  .I DGCOMP="SUFFIX" S DG20NAME=$$CLEANC^XLFNAME(DG20NAME)
  1.  .S DG20NAME=$$FORMAT^XLFNAME7(DG20NAME,1,35,,3,,1,1)
  1.  .I '$L(DG20NAME) W "  ??",$C(7) G ASK
  1.  .W:DG20NAME'=X "   (",DG20NAME,")" S DG20NAME(DGCOMP)=DG20NAME
  1.  .S:DG20NAME(DGCOMP)'=$G(DGX(DGCOMP)) DGEDIT=1
  1.  .Q
  1.  Q:'DGEDIT ""
  1.  Q:DGOUT&'DGCOUT ""
  1.  ;Reconstruct name
  1.  S DG20NAME=$$NAMEFMT^XLFNAME(.DG20NAME,"F","CFL30")
  1.  ;Format the .01 value
  1.  M DGY=DG20NAME
  1.  S DG20NAME=$$FORMAT^XLFNAME7(.DGY,3,30,,2)
  1.  ;Check the length
  1.  I $L(DG20NAME)<3 D  G START
  1.  .W !,"Invalid values to file, full name must be at least 3 characters!",$C(7)
  1.  .K DG20NAME,DGX,DGCOMP Q
  1.  ;File new name value
  1. CONF W !,"Ok to file '",DG20NAME,"' and its name components"
  1.  S %=1 D YN^DICN
  1.  I '% W !,"Indicate if the edits to the name and its components should be filed." G CONF
  1.  I %'=1 K DG20NAME S DG20NAME="" Q DG20NAME
  1.  I '$$CONF1(DG20NAME) K DG20NAME S DG20NAME=""
  1.  Q DG20NAME
  1.  ;
  1. CONF1(DPTX) ;Confirm if single name value is ok.
  1.  ;Input: DPTX=name value
  1.  N %
  1.  Q:$E($P(DPTX,",",2))?1U 1
  1.  W !!?5,$C(7),"WARNING: Do not enter single name values for patients (no given or"
  1.  W !?5,"         first name) unless this is actually their legal name!!!",$C(7)
  1. RC W !!,"Are you sure you want to enter the patient name in this manner"
  1.  S %=2 D YN^DICN S %=$S(%<0!(%=2):-1,%=1:1,1:0) I '% W !?6,"Specify 'YES' to enter a single name value, or 'NO' to discontinue." G RC
  1.  W !
  1.  Q %=1