- XQ6B ;SFISC/KLD-KEY DISTRIBUTION MUTUALLY EXCLUSION KEYS;4/05/00 [ 07/29/2004 9:01 AM ]
- ;;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
- XQ6B ;SFISC/KLD-KEY DISTRIBUTION MUTUALLY EXCLUSION KEYS;4/05/00 [ 07/29/2004 9:01 AM ]
- +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
