- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQUIT 3825 printed Feb 18, 2025@23:33:20 Page 2
- XQUIT ;SEA/LUKE - Jump Utilities (Part II) ;06/23/98 11:28
- +1 ;;8.0;KERNEL;**46,87**;Jul 10, 1995
- +2 ;XQUIT has been set in an entry action
- +3 ;
- +4 ;Rubber band target set the XQUIT
- IF $DATA(XQRB)
- DO RB
- QUIT
- +5 ;
- +6 NEW %,XQFLAG,XQI,XQJ,XQOP,XQOPQT,XQX
- +7 ;Set to 1 if XQUIT EXECUTABLE field is executed
- SET XQX=0
- +8 ;
- +9 ;XQY if this is not a jump or jump is completed
- SET XQOPQT=$SELECT($DATA(XQD):XQD,1:XQY)
- +10 ;
- +11 ;See if there is anything in the XQUIT XECUTABLE field
- +12 DO X
- +13 ;XQUIT cleared, we're done here
- if '$DATA(XQUIT)
- QUIT
- +14 ;
- +15 ;Tasked option, no messages allowed.
- IF $DATA(ZTQUEUED)
- QUIT
- +16 ;
- +17 ;Print the message unless the XQUIT EXECUTABLE field is filled in
- +18 IF 'XQX
- DO MESS
- +19 ;
- +20 ;Single step, no stack resetting is necessary
- +21 IF $SELECT('$DATA(XQJMP):0,XQJMP=1:0,(+XQSV=+^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T"))):1,1:0)
- Begin DoDot:1
- +22 SET XQY=+XQSV
- SET XQDIC=$PIECE(XQSV,U,2)
- SET XQY0=$PIECE(XQSV,U,3,99)
- +23 SET XQT=$PIECE(XQY0,U,4)
- +24 KILL XQJMP,XQNO,XQOPQT,XQTT,XQUIT,XQUR,Y
- +25 QUIT
- End DoDot:1
- +26 if '$DATA(XQUIT)
- QUIT
- +27 ;
- +28 ;
- 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