- XQOO1 ;SEA/Luke - Out-of-order set calls ;01/28/97 15:00
- ;;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQOO1 8389 printed Jan 18, 2025@03:07:02 Page 2
- XQOO1 ;SEA/Luke - Out-of-order set calls ;01/28/97 15:00
- +1 ;;8.0;KERNEL;**10,21,39,41,58**;Jul 10, 1995
- +2 ;
- 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