XQ ; SEA/MJM - Menu driver (Part 1) ;01/10/13 13:41
;;8.0;KERNEL;**9,46,94,103,157,570,593,614**;Jul 10, 1995;Build 11
;Per VHA Directive 2004-038, this routine should not be modified
D LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
D INIT^XQ12 Q:'$D(XQY)
I $D(XQUR),$E(XQUR,1,2)="^^" S XQRB=1,XQJS=4
I '$D(XQJS),$D(XQUR),XQUR'="",XQUR'["[" S:XQUR'[U XQUR=U_XQUR K ^VA(200,DUZ,202.1) S XQJS=0 D ^XQTOC
I $D(XQUR),XQUR["[" K ^VA(200,DUZ,202.1) S XQJS=3,^XUTL("XQ",$J,"T")=1
I $D(^VA(200,DUZ,202.1)),$L($P(^(202.1),U)) S XQJS=1 S %=+^(202.1) S XQUR=$G(^DIC(19,%,"U")) I XQUR]"" D ^XQTOC
M I '$D(XQVOL) S XQVOL=$G(^XUTL("XQ",$J,"XQVOL")) I '$L(XQVOL) D GETENV^%ZOSV S XQVOL=$P(Y,U,2)
I $G(^%ZIS(14.5,"LOGON",XQVOL)) S XQNOLOG="" G H^XUS
S:$S('$D(XQY0):1,'$L(XQY0):1,1:0) XQY0=^DIC(19,XQY,0) S XQT=$P(XQY0,U,4) G:XQT="" M3 K:'$D(XQJS) XQUR K X,XQNOGO,XQR,XQUIT,XQUEFLG ;,XQSV
I $D(XQAUDIT),XQAUDIT D LOGOPT^XQ12
I $G(XQY)>0 D CHKQUE^XQ92 I XQUEFLG S XQNOGO=""
;
;Execute the Entry Action and look for XQUIT
D:'$D(XQM3)&("LOQX"'[XQT) LO K XQM3 I $D(XQUIT) D
.S XQUIT=0
.D ^XQUIT
.Q
;
G:$D(XQUR) ASK1 ;Jump start or continue
I '$D(XQUIT),XQT'="A",$P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
D:$D(XQXFLG)[0 ABT^XQ12
D:$P(XQY0,U)]"" LOGRSRC^%ZOSV($P(XQY0,U),0,1)
I XQT'="M" W:'^XUTL("XQ",$J,"T") !,$P(XQY0,U,2) W:$D(DUZ("SAV")) !,"Not when testing another's menus." S %=^XUTL("XQ",$J,"T"),^("T")=%+1,^(%+1)=XQY_XQPSM_U_XQY0 G M3:XQT'?1U!$D(DUZ("SAV"))
I XQT'="M" D:'$D(XQXFLG) ABT^XQ12 D:+XQXFLG ABLOG^XQ12 K %,X,XQTT G @(XQT_"^XQ1")
M1 ;
D LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
Q:XQY<1!'$D(^XUTL("XQ",$J,"T")) D:'$D(XQXFLG) ABT^XQ12
D:'$D(XQABOLD)&(+XQXFLG) ABLOG^XQ12 K XQABOLD W ! S XQUR=0,XQTT=^XUTL("XQ",$J,"T"),XQDIC=XQY S XQAA="Select "_$S($D(DUZ("SAV")):$P(DUZ("SAV"),U,3)_"'s ",1:"")_$P(XQY0,U,2)
S XQAA=XQAA_$G(DUZ("TEST"))_" Option: " S:$D(XQMM("B")) XQAA=XQAA_XQMM("B")_"//"
S:$S('XQTT:1,1:+$P(^XUTL("XQ",$J,XQTT),U,1)'=XQY) ^("T")=XQTT+1,^(XQTT+1)=XQY_XQPSM_U_XQY0 I $D(DUZ("AUTO")),DUZ("AUTO"),'$D(XQMM("J")),'$D(XQMM("N")) G EN^XQ2
K:'$D(XQMM("J")) XQMM("N")
M2 ;
I '$D(XQMMF),$D(XQMM("J")) G ^XQ74
Q:$D(XQALEXIT)&'$D(XQALMENU) K XQMMF I $D(XQMM("A")) S XQAA=XQMM("A") K XQMM("A") I $D(XQMM("B")),$L(XQMM("B")) S XQAA=XQAA_XQMM("B")_"//"
D DISPLAY^XQALERT,CHK^XM
S:'$D(DTIME) DTIME=60
;
ASK ;Get user's response in XQUR
W !,XQAA R XQUR:DTIME I '$T Q:$D(XQALEXIT) W $C(7)," Timed out...." G CON^XQTOC
I $D(XQALEXIT),XQUR=""!(XQUR["^") Q
;
ASK1 D SETSV ;Set XQSV to remember where we started from (XQY^XQDIC^XQY0)
K XQUIT
I XQUR="*",$D(DUZ("SAV")) G TESTN^XUS91
I $D(XQJS),XQJS,XQJS'>2 D SET^XQTOC G JUMP^XQ72 ;Continue, 3=[LOGIN
I XQUR["[" G:'$D(DUZ("SAV")) ^XQT W !,"Not when testing another's menus!" S %=^XUTL("XQ",$J,"T")+1,^("T")=%,^(%)=XQY_XQPSM_U_XQY0 G M3
I XQUR="" S:$D(XQMM("B")) XQUR=XQMM("B") K XQMM("B") G:$L(XQUR) D S XQABOLD=1 G M3:^XUTL("XQ",$J,"T")>1,XPRMP^XQ12
I XQUR=U G M3
I $E(XQUR)=$C(34),$L(XQUR)>1 S XQUR=$P(XQUR,$C(34),2) D P^XQ75 G:XQY'>0 NOFIND K XQAA S XQY=+XQY,XQCH=XQUR G JUMP^XQ72
D I XQUR["^^" G:XQUR="^^" R^XQ73 S XQRB=1 S XQUR=$P(XQUR,U,2,99)
;"^^" is GO HOME, return to the Primary Menu, "^^x" is a rubber band
I XQUR[U S XQUR=$P(XQUR,U,2) G:'$L(XQUR) NOFIND D S^XQ75 G D:'XQY,NOFIND:XQY<0 K XQAA S XQY=+XQY,XQCH=XQUR G:$D(XQRB) ^XQ73 G JUMP^XQ72
D0 G:XQUR'?1"?"1AN.ANP D1 D OPT^XQHLP G ASK
D1 G EN^XQ2:XQUR?."?"!(XQUR'?.ANP) D DIC^XQ71 G:'XQY D S:XQY>0 XQPSM=$S(XQPSM=("U"_DUZ):XQPSM_",P"_XQDIC,XQPSM[",":XQPSM,XQDIC>0:XQPSM,1:"P"_XQDIC)
I XQY=-1,$O(^VA(200,DUZ,203,0))>0 S XQDIC="U"_DUZ D DIC^XQ71 G:'XQY D S:XQY>0 XQPSM="U"_DUZ_",P"_XQY
M0 I XQY=-1 S XQDIC=$O(^DIC(19,"B","XUCOMMAND",0)) S:XQDIC="" XQDIC=-1 D DIC^XQ71 G:'XQY D S:XQY>0 XQPSM="PXU" I XQY=-1 G M3:XQUR="HALT",NOFIND
G:XQY=-2 NOFIND K XQAA S XQY=+XQY,XQCH=XQUR G M
;
NOFIND ;Could not find the option requested, go back and try again
W:XQY=-1 " ??" S %=^XUTL("XQ",$J,^XUTL("XQ",$J,"T")),XQY0=$P(%,U,2,999),XQY=+$P(%,U,1) K XQJS,XQR G M1
;
M3 I $P(XQY0,U,15),$D(^DIC(19,+XQY,15)),$L(^(15)) X ^(15) ;W " ==> XQ+47"
S %=^XUTL("XQ",$J,"T")-1,^("T")=% G H^XUS:(%'>0) S %=^XUTL("XQ",$J,%),XQY0=$P(%,U,2,999),XQPSM=$P(%,U,1),XQY=+XQPSM,XQPSM=$P(XQPSM,XQY,2,99),XQM3="" I +XQY<0 D RBX^XQ73
G M
;
LO I $P(XQY0,U,4)'="A",$P(XQY0,U,14),$D(^DIC(19,+XQY,20)),$L(^(20)) X ^(20) ;W " ==> LO^XQ"
Q
;
SETSV ;Record where we are now for posterity in XQSV
; ZEXCEPT: XQSV,XQY - global variables recording current VistA menu
N %
S %=^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))
S XQSV=""
S $P(XQSV,U)=+%
S $P(XQSV,U,2)=$S($P(%,U)["PXU":$O(^DIC(19,"B","XUCOMMAND",0)),1:$P($P(%,U),"P",2)) I $P(XQSV,U,2)="" S $P(XQSV,U,2)=XQY
S $P(XQSV,U,3)=$P(%,U,2,99)
Q
;
PRIO ;This subroutine is no longer used. Kernel no longer resets priority.
;S Y=10 X:$D(^%ZOSF("PRIINQ")) ^("PRIINQ") S ^XUTL("XQ",$J,"P")=Y,X=$P(XQY0,U,8) X ^%ZOSF("PRIORITY")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ 4974 printed Jan 18, 2025@03:05:49 Page 2
XQ ; SEA/MJM - Menu driver (Part 1) ;01/10/13 13:41
+1 ;;8.0;KERNEL;**9,46,94,103,157,570,593,614**;Jul 10, 1995;Build 11
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 DO LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
+4 DO INIT^XQ12
if '$DATA(XQY)
QUIT
+5 IF $DATA(XQUR)
IF $EXTRACT(XQUR,1,2)="^^"
SET XQRB=1
SET XQJS=4
+6 IF '$DATA(XQJS)
IF $DATA(XQUR)
IF XQUR'=""
IF XQUR'["["
if XQUR'[U
SET XQUR=U_XQUR
KILL ^VA(200,DUZ,202.1)
SET XQJS=0
DO ^XQTOC
+7 IF $DATA(XQUR)
IF XQUR["["
KILL ^VA(200,DUZ,202.1)
SET XQJS=3
SET ^XUTL("XQ",$JOB,"T")=1
+8 IF $DATA(^VA(200,DUZ,202.1))
IF $LENGTH($PIECE(^(202.1),U))
SET XQJS=1
SET %=+^(202.1)
SET XQUR=$GET(^DIC(19,%,"U"))
IF XQUR]""
DO ^XQTOC
M IF '$DATA(XQVOL)
SET XQVOL=$GET(^XUTL("XQ",$JOB,"XQVOL"))
IF '$LENGTH(XQVOL)
DO GETENV^%ZOSV
SET XQVOL=$PIECE(Y,U,2)
+1 IF $GET(^%ZIS(14.5,"LOGON",XQVOL))
SET XQNOLOG=""
GOTO H^XUS
+2 ;,XQSV
if $SELECT('$DATA(XQY0)
SET XQY0=^DIC(19,XQY,0)
SET XQT=$PIECE(XQY0,U,4)
if XQT=""
GOTO M3
if '$DATA(XQJS)
KILL XQUR
KILL X,XQNOGO,XQR,XQUIT,XQUEFLG
+3 IF $DATA(XQAUDIT)
IF XQAUDIT
DO LOGOPT^XQ12
+4 IF $GET(XQY)>0
DO CHKQUE^XQ92
IF XQUEFLG
SET XQNOGO=""
+5 ;
+6 ;Execute the Entry Action and look for XQUIT
+7 if '$DATA(XQM3)&("LOQX"'[XQT)
DO LO
KILL XQM3
IF $DATA(XQUIT)
Begin DoDot:1
+8 SET XQUIT=0
+9 DO ^XQUIT
+10 QUIT
End DoDot:1
+11 ;
+12 ;Jump start or continue
if $DATA(XQUR)
GOTO ASK1
+13 IF '$DATA(XQUIT)
IF XQT'="A"
IF $PIECE(XQY0,U,17)
IF $DATA(^DIC(19,XQY,26))
IF $LENGTH(^(26))
XECUTE ^(26)
+14 if $DATA(XQXFLG)[0
DO ABT^XQ12
+15 if $PIECE(XQY0,U)]""
DO LOGRSRC^%ZOSV($PIECE(XQY0,U),0,1)
+16 IF XQT'="M"
if '^XUTL("XQ",$JOB,"T")
WRITE !,$PIECE(XQY0,U,2)
if $DATA(DUZ("SAV"))
WRITE !,"Not when testing another's menus."
SET %=^XUTL("XQ",$JOB,"T")
SET ^("T")=%+1
SET ^(%+1)=XQY_XQPSM_U_XQY0
if XQT'?1U!$DATA(DUZ("SAV"))
GOTO M3
+17 IF XQT'="M"
if '$DATA(XQXFLG)
DO ABT^XQ12
if +XQXFLG
DO ABLOG^XQ12
KILL %,X,XQTT
GOTO @(XQT_"^XQ1")
M1 ;
+1 DO LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
+2 if XQY<1!'$DATA(^XUTL("XQ",$JOB,"T"))
QUIT
if '$DATA(XQXFLG)
DO ABT^XQ12
+3 if '$DATA(XQABOLD)&(+XQXFLG)
DO ABLOG^XQ12
KILL XQABOLD
WRITE !
SET XQUR=0
SET XQTT=^XUTL("XQ",$JOB,"T")
SET XQDIC=XQY
SET XQAA="Select "_$SELECT($DATA(DUZ("SAV")):$PIECE(DUZ("SAV"),U,3)_"'s ",1:"")_$PIECE(XQY0,U,2)
+4 SET XQAA=XQAA_$GET(DUZ("TEST"))_" Option: "
if $DATA(XQMM("B"))
SET XQAA=XQAA_XQMM("B")_"//"
+5 if $SELECT('XQTT
SET ^("T")=XQTT+1
SET ^(XQTT+1)=XQY_XQPSM_U_XQY0
IF $DATA(DUZ("AUTO"))
IF DUZ("AUTO")
IF '$DATA(XQMM("J"))
IF '$DATA(XQMM("N"))
GOTO EN^XQ2
+6 if '$DATA(XQMM("J"))
KILL XQMM("N")
M2 ;
+1 IF '$DATA(XQMMF)
IF $DATA(XQMM("J"))
GOTO ^XQ74
+2 if $DATA(XQALEXIT)&'$DATA(XQALMENU)
QUIT
KILL XQMMF
IF $DATA(XQMM("A"))
SET XQAA=XQMM("A")
KILL XQMM("A")
IF $DATA(XQMM("B"))
IF $LENGTH(XQMM("B"))
SET XQAA=XQAA_XQMM("B")_"//"
+3 DO DISPLAY^XQALERT
DO CHK^XM
+4 if '$DATA(DTIME)
SET DTIME=60
+5 ;
ASK ;Get user's response in XQUR
+1 WRITE !,XQAA
READ XQUR:DTIME
IF '$TEST
if $DATA(XQALEXIT)
QUIT
WRITE $CHAR(7)," Timed out...."
GOTO CON^XQTOC
+2 IF $DATA(XQALEXIT)
IF XQUR=""!(XQUR["^")
QUIT
+3 ;
ASK1 ;Set XQSV to remember where we started from (XQY^XQDIC^XQY0)
DO SETSV
+1 KILL XQUIT
+2 IF XQUR="*"
IF $DATA(DUZ("SAV"))
GOTO TESTN^XUS91
+3 ;Continue, 3=[LOGIN
IF $DATA(XQJS)
IF XQJS
IF XQJS'>2
DO SET^XQTOC
GOTO JUMP^XQ72
+4 IF XQUR["["
if '$DATA(DUZ("SAV"))
GOTO ^XQT
WRITE !,"Not when testing another's menus!"
SET %=^XUTL("XQ",$JOB,"T")+1
SET ^("T")=%
SET ^(%)=XQY_XQPSM_U_XQY0
GOTO M3
+5 IF XQUR=""
if $DATA(XQMM("B"))
SET XQUR=XQMM("B")
KILL XQMM("B")
if $LENGTH(XQUR)
GOTO D
SET XQABOLD=1
if ^XUTL("XQ",$JOB,"T")>1
GOTO M3
GOTO XPRMP^XQ12
+6 IF XQUR=U
GOTO M3
+7 IF $EXTRACT(XQUR)=$CHAR(34)
IF $LENGTH(XQUR)>1
SET XQUR=$PIECE(XQUR,$CHAR(34),2)
DO P^XQ75
if XQY'>0
GOTO NOFIND
KILL XQAA
SET XQY=+XQY
SET XQCH=XQUR
GOTO JUMP^XQ72
D IF XQUR["^^"
if XQUR="^^"
GOTO R^XQ73
SET XQRB=1
SET XQUR=$PIECE(XQUR,U,2,99)
+1 ;"^^" is GO HOME, return to the Primary Menu, "^^x" is a rubber band
+2 IF XQUR[U
SET XQUR=$PIECE(XQUR,U,2)
if '$LENGTH(XQUR)
GOTO NOFIND
DO S^XQ75
if 'XQY
GOTO D
if XQY<0
GOTO NOFIND
KILL XQAA
SET XQY=+XQY
SET XQCH=XQUR
if $DATA(XQRB)
GOTO ^XQ73
GOTO JUMP^XQ72
D0 if XQUR'?1"?"1AN.ANP
GOTO D1
DO OPT^XQHLP
GOTO ASK
D1 if XQUR?."?"!(XQUR'?.ANP)
GOTO EN^XQ2
DO DIC^XQ71
if 'XQY
GOTO D
if XQY>0
SET XQPSM=$SELECT(XQPSM=("U"_DUZ):XQPSM_",P"_XQDIC,XQPSM[",":XQPSM,XQDIC>0:XQPSM,1:"P"_XQDIC)
+1 IF XQY=-1
IF $ORDER(^VA(200,DUZ,203,0))>0
SET XQDIC="U"_DUZ
DO DIC^XQ71
if 'XQY
GOTO D
if XQY>0
SET XQPSM="U"_DUZ_",P"_XQY
M0 IF XQY=-1
SET XQDIC=$ORDER(^DIC(19,"B","XUCOMMAND",0))
if XQDIC=""
SET XQDIC=-1
DO DIC^XQ71
if 'XQY
GOTO D
if XQY>0
SET XQPSM="PXU"
IF XQY=-1
if XQUR="HALT"
GOTO M3
GOTO NOFIND
+1 if XQY=-2
GOTO NOFIND
KILL XQAA
SET XQY=+XQY
SET XQCH=XQUR
GOTO M
+2 ;
NOFIND ;Could not find the option requested, go back and try again
+1 if XQY=-1
WRITE " ??"
SET %=^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T"))
SET XQY0=$PIECE(%,U,2,999)
SET XQY=+$PIECE(%,U,1)
KILL XQJS,XQR
GOTO M1
+2 ;
M3 ;W " ==> XQ+47"
IF $PIECE(XQY0,U,15)
IF $DATA(^DIC(19,+XQY,15))
IF $LENGTH(^(15))
XECUTE ^(15)
+1 SET %=^XUTL("XQ",$JOB,"T")-1
SET ^("T")=%
if (%'>0)
GOTO H^XUS
SET %=^XUTL("XQ",$JOB,%)
SET XQY0=$PIECE(%,U,2,999)
SET XQPSM=$PIECE(%,U,1)
SET XQY=+XQPSM
SET XQPSM=$PIECE(XQPSM,XQY,2,99)
SET XQM3=""
IF +XQY<0
DO RBX^XQ73
+2 GOTO M
+3 ;
LO ;W " ==> LO^XQ"
IF $PIECE(XQY0,U,4)'="A"
IF $PIECE(XQY0,U,14)
IF $DATA(^DIC(19,+XQY,20))
IF $LENGTH(^(20))
XECUTE ^(20)
+1 QUIT
+2 ;
SETSV ;Record where we are now for posterity in XQSV
+1 ; ZEXCEPT: XQSV,XQY - global variables recording current VistA menu
+2 NEW %
+3 SET %=^XUTL("XQ",$JOB,^XUTL("XQ",$JOB,"T"))
+4 SET XQSV=""
+5 SET $PIECE(XQSV,U)=+%
+6 SET $PIECE(XQSV,U,2)=$SELECT($PIECE(%,U)["PXU":$ORDER(^DIC(19,"B","XUCOMMAND",0)),1:$PIECE($PIECE(%,U),"P",2))
IF $PIECE(XQSV,U,2)=""
SET $PIECE(XQSV,U,2)=XQY
+7 SET $PIECE(XQSV,U,3)=$PIECE(%,U,2,99)
+8 QUIT
+9 ;
PRIO ;This subroutine is no longer used. Kernel no longer resets priority.
+1 ;S Y=10 X:$D(^%ZOSF("PRIINQ")) ^("PRIINQ") S ^XUTL("XQ",$J,"P")=Y,X=$P(XQY0,U,8) X ^%ZOSF("PRIORITY")
+2 QUIT
