Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQOO1

XQOO1.m

Go to the documentation of this file.
  1. 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
  1. ;
  1. OFF(XQSET) ;Mark options and protocols Out Of Order
  1. N %,DA,XQMESS,XQN,XQKD
  1. I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
  1. S XQMESS=$P(^XTMP("XQOO",XQSET,0),U),XQKD=" is being installed by KIDS"
  1. ;
  1. S XQN=0
  1. F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" D
  1. .Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3)
  1. .;quit if KIDS and option already out by nonKIDS user
  1. .Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
  1. .;if KIDS save off current OOO message
  1. .I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,19,XQN),U,3)=%_XQKD
  1. .S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
  1. .Q
  1. ;
  1. S XQN=0
  1. F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" D
  1. .Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3)
  1. .Q:$D(XPDSET)&(%]"")&(%'[XQKD) S %=$P(%,XQKD)
  1. .I $D(XPDSET),%]"",%'=XQSET,$D(^XTMP("XQOO",%)) S $P(^XTMP("XQOO",XQSET,101,XQN),U,3)=%
  1. .S $P(^ORD(101,XQN,0),U,3)=XQMESS
  1. .Q
  1. D OUT
  1. D KICK^XQ7
  1. Q
  1. ;
  1. ON(XQSET) ;Remove Out Of Order messages from the set XQSET
  1. N %,%1,DA,XQN,XQKD
  1. I '$D(^XTMP("XQOO",XQSET,0))#2 S XQSET="^" Q
  1. ;
  1. S XQN=0,XQKD=" is being installed by KIDS"
  1. F S XQN=$O(^XTMP("XQOO",XQSET,19,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
  1. .Q:'$D(^DIC(19,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
  1. .;quit if OOO message is set by nonKIDS
  1. .Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
  1. .I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q ;another set has this option
  1. .;if we have another message to restore, check that set still exist
  1. .I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
  1. .S $P(^DIC(19,XQN,0),U,3)=XQMESS,DA=XQN D REDO^XQ7
  1. .Q
  1. ;
  1. S XQN=0
  1. F S XQN=$O(^XTMP("XQOO",XQSET,101,XQN)) Q:XQN="" S XQMESS=$P(^(XQN),U,3) D
  1. .Q:'$D(^ORD(101,XQN,0))#2 S %=$P(^(0),U,3),%1=$S($D(XPDSET):$P(XQMESS,XQKD),1:"")
  1. .Q:$D(XPDSET)&(%'[XQKD) S %=$P(%,XQKD)
  1. .I $D(XPDSET),%'=XQSET,%]"",$D(^XTMP("XQOO",%)) Q
  1. .I XQMESS]"" S XQMESS=$S(%1="":"",'$D(^XTMP("XQOO",%1)):"",1:XQMESS)
  1. .S $P(^ORD(101,XQN,0),U,3)=XQMESS
  1. .Q
  1. ;
  1. I '$D(XPDSET) D
  1. .S DIR(0)="Y",DIR("B")="Y"
  1. .S DIR("A")="Should I remove the option set "_XQSET_" from ^XTMP?"
  1. .S DIR("?")=XQSET_" is the list of options and/or protocols you just turned on."
  1. .D ^DIR
  1. .I Y K ^XTMP("XQOO",XQSET)
  1. .K DIR,Y
  1. .Q
  1. D OUT
  1. D KICK^XQ7
  1. Q
  1. ;
  1. ADD(XQSET,XQFIL,XQN) ;New option/protocol - add to set and mark it OOO
  1. ;Called by KIDS during a build
  1. I '$D(^XTMP("XQOO",XQSET,0)) S XQSET="^" D OUT Q
  1. S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
  1. S XQGL=$S(XQFIL=19:"^DIC(",1:"^ORD(")
  1. S %=@(XQGL_XQFIL_","_XQN_",0)"),^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(%,U)_"^"_$P(%,U,2)
  1. S %=XQGL_XQFIL_","_XQN_",0)",$P(@%,U,3)=XQMESS
  1. D OUT
  1. Q
  1. ;
  1. KIDS(XQSET,XQFIL,XQNAME,XQFLAG) ;Turn on/off an option or protocol
  1. ;Called only from KIDS during an install so OERR would work
  1. ;XQFLAG is set to 0 to put an option or protocol out of order,
  1. ;1 to turn it on, and I return it as -1 if the request
  1. ;fails.
  1. ;
  1. N XQGL,XQMESS,XQMES2,XQN
  1. I '$D(^XTMP("XQOO",XQSET)) S XQFLAG=-1 Q
  1. S XQGL=$S(XQFIL=19:"^DIC(19)",XQFIL=101:"^ORD(101)",1:"")
  1. I XQGL="" S XQFLAG=-1 Q
  1. I XQNAME=+XQNAME S XQN=XQNAME
  1. E D I XQFLAG<0 Q
  1. .S XQN=$O(@XQGL@("B",XQNAME,0)) I XQN'>0 S XQFLAG=-1
  1. .Q
  1. S %=@XQGL@(XQN,0) S XQMES2=$P(%,U,3)
  1. S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
  1. I XQMESS=XQMES2 S XQMES2=""
  1. I '$D(^XTMP("XQOO",XQSET,XQFIL,XQN)) S ^XTMP("XQOO",XQSET,XQFIL,XQN)=$P(@XQGL@(XQN,0),U)_U_$P(^(0),U,2)
  1. ;
  1. I 'XQFLAG D
  1. .I XQMES2]"" S $P(^XTMP("XQOO",XQSET,XQFIL,XQN),U,3)=XQMES2
  1. .S $P(@XQGL@(XQN,0),U,3)=XQMESS
  1. .Q
  1. I XQFLAG D
  1. .S $P(@XQGL@(XQN,0),U,3)=""
  1. .Q
  1. ;
  1. OUT ;Exit point
  1. K %,XQFIL,XQGL,XQMESS,XQN,XQS
  1. Q
  1. ;
  1. OFFOP ;Option entry for turning off options
  1. W !
  1. S XQSET=""
  1. D GETSET(.XQSET)
  1. I XQSET]"" D
  1. .S DIR(0)="Y",DIR("B")="N"
  1. .S DIR("A")="Mark the options in "_XQSET_" Out-Of Order now"
  1. .S DIR("?")="If you answer ""Yes"" you will mark all the options in the set "_XQSET_" Out Of Order."
  1. .D ^DIR
  1. .I Y D OFF(XQSET)
  1. .K DIR,X,Y
  1. .Q
  1. Q
  1. ;
  1. ;
  1. ONOP ;Option entry for turning on options
  1. S XQSET=""
  1. D GETSET(.XQSET)
  1. I XQSET]"" D
  1. .S DIR(0)="Y",DIR("B")="Y"
  1. .S DIR("A")="Return options in "_XQSET_" to general use"
  1. .S DIR("?")="If you answer ""Yes"" you will remove the Out-Of-Order message from the options in the set "_XQSET
  1. .D ^DIR
  1. .I Y D ON(XQSET)
  1. .K DIR,X,Y
  1. .Q
  1. D KICK^XQ7
  1. Q
  1. ;
  1. GETSET(XQSET) ;Get the name of the option set in question
  1. I '$D(^XTMP("XQOO")) W !!,"There are currently no option sets definded in ^XTMP." Q
  1. S XQI=0
  1. D SETS^XQOO2(.XQI)
  1. I XQI=1 S XQSET=0,XQSET=$O(^XTMP("XQOO",XQSET)) Q
  1. I XQI>1 D
  1. .S DIR(0)="NO^1:"_XQI,DIR("B")=XQI
  1. .S DIR("A")=" Please enter the number of the option set you want"
  1. .S DIR("?")=" Which option set do you want to work with? 1, "_XQI_" etc."
  1. .W !
  1. .D ^DIR
  1. .S XQSET=0 F XQI=1:1:+Y S XQSET=$O(^XTMP("XQOO",XQSET))
  1. .Q
  1. K XQI
  1. Q
  1. ;
  1. ;
  1. REBLD ;Rebuild a "lost" set of options and protocols
  1. N XQ,XQMESS,XQOP,XQPROT,XQSET
  1. S (XQOP,XQPROT)=0
  1. ;
  1. S DIR(0)="F^3:30"
  1. S DIR("A")=" Please enter the exact Out-Of-Order message"
  1. S DIR("?")=" All options/protocols with this message are reclaimed into a set in ^XTMP"
  1. D ^DIR G:$D(DIRUT) OUTRE
  1. S XQMESS=X K DIR
  1. ;
  1. RE1 S DIR(0)="F^1:20"
  1. S DIR("A")=" What do you want to name the recovered set? "
  1. S DIR("?")=" Enter any name of up to 20 characters"
  1. D ^DIR G:$D(DIRUT) OUTRE
  1. S XQSET=X K DIR
  1. I $D(^XTMP("XQOO",XQSET,0)) D G RE1
  1. .W !,"Sorry, that set already exists. Use the Create/Modify option to"
  1. .W !?3,"modify it, or choose another name."
  1. .Q
  1. ;
  1. REFIND ;Find options and protocols with the message XQMESS
  1. S XQ=0 F S XQ=$O(^DIC(19,XQ)) Q:XQ'=+XQ!(XQ="") D
  1. .Q:$P(^DIC(19,XQ,0),U,3)'=XQMESS
  1. .S ^XTMP("XQOO",XQSET,19,XQ)=$P(^DIC(19,XQ,0),U)_U_$P(^(0),U,2)
  1. .S XQOP=XQOP+1
  1. .Q
  1. ;
  1. S XQ=0 F S XQ=$O(^ORD(101,XQ)) Q:XQ'=+XQ!(XQ="") D
  1. .Q:$P(^ORD(101,XQ,0),U,3)'=XQMESS
  1. .S ^XTMP("XQOO",XQSET,101,XQ)=$P(^ORD(101,XQ,0),U)_U_$P(^(0),U,2)
  1. .S XQPROT=XQPROT+1
  1. .Q
  1. ;
  1. I XQOP>0!(XQPROT>0) D G OUTRE
  1. .D ^XQDATE
  1. .S %=$P(^VA(200,DUZ,0),U),%=$P(%,",")
  1. .S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_%
  1. .S ^XTMP("XQOO",0)=DT+7
  1. .W !!,"Set named ",XQSET," recovered with ",XQOP," options and ",XQPROT," protocols."
  1. .Q
  1. E W !!,"No options or protocols with the message ",XQMESS," were found." G OUTRE
  1. Q
  1. ;
  1. OUTRE ;Exit point for REBLD
  1. K %,%Y,DIR,DIROUT,DIRUT,DTOUT,DUOUT,X,XQ,XQMESS,XQOP,XQPROT,XQSET,Y
  1. Q
  1. ;
  1. TOG ;Toggle options and protocols on and off. (XQOOTOG option)
  1. N XQ
  1. D T1,OUTT,T2,KICK^XQ7
  1. ;
  1. OUTT ;Exit for XQOOTOG
  1. K DIC,DTOUT,DUOUT,X,Y
  1. Q
  1. ;
  1. T1 ;Toggle options
  1. S DIC=19,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of an option: "
  1. F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
  1. .S XQ=+Y,XQ0=Y(0)
  1. .I $P(XQ0,U,3)]"" D
  1. ..S XQMESS=$P(XQ0,U,3)
  1. ..W !!,"Option ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
  1. ..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
  1. ..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
  1. ..D ^DIR
  1. ..I Y S $P(^DIC(19,XQ,0),U,3)="",DA=XQ D REDO^XQ7
  1. ..K DIR,X,Y
  1. ..Q
  1. .E W ! D
  1. ..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this option out of order: "
  1. ..S DIR("?")="This option is in service. Enter a string to remove it from use."
  1. ..K DIRUT D ^DIR
  1. ..I '$D(DIRUT) S $P(^DIC(19,XQ,0),U,3)=Y,DA=XQ D REDO^XQ7
  1. ..K DIR,DIRUT,X,Y
  1. ..Q
  1. .Q
  1. Q
  1. ;
  1. T2 ;Toggle protocols
  1. S DIC=101,DIC(0)="AEMQZ",DIC("A")="Enter the name or menu text of a protocol: "
  1. F W ! D ^DIC Q:$D(DTOUT)!$D(DUOUT)!(Y<0) D
  1. .S XQ=+Y,XQ0=Y(0)
  1. .I $P(XQ0,U,3)]"" D
  1. ..S XQMESS=$P(XQ0,U,3)
  1. ..W !!,"Protocol ",$P(Y(0),U)," is out with the message '",XQMESS,"'",!
  1. ..S DIR(0)="Y",DIR("A")="Put it in service",DIR("B")="YES"
  1. ..S DIR("?")="If you answer 'YES' the out-of-order message will be killed, putting the option back in service."
  1. ..D ^DIR
  1. ..I Y S $P(^ORD(101,XQ,0),U,3)=""
  1. ..K DA,DIR,X,Y
  1. ..Q
  1. .E W ! D
  1. ..S DIR(0)="FA^3:50",DIR("A")="Enter a message to put this protocol out of order: "
  1. ..S DIR("?")="This protocol is in service. Enter a string to remove it from use."
  1. ..K DIRUT D ^DIR
  1. ..I '$D(DIRUT) S $P(^ORD(101,XQ,0),U,3)=Y
  1. ..K DIR,DIRUT,X,Y
  1. ..Q
  1. .Q
  1. Q