- 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 Feb 18, 2025@23:31:17 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