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