- XQSMD3 ; SEA/MJM - Secure MenuMan Delegation utilities; 12/11/07
- ;;8.0;KERNEL;**64,475**;Jul 10, 1995;Build 16
- 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
- XQSMD3 ; SEA/MJM - Secure MenuMan Delegation utilities; 12/11/07
- +1 ;;8.0;KERNEL;**64,475**;Jul 10, 1995;Build 16
- 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
