XQ6 ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;2/14/95 12:47
;;8.0;KERNEL;**1002,1003,1004,1005,1007,1016**;APR 1, 2003;Build 5
;;8.0;KERNEL;;Jul 10, 1995
;THIS ROUTINE CONTAINS IHS MODIFICATION BY IHS/ANMC/LJF 1/29/97
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
I XQM W $S($D(XQKEY(+Y)):" Deleted from current list",1:$C(7)_" ?? Key not on list") K XQKEY(+Y) G KEY
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;Insert new line to warn user that the PROVIDER key must be given under
;the ADD PROVIDER option. Original modification by IHS/ANMC/LJF 7/29/97
I $P(Y,U,2)="PROVIDER" W !,*7,"DO NOT GIVE PROVIDER KEY!! IT MUST BE DONE UNDER ADD PROVIDER OPTION!!",!,"TYPE ^ TO START OVER."
;----- END IHS MODIFICATION
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,!!
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;Next two lines are commented out and replaced by two lines below to
;add user's SERVICE to the display when displaying holders of a
;security key. Original modification by IHS/ANMC/LJF 1/29/97
;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
S %=0 F XQI=0:0 S %=$O(^XUSEC(XQKEY,%)) Q:%="" I $D(^VA(200,+%,0)) S ^TMP($J,$P(^VA(200,+%,0),U))=$$SERVICE(%)
S %="" F XQI=1:1 S %=$O(^TMP($J,%)) Q:%="" W !,%,?30,^TMP($J,%) D:'(XQI#16) PAUSE Q:X[U
;----- END IHS MODIFICATION
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
;----- BEGIN IHS MODIFICATION - XU*8.0*1007
;This SERVICE subroutine is added to return the user's service
;when displaying holders of a security key. Original modification
;by IHS/ANMC/LJF 1/29/97
SERVICE(USR) ; -- RETURNS USER'S SERVICE
NEW X S X=$P($G(^VA(200,+USR,5)),U) I X="" Q ""
Q $P($G(^DIC(49,X,0)),U)
;----- END IHS MODIFICATION
XQ6 ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;2/14/95 12:47
+1 ;;8.0;KERNEL;**1002,1003,1004,1005,1007,1016**;APR 1, 2003;Build 5
+2 ;;8.0;KERNEL;;Jul 10, 1995
+3 ;THIS ROUTINE CONTAINS IHS MODIFICATION BY IHS/ANMC/LJF 1/29/97
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 IF XQM
WRITE $SELECT($DATA(XQKEY(+Y)):" Deleted from current list",1:$CHAR(7)_" ?? Key not on list")
KILL XQKEY(+Y)
GOTO KEY
+9 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+10 ;Insert new line to warn user that the PROVIDER key must be given under
+11 ;the ADD PROVIDER option. Original modification by IHS/ANMC/LJF 7/29/97
+12 IF $PIECE(Y,U,2)="PROVIDER"
WRITE !,*7,"DO NOT GIVE PROVIDER KEY!! IT MUST BE DONE UNDER ADD PROVIDER OPTION!!",!,"TYPE ^ TO START OVER."
+13 ;----- END IHS MODIFICATION
+14 SET XQKEY(+Y)=""
IF $DATA(^DIC(19.1,+Y,3,0))
IF $PIECE(^(0),U,4)>0
DO MORE
+15 GOTO KEY
+16 ;
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 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+5 ;Next two lines are commented out and replaced by two lines below to
+6 ;add user's SERVICE to the display when displaying holders of a
+7 ;security key. Original modification by IHS/ANMC/LJF 1/29/97
+8 ;S %=0 F XQI=0:0 S %=$O(^XUSEC(XQKEY,%)) Q:%="" I $D(^VA(200,+%,0)) S ^TMP($J,$P(^VA(200,+%,0),U))=""
+9 ;S %="" F XQI=1:1 S %=$O(^TMP($J,%)) Q:%="" W !,% D:'(XQI#16) PAUSE Q:X[U
+10 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))=$$SERVICE(%)
+11 SET %=""
FOR XQI=1:1
SET %=$ORDER(^TMP($JOB,%))
IF %=""
QUIT
WRITE !,%,?30,^TMP($JOB,%)
IF '(XQI#16)
DO PAUSE
IF X[U
QUIT
+12 ;----- END IHS MODIFICATION
+13 KILL ^TMP($JOB),%,DIC,XQI,XQL,XQKEY
+14 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
+8 ;----- BEGIN IHS MODIFICATION - XU*8.0*1007
+9 ;This SERVICE subroutine is added to return the user's service
+10 ;when displaying holders of a security key. Original modification
+11 ;by IHS/ANMC/LJF 1/29/97
SERVICE(USR) ; -- RETURNS USER'S SERVICE
+1 NEW X
SET X=$PIECE($GET(^VA(200,+USR,5)),U)
IF X=""
QUIT ""
+2 QUIT $PIECE($GET(^DIC(49,X,0)),U)
+3 ;----- END IHS MODIFICATION
