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