source: FOIAVistA/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQSMD3.m@ 1800

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

initial load of FOIAVistA 6/30/08 version
File size: 3.4 KB
Line 
1XQSMD3 ; SEA/MJM - Secure MenuMan Delegation utilities; 5/3/88 3:34 PM ;06/01/95 12:03
2 ;;8.0;KERNEL;**64**;Jul 10, 1995
3INIT S U="^",XQNGO=1,XQLEV="" S (XQDOP,XQDEL,XQPRO)=0 S:DUZ(0)="@"!($D(^XUSEC("XUMGR",DUZ))) XQPRO=1
4 I $S('$D(IOM):1,IOM=0:1,'$D(IOSL):1,'$L(IOSL):1,'$D(IOF):1,'$L(IOF):1,'$D(IO):1,1:0) S IOP="HOME" D ^%ZIS I POP W !!,"*** DEVICE ERROR ***",!,?5,"-exiting-" G OUT
5 S:'$D(DTIME)#2 DTIME=60
6 S %DT="",X="T" D ^%DT S XQDT=Y X ^DD("DD") S XQDATE=Y K %DT
7 S DIC=200,DIC(0)="FMNZ",X="`"_DUZ D ^DIC K DIC G:+Y<0 OUT S XQMGR=$P(Y(0,0),",",2)_" "_$P(Y(0,0),",",1)
8 S:XQPRO XQLEV=0 S:'$L(XQLEV)&($D(^VA(200,DUZ,19))#2) XQLEV=$P(^(19),U,3) W:'$L(XQLEV) !,"Level problem. No action permitted." G:'$L(XQLEV) OUT
9 ;
10USER1 ;Find the user who's delegated options will be transfered.
11 R !!,"Please enter the user currently holding the options :",XQ:DTIME S:'$T XQ=U G:XQ=U OUT I '$L(XQ)!(XQ="?") W !!,"Enter delegate's name,'^' to quit,'??' for User list, or '???' for help.",! G USER1
12 I XQ="??" S X="?",DIC=200,DIC(0)="Q" D ^DIC K DIC G USER1
13 I XQ="???" S XQH="XQSMD-REPLICATE" D EN^XQH G USER1
14 S X=XQ,DIC(0)="QMENZ",DIC=200 D ^DIC I +Y<1 W !!,"Not a know user. Try again or enter a '^' to quit." G USER1
15 I '$D(^VA(200,+Y,19.5,0))!($O(^(0))="") W !!,Y(0,0)," has not been delegated any menu options to transfer." G USER1
16 S XQPERX="^VA(200,"_+Y_",19.5,",XQU1=$P(Y(0,0),",",2)_" "_$P(Y(0,0),",",1),XQU1Y=+Y
17 S XQU1L=$P(^VA(200,+XQU1Y,19),U,3) I XQLEV>XQU1L W !!,"You may not, in this case, remove the options of ",XQU1 S XQDEL=0 G USER2
18 ;
19RPLC W !!,"Should ALL delegated options be removed from ",XQU1,!," after they have been transferred? N// " R XQ:DTIME S:'$T XQ=U G:XQ=U OUT S:'$L(XQ) XQ="N" I XQ="?" W !!,"Please enter 'Y' or 'N', '^' to quit, or '??' for help.",! G RPLC
20 I XQ="??" S XQH="XQSMD-REMOVE" D EN^XQH G RPLC
21 I "YyNn"'[XQ W !,"Please answer 'Y' or 'N' " G RPLC
22 S:XQ["Y"!(XQ["y") XQDEL=1
23 ;
24USER2 ;Get the name of the person to whom these options will be transfered
25 W !!,"Please enter the user who will get the same options as ",XQU1,!," now has: " R XQ:DTIME S:'$T XQ=U G:XQ=U OUT I XQ="?"!('$L(XQ)) W !!,"Enter User's name,'^' to quit,'??' for User list, or '???'for help.",! G USER2
26 I XQ="??" S DIC=200,X="?",DIC(0)="Q" D ^DIC K DIC G USER2
27 I XQ="???" S XQH="XQSMD-REPLACEMENT" D EN^XQH G USER2
28 S X=XQ,DIC=200,DIC(0)="EFMQZ" D ^DIC I +Y<1 W !!,"Sorry, this person is not in the User File. Try again or enter '^' to quit." G USER2
29 I $D(^VA(200,+Y,0)),'$L($P(^(.1),U,2)) W !!,"Sorry, this person is not a current user. Try again or enter '^' to quit." G USER2
30 S XQHOLD(+Y)=Y(0,0),XQU2=$P(Y(0,0),",",2)_" "_$P(Y(0,0),",",1)
31 I +XQU1Y=+Y W !!,"Sorry, this is illogical: it's the same person!" G USER2
32 I +Y=+DUZ W !!,"Sorry, you can't be your own delegate." G OUT
33 ;
34ASK ;See if we all understand eachother.
35 W !!!,"You want to assign the options currently held by ",XQU1,!,?5,"to ",XQU2
36 W:XQDEL " and remove them from ",XQU1
37 W !!,"Is this correct? Y/N " R XQ:DTIME S:'$T XQ=U G:XQ=U OUT G:XQ["N"!(XQ["n") INIT S XQH="XQSMD-OK" I XQ["?" D EN^XQH G ASK
38 I XQ'["Y"&(XQ'["y") W !!,*7,"Please answer 'Y' or 'N'." G ASK
39 I XQDEL W !!,"Request to remove delegated options from ",XQU1," will be queued. "
40 ;
41 G ^XQSMD31
42 ;
43OUT K DIC,DIK,DA,DISYS,DINUM,POP,XQ,XQD,XQH,XQI,XQJ,XQK,XQL,XQM,XQN,XQT,XQON,XQON0,XQAL,XQDATE,XQDEL,XQDT,XQDUZ,XQLEV,XQLK,XQMG,XQMGR,XQNAM,XQNGO,XQUF,XQPRO,XQSTART,XQEND,XQHOLD,XQKEY,X,Y,XY,%,^TMP($J),XQDOP,C
44 Q
Note: See TracBrowser for help on using the repository browser.