DPTNAME1 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 12 Aug 2002@20:20
;;5.3;Registration;**244,620,720**;Aug 13, 1993
;
NCEVAL(DGC,DGX) ;Evaluate name component entry values
;Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
; DGX=input value for name
;
Q:DGX="@"
N DGM,DGL,DGI
I DGX=""!($E(DGX)=U) Q
D CVALID(DGC,DGX,.DGM)
M DIR("?")=DGM("HELP") S DGI=$O(DIR("?",""),-1) I DGI D
.S DIR("?")=DIR("?",DGI) K DIR("?",DGI)
.Q
I "???"[DGX Q
I DGM("RESULT")="" D Q
.S DGI="" F S DGI=$O(DGM("ERROR",DGI)) Q:DGI="" D
..I DGM("ERROR",DGI)["''" S $P(DGM("ERROR",DGI),"'",2)=DGX
..W:DGI=1 ! W !,DGM("ERROR",DGI)
..Q
.K DGX
.Q
I DGM("RESULT")'=DGX W " (",DGM("RESULT"),")"
S DGX=DGM("RESULT")
Q
;
FAMILY ;Family name help text
S DGM("LENGTH")="1-35"
D HTEXT("family (last) name.",DGM("LENGTH"))
S DGM("HELP",4)="Input values less than 3 characters in length must be all alpha characters."
Q
;
GIVEN ;Given name help text
S DGM("LENGTH")="1-25"
D HTEXT("given (first) name.",DGM("LENGTH"))
Q
;
MIDDLE ;Middle name help text
S DGM("LENGTH")="1-25"
D HTEXT("middle name.",DGM("LENGTH"))
S DGM("HELP",4)="Middle names of 'NMI' and 'NMN' are prohibited."
Q
;
PREFIX ;Name prefix help text
S DGM("LENGTH")="1-10"
D HTEXT("name prefix, such as MR or MS.",DGM("LENGTH"))
Q
;
SUFFIX ;Name suffix help text
S DGM("LENGTH")="1-10"
D HTEXT("suffix(es), such as JR, SR, II, or III.",DGM("LENGTH"))
Q
;
DEGREE ;Name degree help text
S DGM("LENGTH")="1-10"
D HTEXT("academic degree, such as BS, BA, MD, or PHD.",DGM("LENGTH"))
Q
;
CVALID(DGC,DGX,DGM) ;Name component validation
; Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
; DGX=input value to validate
; DGM=array to return results and errors (pass by reference)
;
;Output: DGM array in the format:
; DGM("ERROR",n)=error text (if any)
; DGM("HELP",n)=help text
; DGM("LENGTH")=field length in length (e.g. 3-30)
; DGM("RESULT")=transformed name value (null if invalid entry)
;
N DGL,DGF,DGI,DGR,DGMSG
S DGF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
S DGF=$P(DGF,DGC),DGF=$L(DGF,U)
D @DGC ;Set up length and help text
S DGL=+$P(DGM("LENGTH"),"-")_U_+$P(DGM("LENGTH"),"-",2)
D CVALID^XLFNAME8(DGC,DGX,.DGM)
Q
;
HTEXT(DGF,DGL) ;Generic help text
;Input: DGF=field name
; DGL=field length
S DGM("HELP",1)="Answer with this persons "_DGF
S DGM("HELP",2)="The response must be "_DGL_" characters in length and may only contain"
S DGM("HELP",3)="uppercase alpha characters, spaces, hyphens and apostrophes."
Q
;
JUMP(DGI) ;Evaluate request to jump fields
N DGX,DGY S DGX=$P($E(X,2,99)," ")
I (U_DGCOM)'[(U_DGX) D Q
.W !,"While editing name components, only jumping to other components is allowed!",$C(7)
.Q
I (U_DGCOM_U)[(U_DGX_U) S DGI=$O(DGC(DGX,0)) Q
S DGI=$O(DGC($O(DGC(DGX)),0))
S DGY=$P(DGCOM,U,DGI)_$P(DGCX,U,DGI) W $P(DGY,DGX,2)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDPTNAME1 3020 printed Dec 13, 2024@03:01:02 Page 2
DPTNAME1 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 12 Aug 2002@20:20
+1 ;;5.3;Registration;**244,620,720**;Aug 13, 1993
+2 ;
NCEVAL(DGC,DGX) ;Evaluate name component entry values
+1 ;Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
+2 ; DGX=input value for name
+3 ;
+4 if DGX="@"
QUIT
+5 NEW DGM,DGL,DGI
+6 IF DGX=""!($EXTRACT(DGX)=U)
QUIT
+7 DO CVALID(DGC,DGX,.DGM)
+8 MERGE DIR("?")=DGM("HELP")
SET DGI=$ORDER(DIR("?",""),-1)
IF DGI
Begin DoDot:1
+9 SET DIR("?")=DIR("?",DGI)
KILL DIR("?",DGI)
+10 QUIT
End DoDot:1
+11 IF "???"[DGX
QUIT
+12 IF DGM("RESULT")=""
Begin DoDot:1
+13 SET DGI=""
FOR
SET DGI=$ORDER(DGM("ERROR",DGI))
if DGI=""
QUIT
Begin DoDot:2
+14 IF DGM("ERROR",DGI)["''"
SET $PIECE(DGM("ERROR",DGI),"'",2)=DGX
+15 if DGI=1
WRITE !
WRITE !,DGM("ERROR",DGI)
+16 QUIT
End DoDot:2
+17 KILL DGX
+18 QUIT
End DoDot:1
QUIT
+19 IF DGM("RESULT")'=DGX
WRITE " (",DGM("RESULT"),")"
+20 SET DGX=DGM("RESULT")
+21 QUIT
+22 ;
FAMILY ;Family name help text
+1 SET DGM("LENGTH")="1-35"
+2 DO HTEXT("family (last) name.",DGM("LENGTH"))
+3 SET DGM("HELP",4)="Input values less than 3 characters in length must be all alpha characters."
+4 QUIT
+5 ;
GIVEN ;Given name help text
+1 SET DGM("LENGTH")="1-25"
+2 DO HTEXT("given (first) name.",DGM("LENGTH"))
+3 QUIT
+4 ;
MIDDLE ;Middle name help text
+1 SET DGM("LENGTH")="1-25"
+2 DO HTEXT("middle name.",DGM("LENGTH"))
+3 SET DGM("HELP",4)="Middle names of 'NMI' and 'NMN' are prohibited."
+4 QUIT
+5 ;
PREFIX ;Name prefix help text
+1 SET DGM("LENGTH")="1-10"
+2 DO HTEXT("name prefix, such as MR or MS.",DGM("LENGTH"))
+3 QUIT
+4 ;
SUFFIX ;Name suffix help text
+1 SET DGM("LENGTH")="1-10"
+2 DO HTEXT("suffix(es), such as JR, SR, II, or III.",DGM("LENGTH"))
+3 QUIT
+4 ;
DEGREE ;Name degree help text
+1 SET DGM("LENGTH")="1-10"
+2 DO HTEXT("academic degree, such as BS, BA, MD, or PHD.",DGM("LENGTH"))
+3 QUIT
+4 ;
CVALID(DGC,DGX,DGM) ;Name component validation
+1 ; Input: DGC=name component (e.g. FAMILY, GIVEN, etc.)
+2 ; DGX=input value to validate
+3 ; DGM=array to return results and errors (pass by reference)
+4 ;
+5 ;Output: DGM array in the format:
+6 ; DGM("ERROR",n)=error text (if any)
+7 ; DGM("HELP",n)=help text
+8 ; DGM("LENGTH")=field length in length (e.g. 3-30)
+9 ; DGM("RESULT")=transformed name value (null if invalid entry)
+10 ;
+11 NEW DGL,DGF,DGI,DGR,DGMSG
+12 SET DGF="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
+13 SET DGF=$PIECE(DGF,DGC)
SET DGF=$LENGTH(DGF,U)
+14 ;Set up length and help text
DO @DGC
+15 SET DGL=+$PIECE(DGM("LENGTH"),"-")_U_+$PIECE(DGM("LENGTH"),"-",2)
+16 DO CVALID^XLFNAME8(DGC,DGX,.DGM)
+17 QUIT
+18 ;
HTEXT(DGF,DGL) ;Generic help text
+1 ;Input: DGF=field name
+2 ; DGL=field length
+3 SET DGM("HELP",1)="Answer with this persons "_DGF
+4 SET DGM("HELP",2)="The response must be "_DGL_" characters in length and may only contain"
+5 SET DGM("HELP",3)="uppercase alpha characters, spaces, hyphens and apostrophes."
+6 QUIT
+7 ;
JUMP(DGI) ;Evaluate request to jump fields
+1 NEW DGX,DGY
SET DGX=$PIECE($EXTRACT(X,2,99)," ")
+2 IF (U_DGCOM)'[(U_DGX)
Begin DoDot:1
+3 WRITE !,"While editing name components, only jumping to other components is allowed!",$CHAR(7)
+4 QUIT
End DoDot:1
QUIT
+5 IF (U_DGCOM_U)[(U_DGX_U)
SET DGI=$ORDER(DGC(DGX,0))
QUIT
+6 SET DGI=$ORDER(DGC($ORDER(DGC(DGX)),0))
+7 SET DGY=$PIECE(DGCOM,U,DGI)_$PIECE(DGCX,U,DGI)
WRITE $PIECE(DGY,DGX,2)
+8 QUIT
+9 ;
