source: WorldVistAEHR/trunk/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@ 701

Last change on this file since 701 was 613, checked in by George Lilly, 15 years ago

initial load of WorldVistAEHR

File size: 3.6 KB
Line 
1XQUIT ;SEA/LUKE - Jump Utilities (Part II) ;06/23/98 11:28
2 ;;8.0;KERNEL;**46,87**;Jul 10, 1995
3 ;XQUIT has been set in an entry action
4 ;
5 I $D(XQRB) D RB Q ;Rubber band target set the XQUIT
6 ;
7 N %,XQFLAG,XQI,XQJ,XQOP,XQOPQT,XQX
8 S XQX=0 ;Set to 1 if XQUIT EXECUTABLE field is executed
9 ;
10 S XQOPQT=$S($D(XQD):XQD,1:XQY) ;XQY if this is not a jump or jump is completed
11 ;
12 ;See if there is anything in the XQUIT XECUTABLE field
13 D X
14 Q:'$D(XQUIT) ;XQUIT cleared, we're done here
15 ;
16 I $D(ZTQUEUED) Q ;Tasked option, no messages allowed.
17 ;
18 ;Print the message unless the XQUIT EXECUTABLE field is filled in
19 I 'XQX D MESS
20 ;
21 ;Single step, no stack resetting is necessary
22 I $S('$D(XQJMP):0,XQJMP=1:0,(+XQSV=+^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))):1,1:0) D
23 .S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
24 .S XQT=$P(XQY0,U,4)
25 .K XQJMP,XQNO,XQOPQT,XQTT,XQUIT,XQUR,Y
26 .Q
27 Q:'$D(XQUIT)
28 ;
29 ;
30RESET ;Reset the stack to what it should be
31 S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
32 S XQT1=$S($D(XQTT):XQTT,1:^XUTL("XQ",$J,"T"))
33 ;
34 ;Regular "^" jumps
35 ;Remove the new stuff we have put on the stack.
36 ;
37 D
38 .S %=^XUTL("XQ",$J,XQT1) I $P(%,U,18),$D(^DIC(19,+%,26)),$L(^(26)) X ^(26) ;W " ==> ^XQUIT"
39 .I $D(XQONSTK),$L(XQONSTK) F XQI=1:1 S %=$P(XQONSTK,U,XQI) Q:%="" D POP^XQ72(%)
40 .Q
41 ;.;Restore the old stack as it was.
42 ;.F XQI=1:1:XQT S %=$G(XQOLDSTK(XQI)) Q:%="" D
43 ;..Q:^XUTL("XQ",$J,XQI)=%
44 ;..S ^XUTL("XQ",$J,XQI)=XQOLDSTK(XQI),XQTT=XQTT+1
45 ;..Q
46 ;.Q
47 ;
48 ;Reset the stack pointer
49 I '$D(XQTT) S XQTT=^XUTL("XQ",$J,"T") ;We haven't been to POP^XQ72
50 S ^XUTL("XQ",$J,"T")=$S(XQTT>1:XQTT,1:1)
51 S XQT=$P(XQY0,U,4) ;Reset Option Type
52 ;
53 K XQJMP,XQONSTK,XQOPQT,XQSVSTK,XQTT,XQUR,Y
54 Q
55 ;
56 ;
57RB ;Come here from ^XQ73 for Rubber Band jumps
58 N %,XQOPQT,XQI,XQX
59 S XQX=0 ;Flag that tells us if XQUIT EXECUTABLE is executed (XQX=1)
60 S XQOPQT=$S($D(XQYY):XQYY,1:XQY) ;The option where XQUIT was born
61 D X Q:'$D(XQUIT) ;Stop if the application cleared the XQUIT
62 D:'XQX MESS ;Tell the user what's going on
63 ;
64 I $D(^XUTL("XQ",$J,"RBX")) D ;Unwind the jump
65 .S %=0 F S %=$O(^XUTL("XQ",$J,"RBX",%)) Q:%="" X ^(%)
66 .K ^XUTL("XQ",$J,"RBX"),XQRB
67 .Q
68 ;
69 ;Reload the option we came from, and execute it's header. Quit.
70 I ^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))=-1 S (XQTT,^XUTL("XQ",$J,"T"))=$S(^("T")>1:^("T")-1,1:1)
71 ;F XQI=XQTT:-1:1 S %=^XUTL("XQ",$J,XQI) Q:%=-1 S (^XUTL("XQ",$J,"T"),XQTT)=$S(%>0:%,1:1)
72 S XQY=+XQSV,XQDIC=$P(XQSV,U,2),XQY0=$P(XQSV,U,3,99)
73 S XQT=$P(XQY0,U,4)
74 I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
75 Q
76 ;
77 ;
78T ;Come here from XQT1+14 & 33 if a template finds XQUIT while executing
79 D X
80 Q:'$D(XQUIT)
81 ;I 'XQX D MESS
82 Q
83 ;
84PM ;Come here from XQ12 if XQUIT is encounter at logon in a primary menu
85 N XQOPQT,XQX
86 S XQX=0
87 S XQOPQT=XQY
88 D X
89 Q:'$D(XQUIT)
90 I 'XQX D
91 .I $D(^DIC(19,+XQY,21)),$P(^(21,0),U,3)>0 D DISPLAY^XQUTL
92 .E D
93 ..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."
94 ..D HOLD^XQUTL
95 ..Q
96 .Q
97 Q
98 ;
99 ;
100 ; ***** Subroutines ****
101 ;
102MESS ;Tell the user what's going on unless we executed XQUIT EXECUTABLE field
103 I 'XQX D
104 .I '$D(XQNO) S XQNO=$P(XQY0,U,2)
105 .;
106 .I $D(^DIC(19,XQOPQT,21)),$P(^(21,0),U,3)>0 D DISPLAY^XQUTL
107 .E D
108 ..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),"'",!
109 ..D HOLD^XQUTL
110 ..Q
111 .Q
112 Q
113 ;
114X ;If there is something in the XQUIT EXECUTABLE field, execute it.
115 I '$D(XQOPQT) S XQOPQT=XQY
116 I $D(^DIC(19,XQOPQT,22)),$L(^(22)) X ^(22) S XQX=1
117 Q
Note: See TracBrowser for help on using the repository browser.