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