XQ6 ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;2/14/95 12:47
;;8.0;KERNEL;**775**;Jul 10, 1995;Build 11
;Per VHA Directive 6402, this routine should not be modified.
;
EN1 S XQAL=1,XQDA=0 G INIT ; ENTRY POINT TO ACTIVATE KEY (XUKEYALL)
EN2 S XQAL=0,XQDA=0 G INIT ; DE-ALLOCATE ACTIVE KEY (XUKEYDEALL)
EN3 S XQAL=1,XQDA=1 G INIT ; DELEGATE KEYS (XQKEYDEL)
EN4 S XQAL=0,XQDA=1 ;REMOVE DELEGATED KEYS (XQKEYRDEL)
INIT ;
K XQKEY,XQHOLD S (XQKEY(0),XQHOLD(0),XQBOSS)=0
KEY ;
S:'$D(XQDA) XQDA=0 S XQBOSS=0 S:(DUZ(0)="@"!($D(^XUSEC("XUMGR",DUZ)))) XQBOSS=1
I 'XQBOSS,$O(^VA(200,DUZ,52,0))'>0 W !,"You've nothing to allocate. See your package coordinator or site manager." G OUT
W !!,$S($O(XQKEY(0))>0:"Another",XQAL&XQDA:"Delegate",XQAL:"Allocate",'XQAL&XQDA:"Remove delegated",1:"De-allocate")," key: " R X:DTIME S:'$T X=U G:X[U OUT
I '$L(X) G:($O(XQKEY(0))'>0) OUT G HOLDER
I X["?" S XQH="XQKEYALLOCATE-KEY" D:X="?" EN^XQH D:X="??" LSTKEY^XQ6A D:X="???" KEYFIL^XQ6A G KEY
S XQM=0 S:"-"[$E(X,1) X=$E(X,2,999),XQM=1
S DIC=19.1,DIC(0)="EZM" S:'XQBOSS DIC("S")="I $D(^VA(200,DUZ,52,+Y,0))" D ^DIC K DIC I Y<0 W " ??",*7 G KEY
;*775
I 'XQDA,$P(Y,U,2)="PSDRPH" D G KEY
.W !,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
.W !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)'."
I XQM W $S($D(XQKEY(+Y)):" Deleted from current list",1:$C(7)_" ?? Key not on list") K XQKEY(+Y) G KEY
S XQKEY(+Y)="" I $D(^DIC(19.1,+Y,3,0)),$P(^(0),U,4)>0 D MORE
G KEY
;
MORE ;Handles subordinate or exploding keys
W !!,"There are subordinate keys, do you wish to add them" S %=2 D YN^DICN I %=-1!(%=2) Q
I %=0 W !!,"If you answer 'YES', the subordinate keys will be listed and added." G MORE
F XQI=0:0 S XQI=$O(^DIC(19.1,+Y,3,XQI)) Q:XQI'>0 S XQJ=+^(XQI,0),XQKEY(XQJ)="" W !,$P(^DIC(19.1,XQJ,0),"^")," ",$P(^(0),U,2)
Q
HOLDER ;Continue in next routine
G HOLDER^XQ6A
;
OUT K %,DA,DIC,DIE,DR,XMDUZ,XQBOSS,XQKEY,XQAL,XQHOLD,XQI,XQJ,XQK,XQDA,XQSBNFDT,XQH,XQM,XQNM,X,Y
Q
SHOW ;Show the users of a particular key
K ^TMP($J) S XQL=1,DIC="^DIC(19.1,",DIC(0)="AEQMZ",DIC("A")=" Which key? " W ! D ^DIC I Y'>0 K DIC,XQL Q
S XQKEY=$P(Y,U,2) I '$D(^XUSEC(XQKEY)) W !!,"There are no holders of this key." K DIC,XQKEY Q
W @IOF,?15,"Current holders of the key ",XQKEY,!!
S %=0 F XQI=0:0 S %=$O(^XUSEC(XQKEY,%)) Q:%="" I $D(^VA(200,+%,0)) S ^TMP($J,$P(^VA(200,+%,0),U))=""
S %="" F XQI=1:1 S %=$O(^TMP($J,%)) Q:%="" W !,% D:'(XQI#16) PAUSE Q:X[U
K ^TMP($J),%,DIC,XQI,XQL,XQKEY
Q
PAUSE ;Hold the screen
W !!?5,"Hit RETURN to continue or '^' to stop: " R X:DTIME S:'$T X=U
I X'[U,XQL W @IOF,?15,"Current holders of the key ",XQKEY,!!
Q
LIST ;List all the keys of a given user
K ^TMP($J) S XQL=0,DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")=" User's name: " W ! D ^DIC I Y'>0 K DIC Q
S %=$P(Y,U,2),XQUSER=$P(%,",",2)_" "_$P(%,","),XQU=+Y
I $D(^VA(200,XQU,52,0)),$P(^(0),U,2)["200.051" S $P(^(0),U,2)="200.052PA" D MESS ;This corrects a Kv7 problem can be removed after Kv8
S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,51,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U))=""
W @IOF S XQK=5 I XQI=0 W !!,XQUSER," does not currently hold any keys."
I XQI>0 W !!,XQUSER," currently holds:",! S %="" F XQI=0:1 S %=$O(^TMP($J,%)) Q:%="" W:'(XQI#XQK) ! W ?(XQI#XQK*16),%
K ^TMP($J) S %=0 F XQI=0:1 S %=$O(^VA(200,XQU,52,"B",%)) Q:%="" S:$D(^DIC(19.1,%,0)) ^TMP($J,$P(^DIC(19.1,%,0),U))=""
I XQI>0 W !!!,XQUSER," may delegate the following keys:",! S %="" F XQI=0:1 S %=$O(^TMP($J,%)) Q:%="" W:'(XQI#XQK) ! W ?(XQI#XQK*16),%
K ^TMP($J),%,DIC,XQI,XQK,XQL,XQU,XQUSER
Q
;
ATOD ;Convert all of a users allocated keys to delegated keys
S DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")=" User's name: " W ! D ^DIC I Y'>0 K DIC Q
S %=$P(Y,U,2),XQUSER=$P(%,",",2)_" "_$P(%,","),XQU=+Y
S %=$P($G(^VA(200,XQU,51,0)),U,4) I %'>0 W !!,XQUSER," does not hold any keys to transfer." K XQUSER,XQU,Y G ATOD
I $D(^VA(200,XQU,52,0)),$P(^(0),U,4)>0 W !!,XQUSER," already has some delegated keys." S DIR(0)="YA",DIR("A")=" Shall I merge the two sets? Y/N ",DIR("B")="N" D ^DIR I Y=0!$D(DIRUT) K DIR,DIRUT,XQUSER,XQU,Y G ATOD
S %X="^VA(200,"_XQU_",51,",%Y="^VA(200,"_XQU_",52," D %XY^%RCR
S $P(^VA(200,XQU,52,0),U,2)="200.052PA"
S DIK="^VA(200,"_XQU_",52,",DIK(1)=".01^B",DA=52,DA(1)=XQU D ENALL^DIK
K %,%X,%Y,DA,DIC,DIK,DIR,XQU,XQUSER,X,Y
Q
;
MESS ;Correct problems with key cross-references from 7.0 %RCR above.
S DA(1)=XQU F XQFIL=51,52 D
.K ^VA(200,DA(1),XQFIL,"B")
.S DA=0,DIK="^VA(200,"_DA(1)_","_XQFIL_","
.F S DA=$O(^VA(200,DA(1),XQFIL,DA)) Q:DA'=+DA D IX^DIK
.Q
K DA,DIC,DIK,XQDUZ,XQFIL
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ6 4713 printed Oct 16, 2024@18:05:40 Page 2
XQ6 ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;2/14/95 12:47
+1 ;;8.0;KERNEL;**775**;Jul 10, 1995;Build 11
+2 ;Per VHA Directive 6402, this routine should not be modified.
+3 ;
EN1 ; ENTRY POINT TO ACTIVATE KEY (XUKEYALL)
SET XQAL=1
SET XQDA=0
GOTO INIT
EN2 ; DE-ALLOCATE ACTIVE KEY (XUKEYDEALL)
SET XQAL=0
SET XQDA=0
GOTO INIT
EN3 ; DELEGATE KEYS (XQKEYDEL)
SET XQAL=1
SET XQDA=1
GOTO INIT
EN4 ;REMOVE DELEGATED KEYS (XQKEYRDEL)
SET XQAL=0
SET XQDA=1
INIT ;
+1 KILL XQKEY,XQHOLD
SET (XQKEY(0),XQHOLD(0),XQBOSS)=0
KEY ;
+1 if '$DATA(XQDA)
SET XQDA=0
SET XQBOSS=0
if (DUZ(0)="@"!($DATA(^XUSEC("XUMGR",DUZ))))
SET XQBOSS=1
+2 IF 'XQBOSS
IF $ORDER(^VA(200,DUZ,52,0))'>0
WRITE !,"You've nothing to allocate. See your package coordinator or site manager."
GOTO OUT
+3 WRITE !!,$SELECT($ORDER(XQKEY(0))>0:"Another",XQAL&XQDA:"Delegate",XQAL:"Allocate",'XQAL&XQDA:"Remove delegated",1:"De-allocate")," key: "
READ X:DTIME
if '$TEST
SET X=U
if X[U
GOTO OUT
+4 IF '$LENGTH(X)
if ($ORDER(XQKEY(0))'>0)
GOTO OUT
GOTO HOLDER
+5 IF X["?"
SET XQH="XQKEYALLOCATE-KEY"
if X="?"
DO EN^XQH
if X="??"
DO LSTKEY^XQ6A
if X="???"
DO KEYFIL^XQ6A
GOTO KEY
+6 SET XQM=0
if "-"[$EXTRACT(X,1)
SET X=$EXTRACT(X,2,999)
SET XQM=1
+7 SET DIC=19.1
SET DIC(0)="EZM"
if 'XQBOSS
SET DIC("S")="I $D(^VA(200,DUZ,52,+Y,0))"
DO ^DIC
KILL DIC
IF Y<0
WRITE " ??",*7
GOTO KEY
+8 ;*775
+9 IF 'XQDA
IF $PIECE(Y,U,2)="PSDRPH"
Begin DoDot:1
+10 WRITE !,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
+11 WRITE !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)'."
End DoDot:1
GOTO KEY
+12 IF XQM
WRITE $SELECT($DATA(XQKEY(+Y)):" Deleted from current list",1:$CHAR(7)_" ?? Key not on list")
KILL XQKEY(+Y)
GOTO KEY
+13 SET XQKEY(+Y)=""
IF $DATA(^DIC(19.1,+Y,3,0))
IF $PIECE(^(0),U,4)>0
DO MORE
+14 GOTO KEY
+15 ;
MORE ;Handles subordinate or exploding keys
+1 WRITE !!,"There are subordinate keys, do you wish to add them"
SET %=2
DO YN^DICN
IF %=-1!(%=2)
QUIT
+2 IF %=0
WRITE !!,"If you answer 'YES', the subordinate keys will be listed and added."
GOTO MORE
+3 FOR XQI=0:0
SET XQI=$ORDER(^DIC(19.1,+Y,3,XQI))
if XQI'>0
QUIT
SET XQJ=+^(XQI,0)
SET XQKEY(XQJ)=""
WRITE !,$PIECE(^DIC(19.1,XQJ,0),"^")," ",$PIECE(^(0),U,2)
+4 QUIT
HOLDER ;Continue in next routine
+1 GOTO HOLDER^XQ6A
+2 ;
OUT KILL %,DA,DIC,DIE,DR,XMDUZ,XQBOSS,XQKEY,XQAL,XQHOLD,XQI,XQJ,XQK,XQDA,XQSBNFDT,XQH,XQM,XQNM,X,Y
+1 QUIT
SHOW ;Show the users of a particular key
+1 KILL ^TMP($JOB)
SET XQL=1
SET DIC="^DIC(19.1,"
SET DIC(0)="AEQMZ"
SET DIC("A")=" Which key? "
WRITE !
DO ^DIC
IF Y'>0
KILL DIC,XQL
QUIT
+2 SET XQKEY=$PIECE(Y,U,2)
IF '$DATA(^XUSEC(XQKEY))
WRITE !!,"There are no holders of this key."
KILL DIC,XQKEY
QUIT
+3 WRITE @IOF,?15,"Current holders of the key ",XQKEY,!!
+4 SET %=0
FOR XQI=0:0
SET %=$ORDER(^XUSEC(XQKEY,%))
if %=""
QUIT
IF $DATA(^VA(200,+%,0))
SET ^TMP($JOB,$PIECE(^VA(200,+%,0),U))=""
+5 SET %=""
FOR XQI=1:1
SET %=$ORDER(^TMP($JOB,%))
if %=""
QUIT
WRITE !,%
if '(XQI#16)
DO PAUSE
if X[U
QUIT
+6 KILL ^TMP($JOB),%,DIC,XQI,XQL,XQKEY
+7 QUIT
PAUSE ;Hold the screen
+1 WRITE !!?5,"Hit RETURN to continue or '^' to stop: "
READ X:DTIME
if '$TEST
SET X=U
+2 IF X'[U
IF XQL
WRITE @IOF,?15,"Current holders of the key ",XQKEY,!!
+3 QUIT
LIST ;List all the keys of a given user
+1 KILL ^TMP($JOB)
SET XQL=0
SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
SET DIC("A")=" User's name: "
WRITE !
DO ^DIC
IF Y'>0
KILL DIC
QUIT
+2 SET %=$PIECE(Y,U,2)
SET XQUSER=$PIECE(%,",",2)_" "_$PIECE(%,",")
SET XQU=+Y
+3 ;This corrects a Kv7 problem can be removed after Kv8
IF $DATA(^VA(200,XQU,52,0))
IF $PIECE(^(0),U,2)["200.051"
SET $PIECE(^(0),U,2)="200.052PA"
DO MESS
+4 SET %=0
FOR XQI=0:1
SET %=$ORDER(^VA(200,XQU,51,"B",%))
if %=""
QUIT
if $DATA(^DIC(19.1,%,0))
SET ^TMP($JOB,$PIECE(^DIC(19.1,%,0),U))=""
+5 WRITE @IOF
SET XQK=5
IF XQI=0
WRITE !!,XQUSER," does not currently hold any keys."
+6 IF XQI>0
WRITE !!,XQUSER," currently holds:",!
SET %=""
FOR XQI=0:1
SET %=$ORDER(^TMP($JOB,%))
if %=""
QUIT
if '(XQI#XQK)
WRITE !
WRITE ?(XQI#XQK*16),%
+7 KILL ^TMP($JOB)
SET %=0
FOR XQI=0:1
SET %=$ORDER(^VA(200,XQU,52,"B",%))
if %=""
QUIT
if $DATA(^DIC(19.1,%,0))
SET ^TMP($JOB,$PIECE(^DIC(19.1,%,0),U))=""
+8 IF XQI>0
WRITE !!!,XQUSER," may delegate the following keys:",!
SET %=""
FOR XQI=0:1
SET %=$ORDER(^TMP($JOB,%))
if %=""
QUIT
if '(XQI#XQK)
WRITE !
WRITE ?(XQI#XQK*16),%
+9 KILL ^TMP($JOB),%,DIC,XQI,XQK,XQL,XQU,XQUSER
+10 QUIT
+11 ;
ATOD ;Convert all of a users allocated keys to delegated keys
+1 SET DIC="^VA(200,"
SET DIC(0)="AEQMZ"
SET DIC("A")=" User's name: "
WRITE !
DO ^DIC
IF Y'>0
KILL DIC
QUIT
+2 SET %=$PIECE(Y,U,2)
SET XQUSER=$PIECE(%,",",2)_" "_$PIECE(%,",")
SET XQU=+Y
+3 SET %=$PIECE($GET(^VA(200,XQU,51,0)),U,4)
IF %'>0
WRITE !!,XQUSER," does not hold any keys to transfer."
KILL XQUSER,XQU,Y
GOTO ATOD
+4 IF $DATA(^VA(200,XQU,52,0))
IF $PIECE(^(0),U,4)>0
WRITE !!,XQUSER," already has some delegated keys."
SET DIR(0)="YA"
SET DIR("A")=" Shall I merge the two sets? Y/N "
SET DIR("B")="N"
DO ^DIR
IF Y=0!$DATA(DIRUT)
KILL DIR,DIRUT,XQUSER,XQU,Y
GOTO ATOD
+5 SET %X="^VA(200,"_XQU_",51,"
SET %Y="^VA(200,"_XQU_",52,"
DO %XY^%RCR
+6 SET $PIECE(^VA(200,XQU,52,0),U,2)="200.052PA"
+7 SET DIK="^VA(200,"_XQU_",52,"
SET DIK(1)=".01^B"
SET DA=52
SET DA(1)=XQU
DO ENALL^DIK
+8 KILL %,%X,%Y,DA,DIC,DIK,DIR,XQU,XQUSER,X,Y
+9 QUIT
+10 ;
MESS ;Correct problems with key cross-references from 7.0 %RCR above.
+1 SET DA(1)=XQU
FOR XQFIL=51,52
Begin DoDot:1
+2 KILL ^VA(200,DA(1),XQFIL,"B")
+3 SET DA=0
SET DIK="^VA(200,"_DA(1)_","_XQFIL_","
+4 FOR
SET DA=$ORDER(^VA(200,DA(1),XQFIL,DA))
if DA'=+DA
QUIT
DO IX^DIK
+5 QUIT
End DoDot:1
+6 KILL DA,DIC,DIK,XQDUZ,XQFIL
+7 QUIT
