XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;10/19/18 14:06
;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443,602,653**;Jul 10, 1995;Build 18
;Per VHA Directive 2004-038, this routine should not be modified
;;
Q
; Original entry point - throw away return value since no value expected
SETUP ;
N I S I=$$SETUP1() K XQALERR
Q
;
SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID.
; If not successful XQALERR is defined and contains reason for failure.
K XQALERR
I $O(XQA(0))="" S XQALERR="No recipient list in XQA array" Q 0
I '($D(XQAMSG)#2)!($G(XQAMSG)="") S XQALERR="No valid XQAMSG for display" Q 0
N X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE
S XQALTYPE="INITIAL RECIPIENT"
S XQAOPT1=$S('($D(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU),XQAOPT1=$S(XQAOPT1'=U:XQAOPT1,$D(XQAOPT)#2:XQAOPT_U,1:XQAOPT1) S:XQAOPT1=U XQAOPT1=U_" "
NOW S XQX=$$NOW^XLFDT()
S:$S('$D(XQAID):1,XQAID="":1,1:0) XQAID="NO-ID" S:XQAID[";" XQAID=$P(XQAID,";") S XQA1=XQAID,XQI=XQX
S XQAID=$$SETIEN(XQA1,XQX),XQADA=""
Q $$REENT()
;
REENT() ; Entry for forwarding, etc.
N RETVAL S RETVAL=1
K ^TMP("XQAGROUP",$J) ; P443 - clear location for storage of groups processed
N XQADATIM,XQALIST,XQALIST1,XQNRECIP S XQNRECIP=0 S XQADATIM=$$NOW^XLFDT()
S XQALIN1=$S($D(XQAID)#2:XQAID,1:"")_U_$E(XQAMSG,1,95)_"^1^"_$S(XQAOPT1=U:"D",1:"R")_U_$S($D(XQACTMSG):$E(XQACTMSG,1,40),1:"")_U_XQAOPT1
S:$D(XQACNDEL) $P(XQALIN1,U,9)=1 S:$D(XQASURO) $P(XQALIN1,U,12)=XQASURO S:$D(XQASUPV) $P(XQALIN1,U,13)=XQASUPV S:$D(XQAREVUE) $P(XQALIN1,U,14)=XQAREVUE
S XQALIN=XQX_U_XQALIN1,XQJ=0
K XQALIN1 S:$D(XQADATA) XQALIN1=XQADATA
LOOP1 S XQJ=$O(XQA(" ")) I XQJ'="" K:"G.g."'[$E(XQJ_",,",1,2) XQA(XQJ) D:$D(XQA(XQJ)) GROUP^XQALSET1 G LOOP1
LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE
N:'$D(XQAUSER) XQAUSER M XQALIST=XQA F I=0:0 S I=$O(XQALIST(I)) Q:I'>0 S XQALIST(I,XQALTYPE)="" I '$D(XQAUSER) S XQAUSER=I ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON
; The following section of code was added to provide a generalized way to handle surrogates
F XQJ=0:0 S XQJ=$O(XQA(XQJ)) Q:XQJ="" D
. N X S X=$$ACTVSURO^XQALSURO(XQJ) I X>0 D ; Modified to get final surrogate if a sequence of them
. . S XQA(X)="" K XQA(XQJ) ; Add Surrogate to XQA array, delete XQJ entry
. . S XQALIST(X,$O(XQALIST(XQJ,""))_"-SURROGATE")="" ; Add Surrogate to XQALIST with same type as original
. . S XQALIST(X,"z AS_SURO",XQJ)="" ; Mark user as in list as a surrogate, subscript for surrogate to
. . S XQALIST(XQJ,"z TO_SURO",X)=""
. . Q
. Q
;
S XQJ=0
LOOP ;
S XQJ=$O(XQA(XQJ)) G:XQJ="" WRAP
;
I '(+$$ACTIVE^XUSER(XQJ)) K XQA(XQJ) N XX S XX=$O(XQALIST(XQJ,"")) K XQALIST(XQJ,XX) S XQALIST(XQJ,XX_"-UNDELIVERABLE")="" G LOOP ;Don't send to users that can't sign-on
;
I '$D(^XTV(8992,XQJ,0)) D I '$D(^XTV(8992,XQJ,0)) S ^(0)=XQJ
. N FDA,IENS
. F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",110))&'$D(^TMP("DIERR",$J,"E",111))
. . K DIERR,^TMP("DIERR",$J)
. . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA S @FDA@(8992,"+1,",.01)=XQJ
. . S IENS(1)=XQJ
. . D UPDATE^DIE("S",FDA,"IENS")
. . Q
. Q
L +^XTV(8992,XQJ):10 S XQXI=XQX S:'$D(^XTV(8992,XQJ,"XQA",0)) ^(0)="^8992.01DA^"
REP I $D(^XTV(8992,XQJ,"XQA",XQXI,0)) S XQXI=XQXI+.00000001 G REP
S ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN S:$D(XQALIN1) ^(1)=XQALIN1 S:$D(XQAGUID)!$D(XQADFN) ^(3)=$G(XQAGUID)_U_$G(XQADFN) S:$D(XQARESET) ^(2)=XQAUSER_U_XQX_U_$G(XQACOMNT) S ^(0)=$P(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($P(^(0),U,4)+1)
I $D(XQATEXT) S:($D(XQATEXT)#2) XQATEXT(.1)=XQATEXT D WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT") ; P443 PUT DATA IN XQATEXT INTO ARRAY
L -^XTV(8992,XQJ)
K XQA(XQJ) S:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)="",^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)=""
S XQNRECIP=XQNRECIP+1
G LOOP
;
WRAP ;
M XQALIST1=XQALIST
I XQNRECIP=0,'$$SNDNACTV(XQAID) S RETVAL=0,XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS"
E I XQNRECIP=0 D I $D(XQA) S XQACOMNT=$E("None of recipients were active users. "_$G(XQACOMNT),1,245),XQNRECIP=1,XQARESET=1 K XQALIST G LOOP2 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN
. N XQAA,XQJ F XQI=0:0 S XQI=$O(XQALIST(XQI)) Q:XQI'>0 D GETBKUP^XQALDEL(.XQAA,XQI) S XQALTYPE="BACKUP REVIEWER" F XQJ=0:0 S XQJ=$O(XQAA(XQJ)) Q:XQJ'>0 S XQA(XQAA(XQJ))=""
. I $D(XQA) D CHEKACTV^XQALSET1(.XQA)
. I '$D(XQA) S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1 S XQALTYPE="UNPROCESSED ALERTS MAIL GROUP" ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO
. I '$D(XQA) S XQJ="G.PATCHES" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCHES
. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 S XQALTYPE="LAST HOPE" ; Last gasp, send it to G.PATCH
. I '$D(XQA) S RETVAL=0,XQALERR="Could not find any active user to send it to" ; Should not get here, this is only if all backups and mail groups tried don't have any active users
. Q
; END OF JLI 030129 INSERTION P285
; moved recording of users in Alert Tracking file to here to include all of them 030220
; modified code to use FM calls instead of direct global references
I RETVAL,$G(XQADA)'>0,XQAID'="" D SETTRACK ; moved to here to avoid tracking entries with no users
;
I RETVAL,$G(XQADA)>0 L +^XTV(8992.1,XQADA):10 D L -^XTV(8992.1,XQADA) ; 030131
. F XQJ=0:0 S XQJ=$O(XQALIST1(XQJ)) Q:XQJ'>0 D
. . N NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL
. . S IENVAL=XQADA_",",KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ)
. . S FDA=$NA(^TMP($J,"XQALSET")) K @FDA I KCNT=0 S @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ,KCNT="+1"
. . S IENVAL=","_KCNT_","_IENVAL,NCOUNT=1 S SUBSCRPT="" F S SUBSCRPT=$O(XQALIST1(XQJ,SUBSCRPT)) Q:SUBSCRPT="" I $E(SUBSCRPT,1)'="z" D
. . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
. . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
. . . . Q
. . . S NCOUNT=NCOUNT+1,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN,@FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM
. . . Q
. . I $D(XQALIST1(XQJ,"z TO_SURO")) S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$O(XQALIST1(XQJ,"z TO_SURO",0))
. . I $D(XQALIST1(XQJ,"z AS_SURO")) D
. . . S @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y"
. . . N XQK S NCOUNT=NCOUNT+1 F XQK=0:0 S XQK=$O(XQALIST1(XQJ,"z AS_SURO",XQK)) Q:XQK'>0 S @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK,@FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM
. . . Q
. . S SUBSCRPT=$O(XQALIST1(XQJ,"")) I SUBSCRPT'["INITIAL" S SUBSCRPT=$P(SUBSCRPT,"-") D ; FORWARDING
. . . S SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT) I SUBSCRPN'>0 D
. . . . N FDA1,IENROOT S FDA1=$NA(^TMP($J,"XQALSET1")) K @FDA1 S @FDA1@(8992.2,"+1,",.01)=SUBSCRPT D UPDATE^DIE("",FDA1,"IENROOT") S SUBSCRPN=$G(IENROOT(1))
. . . . Q
. . . S NCOUNT=NCOUNT+1,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM,@FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN I $G(XQACOMNT)'="" S @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT
. . . I $G(XQAUSER)>0 S @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER
. . . Q
. . N IENSTR D UPDATE^DIE("",FDA,"IENSTR")
. . Q
. Q
;
I RETVAL S RETVAL=RETVAL_U_$G(XQADA)_U_XQAID
K:XQAID'="" ^XTV(8992,"AXQA",XQAID,0,0)
K ^TMP("XQAGROUP",$J) ; P443 - clear global used to track processing of groups
K XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT
Q RETVAL
;
SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers
N XVAL
I $E(XQAID,1,3)="TIU" S XVAL=$E($P(XQAID,";"),4,99),XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I") I XVAL>0,$$FMDIFF^XLFDT(DT,XVAL)>60 Q 0
Q 1
;
SETIEN(XQA1,XQI) ; determine unique XQAID value for alert
N XQAID
S:$G(XQA1)="" XQA1="NO-ID" F S XQAID=XQA1_";"_DUZ_";"_XQI L +^XTV(8992,"AXQA",XQAID):10 D L -^XTV(8992,"AXQA",XQAID) Q:XQI="" S XQI=XQI+.00000001
. I $D(^XTV(8992,"AXQA",XQAID)) Q
. S ^XTV(8992,"AXQA",XQAID,0,0)="",XQI=""
. Q
Q XQAID
;
SETTRACK ; Setup entry in Alert Tracking file
; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues
N FDA,IENS,XQA2,DIERR
S XQADA=0
S XQA2=XQA1 I XQA2[",",$P(XQA2,",",3)'="" S XQA2=$P(XQA2,",")_","_$P(XQA2,",",3)
F D Q:'$D(DIERR) Q:'$D(^TMP("DIERR",$J,"E",111))
. K DIERR,^TMP("DIERR",$J)
. S FDA=$NA(^TMP($J,"XQALSET")) K @FDA
. S @FDA@(8992.1,"+1,",.01)=XQAID D UPDATE^DIE("",FDA,"IENS")
. K @FDA
. Q
I $D(DIERR) Q ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q
Q:IENS(1)'>0 S (DA,XQADA)=IENS(1)
S IENS=IENS(1)_",",@FDA@(8992.1,IENS,.02)=XQX,^(.03)=XQA2,^(.05)=DUZ,^(1.01)=XQAMSG
I $D(XQAARCH) S X=$$FMADD^XLFDT(DT,XQAARCH) I X>DT S @FDA@(8992.1,IENS,.08)=X
I $P(XQA1,",")="OR",$P(XQA1,",",2)>0 S @FDA@(8992.1,IENS,.04)=$P(XQA1,",",2)
I $D(ZTQUEUED) S @FDA@(8992.1,IENS,.06)=1
I $D(XQAOPT)#2 S @FDA@(8992.1,IENS,1.02)=XQAOPT
I $D(XQAROU)#2 N XQAXX S XQAXX=$S(XQAROU[U:XQAROU,1:U_XQAROU) I $P(XQAXX,U,2)'="" S:$P(XQAXX,U)'="" @FDA@(8992.1,IENS,1.03)=$P(XQAXX,U) S @FDA@(8992.1,IENS,1.04)=$P(XQAXX,U,2)
I $D(XQACTMSG) S @FDA@(8992.1,IENS,1.05)=XQACTMSG
I $D(XQADATA) S @FDA@(8992.1,IENS,2)=XQADATA
I $D(XQAGUID) S @FDA@(8992.1,IENS,3.01)=XQAGUID
I $D(XQADFN) S @FDA@(8992.1,IENS,.04)=XQADFN
D FILE^DIE("KS",FDA)
I $D(XQATEXT) D WP^DIE(8992.1,IENS,4,"","XQATEXT")
Q
;
CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
Q $$CHEKUSER^XQALSET1(XQAUSER)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALSET 9794 printed Dec 13, 2024@02:05:27 Page 2
XQALSET ;ISC-SF.SEA/JLI - SETUP ALERTS ;10/19/18 14:06
+1 ;;8.0;KERNEL;**1,6,65,75,114,125,173,207,285,443,602,653**;Jul 10, 1995;Build 18
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;;
+4 QUIT
+5 ; Original entry point - throw away return value since no value expected
SETUP ;
+1 NEW I
SET I=$$SETUP1()
KILL XQALERR
+2 QUIT
+3 ;
SETUP1() ; .SR Returns a string beginning with 1 if successful, 0 if not successful, the second piece is the IEN in the Alert Tracking File and the third piece is the value of XQAID.
+1 ; If not successful XQALERR is defined and contains reason for failure.
+2 KILL XQALERR
+3 IF $ORDER(XQA(0))=""
SET XQALERR="No recipient list in XQA array"
QUIT 0
+4 IF '($DATA(XQAMSG)#2)!($GET(XQAMSG)="")
SET XQALERR="No valid XQAMSG for display"
QUIT 0
+5 NEW X,XQI,XQJ,XQX,XQK,XQACOMNT,XQARESET,DA,XQADA,XQALTYPE
+6 SET XQALTYPE="INITIAL RECIPIENT"
+7 SET XQAOPT1=$SELECT('($DATA(XQAROU)#2):U,XQAROU'[U:U_XQAROU,1:XQAROU)
SET XQAOPT1=$SELECT(XQAOPT1'=U:XQAOPT1,$DATA(XQAOPT)#2:XQAOPT_U,1:XQAOPT1)
if XQAOPT1=U
SET XQAOPT1=U_" "
NOW SET XQX=$$NOW^XLFDT()
+1 if $SELECT('$DATA(XQAID)
SET XQAID="NO-ID"
if XQAID[";"
SET XQAID=$PIECE(XQAID,";")
SET XQA1=XQAID
SET XQI=XQX
+2 SET XQAID=$$SETIEN(XQA1,XQX)
SET XQADA=""
+3 QUIT $$REENT()
+4 ;
REENT() ; Entry for forwarding, etc.
+1 NEW RETVAL
SET RETVAL=1
+2 ; P443 - clear location for storage of groups processed
KILL ^TMP("XQAGROUP",$JOB)
+3 NEW XQADATIM,XQALIST,XQALIST1,XQNRECIP
SET XQNRECIP=0
SET XQADATIM=$$NOW^XLFDT()
+4 SET XQALIN1=$SELECT($DATA(XQAID)#2:XQAID,1:"")_U_$EXTRACT(XQAMSG,1,95)_"^1^"_$SELECT(XQAOPT1=U:"D",1:"R")_U_$SELECT($DATA(XQACTMSG):$EXTRACT(XQACTMSG,1,40),1:"")_U_XQAOPT1
+5 if $DATA(XQACNDEL)
SET $PIECE(XQALIN1,U,9)=1
if $DATA(XQASURO)
SET $PIECE(XQALIN1,U,12)=XQASURO
if $DATA(XQASUPV)
SET $PIECE(XQALIN1,U,13)=XQASUPV
if $DATA(XQAREVUE)
SET $PIECE(XQALIN1,U,14)=XQAREVUE
+6 SET XQALIN=XQX_U_XQALIN1
SET XQJ=0
+7 KILL XQALIN1
if $DATA(XQADATA)
SET XQALIN1=XQADATA
LOOP1 SET XQJ=$ORDER(XQA(" "))
IF XQJ'=""
if "G.g."'[$EXTRACT(XQJ_",,",1,2)
KILL XQA(XQJ)
if $DATA(XQA(XQJ))
DO GROUP^XQALSET1
GOTO LOOP1
LOOP2 ; RE-ENTRY FOR FORWARDING IF ALL RECIPIENTS ARE UNDELIVERABLE
+1 ; SAVE ORIGINAL LIST OF RECIPIENTS AND REASON
if '$DATA(XQAUSER)
NEW XQAUSER
MERGE XQALIST=XQA
FOR I=0:0
SET I=$ORDER(XQALIST(I))
if I'>0
QUIT
SET XQALIST(I,XQALTYPE)=""
IF '$DATA(XQAUSER)
SET XQAUSER=I
+2 ; The following section of code was added to provide a generalized way to handle surrogates
+3 FOR XQJ=0:0
SET XQJ=$ORDER(XQA(XQJ))
if XQJ=""
QUIT
Begin DoDot:1
+4 ; Modified to get final surrogate if a sequence of them
NEW X
SET X=$$ACTVSURO^XQALSURO(XQJ)
IF X>0
Begin DoDot:2
+5 ; Add Surrogate to XQA array, delete XQJ entry
SET XQA(X)=""
KILL XQA(XQJ)
+6 ; Add Surrogate to XQALIST with same type as original
SET XQALIST(X,$ORDER(XQALIST(XQJ,""))_"-SURROGATE")=""
+7 ; Mark user as in list as a surrogate, subscript for surrogate to
SET XQALIST(X,"z AS_SURO",XQJ)=""
+8 SET XQALIST(XQJ,"z TO_SURO",X)=""
+9 QUIT
End DoDot:2
+10 QUIT
End DoDot:1
+11 ;
+12 SET XQJ=0
LOOP ;
+1 SET XQJ=$ORDER(XQA(XQJ))
if XQJ=""
GOTO WRAP
+2 ;
+3 ;Don't send to users that can't sign-on
IF '(+$$ACTIVE^XUSER(XQJ))
KILL XQA(XQJ)
NEW XX
SET XX=$ORDER(XQALIST(XQJ,""))
KILL XQALIST(XQJ,XX)
SET XQALIST(XQJ,XX_"-UNDELIVERABLE")=""
GOTO LOOP
+4 ;
+5 IF '$DATA(^XTV(8992,XQJ,0))
Begin DoDot:1
+6 NEW FDA,IENS
+7 FOR
Begin DoDot:2
+8 KILL DIERR,^TMP("DIERR",$JOB)
+9 SET FDA=$NAME(^TMP($JOB,"XQALSET"))
KILL @FDA
SET @FDA@(8992,"+1,",.01)=XQJ
+10 SET IENS(1)=XQJ
+11 DO UPDATE^DIE("S",FDA,"IENS")
+12 QUIT
End DoDot:2
if '$DATA(DIERR)
QUIT
if '$DATA(^TMP("DIERR",$JOB,"E",110))&'$DATA(^TMP("DIERR",$JOB,"E",111))
QUIT
+13 QUIT
End DoDot:1
IF '$DATA(^XTV(8992,XQJ,0))
SET ^(0)=XQJ
+14 LOCK +^XTV(8992,XQJ):10
SET XQXI=XQX
if '$DATA(^XTV(8992,XQJ,"XQA",0))
SET ^(0)="^8992.01DA^"
REP IF $DATA(^XTV(8992,XQJ,"XQA",XQXI,0))
SET XQXI=XQXI+.00000001
GOTO REP
+1 SET ^XTV(8992,XQJ,"XQA",XQXI,0)=XQALIN
if $DATA(XQALIN1)
SET ^(1)=XQALIN1
if $DATA(XQAGUID)!$DATA(XQADFN)
SET ^(3)=$GET(XQAGUID)_U_$GET(XQADFN)
if $DATA(XQARESET)
SET ^(2)=XQAUSER_U_XQX_U_$GET(XQACOMNT)
SET ^(0)=$PIECE(^XTV(8992,XQJ,"XQA",0),U,1,2)_U_XQXI_U_($PIECE(^(0),U,4)+1)
+2 ; P443 PUT DATA IN XQATEXT INTO ARRAY
IF $DATA(XQATEXT)
if ($DATA(XQATEXT)#2)
SET XQATEXT(.1)=XQATEXT
DO WP^DIE(8992.01,(XQXI_","_XQJ_","),4,"","XQATEXT")
+3 LOCK -^XTV(8992,XQJ)
+4 KILL XQA(XQJ)
if XQAID'=""
SET ^XTV(8992,"AXQA",XQAID,XQJ,XQXI)=""
SET ^XTV(8992,"AXQAN",XQA1,XQJ,XQXI)=""
+5 SET XQNRECIP=XQNRECIP+1
+6 GOTO LOOP
+7 ;
WRAP ;
+1 MERGE XQALIST1=XQALIST
+2 IF XQNRECIP=0
IF '$$SNDNACTV(XQAID)
SET RETVAL=0
SET XQALERR="NO ACTIVE RECIPIENTS - OLDER TIU ALERTS"
+3 ; SET NUMBER OF RECIPIENTS TO 1 SO WE WON'T COME HERE AGAIN
IF '$TEST
IF XQNRECIP=0
Begin DoDot:1
+4 NEW XQAA,XQJ
FOR XQI=0:0
SET XQI=$ORDER(XQALIST(XQI))
if XQI'>0
QUIT
DO GETBKUP^XQALDEL(.XQAA,XQI)
SET XQALTYPE="BACKUP REVIEWER"
FOR XQJ=0:0
SET XQJ=$ORDER(XQAA(XQJ))
if XQJ'>0
QUIT
SET XQA(XQAA(XQJ))=""
+5 IF $DATA(XQA)
DO CHEKACTV^XQALSET1(.XQA)
+6 ;D GETMLGRP(.XQA,XQI) ; COULDN'T FIND ANY BACKUP, GET A MAILGROUP AND MEMBERS TO SEND IT TO
IF '$DATA(XQA)
SET XQJ="G.XQAL UNPROCESSED ALERTS"
DO GROUP^XQALSET1
SET XQALTYPE="UNPROCESSED ALERTS MAIL GROUP"
+7 ; Last gasp, send it to G.PATCHES
IF '$DATA(XQA)
SET XQJ="G.PATCHES"
DO GROUP^XQALSET1
SET XQALTYPE="LAST HOPE"
+8 ; Last gasp, send it to G.PATCH
IF '$DATA(XQA)
SET XQJ="G.PATCH"
DO GROUP^XQALSET1
SET XQALTYPE="LAST HOPE"
+9 ; Should not get here, this is only if all backups and mail groups tried don't have any active users
IF '$DATA(XQA)
SET RETVAL=0
SET XQALERR="Could not find any active user to send it to"
+10 QUIT
End DoDot:1
IF $DATA(XQA)
SET XQACOMNT=$EXTRACT("None of recipients were active users. "_$GET(XQACOMNT),1,245)
SET XQNRECIP=1
SET XQARESET=1
KILL XQALIST
GOTO LOOP2
+11 ; END OF JLI 030129 INSERTION P285
+12 ; moved recording of users in Alert Tracking file to here to include all of them 030220
+13 ; modified code to use FM calls instead of direct global references
+14 ; moved to here to avoid tracking entries with no users
IF RETVAL
IF $GET(XQADA)'>0
IF XQAID'=""
DO SETTRACK
+15 ;
+16 ; 030131
IF RETVAL
IF $GET(XQADA)>0
LOCK +^XTV(8992.1,XQADA):10
Begin DoDot:1
+17 FOR XQJ=0:0
SET XQJ=$ORDER(XQALIST1(XQJ))
if XQJ'>0
QUIT
Begin DoDot:2
+18 NEW NCOUNT,SUBSCRPT,SUBSCRPN,KCNT,IENVAL
+19 SET IENVAL=XQADA_","
SET KCNT=$$FIND1^DIC(8992.11,","_IENVAL,"Q",XQJ)
+20 SET FDA=$NAME(^TMP($JOB,"XQALSET"))
KILL @FDA
IF KCNT=0
SET @FDA@(8992.11,"+1,"_IENVAL,.01)=XQJ
SET KCNT="+1"
+21 SET IENVAL=","_KCNT_","_IENVAL
SET NCOUNT=1
SET SUBSCRPT=""
FOR
SET SUBSCRPT=$ORDER(XQALIST1(XQJ,SUBSCRPT))
if SUBSCRPT=""
QUIT
IF $EXTRACT(SUBSCRPT,1)'="z"
Begin DoDot:3
+22 SET SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT)
IF SUBSCRPN'>0
Begin DoDot:4
+23 NEW FDA1,IENROOT
SET FDA1=$NAME(^TMP($JOB,"XQALSET1"))
KILL @FDA1
SET @FDA1@(8992.2,"+1,",.01)=SUBSCRPT
DO UPDATE^DIE("",FDA1,"IENROOT")
SET SUBSCRPN=$GET(IENROOT(1))
+24 QUIT
End DoDot:4
+25 SET NCOUNT=NCOUNT+1
SET @FDA@(8992.111,"+"_NCOUNT_IENVAL,.01)=SUBSCRPN
SET @FDA@(8992.111,"+"_NCOUNT_IENVAL,.04)=XQADATIM
+26 QUIT
End DoDot:3
+27 IF $DATA(XQALIST1(XQJ,"z TO_SURO"))
SET @FDA@(8992.111,"+"_NCOUNT_IENVAL,.02)=$ORDER(XQALIST1(XQJ,"z TO_SURO",0))
+28 IF $DATA(XQALIST1(XQJ,"z AS_SURO"))
Begin DoDot:3
+29 SET @FDA@(8992.111,"+"_NCOUNT_IENVAL,.03)="Y"
+30 NEW XQK
SET NCOUNT=NCOUNT+1
FOR XQK=0:0
SET XQK=$ORDER(XQALIST1(XQJ,"z AS_SURO",XQK))
if XQK'>0
QUIT
SET @FDA@(8992.113,"+"_NCOUNT_IENVAL,.01)=XQK
SET @FDA@(8992.113,"+"_NCOUNT_IENVAL,.02)=XQADATIM
+31 QUIT
End DoDot:3
+32 ; FORWARDING
SET SUBSCRPT=$ORDER(XQALIST1(XQJ,""))
IF SUBSCRPT'["INITIAL"
SET SUBSCRPT=$PIECE(SUBSCRPT,"-")
Begin DoDot:3
+33 SET SUBSCRPN=$$FIND1^DIC(8992.2,"","X",SUBSCRPT)
IF SUBSCRPN'>0
Begin DoDot:4
+34 NEW FDA1,IENROOT
SET FDA1=$NAME(^TMP($JOB,"XQALSET1"))
KILL @FDA1
SET @FDA1@(8992.2,"+1,",.01)=SUBSCRPT
DO UPDATE^DIE("",FDA1,"IENROOT")
SET SUBSCRPN=$GET(IENROOT(1))
+35 QUIT
End DoDot:4
+36 SET NCOUNT=NCOUNT+1
SET @FDA@(8992.112,"+"_NCOUNT_IENVAL,.01)=XQADATIM
SET @FDA@(8992.112,"+"_NCOUNT_IENVAL,.02)=SUBSCRPN
IF $GET(XQACOMNT)'=""
SET @FDA@(8992.112,"+"_NCOUNT_IENVAL,1.01)=XQACOMNT
+37 IF $GET(XQAUSER)>0
SET @FDA@(8992.112,"+"_NCOUNT_IENVAL,.03)=XQAUSER
+38 QUIT
End DoDot:3
+39 NEW IENSTR
DO UPDATE^DIE("",FDA,"IENSTR")
+40 QUIT
End DoDot:2
+41 QUIT
End DoDot:1
LOCK -^XTV(8992.1,XQADA)
+42 ;
+43 IF RETVAL
SET RETVAL=RETVAL_U_$GET(XQADA)_U_XQAID
+44 if XQAID'=""
KILL ^XTV(8992,"AXQA",XQAID,0,0)
+45 ; P443 - clear global used to track processing of groups
KILL ^TMP("XQAGROUP",$JOB)
+46 KILL XQA,XQALIN,XQALIN1,XQAMSG,XQAID,XQAFLG,XQAOPT,XQAOPT1,XQAROU,XQADATA,XQI,XQX,XQJ,XQK,XQA1,XQACTMSG,XQJ,XQXI,XQAARCH,XQACNDEL,XQAREVUE,XQASUPV,XQASURO,XQATEXT
+47 QUIT RETVAL
+48 ;
SNDNACTV(XQAID) ; Determine if we go ahead and send alerts addressed only to inactive users to backup reviewers
+1 NEW XVAL
+2 IF $EXTRACT(XQAID,1,3)="TIU"
SET XVAL=$EXTRACT($PIECE(XQAID,";"),4,99)
SET XVAL=$$GET1^DIQ(8925,XVAL_",",1201,"I")
IF XVAL>0
IF $$FMDIFF^XLFDT(DT,XVAL)>60
QUIT 0
+3 QUIT 1
+4 ;
SETIEN(XQA1,XQI) ; determine unique XQAID value for alert
+1 NEW XQAID
+2 if $GET(XQA1)=""
SET XQA1="NO-ID"
FOR
SET XQAID=XQA1_";"_DUZ_";"_XQI
LOCK +^XTV(8992,"AXQA",XQAID):10
Begin DoDot:1
+3 IF $DATA(^XTV(8992,"AXQA",XQAID))
QUIT
+4 SET ^XTV(8992,"AXQA",XQAID,0,0)=""
SET XQI=""
+5 QUIT
End DoDot:1
LOCK -^XTV(8992,"AXQA",XQAID)
if XQI=""
QUIT
SET XQI=XQI+.00000001
+6 QUIT XQAID
+7 ;
SETTRACK ; Setup entry in Alert Tracking file
+1 ; Note: if there are error messages or we can't create an entry for some reason, it simply returns and continues
+2 NEW FDA,IENS,XQA2,DIERR
+3 SET XQADA=0
+4 SET XQA2=XQA1
IF XQA2[","
IF $PIECE(XQA2,",",3)'=""
SET XQA2=$PIECE(XQA2,",")_","_$PIECE(XQA2,",",3)
+5 FOR
Begin DoDot:1
+6 KILL DIERR,^TMP("DIERR",$JOB)
+7 SET FDA=$NAME(^TMP($JOB,"XQALSET"))
KILL @FDA
+8 SET @FDA@(8992.1,"+1,",.01)=XQAID
DO UPDATE^DIE("",FDA,"IENS")
+9 KILL @FDA
+10 QUIT
End DoDot:1
if '$DATA(DIERR)
QUIT
if '$DATA(^TMP("DIERR",$JOB,"E",111))
QUIT
+11 ;S XQDIERR1=DIERR M XQDIERR=^TMP("DIERR",$J) Q
IF $DATA(DIERR)
QUIT
+12 if IENS(1)'>0
QUIT
SET (DA,XQADA)=IENS(1)
+13 SET IENS=IENS(1)_","
SET @FDA@(8992.1,IENS,.02)=XQX
SET ^(.03)=XQA2
SET ^(.05)=DUZ
SET ^(1.01)=XQAMSG
+14 IF $DATA(XQAARCH)
SET X=$$FMADD^XLFDT(DT,XQAARCH)
IF X>DT
SET @FDA@(8992.1,IENS,.08)=X
+15 IF $PIECE(XQA1,",")="OR"
IF $PIECE(XQA1,",",2)>0
SET @FDA@(8992.1,IENS,.04)=$PIECE(XQA1,",",2)
+16 IF $DATA(ZTQUEUED)
SET @FDA@(8992.1,IENS,.06)=1
+17 IF $DATA(XQAOPT)#2
SET @FDA@(8992.1,IENS,1.02)=XQAOPT
+18 IF $DATA(XQAROU)#2
NEW XQAXX
SET XQAXX=$SELECT(XQAROU[U:XQAROU,1:U_XQAROU)
IF $PIECE(XQAXX,U,2)'=""
if $PIECE(XQAXX,U)'=""
SET @FDA@(8992.1,IENS,1.03)=$PIECE(XQAXX,U)
SET @FDA@(8992.1,IENS,1.04)=$PIECE(XQAXX,U,2)
+19 IF $DATA(XQACTMSG)
SET @FDA@(8992.1,IENS,1.05)=XQACTMSG
+20 IF $DATA(XQADATA)
SET @FDA@(8992.1,IENS,2)=XQADATA
+21 IF $DATA(XQAGUID)
SET @FDA@(8992.1,IENS,3.01)=XQAGUID
+22 IF $DATA(XQADFN)
SET @FDA@(8992.1,IENS,.04)=XQADFN
+23 DO FILE^DIE("KS",FDA)
+24 IF $DATA(XQATEXT)
DO WP^DIE(8992.1,IENS,4,"","XQATEXT")
+25 QUIT
+26 ;
CHEKUSER(XQAUSER) ; .SR Returns 0 if no valid user or surrogate, otherwise returns IEN of user or surrogate
+1 QUIT $$CHEKUSER^XQALSET1(XQAUSER)
+2 ;
