XQ11 ;SEA/MJM - Menu Utilities ;1/08/2006
;;8.0;KERNEL;**155,372**;Jul 10, 1995;Build 3
;
COPY ;Make a copy of a menu-type option
S XQA=$S(DUZ(0)["@":1,$D(^XUSEC("XUMGR",DUZ)):1,$D(^XUSEC("XUPROGMODE",DUZ)):1,1:0)
S XQD="",%=0 I $D(^VA(200,DUZ,19.6,0)),$L($P(^(0),U,3)),$P(^(0),U,3)>0 F XQI=0:0 S %=$O(^VA(200,DUZ,19.6,%)) Q:%=""!(%'?1N.N) S XQD=XQD_^(%,0)_","
I 'XQA,'$L(XQD) W !!,"Sorry. You need to be assigned a valid name space to proceed." H 6 S XQH="XQNAMSPAC" D EN^XQH Q
;
S DIC="^DIC(19,",DIC(0)="AEMQZ",DIC("A")="Menu you would like to make a copy of: " D ^DIC
Q:Y=-1 S XQYO=+Y
W !!,"WARNING ** Option names must be carefully named to avoid system damage!!",!?5,"Do you want more information? Yes// "
R XQUR:DTIME S:"Nn"'[$E(XQUR,1) XQUR="Y" I "Yy"[$E(XQUR,1) S XQH="XQNAMSPAC" D EN^XQH
ASK W !!,"What is the new menu's name: " R XQUR:DTIME S:'$T XQUR=U G:XQUR[U OUT
S XQF=1 I 'XQA S XQF=0 F XQI=1:1 S %=$P(XQD,",",XQI) Q:%="" I %=$E(XQUR,1,$L(%)) S XQF=1 Q
I 'XQF W !!?5,"Sorry. Your new option must begin with: " F XQI=1:1 S %=$P(XQD,",",XQI) Q:%="" W $S(XQI=1:"",1:" or "),%
I 'XQF G ASK
;
S (XQF,XQF0,XQF1)=0 I $D(^DIC(19,"B",XQUR)) S XQYN=$O(^(XQUR,0)) W !!?5,"Sorry, this option name is already in use." S XQF=1
I XQF,$P(^DIC(19,XQYN,0),U,5)=DUZ S XQF0=1
REP I XQF,XQF0 W !!?5,"Do you want to replace it? No// " R %:DTIME S:'$T %=U G:%=U OUT S:%="" %="N" G:"Nn"[$E(%) ASK S:"Yy"[$E(%) XQF1=1 I %["?" W !!?5,"If you answer 'Y' the existing option will be replaced by the one you're creating." G REP
I XQF,'XQF1 G ASK
I $L(XQUR)>30!(+XQUR=XQUR)!($L(XQUR)<3)!'(XQUR'?1P.E)!(XQUR'?.UNP) W *7,!!?5,"3 to 30 uppercase characters, please." G ASK
;
TXT ;Get the new menu text
W !!,"The old menu text is ","""",$P(^DIC(19,+XQYO,0),U,2),"""",!
K DIR S DIR("?")="Please enter 10 to 50 characters describing what the new option does.",DIR(0)="19,1",DIR("A")="What will option say?"
D ^DIR S XQUR0=X G:$D(DIRUT) OUT
;R XQUR0:DTIME S:'$T XQUR0=U G:XQUR0[U OUT G:'$L(XQUR0) TXT I $E(XQUR0,1)="?"!($L(XQUR0)<10)!($L(XQUR0)>50)!(XQUR0'?. W !!?5,"Please enter 10 to 50 characters describing what the new option does." G TXT
S XQUP=$$UP^XLFSTR(XQUR0) ;F XQI=1:1 Q:XQUP?.NUP S %=$A(XQUP,XQI) I %<123,%>96 S XQUP=$E(XQUP,1,XQI-1)_$C(%-32)_$E(XQUP,XQI+1,255)
;
FIL ;Get FileMan to put this all in.
S DIR("?")="'Y' means create the new menu. 'N' means don't.",DIR(0)="YA",DIR("A")="Is everything OK? ",DIR("B")="No" D ^DIR G:$D(DIRUT) OUT I Y=0 D OUT G ^XQ11
I 'XQF S DIC(0)="LMXZ",X=XQUR,DLAYGO=19 D FILE^DICN S XQYN=Y
S %X="^DIC(19,"_+XQYO_",",%Y="^DIC(19,"_+XQYN_"," D %XY^%RCR
;S $P(^DIC(19,+XQYN,0),U)=XQUR S DIK="^DIC(19,",DA=+XQYN D IX^DIC
S DIE="^DIC(19,",DR=".01///"_XQUR_";1///"_XQUR0_";3.6////"_DUZ_";",DA=+XQYN D ^DIE S ^DIC(19,+XQYN,"U")=$E(XQUP,1,30)
;
OUT K %,%1,%X,%Y,C,D,D0,DA,DDH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DQ,DR,X,XQA,XQD,XQF,XQF0,XQF1,XQH,XQI,XQUP,XQUR,XQUR0,XQYN,XQYO,Y
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ11 2985 printed Nov 22, 2024@17:14:48 Page 2
XQ11 ;SEA/MJM - Menu Utilities ;1/08/2006
+1 ;;8.0;KERNEL;**155,372**;Jul 10, 1995;Build 3
+2 ;
COPY ;Make a copy of a menu-type option
+1 SET XQA=$SELECT(DUZ(0)["@":1,$DATA(^XUSEC("XUMGR",DUZ)):1,$DATA(^XUSEC("XUPROGMODE",DUZ)):1,1:0)
+2 SET XQD=""
SET %=0
IF $DATA(^VA(200,DUZ,19.6,0))
IF $LENGTH($PIECE(^(0),U,3))
IF $PIECE(^(0),U,3)>0
FOR XQI=0:0
SET %=$ORDER(^VA(200,DUZ,19.6,%))
if %=""!(%'?1N.N)
QUIT
SET XQD=XQD_^(%,0)_","
+3 IF 'XQA
IF '$LENGTH(XQD)
WRITE !!,"Sorry. You need to be assigned a valid name space to proceed."
HANG 6
SET XQH="XQNAMSPAC"
DO EN^XQH
QUIT
+4 ;
+5 SET DIC="^DIC(19,"
SET DIC(0)="AEMQZ"
SET DIC("A")="Menu you would like to make a copy of: "
DO ^DIC
+6 if Y=-1
QUIT
SET XQYO=+Y
+7 WRITE !!,"WARNING ** Option names must be carefully named to avoid system damage!!",!?5,"Do you want more information? Yes// "
+8 READ XQUR:DTIME
if "Nn"'[$EXTRACT(XQUR,1)
SET XQUR="Y"
IF "Yy"[$EXTRACT(XQUR,1)
SET XQH="XQNAMSPAC"
DO EN^XQH
ASK WRITE !!,"What is the new menu's name: "
READ XQUR:DTIME
if '$TEST
SET XQUR=U
if XQUR[U
GOTO OUT
+1 SET XQF=1
IF 'XQA
SET XQF=0
FOR XQI=1:1
SET %=$PIECE(XQD,",",XQI)
if %=""
QUIT
IF %=$EXTRACT(XQUR,1,$LENGTH(%))
SET XQF=1
QUIT
+2 IF 'XQF
WRITE !!?5,"Sorry. Your new option must begin with: "
FOR XQI=1:1
SET %=$PIECE(XQD,",",XQI)
if %=""
QUIT
WRITE $SELECT(XQI=1:"",1:" or "),%
+3 IF 'XQF
GOTO ASK
+4 ;
+5 SET (XQF,XQF0,XQF1)=0
IF $DATA(^DIC(19,"B",XQUR))
SET XQYN=$ORDER(^(XQUR,0))
WRITE !!?5,"Sorry, this option name is already in use."
SET XQF=1
+6 IF XQF
IF $PIECE(^DIC(19,XQYN,0),U,5)=DUZ
SET XQF0=1
REP IF XQF
IF XQF0
WRITE !!?5,"Do you want to replace it? No// "
READ %:DTIME
if '$TEST
SET %=U
if %=U
GOTO OUT
if %=""
SET %="N"
if "Nn"[$EXTRACT(%)
GOTO ASK
if "Yy"[$EXTRACT(%)
SET XQF1=1
IF %["?"
WRITE !!?5,"If you answer 'Y' the existing option will be replaced by the one you're creating."
GOTO REP
+1 IF XQF
IF 'XQF1
GOTO ASK
+2 IF $LENGTH(XQUR)>30!(+XQUR=XQUR)!($LENGTH(XQUR)<3)!'(XQUR'?1P.E)!(XQUR'?.UNP)
WRITE *7,!!?5,"3 to 30 uppercase characters, please."
GOTO ASK
+3 ;
TXT ;Get the new menu text
+1 WRITE !!,"The old menu text is ","""",$PIECE(^DIC(19,+XQYO,0),U,2),"""",!
+2 KILL DIR
SET DIR("?")="Please enter 10 to 50 characters describing what the new option does."
SET DIR(0)="19,1"
SET DIR("A")="What will option say?"
+3 DO ^DIR
SET XQUR0=X
if $DATA(DIRUT)
GOTO OUT
+4 ;R XQUR0:DTIME S:'$T XQUR0=U G:XQUR0[U OUT G:'$L(XQUR0) TXT I $E(XQUR0,1)="?"!($L(XQUR0)<10)!($L(XQUR0)>50)!(XQUR0'?. W !!?5,"Please enter 10 to 50 characters describing what the new option does." G TXT
+5 ;F XQI=1:1 Q:XQUP?.NUP S %=$A(XQUP,XQI) I %<123,%>96 S XQUP=$E(XQUP,1,XQI-1)_$C(%-32)_$E(XQUP,XQI+1,255)
SET XQUP=$$UP^XLFSTR(XQUR0)
+6 ;
FIL ;Get FileMan to put this all in.
+1 SET DIR("?")="'Y' means create the new menu. 'N' means don't."
SET DIR(0)="YA"
SET DIR("A")="Is everything OK? "
SET DIR("B")="No"
DO ^DIR
if $DATA(DIRUT)
GOTO OUT
IF Y=0
DO OUT
GOTO ^XQ11
+2 IF 'XQF
SET DIC(0)="LMXZ"
SET X=XQUR
SET DLAYGO=19
DO FILE^DICN
SET XQYN=Y
+3 SET %X="^DIC(19,"_+XQYO_","
SET %Y="^DIC(19,"_+XQYN_","
DO %XY^%RCR
+4 ;S $P(^DIC(19,+XQYN,0),U)=XQUR S DIK="^DIC(19,",DA=+XQYN D IX^DIC
+5 SET DIE="^DIC(19,"
SET DR=".01///"_XQUR_";1///"_XQUR0_";3.6////"_DUZ_";"
SET DA=+XQYN
DO ^DIE
SET ^DIC(19,+XQYN,"U")=$EXTRACT(XQUP,1,30)
+6 ;
OUT KILL %,%1,%X,%Y,C,D,D0,DA,DDH,DI,DIC,DIE,DIG,DIH,DIK,DIR,DIU,DIV,DIW,DLAYGO,DQ,DR,X,XQA,XQD,XQF,XQF0,XQF1,XQH,XQI,XQUP,XQUR,XQUR0,XQYN,XQYO,Y
+1 QUIT
