DPTNAME1 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 12 Aug 2002@20:20
;;5.3;Registration;**244,620,720,1015**;Aug 13, 1993;Build 21
;
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
;
NOTES() ;Produce value for the file #20 NOTES ABOUT NAME field ihs/cmi/maw 04/07/2012 PATCH 1015 put back in
;Output: string representing when, who and how editing occurred
;
N DGWHEN,DGWHO,DGHOW
S DGWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
S DGWHO=$S($G(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
S DGWHO=DGWHO_" ("_$G(DUZ)_")"
S DGHOW=$P($G(XQY0),U)
Q "Edited: "_DGWHEN_" By: "_DGWHO_" With: "_DGHOW
;
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
;
COMP(DGX,DGDNC) ;Use existing name array
;Input: DGX=name array (pass by reference)
; DGDNC='do not componentize' flag (pass by reference)
;
N DGY,DGI,DGZ
Q:$D(DGX)<10 Q:DGDNC=0
S DGDNC=1,DGY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
F DGI=1:1:6 S DGZ=$P(DGY,U,DGI) S:'$D(DGX(DGZ)) DGX(DGZ)=""
Q
;
F1(DGX,DGCOMA) ;Transform text value
;Input: DGX=text value to transform (pass by reference)
; DGCOMA=comma indicator
;Output: 1 if changed, 0 otherwise
;
N DGI,DGII,DGC,DGY,DGZ,DGOLDX S DGOLDX=DGX
;Transform accent grave to apostrophe
S DGX=$TR(DGX,"`","'")
;Transform single characters
F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:$$FC1(.DGC,DGCOMA)
.S DGX=$E(DGX,0,DGI-1)_DGC_$E(DGX,DGI+1,999)
.Q
;Transform double character combinations
S DGY=" ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
S DGZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
F DGI=1:1 S DGC=$P(DGY,U,DGI) Q:DGC="" D
.Q:DGX'[DGC
.F DGII=1:1:$L(DGX,DGC)-1 D
..S DGX=$P(DGX,DGC,0,DGII)_$P(DGZ,U,DGI)_$P(DGX,DGC,DGII+1,999)
..Q
.Q
;Remove NMI and NMN
F DGY="NMI","NMN" I DGX[DGY,DGCOMA=3 D
.S DGC=$F(DGX,DGY)
.I " ,"[$E(DGX,(DGC-4))," ,"[$E(DGX,DGC) D
..S DGX=$E(DGX,0,(DGC-4))_$E(DGX,(DGC),999)
..F DGY=" ",",," I DGX[DGY D
...S DGC=$F(DGX,DGY) S DGX=$E(DGX,0,(DGC-3))_$E(DGX,(DGC-1),999) Q
..F DGZ=" ","," F DGC=1,$L(DGX) D
...I $E(DGX,DGC)=DGZ S DGX=$E(DGX,0,(DGC-1))_$E(DGX,(DGC+1),999) Q
..Q
.Q
;Clean up numerics
I DGX?.E1N.E D
.S DGY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
.F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:DGC?1N
..I DGC," ,"[$E(DGX,DGI-1),$E(DGX,DGI,DGI+2)=$P(DGY,U,DGC)," ,"[$E(DGX,DGI+3) Q
..I DGC=1," ,"[$E(DGX,DGI-1),$E(DGX,DGI,DGI+3)="10TH"," ,"[$E(DGX,DGI+4) S DGI=DGI+1 Q
..S DGX=$E(DGX,0,DGI-1)_$E(DGX,DGI+1,999)
..Q
.Q
;Check for dangling apostrophes
I DGX["'" F DGI=1:1:$L(DGX) S DGC=$E(DGX,DGI) D:DGC?1"'"
.I $E(DGX,(DGI-1))?1U,$E(DGX,(DGI+1))?1U Q
.S DGX=$E(DGX,0,(DGI-1))_$E(DGX,(DGI+1),99),DGI=1
.Q
;Remove parenthetical text from name value
N DGCH S DGOLDX(2)=DGX,DGCH=1 F Q:'DGCH D
.S DGCH=0,DGOLDX(1)=DGX,DGY="()[]{}" D
..F DGI=1,3,5 S DGC(1)=$E(DGY,DGI),DGC(2)=$E(DGY,DGI+1) D
...S DGZ(1)=$$CLAST(DGX,DGC(1)) Q:'DGZ(1) S DGZ(2)=$F(DGX,DGC(2),DGZ(1))
...I DGZ(2)>DGZ(1) S DGX=$E(DGX,0,(DGZ(1)-2))_$E(DGX,DGZ(2),999)
...S DGCH=(DGX'=DGOLDX(1)) Q
..Q
.Q
S:DGX'=DGOLDX(2) DGAUDIT(2)=""
F DGI=1:1:6 S DGC=$E(DGY,DGI) D
.F Q:DGX'[DGC S DGX=$P(DGX,DGC)_$P(DGX,DGC,2,999)
.Q
;Insure value begins and ends with an alpha character
F Q:'$L(DGX)!($E(DGX,1)?1A) S DGX=$E(DGX,2,999)
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))
Q DGX'=DGOLDX
;
CLAST(DGX,DGC) ;Find last instance of character
N DGY,DGZ
S DGZ=$F(DGX,DGC) Q:'DGZ DGZ
F S DGY=$F(DGX,DGC,DGZ) Q:'DGY S DGZ=DGY
Q DGZ
;
FC1(DGC,DGCOMA) ;Transform single character
;Input: DGC=character to transform (pass by reference)
; DGCOMA=comma indicator
;Output: 1 if value is changed, 0 otherwise
;
S DGC=$E(DGC) Q:'$L(DGC) 0
;See if comma stays
I DGCOMA'=3,DGC?1"," Q 0
;Retain uppercase, numeric, hyphen, apostrophe and space
Q:DGC?1U!(DGC?1N)!(DGC?1"-")!(DGC?1"'")!(DGC?1" ") 0
;Retain parenthesis, bracket and brace characters
Q:DGC?1"("!(DGC?1")")!(DGC?1"[")!(DGC?1"]")!(DGC?1"{")!(DGC?1"}") 0
;Transform lowercase to uppercase
I DGC?1L S DGC=$C($A(DGC)-32) Q 1
;Set all other characters to space
S DGC=" " Q 1
;
DPTNAME1 ;BPOIFO/KEITH - NAME STANDARDIZATION ; 12 Aug 2002@20:20
+1 ;;5.3;Registration;**244,620,720,1015**;Aug 13, 1993;Build 21
+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 ;
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
+2 ;
+3 NEW DGWHEN,DGWHO,DGHOW
+4 SET DGWHEN=$$FMTE^XLFDT($$NOW^XLFDT())
+5 SET DGWHO=$SELECT($GET(DUZ)>0:$$GET1^DIQ(200,DUZ_",",.01),1:"Unknown")
+6 SET DGWHO=DGWHO_" ("_$GET(DUZ)_")"
+7 SET DGHOW=$PIECE($GET(XQY0),U)
+8 QUIT "Edited: "_DGWHEN_" By: "_DGWHO_" With: "_DGHOW
+9 ;
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 ;
COMP(DGX,DGDNC) ;Use existing name array
+1 ;Input: DGX=name array (pass by reference)
+2 ; DGDNC='do not componentize' flag (pass by reference)
+3 ;
+4 NEW DGY,DGI,DGZ
+5 IF $DATA(DGX)<10
QUIT
IF DGDNC=0
QUIT
+6 SET DGDNC=1
SET DGY="FAMILY^GIVEN^MIDDLE^PREFIX^SUFFIX^DEGREE"
+7 FOR DGI=1:1:6
SET DGZ=$PIECE(DGY,U,DGI)
IF '$DATA(DGX(DGZ))
SET DGX(DGZ)=""
+8 QUIT
+9 ;
F1(DGX,DGCOMA) ;Transform text value
+1 ;Input: DGX=text value to transform (pass by reference)
+2 ; DGCOMA=comma indicator
+3 ;Output: 1 if changed, 0 otherwise
+4 ;
+5 NEW DGI,DGII,DGC,DGY,DGZ,DGOLDX
SET DGOLDX=DGX
+6 ;Transform accent grave to apostrophe
+7 SET DGX=$TRANSLATE(DGX,"`","'")
+8 ;Transform single characters
+9 FOR DGI=1:1:$LENGTH(DGX)
SET DGC=$EXTRACT(DGX,DGI)
IF $$FC1(.DGC,DGCOMA)
Begin DoDot:1
+10 SET DGX=$EXTRACT(DGX,0,DGI-1)_DGC_$EXTRACT(DGX,DGI+1,999)
+11 QUIT
End DoDot:1
+12 ;Transform double character combinations
+13 SET DGY=" ^--^,,^''^,-^,'^ ,^-,^',^ -^ '^- ^' ^-'^'-"
+14 SET DGZ=" ^-^,^'^,^,^,^,^,^ ^ ^ ^ ^-^-"
+15 FOR DGI=1:1
SET DGC=$PIECE(DGY,U,DGI)
IF DGC=""
QUIT
Begin DoDot:1
+16 IF DGX'[DGC
QUIT
+17 FOR DGII=1:1:$LENGTH(DGX,DGC)-1
Begin DoDot:2
+18 SET DGX=$PIECE(DGX,DGC,0,DGII)_$PIECE(DGZ,U,DGI)_$PIECE(DGX,DGC,DGII+1,999)
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;Remove NMI and NMN
+22 FOR DGY="NMI","NMN"
IF DGX[DGY
IF DGCOMA=3
Begin DoDot:1
+23 SET DGC=$FIND(DGX,DGY)
+24 IF " ,"[$EXTRACT(DGX,(DGC-4))
IF " ,"[$EXTRACT(DGX,DGC)
Begin DoDot:2
+25 SET DGX=$EXTRACT(DGX,0,(DGC-4))_$EXTRACT(DGX,(DGC),999)
+26 FOR DGY=" ",",,"
IF DGX[DGY
Begin DoDot:3
+27 SET DGC=$FIND(DGX,DGY)
SET DGX=$EXTRACT(DGX,0,(DGC-3))_$EXTRACT(DGX,(DGC-1),999)
QUIT
End DoDot:3
+28 FOR DGZ=" ",","
FOR DGC=1,$LENGTH(DGX)
Begin DoDot:3
+29 IF $EXTRACT(DGX,DGC)=DGZ
SET DGX=$EXTRACT(DGX,0,(DGC-1))_$EXTRACT(DGX,(DGC+1),999)
QUIT
End DoDot:3
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;Clean up numerics
+33 IF DGX?.E1N.E
Begin DoDot:1
+34 SET DGY="1ST^2ND^3RD^4TH^5TH^6TH^7TH^8TH^9TH"
+35 FOR DGI=1:1:$LENGTH(DGX)
SET DGC=$EXTRACT(DGX,DGI)
IF DGC?1N
Begin DoDot:2
+36 IF DGC
IF " ,"[$EXTRACT(DGX,DGI-1)
IF $EXTRACT(DGX,DGI,DGI+2)=$PIECE(DGY,U,DGC)
IF " ,"[$EXTRACT(DGX,DGI+3)
QUIT
+37 IF DGC=1
IF " ,"[$EXTRACT(DGX,DGI-1)
IF $EXTRACT(DGX,DGI,DGI+3)="10TH"
IF " ,"[$EXTRACT(DGX,DGI+4)
SET DGI=DGI+1
QUIT
+38 SET DGX=$EXTRACT(DGX,0,DGI-1)_$EXTRACT(DGX,DGI+1,999)
+39 QUIT
End DoDot:2
+40 QUIT
End DoDot:1
+41 ;Check for dangling apostrophes
+42 IF DGX["'"
FOR DGI=1:1:$LENGTH(DGX)
SET DGC=$EXTRACT(DGX,DGI)
IF DGC?1"'"
Begin DoDot:1
+43 IF $EXTRACT(DGX,(DGI-1))?1U
IF $EXTRACT(DGX,(DGI+1))?1U
QUIT
+44 SET DGX=$EXTRACT(DGX,0,(DGI-1))_$EXTRACT(DGX,(DGI+1),99)
SET DGI=1
+45 QUIT
End DoDot:1
+46 ;Remove parenthetical text from name value
+47 NEW DGCH
SET DGOLDX(2)=DGX
SET DGCH=1
FOR
IF 'DGCH
QUIT
Begin DoDot:1
+48 SET DGCH=0
SET DGOLDX(1)=DGX
SET DGY="()[]{}"
Begin DoDot:2
+49 FOR DGI=1,3,5
SET DGC(1)=$EXTRACT(DGY,DGI)
SET DGC(2)=$EXTRACT(DGY,DGI+1)
Begin DoDot:3
+50 SET DGZ(1)=$$CLAST(DGX,DGC(1))
IF 'DGZ(1)
QUIT
SET DGZ(2)=$FIND(DGX,DGC(2),DGZ(1))
+51 IF DGZ(2)>DGZ(1)
SET DGX=$EXTRACT(DGX,0,(DGZ(1)-2))_$EXTRACT(DGX,DGZ(2),999)
+52 SET DGCH=(DGX'=DGOLDX(1))
QUIT
End DoDot:3
+53 QUIT
End DoDot:2
+54 QUIT
End DoDot:1
+55 IF DGX'=DGOLDX(2)
SET DGAUDIT(2)=""
+56 FOR DGI=1:1:6
SET DGC=$EXTRACT(DGY,DGI)
Begin DoDot:1
+57 FOR
IF DGX'[DGC
QUIT
SET DGX=$PIECE(DGX,DGC)_$PIECE(DGX,DGC,2,999)
+58 QUIT
End DoDot:1
+59 ;Insure value begins and ends with an alpha character
+60 FOR
IF '$LENGTH(DGX)!($EXTRACT(DGX,1)?1A)
QUIT
SET DGX=$EXTRACT(DGX,2,999)
+61 FOR
IF '$LENGTH(DGX)!($EXTRACT(DGX,$LENGTH(DGX))?1A)
QUIT
IF ($LENGTH(DGX,",")=2)&($EXTRACT(DGX,$LENGTH(DGX))=",")
QUIT
SET DGX=$EXTRACT(DGX,1,($LENGTH(DGX)-1))
+62 QUIT DGX'=DGOLDX
+63 ;
CLAST(DGX,DGC) ;Find last instance of character
+1 NEW DGY,DGZ
+2 SET DGZ=$FIND(DGX,DGC)
IF 'DGZ
QUIT DGZ
+3 FOR
SET DGY=$FIND(DGX,DGC,DGZ)
IF 'DGY
QUIT
SET DGZ=DGY
+4 QUIT DGZ
+5 ;
FC1(DGC,DGCOMA) ;Transform single character
+1 ;Input: DGC=character to transform (pass by reference)
+2 ; DGCOMA=comma indicator
+3 ;Output: 1 if value is changed, 0 otherwise
+4 ;
+5 SET DGC=$EXTRACT(DGC)
IF '$LENGTH(DGC)
QUIT 0
+6 ;See if comma stays
+7 IF DGCOMA'=3
IF DGC?1","
QUIT 0
+8 ;Retain uppercase, numeric, hyphen, apostrophe and space
+9 IF DGC?1U!(DGC?1N)!(DGC?1"-")!(DGC?1"'")!(DGC?1" ")
QUIT 0
+10 ;Retain parenthesis, bracket and brace characters
+11 IF DGC?1"("!(DGC?1")")!(DGC?1"[")!(DGC?1"]")!(DGC?1"{")!(DGC?1"}")
QUIT 0
+12 ;Transform lowercase to uppercase
+13 IF DGC?1L
SET DGC=$CHAR($ASCII(DGC)-32)
QUIT 1
+14 ;Set all other characters to space
+15 SET DGC=" "
QUIT 1
+16 ;
