XQ73 ;SEA/MJM - Rubber Band Jump ("^^") Processor ;05/08/98 10:10 [ 04/02/2003 8:29 AM ]
;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
;;8.0;KERNEL;**46**;Jul 10, 1995
;Entry from XQ
;With +XQY: target opt, XQY0: 0th node
;with a pathway; XQ(XQ) array of alternate pathways, if any; XQDIC:
;P-tree of target option; XQPSM: XQDIC or mutiple trees (U66,P258)
;XQSV: XQY^XQDIC^XQY0 of origin (previous) option.
;
;Set the jump flag to indicate that this is a jump process
S XQJMP=1
;
;Set XQMA to the option from whence we came. XQNMB is set to a high
;number which will count down and be used to save Exit Actions and
;headers that are stored in ^XUTL("XQ", $J,"RBX")
;
S XQMA=$P(XQSV,U,2),XQNMB=999
;
;If the "RBX" nodes already exist we know that we are already in a
;rubber band jump. Set the flag XQFLG and save in XASAV the current
;option, load the original rubberband jump, do RBX^XQ73 to execute
;the stored exit actions and headers.
;
I $D(^XUTL("XQ",$J,"RBX")) S XQFLG=1,XQSAV=XQY_U_XQPSM_U_XQY0,XQY=+^("RBX"),XQY0=$P(^("RBX"),U,2,99) D RBX S XQY=+XQSAV,XQPSM=$P(XQSAV,U,2),XQY0=$P(XQSAV,U,3,99) K XQFLG,XQSAV
;
;If the target option XQY is a sibling of XQMA then it's not really
;a jump, so load it and return to XQ.
;
I $D(^XUTL("XQO",XQMA,"^",+XQY)),($P(^(+XQY),U,6)=+XQY!($P(^(+XQY),U,6)="")) S XQY0=$P(^(+XQY),U,2,99) G M^XQ
;
;Set XQTT to the stack pointer and point XQST to the primary menu.
;Set XQSM to 1 as a flag if this is a jump to a secondary menu.
;Collect the current stack IEN's in XQSTK separated by commas.
;
S XQTT=^XUTL("XQ",$J,"T"),XQST=1,XQSTK="",XQSM=$S($P(^(XQTT),U)["U":1,1:0) F XQI=1:1:XQTT S %=+^XUTL("XQ",$J,XQI),XQSTK=XQSTK_%_","
;
;If XQY, the target option, is already on the stack then back down
;to it if we are not already in a RB jump.
;
I (","_XQSTK)[(","_XQY_",") G:'$D(XQRB) NOJ^XQ72A
;
;Using XQFLAG as a flag, find XQDIC (the parent of the jump tree)
;if there is a "U" then it must be a common option or a secondary
;menu tree.
;
S XQFLAG=0 I XQPSM["U" S XQFLAG=1,XQST=XQTT I XQPSM["," S XQDIC=$P(XQPSM,",",2)
;
;If there are multiple pathways find the shortest. If XQ comes back as
;0, you can't get there from here.
;
I $D(XQ),XQ>0 D MPW^XQ72 G:XQ<0 OUT
;
;Get the jump path in XQJP and set XQI to the stack pointer as it is
;or was before the jump. Set XQI to the original stack pointer.
;
S XQJP=$P(XQY0,U,5) S XQI=XQTT
;
;If this is a secondary menu jump put the parent option on the
;beginning of the jump path.
;
I XQPSM["," S XQJP=$P(XQPSM,"P",2)_","_XQJP ;Secondary menu tree
;
;If this is a common option put XUCOMMAND on the front of the jump
;path.
;
I XQPSM="PXU" S XQJP=$O(^DIC(19,"B","XUCOMMAND",0))_","_XQJP ;Common options
;If we are jumping within the same tree, get the modified path (just
;those options not already executed.
;
;I $D(^XUTL("XQO",XQDIC,U,XQY)) D SAMTREE^XQ72 S XQJP=$P(XQNP,U,2),XQY1=+XQNP
;
FND ;Pop to next Menu-type option, if in path remove options below it
S XQJP1=XQJP,XQI=XQTT+1,XQNP=$S($D(XQNP):XQNP,1:0)
F XQII=0:0 Q:+XQNP>0 S XQI=XQI-1 S XQY1=^XUTL("XQ",$J,XQI),XQT=$P(XQY1,U,5) Q:XQI=1 I "M"[XQT F XQJ=1:1:$L(XQJP,",")-1 I $P(XQJP,",",XQJ)=+XQY1 S XQNP=XQI_U_$P($E(XQJP,$F(XQJP,+XQY1),99),",",2,99) Q
;
I +XQNP>0 D
.N XQSTP,XQJP2,XQDAD,XQI
.S XQSTP=+XQNP,XQJP2=$P(XQNP,U,2),XQDAD=+XQY1
.F XQI=XQTT:-1:XQSTP D
..S %=+^XUTL("XQ",$J,XQI)
..I $D(^DIC(19,%,26)),$L(^(26)) X ^(26) ;W " ==> FND^XQ73"
..Q
.S XQJP=XQJP2
.Q
I '$L(XQJP) G M^XQ
F XQI=1:1 S XQYY=$P(XQJP,",",XQI) Q:XQYY=XQY!(XQYY="") S XQJ=^XUTL("XQO",XQDIC,"^",XQYY) D ACT Q:$D(XQUIT)
I '$D(XQUIT) S ^XUTL("XQ",$J,XQTT+1)=-1,^("T")=XQTT+1,^("RBX")=XQY_U_XQY0
OUT ;Exit here
S:$D(XQ(XQY)) XQPSM=$P(XQ(XQY),U,3)
K %,X,XQ,XQA,XQAL,XQCH,XQFLAG,XQHD,XQI,XQII,XQJ,XQJP,XQJMP,XQJP1,XQL,XQK,XQMA,XQNO,XQNMB,XQNP,XQSM,XQST,XQSTK,XQT,XQTT,XQYY,XQY1,Y
;K '$D(XQUIT) XQRB
;Q:'$D(XQXFLG("GUI"))
I $D(XQUIT) K XQUIT G M1^XQ
G M^XQ
Q
ACT ;Execute headers & entry actions, store headers & exit actions
I $P(XQJ,U,15),$D(^DIC(19,XQYY,20)),$L(^(20)) X ^(20) ;W " ==> ACT^XQ73"
I $D(XQUIT) D RB^XQUIT Q:$D(XQUIT)
S XQHD=0 I $P(XQJ,U,18),$D(^DIC(19,XQYY,26)),$L(^(26)) X ^(26) S XQHD=1 ;W " ==> ACT^XQ73" ;^XUTL("XQ",$J,"RBX",XQNMB)=^(26),XQNMB=XQNMB-1
I $P(XQJ,U,16),$D(^DIC(19,XQYY,15)),$L(^(15)) S ^XUTL("XQ",$J,"RBX",XQNMB)=^(15),XQNMB=XQNMB-1
I XQHD S ^XUTL("XQ",$J,"RBX",XQNMB)=^DIC(19,XQYY,26),XQNMB=XQNMB-1
Q
;
R ;Reset XUTL("XQ") stack pointer ^("T") to 1 (primary menu) 'GO HOME'
;I $S('$D(^XUTL("XQ",$J,"XQM")):1,XQY=^("XQM"):1,1:0) G OUT
I ^XUTL("XQ",$J,"T")>1 F XQI=^("T"):-1:1 D
.S XQY=^XUTL("XQ",$J,XQI) D:+XQY<1 RBX S XQY0=$P(XQY,U,2,99) I XQI>1,$P(XQY0,U,15),$D(^DIC(19,+XQY,15)),$L(^(15)) X ^(15) ;W " ==> R+3^XQ73"
.S %=^XUTL("XQ",$J,XQI-1) I (XQI-1)>1,$P(%,U,18),$D(^DIC(19,+%,26)),$L(^(26)) X ^(26)
S (XQY,XQDIC)=^XUTL("XQ",$J,"XQM"),XQY0=$P(^(1),U,2,99),^("T")=1
S XQT=$P(XQY0,U,4)
K XQI,XQUR S XQM3=1
;Q:$D(XQXFLG("GUI"))
G M^XQ
Q
;
RBX ;Execute stored exit actions to return from RB jump
I $P(XQY0,U,15),$D(^DIC(19,XQY,15)),$L(^(15)) X ^(15) ;W " ==> RBX+1^XQ73"
S XQN="" F XQJ=0:0 S XQN=$O(^XUTL("XQ",$J,"RBX",XQN)) Q:XQN="" X ^(XQN) ;W " ==> RBX^XQ73"
;S ^("T")=^XUTL("XQ",$J,"T")-1,XQY=^(^("T")),XQY0=$P(XQY,U,2,99),XQDIC=$P(XQY,+XQY,2),XQY=+XQY
F XQJ=^XUTL("XQ",$J,"T"):-1:1 Q:^(XQJ)=-1
S ^XUTL("XQ",$J,"T")=$S(XQJ-1>0:XQJ-1,1:1) S:'$D(XQFLG) %=^(^("T")),XQY=+%,XQY0=$P(%,U,2,99),XQPSM=$P($P(%,+XQY,2,99),U),XQDIC=$S((XQPSM[","):$P(XQPSM,",",2),1:XQPSM)
I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26) ;W " ==> RBX^XQ73"
K ^XUTL("XQ",$J,"RBX"),%,XQJ,XQN,XQRB
G:'$D(XQFLG) M1^XQ
Q
XQ73 ;SEA/MJM - Rubber Band Jump ("^^") Processor ;05/08/98 10:10 [ 04/02/2003 8:29 AM ]
+1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
+2 ;;8.0;KERNEL;**46**;Jul 10, 1995
+3 ;Entry from XQ
+4 ;With +XQY: target opt, XQY0: 0th node
+5 ;with a pathway; XQ(XQ) array of alternate pathways, if any; XQDIC:
+6 ;P-tree of target option; XQPSM: XQDIC or mutiple trees (U66,P258)
+7 ;XQSV: XQY^XQDIC^XQY0 of origin (previous) option.
+8 ;
+9 ;Set the jump flag to indicate that this is a jump process
+10 SET XQJMP=1
+11 ;
+12 ;Set XQMA to the option from whence we came. XQNMB is set to a high
+13 ;number which will count down and be used to save Exit Actions and
+14 ;headers that are stored in ^XUTL("XQ", $J,"RBX")
+15 ;
+16 SET XQMA=$PIECE(XQSV,U,2)
SET XQNMB=999
+17 ;
+18 ;If the "RBX" nodes already exist we know that we are already in a
+19 ;rubber band jump. Set the flag XQFLG and save in XASAV the current
+20 ;option, load the original rubberband jump, do RBX^XQ73 to execute
+21 ;the stored exit actions and headers.
+22 ;
+23 IF $DATA(^XUTL("XQ",$JOB,"RBX"))
SET XQFLG=1
SET XQSAV=XQY_U_XQPSM_U_XQY0
SET XQY=+^("RBX")
SET XQY0=$PIECE(^("RBX"),U,2,99)
DO RBX
SET XQY=+XQSAV
SET XQPSM=$PIECE(XQSAV,U,2)
SET XQY0=$PIECE(XQSAV,U,3,99)
KILL XQFLG,XQSAV
+24 ;
+25 ;If the target option XQY is a sibling of XQMA then it's not really
+26 ;a jump, so load it and return to XQ.
+27 ;
+28 IF $DATA(^XUTL("XQO",XQMA,"^",+XQY))
IF ($PIECE(^(+XQY),U,6)=+XQY!($PIECE(^(+XQY),U,6)=""))
SET XQY0=$PIECE(^(+XQY),U,2,99)
GOTO M^XQ
+29 ;
+30 ;Set XQTT to the stack pointer and point XQST to the primary menu.
+31 ;Set XQSM to 1 as a flag if this is a jump to a secondary menu.
+32 ;Collect the current stack IEN's in XQSTK separated by commas.
+33 ;
+34 SET XQTT=^XUTL("XQ",$JOB,"T")
SET XQST=1
SET XQSTK=""
SET XQSM=$SELECT($PIECE(^(XQTT),U)["U":1,1:0)
FOR XQI=1:1:XQTT
SET %=+^XUTL("XQ",$JOB,XQI)
SET XQSTK=XQSTK_%_","
+35 ;
+36 ;If XQY, the target option, is already on the stack then back down
+37 ;to it if we are not already in a RB jump.
+38 ;
+39 IF (","_XQSTK)[(","_XQY_",")
IF '$DATA(XQRB)
GOTO NOJ^XQ72A
+40 ;
+41 ;Using XQFLAG as a flag, find XQDIC (the parent of the jump tree)
+42 ;if there is a "U" then it must be a common option or a secondary
+43 ;menu tree.
+44 ;
+45 SET XQFLAG=0
IF XQPSM["U"
SET XQFLAG=1
SET XQST=XQTT
IF XQPSM[","
SET XQDIC=$PIECE(XQPSM,",",2)
+46 ;
+47 ;If there are multiple pathways find the shortest. If XQ comes back as
+48 ;0, you can't get there from here.
+49 ;
+50 IF $DATA(XQ)
IF XQ>0
DO MPW^XQ72
IF XQ<0
GOTO OUT
+51 ;
+52 ;Get the jump path in XQJP and set XQI to the stack pointer as it is
+53 ;or was before the jump. Set XQI to the original stack pointer.
+54 ;
+55 SET XQJP=$PIECE(XQY0,U,5)
SET XQI=XQTT
+56 ;
+57 ;If this is a secondary menu jump put the parent option on the
+58 ;beginning of the jump path.
+59 ;
+60 ;Secondary menu tree
IF XQPSM[","
SET XQJP=$PIECE(XQPSM,"P",2)_","_XQJP
+61 ;
+62 ;If this is a common option put XUCOMMAND on the front of the jump
+63 ;path.
+64 ;
+65 ;Common options
IF XQPSM="PXU"
SET XQJP=$ORDER(^DIC(19,"B","XUCOMMAND",0))_","_XQJP
+66 ;If we are jumping within the same tree, get the modified path (just
+67 ;those options not already executed.
+68 ;
+69 ;I $D(^XUTL("XQO",XQDIC,U,XQY)) D SAMTREE^XQ72 S XQJP=$P(XQNP,U,2),XQY1=+XQNP
+70 ;
FND ;Pop to next Menu-type option, if in path remove options below it
+1 SET XQJP1=XQJP
SET XQI=XQTT+1
SET XQNP=$SELECT($DATA(XQNP):XQNP,1:0)
+2 FOR XQII=0:0
IF +XQNP>0
QUIT
SET XQI=XQI-1
SET XQY1=^XUTL("XQ",$JOB,XQI)
SET XQT=$PIECE(XQY1,U,5)
IF XQI=1
QUIT
IF "M"[XQT
FOR XQJ=1:1:$LENGTH(XQJP,",")-1
IF $PIECE(XQJP,",",XQJ)=+XQY1
SET XQNP=XQI_U_$PIECE($EXTRACT(XQJP,$FIND(XQJP,+XQY1),99),",",2,99)
QUIT
+3 ;
+4 IF +XQNP>0
Begin DoDot:1
+5 NEW XQSTP,XQJP2,XQDAD,XQI
+6 SET XQSTP=+XQNP
SET XQJP2=$PIECE(XQNP,U,2)
SET XQDAD=+XQY1
+7 FOR XQI=XQTT:-1:XQSTP
Begin DoDot:2
+8 SET %=+^XUTL("XQ",$JOB,XQI)
+9 ;W " ==> FND^XQ73"
IF $DATA(^DIC(19,%,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+10 QUIT
End DoDot:2
+11 SET XQJP=XQJP2
+12 QUIT
End DoDot:1
+13 IF '$LENGTH(XQJP)
GOTO M^XQ
+14 FOR XQI=1:1
SET XQYY=$PIECE(XQJP,",",XQI)
IF XQYY=XQY!(XQYY="")
QUIT
SET XQJ=^XUTL("XQO",XQDIC,"^",XQYY)
DO ACT
IF $DATA(XQUIT)
QUIT
+15 IF '$DATA(XQUIT)
SET ^XUTL("XQ",$JOB,XQTT+1)=-1
SET ^("T")=XQTT+1
SET ^("RBX")=XQY_U_XQY0
OUT ;Exit here
+1 IF $DATA(XQ(XQY))
SET XQPSM=$PIECE(XQ(XQY),U,3)
+2 KILL %,X,XQ,XQA,XQAL,XQCH,XQFLAG,XQHD,XQI,XQII,XQJ,XQJP,XQJMP,XQJP1,XQL,XQK,XQMA,XQNO,XQNMB,XQNP,XQSM,XQST,XQSTK,XQT,XQTT,XQYY,XQY1,Y
+3 ;K '$D(XQUIT) XQRB
+4 ;Q:'$D(XQXFLG("GUI"))
+5 IF $DATA(XQUIT)
KILL XQUIT
GOTO M1^XQ
+6 GOTO M^XQ
+7 QUIT
ACT ;Execute headers & entry actions, store headers & exit actions
+1 ;W " ==> ACT^XQ73"
IF $PIECE(XQJ,U,15)
IF $DATA(^DIC(19,XQYY,20))
IF $LENGTH(^(20))
XECUTE ^(20)
+2 IF $DATA(XQUIT)
DO RB^XQUIT
IF $DATA(XQUIT)
QUIT
+3 ;W " ==> ACT^XQ73" ;^XUTL("XQ",$J,"RBX",XQNMB)=^(26),XQNMB=XQNMB-1
SET XQHD=0
IF $PIECE(XQJ,U,18)
IF $DATA(^DIC(19,XQYY,26))
IF $LENGTH(^(26))
XECUTE ^(26)
SET XQHD=1
+4 IF $PIECE(XQJ,U,16)
IF $DATA(^DIC(19,XQYY,15))
IF $LENGTH(^(15))
SET ^XUTL("XQ",$JOB,"RBX",XQNMB)=^(15)
SET XQNMB=XQNMB-1
+5 IF XQHD
SET ^XUTL("XQ",$JOB,"RBX",XQNMB)=^DIC(19,XQYY,26)
SET XQNMB=XQNMB-1
+6 QUIT
+7 ;
R ;Reset XUTL("XQ") stack pointer ^("T") to 1 (primary menu) 'GO HOME'
+1 ;I $S('$D(^XUTL("XQ",$J,"XQM")):1,XQY=^("XQM"):1,1:0) G OUT
+2 IF ^XUTL("XQ",$JOB,"T")>1
FOR XQI=^("T"):-1:1
Begin DoDot:1
+3 ;W " ==> R+3^XQ73"
SET XQY=^XUTL("XQ",$JOB,XQI)
IF +XQY<1
DO RBX
SET XQY0=$PIECE(XQY,U,2,99)
IF XQI>1
IF $PIECE(XQY0,U,15)
IF $DATA(^DIC(19,+XQY,15))
IF $LENGTH(^(15))
XECUTE ^(15)
+4 SET %=^XUTL("XQ",$JOB,XQI-1)
IF (XQI-1)>1
IF $PIECE(%,U,18)
IF $DATA(^DIC(19,+%,26))
IF $LENGTH(^(26))
XECUTE ^(26)
End DoDot:1
+5 SET (XQY,XQDIC)=^XUTL("XQ",$JOB,"XQM")
SET XQY0=$PIECE(^(1),U,2,99)
SET ^("T")=1
+6 SET XQT=$PIECE(XQY0,U,4)
+7 KILL XQI,XQUR
SET XQM3=1
+8 ;Q:$D(XQXFLG("GUI"))
+9 GOTO M^XQ
+10 QUIT
+11 ;
RBX ;Execute stored exit actions to return from RB jump
+1 ;W " ==> RBX+1^XQ73"
IF $PIECE(XQY0,U,15)
IF $DATA(^DIC(19,XQY,15))
IF $LENGTH(^(15))
XECUTE ^(15)
+2 ;W " ==> RBX^XQ73"
SET XQN=""
FOR XQJ=0:0
SET XQN=$ORDER(^XUTL("XQ",$JOB,"RBX",XQN))
IF XQN=""
QUIT
XECUTE ^(XQN)
+3 ;S ^("T")=^XUTL("XQ",$J,"T")-1,XQY=^(^("T")),XQY0=$P(XQY,U,2,99),XQDIC=$P(XQY,+XQY,2),XQY=+XQY
+4 FOR XQJ=^XUTL("XQ",$JOB,"T"):-1:1
IF ^(XQJ)=-1
QUIT
+5 SET ^XUTL("XQ",$JOB,"T")=$SELECT(XQJ-1>0:XQJ-1,1:1)
IF '$DATA(XQFLG)
SET %=^(^("T"))
SET XQY=+%
SET XQY0=$PIECE(%,U,2,99)
SET XQPSM=$PIECE($PIECE(%,+XQY,2,99),U)
SET XQDIC=$SELECT((XQPSM[","):$PIECE(XQPSM,",",2),1:XQPSM)
+6 ;W " ==> RBX^XQ73"
IF $PIECE(XQY0,U,17)
IF $DATA(^DIC(19,XQY,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+7 KILL ^XUTL("XQ",$JOB,"RBX"),%,XQJ,XQN,XQRB
+8 IF '$DATA(XQFLG)
GOTO M1^XQ
+9 QUIT
