source: FOIAVistA/tag/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQUIT.m@ 1540

XQUIT ;SEA/LUKE - Jump Utilities (Part II)  ;06/23/98  11:28
 ;;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