XQ6B ;SFISC/KLD-KEY DISTRIBUTION MUTUALLY EXCLUSION KEYS;4/05/00
;;8.0;KERNEL;**147**;Jul 10, 1995
;
Q
UNABLE(XQIEN,XQPRSN,XQSTP) ;
D KEYAVAL Q:XQSTP=1
D UNABEXC Q:XQSTP=1
D UNABBLK Q:XQSTP=1
Q
KEYAVAL ;Check if key available to users - Self Exclusive
I $D(^DIC(19.1,XQIEN,5,"B",XQIEN)) D
. W !!,"Key '"_$$GET1^DIQ(19.1,XQIEN,.01)_"' may not be given to any user at this time"
. W !,"no action taken",!
. S XQSTP=1
Q
UNABEXC ;Key cannot be given Exclusive with Primary
N XQCLUDE,XQNUM,XQMKEY,XQTKEY
S (XQCLUDE,XQNUM,XQMKEY,XQTKEY)=""
F S XQCLUDE=$O(^DIC(19.1,XQIEN,5,"B",XQCLUDE)) Q:XQCLUDE="" D
. F S XQNUM=$O(^DIC(19.1,XQIEN,5,"B",XQCLUDE,XQNUM)) Q:XQNUM="" D
. . I $D(^VA(200,XQPRSN,51,XQCLUDE)) D
. . . S XQMKEY=$$GET1^DIQ(19.1,XQIEN,.01)
. . . S XQTKEY=$$GET1^DIQ(19.1,XQCLUDE,.01)
. . . W !!,"You are not AUTHORIZED key '"_XQMKEY_"' with EXCLUSIVE key '"_XQTKEY_"'"
. . . W !,"no action taken",!
. . . S XQSTP=1
Q
UNABBLK ;No Exclusive(s) - Verify primary not exclusive with another key(s)
N XQKEY,XQNBR,XQMKEY,XQTKEY
S (XQKEY,XQNBR,XQMKEY,XQTKEY)=""
I $D(^DIC(19.1,XQIEN,0)) D
. F S XQKEY=$O(^DIC(19.1,"B",XQKEY)) Q:XQKEY="" D
. . F S XQNBR=$O(^DIC(19.1,"B",XQKEY,XQNBR)) Q:XQNBR="" D
. . . I $D(^DIC(19.1,XQNBR,5,"B",XQIEN)) D
. . . . I $D(^VA(200,XQPRSN,51,XQNBR)) D
. . . . . S XQMKEY=$$GET1^DIQ(19.1,XQIEN,.01)
. . . . . S XQTKEY=$$GET1^DIQ(19.1,XQNBR,.01)
. . . . . W !!,"You are not AUTHORIZED key '"_XQMKEY_"' with EXCLUSIVE key '"_XQTKEY_"'"
. . . . . W !,"no action taken",!
. . . . . S XQSTP=1
Q
EXCLUSE ;Set primary exclusive with another key(s)
N DIC,DIE,DA,DR,Y
W !!
S DIC="19.1",DIC(0)="AEQZ",DIC("A")="Select Primary Allocated Key(s): "
D ^DIC Q:Y=-1 D
. W !
. S DIE="^DIC(19.1,",DR="5",DA=+Y
. D ^DIE
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQ6B 1888 printed Dec 13, 2024@02:04:55 Page 2
XQ6B ;SFISC/KLD-KEY DISTRIBUTION MUTUALLY EXCLUSION KEYS;4/05/00
+1 ;;8.0;KERNEL;**147**;Jul 10, 1995
+2 ;
+3 QUIT
UNABLE(XQIEN,XQPRSN,XQSTP) ;
+1 DO KEYAVAL
if XQSTP=1
QUIT
+2 DO UNABEXC
if XQSTP=1
QUIT
+3 DO UNABBLK
if XQSTP=1
QUIT
+4 QUIT
KEYAVAL ;Check if key available to users - Self Exclusive
+1 IF $DATA(^DIC(19.1,XQIEN,5,"B",XQIEN))
Begin DoDot:1
+2 WRITE !!,"Key '"_$$GET1^DIQ(19.1,XQIEN,.01)_"' may not be given to any user at this time"
+3 WRITE !,"no action taken",!
+4 SET XQSTP=1
End DoDot:1
+5 QUIT
UNABEXC ;Key cannot be given Exclusive with Primary
+1 NEW XQCLUDE,XQNUM,XQMKEY,XQTKEY
+2 SET (XQCLUDE,XQNUM,XQMKEY,XQTKEY)=""
+3 FOR
SET XQCLUDE=$ORDER(^DIC(19.1,XQIEN,5,"B",XQCLUDE))
if XQCLUDE=""
QUIT
Begin DoDot:1
+4 FOR
SET XQNUM=$ORDER(^DIC(19.1,XQIEN,5,"B",XQCLUDE,XQNUM))
if XQNUM=""
QUIT
Begin DoDot:2
+5 IF $DATA(^VA(200,XQPRSN,51,XQCLUDE))
Begin DoDot:3
+6 SET XQMKEY=$$GET1^DIQ(19.1,XQIEN,.01)
+7 SET XQTKEY=$$GET1^DIQ(19.1,XQCLUDE,.01)
+8 WRITE !!,"You are not AUTHORIZED key '"_XQMKEY_"' with EXCLUSIVE key '"_XQTKEY_"'"
+9 WRITE !,"no action taken",!
+10 SET XQSTP=1
End DoDot:3
End DoDot:2
End DoDot:1
+11 QUIT
UNABBLK ;No Exclusive(s) - Verify primary not exclusive with another key(s)
+1 NEW XQKEY,XQNBR,XQMKEY,XQTKEY
+2 SET (XQKEY,XQNBR,XQMKEY,XQTKEY)=""
+3 IF $DATA(^DIC(19.1,XQIEN,0))
Begin DoDot:1
+4 FOR
SET XQKEY=$ORDER(^DIC(19.1,"B",XQKEY))
if XQKEY=""
QUIT
Begin DoDot:2
+5 FOR
SET XQNBR=$ORDER(^DIC(19.1,"B",XQKEY,XQNBR))
if XQNBR=""
QUIT
Begin DoDot:3
+6 IF $DATA(^DIC(19.1,XQNBR,5,"B",XQIEN))
Begin DoDot:4
+7 IF $DATA(^VA(200,XQPRSN,51,XQNBR))
Begin DoDot:5
+8 SET XQMKEY=$$GET1^DIQ(19.1,XQIEN,.01)
+9 SET XQTKEY=$$GET1^DIQ(19.1,XQNBR,.01)
+10 WRITE !!,"You are not AUTHORIZED key '"_XQMKEY_"' with EXCLUSIVE key '"_XQTKEY_"'"
+11 WRITE !,"no action taken",!
+12 SET XQSTP=1
End DoDot:5
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+13 QUIT
EXCLUSE ;Set primary exclusive with another key(s)
+1 NEW DIC,DIE,DA,DR,Y
+2 WRITE !!
+3 SET DIC="19.1"
SET DIC(0)="AEQZ"
SET DIC("A")="Select Primary Allocated Key(s): "
+4 DO ^DIC
if Y=-1
QUIT
Begin DoDot:1
+5 WRITE !
+6 SET DIE="^DIC(19.1,"
SET DR="5"
SET DA=+Y
+7 DO ^DIE
End DoDot:1
+8 QUIT
