DDEMAP ;SPFO/RAM,MKB - DDE GENERATE ENTITY MAP ;AUG 1, 2018
;;22.2;VA FileMan;**9**;Jan 05, 2016;Build 73
;;Per VA Directive 6402, this routine should not be modified.
;
Q
;
MAIN ;
;
N FDA,IENS,FIELD,ERR,XUMF,IEN,DIR,X,Y,MAPIFN,DA,DINUM,ZERO,DIC,DA,DIRUT
;
K DIR,X,Y
S DIR(0)="F^3:30^"
S DIR("A")="Enter name of ENTITY RESOURCE - use camelCase"
D ^DIR Q:$G(DIRUT)
;
I $D(^DDE("B",Y)) W !!,"An Entity Resource name must be unique - try again",!! G MAIN
;
S ENTITY=Y
;
NUM ;
;
K DIR,X,Y
S DIR(0)="NO^1:999999999999:8^"
S DIR("A")="Enter file number to auto map"
D ^DIR Q:$G(DIRUT)
;
I '$$VFILE^DILFD(Y) W !!,"Not a valid file number in this account - try again",!! G NUM
;
S MAPIFN=Y
;
D ZERO,CLEAN,ITEM,EXIT
;
Q
;
ZERO ; -- zero node
;
K DIC S DIC="^DDE(",X=ENTITY,DIC(0)="F" D FILE^DICN K DIC
;
S IEN=+Y
S ZERO=$G(^DIC(MAPIFN,0))
;
K FDA
S IENS=IEN_","
;
S FDA(1.5,IENS,.02)=MAPIFN
;
D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
CLEAN ; -- clean out SEQUENCE
;
K FDA
S SEQ=0
F S SEQ=$O(^DDE(IEN,1,SEQ)) Q:'SEQ D
.S IENS=SEQ_","_IEN_","
.S FDA(1.51,IENS,.01)="@"
;
D FILE^DIE("E","FDA")
;
Q
;
ITEM ;
;
N FIELD,SEQ,IDX,ZERO,NAME,SUBFILE,TYPE,ZEROIDX,REQUIRED,MIN,MAX,MULTNAME
;
S FIELD=.001,SEQ=0,IDX=0
F S FIELD=$O(^DD(MAPIFN,FIELD)) Q:'FIELD D
. S ZERO=$G(^DD(MAPIFN,FIELD,0)) Q:ZERO=""
. S NAME=$P(ZERO,U)
. S TYPE=$P(ZERO,U,2)
. S REQUIRED=$S(TYPE["R":1,1:0)
. S SUBFILE=$S(TYPE:TYPE,1:"")
. S TYPE=$S(TYPE["F":"string",TYPE["D":"date",TYPE["N":"number",1:"string")
. S SUBFILE=+SUBFILE
. S MULTNAME=$S(SUBFILE:NAME,1:$G(MULTNAME))
. S SEQ=SEQ+1,IDX=IDX+1
. S MAX=$P(ZERO,U,5),MIN=""
. I MAX["K:$L(X)>" S MIN=+$P(MAX,"!($L(X)<",2),MAX=+$P(MAX,"K:$L(X)>",2)
. D NODE
. I FIELD=".01" D IDNODE
;
Q
;
NODE ; -- ITEM NODE
;
K FDA
S IENS="+"_IDX_","_IEN_","
S FDA(1.51,IENS,.01)=$$CC(NAME)
S FDA(1.51,IENS,.02)=SEQ ;FIELD
S FDA(1.51,IENS,.03)=$S(SUBFILE:"L",1:"S") ;TYPE
S FDA(1.51,IENS,.04)=$S(SUBFILE:SUBFILE,1:MAPIFN)
S:'SUBFILE FDA(1.51,IENS,.05)=FIELD
S:SUBFILE FDA(1.51,IENS,1.01)=2
;S FDA(1.51,IENS,1.08)=SEQ
;S:MIN FDA(1.51,IENS,1.04)=MIN
;S:MAX FDA(1.51,IENS,1.05)=MAX
;S:REQUIRED FDA(1.51,IENS,1.1)=REQUIRED
;S FDA(1.51,IENS,1.12)=NAME
;
I SUBFILE D S FDA(1.51,IENS,.08)=NAME ;D:SUBFILE SUBFILE
. N DIC,X,Y,IEN,IENS,FDA
. ; create sub-entity
. I $D(^DDE("B",NAME)) S NAME=NAME_" "_SUBFILE ;ensure unique name
. S DIC="^DDE(",X=NAME,DIC(0)="F",DIC("DR")=".02///"_SUBFILE
. D FILE^DICN S (IEN,SUB)=+Y
. ; populate
. D SUBFILE
;
D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
IDNODE ; id node
;
K FDA
S IENS=IEN_","
;
S FDA(1.5,IENS,1.1)=$$CC(NAME)
S FDA(1.5,IENS,1.2)=".01"
S FDA(1.5,IENS,1.4)="B"
;
D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
SUBFILE ;
;
N SUBSEQ,ZERO1FLD,SUBFIELD,SUBNAME,SUBTYPE,SUBIDX,REQUIRED,MIN,MAX
;
S ZERO1FLD=$P($G(^DD(SUBFILE,.01,0)),U)
;
S SUBFIELD=.001,SUBSEQ=0,SUBIDX=0
F S SUBFIELD=$O(^DD(SUBFILE,SUBFIELD)) Q:'SUBFIELD D
. S ZERO=$G(^DD(SUBFILE,SUBFIELD,0)) Q:ZERO=""
. S SUBNAME=$P(ZERO,U)
. S SUBTYPE=$P(ZERO,U,2)
. S REQUIRED=$S(SUBTYPE["R":1,1:0)
. S SUBTYPE=$S(SUBTYPE["F":"string",SUBTYPE["D":"date",SUBTYPE["N":"number",1:"string")
. S SUBSEQ=SUBSEQ+1,SUBIDX=SUBIDX+1
. S:SUBFIELD=".01" ZEROIDX=SUBIDX
. S MAX=$P(ZERO,U,5),MIN=""
. I MAX["K:$L(X)>" S MIN=+$P(MAX,"!($L(X)<",2),MAX=+$P(MAX,"K:$L(X)>",2)
. D SUBELE
. ;D SUBSEQ
;
Q
;
SUBELE ; -- SUBFILE ITEMS
;
I $O(^DDE(IEN,1,"B",$$CC(SUBNAME),0)) D
. N SUFFIX,ZNAME S SUFFIX=1
. D S SUBNAME=ZNAME
.. F S ZNAME=$$CC(SUBNAME)_SUFFIX,SUFFIX=SUFFIX+1 Q:'$O(^DDE(IEN,1,"B",ZNAME,0))
. S:SUBFIELD=".01" ZERO1FLD=SUBNAME
;
N IENS
;
;S IDX=IDX+1
;
N FDA
S IENS="+"_SUBIDX_","_IEN_","
S FDA(1.51,IENS,.01)=$$CC(SUBNAME)
S FDA(1.51,IENS,.02)=SUBIDX ;SUBFIELD
S FDA(1.51,IENS,.03)="S" ;SUBTYPE
S FDA(1.51,IENS,.04)=SUBFILE
S FDA(1.51,IENS,.05)=SUBFIELD
;S FDA(1.51,IENS,1.01)=$$CC(ZERO1FLD)
;S:MIN FDA(1.51,IENS,1.04)=MIN
;S:MAX FDA(1.51,IENS,1.05)=MAX
;S:REQUIRED FDA(1.51,IENS,1.1)=REQUIRED
;
D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
SUBSEQ ; -- SUBFILE SEQUENCE
;
N IENS
;
K FDA
S IENS="+"_SUBSEQ_","_ZEROIDX_","_IEN_","
S FDA(1.512,IENS,.01)=SUBSEQ
S FDA(1.512,IENS,.02)=$$CC(SUBNAME)
S FDA(1.512,IENS,.03)=SUBFIELD
;
D UPDATE^DIE("E","FDA",,"ERR")
;
Q
;
EXIT ; -- cleanup, and quit
;
Q
;
CC(X) ; -- camelCase
;
Q:$G(X)="" ""
;
N Y,Y1,Y2
S Y=$$TITLE^XLFSTR(X)
S Y=$TR(Y," ","")
S $E(Y,1)=$$LOW^XLFSTR($E(Y,1))
S Y=$TR(Y,")","")
S Y=$TR(Y,"'","")
S Y=$TR(Y,"]","")
S Y=$TR(Y,"?","")
S Y=$TR(Y,"}","")
I Y["{" S Y1=$P(Y,"("),Y2=$P(Y,"(",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["[" S Y1=$P(Y,"["),Y2=$P(Y,"[",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["/" S Y1=$P(Y,"/"),Y2=$P(Y,"/",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["\" S Y1=$P(Y,"\"),Y2=$P(Y,"\",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["-" S Y1=$P(Y,"-"),Y2=$P(Y,"-",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["." S Y1=$P(Y,"."),Y2=$P(Y,".",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["(" S Y1=$P(Y,"("),Y2=$P(Y,"(",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_Y2
I Y["&" S Y1=$P(Y,"&"),Y2=$P(Y,"&",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"And"_Y2
I Y["+" S Y1=$P(Y,"+"),Y2=$P(Y,"+",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"Plus"_Y2
I Y["$" S Y1=$P(Y,"$"),Y2=$P(Y,"$",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"Dollar"_Y2
I Y["#" S Y1=$P(Y,"#"),Y2=$P(Y,"#",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"Number"_Y2
I Y["%" S Y1=$P(Y,"%"),Y2=$P(Y,"%",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"Percent"_Y2
I Y["~" S Y1=$P(Y,"~"),Y2=$P(Y,"~",2),$E(Y2,1)=$$UP^XLFSTR($E(Y2,1)),Y=Y1_"Tilde"_Y2
;
Q Y
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDEMAP 5880 printed Nov 22, 2024@17:52 Page 2
DDEMAP ;SPFO/RAM,MKB - DDE GENERATE ENTITY MAP ;AUG 1, 2018
+1 ;;22.2;VA FileMan;**9**;Jan 05, 2016;Build 73
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 QUIT
+5 ;
MAIN ;
+1 ;
+2 NEW FDA,IENS,FIELD,ERR,XUMF,IEN,DIR,X,Y,MAPIFN,DA,DINUM,ZERO,DIC,DA,DIRUT
+3 ;
+4 KILL DIR,X,Y
+5 SET DIR(0)="F^3:30^"
+6 SET DIR("A")="Enter name of ENTITY RESOURCE - use camelCase"
+7 DO ^DIR
if $GET(DIRUT)
QUIT
+8 ;
+9 IF $DATA(^DDE("B",Y))
WRITE !!,"An Entity Resource name must be unique - try again",!!
GOTO MAIN
+10 ;
+11 SET ENTITY=Y
+12 ;
NUM ;
+1 ;
+2 KILL DIR,X,Y
+3 SET DIR(0)="NO^1:999999999999:8^"
+4 SET DIR("A")="Enter file number to auto map"
+5 DO ^DIR
if $GET(DIRUT)
QUIT
+6 ;
+7 IF '$$VFILE^DILFD(Y)
WRITE !!,"Not a valid file number in this account - try again",!!
GOTO NUM
+8 ;
+9 SET MAPIFN=Y
+10 ;
+11 DO ZERO
DO CLEAN
DO ITEM
DO EXIT
+12 ;
+13 QUIT
+14 ;
ZERO ; -- zero node
+1 ;
+2 KILL DIC
SET DIC="^DDE("
SET X=ENTITY
SET DIC(0)="F"
DO FILE^DICN
KILL DIC
+3 ;
+4 SET IEN=+Y
+5 SET ZERO=$GET(^DIC(MAPIFN,0))
+6 ;
+7 KILL FDA
+8 SET IENS=IEN_","
+9 ;
+10 SET FDA(1.5,IENS,.02)=MAPIFN
+11 ;
+12 DO UPDATE^DIE("E","FDA",,"ERR")
+13 ;
+14 QUIT
+15 ;
CLEAN ; -- clean out SEQUENCE
+1 ;
+2 KILL FDA
+3 SET SEQ=0
+4 FOR
SET SEQ=$ORDER(^DDE(IEN,1,SEQ))
if 'SEQ
QUIT
Begin DoDot:1
+5 SET IENS=SEQ_","_IEN_","
+6 SET FDA(1.51,IENS,.01)="@"
End DoDot:1
+7 ;
+8 DO FILE^DIE("E","FDA")
+9 ;
+10 QUIT
+11 ;
ITEM ;
+1 ;
+2 NEW FIELD,SEQ,IDX,ZERO,NAME,SUBFILE,TYPE,ZEROIDX,REQUIRED,MIN,MAX,MULTNAME
+3 ;
+4 SET FIELD=.001
SET SEQ=0
SET IDX=0
+5 FOR
SET FIELD=$ORDER(^DD(MAPIFN,FIELD))
if 'FIELD
QUIT
Begin DoDot:1
+6 SET ZERO=$GET(^DD(MAPIFN,FIELD,0))
if ZERO=""
QUIT
+7 SET NAME=$PIECE(ZERO,U)
+8 SET TYPE=$PIECE(ZERO,U,2)
+9 SET REQUIRED=$SELECT(TYPE["R":1,1:0)
+10 SET SUBFILE=$SELECT(TYPE:TYPE,1:"")
+11 SET TYPE=$SELECT(TYPE["F":"string",TYPE["D":"date",TYPE["N":"number",1:"string")
+12 SET SUBFILE=+SUBFILE
+13 SET MULTNAME=$SELECT(SUBFILE:NAME,1:$GET(MULTNAME))
+14 SET SEQ=SEQ+1
SET IDX=IDX+1
+15 SET MAX=$PIECE(ZERO,U,5)
SET MIN=""
+16 IF MAX["K:$L(X)>"
SET MIN=+$PIECE(MAX,"!($L(X)<",2)
SET MAX=+$PIECE(MAX,"K:$L(X)>",2)
+17 DO NODE
+18 IF FIELD=".01"
DO IDNODE
End DoDot:1
+19 ;
+20 QUIT
+21 ;
NODE ; -- ITEM NODE
+1 ;
+2 KILL FDA
+3 SET IENS="+"_IDX_","_IEN_","
+4 SET FDA(1.51,IENS,.01)=$$CC(NAME)
+5 ;FIELD
SET FDA(1.51,IENS,.02)=SEQ
+6 ;TYPE
SET FDA(1.51,IENS,.03)=$SELECT(SUBFILE:"L",1:"S")
+7 SET FDA(1.51,IENS,.04)=$SELECT(SUBFILE:SUBFILE,1:MAPIFN)
+8 if 'SUBFILE
SET FDA(1.51,IENS,.05)=FIELD
+9 if SUBFILE
SET FDA(1.51,IENS,1.01)=2
+10 ;S FDA(1.51,IENS,1.08)=SEQ
+11 ;S:MIN FDA(1.51,IENS,1.04)=MIN
+12 ;S:MAX FDA(1.51,IENS,1.05)=MAX
+13 ;S:REQUIRED FDA(1.51,IENS,1.1)=REQUIRED
+14 ;S FDA(1.51,IENS,1.12)=NAME
+15 ;
+16 ;D:SUBFILE SUBFILE
IF SUBFILE
Begin DoDot:1
+17 NEW DIC,X,Y,IEN,IENS,FDA
+18 ; create sub-entity
+19 ;ensure unique name
IF $DATA(^DDE("B",NAME))
SET NAME=NAME_" "_SUBFILE
+20 SET DIC="^DDE("
SET X=NAME
SET DIC(0)="F"
SET DIC("DR")=".02///"_SUBFILE
+21 DO FILE^DICN
SET (IEN,SUB)=+Y
+22 ; populate
+23 DO SUBFILE
End DoDot:1
SET FDA(1.51,IENS,.08)=NAME
+24 ;
+25 DO UPDATE^DIE("E","FDA",,"ERR")
+26 ;
+27 QUIT
+28 ;
IDNODE ; id node
+1 ;
+2 KILL FDA
+3 SET IENS=IEN_","
+4 ;
+5 SET FDA(1.5,IENS,1.1)=$$CC(NAME)
+6 SET FDA(1.5,IENS,1.2)=".01"
+7 SET FDA(1.5,IENS,1.4)="B"
+8 ;
+9 DO UPDATE^DIE("E","FDA",,"ERR")
+10 ;
+11 QUIT
+12 ;
SUBFILE ;
+1 ;
+2 NEW SUBSEQ,ZERO1FLD,SUBFIELD,SUBNAME,SUBTYPE,SUBIDX,REQUIRED,MIN,MAX
+3 ;
+4 SET ZERO1FLD=$PIECE($GET(^DD(SUBFILE,.01,0)),U)
+5 ;
+6 SET SUBFIELD=.001
SET SUBSEQ=0
SET SUBIDX=0
+7 FOR
SET SUBFIELD=$ORDER(^DD(SUBFILE,SUBFIELD))
if 'SUBFIELD
QUIT
Begin DoDot:1
+8 SET ZERO=$GET(^DD(SUBFILE,SUBFIELD,0))
if ZERO=""
QUIT
+9 SET SUBNAME=$PIECE(ZERO,U)
+10 SET SUBTYPE=$PIECE(ZERO,U,2)
+11 SET REQUIRED=$SELECT(SUBTYPE["R":1,1:0)
+12 SET SUBTYPE=$SELECT(SUBTYPE["F":"string",SUBTYPE["D":"date",SUBTYPE["N":"number",1:"string")
+13 SET SUBSEQ=SUBSEQ+1
SET SUBIDX=SUBIDX+1
+14 if SUBFIELD=".01"
SET ZEROIDX=SUBIDX
+15 SET MAX=$PIECE(ZERO,U,5)
SET MIN=""
+16 IF MAX["K:$L(X)>"
SET MIN=+$PIECE(MAX,"!($L(X)<",2)
SET MAX=+$PIECE(MAX,"K:$L(X)>",2)
+17 DO SUBELE
+18 ;D SUBSEQ
End DoDot:1
+19 ;
+20 QUIT
+21 ;
SUBELE ; -- SUBFILE ITEMS
+1 ;
+2 IF $ORDER(^DDE(IEN,1,"B",$$CC(SUBNAME),0))
Begin DoDot:1
+3 NEW SUFFIX,ZNAME
SET SUFFIX=1
+4 Begin DoDot:2
+5 FOR
SET ZNAME=$$CC(SUBNAME)_SUFFIX
SET SUFFIX=SUFFIX+1
if '$ORDER(^DDE(IEN,1,"B",ZNAME,0))
QUIT
End DoDot:2
SET SUBNAME=ZNAME
+6 if SUBFIELD=".01"
SET ZERO1FLD=SUBNAME
End DoDot:1
+7 ;
+8 NEW IENS
+9 ;
+10 ;S IDX=IDX+1
+11 ;
+12 NEW FDA
+13 SET IENS="+"_SUBIDX_","_IEN_","
+14 SET FDA(1.51,IENS,.01)=$$CC(SUBNAME)
+15 ;SUBFIELD
SET FDA(1.51,IENS,.02)=SUBIDX
+16 ;SUBTYPE
SET FDA(1.51,IENS,.03)="S"
+17 SET FDA(1.51,IENS,.04)=SUBFILE
+18 SET FDA(1.51,IENS,.05)=SUBFIELD
+19 ;S FDA(1.51,IENS,1.01)=$$CC(ZERO1FLD)
+20 ;S:MIN FDA(1.51,IENS,1.04)=MIN
+21 ;S:MAX FDA(1.51,IENS,1.05)=MAX
+22 ;S:REQUIRED FDA(1.51,IENS,1.1)=REQUIRED
+23 ;
+24 DO UPDATE^DIE("E","FDA",,"ERR")
+25 ;
+26 QUIT
+27 ;
SUBSEQ ; -- SUBFILE SEQUENCE
+1 ;
+2 NEW IENS
+3 ;
+4 KILL FDA
+5 SET IENS="+"_SUBSEQ_","_ZEROIDX_","_IEN_","
+6 SET FDA(1.512,IENS,.01)=SUBSEQ
+7 SET FDA(1.512,IENS,.02)=$$CC(SUBNAME)
+8 SET FDA(1.512,IENS,.03)=SUBFIELD
+9 ;
+10 DO UPDATE^DIE("E","FDA",,"ERR")
+11 ;
+12 QUIT
+13 ;
EXIT ; -- cleanup, and quit
+1 ;
+2 QUIT
+3 ;
CC(X) ; -- camelCase
+1 ;
+2 if $GET(X)=""
QUIT ""
+3 ;
+4 NEW Y,Y1,Y2
+5 SET Y=$$TITLE^XLFSTR(X)
+6 SET Y=$TRANSLATE(Y," ","")
+7 SET $EXTRACT(Y,1)=$$LOW^XLFSTR($EXTRACT(Y,1))
+8 SET Y=$TRANSLATE(Y,")","")
+9 SET Y=$TRANSLATE(Y,"'","")
+10 SET Y=$TRANSLATE(Y,"]","")
+11 SET Y=$TRANSLATE(Y,"?","")
+12 SET Y=$TRANSLATE(Y,"}","")
+13 IF Y["{"
SET Y1=$PIECE(Y,"(")
SET Y2=$PIECE(Y,"(",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+14 IF Y["["
SET Y1=$PIECE(Y,"[")
SET Y2=$PIECE(Y,"[",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+15 IF Y["/"
SET Y1=$PIECE(Y,"/")
SET Y2=$PIECE(Y,"/",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+16 IF Y["\"
SET Y1=$PIECE(Y,"\")
SET Y2=$PIECE(Y,"\",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+17 IF Y["-"
SET Y1=$PIECE(Y,"-")
SET Y2=$PIECE(Y,"-",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+18 IF Y["."
SET Y1=$PIECE(Y,".")
SET Y2=$PIECE(Y,".",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+19 IF Y["("
SET Y1=$PIECE(Y,"(")
SET Y2=$PIECE(Y,"(",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_Y2
+20 IF Y["&"
SET Y1=$PIECE(Y,"&")
SET Y2=$PIECE(Y,"&",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"And"_Y2
+21 IF Y["+"
SET Y1=$PIECE(Y,"+")
SET Y2=$PIECE(Y,"+",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"Plus"_Y2
+22 IF Y["$"
SET Y1=$PIECE(Y,"$")
SET Y2=$PIECE(Y,"$",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"Dollar"_Y2
+23 IF Y["#"
SET Y1=$PIECE(Y,"#")
SET Y2=$PIECE(Y,"#",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"Number"_Y2
+24 IF Y["%"
SET Y1=$PIECE(Y,"%")
SET Y2=$PIECE(Y,"%",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"Percent"_Y2
+25 IF Y["~"
SET Y1=$PIECE(Y,"~")
SET Y2=$PIECE(Y,"~",2)
SET $EXTRACT(Y2,1)=$$UP^XLFSTR($EXTRACT(Y2,1))
SET Y=Y1_"Tilde"_Y2
+26 ;
+27 QUIT Y
+28 ;
