- 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 Feb 18, 2025@23:38:43 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 ;---------------------------------------------------------------