XQSMD3 ; SEA/MJM - Secure MenuMan Delegation utilities; 12/11/07
;;8.0;KERNEL;**64,475**;Jul 10, 1995;Build 8
INIT S U="^",XQNGO=1,XQLEV="" S (XQDOP,XQDEL,XQPRO)=0 S:DUZ(0)="@"!($D(^XUSEC("XUMGR",DUZ))) XQPRO=1
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
S:'$D(DTIME)#2 DTIME=60
S %DT="",X="T" D ^%DT S XQDT=Y X ^DD("DD") S XQDATE=Y K %DT
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)
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
;
USER1 ;Find the user who's delegated options will be transfered.
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
I XQ="??" S X="?",DIC=200,DIC(0)="Q" D ^DIC K DIC G USER1
I XQ="???" S XQH="XQSMD-REPLICATE" D EN^XQH G USER1
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
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
S XQPERX="^VA(200,"_+Y_",19.5,",XQU1=$P(Y(0,0),",",2)_" "_$P(Y(0,0),",",1),XQU1Y=+Y
S XQU1L=$P($G(^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
;
RPLC 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
I XQ="??" S XQH="XQSMD-REMOVE" D EN^XQH G RPLC
I "YyNn"'[XQ W !,"Please answer 'Y' or 'N' " G RPLC
S:XQ["Y"!(XQ["y") XQDEL=1
;
USER2 ;Get the name of the person to whom these options will be transfered
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
I XQ="??" S DIC=200,X="?",DIC(0)="Q" D ^DIC K DIC G USER2
I XQ="???" S XQH="XQSMD-REPLACEMENT" D EN^XQH G USER2
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
I $D(^VA(200,+Y,0)),'$L($P($G(^(.1)),U,2)) W !!,"Sorry, this person is not a current user. Try again or enter '^' to quit." G USER2
S XQHOLD(+Y)=Y(0,0),XQU2=$P(Y(0,0),",",2)_" "_$P(Y(0,0),",",1)
I +XQU1Y=+Y W !!,"Sorry, this is illogical: it's the same person!" G USER2
I +Y=+DUZ W !!,"Sorry, you can't be your own delegate." G OUT
;
ASK ;See if we all understand eachother.
W !!!,"You want to assign the options currently held by ",XQU1,!,?5,"to ",XQU2
W:XQDEL " and remove them from ",XQU1
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
I XQ'["Y"&(XQ'["y") W !!,*7,"Please answer 'Y' or 'N'." G ASK
I XQDEL W !!,"Request to remove delegated options from ",XQU1," will be queued. "
;
G ^XQSMD31
;
OUT 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
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQSMD3 3512 printed Dec 13, 2024@02:06:32 Page 2
XQSMD3 ; SEA/MJM - Secure MenuMan Delegation utilities; 12/11/07
+1 ;;8.0;KERNEL;**64,475**;Jul 10, 1995;Build 8
INIT SET U="^"
SET XQNGO=1
SET XQLEV=""
SET (XQDOP,XQDEL,XQPRO)=0
if DUZ(0)="@"!($DATA(^XUSEC("XUMGR",DUZ)))
SET XQPRO=1
+1 IF $SELECT('$DATA(IOM):1,IOM=0:1,'$DATA(IOSL):1,'$LENGTH(IOSL):1,'$DATA(IOF):1,'$LENGTH(IOF):1,'$DATA(IO):1,1:0)
SET IOP="HOME"
DO ^%ZIS
IF POP
WRITE !!,"*** DEVICE ERROR ***",!,?5,"-exiting-"
GOTO OUT
+2 if '$DATA(DTIME)#2
SET DTIME=60
+3 SET %DT=""
SET X="T"
DO ^%DT
SET XQDT=Y
XECUTE ^DD("DD")
SET XQDATE=Y
KILL %DT
+4 SET DIC=200
SET DIC(0)="FMNZ"
SET X="`"_DUZ
DO ^DIC
KILL DIC
if +Y<0
GOTO OUT
SET XQMGR=$PIECE(Y(0,0),",",2)_" "_$PIECE(Y(0,0),",",1)
+5 if XQPRO
SET XQLEV=0
if '$LENGTH(XQLEV)&($DATA(^VA(200,DUZ,19))#2)
SET XQLEV=$PIECE(^(19),U,3)
if '$LENGTH(XQLEV)
WRITE !,"Level problem. No action permitted."
if '$LENGTH(XQLEV)
GOTO OUT
+6 ;
USER1 ;Find the user who's delegated options will be transfered.
+1 READ !!,"Please enter the user currently holding the options :",XQ:DTIME
if '$TEST
SET XQ=U
if XQ=U
GOTO OUT
IF '$LENGTH(XQ)!(XQ="?")
WRITE !!,"Enter delegate's name,'^' to quit,'??' for User list, or '???' for help.",!
GOTO USER1
+2 IF XQ="??"
SET X="?"
SET DIC=200
SET DIC(0)="Q"
DO ^DIC
KILL DIC
GOTO USER1
+3 IF XQ="???"
SET XQH="XQSMD-REPLICATE"
DO EN^XQH
GOTO USER1
+4 SET X=XQ
SET DIC(0)="QMENZ"
SET DIC=200
DO ^DIC
IF +Y<1
WRITE !!,"Not a know user. Try again or enter a '^' to quit."
GOTO USER1
+5 IF '$DATA(^VA(200,+Y,19.5,0))!($ORDER(^(0))="")
WRITE !!,Y(0,0)," has not been delegated any menu options to transfer."
GOTO USER1
+6 SET XQPERX="^VA(200,"_+Y_",19.5,"
SET XQU1=$PIECE(Y(0,0),",",2)_" "_$PIECE(Y(0,0),",",1)
SET XQU1Y=+Y
+7 SET XQU1L=$PIECE($GET(^VA(200,+XQU1Y,19)),U,3)
IF XQLEV>XQU1L
WRITE !!,"You may not, in this case, remove the options of ",XQU1
SET XQDEL=0
GOTO USER2
+8 ;
RPLC WRITE !!,"Should ALL delegated options be removed from ",XQU1,!," after they have been transferred? N// "
READ XQ:DTIME
if '$TEST
SET XQ=U
if XQ=U
GOTO OUT
if '$LENGTH(XQ)
SET XQ="N"
IF XQ="?"
WRITE !!,"Please enter 'Y' or 'N', '^' to quit, or '??' for help.",!
GOTO RPLC
+1 IF XQ="??"
SET XQH="XQSMD-REMOVE"
DO EN^XQH
GOTO RPLC
+2 IF "YyNn"'[XQ
WRITE !,"Please answer 'Y' or 'N' "
GOTO RPLC
+3 if XQ["Y"!(XQ["y")
SET XQDEL=1
+4 ;
USER2 ;Get the name of the person to whom these options will be transfered
+1 WRITE !!,"Please enter the user who will get the same options as ",XQU1,!," now has: "
READ XQ:DTIME
if '$TEST
SET XQ=U
if XQ=U
GOTO OUT
IF XQ="?"!('$LENGTH(XQ))
WRITE !!,"Enter User's name,'^' to quit,'??' for User list, or '???'for help.",!
GOTO USER2
+2 IF XQ="??"
SET DIC=200
SET X="?"
SET DIC(0)="Q"
DO ^DIC
KILL DIC
GOTO USER2
+3 IF XQ="???"
SET XQH="XQSMD-REPLACEMENT"
DO EN^XQH
GOTO USER2
+4 SET X=XQ
SET DIC=200
SET DIC(0)="EFMQZ"
DO ^DIC
IF +Y<1
WRITE !!,"Sorry, this person is not in the User File. Try again or enter '^' to quit."
GOTO USER2
+5 IF $DATA(^VA(200,+Y,0))
IF '$LENGTH($PIECE($GET(^(.1)),U,2))
WRITE !!,"Sorry, this person is not a current user. Try again or enter '^' to quit."
GOTO USER2
+6 SET XQHOLD(+Y)=Y(0,0)
SET XQU2=$PIECE(Y(0,0),",",2)_" "_$PIECE(Y(0,0),",",1)
+7 IF +XQU1Y=+Y
WRITE !!,"Sorry, this is illogical: it's the same person!"
GOTO USER2
+8 IF +Y=+DUZ
WRITE !!,"Sorry, you can't be your own delegate."
GOTO OUT
+9 ;
ASK ;See if we all understand eachother.
+1 WRITE !!!,"You want to assign the options currently held by ",XQU1,!,?5,"to ",XQU2
+2 if XQDEL
WRITE " and remove them from ",XQU1
+3 WRITE !!,"Is this correct? Y/N "
READ XQ:DTIME
if '$TEST
SET XQ=U
if XQ=U
GOTO OUT
if XQ["N"!(XQ["n")
GOTO INIT
SET XQH="XQSMD-OK"
IF XQ["?"
DO EN^XQH
GOTO ASK
+4 IF XQ'["Y"&(XQ'["y")
WRITE !!,*7,"Please answer 'Y' or 'N'."
GOTO ASK
+5 IF XQDEL
WRITE !!,"Request to remove delegated options from ",XQU1," will be queued. "
+6 ;
+7 GOTO ^XQSMD31
+8 ;
OUT KILL 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($JOB),XQDOP,C
+1 QUIT
