XQUIT ;SEA/LUKE - Jump Utilities (Part II) ;06/23/98 11:28 [ 04/02/2003 8:29 AM ]
;;8.0;KERNEL;**1005,1007**;APR 1, 2003
;;8.0;KERNEL;**46,87**;Jul 10, 1995
;XQUIT has been set in an entry action
;
I $D(XQRB) D RB Q ;Rubber band target set the XQUIT
;
N %,XQFLAG,XQI,XQJ,XQOP,XQOPQT,XQX
S XQX=0 ;Set to 1 if XQUIT EXECUTABLE field is executed
;
S XQOPQT=$S($D(XQD):XQD,1:XQY) ;XQY if this is not a jump or jump is completed
;
;See if there is anything in the XQUIT XECUTABLE field
D X
Q:'$D(XQUIT) ;XQUIT cleared, we're done here
;
I $D(ZTQUEUED) Q ;Tasked option, no messages allowed.
;
;Print the message unless the XQUIT EXECUTABLE field is filled in
I 'XQX D MESS
;
;Single step, no stack resetting is necessary
I $S('$D(XQJMP):0,XQJMP=1:0,(+XQSV=+^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))):1,1:0) D
.S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
.S XQT=$P(XQY0,U,4)
.K XQJMP,XQNO,XQOPQT,XQTT,XQUIT,XQUR,Y
.Q
Q:'$D(XQUIT)
;
;
RESET ;Reset the stack to what it should be
S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
S XQT1=$S($D(XQTT):XQTT,1:^XUTL("XQ",$J,"T"))
;
;Regular "^" jumps
;Remove the new stuff we have put on the stack.
;
D
.S %=^XUTL("XQ",$J,XQT1) I $P(%,U,18),$D(^DIC(19,+%,26)),$L(^(26)) X ^(26) ;W " ==> ^XQUIT"
.I $D(XQONSTK),$L(XQONSTK) F XQI=1:1 S %=$P(XQONSTK,U,XQI) Q:%="" D POP^XQ72(%)
.Q
;.;Restore the old stack as it was.
;.F XQI=1:1:XQT S %=$G(XQOLDSTK(XQI)) Q:%="" D
;..Q:^XUTL("XQ",$J,XQI)=%
;..S ^XUTL("XQ",$J,XQI)=XQOLDSTK(XQI),XQTT=XQTT+1
;..Q
;.Q
;
;Reset the stack pointer
I '$D(XQTT) S XQTT=^XUTL("XQ",$J,"T") ;We haven't been to POP^XQ72
S ^XUTL("XQ",$J,"T")=$S(XQTT>1:XQTT,1:1)
S XQT=$P(XQY0,U,4) ;Reset Option Type
;
K XQJMP,XQONSTK,XQOPQT,XQSVSTK,XQTT,XQUR,Y
Q
;
;
RB ;Come here from ^XQ73 for Rubber Band jumps
N %,XQOPQT,XQI,XQX
S XQX=0 ;Flag that tells us if XQUIT EXECUTABLE is executed (XQX=1)
S XQOPQT=$S($D(XQYY):XQYY,1:XQY) ;The option where XQUIT was born
D X Q:'$D(XQUIT) ;Stop if the application cleared the XQUIT
D:'XQX MESS ;Tell the user what's going on
;
I $D(^XUTL("XQ",$J,"RBX")) D ;Unwind the jump
.S %=0 F S %=$O(^XUTL("XQ",$J,"RBX",%)) Q:%="" X ^(%)
.K ^XUTL("XQ",$J,"RBX"),XQRB
.Q
;
;Reload the option we came from, and execute it's header. Quit.
I ^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))=-1 S (XQTT,^XUTL("XQ",$J,"T"))=$S(^("T")>1:^("T")-1,1:1)
;F XQI=XQTT:-1:1 S %=^XUTL("XQ",$J,XQI) Q:%=-1 S (^XUTL("XQ",$J,"T"),XQTT)=$S(%>0:%,1:1)
S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
S XQT=$P(XQY0,U,4)
I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
Q
;
;
T ;Come here from XQT1+14 & 33 if a template finds XQUIT while executing
D X
Q:'$D(XQUIT)
;I 'XQX D MESS
Q
;
PM ;Come here from XQ12 if XQUIT is encounter at logon in a primary menu
N XQOPQT,XQX
S XQX=0
S XQOPQT=XQY
D X
Q:'$D(XQUIT)
I 'XQX D
.I $D(^DIC(19,+XQY,21)),$P(^(21,0),U,3)>0 D DISPLAY^XQUTL
.E D
..W !!," **> Sorry, access to your primary menu has been denied by the application.",!?6,"An XQUIT was encountered in the Entry Action code.",!?6,"Please see your computer person."
..D HOLD^XQUTL
..Q
.Q
Q
;
;
; ***** Subroutines ****
;
MESS ;Tell the user what's going on unless we executed XQUIT EXECUTABLE field
I 'XQX D
.I '$D(XQNO) S XQNO=$P(XQY0,U,2)
.;
.I $D(^DIC(19,XQOPQT,21)),$P(^(21,0),U,3)>0 D DISPLAY^XQUTL
.E D
..W !!," **> Sorry, access to this option has been denied by the application.",!!?7,"The variable XQUIT was encountered at the option",!?7,"'",XQNO,"'.",!?7,"You are being returned to:",!?7,"'",$P(XQSV,U,4),"'",!
..D HOLD^XQUTL
..Q
.Q
Q
;
X ;If there is something in the XQUIT EXECUTABLE field, execute it.
I '$D(XQOPQT) S XQOPQT=XQY
I $D(^DIC(19,XQOPQT,22)),$L(^(22)) X ^(22) S XQX=1
Q
XQUIT ;SEA/LUKE - Jump Utilities (Part II) ;06/23/98 11:28 [ 04/02/2003 8:29 AM ]
+1 ;;8.0;KERNEL;**1005,1007**;APR 1, 2003
+2 ;;8.0;KERNEL;**46,87**;Jul 10, 1995
+3 ;XQUIT has been set in an entry action
+4 ;
+5 ;Rubber band target set the XQUIT
IF $DATA(XQRB)
DO RB
QUIT
+6 ;
+7 NEW %,XQFLAG,XQI,XQJ,XQOP,XQOPQT,XQX
+8 ;Set to 1 if XQUIT EXECUTABLE field is executed
SET XQX=0
+9 ;
+10 ;XQY if this is not a jump or jump is completed
SET XQOPQT=$SELECT($DATA(XQD):XQD,1:XQY)
+11 ;
+12 ;See if there is anything in the XQUIT XECUTABLE field
+13 DO X
+14 ;XQUIT cleared, we're done here
IF '$DATA(XQUIT)
QUIT
+15 ;
+16 ;Tasked option, no messages allowed.
IF $DATA(ZTQUEUED)
QUIT
+17 ;
+18 ;Print the message unless the XQUIT EXECUTABLE field is filled in
+19 IF 'XQX
DO MESS
+20 ;
+21 ;Single step, no stack resetting is necessary
+22 IF $SELECT('$DATA(XQJMP):0,XQJMP=1:0,(+XQSV=+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T"))):1,1:0)
Begin DoDot:1
+23 SET XQY=+XQSV
SET XQDIC=$PIECE(XQSV,U,2)
SET XQY0=$PIECE(XQSV,U,3,99)
+24 SET XQT=$PIECE(XQY0,U,4)
+25 KILL XQJMP,XQNO,XQOPQT,XQTT,XQUIT,XQUR,Y
+26 QUIT
End DoDot:1
+27 IF '$DATA(XQUIT)
QUIT
+28 ;
+29 ;
RESET ;Reset the stack to what it should be
+1 SET XQY=+XQSV
SET XQDIC=$PIECE(XQSV,U,2)
SET XQY0=$PIECE(XQSV,U,3,99)
+2 SET XQT1=$SELECT($DATA(XQTT):XQTT,1:^XUTL("XQ",$JOB,"T"))
+3 ;
+4 ;Regular "^" jumps
+5 ;Remove the new stuff we have put on the stack.
+6 ;
+7 Begin DoDot:1
+8 ;W " ==> ^XQUIT"
SET %=^XUTL("XQ",$JOB,XQT1)
IF $PIECE(%,U,18)
IF $DATA(^DIC(19,+%,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+9 IF $DATA(XQONSTK)
IF $LENGTH(XQONSTK)
FOR XQI=1:1
SET %=$PIECE(XQONSTK,U,XQI)
IF %=""
QUIT
DO POP^XQ72(%)
+10 QUIT
End DoDot:1
+11 ;.;Restore the old stack as it was.
+12 ;.F XQI=1:1:XQT S %=$G(XQOLDSTK(XQI)) Q:%="" D
+13 ;..Q:^XUTL("XQ",$J,XQI)=%
+14 ;..S ^XUTL("XQ",$J,XQI)=XQOLDSTK(XQI),XQTT=XQTT+1
+15 ;..Q
+16 ;.Q
+17 ;
+18 ;Reset the stack pointer
+19 ;We haven't been to POP^XQ72
IF '$DATA(XQTT)
SET XQTT=^XUTL("XQ",$JOB,"T")
+20 SET ^XUTL("XQ",$JOB,"T")=$SELECT(XQTT>1:XQTT,1:1)
+21 ;Reset Option Type
SET XQT=$PIECE(XQY0,U,4)
+22 ;
+23 KILL XQJMP,XQONSTK,XQOPQT,XQSVSTK,XQTT,XQUR,Y
+24 QUIT
+25 ;
+26 ;
RB ;Come here from ^XQ73 for Rubber Band jumps
+1 NEW %,XQOPQT,XQI,XQX
+2 ;Flag that tells us if XQUIT EXECUTABLE is executed (XQX=1)
SET XQX=0
+3 ;The option where XQUIT was born
SET XQOPQT=$SELECT($DATA(XQYY):XQYY,1:XQY)
+4 ;Stop if the application cleared the XQUIT
DO X
IF '$DATA(XQUIT)
QUIT
+5 ;Tell the user what's going on
IF 'XQX
DO MESS
+6 ;
+7 ;Unwind the jump
IF $DATA(^XUTL("XQ",$JOB,"RBX"))
Begin DoDot:1
+8 SET %=0
FOR
SET %=$ORDER(^XUTL("XQ",$JOB,"RBX",%))
IF %=""
QUIT
XECUTE ^(%)
+9 KILL ^XUTL("XQ",$JOB,"RBX"),XQRB
+10 QUIT
End DoDot:1
+11 ;
+12 ;Reload the option we came from, and execute it's header. Quit.
+13 IF ^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T"))=-1
SET (XQTT,^XUTL("XQ",$JOB,"T"))=$SELECT(^("T")>1:^("T")-1,1:1)
+14 ;F XQI=XQTT:-1:1 S %=^XUTL("XQ",$J,XQI) Q:%=-1 S (^XUTL("XQ",$J,"T"),XQTT)=$S(%>0:%,1:1)
+15 SET XQY=+XQSV
SET XQDIC=$PIECE(XQSV,U,2)
SET XQY0=$PIECE(XQSV,U,3,99)
+16 SET XQT=$PIECE(XQY0,U,4)
+17 IF $PIECE(XQY0,U,17)
IF $DATA(^DIC(19,XQY,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+18 QUIT
+19 ;
+20 ;
T ;Come here from XQT1+14 & 33 if a template finds XQUIT while executing
+1 DO X
+2 IF '$DATA(XQUIT)
QUIT
+3 ;I 'XQX D MESS
+4 QUIT
+5 ;
PM ;Come here from XQ12 if XQUIT is encounter at logon in a primary menu
+1 NEW XQOPQT,XQX
+2 SET XQX=0
+3 SET XQOPQT=XQY
+4 DO X
+5 IF '$DATA(XQUIT)
QUIT
+6 IF 'XQX
Begin DoDot:1
+7 IF $DATA(^DIC(19,+XQY,21))
IF $PIECE(^(21,0),U,3)>0
DO DISPLAY^XQUTL
+8 IF '$TEST
Begin DoDot:2
+9 WRITE !!," **> Sorry, access to your primary menu has been denied by the application.",!?6,"An XQUIT was encountered in the Entry Action code.",!?6,"Please see your computer person."
+10 DO HOLD^XQUTL
+11 QUIT
End DoDot:2
+12 QUIT
End DoDot:1
+13 QUIT
+14 ;
+15 ;
+16 ; ***** Subroutines ****
+17 ;
MESS ;Tell the user what's going on unless we executed XQUIT EXECUTABLE field
+1 IF 'XQX
Begin DoDot:1
+2 IF '$DATA(XQNO)
SET XQNO=$PIECE(XQY0,U,2)
+3 ;
+4 IF $DATA(^DIC(19,XQOPQT,21))
IF $PIECE(^(21,0),U,3)>0
DO DISPLAY^XQUTL
+5 IF '$TEST
Begin DoDot:2
+6 WRITE !!," **> Sorry, access to this option has been denied by the application.",!!?7,"The variable XQUIT was encountered at the option",!?7,"'",XQNO,"'.",!?7,"You are being returned to:",!?7,"'",$PIECE(XQSV,U,4),"'",!
+7 DO HOLD^XQUTL
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
X ;If there is something in the XQUIT EXECUTABLE field, execute it.
+1 IF '$DATA(XQOPQT)
SET XQOPQT=XQY
+2 IF $DATA(^DIC(19,XQOPQT,22))
IF $LENGTH(^(22))
XECUTE ^(22)
SET XQX=1
+3 QUIT
