XUSEHRM1 ; BA/OAK - EHRM REVERSED LOCK -ASSIGN AND REMOVE; Jan 19, 2022@08:07:01
;;8.0;KERNEL;**758**;Jul 10, 1995;Build 17
;;Per VHA Directive 2004-038, this routine should not be modified
Q
1 ; assign a Program Replacement Key to all users
N XUSASK,XUSDVSION,XUSKEY,XUDUZ,XUANS,XUSER,DIR,XUEXIT,ZTSK
S XUSDUZ=$G(DUZ,.5),XUSER="",XUSDVSION="",XUSKEY="",XUEXIT=""
S XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to assign to VistA users? ") I XUSKEY'>0 G END
S XUSKEY=$P($G(^DIC(19.1,XUSKEY,0)),"^")
SET DIR(0)="SA^U:User(s);D:Division(s);A:All users;Q:Quit",DIR("A")="Do you want to select (U)sers, (D)ivisions, (A)ll users, (Q)uit: ",DIR("B")="D"
W ! D ^DIR S XUANS=Y
K DIR
IF XUANS="^" Q
IF XUANS="Q" Q
IF XUANS="U" D
. S XUSER=$$U1("NULL") I +XUSER'>0 S XUEXIT=1 Q
. W !
. N Y,X,DIR
. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to the users" D ^DIR
. K DIR I +$G(Y)'>0 S XUEXIT=1 Q
IF XUANS="D" D
. S XUSDVSION=$$D1("NULL") I +XUSDVSION'>0 S XUEXIT=1 Q
. W !!!,"Chosen Division(s):"
. W !,"-------------------"
. D LISTDVS(XUSDVSION)
. W !
. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to VistA users at above Division(s): " D ^DIR K DIR
. I +Y'>0 S XUEXIT=1 Q
. Q
IF XUANS="A" S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to ALL VistA users" D ^DIR K DIR I +Y'>0 S XUEXIT=1 Q
I XUEXIT=1 Q
; Start Queue process
S ZTRTN="ASSIGN^XUSEHRM1",ZTIO="" ;queue the process
S ZTSAVE("XUSKEY")="",ZTSAVE("XUSDVSION")="",ZTSAVE("XUDUZ")="",ZTSAVE("XUSER")="",ZTSAVE("XUANS")=""
S ZTDESC="Assign Keys for users."
D ^%ZTLOAD
I $D(ZTSK) W !!,"Task #: ",ZTSK,!
Q
;-------------------------------------------------------------
U1(XUS) ; select users
N DIC,Y,X,XUTEXT,XUSER1U,XUC1U
S XUTEXT="Select a user: ",XUSER1U="",XUC1U=0
LOOP1U ;
S DIC="^VA(200,",DIC(0)="AEQM" S DIC("A")=XUTEXT D ^DIC
I Y=-1,$G(X)="^" S XUC1U=0
I +Y>0 S XUTEXT="Select another user: ",XUSER1U=XUSER1U_";"_+Y,XUC1U=XUC1U+1 G LOOP1U
Q XUC1U_"^"_$P(XUSER1U,";",2,99)
;------------------------------------------------------------
D1(XUS) ; select Divisions
N DIC,Y,X,XUTEXT,XUSER1D,XUC1D
S XUTEXT="Select a division: ",XUSER1D="",XUC1D=0
LOOP1D ;
S DIC="^DIC(4,",DIC(0)="AEQM" S DIC("A")=XUTEXT D ^DIC
I Y=-1,$G(X)="^" S XUC1D=0
I +Y>0 S XUTEXT="Select another division: ",XUSER1D=XUSER1D_";"_+Y,XUC1D=XUC1D+1 G LOOP1D
Q XUC1D_"^"_$P(XUSER1D,";",2,99)
;--------------------------------------------------------------
2 ; remove a Program Replacement Key from all users
N XUSASK,XUSDVSION,XUSKEY,XUDUZ,XUANS,XUSER,DIR,XUEXIT,ZTSK
S XUSDUZ=$G(DUZ,.5),XUSER="",XUSDVSION="",XUSKEY="",XUEXIT=""
S XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to remove from VistA users? ") I XUSKEY'>0 G END
S XUSKEY=$P($G(^DIC(19.1,XUSKEY,0)),"^")
SET DIR(0)="SA^U:User(s);D:Division(s);A:All users;Q:Quit",DIR("A")="Do you want to select (U)sers, (D)ivisions, (A)ll users, (Q)uit: ",DIR("B")="D"
W ! D ^DIR S XUANS=Y
K DIR
IF XUANS="^" Q
IF XUANS="Q" Q
IF XUANS="U" D
. S XUSER=$$U1("NULL") I +XUSER'>0 S XUEXIT=1 Q
. W !
. N Y,X,DIR
. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from the users" D ^DIR
. K DIR I +$G(Y)'>0 S XUEXIT=1 Q
IF XUANS="D" D
. S XUSDVSION=$$D1("NULL") I +XUSDVSION'>0 S XUEXIT=1 Q
. W !!!,"Chosen Division(s):"
. W !,"-------------------"
. D LISTDVS(XUSDVSION)
. W !
. S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from VistA users at above Division(s): " D ^DIR K DIR
. I +Y'>0 S XUEXIT=1 Q
. Q
IF XUANS="A" S DIR(0)="Y",DIR("B")="YES",DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from ALL VistA users" D ^DIR K DIR I +Y'>0 S XUEXIT=1 Q
; Start Queue process
I XUEXIT=1 Q
S ZTRTN="REMOVE^XUSEHRM1",ZTIO="" ;queue the process
S ZTSAVE("XUSKEY")="",ZTSAVE("XUSDVSION")="",ZTSAVE("XUDUZ")="",ZTSAVE("XUSER")="",ZTSAVE("XUANS")=""
S ZTDESC="Remove Keys from users."
D ^%ZTLOAD
I $D(ZTSK) W !!,"Task #: ",ZTSK,!
Q
;--------------------------------------------------
5 ; set REVERSE/NEGATIVE LOCK field
N XUSKEY,XUSOPTN,XUSKEYN,DIR,XUANS,XUFLAG,ZTSK
SET XUFLAG=0
K ^XUBA758("ACTION758")
SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to assign to options? ") I XUSKEY'>0 Q
SET XUSKEYN=$P($G(^DIC(19.1,XUSKEY,0)),"^")
SET DIR(0)="SA^N:NameSpace;O:Option;Q:Quit",DIR("A")="Do you want to select (N)ameSpaces, (O)ptions, (Q)uit: ",DIR("B")="O"
W ! D ^DIR S XUANS=Y
IF XUANS="^" Q
IF XUANS="N" D NAMESPACE
IF XUANS="O" D OPTION
IF XUANS="Q" Q
I $D(^XUBA758("ACTION758"))'>0 Q
SET ZTRTN="SETLOCKS^XUSEHRM1",ZTIO="" ;queue the process
SET ZTSAVE("XUSKEYN")="",ZTSAVE("^XUBA758")="",ZTSAVE("XUFLAG")=""
SET ZTDESC="Add REVERSE/NEGATIVE LOCK field."
DO ^%ZTLOAD
IF $D(ZTSK) W !!,"Task #: ",ZTSK,!
Q
;----------------------------------------------------
6 ; remove REVERSE/NEGATIVE LOCK field
N XUSKEY,XUSOPTN,XUSKEYN,DIR,XUANS,XUCOUNT,XUFLAG,ZTSK
S XUFLAG=1
K ^XUBA758("ACTION758")
SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to remove from options? ") I XUSKEY'>0 Q
SET XUSKEYN=$P($G(^DIC(19.1,XUSKEY,0)),"^")
SET DIR(0)="SA^N:NameSpace;O:Option;Q:Quit",DIR("A")="Do you want to select (N)ameSpaces, (O)ptions, (Q)uit: ",DIR("B")="O"
W ! D ^DIR S XUANS=Y
IF XUANS="^" Q
IF XUANS="N" D NAMESPACE
IF XUANS="O" D OPTION
IF XUANS="Q" Q
I $D(^XUBA758("ACTION758"))'>0 Q
SET ZTRTN="DELOCKS^XUSEHRM1",ZTIO="" ;queue the process
SET ZTSAVE("XUSKEYN")="",ZTSAVE("^XUBA758")="",ZTSAVE("XUFLAG")=""
SET ZTDESC="Remove REVERSE/NEGATIVE LOCK field."
DO ^%ZTLOAD
IF $D(ZTSK) W !!,"Task #: ",ZTSK,!
Q
;----------------------------------------------------------
YN(XUSTEXT) ; ask yes no question
N DIR,Y
S DIR(0)="Y",DIR("B")="YES",DIR("A")=XUSTEXT D ^DIR K DIR
Q Y
;------------------------------------------------------
SELECOP(XUSTEXT,ACTION) ; select Option in the Option file
; ACTION is "ACTION758" or "NOACTION758"
N DIC,Y,XUCOUNT
K ^XUBA758(ACTION)
S XUCOUNT=0
LOOP1 ;
S DIC="^DIC(19,",DIC(0)="AEQ" S DIC("A")=XUSTEXT D ^DIC
I Y=-1,$G(X)="^" G END
I Y>0 D
. I ACTION="NOACTION758" S ^XUBA758(ACTION,$J,+Y)="" G LOOP1
. I ACTION="ACTION758" S XUCOUNT=XUCOUNT+1,^XUBA758(ACTION,$J,XUCOUNT)=Y G LOOP1
Q XUCOUNT
;-------------------------------------------------------
LISTDVS(XUSDVSION) ; List the chosen DIVISIONS
N XUS,XUS1,XUS2,XUS3
S XUS=$P(XUSDVSION,"^")
S XUS1=$P(XUSDVSION,"^",2,99)
F XUS2=1:1:XUS D
. S XUS3=$P(XUS1,";",XUS2) W !,$P($G(^DIC(4,XUS3,0)),"^")
Q
;----------------------------------------------------------
ASKKEY(XUSTEXT) ; select REPLACEMENT Keys
N DIC,Y
BACK ;
S DIC="^DIC(19.1,",DIC(0)="AEQ" S DIC("A")=XUSTEXT D ^DIC I Y'>0 Q Y
I Y'["REPLACEMENT" W !!,"Invalid Program Replacement Key, it must contain <REPLACEMENT>",! G BACK
Q Y
;----------------------------------------------------------
ASSDVS(XUSIEN4) ; set Key for user in specific one Division XUSIEN4 is the IEN in the INSTITUTION file.
N XUS S XUS=0
F S XUS=$O(^VA(200,"AH",XUSIEN4,XUS)) Q:XUS'>0 D
. I $D(^VA(200,XUS,0))'>0 Q
. I $D(^XUSEC(XUSKEY,XUS))>0 Q ; prevent a user has mutiple divisions
. D SETKEY(XUS,XUSKEY)
. I $D(^XUSEC(XUSKEY,XUS))>0 S XUCN=XUCN+1
Q
;---------------------------------------------------------
ASSIGN ; assign the Program Replacement Key to all users
N XUS,XUCN,XUSD1,XUSD2,XUI,XUSIEN4,XUIEN
S XUS=0,XUCN=0
S XUDUZ=$G(XUDUZ,DUZ),XUANS=$G(XUANS),XUSDVSION=$G(XUSDVSION),XUSER=$G(XUSER)
I XUANS="D" D
. S XUSD1=$P(XUSDVSION,"^"),XUSD2=$P(XUSDVSION,"^",2)
. F XUI=1:1:XUSD1 S XUSIEN4=$P(XUSD2,";",XUI) D ASSDVS(XUSIEN4)
I XUANS="U" D
. S XUSC1=$P(XUSER,"^"),XUSC2=$P(XUSER,"^",2)
. F XUI=1:1:XUSC1 S XUIEN=$P(XUSC2,";",XUI) D SETKEY(XUIEN,XUSKEY)
. S XUCN=XUSC1
I XUANS="A" D
. F S XUS=$O(^VA(200,XUS)) Q:XUS'>0 D
.. I $D(^VA(200,XUS,0))'>0
.. D SETKEY(XUS,XUSKEY)
.. I $D(^XUSEC(XUSKEY,XUS))>0 S XUCN=XUCN+1
D SENDALERT(XUDUZ,XUSKEY,"Assigned",XUCN)
K XUDUZ,XUSKEY,XUSER,XUANS
Q
;-----------------------------------------------------------
SETKEY(XUS,XUSKEY) ;assign a Program Replacement Key for a user
N IENS,XUSKEYN,ERR
K FDA
S IENS="?+2,"_XUS_","
S FDA(200.051,IENS,.01)=XUSKEY
D UPDATE^DIE("E","FDA",,"ERR")
Q
;-----------------------------------------------------------
DELKEY(XUIEN,KEY) ;delete a Program Replacement Key for a user
N DIK,DA S DA(1)=XUIEN,DA=KEY,DIK="^VA(200,"_DA(1)_",51," D ^DIK
Q
;-----------------------------------------------------------
REMDVS(XUSIEN4) ; remove Program Replacement Key for users at specific one Division
N XUS S XUS=0
F S XUS=$O(^VA(200,"AH",XUSIEN4,XUS)) Q:XUS'>0 D
. I +$D(^XUSEC(XUSKEY,XUS))>0 D DELKEY(XUS,XUSKEY1) S XUCN=XUCN+1
Q
;-----------------------------------------------------------
REMOVE ;remove a Program Replacement Key from all users
N XUS,XUCN,XUSD1,XUSD2,XUI,XUSIEN4,XUIEN,XUSKEY1
S XUS=0,XUCN=0
S XUSKEY1=+$O(^DIC(19.1,"B",XUSKEY,0))
I XUSKEY1'>0 Q
S XUDUZ=$G(XUDUZ,DUZ),XUANS=$G(XUANS),XUSDVSION=$G(XUSDVSION),XUSER=$G(XUSER)
I XUANS="D" D
. S XUSD1=$P(XUSDVSION,"^"),XUSD2=$P(XUSDVSION,"^",2)
. F XUI=1:1:XUSD1 S XUSIEN4=$P(XUSD2,";",XUI) D REMDVS(XUSIEN4)
I XUANS="U" D
. S XUSC1=$P(XUSER,"^"),XUSC2=$P(XUSER,"^",2)
. F XUI=1:1:XUSC1 S XUIEN=$P(XUSC2,";",XUI) D DELKEY(XUIEN,XUSKEY1)
. S XUCN=XUSC1
I XUANS="A" D
. F S XUS=$O(^XUSEC(XUSKEY,XUS)) Q:XUS'>0 D
.. I $D(^VA(200,XUS,0))'>0
.. D DELKEY(XUS,XUSKEY1) S XUCN=XUCN+1
D SENDALERT(XUDUZ,XUSKEY,"Removed",XUCN)
K XUDUZ,XUSKEY,XUSER,XUANS
Q
;------------------------------------------------------------
GETOPTION(XUSOPTN,XUCOUNT) ;
N XUOPTIEN,XUOPTIEN1
S XUOPTIEN=0
K OUT758
S XUSOPTN=$P($G(XUSOPTN),"*")
;I XUSOPTN="" Q XUCOUNT
D LIST^DIC(19,"","","",,XUSOPTN,XUSOPTN,"","","","OUT758")
S OUT758("DILIST",1,.1)=XUSOPTN
F S XUOPTIEN=$O(OUT758("DILIST",1,XUOPTIEN)) Q:+XUOPTIEN'>0 D
. S XUOPNAME=$G(OUT758("DILIST",1,XUOPTIEN)) Q:XUOPNAME=""
. S XUOPTIEN1=$O(^DIC(19,"B",XUOPNAME,0)) Q:XUOPTIEN1'>0
. S XUCOUNT=XUCOUNT+1,^XUBA758("ACTION758",$J,XUCOUNT)=XUOPTIEN1_"^"_XUOPNAME
Q XUCOUNT
;------------------------------------------------------------
NAMESPACE ; Set Reversed Lock for NameSpaces
N XUCOUNT,XU3
S XUCOUNT=0
S XUCOUNT=$$ASKNAMESP("Please select a NameSpace") Q:XUCOUNT=0
S XUS3=$$PRINTOPTION(XUCOUNT,XUFLAG)
I XUS3=0 G END
D EXCLUDE
Q
;----------------------------------------------------------
OPTION ;Set Reversed Lock for Options
N XUCOUNT,XU3
S XUCOUNT=$$SELECOP("Select an option: ","ACTION758")
S XUS3=$$PRINTOPTION(XUCOUNT,XUFLAG)
I XUS3=0 G END
D EXCLUDE
Q
;-----------------------------------------------------------
ASKNAMESP(XUSTEXT) ; ask NameSpaces
N DIR,Y,XUCOUNT,XUNEXT
S XUCOUNT=0
K ^XUBA758("ACTION758")
LOOPN ;
S DIR(0)="FO^1:30",DIR("A")=$G(XUNEXT,XUSTEXT),DIR("?")="You may select a NameSpace* such as TIU* or one or more option names such as TIU MAIN MENU MGR, TIU MAIN MENU MRT"
D ^DIR K DIR
I Y="*" S XUNEXT="Invalid NameSpace, please choose another NameSpace. For example TIU*" G LOOPN
I Y'="^",Y'="" S XUCOUNT=$$GETOPTION(Y,XUCOUNT) S XUNEXT="Another NameSpace" G LOOPN
W !
Q XUCOUNT
;----------------------------------------------------------
PRINTOPTION(XUCOUNT,XUFLAG) ; list options and ask users if they want to remove any options from the list.
N XUI,XUY,XUZ,XU2,XU3
S XUY="",XUZ=0,XU3=0
K ^XUBA758("NOACTON758")
W !,"Option list :"
W !,"-----------------"
F XUI=1:1:XUCOUNT D
. S XUY=$P($G(^XUBA758("ACTION758",$J,XUI)),"^",2),XUY1=+$P($G(^XUBA758("ACTION758",$J,XUI)),"^")
. I XUY1,XUFLAG=1,$P($G(^DIC(19,XUY1,3)),"^")'=XUSKEYN Q
. S XUZ=XUZ+1,XU2=XUZ/2
. I $P(XU2,".",2)=5 W !,XUY S XU3=XU3+1 Q
. W ?40,XUY
. S XU3=XU3+1
. Q
N XUOPTION,XUARE
S XUOPTION="option",XUARE="is"
IF XU3>1 S XUOPTION="options",XUARE="are"
W !!,"There ",XUARE," ",XU3," ",XUOPTION," from the list above."
Q XU3
;------------------------------------------------------------
EXCLUDE ; remove options from the list
N ANS,XUN
S ANS=$$YN("Do you want to remove any options from the list above")
I ANS=0 Q
I ANS="^" G END
W !
S XUN=$$SELECOP("Select an option: ","NOACTION758")
W !
Q
;-----------------------------------------------------------
END ;
K ^XUBA758("ACTION758")
K ^XUBA758("NOACTION758")
Q
END1 ;
;-----------------------------------------------------------
SETLOCKS ; set REVERSE/NEGATIVE LOCK for options
N XUOPTIEN,XUSECOND
S XUI=0,XUSECOND=$O(^XUBA758("ACTION758",0)) I XUSECOND'>0 Q
F S XUI=$O(^XUBA758("ACTION758",XUSECOND,XUI)) Q:XUI'>0 D
. S XUOPTIEN=+$G(^XUBA758("ACTION758",XUSECOND,XUI))
. I XUOPTIEN="" Q
. I $D(^XUBA758("NOACTION758",XUSECOND,XUOPTIEN)) Q
. D SETLOCK(XUOPTIEN) ;set REVERSE/NEGATIVE LOCK
D END
Q
;-------------------------------------------------------------
SETLOCK(XUOPTIEN) ; set REVERSE/NEGATIVE LOCK for an option
N DR,DIE
S DIE="^DIC(19,",DA=XUOPTIEN
S DR="3.01////^S X=XUSKEYN"
D ^DIE
Q
;--------------------------------------------------------------
DELOCKS ;remove REVERSE/NEGATIVE LOCK for options
N XUOPTIEN,XUSECOND
S XUI=0,XUSECOND=$O(^XUBA758("ACTION758",0)) I XUSECOND'>0 Q
F S XUI=$O(^XUBA758("ACTION758",XUSECOND,XUI)) Q:XUI'>0 D
. S XUOPTIEN=+$G(^XUBA758("ACTION758",XUSECOND,XUI))
. I XUOPTIEN'>0 Q
. I $P($G(^DIC(19,XUOPTIEN,3)),"^")'=XUSKEYN Q
. I $D(^XUBA758("NOACTION758",XUSECOND,XUOPTIEN)) Q
. D DELOCK(XUOPTIEN) ;remove REVERSE/NEGATIVE LOCK
D END
Q
;--------------------------------------------------------------
DELOCK(XUOPTIEN) ; remove REVERSE/NEGATIVE LOCK for an option
N DR,DIE,XUSKEYN
S XUSKEYN="@"
S DIE="^DIC(19,",DA=XUOPTIEN
S DR="3.01////^S X=XUSKEYN"
D ^DIE
Q
;--------------------------------------------------------------
SENDALERT(XUDUZ,XUKEY,STATUS,XUCN) ; send alert to user
;XUDUZ is IEN of user
;XUKEY is Replacement Key
;STATUS is Assign or Remoe
;XUCN is number of users
N XQA,XQAARCH,XQADATA,XQAFLG,XQAGUID,XQAID,XQAMSG,XQAOPT,XQAROU,XQASUPV,XQASURO,XQATEXT,XQALERR,XQVAR
N XUDATE S XUDATE=$$NOW^XLFDT,XUDATE=$$FMTE^XLFDT(XUDATE,1)
S XQA(XUDUZ)="" ; recipient is user
S XQAMSG=XUCN_" users are "_STATUS_" the Program Replacement Key "_XUKEY_" on "_XUDATE_"."
S XQVAR=$$SETUP1^XQALERT I $G(XQALERR)'="" W !,"ERROR IN ALERT: ",XQALERR
Q
;---------------------------------------------------------------
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXUSEHRM1 14881 printed Sep 23, 2025@19:48:32 Page 2
XUSEHRM1 ; BA/OAK - EHRM REVERSED LOCK -ASSIGN AND REMOVE; Jan 19, 2022@08:07:01
+1 ;;8.0;KERNEL;**758**;Jul 10, 1995;Build 17
+2 ;;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
1 ; assign a Program Replacement Key to all users
+1 NEW XUSASK,XUSDVSION,XUSKEY,XUDUZ,XUANS,XUSER,DIR,XUEXIT,ZTSK
+2 SET XUSDUZ=$GET(DUZ,.5)
SET XUSER=""
SET XUSDVSION=""
SET XUSKEY=""
SET XUEXIT=""
+3 SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to assign to VistA users? ")
IF XUSKEY'>0
GOTO END
+4 SET XUSKEY=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+5 SET DIR(0)="SA^U:User(s);D:Division(s);A:All users;Q:Quit"
SET DIR("A")="Do you want to select (U)sers, (D)ivisions, (A)ll users, (Q)uit: "
SET DIR("B")="D"
+6 WRITE !
DO ^DIR
SET XUANS=Y
+7 KILL DIR
+8 IF XUANS="^"
QUIT
+9 IF XUANS="Q"
QUIT
+10 IF XUANS="U"
Begin DoDot:1
+11 SET XUSER=$$U1("NULL")
IF +XUSER'>0
SET XUEXIT=1
QUIT
+12 WRITE !
+13 NEW Y,X,DIR
+14 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to the users"
DO ^DIR
+15 KILL DIR
IF +$GET(Y)'>0
SET XUEXIT=1
QUIT
End DoDot:1
+16 IF XUANS="D"
Begin DoDot:1
+17 SET XUSDVSION=$$D1("NULL")
IF +XUSDVSION'>0
SET XUEXIT=1
QUIT
+18 WRITE !!!,"Chosen Division(s):"
+19 WRITE !,"-------------------"
+20 DO LISTDVS(XUSDVSION)
+21 WRITE !
+22 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to VistA users at above Division(s): "
DO ^DIR
KILL DIR
+23 IF +Y'>0
SET XUEXIT=1
QUIT
+24 QUIT
End DoDot:1
+25 IF XUANS="A"
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to assign the Program Replacement Key <"_XUSKEY_"> to ALL VistA users"
DO ^DIR
KILL DIR
IF +Y'>0
SET XUEXIT=1
QUIT
+26 IF XUEXIT=1
QUIT
+27 ; Start Queue process
+28 ;queue the process
SET ZTRTN="ASSIGN^XUSEHRM1"
SET ZTIO=""
+29 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSDVSION")=""
SET ZTSAVE("XUDUZ")=""
SET ZTSAVE("XUSER")=""
SET ZTSAVE("XUANS")=""
+30 SET ZTDESC="Assign Keys for users."
+31 DO ^%ZTLOAD
+32 IF $DATA(ZTSK)
WRITE !!,"Task #: ",ZTSK,!
+33 QUIT
+34 ;-------------------------------------------------------------
U1(XUS) ; select users
+1 NEW DIC,Y,X,XUTEXT,XUSER1U,XUC1U
+2 SET XUTEXT="Select a user: "
SET XUSER1U=""
SET XUC1U=0
LOOP1U ;
+1 SET DIC="^VA(200,"
SET DIC(0)="AEQM"
SET DIC("A")=XUTEXT
DO ^DIC
+2 IF Y=-1
IF $GET(X)="^"
SET XUC1U=0
+3 IF +Y>0
SET XUTEXT="Select another user: "
SET XUSER1U=XUSER1U_";"_+Y
SET XUC1U=XUC1U+1
GOTO LOOP1U
+4 QUIT XUC1U_"^"_$PIECE(XUSER1U,";",2,99)
+5 ;------------------------------------------------------------
D1(XUS) ; select Divisions
+1 NEW DIC,Y,X,XUTEXT,XUSER1D,XUC1D
+2 SET XUTEXT="Select a division: "
SET XUSER1D=""
SET XUC1D=0
LOOP1D ;
+1 SET DIC="^DIC(4,"
SET DIC(0)="AEQM"
SET DIC("A")=XUTEXT
DO ^DIC
+2 IF Y=-1
IF $GET(X)="^"
SET XUC1D=0
+3 IF +Y>0
SET XUTEXT="Select another division: "
SET XUSER1D=XUSER1D_";"_+Y
SET XUC1D=XUC1D+1
GOTO LOOP1D
+4 QUIT XUC1D_"^"_$PIECE(XUSER1D,";",2,99)
+5 ;--------------------------------------------------------------
2 ; remove a Program Replacement Key from all users
+1 NEW XUSASK,XUSDVSION,XUSKEY,XUDUZ,XUANS,XUSER,DIR,XUEXIT,ZTSK
+2 SET XUSDUZ=$GET(DUZ,.5)
SET XUSER=""
SET XUSDVSION=""
SET XUSKEY=""
SET XUEXIT=""
+3 SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to remove from VistA users? ")
IF XUSKEY'>0
GOTO END
+4 SET XUSKEY=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+5 SET DIR(0)="SA^U:User(s);D:Division(s);A:All users;Q:Quit"
SET DIR("A")="Do you want to select (U)sers, (D)ivisions, (A)ll users, (Q)uit: "
SET DIR("B")="D"
+6 WRITE !
DO ^DIR
SET XUANS=Y
+7 KILL DIR
+8 IF XUANS="^"
QUIT
+9 IF XUANS="Q"
QUIT
+10 IF XUANS="U"
Begin DoDot:1
+11 SET XUSER=$$U1("NULL")
IF +XUSER'>0
SET XUEXIT=1
QUIT
+12 WRITE !
+13 NEW Y,X,DIR
+14 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from the users"
DO ^DIR
+15 KILL DIR
IF +$GET(Y)'>0
SET XUEXIT=1
QUIT
End DoDot:1
+16 IF XUANS="D"
Begin DoDot:1
+17 SET XUSDVSION=$$D1("NULL")
IF +XUSDVSION'>0
SET XUEXIT=1
QUIT
+18 WRITE !!!,"Chosen Division(s):"
+19 WRITE !,"-------------------"
+20 DO LISTDVS(XUSDVSION)
+21 WRITE !
+22 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from VistA users at above Division(s): "
DO ^DIR
KILL DIR
+23 IF +Y'>0
SET XUEXIT=1
QUIT
+24 QUIT
End DoDot:1
+25 IF XUANS="A"
SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")="Are you ready to remove the Program Replacement Key <"_XUSKEY_"> from ALL VistA users"
DO ^DIR
KILL DIR
IF +Y'>0
SET XUEXIT=1
QUIT
+26 ; Start Queue process
+27 IF XUEXIT=1
QUIT
+28 ;queue the process
SET ZTRTN="REMOVE^XUSEHRM1"
SET ZTIO=""
+29 SET ZTSAVE("XUSKEY")=""
SET ZTSAVE("XUSDVSION")=""
SET ZTSAVE("XUDUZ")=""
SET ZTSAVE("XUSER")=""
SET ZTSAVE("XUANS")=""
+30 SET ZTDESC="Remove Keys from users."
+31 DO ^%ZTLOAD
+32 IF $DATA(ZTSK)
WRITE !!,"Task #: ",ZTSK,!
+33 QUIT
+34 ;--------------------------------------------------
5 ; set REVERSE/NEGATIVE LOCK field
+1 NEW XUSKEY,XUSOPTN,XUSKEYN,DIR,XUANS,XUFLAG,ZTSK
+2 SET XUFLAG=0
+3 KILL ^XUBA758("ACTION758")
+4 SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to assign to options? ")
IF XUSKEY'>0
QUIT
+5 SET XUSKEYN=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+6 SET DIR(0)="SA^N:NameSpace;O:Option;Q:Quit"
SET DIR("A")="Do you want to select (N)ameSpaces, (O)ptions, (Q)uit: "
SET DIR("B")="O"
+7 WRITE !
DO ^DIR
SET XUANS=Y
+8 IF XUANS="^"
QUIT
+9 IF XUANS="N"
DO NAMESPACE
+10 IF XUANS="O"
DO OPTION
+11 IF XUANS="Q"
QUIT
+12 IF $DATA(^XUBA758("ACTION758"))'>0
QUIT
+13 ;queue the process
SET ZTRTN="SETLOCKS^XUSEHRM1"
SET ZTIO=""
+14 SET ZTSAVE("XUSKEYN")=""
SET ZTSAVE("^XUBA758")=""
SET ZTSAVE("XUFLAG")=""
+15 SET ZTDESC="Add REVERSE/NEGATIVE LOCK field."
+16 DO ^%ZTLOAD
+17 IF $DATA(ZTSK)
WRITE !!,"Task #: ",ZTSK,!
+18 QUIT
+19 ;----------------------------------------------------
6 ; remove REVERSE/NEGATIVE LOCK field
+1 NEW XUSKEY,XUSOPTN,XUSKEYN,DIR,XUANS,XUCOUNT,XUFLAG,ZTSK
+2 SET XUFLAG=1
+3 KILL ^XUBA758("ACTION758")
+4 SET XUSKEY=+$$ASKKEY("What Program Replacement Key do you want to remove from options? ")
IF XUSKEY'>0
QUIT
+5 SET XUSKEYN=$PIECE($GET(^DIC(19.1,XUSKEY,0)),"^")
+6 SET DIR(0)="SA^N:NameSpace;O:Option;Q:Quit"
SET DIR("A")="Do you want to select (N)ameSpaces, (O)ptions, (Q)uit: "
SET DIR("B")="O"
+7 WRITE !
DO ^DIR
SET XUANS=Y
+8 IF XUANS="^"
QUIT
+9 IF XUANS="N"
DO NAMESPACE
+10 IF XUANS="O"
DO OPTION
+11 IF XUANS="Q"
QUIT
+12 IF $DATA(^XUBA758("ACTION758"))'>0
QUIT
+13 ;queue the process
SET ZTRTN="DELOCKS^XUSEHRM1"
SET ZTIO=""
+14 SET ZTSAVE("XUSKEYN")=""
SET ZTSAVE("^XUBA758")=""
SET ZTSAVE("XUFLAG")=""
+15 SET ZTDESC="Remove REVERSE/NEGATIVE LOCK field."
+16 DO ^%ZTLOAD
+17 IF $DATA(ZTSK)
WRITE !!,"Task #: ",ZTSK,!
+18 QUIT
+19 ;----------------------------------------------------------
YN(XUSTEXT) ; ask yes no question
+1 NEW DIR,Y
+2 SET DIR(0)="Y"
SET DIR("B")="YES"
SET DIR("A")=XUSTEXT
DO ^DIR
KILL DIR
+3 QUIT Y
+4 ;------------------------------------------------------
SELECOP(XUSTEXT,ACTION) ; select Option in the Option file
+1 ; ACTION is "ACTION758" or "NOACTION758"
+2 NEW DIC,Y,XUCOUNT
+3 KILL ^XUBA758(ACTION)
+4 SET XUCOUNT=0
LOOP1 ;
+1 SET DIC="^DIC(19,"
SET DIC(0)="AEQ"
SET DIC("A")=XUSTEXT
DO ^DIC
+2 IF Y=-1
IF $GET(X)="^"
GOTO END
+3 IF Y>0
Begin DoDot:1
+4 IF ACTION="NOACTION758"
SET ^XUBA758(ACTION,$JOB,+Y)=""
GOTO LOOP1
+5 IF ACTION="ACTION758"
SET XUCOUNT=XUCOUNT+1
SET ^XUBA758(ACTION,$JOB,XUCOUNT)=Y
GOTO LOOP1
End DoDot:1
+6 QUIT XUCOUNT
+7 ;-------------------------------------------------------
LISTDVS(XUSDVSION) ; List the chosen DIVISIONS
+1 NEW XUS,XUS1,XUS2,XUS3
+2 SET XUS=$PIECE(XUSDVSION,"^")
+3 SET XUS1=$PIECE(XUSDVSION,"^",2,99)
+4 FOR XUS2=1:1:XUS
Begin DoDot:1
+5 SET XUS3=$PIECE(XUS1,";",XUS2)
WRITE !,$PIECE($GET(^DIC(4,XUS3,0)),"^")
End DoDot:1
+6 QUIT
+7 ;----------------------------------------------------------
ASKKEY(XUSTEXT) ; select REPLACEMENT Keys
+1 NEW DIC,Y
BACK ;
+1 SET DIC="^DIC(19.1,"
SET DIC(0)="AEQ"
SET DIC("A")=XUSTEXT
DO ^DIC
IF Y'>0
QUIT Y
+2 IF Y'["REPLACEMENT"
WRITE !!,"Invalid Program Replacement Key, it must contain <REPLACEMENT>",!
GOTO BACK
+3 QUIT Y
+4 ;----------------------------------------------------------
ASSDVS(XUSIEN4) ; set Key for user in specific one Division XUSIEN4 is the IEN in the INSTITUTION file.
+1 NEW XUS
SET XUS=0
+2 FOR
SET XUS=$ORDER(^VA(200,"AH",XUSIEN4,XUS))
if XUS'>0
QUIT
Begin DoDot:1
+3 IF $DATA(^VA(200,XUS,0))'>0
QUIT
+4 ; prevent a user has mutiple divisions
IF $DATA(^XUSEC(XUSKEY,XUS))>0
QUIT
+5 DO SETKEY(XUS,XUSKEY)
+6 IF $DATA(^XUSEC(XUSKEY,XUS))>0
SET XUCN=XUCN+1
End DoDot:1
+7 QUIT
+8 ;---------------------------------------------------------
ASSIGN ; assign the Program Replacement Key to all users
+1 NEW XUS,XUCN,XUSD1,XUSD2,XUI,XUSIEN4,XUIEN
+2 SET XUS=0
SET XUCN=0
+3 SET XUDUZ=$GET(XUDUZ,DUZ)
SET XUANS=$GET(XUANS)
SET XUSDVSION=$GET(XUSDVSION)
SET XUSER=$GET(XUSER)
+4 IF XUANS="D"
Begin DoDot:1
+5 SET XUSD1=$PIECE(XUSDVSION,"^")
SET XUSD2=$PIECE(XUSDVSION,"^",2)
+6 FOR XUI=1:1:XUSD1
SET XUSIEN4=$PIECE(XUSD2,";",XUI)
DO ASSDVS(XUSIEN4)
End DoDot:1
+7 IF XUANS="U"
Begin DoDot:1
+8 SET XUSC1=$PIECE(XUSER,"^")
SET XUSC2=$PIECE(XUSER,"^",2)
+9 FOR XUI=1:1:XUSC1
SET XUIEN=$PIECE(XUSC2,";",XUI)
DO SETKEY(XUIEN,XUSKEY)
+10 SET XUCN=XUSC1
End DoDot:1
+11 IF XUANS="A"
Begin DoDot:1
+12 FOR
SET XUS=$ORDER(^VA(200,XUS))
if XUS'>0
QUIT
Begin DoDot:2
+13 IF $DATA(^VA(200,XUS,0))'>0
+14 DO SETKEY(XUS,XUSKEY)
+15 IF $DATA(^XUSEC(XUSKEY,XUS))>0
SET XUCN=XUCN+1
End DoDot:2
End DoDot:1
+16 DO SENDALERT(XUDUZ,XUSKEY,"Assigned",XUCN)
+17 KILL XUDUZ,XUSKEY,XUSER,XUANS
+18 QUIT
+19 ;-----------------------------------------------------------
SETKEY(XUS,XUSKEY) ;assign a Program Replacement Key for a user
+1 NEW IENS,XUSKEYN,ERR
+2 KILL FDA
+3 SET IENS="?+2,"_XUS_","
+4 SET FDA(200.051,IENS,.01)=XUSKEY
+5 DO UPDATE^DIE("E","FDA",,"ERR")
+6 QUIT
+7 ;-----------------------------------------------------------
DELKEY(XUIEN,KEY) ;delete a Program Replacement Key for a user
+1 NEW DIK,DA
SET DA(1)=XUIEN
SET DA=KEY
SET DIK="^VA(200,"_DA(1)_",51,"
DO ^DIK
+2 QUIT
+3 ;-----------------------------------------------------------
REMDVS(XUSIEN4) ; remove Program Replacement Key for users at specific one Division
+1 NEW XUS
SET XUS=0
+2 FOR
SET XUS=$ORDER(^VA(200,"AH",XUSIEN4,XUS))
if XUS'>0
QUIT
Begin DoDot:1
+3 IF +$DATA(^XUSEC(XUSKEY,XUS))>0
DO DELKEY(XUS,XUSKEY1)
SET XUCN=XUCN+1
End DoDot:1
+4 QUIT
+5 ;-----------------------------------------------------------
REMOVE ;remove a Program Replacement Key from all users
+1 NEW XUS,XUCN,XUSD1,XUSD2,XUI,XUSIEN4,XUIEN,XUSKEY1
+2 SET XUS=0
SET XUCN=0
+3 SET XUSKEY1=+$ORDER(^DIC(19.1,"B",XUSKEY,0))
+4 IF XUSKEY1'>0
QUIT
+5 SET XUDUZ=$GET(XUDUZ,DUZ)
SET XUANS=$GET(XUANS)
SET XUSDVSION=$GET(XUSDVSION)
SET XUSER=$GET(XUSER)
+6 IF XUANS="D"
Begin DoDot:1
+7 SET XUSD1=$PIECE(XUSDVSION,"^")
SET XUSD2=$PIECE(XUSDVSION,"^",2)
+8 FOR XUI=1:1:XUSD1
SET XUSIEN4=$PIECE(XUSD2,";",XUI)
DO REMDVS(XUSIEN4)
End DoDot:1
+9 IF XUANS="U"
Begin DoDot:1
+10 SET XUSC1=$PIECE(XUSER,"^")
SET XUSC2=$PIECE(XUSER,"^",2)
+11 FOR XUI=1:1:XUSC1
SET XUIEN=$PIECE(XUSC2,";",XUI)
DO DELKEY(XUIEN,XUSKEY1)
+12 SET XUCN=XUSC1
End DoDot:1
+13 IF XUANS="A"
Begin DoDot:1
+14 FOR
SET XUS=$ORDER(^XUSEC(XUSKEY,XUS))
if XUS'>0
QUIT
Begin DoDot:2
+15 IF $DATA(^VA(200,XUS,0))'>0
+16 DO DELKEY(XUS,XUSKEY1)
SET XUCN=XUCN+1
End DoDot:2
End DoDot:1
+17 DO SENDALERT(XUDUZ,XUSKEY,"Removed",XUCN)
+18 KILL XUDUZ,XUSKEY,XUSER,XUANS
+19 QUIT
+20 ;------------------------------------------------------------
GETOPTION(XUSOPTN,XUCOUNT) ;
+1 NEW XUOPTIEN,XUOPTIEN1
+2 SET XUOPTIEN=0
+3 KILL OUT758
+4 SET XUSOPTN=$PIECE($GET(XUSOPTN),"*")
+5 ;I XUSOPTN="" Q XUCOUNT
+6 DO LIST^DIC(19,"","","",,XUSOPTN,XUSOPTN,"","","","OUT758")
+7 SET OUT758("DILIST",1,.1)=XUSOPTN
+8 FOR
SET XUOPTIEN=$ORDER(OUT758("DILIST",1,XUOPTIEN))
if +XUOPTIEN'>0
QUIT
Begin DoDot:1
+9 SET XUOPNAME=$GET(OUT758("DILIST",1,XUOPTIEN))
if XUOPNAME=""
QUIT
+10 SET XUOPTIEN1=$ORDER(^DIC(19,"B",XUOPNAME,0))
if XUOPTIEN1'>0
QUIT
+11 SET XUCOUNT=XUCOUNT+1
SET ^XUBA758("ACTION758",$JOB,XUCOUNT)=XUOPTIEN1_"^"_XUOPNAME
End DoDot:1
+12 QUIT XUCOUNT
+13 ;------------------------------------------------------------
NAMESPACE ; Set Reversed Lock for NameSpaces
+1 NEW XUCOUNT,XU3
+2 SET XUCOUNT=0
+3 SET XUCOUNT=$$ASKNAMESP("Please select a NameSpace")
if XUCOUNT=0
QUIT
+4 SET XUS3=$$PRINTOPTION(XUCOUNT,XUFLAG)
+5 IF XUS3=0
GOTO END
+6 DO EXCLUDE
+7 QUIT
+8 ;----------------------------------------------------------
OPTION ;Set Reversed Lock for Options
+1 NEW XUCOUNT,XU3
+2 SET XUCOUNT=$$SELECOP("Select an option: ","ACTION758")
+3 SET XUS3=$$PRINTOPTION(XUCOUNT,XUFLAG)
+4 IF XUS3=0
GOTO END
+5 DO EXCLUDE
+6 QUIT
+7 ;-----------------------------------------------------------
ASKNAMESP(XUSTEXT) ; ask NameSpaces
+1 NEW DIR,Y,XUCOUNT,XUNEXT
+2 SET XUCOUNT=0
+3 KILL ^XUBA758("ACTION758")
LOOPN ;
+1 SET DIR(0)="FO^1:30"
SET DIR("A")=$GET(XUNEXT,XUSTEXT)
SET DIR("?")="You may select a NameSpace* such as TIU* or one or more option names such as TIU MAIN MENU MGR, TIU MAIN MENU MRT"
+2 DO ^DIR
KILL DIR
+3 IF Y="*"
SET XUNEXT="Invalid NameSpace, please choose another NameSpace. For example TIU*"
GOTO LOOPN
+4 IF Y'="^"
IF Y'=""
SET XUCOUNT=$$GETOPTION(Y,XUCOUNT)
SET XUNEXT="Another NameSpace"
GOTO LOOPN
+5 WRITE !
+6 QUIT XUCOUNT
+7 ;----------------------------------------------------------
PRINTOPTION(XUCOUNT,XUFLAG) ; list options and ask users if they want to remove any options from the list.
+1 NEW XUI,XUY,XUZ,XU2,XU3
+2 SET XUY=""
SET XUZ=0
SET XU3=0
+3 KILL ^XUBA758("NOACTON758")
+4 WRITE !,"Option list :"
+5 WRITE !,"-----------------"
+6 FOR XUI=1:1:XUCOUNT
Begin DoDot:1
+7 SET XUY=$PIECE($GET(^XUBA758("ACTION758",$JOB,XUI)),"^",2)
SET XUY1=+$PIECE($GET(^XUBA758("ACTION758",$JOB,XUI)),"^")
+8 IF XUY1
IF XUFLAG=1
IF $PIECE($GET(^DIC(19,XUY1,3)),"^")'=XUSKEYN
QUIT
+9 SET XUZ=XUZ+1
SET XU2=XUZ/2
+10 IF $PIECE(XU2,".",2)=5
WRITE !,XUY
SET XU3=XU3+1
QUIT
+11 WRITE ?40,XUY
+12 SET XU3=XU3+1
+13 QUIT
End DoDot:1
+14 NEW XUOPTION,XUARE
+15 SET XUOPTION="option"
SET XUARE="is"
+16 IF XU3>1
SET XUOPTION="options"
SET XUARE="are"
+17 WRITE !!,"There ",XUARE," ",XU3," ",XUOPTION," from the list above."
+18 QUIT XU3
+19 ;------------------------------------------------------------
EXCLUDE ; remove options from the list
+1 NEW ANS,XUN
+2 SET ANS=$$YN("Do you want to remove any options from the list above")
+3 IF ANS=0
QUIT
+4 IF ANS="^"
GOTO END
+5 WRITE !
+6 SET XUN=$$SELECOP("Select an option: ","NOACTION758")
+7 WRITE !
+8 QUIT
+9 ;-----------------------------------------------------------
END ;
+1 KILL ^XUBA758("ACTION758")
+2 KILL ^XUBA758("NOACTION758")
+3 QUIT
END1 ;
+1 ;-----------------------------------------------------------
SETLOCKS ; set REVERSE/NEGATIVE LOCK for options
+1 NEW XUOPTIEN,XUSECOND
+2 SET XUI=0
SET XUSECOND=$ORDER(^XUBA758("ACTION758",0))
IF XUSECOND'>0
QUIT
+3 FOR
SET XUI=$ORDER(^XUBA758("ACTION758",XUSECOND,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+4 SET XUOPTIEN=+$GET(^XUBA758("ACTION758",XUSECOND,XUI))
+5 IF XUOPTIEN=""
QUIT
+6 IF $DATA(^XUBA758("NOACTION758",XUSECOND,XUOPTIEN))
QUIT
+7 ;set REVERSE/NEGATIVE LOCK
DO SETLOCK(XUOPTIEN)
End DoDot:1
+8 DO END
+9 QUIT
+10 ;-------------------------------------------------------------
SETLOCK(XUOPTIEN) ; set REVERSE/NEGATIVE LOCK for an option
+1 NEW DR,DIE
+2 SET DIE="^DIC(19,"
SET DA=XUOPTIEN
+3 SET DR="3.01////^S X=XUSKEYN"
+4 DO ^DIE
+5 QUIT
+6 ;--------------------------------------------------------------
DELOCKS ;remove REVERSE/NEGATIVE LOCK for options
+1 NEW XUOPTIEN,XUSECOND
+2 SET XUI=0
SET XUSECOND=$ORDER(^XUBA758("ACTION758",0))
IF XUSECOND'>0
QUIT
+3 FOR
SET XUI=$ORDER(^XUBA758("ACTION758",XUSECOND,XUI))
if XUI'>0
QUIT
Begin DoDot:1
+4 SET XUOPTIEN=+$GET(^XUBA758("ACTION758",XUSECOND,XUI))
+5 IF XUOPTIEN'>0
QUIT
+6 IF $PIECE($GET(^DIC(19,XUOPTIEN,3)),"^")'=XUSKEYN
QUIT
+7 IF $DATA(^XUBA758("NOACTION758",XUSECOND,XUOPTIEN))
QUIT
+8 ;remove REVERSE/NEGATIVE LOCK
DO DELOCK(XUOPTIEN)
End DoDot:1
+9 DO END
+10 QUIT
+11 ;--------------------------------------------------------------
DELOCK(XUOPTIEN) ; remove REVERSE/NEGATIVE LOCK for an option
+1 NEW DR,DIE,XUSKEYN
+2 SET XUSKEYN="@"
+3 SET DIE="^DIC(19,"
SET DA=XUOPTIEN
+4 SET DR="3.01////^S X=XUSKEYN"
+5 DO ^DIE
+6 QUIT
+7 ;--------------------------------------------------------------
SENDALERT(XUDUZ,XUKEY,STATUS,XUCN) ; send alert to user
+1 ;XUDUZ is IEN of user
+2 ;XUKEY is Replacement Key
+3 ;STATUS is Assign or Remoe
+4 ;XUCN is number of users
+5 NEW XQA,XQAARCH,XQADATA,XQAFLG,XQAGUID,XQAID,XQAMSG,XQAOPT,XQAROU,XQASUPV,XQASURO,XQATEXT,XQALERR,XQVAR
+6 NEW XUDATE
SET XUDATE=$$NOW^XLFDT
SET XUDATE=$$FMTE^XLFDT(XUDATE,1)
+7 ; recipient is user
SET XQA(XUDUZ)=""
+8 SET XQAMSG=XUCN_" users are "_STATUS_" the Program Replacement Key "_XUKEY_" on "_XUDATE_"."
+9 SET XQVAR=$$SETUP1^XQALERT
IF $GET(XQALERR)'=""
WRITE !,"ERROR IN ALERT: ",XQALERR
+10 QUIT
+11 ;---------------------------------------------------------------
