Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQ6

XQ6.m

Go to the documentation of this file.
  1. XQ6 ;SEA/AMF,SLC/CJS- BULK KEY DISTRIBUTION ;2/14/95 12:47
  1. ;;8.0;KERNEL;**775**;Jul 10, 1995;Build 11
  1. ;Per VHA Directive 6402, this routine should not be modified.
  1. ;
  1. EN1 S XQAL=1,XQDA=0 G INIT ; ENTRY POINT TO ACTIVATE KEY (XUKEYALL)
  1. EN2 S XQAL=0,XQDA=0 G INIT ; DE-ALLOCATE ACTIVE KEY (XUKEYDEALL)
  1. EN3 S XQAL=1,XQDA=1 G INIT ; DELEGATE KEYS (XQKEYDEL)
  1. EN4 S XQAL=0,XQDA=1 ;REMOVE DELEGATED KEYS (XQKEYRDEL)
  1. INIT ;
  1. K XQKEY,XQHOLD S (XQKEY(0),XQHOLD(0),XQBOSS)=0
  1. KEY ;
  1. S:'$D(XQDA) XQDA=0 S XQBOSS=0 S:(DUZ(0)="@"!($D(^XUSEC("XUMGR",DUZ)))) XQBOSS=1
  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
  1. 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
  1. I '$L(X) G:($O(XQKEY(0))'>0) OUT G HOLDER
  1. I X["?" S XQH="XQKEYALLOCATE-KEY" D:X="?" EN^XQH D:X="??" LSTKEY^XQ6A D:X="???" KEYFIL^XQ6A G KEY
  1. S XQM=0 S:"-"[$E(X,1) X=$E(X,2,999),XQM=1
  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
  1. ;*775
  1. I 'XQDA,$P(Y,U,2)="PSDRPH" D G KEY
  1. .W !,"The PSDRPH key cannot be allocated / de-allocated by this option. Please"
  1. .W !,"use the option 'Allocate/De-Allocate of PSDRPH Key (Audited)'."
  1. I XQM W $S($D(XQKEY(+Y)):" Deleted from current list",1:$C(7)_" ?? Key not on list") K XQKEY(+Y) G KEY
  1. S XQKEY(+Y)="" I $D(^DIC(19.1,+Y,3,0)),$P(^(0),U,4)>0 D MORE
  1. G KEY
  1. ;
  1. MORE ;Handles subordinate or exploding keys
  1. W !!,"There are subordinate keys, do you wish to add them" S %=2 D YN^DICN I %=-1!(%=2) Q
  1. I %=0 W !!,"If you answer 'YES', the subordinate keys will be listed and added." G MORE
  1. 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)
  1. Q
  1. HOLDER ;Continue in next routine
  1. G HOLDER^XQ6A
  1. ;
  1. OUT K %,DA,DIC,DIE,DR,XMDUZ,XQBOSS,XQKEY,XQAL,XQHOLD,XQI,XQJ,XQK,XQDA,XQSBNFDT,XQH,XQM,XQNM,X,Y
  1. Q
  1. SHOW ;Show the users of a particular key
  1. 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
  1. S XQKEY=$P(Y,U,2) I '$D(^XUSEC(XQKEY)) W !!,"There are no holders of this key." K DIC,XQKEY Q
  1. W @IOF,?15,"Current holders of the key ",XQKEY,!!
  1. S %=0 F XQI=0:0 S %=$O(^XUSEC(XQKEY,%)) Q:%="" I $D(^VA(200,+%,0)) S ^TMP($J,$P(^VA(200,+%,0),U))=""
  1. S %="" F XQI=1:1 S %=$O(^TMP($J,%)) Q:%="" W !,% D:'(XQI#16) PAUSE Q:X[U
  1. K ^TMP($J),%,DIC,XQI,XQL,XQKEY
  1. Q
  1. PAUSE ;Hold the screen
  1. W !!?5,"Hit RETURN to continue or '^' to stop: " R X:DTIME S:'$T X=U
  1. I X'[U,XQL W @IOF,?15,"Current holders of the key ",XQKEY,!!
  1. Q
  1. LIST ;List all the keys of a given user
  1. 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
  1. S %=$P(Y,U,2),XQUSER=$P(%,",",2)_" "_$P(%,","),XQU=+Y
  1. 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
  1. 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))=""
  1. W @IOF S XQK=5 I XQI=0 W !!,XQUSER," does not currently hold any keys."
  1. I XQI>0 W !!,XQUSER," currently holds:",! S %="" F XQI=0:1 S %=$O(^TMP($J,%)) Q:%="" W:'(XQI#XQK) ! W ?(XQI#XQK*16),%
  1. 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))=""
  1. 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),%
  1. K ^TMP($J),%,DIC,XQI,XQK,XQL,XQU,XQUSER
  1. Q
  1. ;
  1. ATOD ;Convert all of a users allocated keys to delegated keys
  1. S DIC="^VA(200,",DIC(0)="AEQMZ",DIC("A")=" User's name: " W ! D ^DIC I Y'>0 K DIC Q
  1. S %=$P(Y,U,2),XQUSER=$P(%,",",2)_" "_$P(%,","),XQU=+Y
  1. 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
  1. 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
  1. S %X="^VA(200,"_XQU_",51,",%Y="^VA(200,"_XQU_",52," D %XY^%RCR
  1. S $P(^VA(200,XQU,52,0),U,2)="200.052PA"
  1. S DIK="^VA(200,"_XQU_",52,",DIK(1)=".01^B",DA=52,DA(1)=XQU D ENALL^DIK
  1. K %,%X,%Y,DA,DIC,DIK,DIR,XQU,XQUSER,X,Y
  1. Q
  1. ;
  1. MESS ;Correct problems with key cross-references from 7.0 %RCR above.
  1. S DA(1)=XQU F XQFIL=51,52 D
  1. .K ^VA(200,DA(1),XQFIL,"B")
  1. .S DA=0,DIK="^VA(200,"_DA(1)_","_XQFIL_","
  1. .F S DA=$O(^VA(200,DA(1),XQFIL,DA)) Q:DA'=+DA D IX^DIK
  1. .Q
  1. K DA,DIC,DIK,XQDUZ,XQFIL
  1. Q