- XQSTCK ;Luke/SEA - Stack utilities ;3/11/94 13:50 [ 04/02/2003 8:29 AM ]
- ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
- ;;8.0;KERNEL;;Jul 10, 1995
- PUSH(XQY,XQPSM,XQY0) ;Add an option to the stack
- S XQSTPT=^XUTL("XQ",$J,"T")
- S XQSTPT=XQSTPT+1
- S ^XUTL("XQ",$J,XQSTPT)=XQY_XQPSM_U_XQY0,^("T")=XQSTPT
- I $P(XQY0,U,14),$D(^DIC(19,XQY,20)),$L(^(20)) X ^(20)
- I $D(XQUIT) S TITLE="Menu Error",MESS="'XQUIT' Encountered at Option "_$P(XQY0,U,2)_" ["_$P(XQY0,U)_"]" D POP^XQGP(MESS,TITLE),P1 K XQUIT Q
- I $P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
- Q
- ;
- POP ;Pop one level on the stack
- I $P(XQY0,U,15),$D(^DIC(19,XQY,15)),$L(^(15)) X ^(15)
- P1 S XQSTPT=^XUTL("XQ",$J,"T")
- S XQSTPT=XQSTPT-1
- I XQSTPT=0 S XQSTPT=1
- S %=^XUTL("XQ",$J,XQSTPT),XQY=+%,XQY0=$P(%,XQPSM,2,99)
- I '$D(XQUIT),$P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
- S ^XUTL("XQ",$J,"T")=XQSTPT
- Q
- ;
- XACT ;Execute Exit Actions and Headers: input X=option number, no output.
- Q:'$D(^DIC(19,+XQEX,0))
- I $D(^DIC(19,+XQEX,15)),$L(^(15)) X ^(15)
- I $D(^DIC(19,+XQEX,26)),$L(^(26)) X ^(26)
- Q
- ;
- PM ;Put primary menu in stack position 1
- D GET I $D(XQFAIL) G OUT
- ;
- S ^XUTL("XQ",$J,1)=XQPM_XQPSM_U_XQY0
- S (XQY,XQDIC)=XQPM,XQPSM="P"_XQPM
- S ^XUTL("XQ",$J,"T")=1
- ;S XQSTPT=1
- G OUT
- Q
- ;
- PM1 ;Put primary menu in some other stack position
- ;called by XQGUI to start Option Selection Window
- D GET I $D(XQFAIL) G OUT
- ;
- S XQTT=^XUTL("XQ",$J,"T")
- F XQI=1:1:XQTT I +^XUTL("XQ",$J,XQI)=XQPM S ^XUTL("XQ",$J,"T")=XQI,XQI=0 Q
- G:XQI=0 OUT
- ;
- I XQI>0,$P(^XUTL("XQ",$J,XQTT),U,3)'="XQGUI" S XQTT=XQTT+1
- S ^XUTL("XQ",$J,XQTT)=XQPM_XQPSM_U_XQY0
- S ^XUTL("XQ",$J,"T")=XQTT
- G OUT
- Q
- ;
- GET ;Get the Primary Menu Option and set XQY0,XQDIC,XQPSM
- I '$D(DUZ)#2 D NODUZ S XQFAIL="" Q
- S XQPM=$G(^VA(200,DUZ,201)),XQPM=+XQPM I XQPM'>0 D NOPM S XQFAIL="" Q
- S (XQY,XQDIC)=XQPM,XQPSM="P"_XQPM
- ;
- S XQY0=$P(^XUTL("XQO","P"_XQPM,"^",XQPM),U,2,99)
- I '$L(XQY0) D NOXUTL S XQYO=$G(^XUTL("XQO","P"_XQPM,"^",XQPM))
- I '$L(XQY0) S XQY=XQPM D SET^XQCHK
- I XQY'>0 D FAIL S XQFAIL="" Q
- Q
- ;
- NOPM ;This user has no primary menu
- S XQER=" No primary menu "
- Q
- ;
- NODUZ ;There is no user connected with this process
- S XQER=" No user (DUZ) "
- Q
- ;
- NOXUTL ;No ^XUTL("XQO","P"_XQPM) on this system
- I $D(^XTMP("XQO","P"_XQMP)) M ^XUTL("XQO","P"_XQPM)=^XTMP("XQO","P"_XQPM)
- Q
- ;
- FAIL ;Absolute and utter failure
- S XQER=$S('$D(XQER):"",'$L(XQER):"",1:XQER)
- D ^XQDATE
- S ^XUTL("XQ",$J,XQNO)=" Failed: "_"^"_%Y_XQER
- Q
- ;
- OUT ;Exit point for all subroutines
- K %,%Y,XQER,XQI,XQPM,XQTT
- Q
- XQSTCK ;Luke/SEA - Stack utilities ;3/11/94 13:50 [ 04/02/2003 8:29 AM ]
- +1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007**;APR 1, 2003
- +2 ;;8.0;KERNEL;;Jul 10, 1995
- PUSH(XQY,XQPSM,XQY0) ;Add an option to the stack
- +1 SET XQSTPT=^XUTL("XQ",$JOB,"T")
- +2 SET XQSTPT=XQSTPT+1
- +3 SET ^XUTL("XQ",$JOB,XQSTPT)=XQY_XQPSM_U_XQY0
- SET ^("T")=XQSTPT
- +4 IF $PIECE(XQY0,U,14)
- IF $DATA(^DIC(19,XQY,20))
- IF $LENGTH(^(20))
- XECUTE ^(20)
- +5 IF $DATA(XQUIT)
- SET TITLE="Menu Error"
- SET MESS="'XQUIT' Encountered at Option "_$PIECE(XQY0,U,2)_" ["_$PIECE(XQY0,U)_"]"
- DO POP^XQGP(MESS,TITLE)
- DO P1
- KILL XQUIT
- QUIT
- +6 IF $PIECE(XQY0,U,17)
- IF $DATA(^DIC(19,XQY,26))
- IF $LENGTH(^(26))
- XECUTE ^(26)
- +7 QUIT
- +8 ;
- POP ;Pop one level on the stack
- +1 IF $PIECE(XQY0,U,15)
- IF $DATA(^DIC(19,XQY,15))
- IF $LENGTH(^(15))
- XECUTE ^(15)
- P1 SET XQSTPT=^XUTL("XQ",$JOB,"T")
- +1 SET XQSTPT=XQSTPT-1
- +2 IF XQSTPT=0
- SET XQSTPT=1
- +3 SET %=^XUTL("XQ",$JOB,XQSTPT)
- SET XQY=+%
- SET XQY0=$PIECE(%,XQPSM,2,99)
- +4 IF '$DATA(XQUIT)
- IF $PIECE(XQY0,U,17)
- IF $DATA(^DIC(19,XQY,26))
- IF $LENGTH(^(26))
- XECUTE ^(26)
- +5 SET ^XUTL("XQ",$JOB,"T")=XQSTPT
- +6 QUIT
- +7 ;
- XACT ;Execute Exit Actions and Headers: input X=option number, no output.
- +1 IF '$DATA(^DIC(19,+XQEX,0))
- QUIT
- +2 IF $DATA(^DIC(19,+XQEX,15))
- IF $LENGTH(^(15))
- XECUTE ^(15)
- +3 IF $DATA(^DIC(19,+XQEX,26))
- IF $LENGTH(^(26))
- XECUTE ^(26)
- +4 QUIT
- +5 ;
- PM ;Put primary menu in stack position 1
- +1 DO GET
- IF $DATA(XQFAIL)
- GOTO OUT
- +2 ;
- +3 SET ^XUTL("XQ",$JOB,1)=XQPM_XQPSM_U_XQY0
- +4 SET (XQY,XQDIC)=XQPM
- SET XQPSM="P"_XQPM
- +5 SET ^XUTL("XQ",$JOB,"T")=1
- +6 ;S XQSTPT=1
- +7 GOTO OUT
- +8 QUIT
- +9 ;
- PM1 ;Put primary menu in some other stack position
- +1 ;called by XQGUI to start Option Selection Window
- +2 DO GET
- IF $DATA(XQFAIL)
- GOTO OUT
- +3 ;
- +4 SET XQTT=^XUTL("XQ",$JOB,"T")
- +5 FOR XQI=1:1:XQTT
- IF +^XUTL("XQ",$JOB,XQI)=XQPM
- SET ^XUTL("XQ",$JOB,"T")=XQI
- SET XQI=0
- QUIT
- +6 IF XQI=0
- GOTO OUT
- +7 ;
- +8 IF XQI>0
- IF $PIECE(^XUTL("XQ",$JOB,XQTT),U,3)'="XQGUI"
- SET XQTT=XQTT+1
- +9 SET ^XUTL("XQ",$JOB,XQTT)=XQPM_XQPSM_U_XQY0
- +10 SET ^XUTL("XQ",$JOB,"T")=XQTT
- +11 GOTO OUT
- +12 QUIT
- +13 ;
- GET ;Get the Primary Menu Option and set XQY0,XQDIC,XQPSM
- +1 IF '$DATA(DUZ)#2
- DO NODUZ
- SET XQFAIL=""
- QUIT
- +2 SET XQPM=$GET(^VA(200,DUZ,201))
- SET XQPM=+XQPM
- IF XQPM'>0
- DO NOPM
- SET XQFAIL=""
- QUIT
- +3 SET (XQY,XQDIC)=XQPM
- SET XQPSM="P"_XQPM
- +4 ;
- +5 SET XQY0=$PIECE(^XUTL("XQO","P"_XQPM,"^",XQPM),U,2,99)
- +6 IF '$LENGTH(XQY0)
- DO NOXUTL
- SET XQYO=$GET(^XUTL("XQO","P"_XQPM,"^",XQPM))
- +7 IF '$LENGTH(XQY0)
- SET XQY=XQPM
- DO SET^XQCHK
- +8 IF XQY'>0
- DO FAIL
- SET XQFAIL=""
- QUIT
- +9 QUIT
- +10 ;
- NOPM ;This user has no primary menu
- +1 SET XQER=" No primary menu "
- +2 QUIT
- +3 ;
- NODUZ ;There is no user connected with this process
- +1 SET XQER=" No user (DUZ) "
- +2 QUIT
- +3 ;
- NOXUTL ;No ^XUTL("XQO","P"_XQPM) on this system
- +1 IF $DATA(^XTMP("XQO","P"_XQMP))
- MERGE ^XUTL("XQO","P"_XQPM)=^XTMP("XQO","P"_XQPM)
- +2 QUIT
- +3 ;
- FAIL ;Absolute and utter failure
- +1 SET XQER=$SELECT('$DATA(XQER):"",'$LENGTH(XQER):"",1:XQER)
- +2 DO ^XQDATE
- +3 SET ^XUTL("XQ",$JOB,XQNO)=" Failed: "_"^"_%Y_XQER
- +4 QUIT
- +5 ;
- OUT ;Exit point for all subroutines
- +1 KILL %,%Y,XQER,XQI,XQPM,XQTT
- +2 QUIT