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/XQ.m@ 975

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

initial load of WorldVistAEHR

File size: 4.9 KB
Line 
1XQ ; SEA/MJM - Menu driver (Part 1) ;05/06/2002 10:21
2 ;;8.0;KERNEL;**9,46,94,103,157**;Jul 10, 1995
3 D LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
4 D INIT^XQ12 Q:'$D(XQY)
5 I $D(XQUR),$E(XQUR,1,2)="^^" S XQRB=1,XQJS=4
6 I '$D(XQJS),$D(XQUR),XQUR'="",XQUR'["[" S:XQUR'[U XQUR=U_XQUR K ^VA(200,DUZ,202.1) S XQJS=0 D ^XQTOC
7 I $D(XQUR),XQUR["[" K ^VA(200,DUZ,202.1) S XQJS=3,^XUTL("XQ",$J,"T")=1
8 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
9M I '$D(XQVOL) S XQVOL=$G(^XUTL("XQ",$J,"XQVOL")) I '$L(XQVOL) D GETENV^%ZOSV S XQVOL=$P(Y,U,2)
10 I $G(^%ZIS(14.5,"LOGON",XQVOL)) S XQNOLOG="" G H^XUS
11 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
12 I $D(XQAUDIT),XQAUDIT D LOGOPT^XQ12
13 I $P(XQY0,U,18) D CHKQUE^XQ92 I XQUEFLG S XQNOGO=""
14 ;
15 ;Execute the Entry Action and look for XQUIT
16 D:'$D(XQM3)&("LOQX"'[XQT) LO K XQM3 I $D(XQUIT) D
17 .S XQUIT=0
18 .D ^XQUIT
19 .Q
20 ;
21 G:$D(XQUR) ASK1 ;Jump start or continue
22 I '$D(XQUIT),XQT'="A",$P(XQY0,U,17),$D(^DIC(19,XQY,26)),$L(^(26)) X ^(26)
23 D:$D(XQXFLG)[0 ABT^XQ12 ;D:$P($G(XQXFLG),U,2) LOGRSRC^%ZOSV($P(XQY0,U))
24 D:$P(XQY0,U)]"" LOGRSRC^%ZOSV($P(XQY0,U),0,1)
25 ;A call to PRIO was removed from the following line D:$L($P(XQY0,U,8))
26 ;Since Kernel no longer resets priority from the Option File
27 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"))
28 I XQT'="M" D:'$D(XQXFLG) ABT^XQ12 D:+XQXFLG ABLOG^XQ12 K %,X,XQTT G @(XQT_"^XQ1")
29M1 ;
30 D LOGRSRC^%ZOSV("$XQ MENU DRIVER$",0,1)
31 Q:XQY<1!'$D(^XUTL("XQ",$J,"T")) D:'$D(XQXFLG) ABT^XQ12
32 D:'$D(XQABOLD)&(+XQXFLG) ABLOG^XQ12 K XQABOLD W ! S XQUR=0,XQTT=^XUTL("XQ",$J,"T"),XQDIC=XQY,XQAA="Select "_$S($D(DUZ("SAV")):$P(DUZ("SAV"),U,3)_"'s ",1:"")_$P(XQY0,U,2)_" Option: " S:$D(XQMM("B")) XQAA=XQAA_XQMM("B")_"//"
33 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
34 K:'$D(XQMM("J")) XQMM("N")
35M2 ;
36 I '$D(XQMMF),$D(XQMM("J")) G ^XQ74
37 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")_"//"
38 D DISPLAY^XQALERT,CHK^XM
39 S:'$D(DTIME) DTIME=60
40 ;
41ASK ;Get user's response in XQUR
42 W !,XQAA R XQUR:DTIME I '$T Q:$D(XQALEXIT) W $C(7)," Timed out...." G CON^XQTOC
43 I $D(XQALEXIT),XQUR=""!(XQUR["^") Q
44 ;
45ASK1 D SETSV ;Set XQSV to remember where we started from (XQY^XQDIC^XQY0)
46 K XQUIT
47 I XQUR="*",$D(DUZ("SAV")) G TESTN^XUS91
48 I $D(XQJS),XQJS,XQJS'>2 D SET^XQTOC G JUMP^XQ72 ;Continue, 3=[LOGIN
49 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
50 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
51 I XQUR=U G M3
52 ;$C(34) is ", which is a shortcut to XUCOMMAND
53 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
54 ;,XQY=-1 G:$L(XQUR) M0 S XQUR=$C(34)
55D I XQUR["^^" G:XQUR="^^" R^XQ73 S XQRB=1 S XQUR=$P(XQUR,U,2,99)
56 ;"^^" is GO HOME, return to the Primary Menu, "^^x" is a rubber band
57 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
58D0 G:XQUR'?1"?"1AN.ANP D1 D OPT^XQHLP G ASK
59D1 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)
60 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
61M0 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
62 G:XQY=-2 NOFIND K XQAA S XQY=+XQY,XQCH=XQUR G M
63 ;
64NOFIND ;Could not find the option requested, go back and try again
65 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
66 ;
67M3 I $P(XQY0,U,15),$D(^DIC(19,+XQY,15)),$L(^(15)) X ^(15) ;W " ==> XQ+47"
68 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
69 G M
70 ;
71LO I $P(XQY0,U,4)'="A",$P(XQY0,U,14),$D(^DIC(19,+XQY,20)),$L(^(20)) X ^(20) ;W " ==> LO^XQ"
72 ;I $D(^XUTL("XQ",$J,"P")) S X=^("P") K ^("P") X ^%ZOSF("PRIORITY")
73 Q
74 ;
75SETSV ;Record where we are now for posterity in XQSV
76 N %
77 S %=^XUTL("XQ",$J,^XUTL("XQ",$J,"T"))
78 S XQSV=""
79 S $P(XQSV,U)=+%
80 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
81 S $P(XQSV,U,3)=$P(%,U,2,99)
82 Q
83 ;
84PRIO ;This subroutine is no longer used. Kernel no longer resets priority.
85 ;S Y=10 X:$D(^%ZOSF("PRIINQ")) ^("PRIINQ") S ^XUTL("XQ",$J,"P")=Y,X=$P(XQY0,U,8) X ^%ZOSF("PRIORITY")
86 Q
Note: See TracBrowser for help on using the repository browser.