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

XQOO.m

Go to the documentation of this file. 
  1. XQOO ;SEATTLE/LUKE - Out Of Order, Man ;9/13/96  09:21
  1.  ;;8.0;KERNEL;**10,21,47,520**;Jul 03, 1995;Build 11
  1.  ;Per VHA Directive  2004-038, this routine should not be modified.
  1. INIT(XQSET) ;Call for Out-of-order set creation, called by KIDS
  1.  ;
  1.  ;The variable XQSET should be null if this is the first pass
  1.  ;or if KIDS thinks the user wants a new set of options
  1.  ;
  1.  S XQINI="",XQK=0 ;XQINI used as a flag to see if it's KIDS calling
  1.  I XQSET]"" S:'$D(^XTMP("XQOO",XQSET,0)) XQSET="^"
  1.  I XQSET="^" G OUT
  1.  I XQSET]"" S XQMESS=$P(^XTMP("XQOO",XQSET,0),U) G ASK1
  1.  ;
  1. EN ;Entry point for Define Out Of Order Options Set option
  1.  S XQK=0,U="^",XQSET=U
  1.  ;
  1. NAME ;Get name for this option set
  1.  W !!,"Enter a short name for this set of options and or protocols: " R XQSET:DTIME S:'$T XQSET=U G:XQSET=U OUT
  1.  I XQSET="?" W !!,"Enter a name of 20 characters or less for this set, '^' to quit, or '??' for help" G NAME
  1.  I XQSET["??" S XQH="XQOO-NAME" D EN^XQH G NAME
  1.  I XQSET=""!($L(XQSET)>20) W !!,"Out-of-order sets must be named with 20 or less characters.  Enter '^' to quit." G NAME
  1.  I $D(^XTMP("XQOO",XQSET,0)) D  G:$D(DIRUT) OUT G:Y=0 NAME G ASK1
  1.  .S XQMESS=$P(^XTMP("XQOO",XQSET,0),U)
  1.  .W !!,"WARNING: The Out-of-order set '",XQSET,"' already exists.",!
  1.  .S DIR("A")="Do you want to modify it? (Y/N) " S DIR(0)="Y",DIR("B")="YES" D ^DIR K DIR
  1.  .Q
  1.  ;
  1. MESS ;Get the Out Of Order Message
  1.  R !!,"What should the Out Of Order message text be? :",XQMESS:DTIME S:'$T XQMESS=U G:XQMESS=U OUT
  1.  I XQMESS="?" W !!,"This is the message that will be shown with the options/protocols",!,"that are made out of order. For instance, ""Laboratory install in progress""" G MESS
  1.  I XQMESS["??" S XQH="XQOO-MESS" D EN^XQH G MESS
  1.  ;
  1. ASK1 S XQFIL=19
  1. ASK ;Get options to mark
  1.  S (XQ,XQN)=""
  1.  W !!,"Enter "_$S(XQFIL=19:"options",1:"protocols")_" you wish to mark as 'Out Of Order': "
  1.  R XQ:DTIME S:'$T XQ=U G:XQ=U OUT G:XQ="" SET
  1.  I XQ="?" D  G ASK
  1.  .W !!?5,"Enter "_$S(XQFIL=19:"an option",1:"a protocol")_" name,"
  1.  .W !?5,"a name preceded by a minus sign to remove "_$S(XQFIL=19:"an option,",1:"a protocol,")
  1.  .W !?5,$S(XQFIL=19:"'^PR'",1:"'^OP'")_" to switch to "_$S(XQFIL=19:"protocols,",1:"options,")
  1.  .W !?5,"an uparrow (that is '^') to quit,"
  1.  .W !?5,"or '??' for more help."
  1.  .Q
  1.  I XQ["??" S XQH="XQOO" D:XQ="??" EN^XQH D:XQ="???" LIST D:XQ="????" LSTFIL S XQH="XQOO-MAIN" D:XQ="?????" EN^XQH G ASK
  1.  I $E(XQ,1,3)="^OP"!($E(XQ,1,3)="^op") S XQFIL=19,XQSWTCH="" G ASK
  1.  I $E(XQ,1,3)="^PR"!($E(XQ,1,3)="^pr") S XQFIL=101,XQSWTCH="" G ASK
  1.  S XQDEL=0 I $E(XQ,1)="-" S XQDEL=1,XQ=$E(XQ,2,99)
  1.  I XQ="*",XQDEL K ^XTMP("XQOO",XQSET,XQFIL) W !," All "_$S(XQFIL=19:"options",1:"protocols")_" removed.  Start again or '^' to quit. " G ASK
  1.  I XQ="*" S XQSTART=1,XQEND="ZZZZZ" D FIND G ASK
  1.  I XQ?.E1"*" S XQSTART=$E(XQ,1,$L(XQ)-1),XQEND=XQSTART_$C(127) D FIND G ASK
  1.  ;Get a range of options allowing for name with hyphens in them
  1.  I XQ?1E.E1"-"1E.E S XQRNG=0 D  G:'XQRNG ASK
  1.  .;Name has hyphen, echo back the name and quit
  1.  .S X=XQ,DIC=XQFIL,DIC(0)="EZ" D ^DIC I Y>0 S XQ=$P(Y,U,2),XQRNG=1 Q
  1.  .;It is a range, build prompt to verify range
  1.  .W ! K DIR S DIR("A")="Do mean the "_$S(XQFIL=19:"options",1:"protocols")_" from "_$P(XQ,"-")_" to "_$P(XQ,"-",2)_"? (Y/N)",DIR(0)="YA" D ^DIR K DIR I Y S (XQN,XQSTART)=$P(XQ,"-",1),XQEND=$P(XQ,"-",2) D FIND
  1.  .Q
  1.  ;
  1.  I XQ'?1E.E1"-"1E.E S X=XQ,DIC=XQFIL,DIC(0)="MEZ" D ^DIC S:Y'<0 XQ=$P(Y,U,2) I Y<0 W " ??",*7 G ASK
  1.  I XQDEL K ^XTMP("XQOO",XQSET,XQFIL,+Y) G ASK
  1.  S:$E(Y(0),1,4)'="XQOO" ^XTMP("XQOO",XQSET,XQFIL,+Y)=$P(Y(0),U)_U_$P(Y(0),U,2) G ASK
  1.  ;
  1. FIND ;Find first option in wildcard list
  1.  S XQN="" S:$L(XQSTART)>2 XQN=$E(XQSTART,1,$L(XQSTART)-1)
  1.  I XQFIL=19 F XQI=0:0 S XQN=$O(^DIC(XQFIL,"B",XQN)) Q:XQN=""!($E(XQN,1,$L(XQSTART))=XQSTART)
  1.  E  F XQI=0:0 S XQN=$O(^ORD(101,"B",XQN)) Q:XQN=""!($E(XQN,1,$L(XQSTART))=XQSTART)
  1.  I XQN="" W !," No such ",$S(XQFIL=19:"option(s).",1:"protocol(s).") Q
  1.  S XQSTART=XQN
  1.  ;
  1. FINDR I XQFIL=19 S XQON=$O(^DIC(XQFIL,"B",XQN,0)),XQON0=^DIC(XQFIL,+XQON,0)
  1.  E  S XQON=$O(^ORD(XQFIL,"B",XQN,0)),XQON0=^ORD(XQFIL,+XQON,0)
  1.  I XQDEL D DELET Q
  1.  ;
  1. GET ;Get the first option selected and put it in ^XTMP
  1.  S XQN=XQSTART I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
  1.  S DIC=XQFIL,DIC(0)="MZ"
  1.  ;
  1. NEXT ;Find the rest of the options in this range and do likewise
  1.  I XQFIL=19 F  Q:XQN=XQEND  S XQN=$O(^DIC(XQFIL,"B",XQN)) Q:XQN=""!(XQN]XQEND)  S XQON=$O(^DIC(XQFIL,"B",XQN,0)),XQON0=^DIC(XQFIL,+XQON,0) I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
  1.  E  F  Q:XQN=XQEND  S XQN=$O(^ORD(XQFIL,"B",XQN)) Q:XQN=""!(XQN]XQEND)  S XQON=$O(^ORD(XQFIL,"B",XQN,0)),XQON0=^ORD(XQFIL,+XQON,0) I $E(XQON,1,4)'="XQOO" S ^XTMP("XQOO",XQSET,XQFIL,+XQON)=$P(XQON0,U)_U_$P(XQON0,U,2),XQK=XQK+1
  1.  Q
  1.  ;
  1. DELET ;Delete option(s) from the list in ^XTMP
  1.  ;W !,XQON,"  ",XQSTART,"  ",XQDEL
  1.  S XQN=XQSTART,XQDEL=0
  1.  I XQFIL=19 F  K ^XTMP("XQOO",XQSET,XQFIL,+XQON) S XQN=$O(^DIC(XQFIL,"B",XQN)),XQX=XQK-1 Q:XQN=""!(XQN]XQEND)  S XQON=$O(^DIC(XQFIL,"B",XQN,0))
  1.  E  F  K ^XTMP("XQOO",XQSET,XQFIL,+XQON) S XQN=$O(^ORD(XQFIL,"B",XQN)),XQX=XQK-1 Q:XQN=""!(XQN]XQEND)  S XQON=$O(^ORD(XQFIL,"B",XQN,0))
  1.  Q
  1.  ;
  1. REMOV R !!,"Remove all options previously selected? ",XQ:DTIME S:'$T XQ=U G:XQ[U OUT I XQ["N"!(XQ["n") W !!,"OK, you may continue." G ASK
  1.  K ^XTMP("XQOO",XQSET)
  1.  Q
  1. LSTFIL ;Show Option File
  1.  N XQE,XQR,XQS
  1.  D RANGE^XQOO2(.XQS,.XQE,.XQR) I XQR D BXREF^XQOO2(XQS,XQE)
  1.  Q
  1.  ;
  1. LIST ;List users and options selected so far.
  1.  W @IOF S (XQT,XQM)=0
  1.  F XQFIL0=19,101 D
  1.  .S XQT=0,XQN=0,XQN=$O(^XTMP("XQOO",XQSET,XQFIL0,XQN)) I XQN="" W !!,"No "_$S(XQFIL0=19:"menu options",1:"protocols")_" selected yet" Q
  1.  .W !!,"You will place Out Of Order the following "_$S(XQFIL0=19:"options:",1:"protocols:"),! F XQI=0:0 D:$Y+3>IOSL WAIT Q:XQ=U  W !,$P(^XTMP("XQOO",XQSET,XQFIL0,XQN),U,2)_"   ["_$P(^(XQN),U)_"]   (IEN = "_XQN_")" S XQN=$O(^(XQN)) Q:XQN=""
  1.  .Q
  1.  Q
  1.  ;
  1. WAIT ;Skip to the head of the next page
  1.  I 1 S XQ="" R:IOST["C-" !!,"Press RETURN to continue, or '^' to quit.",XQ:DTIME S:'$T XQ=U W @IOF
  1.  Q
  1.  ;
  1. SET ;Set 0th node in ^XTMP global
  1.  I XQFIL=19,'$D(XQSWTCH) S XQFIL=101 G ASK
  1.  D ^XQDATE
  1.  I $D(^XTMP("XQOO",XQSET,0)) S XQMESS=$P(^(0),U)
  1.  S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_$P(^VA(200,DUZ,0),",")
  1.  S ^XTMP("XQOO",0)=DT_U_DT+7
  1.  ;
  1. OUT ;Clean up
  1.  ;
  1.  I '$D(XPDNM),'$D(^XTMP("XQOO",XQSET,0)),$D(^XTMP("XQOO",XQSET)) D
  1.  .;Temporary Fix: ^ at protocol prompt leaves partial set (no 0th node)
  1.  .S DIR(0)="Y",DIR("B")="YES"
  1.  .S DIR("A")="Delete this set of options? (Y/N) "
  1.  .D ^DIR
  1.  .I Y K ^XTMP("XQOO",XQSET)
  1.  .E  D ^XQDATE S ^XTMP("XQOO",XQSET,0)=XQMESS_U_%Y_U_$P(^VA(200,DUZ,0),","),^XTMP("XQOO",0)=DT_U_DT+7
  1.  .Q
  1.  ;
  1.  I '$D(XPDNM),$D(^XTMP("XQOO",XQSET,0)) D
  1.  .S DIR(0)="Y",DIR("B")="NO"
  1.  .S DIR("A")="Should I mark these options/protocols out-of-order now? (Y/N) "
  1.  .D ^DIR I Y D OFF^XQOO1(XQSET)
  1.  .Q
  1.  ;
  1.  K %,%Y,DIRUT,XQ,XQDEL,XQEND,XQFIL,XQFIL0,XQH,XQI,XQINI,XQK,XQM,XQMESS,XQN,XQON,XQON0,XQRNG,XQSTART,XQSWTCH,XQT,XQX,X,Y
  1.  Q