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