XQALDATA ;ISC/JLI ISD/HGW - PROVIDE DATA ON ALERTS ; Mar 23, 2023@8:00
;;8.0;KERNEL;**207,285,443,513,602,653,734,662,772,784**;Jul 10, 1995;Build 6
;Per VHA Directive 2004-038, this routine should not be modified
Q
GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; SR. ICR #4834 (private OE/RR)
N XREF,XVAL,X,X2,X3,I,NCNT ; P443
S:$G(XQAUSER)'>0 XQAUSER=DUZ
S:$G(FRSTDATE)'>0 FRSTDATE=0
S:$G(LASTDATE)'>0 LASTDATE=0
S NCNT=0 K @ROOT
I FRSTDATE=0 D Q
. F I=0:0 S I=$O(^XTV(8992,XQAUSER,"XQA",I)) Q:I'>0 S X=^(I,0),X3=$G(^(3)),X2=$G(^(2)) D
. . S NCNT=NCNT+1
. . S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X,U,7,8)="^ ":"I ",1:" ")_$P(X,U,3)_U_$P(X,U,2)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
. S @ROOT=NCNT
S XREF="R"
S XVAL=XQAUSER
D CHKTRAIL
Q
GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
N XREF,XVAL,NCNT
S NCNT=0 K @ROOT
I $G(PATIENT)'>0 S @ROOT=0 Q
S XREF="C"
S XVAL=PATIENT
D CHKTRAIL
Q
GETPAT2(ROOT,PATIENT,PAGE,LIMIT) ; P653
N XREF,XVAL,NCNT
S NCNT=0 K @ROOT
I $G(PATIENT)'>0 S @ROOT=0 Q
S XREF="C"
S XVAL=PATIENT
D GETPAGE
Q
GETPAGE ;P653
N XQ1,XQCNT,XQSTART,XQEND,XQCNTTOT
S XQ1="",XQCNT=0,XQCNTTOT=0
S XQSTART=(PAGE-1)*LIMIT+1
S XQEND=PAGE*LIMIT
F S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1),-1) Q:'XQ1 D
. S XQCNT=XQCNT+1
. I (XQCNT>=XQSTART),(XQCNT<=XQEND) D
. . S XQCNTTOT=XQCNTTOT+1
. . N X,X1,X2,X3
. . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
. . S @ROOT@(XQCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"")
S @ROOT@(0)=PAGE_U_(XQCNT\LIMIT+$S(XQCNT#LIMIT:1,1:0)) ; @ROOT@(0)=PAGE^TOTALPAGES
S @ROOT=XQCNTTOT
Q
CHKTRAIL ;
; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER
N XQ1,X,X1,X2,X3
F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D
. S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
. I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q
. I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q
. I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q
. S NCNT=NCNT+1
. S @ROOT@(NCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"") ; P443
S @ROOT=NCNT
Q
GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE,FLAG) ;Add FLAG to check for deferred alert. P653
N NCNT,KEY
S NCNT=0 K @ROOT S @ROOT=NCNT ; p772
S:$G(XQAUSER)'>0 XQAUSER=DUZ
S:$G(FRSTDATE)'>0 FRSTDATE=0
S:$G(LASTDATE)'>0 LASTDATE=0
S:$G(FLAG)'>0 FLAG=0 ;P653
I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D
. D RETURN^XQALSUR1(XQAUSER) ; P513
. ;D RETURN(XQAUSER) ; p734
; p734
N SURFOR D SUROFOR^XQALSURO(.SURFOR,XQAUSER) I SURFOR D FORWARD(.SURFOR,XQAUSER)
; p772 LOCK to prevent conflict with daily cleanup or other modifying events
I FRSTDATE=0 D L -^XTV(8992,XQAUSER) Q
. L +^XTV(8992,XQAUSER):10 ;Q:'$T p772 v4 continue if no LOCK. improvements to LOCK in future patch with CPRS
. I '$O(^XTV(8992,XQAUSER,"XQA",0)) Q
. N X,X2,X3,X4,XDEF,XCKUSER,I S I="" F S I=$O(^XTV(8992,XQAUSER,"XQA",I),-1) Q:I'>0 S X=^(I,0),X2=$G(^(2)),X3=$G(^(3)),X4=$D(^(4)) S XDEF=$P($G(X),"^",6) D ; P653
. . N XNOW,XQUIT S XQUIT=0
. . I $G(FLAG)>0 D Q:XQUIT=1
. . . S XNOW=$$NOW^XLFDT()
. . . I XDEF'="" D
. . . . I XNOW<XDEF S XQUIT=1
. . . . Q
. . I $P(X,U,4)'="" D
. . . N XQAID,XQXX,XQXY,XQADAT ; P513, update ALERT TRACKING FILE
. . . S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; P513 - MARK SEEN
. . . S XQAID=$P(X,U,2) ; P513
. . . S XQXX=$O(^XTV(8992.1,"B",XQAID,0)),XQXY=0,XQADAT=$$NOW^XLFDT() ;P513
. . . I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0 D
. . . . I $P(^XTV(8992.1,XQXX,20,XQXY,0),U,2)="" S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,2)=XQADAT
. . . . I $P(^XTV(8992.1,XQXX,20,XQXY,0),U,3)="" S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,3)=XQADAT
. . S NCNT=NCNT+1
. . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X,U,7,8)="^ ":"I ",1:"R "),@ROOT@(NCNT)=KEY_$P(X,U,3)_U_$P(X,U,2)
. . I X2'="" D
. . . S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($P(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($P(X2,U,2),1)_U_$P(X,U,2)
. . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2)
. . . Q
. S @ROOT=NCNT
. Q
Q
;
;
; Get XQAUSER's PROCESSED alerts where the processed date is between FRSTDATE and LASTDATE
; If MAXRET is passed, only return up to MAXRET alerts. MAXRET must be > 0 or it will default to 1 P784
; The PROONLY and FLAG parameters are not used
; Hard code the returned processed alerts to descending order P784
GETUSER2(ROOT,XQAUSER,FRSTDATE,LASTDATE,MAXRET,PROONLY,FLAG) ;Get PROCESSED alerts rather than pending alerts p662
I '$D(ROOT) Q ;Quit if ROOT is undefined P784
K @ROOT
S @ROOT=0
I ($G(XQAUSER)'>0)&($G(DUZ)'>0) Q ;Quit is XQAUSER and DUZ are '> 0 P784
S:$G(XQAUSER)'>0 XQAUSER=DUZ
S:$G(FRSTDATE)'>0 FRSTDATE=0
S:$G(LASTDATE)'>0 LASTDATE=0
S:$G(MAXRET)'>0 MAXRET=1 ;Default to 1 record returned if no parameter passed p784
N NCNT,RECIPDA,PDATE
S NCNT=0
I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER)
S RECIPDA=XQAUSER Q:'$D(^XTV(8992.1,"PAR",XQAUSER)) D
. N XDA,XMDA,X,X1,X2,X3,X4,X20
. N KEY,TYPNODE,RTYP,SURRFOR,PROCBY,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE
. ;p784
. ; Add the ",-1" parameter to the $O command for descending order
. ; Initialize PDATE to LASTDATE and add a small offset so that LASTDATE is included
. S PDATE=LASTDATE I PDATE'=0 S PDATE=PDATE+.000001
. F S PDATE=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE),-1) Q:PDATE<FRSTDATE!(PDATE="") D
. . S XDA="" F S XDA=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA)) Q:XDA="" I $D(^XTV(8992.1,XDA)) D
. . . S XMDA="" F S XMDA=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA,XMDA)) Q:XMDA="" D
. . . . S X=$G(^XTV(8992.1,XDA,0)),X1=$G(^(1)),X2=$G(^(2)),X3=$G(^(3)),X4=$G(^(4))
. . . . S X20(0)=$G(^XTV(8992.1,XDA,20,XMDA,0))
. . . . S (SURRFOR,PROCBY,RTYP,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE)=""
. . . . S RETURN=$P($G(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U,3)
. . . . I RETURN Q
. . . . S LASTTYPE=$O(^XTV(8992.1,XDA,20,XMDA,1,999999999),-1)
. . . . S TYPNODE=$G(^XTV(8992.1,XDA,20,XMDA,1,LASTTYPE,0))
. . . . I $P(TYPNODE,U)]"" S RTYP=$G(^XTV(8992.2,$P(TYPNODE,U),0))
. . . . I RTYP="FWD BY USER" D
. . . . . N LASTFWD,FWD0
. . . . . S LASTFWD=$O(^XTV(8992.1,XDA,20,XMDA,2,999999999),-1)
. . . . . S FWD0=$G(^XTV(8992.1,XDA,20,XMDA,2,LASTFWD,0))
. . . . . S FWDNM=+$P(FWD0,U,3)
. . . . . I +FWDNM>0 D
. . . . . . S FWDDT=$TR($$FMTE^XLFDT($P(FWD0,U,1),2),"@"," ")
. . . . . . S FWDNM=$P($G(^VA(200,FWDNM,0)),U)_" "_FWDDT
. . . . N I,BEST S (I,BEST)=0 F S I=$O(^XTV(8992.1,XDA,20,I)) Q:'I D
. . . . . N TMP0 S TMP0=$G(^XTV(8992.1,XDA,20,I,0))
. . . . . I $P(TMP0,U,4),'$P($G(^XTV(8992.1,XDA,20,I,3,1,0)),U,3) D ; if recipient has processed, excluding returned from surrogate
. . . . . . I $P(TMP0,U,4)>BEST S BEST=$P(TMP0,U,4),PROCBY=$P($G(^VA(200,$P(TMP0,U),0)),U)
. . . . I PROCBY="" S PROCBY="UNKNOWN"
. . . . S SURRDA=$P($G(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U)
. . . . I SURRDA]"" S SURRFOR=$P($G(^VA(200,SURRDA,0)),U)
. . . . S NCNT=NCNT+1
. . . . I MAXRET,NCNT>MAXRET Q
. . . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X1,U,3,4)="^ ":"I ",1:"R ")
. . . . S @ROOT@(NCNT)=KEY_$P(X1,U)_U_$P(X,U)
. . . . S @ROOT@(NCNT,"PROCESSED")=$P(X20(0),U,2)_U_$P(X20(0),U,3)_U_$P(X20(0),U,4)_U_$P(X20(0),U,5)_U_RTYP_U_PROCBY_U_SURRFOR_U_FWDNM
I MAXRET,NCNT>MAXRET S NCNT=MAXRET
S @ROOT=NCNT
Q
;
DEFALERT(ROOT,XQAUSER1,DEFDATE,ALERTID) ;ADD DEFERRED DATE/TIME TO ALERT; FOR CPRS USE P653
;ROOT =Global created to store the information
;XQAUSER1 =User responsible for the alert
;DEFDATE =The date/time the alert is deferred til...user
; responsible sets the date...maximum of 14 days
; from the date/time deferred.
;ALERTID =ALERT ID - the IEN of the alert in file 8992 2nd piece
; of the alert date/time multiple.
; DG,IEN of file;original recipient;date/time of alert
N NCNT,X,X1,X2,%
S NCNT=0 K @ROOT
S:$G(XQAUSER1)'>0 XQAUSER=DUZ
I $G(DEFDATE)'>0 D Q
. S @ROOT@(1)="-1^No Deferred Date/Time has been entered. The alert will not be deferred!"
. Q
; Check deferred date can't be over 14 days deferred.
D NOW^%DTC S X1=%,X2=14 D C^%DTC
I DEFDATE>X D Q
. S @ROOT@(1)="-1^Deferred Date/Time is greater than 14 days in the future. The alert will not be deferred!"
. Q
; Check if surrogacy is before DEFDATE. p734
N SURFOR D SUROFOR^XQALSURO(.SURFOR,XQAUSER1) I SURFOR D
. N USERS D USERLIST^XQALBUTL($G(ALERTID),$NAME(USERS)) I $D(USERS)>9 D
. . N COMUSERS D COMMON(.SURFOR,.USERS,.COMUSERS) I COMUSERS D
. . . N DEFDATE1 S DEFDATE1=$$MINEND(.COMUSERS,DEFDATE)
. . . I DEFDATE1<DEFDATE S DEFDATE=DEFDATE1,@ROOT@(1)="1^Deferred Date set to end of surrogacy: "_DEFDATE
;
N XDT,XFLAG S XFLAG=0,XDT=$P(ALERTID,";",3)-.00000001 ;P653
F XDT=XDT:0 S XDT=$O(^XTV(8992,XQAUSER1,"XQA",XDT)) Q:XDT'>0!(XFLAG=1) I $D(^XTV(8992,XQAUSER1,"XQA",XDT,0)) D Q:XFLAG=1 ;P653
.I $P(^XTV(8992,XQAUSER1,"XQA",XDT,0),"^",2)=ALERTID S XFLAG=1 Q ;P653
I 'XFLAG D Q ; p734
. S @ROOT@(1)="-1^No match on alert id. The alert will not be deferred!"
. Q
S DA(1)=XQAUSER1
S DA=XDT
S DIE="^XTV(8992,"_DA(1)_","_"""XQA"""_","
S DR=".06///^S X=DEFDATE"
;Lock Subentry
L +^XTV(8992,XQAUSER1,"XQA",DA):10
;Update value
D ^DIE
;Unlock subentry
L -^XTV(8992,XQAUSER1,"XQA",DA) ; p734
K DA,DIE,DR
Q
;. . . I XCKUSER=XQAUSER&(XNOW<XDEF) S XQUIT=1
Q
GETPAT3(ROOT,PATIENT,XFROM,XTO) ;
N XREF,XVAL,NCNT,XQ1,XQCNT,XQSTART,XQEND,X,XDATE,X1,X2,X3
S NCNT=0 K @ROOT
I $G(PATIENT)'>0 S @ROOT=0 Q
S XREF="C"
S XVAL=PATIENT
S XQ1="",XQCNT=0
F S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1),-1) Q:'XQ1 D
. S X=$G(^XTV(8992.1,XQ1,0)) Q:X=""
. Q:'$D(^XTV(8992,"AXQA",$P(X,U)))
. S XDATE=$P(X,U,2)
. I XDATE'<XFROM,XDATE'>XTO D
. . S XQCNT=XQCNT+1
. . S X1=$G(^XTV(8992.1,XQ1,1)),X3=$G(^(3)),X2=$G(^(2))
. . S @ROOT@(XQCNT)=$S($P(X3,U)'="":"G ",$P(X1,U,2,3)="^":"I ",$P(X1,U,2,3)="":"I ",1:" ")_$P(X1,U)_U_$P(X,U)_$S($P(X2,U,3)'="":U_$P(X2,U,3),1:"")
S @ROOT@(0)=XQCNT
Q
;
COMMON(SURFOR,USERS,RES) ; List of users common in SURFOR and USERS. p734
N I,J,K
K RES S RES=0
Q:'$G(SURFOR)
Q:$D(USERS)<10
S K=0
S I=0 F S I=$O(SURFOR(I)) Q:'I D
. S J=0 F S J=$O(USERS(J)) Q:'J D
. . I $P(USERS(J),U)=$P(SURFOR(I),U) S K=K+1,RES(K)=SURFOR(I)
S RES=K
Q
;
MINEND(SURFOR,ENDDATE) ; Minimum of ENDDATE and end dates in surrogacy. p734
N XQI
Q:'$G(SURFOR) $G(ENDDATE)
S ENDDATE=$G(ENDDATE,$$FMADD^XLFDT($$NOW^XLFDT,100))
F XQI=1:1:SURFOR D
. N X
. S X=$P(SURFOR(XQI),U,4)
. Q:X="" ; surrogacy with no end date
. S X=$$ETFM(X) Q:'X
. I X<ENDDATE S ENDDATE=X
Q ENDDATE
;
ETFM(EXDATE) ; p734 external to internal FM date
N %DT,X,Y S %DT="TS"
S X=$G(EXDATE) D ^%DT
Q Y
;
FORWARD(SURFOR,SURR) ; p734 Forward deferred-alerts to current surrogate
Q:'$G(SURFOR)
N I,IEN,XQAUSER
; for each original recipient
S I=0 F S I=$O(SURFOR(I)) Q:'I S XQAUSER=$P(SURFOR(I),U) D
. S IEN=0 F S IEN=$O(^XTV(8992,XQAUSER,"XQA",IEN)) Q:'IEN D
. . ; for each deferred alert by recipient, forward to surrogate
. . N BEGDATE,DEFDATE,ENDDATE,FWD,XQA,XQAID,XQALERT,XQACMNT,XQALTID,XQALTYPE
. . S BEGDATE=$$ETFM($P(SURFOR(I),U,3)),ENDDATE=$$ETFM($P(SURFOR(I),U,4))
. . S XQALERT=$G(^XTV(8992,XQAUSER,"XQA",IEN,0)),DEFDATE=$P(XQALERT,U,6),XQAID=$P(XQALERT,U,2)
. . Q:(DEFDATE="")!(XQAID="") ; p772 only deferred, no bad data in XQAID or XQALTID
. . S XQALTID=$O(^XTV(8992.1,"B",XQAID,0)),FWD="" S:XQALTID'="" FWD=$D(^XTV(8992.1,XQALTID,20,"B",SURR)) ; been fwd to surr?
. . I ENDDATE<0 S ENDDATE=DEFDATE ; surrogacy has no end date
. . I (DEFDATE>=BEGDATE),(DEFDATE<=ENDDATE),'FWD D
. . . S $P(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)="" ; clear deferred date before forwarding
. . . S XQA(SURR)="",XQACMNT="DEFERRED BY INITIAL RECIPIENT",XQALTYPE="FWD TO SURROGATE"
. . . D FORWARD^XQALFWD($P(XQALERT,U,2),SURR,"A",XQACMNT)
. . . S $P(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)=DEFDATE ; restore after forwarding
. . . ;N XQAID S XQAID=$P(XQALERT,U,2) D DELETE^XQALERT
Q
;
RETURN(XQAUSER) ; p734 - return surrogate-deferred alerts to the user
Q:'$G(XQAUSER)
N IEN,IEN2,END,RCPNT,SURR,SURR0
; for each surrogate that had XQAUSER as original recipient in the past
S SURR=0,IEN=0 F S IEN=$O(^XTV(8992,XQAUSER,2,IEN)) Q:'IEN D
. S SURR0=$G(^XTV(8992,XQAUSER,2,IEN,0)),SURR=$P(SURR0,U,2),END=$P(SURR0,U,3) D:SURR
. . S RCPNT="",IEN2=0 F S IEN2=$O(^XTV(8992,SURR,"XQA",IEN2)) Q:IEN2="" D
. . . S RCPNT=$G(^XTV(8992,SURR,"XQA",IEN2,2)) I $P(RCPNT,U)=XQAUSER,END'="",END<$$NOW^XLFDT D
. . . . ; for each alert still in surrogate, return to original recipient
. . . . N XQA,XQAID,XQALERT,XQACMNT,XQALTYPE
. . . . S XQALERT=$G(^XTV(8992,SURR,"XQA",IEN2,0)),XQAID=$P(XQALERT,U,2) Q:XQAID=""
. . . . S XQA(1)=XQAUSER,XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
. . . . N XQAUSER S XQAUSER=SURR D FORWARD^XQALFWD(XQAID,.XQA,"A",XQACMNT)
. . . . D DELETE^XQALERT
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALDATA 13367 printed Apr 09, 2024@21:06:43 Page 2
XQALDATA ;ISC/JLI ISD/HGW - PROVIDE DATA ON ALERTS ; Mar 23, 2023@8:00
+1 ;;8.0;KERNEL;**207,285,443,513,602,653,734,662,772,784**;Jul 10, 1995;Build 6
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; SR. ICR #4834 (private OE/RR)
+1 ; P443
NEW XREF,XVAL,X,X2,X3,I,NCNT
+2 if $GET(XQAUSER)'>0
SET XQAUSER=DUZ
+3 if $GET(FRSTDATE)'>0
SET FRSTDATE=0
+4 if $GET(LASTDATE)'>0
SET LASTDATE=0
+5 SET NCNT=0
KILL @ROOT
+6 IF FRSTDATE=0
Begin DoDot:1
+7 FOR I=0:0
SET I=$ORDER(^XTV(8992,XQAUSER,"XQA",I))
if I'>0
QUIT
SET X=^(I,0)
SET X3=$GET(^(3))
SET X2=$GET(^(2))
Begin DoDot:2
+8 SET NCNT=NCNT+1
+9 ; P443
SET @ROOT@(NCNT)=$SELECT($PIECE(X3,U)'="":"G ",$PIECE(X,U,7,8)="^ ":"I ",1:" ")_$PIECE(X,U,3)_U_$PIECE(X,U,2)_$SELECT($PIECE(X2,U,3)'="":U_$PIECE(X2,U,3),1:"")
End DoDot:2
+10 SET @ROOT=NCNT
End DoDot:1
QUIT
+11 SET XREF="R"
+12 SET XVAL=XQAUSER
+13 DO CHKTRAIL
+14 QUIT
GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
+1 NEW XREF,XVAL,NCNT
+2 SET NCNT=0
KILL @ROOT
+3 IF $GET(PATIENT)'>0
SET @ROOT=0
QUIT
+4 SET XREF="C"
+5 SET XVAL=PATIENT
+6 DO CHKTRAIL
+7 QUIT
GETPAT2(ROOT,PATIENT,PAGE,LIMIT) ; P653
+1 NEW XREF,XVAL,NCNT
+2 SET NCNT=0
KILL @ROOT
+3 IF $GET(PATIENT)'>0
SET @ROOT=0
QUIT
+4 SET XREF="C"
+5 SET XVAL=PATIENT
+6 DO GETPAGE
+7 QUIT
GETPAGE ;P653
+1 NEW XQ1,XQCNT,XQSTART,XQEND,XQCNTTOT
+2 SET XQ1=""
SET XQCNT=0
SET XQCNTTOT=0
+3 SET XQSTART=(PAGE-1)*LIMIT+1
+4 SET XQEND=PAGE*LIMIT
+5 FOR
SET XQ1=$ORDER(^XTV(8992.1,XREF,XVAL,XQ1),-1)
if 'XQ1
QUIT
Begin DoDot:1
+6 SET XQCNT=XQCNT+1
+7 IF (XQCNT>=XQSTART)
IF (XQCNT<=XQEND)
Begin DoDot:2
+8 SET XQCNTTOT=XQCNTTOT+1
+9 NEW X,X1,X2,X3
+10 SET X=$GET(^XTV(8992.1,XQ1,0))
SET X1=$GET(^(1))
SET X3=$GET(^(3))
SET X2=$GET(^(2))
if X=""
QUIT
+11 SET @ROOT@(XQCNT)=$SELECT($PIECE(X3,U)'="":"G ",$PIECE(X1,U,2,3)="^":"I ",$PIECE(X1,U,2,3)="":"I ",1:" ")_$PIECE(X1,U)_U_$PIECE(X,U)_$SELECT($PIECE(X2,U,3)'="":U_$PIECE(X2,U,3),1:"")
End DoDot:2
End DoDot:1
+12 ; @ROOT@(0)=PAGE^TOTALPAGES
SET @ROOT@(0)=PAGE_U_(XQCNT\LIMIT+$SELECT(XQCNT#LIMIT:1,1:0))
+13 SET @ROOT=XQCNTTOT
+14 QUIT
CHKTRAIL ;
+1 ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER
+2 NEW XQ1,X,X1,X2,X3
+3 FOR XQ1=0:0
SET XQ1=$ORDER(^XTV(8992.1,XREF,XVAL,XQ1))
if XQ1'>0
QUIT
Begin DoDot:1
+4 SET X=$GET(^XTV(8992.1,XQ1,0))
SET X1=$GET(^(1))
SET X3=$GET(^(3))
SET X2=$GET(^(2))
if X=""
QUIT
+5 IF FRSTDATE'>0
IF '$DATA(^XTV(8992,"AXQA",$PIECE(X,U)))
QUIT
+6 IF FRSTDATE>0
IF $PIECE(X,U,2)<FRSTDATE
QUIT
+7 IF FRSTDATE>0
IF LASTDATE>0
IF $PIECE(X,U,2)>LASTDATE
QUIT
+8 SET NCNT=NCNT+1
+9 ; P443
SET @ROOT@(NCNT)=$SELECT($PIECE(X3,U)'="":"G ",$PIECE(X1,U,2,3)="^":"I ",$PIECE(X1,U,2,3)="":"I ",1:" ")_$PIECE(X1,U)_U_$PIECE(X,U)_$SELECT($PIECE(X2,U,3)'="":U_$PIECE(X2,U,3),1:"")
End DoDot:1
+10 SET @ROOT=NCNT
+11 QUIT
GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE,FLAG) ;Add FLAG to check for deferred alert. P653
+1 NEW NCNT,KEY
+2 ; p772
SET NCNT=0
KILL @ROOT
SET @ROOT=NCNT
+3 if $GET(XQAUSER)'>0
SET XQAUSER=DUZ
+4 if $GET(FRSTDATE)'>0
SET FRSTDATE=0
+5 if $GET(LASTDATE)'>0
SET LASTDATE=0
+6 ;P653
if $GET(FLAG)'>0
SET FLAG=0
+7 IF $$ACTVSURO^XQALSURO(XQAUSER)'>0
Begin DoDot:1
+8 ; P513
DO RETURN^XQALSUR1(XQAUSER)
+9 ;D RETURN(XQAUSER) ; p734
End DoDot:1
+10 ; p734
+11 NEW SURFOR
DO SUROFOR^XQALSURO(.SURFOR,XQAUSER)
IF SURFOR
DO FORWARD(.SURFOR,XQAUSER)
+12 ; p772 LOCK to prevent conflict with daily cleanup or other modifying events
+13 IF FRSTDATE=0
Begin DoDot:1
+14 ;Q:'$T p772 v4 continue if no LOCK. improvements to LOCK in future patch with CPRS
LOCK +^XTV(8992,XQAUSER):10
+15 IF '$ORDER(^XTV(8992,XQAUSER,"XQA",0))
QUIT
+16 ; P653
NEW X,X2,X3,X4,XDEF,XCKUSER,I
SET I=""
FOR
SET I=$ORDER(^XTV(8992,XQAUSER,"XQA",I),-1)
if I'>0
QUIT
SET X=^(I,0)
SET X2=$GET(^(2))
SET X3=$GET(^(3))
SET X4=$DATA(^(4))
SET XDEF=$PIECE($GET(X),"^",6)
Begin DoDot:2
+17 NEW XNOW,XQUIT
SET XQUIT=0
+18 IF $GET(FLAG)>0
Begin DoDot:3
+19 SET XNOW=$$NOW^XLFDT()
+20 IF XDEF'=""
Begin DoDot:4
+21 IF XNOW<XDEF
SET XQUIT=1
+22 QUIT
End DoDot:4
End DoDot:3
if XQUIT=1
QUIT
+23 IF $PIECE(X,U,4)'=""
Begin DoDot:3
+24 ; P513, update ALERT TRACKING FILE
NEW XQAID,XQXX,XQXY,XQADAT
+25 ; P513 - MARK SEEN
SET $PIECE(^XTV(8992,XQAUSER,"XQA",I,0),U,4)=""
+26 ; P513
SET XQAID=$PIECE(X,U,2)
+27 ;P513
SET XQXX=$ORDER(^XTV(8992.1,"B",XQAID,0))
SET XQXY=0
SET XQADAT=$$NOW^XLFDT()
+28 IF XQXX>0
SET XQXY=$ORDER(^XTV(8992.1,XQXX,20,"B",XQAUSER,0))
IF XQXY>0
Begin DoDot:4
+29 IF $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,2)=""
SET $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,2)=XQADAT
+30 IF $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,3)=""
SET $PIECE(^XTV(8992.1,XQXX,20,XQXY,0),U,3)=XQADAT
End DoDot:4
End DoDot:3
+31 SET NCNT=NCNT+1
+32 SET KEY=$SELECT($PIECE(X3,U)'="":"G ",X4>1:"L ",$PIECE(X,U,7,8)="^ ":"I ",1:"R ")
SET @ROOT@(NCNT)=KEY_$PIECE(X,U,3)_U_$PIECE(X,U,2)
+33 IF X2'=""
Begin DoDot:3
+34 SET NCNT=NCNT+1
SET @ROOT@(NCNT)=KEY_"-----Forwarded by: "_$$GET1^DIQ(200,($PIECE(X2,U)_","),.01)_" Generated: "_$$DAT8^XQALERT($PIECE(X2,U,2),1)_U_$PIECE(X,U,2)
+35 IF $PIECE(X2,U,3)'=""
SET NCNT=NCNT+1
SET @ROOT@(NCNT)=KEY_"-----"_$PIECE(X2,U,3)_U_$PIECE(X,U,2)
+36 QUIT
End DoDot:3
End DoDot:2
+37 SET @ROOT=NCNT
+38 QUIT
End DoDot:1
LOCK -^XTV(8992,XQAUSER)
QUIT
+39 QUIT
+40 ;
+41 ;
+42 ; Get XQAUSER's PROCESSED alerts where the processed date is between FRSTDATE and LASTDATE
+43 ; If MAXRET is passed, only return up to MAXRET alerts. MAXRET must be > 0 or it will default to 1 P784
+44 ; The PROONLY and FLAG parameters are not used
+45 ; Hard code the returned processed alerts to descending order P784
GETUSER2(ROOT,XQAUSER,FRSTDATE,LASTDATE,MAXRET,PROONLY,FLAG) ;Get PROCESSED alerts rather than pending alerts p662
+1 ;Quit if ROOT is undefined P784
IF '$DATA(ROOT)
QUIT
+2 KILL @ROOT
+3 SET @ROOT=0
+4 ;Quit is XQAUSER and DUZ are '> 0 P784
IF ($GET(XQAUSER)'>0)&($GET(DUZ)'>0)
QUIT
+5 if $GET(XQAUSER)'>0
SET XQAUSER=DUZ
+6 if $GET(FRSTDATE)'>0
SET FRSTDATE=0
+7 if $GET(LASTDATE)'>0
SET LASTDATE=0
+8 ;Default to 1 record returned if no parameter passed p784
if $GET(MAXRET)'>0
SET MAXRET=1
+9 NEW NCNT,RECIPDA,PDATE
+10 SET NCNT=0
+11 IF $$ACTVSURO^XQALSURO(XQAUSER)'>0
DO RETURN^XQALSUR1(XQAUSER)
+12 SET RECIPDA=XQAUSER
if '$DATA(^XTV(8992.1,"PAR",XQAUSER))
QUIT
Begin DoDot:1
+13 NEW XDA,XMDA,X,X1,X2,X3,X4,X20
+14 NEW KEY,TYPNODE,RTYP,SURRFOR,PROCBY,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE
+15 ;p784
+16 ; Add the ",-1" parameter to the $O command for descending order
+17 ; Initialize PDATE to LASTDATE and add a small offset so that LASTDATE is included
+18 SET PDATE=LASTDATE
IF PDATE'=0
SET PDATE=PDATE+.000001
+19 FOR
SET PDATE=$ORDER(^XTV(8992.1,"PAR",RECIPDA,PDATE),-1)
if PDATE<FRSTDATE!(PDATE="")
QUIT
Begin DoDot:2
+20 SET XDA=""
FOR
SET XDA=$ORDER(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA))
if XDA=""
QUIT
IF $DATA(^XTV(8992.1,XDA))
Begin DoDot:3
+21 SET XMDA=""
FOR
SET XMDA=$ORDER(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA,XMDA))
if XMDA=""
QUIT
Begin DoDot:4
+22 SET X=$GET(^XTV(8992.1,XDA,0))
SET X1=$GET(^(1))
SET X2=$GET(^(2))
SET X3=$GET(^(3))
SET X4=$GET(^(4))
+23 SET X20(0)=$GET(^XTV(8992.1,XDA,20,XMDA,0))
+24 SET (SURRFOR,PROCBY,RTYP,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE)=""
+25 SET RETURN=$PIECE($GET(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U,3)
+26 IF RETURN
QUIT
+27 SET LASTTYPE=$ORDER(^XTV(8992.1,XDA,20,XMDA,1,999999999),-1)
+28 SET TYPNODE=$GET(^XTV(8992.1,XDA,20,XMDA,1,LASTTYPE,0))
+29 IF $PIECE(TYPNODE,U)]""
SET RTYP=$GET(^XTV(8992.2,$PIECE(TYPNODE,U),0))
+30 IF RTYP="FWD BY USER"
Begin DoDot:5
+31 NEW LASTFWD,FWD0
+32 SET LASTFWD=$ORDER(^XTV(8992.1,XDA,20,XMDA,2,999999999),-1)
+33 SET FWD0=$GET(^XTV(8992.1,XDA,20,XMDA,2,LASTFWD,0))
+34 SET FWDNM=+$PIECE(FWD0,U,3)
+35 IF +FWDNM>0
Begin DoDot:6
+36 SET FWDDT=$TRANSLATE($$FMTE^XLFDT($PIECE(FWD0,U,1),2),"@"," ")
+37 SET FWDNM=$PIECE($GET(^VA(200,FWDNM,0)),U)_" "_FWDDT
End DoDot:6
End DoDot:5
+38 NEW I,BEST
SET (I,BEST)=0
FOR
SET I=$ORDER(^XTV(8992.1,XDA,20,I))
if 'I
QUIT
Begin DoDot:5
+39 NEW TMP0
SET TMP0=$GET(^XTV(8992.1,XDA,20,I,0))
+40 ; if recipient has processed, excluding returned from surrogate
IF $PIECE(TMP0,U,4)
IF '$PIECE($GET(^XTV(8992.1,XDA,20,I,3,1,0)),U,3)
Begin DoDot:6
+41 IF $PIECE(TMP0,U,4)>BEST
SET BEST=$PIECE(TMP0,U,4)
SET PROCBY=$PIECE($GET(^VA(200,$PIECE(TMP0,U),0)),U)
End DoDot:6
End DoDot:5
+42 IF PROCBY=""
SET PROCBY="UNKNOWN"
+43 SET SURRDA=$PIECE($GET(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U)
+44 IF SURRDA]""
SET SURRFOR=$PIECE($GET(^VA(200,SURRDA,0)),U)
+45 SET NCNT=NCNT+1
+46 IF MAXRET
IF NCNT>MAXRET
QUIT
+47 SET KEY=$SELECT($PIECE(X3,U)'="":"G ",X4>1:"L ",$PIECE(X1,U,3,4)="^ ":"I ",1:"R ")
+48 SET @ROOT@(NCNT)=KEY_$PIECE(X1,U)_U_$PIECE(X,U)
+49 SET @ROOT@(NCNT,"PROCESSED")=$PIECE(X20(0),U,2)_U_$PIECE(X20(0),U,3)_U_$PIECE(X20(0),U,4)_U_$PIECE(X20(0),U,5)_U_RTYP_U_PROCBY_U_SURRFOR_U_FWDNM
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+50 IF MAXRET
IF NCNT>MAXRET
SET NCNT=MAXRET
+51 SET @ROOT=NCNT
+52 QUIT
+53 ;
DEFALERT(ROOT,XQAUSER1,DEFDATE,ALERTID) ;ADD DEFERRED DATE/TIME TO ALERT; FOR CPRS USE P653
+1 ;ROOT =Global created to store the information
+2 ;XQAUSER1 =User responsible for the alert
+3 ;DEFDATE =The date/time the alert is deferred til...user
+4 ; responsible sets the date...maximum of 14 days
+5 ; from the date/time deferred.
+6 ;ALERTID =ALERT ID - the IEN of the alert in file 8992 2nd piece
+7 ; of the alert date/time multiple.
+8 ; DG,IEN of file;original recipient;date/time of alert
+9 NEW NCNT,X,X1,X2,%
+10 SET NCNT=0
KILL @ROOT
+11 if $GET(XQAUSER1)'>0
SET XQAUSER=DUZ
+12 IF $GET(DEFDATE)'>0
Begin DoDot:1
+13 SET @ROOT@(1)="-1^No Deferred Date/Time has been entered. The alert will not be deferred!"
+14 QUIT
End DoDot:1
QUIT
+15 ; Check deferred date can't be over 14 days deferred.
+16 DO NOW^%DTC
SET X1=%
SET X2=14
DO C^%DTC
+17 IF DEFDATE>X
Begin DoDot:1
+18 SET @ROOT@(1)="-1^Deferred Date/Time is greater than 14 days in the future. The alert will not be deferred!"
+19 QUIT
End DoDot:1
QUIT
+20 ; Check if surrogacy is before DEFDATE. p734
+21 NEW SURFOR
DO SUROFOR^XQALSURO(.SURFOR,XQAUSER1)
IF SURFOR
Begin DoDot:1
+22 NEW USERS
DO USERLIST^XQALBUTL($GET(ALERTID),$NAME(USERS))
IF $DATA(USERS)>9
Begin DoDot:2
+23 NEW COMUSERS
DO COMMON(.SURFOR,.USERS,.COMUSERS)
IF COMUSERS
Begin DoDot:3
+24 NEW DEFDATE1
SET DEFDATE1=$$MINEND(.COMUSERS,DEFDATE)
+25 IF DEFDATE1<DEFDATE
SET DEFDATE=DEFDATE1
SET @ROOT@(1)="1^Deferred Date set to end of surrogacy: "_DEFDATE
End DoDot:3
End DoDot:2
End DoDot:1
+26 ;
+27 ;P653
NEW XDT,XFLAG
SET XFLAG=0
SET XDT=$PIECE(ALERTID,";",3)-.00000001
+28 ;P653
FOR XDT=XDT:0
SET XDT=$ORDER(^XTV(8992,XQAUSER1,"XQA",XDT))
if XDT'>0!(XFLAG=1)
QUIT
IF $DATA(^XTV(8992,XQAUSER1,"XQA",XDT,0))
Begin DoDot:1
+29 ;P653
IF $PIECE(^XTV(8992,XQAUSER1,"XQA",XDT,0),"^",2)=ALERTID
SET XFLAG=1
QUIT
End DoDot:1
if XFLAG=1
QUIT
+30 ; p734
IF 'XFLAG
Begin DoDot:1
+31 SET @ROOT@(1)="-1^No match on alert id. The alert will not be deferred!"
+32 QUIT
End DoDot:1
QUIT
+33 SET DA(1)=XQAUSER1
+34 SET DA=XDT
+35 SET DIE="^XTV(8992,"_DA(1)_","_"""XQA"""_","
+36 SET DR=".06///^S X=DEFDATE"
+37 ;Lock Subentry
+38 LOCK +^XTV(8992,XQAUSER1,"XQA",DA):10
+39 ;Update value
+40 DO ^DIE
+41 ;Unlock subentry
+42 ; p734
LOCK -^XTV(8992,XQAUSER1,"XQA",DA)
+43 KILL DA,DIE,DR
+44 QUIT
+45 ;. . . I XCKUSER=XQAUSER&(XNOW<XDEF) S XQUIT=1
+46 QUIT
GETPAT3(ROOT,PATIENT,XFROM,XTO) ;
+1 NEW XREF,XVAL,NCNT,XQ1,XQCNT,XQSTART,XQEND,X,XDATE,X1,X2,X3
+2 SET NCNT=0
KILL @ROOT
+3 IF $GET(PATIENT)'>0
SET @ROOT=0
QUIT
+4 SET XREF="C"
+5 SET XVAL=PATIENT
+6 SET XQ1=""
SET XQCNT=0
+7 FOR
SET XQ1=$ORDER(^XTV(8992.1,XREF,XVAL,XQ1),-1)
if 'XQ1
QUIT
Begin DoDot:1
+8 SET X=$GET(^XTV(8992.1,XQ1,0))
if X=""
QUIT
+9 if '$DATA(^XTV(8992,"AXQA",$PIECE(X,U)))
QUIT
+10 SET XDATE=$PIECE(X,U,2)
+11 IF XDATE'<XFROM
IF XDATE'>XTO
Begin DoDot:2
+12 SET XQCNT=XQCNT+1
+13 SET X1=$GET(^XTV(8992.1,XQ1,1))
SET X3=$GET(^(3))
SET X2=$GET(^(2))
+14 SET @ROOT@(XQCNT)=$SELECT($PIECE(X3,U)'="":"G ",$PIECE(X1,U,2,3)="^":"I ",$PIECE(X1,U,2,3)="":"I ",1:" ")_$PIECE(X1,U)_U_$PIECE(X,U)_$SELECT($PIECE(X2,U,3)'="":U_$PIECE(X2,U,3),1:"")
End DoDot:2
End DoDot:1
+15 SET @ROOT@(0)=XQCNT
+16 QUIT
+17 ;
COMMON(SURFOR,USERS,RES) ; List of users common in SURFOR and USERS. p734
+1 NEW I,J,K
+2 KILL RES
SET RES=0
+3 if '$GET(SURFOR)
QUIT
+4 if $DATA(USERS)<10
QUIT
+5 SET K=0
+6 SET I=0
FOR
SET I=$ORDER(SURFOR(I))
if 'I
QUIT
Begin DoDot:1
+7 SET J=0
FOR
SET J=$ORDER(USERS(J))
if 'J
QUIT
Begin DoDot:2
+8 IF $PIECE(USERS(J),U)=$PIECE(SURFOR(I),U)
SET K=K+1
SET RES(K)=SURFOR(I)
End DoDot:2
End DoDot:1
+9 SET RES=K
+10 QUIT
+11 ;
MINEND(SURFOR,ENDDATE) ; Minimum of ENDDATE and end dates in surrogacy. p734
+1 NEW XQI
+2 if '$GET(SURFOR)
QUIT $GET(ENDDATE)
+3 SET ENDDATE=$GET(ENDDATE,$$FMADD^XLFDT($$NOW^XLFDT,100))
+4 FOR XQI=1:1:SURFOR
Begin DoDot:1
+5 NEW X
+6 SET X=$PIECE(SURFOR(XQI),U,4)
+7 ; surrogacy with no end date
if X=""
QUIT
+8 SET X=$$ETFM(X)
if 'X
QUIT
+9 IF X<ENDDATE
SET ENDDATE=X
End DoDot:1
+10 QUIT ENDDATE
+11 ;
ETFM(EXDATE) ; p734 external to internal FM date
+1 NEW %DT,X,Y
SET %DT="TS"
+2 SET X=$GET(EXDATE)
DO ^%DT
+3 QUIT Y
+4 ;
FORWARD(SURFOR,SURR) ; p734 Forward deferred-alerts to current surrogate
+1 if '$GET(SURFOR)
QUIT
+2 NEW I,IEN,XQAUSER
+3 ; for each original recipient
+4 SET I=0
FOR
SET I=$ORDER(SURFOR(I))
if 'I
QUIT
SET XQAUSER=$PIECE(SURFOR(I),U)
Begin DoDot:1
+5 SET IEN=0
FOR
SET IEN=$ORDER(^XTV(8992,XQAUSER,"XQA",IEN))
if 'IEN
QUIT
Begin DoDot:2
+6 ; for each deferred alert by recipient, forward to surrogate
+7 NEW BEGDATE,DEFDATE,ENDDATE,FWD,XQA,XQAID,XQALERT,XQACMNT,XQALTID,XQALTYPE
+8 SET BEGDATE=$$ETFM($PIECE(SURFOR(I),U,3))
SET ENDDATE=$$ETFM($PIECE(SURFOR(I),U,4))
+9 SET XQALERT=$GET(^XTV(8992,XQAUSER,"XQA",IEN,0))
SET DEFDATE=$PIECE(XQALERT,U,6)
SET XQAID=$PIECE(XQALERT,U,2)
+10 ; p772 only deferred, no bad data in XQAID or XQALTID
if (DEFDATE="")!(XQAID="")
QUIT
+11 ; been fwd to surr?
SET XQALTID=$ORDER(^XTV(8992.1,"B",XQAID,0))
SET FWD=""
if XQALTID'=""
SET FWD=$DATA(^XTV(8992.1,XQALTID,20,"B",SURR))
+12 ; surrogacy has no end date
IF ENDDATE<0
SET ENDDATE=DEFDATE
+13 IF (DEFDATE>=BEGDATE)
IF (DEFDATE<=ENDDATE)
IF 'FWD
Begin DoDot:3
+14 ; clear deferred date before forwarding
SET $PIECE(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)=""
+15 SET XQA(SURR)=""
SET XQACMNT="DEFERRED BY INITIAL RECIPIENT"
SET XQALTYPE="FWD TO SURROGATE"
+16 DO FORWARD^XQALFWD($PIECE(XQALERT,U,2),SURR,"A",XQACMNT)
+17 ; restore after forwarding
SET $PIECE(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)=DEFDATE
+18 ;N XQAID S XQAID=$P(XQALERT,U,2) D DELETE^XQALERT
End DoDot:3
End DoDot:2
End DoDot:1
+19 QUIT
+20 ;
RETURN(XQAUSER) ; p734 - return surrogate-deferred alerts to the user
+1 if '$GET(XQAUSER)
QUIT
+2 NEW IEN,IEN2,END,RCPNT,SURR,SURR0
+3 ; for each surrogate that had XQAUSER as original recipient in the past
+4 SET SURR=0
SET IEN=0
FOR
SET IEN=$ORDER(^XTV(8992,XQAUSER,2,IEN))
if 'IEN
QUIT
Begin DoDot:1
+5 SET SURR0=$GET(^XTV(8992,XQAUSER,2,IEN,0))
SET SURR=$PIECE(SURR0,U,2)
SET END=$PIECE(SURR0,U,3)
if SURR
Begin DoDot:2
+6 SET RCPNT=""
SET IEN2=0
FOR
SET IEN2=$ORDER(^XTV(8992,SURR,"XQA",IEN2))
if IEN2=""
QUIT
Begin DoDot:3
+7 SET RCPNT=$GET(^XTV(8992,SURR,"XQA",IEN2,2))
IF $PIECE(RCPNT,U)=XQAUSER
IF END'=""
IF END<$$NOW^XLFDT
Begin DoDot:4
+8 ; for each alert still in surrogate, return to original recipient
+9 NEW XQA,XQAID,XQALERT,XQACMNT,XQALTYPE
+10 SET XQALERT=$GET(^XTV(8992,SURR,"XQA",IEN2,0))
SET XQAID=$PIECE(XQALERT,U,2)
if XQAID=""
QUIT
+11 SET XQA(1)=XQAUSER
SET XQACMNT="RESTORED FROM SURROGATE"
SET XQALTYPE="RESTORE FROM SURROGATE"
+12 NEW XQAUSER
SET XQAUSER=SURR
DO FORWARD^XQALFWD(XQAID,.XQA,"A",XQACMNT)
+13 DO DELETE^XQALERT
End DoDot:4
End DoDot:3
End DoDot:2
End DoDot:1
+14 QUIT
+15 ;
