DPTNAME ;BPOIFO/KEITH,ARF - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
;;5.3;Registration;**244,620,1111**;Aug 13, 1993;Build 18
;
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
.;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
.;D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
.D GETS^DIQ(20,DGCOMP,"1:3;5",,"DGCOMP")
.I '$D(DGCOMP(20,DGCOMP)) S DGCOMP=0 Q
.;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
.;F DGI=1:1:6 S DGX($P(DGCOM,U,DGI))=DGCOMP(20,DGCOMP,DGI)
.F DGI=1:1:3,5 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--"
;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
;F DGI=1:1:6 S DGC($P(DGCOM,U,DGI),DGI)=""
F DGI=1:1:3,5 S DGC($P(DGCOM,U,DGI),DGI)=""
;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
;F DGI=1:1:6 Q:DGOUT D
F DGI=1:1:3,5 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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTNAME 4042 printed Nov 22, 2024@18:11 Page 2
DPTNAME ;BPOIFO/KEITH,ARF - NAME STANDARDIZATION ; 27 Jan 2002 11:05 PM
+1 ;;5.3;Registration;**244,620,1111**;Aug 13, 1993;Build 18
+2 ;
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 ;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
+9 ;D GETS^DIQ(20,DGCOMP,"1:6",,"DGCOMP")
+10 DO GETS^DIQ(20,DGCOMP,"1:3;5",,"DGCOMP")
+11 IF '$DATA(DGCOMP(20,DGCOMP))
SET DGCOMP=0
QUIT
+12 ;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
+13 ;F DGI=1:1:6 S DGX($P(DGCOM,U,DGI))=DGCOMP(20,DGCOMP,DGI)
+14 FOR DGI=1:1:3,5
SET DGX($PIECE(DGCOM,U,DGI))=DGCOMP(20,DGCOMP,DGI)
+15 QUIT
End DoDot:1
+16 ;Parse name components from name value
+17 IF 'DGCOMP
Begin DoDot:1
+18 DO STDNAME^XLFNAME(.DGX,"C")
SET DGEDIT=1
+19 SET DGX("SUFFIX")=$$CLEANC^XLFNAME(DGX("SUFFIX"))
+20 QUIT
End DoDot:1
+21 ;Prompt for name component edits
+22 NEW DTOUT,DUOUT,DIRUT,DGCOUT
+23 SET DGCOUT=0
MERGE DG20NAME=DGX
+24 SET DIR("PRE")="D:X'=""@"" NCEVAL^DPTNAME1(DGCOMP,.X)"
+25 IF $GET(DGHDR)
WRITE !,"Patient name components--"
+26 ;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
+27 ;F DGI=1:1:6 S DGC($P(DGCOM,U,DGI),DGI)=""
+28 FOR DGI=1:1:3,5
SET DGC($PIECE(DGCOM,U,DGI),DGI)=""
+29 ;DG*5.3*1111 removed PREFIX (#20,4), and DEGREE (#20,6) fields of the NAME COMPONENTS (#20) file
+30 ;F DGI=1:1:6 Q:DGOUT D
+31 FOR DGI=1:1:3,5
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
