- XQ73 ;SEA/MJM - Rubber Band Jump ("^^") Processor ;05/08/98 10:10
- ;;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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ73 5735 printed Feb 18, 2025@23:31:26 Page 2
- XQ73 ;SEA/MJM - Rubber Band Jump ("^^") Processor ;05/08/98 10:10
- +1 ;;8.0;KERNEL;**46**;Jul 10, 1995
- +2 ;Entry from XQ
- +3 ;With +XQY: target opt, XQY0: 0th node
- +4 ;with a pathway; XQ(XQ) array of alternate pathways, if any; XQDIC:
- +5 ;P-tree of target option; XQPSM: XQDIC or mutiple trees (U66,P258)
- +6 ;XQSV: XQY^XQDIC^XQY0 of origin (previous) option.
- +7 ;
- +8 ;Set the jump flag to indicate that this is a jump process
- +9 SET XQJMP=1
- +10 ;
- +11 ;Set XQMA to the option from whence we came. XQNMB is set to a high
- +12 ;number which will count down and be used to save Exit Actions and
- +13 ;headers that are stored in ^XUTL("XQ", $J,"RBX")
- +14 ;
- +15 SET XQMA=$PIECE(XQSV,U,2)
- SET XQNMB=999
- +16 ;
- +17 ;If the "RBX" nodes already exist we know that we are already in a
- +18 ;rubber band jump. Set the flag XQFLG and save in XASAV the current
- +19 ;option, load the original rubberband jump, do RBX^XQ73 to execute
- +20 ;the stored exit actions and headers.
- +21 ;
- +22 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
- +23 ;
- +24 ;If the target option XQY is a sibling of XQMA then it's not really
- +25 ;a jump, so load it and return to XQ.
- +26 ;
- +27 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
- +28 ;
- +29 ;Set XQTT to the stack pointer and point XQST to the primary menu.
- +30 ;Set XQSM to 1 as a flag if this is a jump to a secondary menu.
- +31 ;Collect the current stack IEN's in XQSTK separated by commas.
- +32 ;
- +33 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_%_","
- +34 ;
- +35 ;If XQY, the target option, is already on the stack then back down
- +36 ;to it if we are not already in a RB jump.
- +37 ;
- +38 IF (","_XQSTK)[(","_XQY_",")
- if '$DATA(XQRB)
- GOTO NOJ^XQ72A
- +39 ;
- +40 ;Using XQFLAG as a flag, find XQDIC (the parent of the jump tree)
- +41 ;if there is a "U" then it must be a common option or a secondary
- +42 ;menu tree.
- +43 ;
- +44 SET XQFLAG=0
- IF XQPSM["U"
- SET XQFLAG=1
- SET XQST=XQTT
- IF XQPSM[","
- SET XQDIC=$PIECE(XQPSM,",",2)
- +45 ;
- +46 ;If there are multiple pathways find the shortest. If XQ comes back as
- +47 ;0, you can't get there from here.
- +48 ;
- +49 IF $DATA(XQ)
- IF XQ>0
- DO MPW^XQ72
- if XQ<0
- GOTO OUT
- +50 ;
- +51 ;Get the jump path in XQJP and set XQI to the stack pointer as it is
- +52 ;or was before the jump. Set XQI to the original stack pointer.
- +53 ;
- +54 SET XQJP=$PIECE(XQY0,U,5)
- SET XQI=XQTT
- +55 ;
- +56 ;If this is a secondary menu jump put the parent option on the
- +57 ;beginning of the jump path.
- +58 ;
- +59 ;Secondary menu tree
- IF XQPSM[","
- SET XQJP=$PIECE(XQPSM,"P",2)_","_XQJP
- +60 ;
- +61 ;If this is a common option put XUCOMMAND on the front of the jump
- +62 ;path.
- +63 ;
- +64 ;Common options
- IF XQPSM="PXU"
- SET XQJP=$ORDER(^DIC(19,"B","XUCOMMAND",0))_","_XQJP
- +65 ;If we are jumping within the same tree, get the modified path (just
- +66 ;those options not already executed.
- +67 ;
- +68 ;I $D(^XUTL("XQO",XQDIC,U,XQY)) D SAMTREE^XQ72 S XQJP=$P(XQNP,U,2),XQY1=+XQNP
- +69 ;
- 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