XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;Oct 06, 2022 12:08
;;8.0;KERNEL;**6,24,65,114,174,285,443,602,653,662,772**;Jul 10, 1995;Build 5
;Per VHA Directive 2004-038, this routine should not be modified
;;
Q
;
DELETE ;
N XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1
Q:'$D(XQAID) Q:XQAID="" S:'$D(XQAKILL) XQAKILL=0 S:$P(XQAID,";")="NO-ID" XQAKILL=1
S XQADAT=$$NOW^XLFDT()
I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
S XQAFOUND=0 D
. S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID S XQAFOUND=1 Q
S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT D PAR ; p662
K XQXX,XQXY
I '$D(^XTV(8992,"AXQA",XQAID,XQAUSER)) D KILLOC
F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL
. I XQAKILL S XQX=XQAUSER ; Make sure XQAKILL gets only XQAUSER
. F XQK=0:0 S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,XQK)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) S XQAID1=XQAID D:$D(^XTV(8992,XQX,"XQA",XQK,0)) DELA S XQAID=XQAID1
K XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL
Q
;
DELETEA ;
N XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ
Q:'$D(XQAID) Q:XQAID="" S XQA1=$P(XQAID,";")
S XQADAT=$$NOW^XLFDT()
I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
S:'$D(XQAKILL) XQAKILL=0 G:$P(XQAID,";")="NO-ID" DELETE
S XQAFOUND=0 D
. S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P($G(^(XQK,0)),U,2)=XQAID S XQAFOUND=1 Q
S XQXX=$O(^XTV(8992.1,"B",XQAID,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0,XQAFOUND,'$G(XQAUSERD) S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT D PAR ; p662
I '$D(^XTV(8992,"AXQAN",XQA1,XQAUSER)) D KILLOC
I $P(XQAID,",",2)'=""!($P(XQAID,";",2)="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQAN",XQA1,XQX)) Q:XQX'>0 D Q:XQAKILL
. I XQAKILL S XQX=XQAUSER
. F XQK=0:0 S XQK=$O(^XTV(8992,"AXQAN",XQA1,XQX,XQK)) Q:XQK'>0 K ^(XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
I $P(XQAID,",",2)=""&($P(XQAID,";",2)'="") F XQX=0:0 S XQX=$O(^XTV(8992,"AXQA",XQAID,XQX)) Q:XQX'>0 D Q:XQAKILL
. I XQAKILL S XQX=XQAUSER
. S XQK=$O(^XTV(8992,"AXQA",XQAID,XQX,0)) Q:XQK'>0 K ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK) I $D(^XTV(8992,XQX,"XQA",XQK,0)) D DELA
K XQAID,XQA1,XQX,XQK,XQAKILL
Q
DELA ;
N XQDEL11 S XQAID=$P($G(^XTV(8992,XQX,"XQA",XQK,0)),U,2),XQDEL11=$P($G(^(0)),U) K ^XTV(8992,XQX,"XQA",XQK) K:XQAID'="" ^XTV(8992,"AXQA",XQAID,XQX,XQK)
D COUNT(-1,XQX)
K:XQAID'="" ^XTV(8992,"AXQAN",$P(XQAID,";"),XQX,XQK) K:XQDEL11'="" ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK)
S XQXX=$S(XQAID'="":$O(^XTV(8992.1,"B",XQAID,0)),1:0) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQX,0))
I $G(XQXY),$P(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0 S $P(^(0),U,5)=XQADAT I $G(XQAUSERD) S $P(^(0),U,9)=DUZ
I '$G(XQAUSERD) D PAR ; p662
K XQXX,XQXY
Q
;
PAR ; p662 mwa set processed alert index
Q:'$G(XQXX) Q:'$G(XQXY) Q:'$G(XQX) Q:'$G(XQADAT)
; if processed field is not filled out for current user, mark as processed
I +$G(^XTV(8992.1,XQXX,20,XQXY,0))=DUZ,'$P($G(^(0)),U,4) S $P(^(0),U,4)=XQADAT
Q:'$P($G(^XTV(8992.1,XQXX,20,XQXY,0)),U,4)
S ^XTV(8992.1,"PAR",XQX,XQADAT,XQXX,XQXY)=""
; if user is "Surrogate for" a provider create "PAR" for provider (exclude if returned to provider)
I $D(^XTV(8992.1,XQXX,20,XQXY,3)),'$P($G(^(3,1,0)),U,3) D
. N XQXI,XQSUR,XQNUM S XQXI=0 F S XQXI=$O(^XTV(8992.1,XQXX,20,XQXY,3,XQXI)) Q:'XQXI D
. . S XQSUR=+$P($G(^XTV(8992.1,XQXX,20,XQXY,3,XQXI,0)),U)
. . S XQNUM=$O(^XTV(8992.1,XQXX,20,"B",XQSUR,0)) ; ien of surrogate in receipient subfile
. . I $G(XQSUR),$G(XQNUM) S ^XTV(8992.1,"PAR",XQSUR,XQADAT,XQXX,XQNUM)=""
Q
;
COUNT(%1,%2) ;Change the count on the zero node, (amount, user)
Q:$G(%2)'>0
L +^XTV(8992,%2):10
I %1 S %=$P($G(^XTV(8992,%2,"XQA",0)),U,4)+%1 S:%'<0 $P(^(0),U,4)=%
I '%1 D
. N % S %1=0,%=0 F S %=$O(^XTV(8992,%2,"XQA",%)) Q:%'>0 S %1=%1+1
. S $P(^XTV(8992,%2,"XQA",0),U,4)=%1
L -^XTV(8992,%2)
Q
KILLOC ;
N XQX,XQK
S XQX=XQAUSER F XQK=0:0 S XQK=$O(^XTV(8992,XQAUSER,"XQA",XQK)) Q:XQK'>0 I $P(^(XQK,0),U,2)=XQAID D
. N XQAID D DELA
Q
;
OLDDEL ;
N XQADAT,X2,XQDAT,XQDEL1
S XQADAT=$$NOW^XLFDT()
S X2=-15 I $G(ZTQPARAM)>0 S X2=-ZTQPARAM
S XQDAT=$$FMADD^XLFDT(DT,X2)
;Loop thru users (XQDEL1) levels
F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992,XQDEL1)) Q:XQDEL1'>0 D OLDDEL1
D KILLARCH
K X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT
Q
OLDDEL1 ;Loop thru the Alert (XQDEL2) level
L +^XTV(8992,XQDEL1):10
N XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA
S XQAGLOB=$NA(^XTV(8992,XQDEL1,"XQA")),XQAUSER=XQDEL1
F XQDEL2=0:0 S XQDEL2=$O(@XQAGLOB@(XQDEL2)) Q:XQDEL2'>0 S XQAZERO=^(XQDEL2,0) D
. ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174
. I $P($G(XQAZERO),"^",6)]""&($P($G(XQAZERO),"^",6)>XQDAT) Q ;For CPRS XU*8.0*653 Quit if the alert was deferred and the deferred date is greater than the purge date.
. I $P(XQAZERO,U,15)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,15))\1=DT D Q:$D(KILLOLD) ; changed '>DT to =DT so only send once without killing
. . N XQA D GETBKUP(.XQA,XQDEL1)
. . I $D(XQA) S XQALTYPE="BACKUP REVIEWER" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
. . Q ; End of Backup Reviewer Code -- P174
. I $P(XQAZERO,U,13)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,13))\1=DT D Q:$D(KILLOLD) ; P174
. . N XQA,I F I=0:0 S I=$O(^XMB(3.7,XQAUSER,9,I)) Q:I'>0 S XQAV=+^(I,0),XQA(XQAV)=XQAV
. . I $D(XQA) S XQALTYPE="EMAIL SURROGATE" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
. . Q
. I $P(XQAZERO,U,14)>0 I $$FMADD^XLFDT(+XQAZERO,+$P(XQAZERO,U,14))\1=DT D Q:$D(KILLOLD) ; P174
. . N XQA,I S I=$P($G(^VA(200,XQAUSER,5)),U) I I>0 S I=$P($G(^DIC(49,+I,0)),U,3) I I>0,$D(^VA(200,+I,0)) S XQA(+I)=+I
. . I $D(XQA) S XQALTYPE="CHIEF/SUPERVISOR" D FORWARD^XQALFWD($P(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01)) S KILLOLD=1
. . Q
. I XQDEL2'>XQDAT D OLDDEL2
. Q
K:$O(^XTV(8992,XQDEL1,"XQA",0))="" ^XTV(8992,XQDEL1,"XQA")
L -^XTV(8992,XQDEL1)
Q
;
OLDDEL2 ;
N XQA,XQXX,XQXY
S XQA=$P(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2) K ^XTV(8992,XQDEL1,"XQA",XQDEL2) K:XQA'="" ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$P(XQA,";"),XQDEL1)
D COUNT(-1,XQDEL1)
I XQA'="" S XQXX=$O(^XTV(8992.1,"B",XQA,0)) I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQDEL1,0)) I XQXY>0 S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT
Q
;
KILLARCH ;
;Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624
Q ; p772 INC24097729 prevent accidental purging/deleting of alerts
N DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK
S XQDAT=$$FMADD^XLFDT(DT,-30)
F XQDEL1=0:0 S XQDEL1=$O(^XTV(8992.1,XQDEL1)) Q:XQDEL1'>0 D
. S X1=$P($G(^XTV(8992.1,XQDEL1,0)),U,2),X2=$P($G(^(0)),U,8)
. S DA=XQDEL1 I X2="",X1>XQDAT Q
. I X2>0,DT<X2 Q
. S DIK="^XTV(8992.1," D ^DIK
Q
;
USERDEL ; Delete undesired alerts for a user
N DA,DIC,XQAUSERD
S DIC("A")="Select NEW PERSON entry for deletion of alerts: "
S DIC(0)="AEQM",DIC=200
D ^DIC K DIC Q:Y'>0 S XQAUSER=+Y
S XQALDELE=1
K XQX1
D DOIT^XQALERT1
K XQALDELE S XQAUSERD=1
I $D(XQX1),XQX1>0 D
. F Q:XQX1="" S DA=+XQX1,XQX1=$P(XQX1,",",2,99) D I XQX1="" S Y=$O(XQX1(0)) I Y>0 S XQX1=XQX1(Y) K XQX1(Y)
. . I $P(^TMP("XQ",$J,"XQA1",DA),U,6)]"" N XQADAT S XQADAT=$$NOW^XLFDT() I $P(^TMP("XQ",$J,"XQA1",DA),U,6)>XQADAT D Q ;For CPRS P653
. . . N Y S Y=$P(^TMP("XQ",$J,"XQA1",DA),U,1) D DD^%DT W !!,?10,"Alert Deferred - Alert "_Y_" Not Deleted!" Q
. . S XQAID=$P(^TMP("XQ",$J,"XQA1",DA),U,2),XQAKILL=1
. . I XQAID="" K ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$J,"XQA1",DA,1))
. . I XQAID'="" D DELETE
. . K ^TMP("XQ",$J,"XQA1",DA),^TMP("XQ",$J,"XQA",(999999-DA))
K XQAUSER,XQX1
Q
;
GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD
N I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST
S XQPARAM="XQAL BACKUP REVIEWER"
D GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=200 ; USER
I '($D(XQLIST)>1) S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 D GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=49 ; SERVICE
I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4 ; DIVISION
I '($D(XQLIST)>1) D GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR) S:$D(XQLIST)>1 XQPRAMTY=4.2 ; SYSTEM
F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
; Removed Teams per Curtis Anderson with CPRS
;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS
;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION
;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D
;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV
;. . Q`
;. Q
;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM)
;. S XQENTITY="SYS"
;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION
;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION
;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
;. Q
;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP
;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1
;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT
;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I
;. Q
Q
;
DIVENTIT(XQAUSER) ;
N ENTITY,NCNT,DIVNAM,I
S ENTITY="" I DUZ=XQAUSER S ENTITY="DIV.`"_DUZ(2)
I ENTITY="" D
. K NCNT,DIVNAM S NCNT=0 F I=0:0 S I=$O(^VA(200,XQAUSER,2,I)) Q:I'>0 S NCNT=NCNT+1,DIVNAM(NCNT)=+^(I,0) I $P(^(0),U,2) S DIVNAM=+^(0)
. I NCNT'>0 Q
. I NCNT=1 S ENTITY="DIV.`"_DIVNAM(1) Q
. I $D(DIVNAM)#2 S ENTITY="DIV.`"_DIVNAM Q
. F I=1:1:NCNT S ENTITY="DIV.`"_DIVNAM(I)_$S(ENTITY'="":U,1:"")_ENTITY
I ENTITY="" S ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I")
Q ENTITY
;
BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE
G BKUPREVW^XQALBUTL
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALDEL 10491 printed Dec 13, 2024@02:05:20 Page 2
XQALDEL ;ISC-SF.SEA/JLI - DELETE ALERTS ;Oct 06, 2022 12:08
+1 ;;8.0;KERNEL;**6,24,65,114,174,285,443,602,653,662,772**;Jul 10, 1995;Build 5
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 ;;
+4 QUIT
+5 ;
DELETE ;
+1 NEW XQAFOUND,XQADAT,XQX,XQK,XQXX,XQXY,XQJ,XQAID1
+2 if '$DATA(XQAID)
QUIT
if XQAID=""
QUIT
if '$DATA(XQAKILL)
SET XQAKILL=0
if $PIECE(XQAID,";")="NO-ID"
SET XQAKILL=1
+3 SET XQADAT=$$NOW^XLFDT()
+4 IF '$DATA(XQAUSER)
NEW XQAUSER
SET XQAUSER=DUZ
+5 SET XQAFOUND=0
Begin DoDot:1
+6 SET XQX=XQAUSER
FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQAUSER,"XQA",XQK))
if XQK'>0
QUIT
IF $PIECE(^(XQK,0),U,2)=XQAID
SET XQAFOUND=1
QUIT
End DoDot:1
+7 ; p662
SET XQXX=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF XQXX>0
SET XQXY=$ORDER(^XTV(8992.1,XQXX,20,"B",XQAUSER,0))
IF XQXY>0
IF XQAFOUND
IF '$GET(XQAUSERD)
SET $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
DO PAR
+8 KILL XQXX,XQXY
+9 IF '$DATA(^XTV(8992,"AXQA",XQAID,XQAUSER))
DO KILLOC
+10 FOR XQX=0:0
SET XQX=$ORDER(^XTV(8992,"AXQA",XQAID,XQX))
if XQX'>0
QUIT
Begin DoDot:1
+11 ; Make sure XQAKILL gets only XQAUSER
IF XQAKILL
SET XQX=XQAUSER
+12 FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,"AXQA",XQAID,XQX,XQK))
if XQK'>0
QUIT
KILL ^(XQK),^XTV(8992,"AXQAN",$PIECE(XQAID,";"),XQX,XQK)
SET XQAID1=XQAID
if $DATA(^XTV(8992,XQX,"XQA",XQK,0))
DO DELA
SET XQAID=XQAID1
End DoDot:1
if XQAKILL
QUIT
+13 KILL XQAID,XQX,XQJ,XQK,XQAID1,XQAKILL
+14 QUIT
+15 ;
DELETEA ;
+1 NEW XQA1,XQADAT,XQAFOUND,XQX,XQXX,XQXY,XQK,XQJ
+2 if '$DATA(XQAID)
QUIT
if XQAID=""
QUIT
SET XQA1=$PIECE(XQAID,";")
+3 SET XQADAT=$$NOW^XLFDT()
+4 IF '$DATA(XQAUSER)
NEW XQAUSER
SET XQAUSER=DUZ
+5 if '$DATA(XQAKILL)
SET XQAKILL=0
if $PIECE(XQAID,";")="NO-ID"
GOTO DELETE
+6 SET XQAFOUND=0
Begin DoDot:1
+7 SET XQX=XQAUSER
FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQAUSER,"XQA",XQK))
if XQK'>0
QUIT
IF $PIECE($GET(^(XQK,0)),U,2)=XQAID
SET XQAFOUND=1
QUIT
End DoDot:1
+8 ; p662
SET XQXX=$ORDER(^XTV(8992.1,"B",XQAID,0))
IF XQXX>0
SET XQXY=$ORDER(^XTV(8992.1,XQXX,20,"B",XQAUSER,0))
IF XQXY>0
IF XQAFOUND
IF '$GET(XQAUSERD)
SET $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,4)=XQADAT
DO PAR
+9 IF '$DATA(^XTV(8992,"AXQAN",XQA1,XQAUSER))
DO KILLOC
+10 IF $PIECE(XQAID,",",2)'=""!($PIECE(XQAID,";",2)="")
FOR XQX=0:0
SET XQX=$ORDER(^XTV(8992,"AXQAN",XQA1,XQX))
if XQX'>0
QUIT
Begin DoDot:1
+11 IF XQAKILL
SET XQX=XQAUSER
+12 FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,"AXQAN",XQA1,XQX,XQK))
if XQK'>0
QUIT
KILL ^(XQK)
IF $DATA(^XTV(8992,XQX,"XQA",XQK,0))
DO DELA
End DoDot:1
if XQAKILL
QUIT
+13 IF $PIECE(XQAID,",",2)=""&($PIECE(XQAID,";",2)'="")
FOR XQX=0:0
SET XQX=$ORDER(^XTV(8992,"AXQA",XQAID,XQX))
if XQX'>0
QUIT
Begin DoDot:1
+14 IF XQAKILL
SET XQX=XQAUSER
+15 SET XQK=$ORDER(^XTV(8992,"AXQA",XQAID,XQX,0))
if XQK'>0
QUIT
KILL ^(XQK),^XTV(8992,"AXQAN",XQA1,XQX,XQK)
IF $DATA(^XTV(8992,XQX,"XQA",XQK,0))
DO DELA
End DoDot:1
if XQAKILL
QUIT
+16 KILL XQAID,XQA1,XQX,XQK,XQAKILL
+17 QUIT
DELA ;
+1 NEW XQDEL11
SET XQAID=$PIECE($GET(^XTV(8992,XQX,"XQA",XQK,0)),U,2)
SET XQDEL11=$PIECE($GET(^(0)),U)
KILL ^XTV(8992,XQX,"XQA",XQK)
if XQAID'=""
KILL ^XTV(8992,"AXQA",XQAID,XQX,XQK)
+2 DO COUNT(-1,XQX)
+3 if XQAID'=""
KILL ^XTV(8992,"AXQAN",$PIECE(XQAID,";"),XQX,XQK)
if XQDEL11'=""
KILL ^XTV(8992,XQX,"XQA","B",XQDEL11,XQK)
+4 SET XQXX=$SELECT(XQAID'="":$ORDER(^XTV(8992.1,"B",XQAID,0)),1:0)
IF XQXX>0
SET XQXY=$ORDER(^XTV(8992.1,XQXX,20,"B",XQX,0))
+5 IF $GET(XQXY)
IF $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,5)'>0
SET $PIECE(^(0),U,5)=XQADAT
IF $GET(XQAUSERD)
SET $PIECE(^(0),U,9)=DUZ
+6 ; p662
IF '$GET(XQAUSERD)
DO PAR
+7 KILL XQXX,XQXY
+8 QUIT
+9 ;
PAR ; p662 mwa set processed alert index
+1 if '$GET(XQXX)
QUIT
if '$GET(XQXY)
QUIT
if '$GET(XQX)
QUIT
if '$GET(XQADAT)
QUIT
+2 ; if processed field is not filled out for current user, mark as processed
+3 IF +$GET(^XTV(8992.1,XQXX,20,XQXY,0))=DUZ
IF '$PIECE($GET(^(0)),U,4)
SET $PIECE(^(0),U,4)=XQADAT
+4 if '$PIECE($GET(^XTV(8992.1,XQXX,20,XQXY,0)),U,4)
QUIT
+5 SET ^XTV(8992.1,"PAR",XQX,XQADAT,XQXX,XQXY)=""
+6 ; if user is "Surrogate for" a provider create "PAR" for provider (exclude if returned to provider)
+7 IF $DATA(^XTV(8992.1,XQXX,20,XQXY,3))
IF '$PIECE($GET(^(3,1,0)),U,3)
Begin DoDot:1
+8 NEW XQXI,XQSUR,XQNUM
SET XQXI=0
FOR
SET XQXI=$ORDER(^XTV(8992.1,XQXX,20,XQXY,3,XQXI))
if 'XQXI
QUIT
Begin DoDot:2
+9 SET XQSUR=+$PIECE($GET(^XTV(8992.1,XQXX,20,XQXY,3,XQXI,0)),U)
+10 ; ien of surrogate in receipient subfile
SET XQNUM=$ORDER(^XTV(8992.1,XQXX,20,"B",XQSUR,0))
+11 IF $GET(XQSUR)
IF $GET(XQNUM)
SET ^XTV(8992.1,"PAR",XQSUR,XQADAT,XQXX,XQNUM)=""
End DoDot:2
End DoDot:1
+12 QUIT
+13 ;
COUNT(%1,%2) ;Change the count on the zero node, (amount, user)
+1 if $GET(%2)'>0
QUIT
+2 LOCK +^XTV(8992,%2):10
+3 IF %1
SET %=$PIECE($GET(^XTV(8992,%2,"XQA",0)),U,4)+%1
if %'<0
SET $PIECE(^(0),U,4)=%
+4 IF '%1
Begin DoDot:1
+5 NEW %
SET %1=0
SET %=0
FOR
SET %=$ORDER(^XTV(8992,%2,"XQA",%))
if %'>0
QUIT
SET %1=%1+1
+6 SET $PIECE(^XTV(8992,%2,"XQA",0),U,4)=%1
End DoDot:1
+7 LOCK -^XTV(8992,%2)
+8 QUIT
KILLOC ;
+1 NEW XQX,XQK
+2 SET XQX=XQAUSER
FOR XQK=0:0
SET XQK=$ORDER(^XTV(8992,XQAUSER,"XQA",XQK))
if XQK'>0
QUIT
IF $PIECE(^(XQK,0),U,2)=XQAID
Begin DoDot:1
+3 NEW XQAID
DO DELA
End DoDot:1
+4 QUIT
+5 ;
OLDDEL ;
+1 NEW XQADAT,X2,XQDAT,XQDEL1
+2 SET XQADAT=$$NOW^XLFDT()
+3 SET X2=-15
IF $GET(ZTQPARAM)>0
SET X2=-ZTQPARAM
+4 SET XQDAT=$$FMADD^XLFDT(DT,X2)
+5 ;Loop thru users (XQDEL1) levels
+6 FOR XQDEL1=0:0
SET XQDEL1=$ORDER(^XTV(8992,XQDEL1))
if XQDEL1'>0
QUIT
DO OLDDEL1
+7 DO KILLARCH
+8 KILL X1,X2,X,XQDEL1,XQDEL2,XQDAT,XQA,XQADAT
+9 QUIT
OLDDEL1 ;Loop thru the Alert (XQDEL2) level
+1 LOCK +^XTV(8992,XQDEL1):10
+2 NEW XQAGLOB,KILLOLD,XQAZERO,XQAUSER,XQLIST,Y,XQAV,XQPRAMTY,XQDEL2,XQA
+3 SET XQAGLOB=$NAME(^XTV(8992,XQDEL1,"XQA"))
SET XQAUSER=XQDEL1
+4 FOR XQDEL2=0:0
SET XQDEL2=$ORDER(@XQAGLOB@(XQDEL2))
if XQDEL2'>0
QUIT
SET XQAZERO=^(XQDEL2,0)
Begin DoDot:1
+5 ; CHECK FOR BACKUP REVIEWER TO FORWARD ALERTS NEEDING ACTION -- P174
+6 ;For CPRS XU*8.0*653 Quit if the alert was deferred and the deferred date is greater than the purge date.
IF $PIECE($GET(XQAZERO),"^",6)]""&($PIECE($GET(XQAZERO),"^",6)>XQDAT)
QUIT
+7 ; changed '>DT to =DT so only send once without killing
IF $PIECE(XQAZERO,U,15)>0
IF $$FMADD^XLFDT(+XQAZERO,+$PIECE(XQAZERO,U,15))\1=DT
Begin DoDot:2
+8 NEW XQA
DO GETBKUP(.XQA,XQDEL1)
+9 IF $DATA(XQA)
SET XQALTYPE="BACKUP REVIEWER"
DO FORWARD^XQALFWD($PIECE(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01))
SET KILLOLD=1
+10 ; End of Backup Reviewer Code -- P174
QUIT
End DoDot:2
if $DATA(KILLOLD)
QUIT
+11 ; P174
IF $PIECE(XQAZERO,U,13)>0
IF $$FMADD^XLFDT(+XQAZERO,+$PIECE(XQAZERO,U,13))\1=DT
Begin DoDot:2
+12 NEW XQA,I
FOR I=0:0
SET I=$ORDER(^XMB(3.7,XQAUSER,9,I))
if I'>0
QUIT
SET XQAV=+^(I,0)
SET XQA(XQAV)=XQAV
+13 IF $DATA(XQA)
SET XQALTYPE="EMAIL SURROGATE"
DO FORWARD^XQALFWD($PIECE(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01))
SET KILLOLD=1
+14 QUIT
End DoDot:2
if $DATA(KILLOLD)
QUIT
+15 ; P174
IF $PIECE(XQAZERO,U,14)>0
IF $$FMADD^XLFDT(+XQAZERO,+$PIECE(XQAZERO,U,14))\1=DT
Begin DoDot:2
+16 NEW XQA,I
SET I=$PIECE($GET(^VA(200,XQAUSER,5)),U)
IF I>0
SET I=$PIECE($GET(^DIC(49,+I,0)),U,3)
IF I>0
IF $DATA(^VA(200,+I,0))
SET XQA(+I)=+I
+17 IF $DATA(XQA)
SET XQALTYPE="CHIEF/SUPERVISOR"
DO FORWARD^XQALFWD($PIECE(XQAZERO,U,2),.XQA,"A","ALERT NOT PROCESSED BY "_$$GET1^DIQ(200,XQDEL1_",",.01))
SET KILLOLD=1
+18 QUIT
End DoDot:2
if $DATA(KILLOLD)
QUIT
+19 IF XQDEL2'>XQDAT
DO OLDDEL2
+20 QUIT
End DoDot:1
+21 if $ORDER(^XTV(8992,XQDEL1,"XQA",0))=""
KILL ^XTV(8992,XQDEL1,"XQA")
+22 LOCK -^XTV(8992,XQDEL1)
+23 QUIT
+24 ;
OLDDEL2 ;
+1 NEW XQA,XQXX,XQXY
+2 SET XQA=$PIECE(^XTV(8992,XQDEL1,"XQA",XQDEL2,0),U,2)
KILL ^XTV(8992,XQDEL1,"XQA",XQDEL2)
if XQA'=""
KILL ^XTV(8992,"AXQA",XQA,XQDEL1),^XTV(8992,"AXQAN",$PIECE(XQA,";"),XQDEL1)
+3 DO COUNT(-1,XQDEL1)
+4 IF XQA'=""
SET XQXX=$ORDER(^XTV(8992.1,"B",XQA,0))
IF XQXX>0
SET XQXY=$ORDER(^XTV(8992.1,XQXX,20,"B",XQDEL1,0))
IF XQXY>0
SET $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,6)=XQADAT
+5 QUIT
+6 ;
KILLARCH ;
+1 ;Q ; turn off deletion from ALERT TRACKING file ; remove from XU*8*285 JLI 040624
+2 ; p772 INC24097729 prevent accidental purging/deleting of alerts
QUIT
+3 NEW DA,DIK,XQDAT,XQDEL1,X1,X2,DA,DIK
+4 SET XQDAT=$$FMADD^XLFDT(DT,-30)
+5 FOR XQDEL1=0:0
SET XQDEL1=$ORDER(^XTV(8992.1,XQDEL1))
if XQDEL1'>0
QUIT
Begin DoDot:1
+6 SET X1=$PIECE($GET(^XTV(8992.1,XQDEL1,0)),U,2)
SET X2=$PIECE($GET(^(0)),U,8)
+7 SET DA=XQDEL1
IF X2=""
IF X1>XQDAT
QUIT
+8 IF X2>0
IF DT<X2
QUIT
+9 SET DIK="^XTV(8992.1,"
DO ^DIK
End DoDot:1
+10 QUIT
+11 ;
USERDEL ; Delete undesired alerts for a user
+1 NEW DA,DIC,XQAUSERD
+2 SET DIC("A")="Select NEW PERSON entry for deletion of alerts: "
+3 SET DIC(0)="AEQM"
SET DIC=200
+4 DO ^DIC
KILL DIC
if Y'>0
QUIT
SET XQAUSER=+Y
+5 SET XQALDELE=1
+6 KILL XQX1
+7 DO DOIT^XQALERT1
+8 KILL XQALDELE
SET XQAUSERD=1
+9 IF $DATA(XQX1)
IF XQX1>0
Begin DoDot:1
+10 FOR
if XQX1=""
QUIT
SET DA=+XQX1
SET XQX1=$PIECE(XQX1,",",2,99)
Begin DoDot:2
+11 ;For CPRS P653
IF $PIECE(^TMP("XQ",$JOB,"XQA1",DA),U,6)]""
NEW XQADAT
SET XQADAT=$$NOW^XLFDT()
IF $PIECE(^TMP("XQ",$JOB,"XQA1",DA),U,6)>XQADAT
Begin DoDot:3
+12 NEW Y
SET Y=$PIECE(^TMP("XQ",$JOB,"XQA1",DA),U,1)
DO DD^%DT
WRITE !!,?10,"Alert Deferred - Alert "_Y_" Not Deleted!"
QUIT
End DoDot:3
QUIT
+13 SET XQAID=$PIECE(^TMP("XQ",$JOB,"XQA1",DA),U,2)
SET XQAKILL=1
+14 IF XQAID=""
KILL ^XTV(8992,XQAUSER,"XQA",+^TMP("XQ",$JOB,"XQA1",DA,1))
+15 IF XQAID'=""
DO DELETE
+16 KILL ^TMP("XQ",$JOB,"XQA1",DA),^TMP("XQ",$JOB,"XQA",(999999-DA))
End DoDot:2
IF XQX1=""
SET Y=$ORDER(XQX1(0))
IF Y>0
SET XQX1=XQX1(Y)
KILL XQX1(Y)
End DoDot:1
+17 KILL XQAUSER,XQX1
+18 QUIT
+19 ;
GETBKUP(XQA,XQAUSER) ; JLI 030129 - REMOVED TO SEPARATE METHOD
+1 NEW I,XQORY,XQENTITY,XQPARAM,XQERR,K,XQAV,XQLIST
+2 SET XQPARAM="XQAL BACKUP REVIEWER"
+3 ; USER
DO GETLST^XPAR(.XQLIST,"USR.`"_XQAUSER,XQPARAM,"Q",.XQERR)
if $DATA(XQLIST)>1
SET XQPRAMTY=200
+4 ; SERVICE
IF '($DATA(XQLIST)>1)
SET I=$$GET1^DIQ(200,XQAUSER_",",29,"I")
IF I>0
DO GETLST^XPAR(.XQLIST,"SRV.`"_I,XQPARAM,"Q",.XQERR)
if $DATA(XQLIST)>1
SET XQPRAMTY=49
+5 ; DIVISION
IF '($DATA(XQLIST)>1)
DO GETLST^XPAR(.XQLIST,$$DIVENTIT(XQAUSER),XQPARAM,"Q",.XQERR)
if $DATA(XQLIST)>1
SET XQPRAMTY=4
+6 ; SYSTEM
IF '($DATA(XQLIST)>1)
DO GETLST^XPAR(.XQLIST,"SYS",XQPARAM,"Q",.XQERR)
if $DATA(XQLIST)>1
SET XQPRAMTY=4.2
+7 FOR I=0:0
SET I=$ORDER(XQLIST(I))
if I'>0
QUIT
SET XQAV=$PIECE(XQLIST(I),U,2)
SET XQA(XQAV)=XQAV
+8 ; Removed Teams per Curtis Anderson with CPRS
+9 ;I '$D(XQA) D ; NONE UNDER USER - CHECK FOR ENTRIES IN PARAMETER FILE FOR TEAMS
+10 ;. I $T(TEAMPR^ORQPTQ1)]"" D TEAMPR^ORQPTQ1(.XQORY,XQAUSER) K:+$G(XQORY(1))<1 XQORY ; GET TEAM ID'S IF ANY ; CONTROLLED SUBSCRIPTION
+11 ;. S I=0 F S I=$O(XQORY(I)) Q:I'>0 K XQLIST D GETLST^XPAR(.XQLIST,$P(XQORY(I),U,2)_";OR(100.21,",XQPARAM,"Q",.ERR) I $D(XQTEAM) D
+12 ;. . N K F K=0:0 S K=$O(XQLIST(K)) Q:K'>0 S XQAV=$P(XQLIST(K),U,2),XQA(XQAV)=XQAV
+13 ;. . Q`
+14 ;. Q
+15 ;I '$D(XQLIST) D ; NO TEAM ENTRIES, CHECK OTHER ENTITIES (SERVICE,DIVISION,SYSTEM)
+16 ;. S XQENTITY="SYS"
+17 ;. S I=$$GET1^DIQ(200,XQAUSER_",",16,"I") I I>0 S XQENTITY="DIV.`"_I_U_XQENTITY ; DIVISION
+18 ;. S I=$$GET1^DIQ(200,XQAUSER_",",29,"I") I I>0 S XQENTITY="SRV.`"_I_U_XQENTITY ; SERVICE\SECTION
+19 ;. D GETLST^XPAR(.XQLIST,XQENTITY,XQPARAM,"Q",.XQERR) F I=0:0 S I=$O(XQLIST(I)) Q:I'>0 S XQAV=+$P(XQLIST(I),U,2),XQA(XQAV)=XQAV
+20 ;. Q
+21 ;I '$D(XQA) D ; NO PARAMETERS ENTERED - USE LAST RESORT MAIL GROUP
+22 ;. S XQJ="G.XQAL UNPROCESSED ALERTS" D GROUP^XQALSET1
+23 ;. I '$D(XQA) S XQJ="G.PATCH" D GROUP^XQALSET1 ; REALLY LAST RESORT
+24 ;. F I=0:0 S I=$O(XQA(I)) Q:I'>0 S XQA(I)=I
+25 ;. Q
+26 QUIT
+27 ;
DIVENTIT(XQAUSER) ;
+1 NEW ENTITY,NCNT,DIVNAM,I
+2 SET ENTITY=""
IF DUZ=XQAUSER
SET ENTITY="DIV.`"_DUZ(2)
+3 IF ENTITY=""
Begin DoDot:1
+4 KILL NCNT,DIVNAM
SET NCNT=0
FOR I=0:0
SET I=$ORDER(^VA(200,XQAUSER,2,I))
if I'>0
QUIT
SET NCNT=NCNT+1
SET DIVNAM(NCNT)=+^(I,0)
IF $PIECE(^(0),U,2)
SET DIVNAM=+^(0)
+5 IF NCNT'>0
QUIT
+6 IF NCNT=1
SET ENTITY="DIV.`"_DIVNAM(1)
QUIT
+7 IF $DATA(DIVNAM)#2
SET ENTITY="DIV.`"_DIVNAM
QUIT
+8 FOR I=1:1:NCNT
SET ENTITY="DIV.`"_DIVNAM(I)_$SELECT(ENTITY'="":U,1:"")_ENTITY
End DoDot:1
+9 IF ENTITY=""
SET ENTITY="DIV.`"_$$GET1^DIQ(8989.3,"1,",217,"I")
+10 QUIT ENTITY
+11 ;
BKUPREVW ;OPT - SET BACKUP REVIEWER(S) IN PARAMETER FILE
+1 GOTO BKUPREVW^XQALBUTL
+2 ;
