XQ6A ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;5:22 AM 19 Jun 2002
;;8.0;KERNEL;**12,147**;Jul 10, 1995
HOLDER ;
W !!,$S($O(XQHOLD(0))>0:"Another holder: ",1:"Holder of key: ") R X:DTIME S:'$T X=U G:X[U OUT
I '$L(X) G:($O(XQHOLD(0))>0) OK W " ??",$C(7),!,"You have not yet selected any holders." G HOLDER
I X["?" S XQH="XQKEYALLOCATE-HOLDER" D:X="?" EN^XQH D:X="??" LSTHOL D:X="???" USERFIL G HOLDER
S XQM=0 S:"'-"[$E(X,1) X=$E(X,2,999),XQM=1
;I $E(X,1,2)'="G." S DIC=200,DIC(0)="EZM",DIC("S")="I $L($P(^(0),U,3))" D ^DIC K DIC W:(Y<0) " ??",$C(7) G:Y<0 HOLDER S XQI=+Y D EACH G HOLDER
I $E(X,1,2)'="G." S DIC=200,DIC(0)="EZM" D ^DIC K DIC W:(Y<0) " ??",$C(7) G:Y<0 HOLDER S XQI=+Y D EACH G HOLDER
S X=$E(X,3,999),XMDUZ=DUZ,DIC("S")="D:$P(^(0),U,2)=""PR"" CHK^XMA21",DIC="^XMB(3.8,",DIC(0)="EMZ" D ^DIC K DIC I Y<0 W " ??",$C(7) G HOLDER
;S XQJ=0 F XQI=1:1 S XQJ=$O(^XMB(3.8,+Y,1,XQJ)) Q:XQJ'>0!(XQJ'=+XQJ) S XQI=+^(XQJ,0) I $L($P(^VA(200,XQI,0),U,3)) W !,$P(^(0),U,1) D EACH
S XQJ=0 F XQI=1:1 S XQJ=$O(^XMB(3.8,+Y,1,XQJ)) Q:XQJ'>0!(XQJ'=+XQJ) S XQI=+^(XQJ,0) W !,$P(^VA(200,XQI,0),U,1) D EACH
G HOLDER
;
EACH ;Check out each potential user
I 'XQBOSS,(XQI=DUZ) W !!,$C(7),"==> Sorry, you can't give yourself keys. See your IRM staff." Q
I XQM W $S($D(XQHOLD(XQI)):" Deleted from current list",1:$C(7)_" ?? Holder not on list") K XQHOLD(XQI) Q
S XQHOLD(XQI)=""
Q
OK ;
D LSTKEY,LSTHOL
W !!,"You are ",$S(XQAL&XQDA:"delegating",XQAL:"allocating",XQDA:"removing delegated",1:"deallocating")," keys."
OK1 R " Do you wish to proceed? YES// ",X:DTIME S:'$T X=U G:X[U OUT S:(X="") X="Y" I "YyNn"'[$E(X,1) W $C(7)," ??",!,"Please enter 'Y' or 'N'" G OK1
I $E(X,1)="N"!($E(X,1)="n") R !!,"Do you wish to start again? NO// ",X:DTIME S:'$T X=U G:X[U OUT S:(X="") X="N" G:X["Y"!(X["y") KEY^XQ6 G:"YyNn"'[$E(X,1) OK1 G OUT
;
ACT ;Run through list of keys
F XQK=0:0 S XQK=$O(XQKEY(XQK)) Q:XQK'>0 W !!,$P(^DIC(19.1,XQK,0),U,1)," being ",$S(XQAL&XQDA:"delegated to",XQAL:"assigned to:",1:"taken away from:") D ACT1
;
OUT ;Exit point
K %,DA,DIC,DIE,DR,XMDUZ,XQBOSS,XQKEY,XQAL,XQHOLD,XQI,XQJ,XQK,XQDA,XQSBNFDT,XQH,XQM,XQNM,X,Y
Q
ACT1 ;Run through list of people
F XQM=0:0 S XQM=$O(XQHOLD(XQM)) Q:XQM'>0 D ACT2
Q
ACT2 ;Add keys or DO ACT3 if we're removing them
N XQEND
S XQEND=""
S XQNM=$P(^VA(200,XQM,0),U,1) W !?5,XQNM I 'XQAL D ACT3 Q
I $D(^VA(200,XQM,$S(XQDA:52,1:51),XQK)) W ?30,"Person already holds key - no action taken" Q
D UNABLE^XQ6B(XQK,XQM,.XQEND) I XQEND=1 Q
S DIC(0)="NMQ",DIC("P")=$S(XQDA:"200.052PA",1:"200.051PA"),DIC="^VA(200,XQM,"_$S(XQDA:52,1:51)_",",DA(1)=XQM,X=XQK,DINUM=X D FILE^DICN Q
ACT3 I '$D(^VA(200,XQM,$S(XQDA:52,1:51),XQK)) W ?30,"Person doesn't hold key - no action taken" Q
S DIK="^VA(200,XQM,"_$S(XQDA:52,1:51)_",",DA(1)=XQM,DA=XQK D ^DIK Q
Q
LSTKEY ;
I $O(XQKEY(0))'>0 W !!,"You have not yet selected any keys." Q
W !!,"You've selected the following keys: ",! S XQJ=0,XQI=5 F XQK=0:1 S XQJ=$O(XQKEY(XQJ)) Q:XQJ'>0 W:'(XQK#XQI) ! W ?(XQK#XQI*15),$P(^DIC(19.1,XQJ,0),U,1)
Q
LSTHOL ;
I $O(XQHOLD(0))'>0 W !!,"You have not yet selected any holders." Q
W !!,"You've selected the following holders: ",! S XQJ=0,XQI=3 F XQK=0:1 S XQJ=$O(XQHOLD(XQJ)) Q:XQJ'>0 W:'(XQK#XQI) ! W ?(XQK#XQI*26),$P(^VA(200,XQJ,0),U,1)
Q
KEYFIL ;
I '$D(XQBOSS) S XQBOSS=0 S:(DUZ(0)="@"!($D(^XUSEC("XUMGR",DUZ)))) XQBOSS=1
S:'XQBOSS DIC("S")="I $D(^VA(200,DUZ,52,+Y,0))"
R !,"Do you want to see the KEY file? NO// ",X:DTIME S:'$T X="N" Q:X'["Y"&(X'["y") S X="?",DIC="^DIC(19.1,",DIC(0)="Q" D ^DIC K DIC
Q
USERFIL ;
R !,"Do you want to see the current holders of a key? NO//",X:DTIME S:'$T X="N" G:X'["Y"&(X'["y") U0
US0 S DIC=19.1,DIC(0)="AEQMZ" D ^DIC K DIC G:Y<0 U0 W !,"Holders are:" S XQII=0
US1 S XQII=$O(^VA(200,"AB",+Y,XQII)) G:+XQII'>0 US0 W !?5,$S('$D(^VA(200,XQII,0)):XQII,1:$P(^VA(200,XQII,0),U)) G US1
U0 R !,"Do you want to see the NEW PERSON file? NO// ",X:DTIME G:X'["Y"&(X'["y") U1 S X="?",DIC="^VA(200,",DIC(0)="Q" ;,DIC("S")="I $L($P(^(0),U,3))"
D ^DIC K DIC
U1 R !,"Do you want to see the members of a Mail Group? NO// ",X:DTIME S:'$T X="N" Q:'(X["Y"!(X["y"))
U2 S XMDUZ=DUZ,DIC("S")="D:$P(^(0),U,2)=""PR"" CHK^XMA21",DIC="^XMB(3.8,",DIC(0)="AEQMZ" D ^DIC K DIC Q:Y<0 W !,"Members are:" S XQII=0
U3 S XQII=$O(^XMB(3.8,+Y,1,XQII)) G:+XQII'>0 U2 W !,?5 S X=^(XQII,0) W $S('X:X,'$D(^VA(200,X,0)):X,1:$P(^VA(200,X,0),U,1)) G U3
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ6A 4457 printed Dec 13, 2024@02:04:54 Page 2
XQ6A ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;5:22 AM 19 Jun 2002
+1 ;;8.0;KERNEL;**12,147**;Jul 10, 1995
HOLDER ;
+1 WRITE !!,$SELECT($ORDER(XQHOLD(0))>0:"Another holder: ",1:"Holder of key: ")
READ X:DTIME
if '$TEST
SET X=U
if X[U
GOTO OUT
+2 IF '$LENGTH(X)
if ($ORDER(XQHOLD(0))>0)
GOTO OK
WRITE " ??",$CHAR(7),!,"You have not yet selected any holders."
GOTO HOLDER
+3 IF X["?"
SET XQH="XQKEYALLOCATE-HOLDER"
if X="?"
DO EN^XQH
if X="??"
DO LSTHOL
if X="???"
DO USERFIL
GOTO HOLDER
+4 SET XQM=0
if "'-"[$EXTRACT(X,1)
SET X=$EXTRACT(X,2,999)
SET XQM=1
+5 ;I $E(X,1,2)'="G." S DIC=200,DIC(0)="EZM",DIC("S")="I $L($P(^(0),U,3))" D ^DIC K DIC W:(Y<0) " ??",$C(7) G:Y<0 HOLDER S XQI=+Y D EACH G HOLDER
+6 IF $EXTRACT(X,1,2)'="G."
SET DIC=200
SET DIC(0)="EZM"
DO ^DIC
KILL DIC
if (Y<0)
WRITE " ??",$CHAR(7)
if Y<0
GOTO HOLDER
SET XQI=+Y
DO EACH
GOTO HOLDER
+7 SET X=$EXTRACT(X,3,999)
SET XMDUZ=DUZ
SET DIC("S")="D:$P(^(0),U,2)=""PR"" CHK^XMA21"
SET DIC="^XMB(3.8,"
SET DIC(0)="EMZ"
DO ^DIC
KILL DIC
IF Y<0
WRITE " ??",$CHAR(7)
GOTO HOLDER
+8 ;S XQJ=0 F XQI=1:1 S XQJ=$O(^XMB(3.8,+Y,1,XQJ)) Q:XQJ'>0!(XQJ'=+XQJ) S XQI=+^(XQJ,0) I $L($P(^VA(200,XQI,0),U,3)) W !,$P(^(0),U,1) D EACH
+9 SET XQJ=0
FOR XQI=1:1
SET XQJ=$ORDER(^XMB(3.8,+Y,1,XQJ))
if XQJ'>0!(XQJ'=+XQJ)
QUIT
SET XQI=+^(XQJ,0)
WRITE !,$PIECE(^VA(200,XQI,0),U,1)
DO EACH
+10 GOTO HOLDER
+11 ;
EACH ;Check out each potential user
+1 IF 'XQBOSS
IF (XQI=DUZ)
WRITE !!,$CHAR(7),"==> Sorry, you can't give yourself keys. See your IRM staff."
QUIT
+2 IF XQM
WRITE $SELECT($DATA(XQHOLD(XQI)):" Deleted from current list",1:$CHAR(7)_" ?? Holder not on list")
KILL XQHOLD(XQI)
QUIT
+3 SET XQHOLD(XQI)=""
+4 QUIT
OK ;
+1 DO LSTKEY
DO LSTHOL
+2 WRITE !!,"You are ",$SELECT(XQAL&XQDA:"delegating",XQAL:"allocating",XQDA:"removing delegated",1:"deallocating")," keys."
OK1 READ " Do you wish to proceed? YES// ",X:DTIME
if '$TEST
SET X=U
if X[U
GOTO OUT
if (X="")
SET X="Y"
IF "YyNn"'[$EXTRACT(X,1)
WRITE $CHAR(7)," ??",!,"Please enter 'Y' or 'N'"
GOTO OK1
+1 IF $EXTRACT(X,1)="N"!($EXTRACT(X,1)="n")
READ !!,"Do you wish to start again? NO// ",X:DTIME
if '$TEST
SET X=U
if X[U
GOTO OUT
if (X="")
SET X="N"
if X["Y"!(X["y")
GOTO KEY^XQ6
if "YyNn"'[$EXTRACT(X,1)
GOTO OK1
GOTO OUT
+2 ;
ACT ;Run through list of keys
+1 FOR XQK=0:0
SET XQK=$ORDER(XQKEY(XQK))
if XQK'>0
QUIT
WRITE !!,$PIECE(^DIC(19.1,XQK,0),U,1)," being ",$SELECT(XQAL&XQDA:"delegated to",XQAL:"assigned to:",1:"taken away from:")
DO ACT1
+2 ;
OUT ;Exit point
+1 KILL %,DA,DIC,DIE,DR,XMDUZ,XQBOSS,XQKEY,XQAL,XQHOLD,XQI,XQJ,XQK,XQDA,XQSBNFDT,XQH,XQM,XQNM,X,Y
+2 QUIT
ACT1 ;Run through list of people
+1 FOR XQM=0:0
SET XQM=$ORDER(XQHOLD(XQM))
if XQM'>0
QUIT
DO ACT2
+2 QUIT
ACT2 ;Add keys or DO ACT3 if we're removing them
+1 NEW XQEND
+2 SET XQEND=""
+3 SET XQNM=$PIECE(^VA(200,XQM,0),U,1)
WRITE !?5,XQNM
IF 'XQAL
DO ACT3
QUIT
+4 IF $DATA(^VA(200,XQM,$SELECT(XQDA:52,1:51),XQK))
WRITE ?30,"Person already holds key - no action taken"
QUIT
+5 DO UNABLE^XQ6B(XQK,XQM,.XQEND)
IF XQEND=1
QUIT
+6 SET DIC(0)="NMQ"
SET DIC("P")=$SELECT(XQDA:"200.052PA",1:"200.051PA")
SET DIC="^VA(200,XQM,"_$SELECT(XQDA:52,1:51)_","
SET DA(1)=XQM
SET X=XQK
SET DINUM=X
DO FILE^DICN
QUIT
ACT3 IF '$DATA(^VA(200,XQM,$SELECT(XQDA:52,1:51),XQK))
WRITE ?30,"Person doesn't hold key - no action taken"
QUIT
+1 SET DIK="^VA(200,XQM,"_$SELECT(XQDA:52,1:51)_","
SET DA(1)=XQM
SET DA=XQK
DO ^DIK
QUIT
+2 QUIT
LSTKEY ;
+1 IF $ORDER(XQKEY(0))'>0
WRITE !!,"You have not yet selected any keys."
QUIT
+2 WRITE !!,"You've selected the following keys: ",!
SET XQJ=0
SET XQI=5
FOR XQK=0:1
SET XQJ=$ORDER(XQKEY(XQJ))
if XQJ'>0
QUIT
if '(XQK#XQI)
WRITE !
WRITE ?(XQK#XQI*15),$PIECE(^DIC(19.1,XQJ,0),U,1)
+3 QUIT
LSTHOL ;
+1 IF $ORDER(XQHOLD(0))'>0
WRITE !!,"You have not yet selected any holders."
QUIT
+2 WRITE !!,"You've selected the following holders: ",!
SET XQJ=0
SET XQI=3
FOR XQK=0:1
SET XQJ=$ORDER(XQHOLD(XQJ))
if XQJ'>0
QUIT
if '(XQK#XQI)
WRITE !
WRITE ?(XQK#XQI*26),$PIECE(^VA(200,XQJ,0),U,1)
+3 QUIT
KEYFIL ;
+1 IF '$DATA(XQBOSS)
SET XQBOSS=0
if (DUZ(0)="@"!($DATA(^XUSEC("XUMGR",DUZ))))
SET XQBOSS=1
+2 if 'XQBOSS
SET DIC("S")="I $D(^VA(200,DUZ,52,+Y,0))"
+3 READ !,"Do you want to see the KEY file? NO// ",X:DTIME
if '$TEST
SET X="N"
if X'["Y"&(X'["y")
QUIT
SET X="?"
SET DIC="^DIC(19.1,"
SET DIC(0)="Q"
DO ^DIC
KILL DIC
+4 QUIT
USERFIL ;
+1 READ !,"Do you want to see the current holders of a key? NO//",X:DTIME
if '$TEST
SET X="N"
if X'["Y"&(X'["y")
GOTO U0
US0 SET DIC=19.1
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y<0
GOTO U0
WRITE !,"Holders are:"
SET XQII=0
US1 SET XQII=$ORDER(^VA(200,"AB",+Y,XQII))
if +XQII'>0
GOTO US0
WRITE !?5,$SELECT('$DATA(^VA(200,XQII,0)):XQII,1:$PIECE(^VA(200,XQII,0),U))
GOTO US1
U0 ;,DIC("S")="I $L($P(^(0),U,3))"
READ !,"Do you want to see the NEW PERSON file? NO// ",X:DTIME
if X'["Y"&(X'["y")
GOTO U1
SET X="?"
SET DIC="^VA(200,"
SET DIC(0)="Q"
+1 DO ^DIC
KILL DIC
U1 READ !,"Do you want to see the members of a Mail Group? NO// ",X:DTIME
if '$TEST
SET X="N"
if '(X["Y"!(X["y"))
QUIT
U2 SET XMDUZ=DUZ
SET DIC("S")="D:$P(^(0),U,2)=""PR"" CHK^XMA21"
SET DIC="^XMB(3.8,"
SET DIC(0)="AEQMZ"
DO ^DIC
KILL DIC
if Y<0
QUIT
WRITE !,"Members are:"
SET XQII=0
U3 SET XQII=$ORDER(^XMB(3.8,+Y,1,XQII))
if +XQII'>0
GOTO U2
WRITE !,?5
SET X=^(XQII,0)
WRITE $SELECT('X:X,'$DATA(^VA(200,X,0)):X,1:$PIECE(^VA(200,X,0),U,1))
GOTO U3
+1 QUIT
