XQOO1 ;SEA/Luke - Out-of-order set calls ;01/28/97 15:00 [ 04/02/2003 8:29 AM ]
;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
;;8.0;KERNEL;**10,21,39,41,58**;Jul 10, 1995
;
OFF(XQSET) ;Mark options and protocols Out Of Order
N %,DA,XQMESS,XQN,XQKD
I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
S XQMESS=$P(^XTMP("XQOO",XQSET,0),U),XQKD=" is being installed by KIDS"
;
S XQN=0
F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" D
.Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3)
.;quit if KIDS and option already out by nonKIDS user
.Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
.;if KIDS save off current OOO message
.I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,19,XQN),U,3)=%_XQKD
.S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
.Q
;
S XQN=0
F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" D
.Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3)
.Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
.I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,101,XQN),U,3)=%
.S $P(^ORD(101,XQN,0),U,3)=XQMESS
.Q
D OUT
D KICK^XQ7
Q
;
ON(XQSET) ;Remove Out Of Order messages from the set XQSET
N %,%1,DA,XQN,XQKD
I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
;
S XQN=0,XQKD=" is being installed by KIDS"
F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
.Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
.;quit if OOO message is set by nonKIDS
.Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
.I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q ;another set has this option
.;if we have another message to restore, check that set still exist
.I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
.S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
.Q
;
S XQN=0
F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
.Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
.Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
.I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q
.I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
.S $P(^ORD(101,XQN,0),U,3)=XQMESS
.Q
;
I '$D(XPDSET) D
.S DIR(0)="Y",DIR("B")="Y"
.S DIR("A")="Should I remove the option set "_XQSET_" from ^XTMP?"
.S DIR("?")=XQSET_" is the list of options and/or protocols you just turned on."
.D ^DIR
.I Y K ^XTMP("XQOO",XQSET)
.K DIR,Y
.Q
D OUT
D KICK^XQ7
Q
;
ADD(XQSET,XQFIL,XQN) ;New option/protocol - add to set and mark it OOO
;Called by KIDS during a build
I '$D(^XTMP("XQOO",XQSET,0)) S XQSET="^" D OUT Q
S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
S XQGL=$S(XQFIL=19:"^DIC(",1:"^ORD(")
S %=@(XQGL_XQFIL_","_XQN_",0)"),^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(%,U)_"^"_$P(%,U,2)
S %=XQGL_XQFIL_","_XQN_",0)",$P(@%,U,3)=XQMESS
D OUT
Q
;
KIDS(XQSET,XQFIL,XQNAME,XQFLAG) ;Turn on/off an option or protocol
;Called only from KIDS during an install so OERR would work
;XQFLAG is set to 0 to put an option or protocol out of order,
;1 to turn it on, and I return it as -1 if the request
;fails.
;
N XQGL,XQMESS,XQMES2,XQN
I '$D(^XTMP("XQOO",XQSET)) S XQFLAG=-1 Q
S XQGL=$S(XQFIL=19:"^DIC(19)",XQFIL=101:"^ORD(101)",1:"")
I XQGL="" S XQFLAG=-1 Q
I XQNAME=+XQNAME S XQN=XQNAME
E D I XQFLAG<0 Q
.S XQN=$O(@XQGL@("B",XQNAME,0)) I XQN'>0 S XQFLAG=-1
.Q
S %=@XQGL@(XQN,0) S XQMES2=$P(%,U,3)
S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
I XQMESS=XQMES2 S XQMES2=""
I '$D(^XTMP("XQOO",XQSET,XQFIL,XQN)) S ^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(@XQGL@(XQN,0),U)_U_$P(^(0),U,2)
;
I 'XQFLAG D
.I XQMES2]"" S $P(^XTMP("XQOO",XQSET,XQFIL,XQN),U,3)=XQMES2
.S $P(@XQGL@(XQN,0),U,3)=XQMESS
.Q
I XQFLAG D
.S $P(@XQGL@(XQN,0),U,3)=""
.Q
;
OUT ;Exit point
K %,XQFIL,XQGL,XQMESS,XQN,XQS
Q
;
OFFOP ;Option entry for turning off options
W !
S XQSET=""
D GETSET(.XQSET)
I XQSET]"" D
.S DIR(0)="Y",DIR("B")="N"
.S DIR("A")="Mark the options in "_XQSET_" Out-Of Order now"
.S DIR("?")="If you answer ""Yes"" you will mark all the options in the set "_XQSET_" Out Of Order."
.D ^DIR
.I Y D OFF(XQSET)
.K DIR,X,Y
.Q
Q
;
;
ONOP ;Option entry for turning on options
S XQSET=""
D GETSET(.XQSET)
I XQSET]"" D
.S DIR(0)="Y",DIR("B")="Y"
.S DIR("A")="Return options in "_XQSET_" to general use"
.S DIR("?")="If you answer ""Yes"" you will remove the Out-Of-Order message from the options in the set "_XQSET
.D ^DIR
.I Y D ON(XQSET)
.K DIR,X,Y
.Q
D KICK^XQ7
Q
;
GETSET(XQSET) ;Get the name of the option set in question
I '$D(^XTMP("XQOO")) W !!,"There are currently no option sets definded in ^XTMP." Q
S XQI=0
D SETS^XQOO2(.XQI)
I XQI=1 S XQSET=0,XQSET=$O(^XTMP("XQOO",XQSET)) Q
I XQI>1 D
.S DIR(0)="NO^1:"_XQI,DIR("B")=XQI
.S DIR("A")=" Please enter the number of the option set you want"
.S DIR("?")=" Which option set do you want to work with? 1, "_XQI_" etc."
.W !
.D ^DIR
.S XQSET=0 F XQI=1:1:+Y S XQSET=$O(^XTMP("XQOO",XQSET))
.Q
K XQI
Q
;
;
REBLD ;Rebuild a "lost" set of options and protocols
N XQ,XQMESS,XQOP,XQPROT,XQSET
S (XQOP,XQPROT)=0
;
S DIR(0)="F^3:30"
S DIR("A")=" Please enter the exact Out-Of-Order message"
S DIR("?")=" All options/protocols with this message are reclaimed into a set in ^XTMP"
D ^DIR G:$D(DIRUT) OUTRE
S XQMESS=X K DIR
;
RE1 S DIR(0)="F^1:20"
S DIR("A")=" What do you want to name the recovered set? "
S DIR("?")=" Enter any name of up to 20 characters"
D ^DIR G:$D(DIRUT) OUTRE
S XQSET=X K DIR
I $D(^XTMP("XQOO",XQSET,0)) D G RE1
.W !,"Sorry, that set already exists. Use the Create/Modify option to"
.W !?3,"modify it, or choose another name."
.Q
;
REFIND ;Find options and protocols with the message XQMESS
S XQ=0 F S XQ=$O(^DIC(19,XQ)) Q:XQ'=+XQ!(XQ="") D
.Q:$P(^DIC(19,XQ,0),U,3)'=XQMESS
.S ^XTMP("XQOO",XQSET,19,XQ)=$P(^DIC(19,XQ,0),U)_U_$P(^(0),U,2)
.S XQOP=XQOP+1
.Q
;
S XQ=0 F S XQ=$O(^ORD(101,XQ)) Q:XQ'=+XQ!(XQ="") D
.Q:$P(^ORD(101,XQ,0),U,3)'=XQMESS
.S ^XTMP("XQOO",XQSET,101,XQ)=$P(^ORD(101,XQ,0),U)_U_$P(^(0),U,2)
.S XQPROT=XQPROT+1
.Q
;
I XQOP>0!(XQPROT>0) D G OUTRE
.D ^XQDATE
.S %=$P(^VA(200,DUZ,0),U),%=$P(%,",")
.S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_%
.S ^XTMP("XQOO",0)=DT+7
.W !!,"Set named ",XQSET," recovered with ",XQOP," options and ",XQPROT," protocols."
.Q
E W !!,"No options or protocols with the message ",XQMESS," were found." G OUTRE
Q
;
OUTRE ;Exit point for REBLD
K %,%Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XQ,XQMESS,XQOP,XQPROT,XQSET,Y
Q
;
TOG ;Toggle options and protocols on and off. (XQOOTOG option)
N XQ
D T1,OUTT,T2,KICK^XQ7
;
OUTT ;Exit for XQOOTOG
K DIC,DTOUT,DUOUT,X,Y
Q
;
T1 ;Toggle options
S DIC=19,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of an option: "
F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
.S XQ=+Y,XQ0=Y(0)
.I $P(XQ0,U,3)]"" D
..S XQMESS=$P(XQ0,U,3)
..W !!,"Option ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
..D ^DIR
..I Y S $P(^DIC(19,XQ,0),U,3)="",DA=XQ D REDO^XQ7
..K DIR,X,Y
..Q
.E W ! D
..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this option out of order: "
..S DIR("?")="This option is in service. Enter a string to remove it from use."
..K DIRUT D ^DIR
..I '$D(DIRUT) S $P(^DIC(19,XQ,0),U,3)=Y,DA=XQ D REDO^XQ7
..K DIR,DIRUT,X,Y
..Q
.Q
Q
;
T2 ;Toggle protocols
S DIC=101,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of a protocol: "
F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
.S XQ=+Y,XQ0=Y(0)
.I $P(XQ0,U,3)]"" D
..S XQMESS=$P(XQ0,U,3)
..W !!,"Protocol ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
..D ^DIR
..I Y S $P(^ORD(101,XQ,0),U,3)=""
..K DA,DIR,X,Y
..Q
.E W ! D
..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this protocol out of order: "
..S DIR("?")="This protocol is in service. Enter a string to remove it from use."
..K DIRUT D ^DIR
..I '$D(DIRUT) S $P(^ORD(101,XQ,0),U,3)=Y
..K DIR,DIRUT,X,Y
..Q
.Q
Q
XQOO1 ;SEA/Luke - Out-of-order set calls ;01/28/97 15:00 [ 04/02/2003 8:29 AM ]
+1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
+2 ;;8.0;KERNEL;**10,21,39,41,58**;Jul 10, 1995
+3 ;
OFF(XQSET) ;Mark options and protocols Out Of Order
+1 NEW %,DA,XQMESS,XQN,XQKD
+2 IF '$DATA(^XTMP("XQOO",XQSET,0))#2
SET XQSET="^"
QUIT
+3 SET XQMESS=$PIECE(^XTMP("XQOO",XQSET,0),U)
SET XQKD=" is being installed by KIDS"
+4 ;
+5 SET XQN=0
+6 FOR
SET XQN=$ORDER(^XTMP("XQOO",XQSET,19,XQN))
IF XQN=""
QUIT
Begin DoDot:1
+7 IF '$DATA(^DIC(19,XQN,0))#2
QUIT
SET %=$PIECE(^(0),U,3)
+8 ;quit if KIDS and option already out by nonKIDS user
+9 IF $DATA(XPDSET)&(%]"")&(%'[XQKD)
QUIT
SET %=$PIECE(%,XQKD)
+10 ;if KIDS save off current OOO message
+11 IF $DATA(XPDSET)
IF %]""
IF %'=XQSET
IF $DATA(^XTMP("XQOO",%))
SET $PIECE(^XTMP("XQOO",XQSET,19,XQN),U,3)=%_XQKD
+12 SET $PIECE(^DIC(19,XQN,0),U,3)=XQMESS
SET DA=XQN
DO REDO^XQ7
+13 QUIT
End DoDot:1
+14 ;
+15 SET XQN=0
+16 FOR
SET XQN=$ORDER(^XTMP("XQOO",XQSET,101,XQN))
IF XQN=""
QUIT
Begin DoDot:1
+17 IF '$DATA(^ORD(101,XQN,0))#2
QUIT
SET %=$PIECE(^(0),U,3)
+18 IF $DATA(XPDSET)&(%]"")&(%'[XQKD)
QUIT
SET %=$PIECE(%,XQKD)
+19 IF $DATA(XPDSET)
IF %]""
IF %'=XQSET
IF $DATA(^XTMP("XQOO",%))
SET $PIECE(^XTMP("XQOO",XQSET,101,XQN),U,3)=%
+20 SET $PIECE(^ORD(101,XQN,0),U,3)=XQMESS
+21 QUIT
End DoDot:1
+22 DO OUT
+23 DO KICK^XQ7
+24 QUIT
+25 ;
ON(XQSET) ;Remove Out Of Order messages from the set XQSET
+1 NEW %,%1,DA,XQN,XQKD
+2 IF '$DATA(^XTMP("XQOO",XQSET,0))#2
SET XQSET="^"
QUIT
+3 ;
+4 SET XQN=0
SET XQKD=" is being installed by KIDS"
+5 FOR
SET XQN=$ORDER(^XTMP("XQOO",XQSET,19,XQN))
IF XQN=""
QUIT
SET XQMESS=$PIECE(^(XQN),U,3)
Begin DoDot:1
+6 IF '$DATA(^DIC(19,XQN,0))#2
QUIT
SET %=$PIECE(^(0),U,3)
SET %1=$SELECT($DATA(XPDSET):$PIECE(XQMESS,XQKD),1:"")
+7 ;quit if OOO message is set by nonKIDS
+8 IF $DATA(XPDSET)&(%'[XQKD)
QUIT
SET %=$PIECE(%,XQKD)
+9 ;another set has this option
IF $DATA(XPDSET)
IF %'=XQSET
IF %]""
IF $DATA(^XTMP("XQOO",%))
QUIT
+10 ;if we have another message to restore, check that set still exist
+11 IF XQMESS]""
SET XQMESS=$SELECT(%1="":"",'$DATA(^XTMP("XQOO",%1)):"",1:XQMESS)
+12 SET $PIECE(^DIC(19,XQN,0),U,3)=XQMESS
SET DA=XQN
DO REDO^XQ7
+13 QUIT
End DoDot:1
+14 ;
+15 SET XQN=0
+16 FOR
SET XQN=$ORDER(^XTMP("XQOO",XQSET,101,XQN))
IF XQN=""
QUIT
SET XQMESS=$PIECE(^(XQN),U,3)
Begin DoDot:1
+17 IF '$DATA(^ORD(101,XQN,0))#2
QUIT
SET %=$PIECE(^(0),U,3)
SET %1=$SELECT($DATA(XPDSET):$PIECE(XQMESS,XQKD),1:"")
+18 IF $DATA(XPDSET)&(%'[XQKD)
QUIT
SET %=$PIECE(%,XQKD)
+19 IF $DATA(XPDSET)
IF %'=XQSET
IF %]""
IF $DATA(^XTMP("XQOO",%))
QUIT
+20 IF XQMESS]""
SET XQMESS=$SELECT(%1="":"",'$DATA(^XTMP("XQOO",%1)):"",1:XQMESS)
+21 SET $PIECE(^ORD(101,XQN,0),U,3)=XQMESS
+22 QUIT
End DoDot:1
+23 ;
+24 IF '$DATA(XPDSET)
Begin DoDot:1
+25 SET DIR(0)="Y"
SET DIR("B")="Y"
+26 SET DIR("A")="Should I remove the option set "_XQSET_" from ^XTMP?"
+27 SET DIR("?")=XQSET_" is the list of options and/or protocols you just turned on."
+28 DO ^DIR
+29 IF Y
KILL ^XTMP("XQOO",XQSET)
+30 KILL DIR,Y
+31 QUIT
End DoDot:1
+32 DO OUT
+33 DO KICK^XQ7
+34 QUIT
+35 ;
ADD(XQSET,XQFIL,XQN) ;New option/protocol - add to set and mark it OOO
+1 ;Called by KIDS during a build
+2 IF '$DATA(^XTMP("XQOO",XQSET,0))
SET XQSET="^"
DO OUT
QUIT
+3 SET XQMESS=$PIECE(^XTMP("XQOO",XQSET,0),U)
+4 SET XQGL=$SELECT(XQFIL=19:"^DIC(",1:"^ORD(")
+5 SET %=@(XQGL_XQFIL_","_XQN_",0)")
SET ^XTMP("XQOO",XQSET,XQFIL,XQN)=$PIECE(%,U)_"^"_$PIECE(%,U,2)
+6 SET %=XQGL_XQFIL_","_XQN_",0)"
SET $PIECE(@%,U,3)=XQMESS
+7 DO OUT
+8 QUIT
+9 ;
KIDS(XQSET,XQFIL,XQNAME,XQFLAG) ;Turn on/off an option or protocol
+1 ;Called only from KIDS during an install so OERR would work
+2 ;XQFLAG is set to 0 to put an option or protocol out of order,
+3 ;1 to turn it on, and I return it as -1 if the request
+4 ;fails.
+5 ;
+6 NEW XQGL,XQMESS,XQMES2,XQN
+7 IF '$DATA(^XTMP("XQOO",XQSET))
SET XQFLAG=-1
QUIT
+8 SET XQGL=$SELECT(XQFIL=19:"^DIC(19)",XQFIL=101:"^ORD(101)",1:"")
+9 IF XQGL=""
SET XQFLAG=-1
QUIT
+10 IF XQNAME=+XQNAME
SET XQN=XQNAME
+11 IF '$TEST
Begin DoDot:1
+12 SET XQN=$ORDER(@XQGL@("B",XQNAME,0))
IF XQN'>0
SET XQFLAG=-1
+13 QUIT
End DoDot:1
IF XQFLAG<0
QUIT
+14 SET %=@XQGL@(XQN,0)
SET XQMES2=$PIECE(%,U,3)
+15 SET XQMESS=$PIECE(^XTMP("XQOO",XQSET,0),U)
+16 IF XQMESS=XQMES2
SET XQMES2=""
+17 IF '$DATA(^XTMP("XQOO",XQSET,XQFIL,XQN))
SET ^XTMP("XQOO",XQSET,XQFIL,XQN)=$PIECE(@XQGL@(XQN,0),U)_U_$PIECE(^(0),U,2)
+18 ;
+19 IF 'XQFLAG
Begin DoDot:1
+20 IF XQMES2]""
SET $PIECE(^XTMP("XQOO",XQSET,XQFIL,XQN),U,3)=XQMES2
+21 SET $PIECE(@XQGL@(XQN,0),U,3)=XQMESS
+22 QUIT
End DoDot:1
+23 IF XQFLAG
Begin DoDot:1
+24 SET $PIECE(@XQGL@(XQN,0),U,3)=""
+25 QUIT
End DoDot:1
+26 ;
OUT ;Exit point
+1 KILL %,XQFIL,XQGL,XQMESS,XQN,XQS
+2 QUIT
+3 ;
OFFOP ;Option entry for turning off options
+1 WRITE !
+2 SET XQSET=""
+3 DO GETSET(.XQSET)
+4 IF XQSET]""
Begin DoDot:1
+5 SET DIR(0)="Y"
SET DIR("B")="N"
+6 SET DIR("A")="Mark the options in "_XQSET_" Out-Of Order now"
+7 SET DIR("?")="If you answer ""Yes"" you will mark all the options in the set "_XQSET_" Out Of Order."
+8 DO ^DIR
+9 IF Y
DO OFF(XQSET)
+10 KILL DIR,X,Y
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
+14 ;
ONOP ;Option entry for turning on options
+1 SET XQSET=""
+2 DO GETSET(.XQSET)
+3 IF XQSET]""
Begin DoDot:1
+4 SET DIR(0)="Y"
SET DIR("B")="Y"
+5 SET DIR("A")="Return options in "_XQSET_" to general use"
+6 SET DIR("?")="If you answer ""Yes"" you will remove the Out-Of-Order message from the options in the set "_XQSET
+7 DO ^DIR
+8 IF Y
DO ON(XQSET)
+9 KILL DIR,X,Y
+10 QUIT
End DoDot:1
+11 DO KICK^XQ7
+12 QUIT
+13 ;
GETSET(XQSET) ;Get the name of the option set in question
+1 IF '$DATA(^XTMP("XQOO"))
WRITE !!,"There are currently no option sets definded in ^XTMP."
QUIT
+2 SET XQI=0
+3 DO SETS^XQOO2(.XQI)
+4 IF XQI=1
SET XQSET=0
SET XQSET=$ORDER(^XTMP("XQOO",XQSET))
QUIT
+5 IF XQI>1
Begin DoDot:1
+6 SET DIR(0)="NO^1:"_XQI
SET DIR("B")=XQI
+7 SET DIR("A")=" Please enter the number of the option set you want"
+8 SET DIR("?")=" Which option set do you want to work with? 1, "_XQI_" etc."
+9 WRITE !
+10 DO ^DIR
+11 SET XQSET=0
FOR XQI=1:1:+Y
SET XQSET=$ORDER(^XTMP("XQOO",XQSET))
+12 QUIT
End DoDot:1
+13 KILL XQI
+14 QUIT
+15 ;
+16 ;
REBLD ;Rebuild a "lost" set of options and protocols
+1 NEW XQ,XQMESS,XQOP,XQPROT,XQSET
+2 SET (XQOP,XQPROT)=0
+3 ;
+4 SET DIR(0)="F^3:30"
+5 SET DIR("A")=" Please enter the exact Out-Of-Order message"
+6 SET DIR("?")=" All options/protocols with this message are reclaimed into a set in ^XTMP"
+7 DO ^DIR
IF $DATA(DIRUT)
GOTO OUTRE
+8 SET XQMESS=X
KILL DIR
+9 ;
RE1 SET DIR(0)="F^1:20"
+1 SET DIR("A")=" What do you want to name the recovered set? "
+2 SET DIR("?")=" Enter any name of up to 20 characters"
+3 DO ^DIR
IF $DATA(DIRUT)
GOTO OUTRE
+4 SET XQSET=X
KILL DIR
+5 IF $DATA(^XTMP("XQOO",XQSET,0))
Begin DoDot:1
+6 WRITE !,"Sorry, that set already exists. Use the Create/Modify option to"
+7 WRITE !?3,"modify it, or choose another name."
+8 QUIT
End DoDot:1
GOTO RE1
+9 ;
REFIND ;Find options and protocols with the message XQMESS
+1 SET XQ=0
FOR
SET XQ=$ORDER(^DIC(19,XQ))
IF XQ'=+XQ!(XQ="")
QUIT
Begin DoDot:1
+2 IF $PIECE(^DIC(19,XQ,0),U,3)'=XQMESS
QUIT
+3 SET ^XTMP("XQOO",XQSET,19,XQ)=$PIECE(^DIC(19,XQ,0),U)_U_$PIECE(^(0),U,2)
+4 SET XQOP=XQOP+1
+5 QUIT
End DoDot:1
+6 ;
+7 SET XQ=0
FOR
SET XQ=$ORDER(^ORD(101,XQ))
IF XQ'=+XQ!(XQ="")
QUIT
Begin DoDot:1
+8 IF $PIECE(^ORD(101,XQ,0),U,3)'=XQMESS
QUIT
+9 SET ^XTMP("XQOO",XQSET,101,XQ)=$PIECE(^ORD(101,XQ,0),U)_U_$PIECE(^(0),U,2)
+10 SET XQPROT=XQPROT+1
+11 QUIT
End DoDot:1
+12 ;
+13 IF XQOP>0!(XQPROT>0)
Begin DoDot:1
+14 DO ^XQDATE
+15 SET %=$PIECE(^VA(200,DUZ,0),U)
SET %=$PIECE(%,",")
+16 SET ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_%
+17 SET ^XTMP("XQOO",0)=DT+7
+18 WRITE !!,"Set named ",XQSET," recovered with ",XQOP," options and ",XQPROT," protocols."
+19 QUIT
End DoDot:1
GOTO OUTRE
+20 IF '$TEST
WRITE !!,"No options or protocols with the message ",XQMESS," were found."
GOTO OUTRE
+21 QUIT
+22 ;
OUTRE ;Exit point for REBLD
+1 KILL %,%Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XQ,XQMESS,XQOP,XQPROT,XQSET,Y
+2 QUIT
+3 ;
TOG ;Toggle options and protocols on and off. (XQOOTOG option)
+1 NEW XQ
+2 DO T1
DO OUTT
DO T2
DO KICK^XQ7
+3 ;
OUTT ;Exit for XQOOTOG
+1 KILL DIC,DTOUT,DUOUT,X,Y
+2 QUIT
+3 ;
T1 ;Toggle options
+1 SET DIC=19
SET DIC(0)="AEMQZ"
SET DIC("A")="Enter the name or menu text of an option: "
+2 FOR
WRITE !
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
QUIT
Begin DoDot:1
+3 SET XQ=+Y
SET XQ0=Y(0)
+4 IF $PIECE(XQ0,U,3)]""
Begin DoDot:2
+5 SET XQMESS=$PIECE(XQ0,U,3)
+6 WRITE !!,"Option ",$PIECE(Y(0),U)," is out with the message '",XQMESS,"'",!
+7 SET DIR(0)="Y"
SET DIR("A")="Put it in service"
SET DIR("B")="YES"
+8 SET DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
+9 DO ^DIR
+10 IF Y
SET $PIECE(^DIC(19,XQ,0),U,3)=""
SET DA=XQ
DO REDO^XQ7
+11 KILL DIR,X,Y
+12 QUIT
End DoDot:2
+13 IF '$TEST
WRITE !
Begin DoDot:2
+14 SET DIR(0)="FA^3:50"
SET DIR("A")="Enter a message to put this option out of order: "
+15 SET DIR("?")="This option is in service. Enter a string to remove it from use."
+16 KILL DIRUT
DO ^DIR
+17 IF '$DATA(DIRUT)
SET $PIECE(^DIC(19,XQ,0),U,3)=Y
SET DA=XQ
DO REDO^XQ7
+18 KILL DIR,DIRUT,X,Y
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
+22 ;
T2 ;Toggle protocols
+1 SET DIC=101
SET DIC(0)="AEMQZ"
SET DIC("A")="Enter the name or menu text of a protocol: "
+2 FOR
WRITE !
DO ^DIC
IF $DATA(DTOUT)!$DATA(DUOUT)!(Y<0)
QUIT
Begin DoDot:1
+3 SET XQ=+Y
SET XQ0=Y(0)
+4 IF $PIECE(XQ0,U,3)]""
Begin DoDot:2
+5 SET XQMESS=$PIECE(XQ0,U,3)
+6 WRITE !!,"Protocol ",$PIECE(Y(0),U)," is out with the message '",XQMESS,"'",!
+7 SET DIR(0)="Y"
SET DIR("A")="Put it in service"
SET DIR("B")="YES"
+8 SET DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
+9 DO ^DIR
+10 IF Y
SET $PIECE(^ORD(101,XQ,0),U,3)=""
+11 KILL DA,DIR,X,Y
+12 QUIT
End DoDot:2
+13 IF '$TEST
WRITE !
Begin DoDot:2
+14 SET DIR(0)="FA^3:50"
SET DIR("A")="Enter a message to put this protocol out of order: "
+15 SET DIR("?")="This protocol is in service. Enter a string to remove it from use."
+16 KILL DIRUT
DO ^DIR
+17 IF '$DATA(DIRUT)
SET $PIECE(^ORD(101,XQ,0),U,3)=Y
+18 KILL DIR,DIRUT,X,Y
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 QUIT
