- 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 Feb 18, 2025@23:31:03 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