XQALBUTL ; ISC-SF/JLI - Utilities for OE/RR notifications ;07/13/12 13:24
;;8.0;KERNEL;**114,125,171,285,602**;Jul 10, 1995;Build 10
;Per VHA Directive 2004-038, this routine should not be modified
; PROVIDES FUNCTIONALITY USED BY ORBUTL
EN ;
Q
RECIPURG(XQX) ; SR. ICR #3010 (supported)
; Called by option ORB PURG RECIP - purge existing notifs: recipient/DUZ
N XQK,XQA,XQADAT S XQADAT=$$NOW^XLFDT()
F XQK=0:0 S XQK=$O(^XTV(8992,XQX,"XQA",XQK)) Q:XQK'>0 S XQA=$P(^(XQK,0),"^",2) D OLDPURG
Q
;
PTPURG(DFN) ; SR. ICR #3010 (supported)
; Called by option ORB PURG PATIENT - purge existing notifs: patient
N XQX,XQK,XQA,XQADAT S XQADAT=$$NOW^XLFDT()
F XQX=0:0 S XQX=$O(^XTV(8992,XQX)) Q:XQX'>0 F XQK=0:0 S XQK=$O(^XTV(8992,XQX,"XQA",XQK)) Q:XQK'>0 S XQA=$P(^(XQK,0),"^",2) I $P($P(XQA,";"),",",2)=DFN D OLDPURG
Q
;
NOTIPURG(Y) ; SR. ICR #3010 (supported)
; Called by option ORB PURG NOTIF - purge existing notifs: notification
N XQX,XQK,XQA,XQADAT S XQADAT=$$NOW^XLFDT()
F XQX=0:0 S XQX=$O(^XTV(8992,XQX)) Q:XQX'>0 F XQK=0:0 S XQK=$O(^XTV(8992,XQX,"XQA",XQK)) Q:XQK'>0 S XQA=$P(^(XQK,0),"^",2) I $P($P(XQA,";"),",",3)=+Y D OLDPURG
Q
;
OLDPURG ;called by RECIPURG, PTPURG, NOTIPURG - KILLs specified alert entries
N XQAID S XQAID=XQA D DELA^XQALDEL ; JLI 9-3-99 FIXES NULL SUBSCRIPT IN DELA+1^XQALDEL
Q
;
AHISTORY(XQAID,ROOT) ; SR. ICR #2778 (supported)
; Returns information from alert tracking file for alert with XQAID as its alert ID. The data is returned desendent from the closed root passed in ROOT.
N X
K @ROOT
S X=$O(^XTV(8992.1,"B",XQAID,0)) I X'>0 Q
M @ROOT=^XTV(8992.1,X)
Q
;
PENDING(XQAUSER,XQAID) ; SR. ICR #2778 (supported)
; Returns whether the user specified has the alert indicated by XQAID pending. (1=YES, 0=NO)
Q $D(^XTV(8992,"AXQA",XQAID,XQAUSER))/10
;
PKGPEND(XQAUSER,XQAPKG) ; SR. ICR #2778 (supported)
; Returns 1 if the user indicated by XQAUSER has any pending alerts with the first ';'-piece of XQAID contains the package identifier indicated by XQAPKG.
N I,X
F I=0:0 S X="",I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=$P($P(^(I,0),U,2),";") I X[XQAPKG Q
Q $S(X'="":1,1:0)
;
ALERTDAT(XQAID,ROOT) ; SR. ICR #2778 (supported)
; Returns information from alert tracking file for alert with XQAID in array XQALERTD. If the alert is not present, the array is undefined.
N IEN
I $G(ROOT)="" S ROOT="XQALERTD"
K @ROOT
S IEN=$O(^XTV(8992.1,"B",XQAID,0)) I IEN'>0 S @ROOT="" Q
D MAKELIST(ROOT,8992.1,(IEN_","))
Q
;
USERLIST(XQAID,ROOT) ; SR. ICR #2778 (supported)
; Returns recipients of alert with ID of XQAID from alert tracking file in array XQALUSER
N IEN,N,I,X
I $G(ROOT)="" S ROOT="XQALUSRS"
K @ROOT
S IEN=$O(^XTV(8992.1,"B",XQAID,0)) I IEN'>0 S @ROOT="" Q
S N=0 F I=0:0 S I=$O(^XTV(8992.1,IEN,20,I)) Q:I'>0 S N=N+1,X=+^(I,0),X=X_U_$$GET1^DIQ(8992.11,(I_","_IEN_","),.01),@ROOT@(N)=X
Q
;
USERDATA(XQAID,XQAUSER,ROOT) ; SR. ICR #2778 (supported)
; Returns information from alert tracking file related to alert with ID of XQAID for user specified by XQAUSER
N IEN,IEN2
I $G(ROOT)="" S ROOT="XQALUSER"
K @ROOT
S IEN=$O(^XTV(8992.1,"B",XQAID,0)) I IEN'>0 S @ROOT="" Q
S IEN2=$O(^XTV(8992.1,IEN,20,"B",XQAUSER,0)) I IEN2'>0 S @ROOT="" Q
D MAKELIST(ROOT,8992.11,(IEN2_","_IEN_","))
Q
;
MAKELIST(ARRAY,FILE,IENS) ; Makes a list of fields as subscripts in ARRAY with the values of the fields as the value. If internal and external differ, the value is given as internal^external.
N ROOT,FIELD,X
K @ARRAY
S ROOT=$NA(^TMP("XQALMAKELIST",$J))
K @ROOT
D GETS^DIQ(FILE,IENS,"*","IE",ROOT)
F FIELD=0:0 S FIELD=$O(@ROOT@(FILE,IENS,FIELD)) Q:FIELD'>0 S X=^(FIELD,"I") S:X'=^("E") X=X_U_^("E") S @ARRAY@(FIELD)=X,@ARRAY@(FIELD,$$GET1^DID(FILE,FIELD,"","LABEL"))=""
K @ROOT
Q
;
;; DELSTAT - For the most recent alert with XQAIDVAL as the PackageID
;; passed in, on return array VALUES contains the DUZ for users in
;; VALUES along with an indicator of whether the alert has been
;; deleted or not, e.g., DUZ^0 if not deleted or DUZ^1 if deleted.
;; Note that contents of VALUES will be killed prior to building the
;; list.
;;
;; Example: D DELSTAT^XQALBUTL("OR;14765;23",.RESULTS)
;;
;; Returned: The value of RESULTS indicates the number of entries in
;; the array. The entries are then ordered in numerical
;; order in the RESULTS array.
;; RESULTS = 3
;; RESULTS(1) = "146^0" User 146 - not deleted
;; RESULTS(2) = "297^1" User 297 - deleted
;; RESULTS(3) = "673^0" User 673 - not deleted
;;
DELSTAT(XQAIDVAL,VALUES) ; .SR ICR #3197 (supported)
N XQAX,XQADATE,XQAID,XQAFN,I,X,X1,X
S XQAX=XQAIDVAL,XQADATE=0,XQAID="" K VALUES S VALUES=0
F S XQAX=$O(^XTV(8992.1,"B",XQAX)) Q:XQAX'[XQAIDVAL I XQADATE<$P(XQAX,";",3) S XQADATE=$P(XQAX,";",3),XQAID=XQAX
Q:XQAID="" S XQAFN=$O(^XTV(8992.1,"B",XQAID,0)) Q:XQAFN'>0
F I=0:0 S I=$O(^XTV(8992.1,XQAFN,20,I)) Q:I'>0 S X=^(I,0),X1=+X,X2=($P(X,U,5)>0!($P(X,U,6)>0)),VALUES=VALUES+1,VALUES(VALUES)=X1_U_X2
Q
;
BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE - Moved from XQALDEL
N DIR,DIRUT,XQALBKUP,XQALCASE,XQPARAM,ERR
S XQPARAM="XQAL BACKUP REVIEWER"
BK1 ; Select NEW PERSON entry as backup reviewer
F S XQALBKUP=$$NEWPERSN() Q:$D(DIRUT) Q:XQALBKUP'>0 D Q:$D(DIRUT)
. D LISTCURR(XQALBKUP)
BK2 . ; Select Entity type for backup reviewer - XQALLAST indicates maximum number of choices, last is SYSTEM.
. N XQALVALS,XQALLAST
. S XQALLAST=4,XQALVALS(1)="User^200^USER^USR",XQALVALS(2)="Service^49^SERVICE^SRV",XQALVALS(3)="Division^4^DIVISION^DIV",XQALVALS(4)="System^"
. F S XQALCASE=$$ENTTYPE(.XQALVALS,XQALLAST) Q:$D(DIRUT) Q:XQALCASE'>0 D K:X="" DIRUT Q:$D(DIRUT)
. . ; Select individual in Entity for backup reviewer
. . I XQALCASE<XQALLAST D
. . . S DIR(0)="PO^"_$P(XQALVALS(XQALCASE),U,2)_":AEQM",DIR("A")="Select "_$P(XQALVALS(XQALCASE),U,3)_" to set "_$P(XQALBKUP,U,2)_" as BACKUP REVIEWER for"
. . . F D ^DIR Q:Y'>0 S XQAENT=+Y D CHKCURR($P(XQALVALS(XQALCASE),U,4)_".`"_XQAENT,+XQALBKUP)
. . . K DIR
. . . Q
. . ; Special handling for SYSTEM entity
. . I XQALCASE=XQALLAST S Y=$$GET1^DIQ(8989.3,"1,",.01,"I") D CHKCURR("SYS.`"_Y,+XQALBKUP)
. . Q
. Q
Q
;
NEWPERSN() ;
; Select a Backup Reviewer, then select parameter cases for this Backup
; Reviewer. You may then select another Backup Reviewer for additional
; parameter cases if necessary.
;
; Select NEW PERSON entry to be BACKUP REVIEWER
NEWLOOP ;
W ! S DIR(0)="PO^200:AEQM",DIR("A")="Select NEW PERSON entry to be BACKUP REVIEWER",DIR("A",1)="Select a Backup Reviewer, then select parameter cases for this Backup"
S DIR("A",2)="Reviewer. You may then select another Backup Reviewer for additional",DIR("A",3)="parameter cases if necessary.",DIR("A",4)=""
D ^DIR K DIR I X="" K DIRUT
I Y>0,'$$ACTIVE^XUSER(+Y) W !,$C(7),"This is not an ACTIVE USER... Select an Active user",! G NEWLOOP
Q Y
;
ENTTYPE(XQALVALS,XQALLAST) ;
K DIR("A")
S XQALCASE="" F I=1:1:XQALLAST S XQALCASE=XQALCASE_I_":"_$P(XQALVALS(I),U)_";"
S DIR(0)="SO^"_XQALCASE D ^DIR K DIR I X="" K DIRUT
Q Y
;
CHKCURR(ENTITY,XQALBKUP) ;
S XQAINST=$$GETINST(ENTITY,XQALBKUP)
I XQAINST>0 D PUT^XPAR(ENTITY,XQPARAM,XQAINST,XQALBKUP,.ERR) W " ...Done"
I XQAINST<0 D PUT^XPAR(ENTITY,XQPARAM,-XQAINST,"@",.ERR) W " ...Done"
Q
;
GETINST(ENTITY,XQALBKUP) ;
N DIR,DIRUT,I,J,IMAX,XQAA,XQATYP,XQAI,Y,ISELF,IEN,XQAVAL
D GETLST^XPAR(.XQAA,ENTITY,XQPARAM,"Q",.XQERR) I XQAA=0 Q 1
LOOP ;
W !,"There "_$S(XQAA=1:"is",1:"are")_" currently "_XQAA_" instance"_$S(XQAA>1:"s",1:"")_" for this entity"
S ISELF=0
F I=0:0 S I=$O(XQAA(I)) Q:I'>0 S IEN=+$P(XQAA(I),U,2) W !,?5,+XQAA(I),?10,$$GET1^DIQ(200,IEN_",",.01) S IMAX=+XQAA(I) I IEN=XQALBKUP S ISELF=+XQAA(I)
S DIR(0)="S^"_$S(ISELF=0:";a:Add an instance;r:Replace an instance;",1:"")_"d:Delete an instance;q:Quit",DIR("A")="Select Action" D ^DIR K DIR I $D(DIRUT)!(Y="q") K DIRUT Q 0
S XQATYP=Y I XQATYP="a" S J=0 D Q J
. F XQAI=1:1 I +$G(XQAA(XQAI))'=XQAI S J=XQAI I J>0 Q
E D Q:Y=0 0
. S Y=IMAX I XQAA>1 S DIR(0)="N^1:"_IMAX,DIR("A")="Select Instance number to "_$S(XQATYP="r":"REPLACE",1:"DELETE") D ^DIR K DIR I $D(DIRUT) K DIRUT S Y=0 Q
. F XQAI=1:1 Q:'$D(XQAA(XQAI)) I +XQAA(XQAI)=Y Q
. I '$D(XQAA(XQAI)) S Y=-1
I Y<0 W $C(7),!!,"To "_$S(XQATYP="r":"REPLACE",1:"DELETE")_" an entry enter an instance number from the list." G LOOP
S XQAVAL=+Y I XQATYP="d" S XQAVAL=-Y
Q XQAVAL
;
LISTCURR(XQALBKUP) ;
N XLIST,NVALS,ENT,XQIEN,X,ENTIEN,ENTFIL,FILNAM,FILNUM
S NVALS=$$LISTGET(+XQALBKUP,.XLIST) I NVALS>0 D
. W !,"Currently Backup Reviewer for:"
. S ENT="" F S ENT=$O(XLIST(ENT)) Q:ENT="" F XQIEN=0:0 S XQIEN=$O(XLIST(ENT,XQIEN)) Q:XQIEN'>0 D
. . S X=$$GET1^DIQ(8989.5,XQIEN_",",.01,"I"),ENTIEN=$P(X,";"),ENTFIL=$P(X,";",2),FILNAM=$P(@(U_ENTFIL_"0)"),U),FILNUM=+$P(@(U_ENTFIL_"0)"),U,2) I FILNUM>0 D
. . . W !?10,$S(FILNUM=4:"Division",FILNUM=4.2:"System",FILNUM=49:"Service",FILNUM=200:"User",1:"UNKNOWN???")_":",?25,$$GET1^DIQ(FILNUM,ENTIEN_",",.01)
. . . Q
. . Q
. Q
Q
;
LISTGET(XQALBKUP,XLIST) ;
N PARAMIEN,ENT,INST,X,IEN,ENT1,CNT
S PARAMIEN=$$FIND1^DIC(8989.51,"","","XQAL BACKUP REVIEWER"),CNT=0
S ENT="" F S ENT=$O(^XTV(8989.5,"AC",PARAMIEN,ENT)) Q:ENT="" F INST=0:0 S INST=$O(^XTV(8989.5,"AC",PARAMIEN,ENT,INST)) Q:INST'>0 S IEN=^(INST),X=$O(^(INST,"")) I IEN=XQALBKUP S ENT1=$P(ENT,";",2),XLIST(ENT1,X)="",CNT=CNT+1
Q CNT
XQALBUTL ; ISC-SF/JLI - Utilities for OE/RR notifications ;07/13/12 13:24
+1 ;;8.0;KERNEL;**114,125,171,285,602**;Jul 10, 1995;Build 10
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ; PROVIDES FUNCTIONALITY USED BY ORBUTL
EN ;
+1 QUIT
RECIPURG(XQX) ; SR. ICR #3010 (supported)
+1 ; Called by option ORB PURG RECIP - purge existing notifs: recipient/DUZ
+2 NEW XQK,XQA,XQADAT
SET XQADAT=$$NOW^XLFDT()
+3 FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQX,"XQA",XQK))
IF XQK'>0
QUIT
SET XQA=$PIECE(^(XQK,0),"^",2)
DO OLDPURG
+4 QUIT
+5 ;
PTPURG(DFN) ; SR. ICR #3010 (supported)
+1 ; Called by option ORB PURG PATIENT - purge existing notifs: patient
+2 NEW XQX,XQK,XQA,XQADAT
SET XQADAT=$$NOW^XLFDT()
+3 FOR XQX=0:0
SET XQX=$ORDER(^XTV(8992,XQX))
IF XQX'>0
QUIT
FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQX,"XQA",XQK))
IF XQK'>0
QUIT
SET XQA=$PIECE(^(XQK,0),"^",2)
IF $PIECE($PIECE(XQA,";"),",",2)=DFN
DO OLDPURG
+4 QUIT
+5 ;
NOTIPURG(Y) ; SR. ICR #3010 (supported)
+1 ; Called by option ORB PURG NOTIF - purge existing notifs: notification
+2 NEW XQX,XQK,XQA,XQADAT
SET XQADAT=$$NOW^XLFDT()
+3 FOR XQX=0:0
SET XQX=$ORDER(^XTV(8992,XQX))
IF XQX'>0
QUIT
FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQX,"XQA",XQK))
IF XQK'>0
QUIT
SET XQA=$PIECE(^(XQK,0),"^",2)
IF $PIECE($PIECE(XQA,";"),",",3)=+Y
DO OLDPURG
+4 QUIT
+5 ;
OLDPURG ;called by RECIPURG, PTPURG, NOTIPURG - KILLs specified alert entries
+1 ; JLI 9-3-99 FIXES NULL SUBSCRIPT IN DELA+1^XQALDEL
NEW XQAID
SET XQAID=XQA
DO DELA^XQALDEL
+2 QUIT
+3 ;
AHISTORY(XQAID,ROOT) ; SR. ICR #2778 (supported)
+1 ; Returns information from alert tracking file for alert with XQAID as its alert ID. The data is returned desendent from the closed root passed in ROOT.
+2 NEW X
+3 KILL @ROOT
+4 SET X=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF X'>0
QUIT
+5 MERGE @ROOT=^XTV(8992.1,X)
+6 QUIT
+7 ;
PENDING(XQAUSER,XQAID) ; SR. ICR #2778 (supported)
+1 ; Returns whether the user specified has the alert indicated by XQAID pending. (1=YES, 0=NO)
+2 QUIT $DATA(^XTV(8992,"AXQA",XQAID,XQAUSER))/10
+3 ;
PKGPEND(XQAUSER,XQAPKG) ; SR. ICR #2778 (supported)
+1 ; Returns 1 if the user indicated by XQAUSER has any pending alerts with the first ';'-piece of XQAID contains the package identifier indicated by XQAPKG.
+2 NEW I,X
+3 FOR I=0:0
SET X=""
SET I=$ORDER(^XTV(8992,XQAUSER,"XQA",I))
IF I'>0
QUIT
SET X=$PIECE($PIECE(^(I,0),U,2),";")
IF X[XQAPKG
QUIT
+4 QUIT $SELECT(X'="":1,1:0)
+5 ;
ALERTDAT(XQAID,ROOT) ; SR. ICR #2778 (supported)
+1 ; Returns information from alert tracking file for alert with XQAID in array XQALERTD. If the alert is not present, the array is undefined.
+2 NEW IEN
+3 IF $GET(ROOT)=""
SET ROOT="XQALERTD"
+4 KILL @ROOT
+5 SET IEN=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF IEN'>0
SET @ROOT=""
QUIT
+6 DO MAKELIST(ROOT,8992.1,(IEN_","))
+7 QUIT
+8 ;
USERLIST(XQAID,ROOT) ; SR. ICR #2778 (supported)
+1 ; Returns recipients of alert with ID of XQAID from alert tracking file in array XQALUSER
+2 NEW IEN,N,I,X
+3 IF $GET(ROOT)=""
SET ROOT="XQALUSRS"
+4 KILL @ROOT
+5 SET IEN=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF IEN'>0
SET @ROOT=""
QUIT
+6 SET N=0
FOR I=0:0
SET I=$ORDER(^XTV(8992.1,IEN,20,I))
IF I'>0
QUIT
SET N=N+1
SET X=+^(I,0)
SET X=X_U_$$GET1^DIQ(8992.11,(I_","_IEN_","),.01)
SET @ROOT@(N)=X
+7 QUIT
+8 ;
USERDATA(XQAID,XQAUSER,ROOT) ; SR. ICR #2778 (supported)
+1 ; Returns information from alert tracking file related to alert with ID of XQAID for user specified by XQAUSER
+2 NEW IEN,IEN2
+3 IF $GET(ROOT)=""
SET ROOT="XQALUSER"
+4 KILL @ROOT
+5 SET IEN=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF IEN'>0
SET @ROOT=""
QUIT
+6 SET IEN2=$ORDER(^XTV(8992.1,IEN,20,"B",XQAUSER,0))
IF IEN2'>0
SET @ROOT=""
QUIT
+7 DO MAKELIST(ROOT,8992.11,(IEN2_","_IEN_","))
+8 QUIT
+9 ;
MAKELIST(ARRAY,FILE,IENS) ; Makes a list of fields as subscripts in ARRAY with the values of the fields as the value. If internal and external differ, the value is given as internal^external.
+1 NEW ROOT,FIELD,X
+2 KILL @ARRAY
+3 SET ROOT=$NAME(^TMP("XQALMAKELIST",$JOB))
+4 KILL @ROOT
+5 DO GETS^DIQ(FILE,IENS,"*","IE",ROOT)
+6 FOR FIELD=0:0
SET FIELD=$ORDER(@ROOT@(FILE,IENS,FIELD))
IF FIELD'>0
QUIT
SET X=^(FIELD,"I")
IF X'=^("E")
SET X=X_U_^("E")
SET @ARRAY@(FIELD)=X
SET @ARRAY@(FIELD,$$GET1^DID(FILE,FIELD,"","LABEL"))=""
+7 KILL @ROOT
+8 QUIT
+9 ;
+10 ;; DELSTAT - For the most recent alert with XQAIDVAL as the PackageID
+11 ;; passed in, on return array VALUES contains the DUZ for users in
+12 ;; VALUES along with an indicator of whether the alert has been
+13 ;; deleted or not, e.g., DUZ^0 if not deleted or DUZ^1 if deleted.
+14 ;; Note that contents of VALUES will be killed prior to building the
+15 ;; list.
+16 ;;
+17 ;; Example: D DELSTAT^XQALBUTL("OR;14765;23",.RESULTS)
+18 ;;
+19 ;; Returned: The value of RESULTS indicates the number of entries in
+20 ;; the array. The entries are then ordered in numerical
+21 ;; order in the RESULTS array.
+22 ;; RESULTS = 3
+23 ;; RESULTS(1) = "146^0" User 146 - not deleted
+24 ;; RESULTS(2) = "297^1" User 297 - deleted
+25 ;; RESULTS(3) = "673^0" User 673 - not deleted
+26 ;;
DELSTAT(XQAIDVAL,VALUES) ; .SR ICR #3197 (supported)
+1 NEW XQAX,XQADATE,XQAID,XQAFN,I,X,X1,X
+2 SET XQAX=XQAIDVAL
SET XQADATE=0
SET XQAID=""
KILL VALUES
SET VALUES=0
+3 FOR
SET XQAX=$ORDER(^XTV(8992.1,"B",XQAX))
IF XQAX'[XQAIDVAL
QUIT
IF XQADATE<$PIECE(XQAX,";",3)
SET XQADATE=$PIECE(XQAX,";",3)
SET XQAID=XQAX
+4 IF XQAID=""
QUIT
SET XQAFN=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF XQAFN'>0
QUIT
+5 FOR I=0:0
SET I=$ORDER(^XTV(8992.1,XQAFN,20,I))
IF I'>0
QUIT
SET X=^(I,0)
SET X1=+X
SET X2=($PIECE(X,U,5)>0!($PIECE(X,U,6)>0))
SET VALUES=VALUES+1
SET VALUES(VALUES)=X1_U_X2
+6 QUIT
+7 ;
BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE - Moved from XQALDEL
+1 NEW DIR,DIRUT,XQALBKUP,XQALCASE,XQPARAM,ERR
+2 SET XQPARAM="XQAL BACKUP REVIEWER"
BK1 ; Select NEW PERSON entry as backup reviewer
+1 FOR
SET XQALBKUP=$$NEWPERSN()
IF $DATA(DIRUT)
QUIT
IF XQALBKUP'>0
QUIT
Begin DoDot:1
+2 DO LISTCURR(XQALBKUP)
BK2 ; Select Entity type for backup reviewer - XQALLAST indicates maximum number of choices, last is SYSTEM.
+1 NEW XQALVALS,XQALLAST
+2 SET XQALLAST=4
SET XQALVALS(1)="User^200^USER^USR"
SET XQALVALS(2)="Service^49^SERVICE^SRV"
SET XQALVALS(3)="Division^4^DIVISION^DIV"
SET XQALVALS(4)="System^"
+3 FOR
SET XQALCASE=$$ENTTYPE(.XQALVALS,XQALLAST)
IF $DATA(DIRUT)
QUIT
IF XQALCASE'>0
QUIT
Begin DoDot:2
+4 ; Select individual in Entity for backup reviewer
+5 IF XQALCASE<XQALLAST
Begin DoDot:3
+6 SET DIR(0)="PO^"_$PIECE(XQALVALS(XQALCASE),U,2)_":AEQM"
SET DIR("A")="Select "_$PIECE(XQALVALS(XQALCASE),U,3)_" to set "_$PIECE(XQALBKUP,U,2)_" as BACKUP REVIEWER for"
+7 FOR
DO ^DIR
IF Y'>0
QUIT
SET XQAENT=+Y
DO CHKCURR($PIECE(XQALVALS(XQALCASE),U,4)_".`"_XQAENT,+XQALBKUP)
+8 KILL DIR
+9 QUIT
End DoDot:3
+10 ; Special handling for SYSTEM entity
+11 IF XQALCASE=XQALLAST
SET Y=$$GET1^DIQ(8989.3,"1,",.01,"I")
DO CHKCURR("SYS.`"_Y,+XQALBKUP)
+12 QUIT
End DoDot:2
IF X=""
KILL DIRUT
IF $DATA(DIRUT)
QUIT
+13 QUIT
End DoDot:1
IF $DATA(DIRUT)
QUIT
+14 QUIT
+15 ;
NEWPERSN() ;
+1 ; Select a Backup Reviewer, then select parameter cases for this Backup
+2 ; Reviewer. You may then select another Backup Reviewer for additional
+3 ; parameter cases if necessary.
+4 ;
+5 ; Select NEW PERSON entry to be BACKUP REVIEWER
NEWLOOP ;
+1 WRITE !
SET DIR(0)="PO^200:AEQM"
SET DIR("A")="Select NEW PERSON entry to be BACKUP REVIEWER"
SET DIR("A",1)="Select a Backup Reviewer, then select parameter cases for this Backup"
+2 SET DIR("A",2)="Reviewer. You may then select another Backup Reviewer for additional"
SET DIR("A",3)="parameter cases if necessary."
SET DIR("A",4)=""
+3 DO ^DIR
KILL DIR
IF X=""
KILL DIRUT
+4 IF Y>0
IF '$$ACTIVE^XUSER(+Y)
WRITE !,$CHAR(7),"This is not an ACTIVE USER... Select an Active user",!
GOTO NEWLOOP
+5 QUIT Y
+6 ;
ENTTYPE(XQALVALS,XQALLAST) ;
+1 KILL DIR("A")
+2 SET XQALCASE=""
FOR I=1:1:XQALLAST
SET XQALCASE=XQALCASE_I_":"_$PIECE(XQALVALS(I),U)_";"
+3 SET DIR(0)="SO^"_XQALCASE
DO ^DIR
KILL DIR
IF X=""
KILL DIRUT
+4 QUIT Y
+5 ;
CHKCURR(ENTITY,XQALBKUP) ;
+1 SET XQAINST=$$GETINST(ENTITY,XQALBKUP)
+2 IF XQAINST>0
DO PUT^XPAR(ENTITY,XQPARAM,XQAINST,XQALBKUP,.ERR)
WRITE " ...Done"
+3 IF XQAINST<0
DO PUT^XPAR(ENTITY,XQPARAM,-XQAINST,"@",.ERR)
WRITE " ...Done"
+4 QUIT
+5 ;
GETINST(ENTITY,XQALBKUP) ;
+1 NEW DIR,DIRUT,I,J,IMAX,XQAA,XQATYP,XQAI,Y,ISELF,IEN,XQAVAL
+2 DO GETLST^XPAR(.XQAA,ENTITY,XQPARAM,"Q",.XQERR)
IF XQAA=0
QUIT 1
LOOP ;
+1 WRITE !,"There "_$SELECT(XQAA=1:"is",1:"are")_" currently "_XQAA_" instance"_$SELECT(XQAA>1:"s",1:"")_" for this entity"
+2 SET ISELF=0
+3 FOR I=0:0
SET I=$ORDER(XQAA(I))
IF I'>0
QUIT
SET IEN=+$PIECE(XQAA(I),U,2)
WRITE !,?5,+XQAA(I),?10,$$GET1^DIQ(200,IEN_",",.01)
SET IMAX=+XQAA(I)
IF IEN=XQALBKUP
SET ISELF=+XQAA(I)
+4 SET DIR(0)="S^"_$SELECT(ISELF=0:";a:Add an instance;r:Replace an instance;",1:"")_"d:Delete an instance;q:Quit"
SET DIR("A")="Select Action"
DO ^DIR
KILL DIR
IF $DATA(DIRUT)!(Y="q")
KILL DIRUT
QUIT 0
+5 SET XQATYP=Y
IF XQATYP="a"
SET J=0
Begin DoDot:1
+6 FOR XQAI=1:1
IF +$GET(XQAA(XQAI))'=XQAI
SET J=XQAI
IF J>0
QUIT
End DoDot:1
QUIT J
+7 IF '$TEST
Begin DoDot:1
+8 SET Y=IMAX
IF XQAA>1
SET DIR(0)="N^1:"_IMAX
SET DIR("A")="Select Instance number to "_$SELECT(XQATYP="r":"REPLACE",1:"DELETE")
DO ^DIR
KILL DIR
IF $DATA(DIRUT)
KILL DIRUT
SET Y=0
QUIT
+9 FOR XQAI=1:1
IF '$DATA(XQAA(XQAI))
QUIT
IF +XQAA(XQAI)=Y
QUIT
+10 IF '$DATA(XQAA(XQAI))
SET Y=-1
End DoDot:1
IF Y=0
QUIT 0
+11 IF Y<0
WRITE $CHAR(7),!!,"To "_$SELECT(XQATYP="r":"REPLACE",1:"DELETE")_" an entry enter an instance number from the list."
GOTO LOOP
+12 SET XQAVAL=+Y
IF XQATYP="d"
SET XQAVAL=-Y
+13 QUIT XQAVAL
+14 ;
LISTCURR(XQALBKUP) ;
+1 NEW XLIST,NVALS,ENT,XQIEN,X,ENTIEN,ENTFIL,FILNAM,FILNUM
+2 SET NVALS=$$LISTGET(+XQALBKUP,.XLIST)
IF NVALS>0
Begin DoDot:1
+3 WRITE !,"Currently Backup Reviewer for:"
+4 SET ENT=""
FOR
SET ENT=$ORDER(XLIST(ENT))
IF ENT=""
QUIT
FOR XQIEN=0:0
SET XQIEN=$ORDER(XLIST(ENT,XQIEN))
IF XQIEN'>0
QUIT
Begin DoDot:2
+5 SET X=$$GET1^DIQ(8989.5,XQIEN_",",.01,"I")
SET ENTIEN=$PIECE(X,";")
SET ENTFIL=$PIECE(X,";",2)
SET FILNAM=$PIECE(@(U_ENTFIL_"0)"),U)
SET FILNUM=+$PIECE(@(U_ENTFIL_"0)"),U,2)
IF FILNUM>0
Begin DoDot:3
+6 WRITE !?10,$SELECT(FILNUM=4:"Division",FILNUM=4.2:"System",FILNUM=49:"Service",FILNUM=200:"User",1:"UNKNOWN???")_":",?25,$$GET1^DIQ(FILNUM,ENTIEN_",",.01)
+7 QUIT
End DoDot:3
+8 QUIT
End DoDot:2
+9 QUIT
End DoDot:1
+10 QUIT
+11 ;
LISTGET(XQALBKUP,XLIST) ;
+1 NEW PARAMIEN,ENT,INST,X,IEN,ENT1,CNT
+2 SET PARAMIEN=$$FIND1^DIC(8989.51,"","","XQAL BACKUP REVIEWER")
SET CNT=0
+3 SET ENT=""
FOR
SET ENT=$ORDER(^XTV(8989.5,"AC",PARAMIEN,ENT))
IF ENT=""
QUIT
FOR INST=0:0
SET INST=$ORDER(^XTV(8989.5,"AC",PARAMIEN,ENT,INST))
IF INST'>0
QUIT
SET IEN=^(INST)
SET X=$ORDER(^(INST,""))
IF IEN=XQALBKUP
SET ENT1=$PIECE(ENT,";",2)
SET XLIST(ENT1,X)=""
SET CNT=CNT+1
+4 QUIT CNT
