Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: XQALDATA

XQALDATA.m

Go to the documentation of this file.
  1. 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
  1. ;Per VHA Directive 2004-038, this routine should not be modified
  1. Q
  1. GETUSER(ROOT,XQAUSER,FRSTDATE,LASTDATE) ; SR. ICR #4834 (private OE/RR)
  1. N XREF,XVAL,X,X2,X3,I,NCNT ; P443
  1. S:$G(XQAUSER)'>0 XQAUSER=DUZ
  1. S:$G(FRSTDATE)'>0 FRSTDATE=0
  1. S:$G(LASTDATE)'>0 LASTDATE=0
  1. S NCNT=0 K @ROOT
  1. I FRSTDATE=0 D Q
  1. . 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
  1. . . S NCNT=NCNT+1
  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
  1. . S @ROOT=NCNT
  1. S XREF="R"
  1. S XVAL=XQAUSER
  1. D CHKTRAIL
  1. Q
  1. GETPAT(ROOT,PATIENT,FRSTDATE,LASTDATE) ;
  1. N XREF,XVAL,NCNT
  1. S NCNT=0 K @ROOT
  1. I $G(PATIENT)'>0 S @ROOT=0 Q
  1. S XREF="C"
  1. S XVAL=PATIENT
  1. D CHKTRAIL
  1. Q
  1. GETPAT2(ROOT,PATIENT,PAGE,LIMIT) ; P653
  1. N XREF,XVAL,NCNT
  1. S NCNT=0 K @ROOT
  1. I $G(PATIENT)'>0 S @ROOT=0 Q
  1. S XREF="C"
  1. S XVAL=PATIENT
  1. D GETPAGE
  1. Q
  1. GETPAGE ;P653
  1. N XQ1,XQCNT,XQSTART,XQEND,XQCNTTOT
  1. S XQ1="",XQCNT=0,XQCNTTOT=0
  1. S XQSTART=(PAGE-1)*LIMIT+1
  1. S XQEND=PAGE*LIMIT
  1. F S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1),-1) Q:'XQ1 D
  1. . S XQCNT=XQCNT+1
  1. . I (XQCNT>=XQSTART),(XQCNT<=XQEND) D
  1. . . S XQCNTTOT=XQCNTTOT+1
  1. . . N X,X1,X2,X3
  1. . . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
  1. . . 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:"")
  1. S @ROOT@(0)=PAGE_U_(XQCNT\LIMIT+$S(XQCNT#LIMIT:1,1:0)) ; @ROOT@(0)=PAGE^TOTALPAGES
  1. S @ROOT=XQCNTTOT
  1. Q
  1. CHKTRAIL ;
  1. ; ZEXCEPT: FRSTDATE,LASTDATE,NCNT,ROOT,XREF,XVAL -- from GETPAT or GETUSER
  1. N XQ1,X,X1,X2,X3
  1. F XQ1=0:0 S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1)) Q:XQ1'>0 D
  1. . S X=$G(^XTV(8992.1,XQ1,0)),X1=$G(^(1)),X3=$G(^(3)),X2=$G(^(2)) Q:X=""
  1. . I FRSTDATE'>0,'$D(^XTV(8992,"AXQA",$P(X,U))) Q
  1. . I FRSTDATE>0,$P(X,U,2)<FRSTDATE Q
  1. . I FRSTDATE>0,LASTDATE>0,$P(X,U,2)>LASTDATE Q
  1. . S NCNT=NCNT+1
  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
  1. S @ROOT=NCNT
  1. Q
  1. GETUSER1(ROOT,XQAUSER,FRSTDATE,LASTDATE,FLAG) ;Add FLAG to check for deferred alert. P653
  1. N NCNT,KEY
  1. S NCNT=0 K @ROOT S @ROOT=NCNT ; p772
  1. S:$G(XQAUSER)'>0 XQAUSER=DUZ
  1. S:$G(FRSTDATE)'>0 FRSTDATE=0
  1. S:$G(LASTDATE)'>0 LASTDATE=0
  1. S:$G(FLAG)'>0 FLAG=0 ;P653
  1. I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D
  1. . D RETURN^XQALSUR1(XQAUSER) ; P513
  1. . ;D RETURN(XQAUSER) ; p734
  1. ; p734
  1. N SURFOR D SUROFOR^XQALSURO(.SURFOR,XQAUSER) I SURFOR D FORWARD(.SURFOR,XQAUSER)
  1. ; p772 LOCK to prevent conflict with daily cleanup or other modifying events
  1. I FRSTDATE=0 D L -^XTV(8992,XQAUSER) Q
  1. . L +^XTV(8992,XQAUSER):10 ;Q:'$T p772 v4 continue if no LOCK. improvements to LOCK in future patch with CPRS
  1. . I '$O(^XTV(8992,XQAUSER,"XQA",0)) Q
  1. . 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
  1. . . N XNOW,XQUIT S XQUIT=0
  1. . . I $G(FLAG)>0 D Q:XQUIT=1
  1. . . . S XNOW=$$NOW^XLFDT()
  1. . . . I XDEF'="" D
  1. . . . . I XNOW<XDEF S XQUIT=1
  1. . . . . Q
  1. . . I $P(X,U,4)'="" D
  1. . . . N XQAID,XQXX,XQXY,XQADAT ; P513, update ALERT TRACKING FILE
  1. . . . S $P(^XTV(8992,XQAUSER,"XQA",I,0),U,4)="" ; P513 - MARK SEEN
  1. . . . S XQAID=$P(X,U,2) ; P513
  1. . . . S XQXX=$O(^XTV(8992.1,"B",XQAID,0)),XQXY=0,XQADAT=$$NOW^XLFDT() ;P513
  1. . . . I XQXX>0 S XQXY=$O(^XTV(8992.1,XQXX,20,"B",XQAUSER,0)) I XQXY>0 D
  1. . . . . I $P(^XTV(8992.1,XQXX,20,XQXY,0),U,2)="" S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,2)=XQADAT
  1. . . . . I $P(^XTV(8992.1,XQXX,20,XQXY,0),U,3)="" S $P(^XTV(8992.1,XQXX,20,XQXY,0),U,3)=XQADAT
  1. . . S NCNT=NCNT+1
  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)
  1. . . I X2'="" D
  1. . . . 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)
  1. . . . I $P(X2,U,3)'="" S NCNT=NCNT+1,@ROOT@(NCNT)=KEY_"-----"_$P(X2,U,3)_U_$P(X,U,2)
  1. . . . Q
  1. . S @ROOT=NCNT
  1. . Q
  1. Q
  1. ;
  1. ;
  1. ; Get XQAUSER's PROCESSED alerts where the processed date is between FRSTDATE and LASTDATE
  1. ; If MAXRET is passed, only return up to MAXRET alerts. MAXRET must be > 0 or it will default to 1 P784
  1. ; The PROONLY and FLAG parameters are not used
  1. ; Hard code the returned processed alerts to descending order P784
  1. GETUSER2(ROOT,XQAUSER,FRSTDATE,LASTDATE,MAXRET,PROONLY,FLAG) ;Get PROCESSED alerts rather than pending alerts p662
  1. I '$D(ROOT) Q ;Quit if ROOT is undefined P784
  1. K @ROOT
  1. S @ROOT=0
  1. I ($G(XQAUSER)'>0)&($G(DUZ)'>0) Q ;Quit is XQAUSER and DUZ are '> 0 P784
  1. S:$G(XQAUSER)'>0 XQAUSER=DUZ
  1. S:$G(FRSTDATE)'>0 FRSTDATE=0
  1. S:$G(LASTDATE)'>0 LASTDATE=0
  1. S:$G(MAXRET)'>0 MAXRET=1 ;Default to 1 record returned if no parameter passed p784
  1. N NCNT,RECIPDA,PDATE
  1. S NCNT=0
  1. I $$ACTVSURO^XQALSURO(XQAUSER)'>0 D RETURN^XQALSUR1(XQAUSER)
  1. S RECIPDA=XQAUSER Q:'$D(^XTV(8992.1,"PAR",XQAUSER)) D
  1. . N XDA,XMDA,X,X1,X2,X3,X4,X20
  1. . N KEY,TYPNODE,RTYP,SURRFOR,PROCBY,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE
  1. . ;p784
  1. . ; Add the ",-1" parameter to the $O command for descending order
  1. . ; Initialize PDATE to LASTDATE and add a small offset so that LASTDATE is included
  1. . S PDATE=LASTDATE I PDATE'=0 S PDATE=PDATE+.000001
  1. . F S PDATE=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE),-1) Q:PDATE<FRSTDATE!(PDATE="") D
  1. . . S XDA="" F S XDA=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA)) Q:XDA="" I $D(^XTV(8992.1,XDA)) D
  1. . . . S XMDA="" F S XMDA=$O(^XTV(8992.1,"PAR",RECIPDA,PDATE,XDA,XMDA)) Q:XMDA="" D
  1. . . . . S X=$G(^XTV(8992.1,XDA,0)),X1=$G(^(1)),X2=$G(^(2)),X3=$G(^(3)),X4=$G(^(4))
  1. . . . . S X20(0)=$G(^XTV(8992.1,XDA,20,XMDA,0))
  1. . . . . S (SURRFOR,PROCBY,RTYP,SURRDA,RETURN,FWDNM,FWDDT,LASTTYPE)=""
  1. . . . . S RETURN=$P($G(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U,3)
  1. . . . . I RETURN Q
  1. . . . . S LASTTYPE=$O(^XTV(8992.1,XDA,20,XMDA,1,999999999),-1)
  1. . . . . S TYPNODE=$G(^XTV(8992.1,XDA,20,XMDA,1,LASTTYPE,0))
  1. . . . . I $P(TYPNODE,U)]"" S RTYP=$G(^XTV(8992.2,$P(TYPNODE,U),0))
  1. . . . . I RTYP="FWD BY USER" D
  1. . . . . . N LASTFWD,FWD0
  1. . . . . . S LASTFWD=$O(^XTV(8992.1,XDA,20,XMDA,2,999999999),-1)
  1. . . . . . S FWD0=$G(^XTV(8992.1,XDA,20,XMDA,2,LASTFWD,0))
  1. . . . . . S FWDNM=+$P(FWD0,U,3)
  1. . . . . . I +FWDNM>0 D
  1. . . . . . . S FWDDT=$TR($$FMTE^XLFDT($P(FWD0,U,1),2),"@"," ")
  1. . . . . . . S FWDNM=$P($G(^VA(200,FWDNM,0)),U)_" "_FWDDT
  1. . . . . N I,BEST S (I,BEST)=0 F S I=$O(^XTV(8992.1,XDA,20,I)) Q:'I D
  1. . . . . . N TMP0 S TMP0=$G(^XTV(8992.1,XDA,20,I,0))
  1. . . . . . 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
  1. . . . . . . I $P(TMP0,U,4)>BEST S BEST=$P(TMP0,U,4),PROCBY=$P($G(^VA(200,$P(TMP0,U),0)),U)
  1. . . . . I PROCBY="" S PROCBY="UNKNOWN"
  1. . . . . S SURRDA=$P($G(^XTV(8992.1,XDA,20,XMDA,3,1,0)),U)
  1. . . . . I SURRDA]"" S SURRFOR=$P($G(^VA(200,SURRDA,0)),U)
  1. . . . . S NCNT=NCNT+1
  1. . . . . I MAXRET,NCNT>MAXRET Q
  1. . . . . S KEY=$S($P(X3,U)'="":"G ",X4>1:"L ",$P(X1,U,3,4)="^ ":"I ",1:"R ")
  1. . . . . S @ROOT@(NCNT)=KEY_$P(X1,U)_U_$P(X,U)
  1. . . . . 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
  1. I MAXRET,NCNT>MAXRET S NCNT=MAXRET
  1. S @ROOT=NCNT
  1. Q
  1. ;
  1. DEFALERT(ROOT,XQAUSER1,DEFDATE,ALERTID) ;ADD DEFERRED DATE/TIME TO ALERT; FOR CPRS USE P653
  1. ;ROOT =Global created to store the information
  1. ;XQAUSER1 =User responsible for the alert
  1. ;DEFDATE =The date/time the alert is deferred til...user
  1. ; responsible sets the date...maximum of 14 days
  1. ; from the date/time deferred.
  1. ;ALERTID =ALERT ID - the IEN of the alert in file 8992 2nd piece
  1. ; of the alert date/time multiple.
  1. ; DG,IEN of file;original recipient;date/time of alert
  1. N NCNT,X,X1,X2,%
  1. S NCNT=0 K @ROOT
  1. S:$G(XQAUSER1)'>0 XQAUSER=DUZ
  1. I $G(DEFDATE)'>0 D Q
  1. . S @ROOT@(1)="-1^No Deferred Date/Time has been entered. The alert will not be deferred!"
  1. . Q
  1. ; Check deferred date can't be over 14 days deferred.
  1. D NOW^%DTC S X1=%,X2=14 D C^%DTC
  1. I DEFDATE>X D Q
  1. . S @ROOT@(1)="-1^Deferred Date/Time is greater than 14 days in the future. The alert will not be deferred!"
  1. . Q
  1. ; Check if surrogacy is before DEFDATE. p734
  1. N SURFOR D SUROFOR^XQALSURO(.SURFOR,XQAUSER1) I SURFOR D
  1. . N USERS D USERLIST^XQALBUTL($G(ALERTID),$NAME(USERS)) I $D(USERS)>9 D
  1. . . N COMUSERS D COMMON(.SURFOR,.USERS,.COMUSERS) I COMUSERS D
  1. . . . N DEFDATE1 S DEFDATE1=$$MINEND(.COMUSERS,DEFDATE)
  1. . . . I DEFDATE1<DEFDATE S DEFDATE=DEFDATE1,@ROOT@(1)="1^Deferred Date set to end of surrogacy: "_DEFDATE
  1. ;
  1. N XDT,XFLAG S XFLAG=0,XDT=$P(ALERTID,";",3)-.00000001 ;P653
  1. 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
  1. .I $P(^XTV(8992,XQAUSER1,"XQA",XDT,0),"^",2)=ALERTID S XFLAG=1 Q ;P653
  1. I 'XFLAG D Q ; p734
  1. . S @ROOT@(1)="-1^No match on alert id. The alert will not be deferred!"
  1. . Q
  1. S DA(1)=XQAUSER1
  1. S DA=XDT
  1. S DIE="^XTV(8992,"_DA(1)_","_"""XQA"""_","
  1. S DR=".06///^S X=DEFDATE"
  1. ;Lock Subentry
  1. L +^XTV(8992,XQAUSER1,"XQA",DA):10
  1. ;Update value
  1. D ^DIE
  1. ;Unlock subentry
  1. L -^XTV(8992,XQAUSER1,"XQA",DA) ; p734
  1. K DA,DIE,DR
  1. Q
  1. ;. . . I XCKUSER=XQAUSER&(XNOW<XDEF) S XQUIT=1
  1. Q
  1. GETPAT3(ROOT,PATIENT,XFROM,XTO) ;
  1. N XREF,XVAL,NCNT,XQ1,XQCNT,XQSTART,XQEND,X,XDATE,X1,X2,X3
  1. S NCNT=0 K @ROOT
  1. I $G(PATIENT)'>0 S @ROOT=0 Q
  1. S XREF="C"
  1. S XVAL=PATIENT
  1. S XQ1="",XQCNT=0
  1. F S XQ1=$O(^XTV(8992.1,XREF,XVAL,XQ1),-1) Q:'XQ1 D
  1. . S X=$G(^XTV(8992.1,XQ1,0)) Q:X=""
  1. . Q:'$D(^XTV(8992,"AXQA",$P(X,U)))
  1. . S XDATE=$P(X,U,2)
  1. . I XDATE'<XFROM,XDATE'>XTO D
  1. . . S XQCNT=XQCNT+1
  1. . . S X1=$G(^XTV(8992.1,XQ1,1)),X3=$G(^(3)),X2=$G(^(2))
  1. . . 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:"")
  1. S @ROOT@(0)=XQCNT
  1. Q
  1. ;
  1. COMMON(SURFOR,USERS,RES) ; List of users common in SURFOR and USERS. p734
  1. N I,J,K
  1. K RES S RES=0
  1. Q:'$G(SURFOR)
  1. Q:$D(USERS)<10
  1. S K=0
  1. S I=0 F S I=$O(SURFOR(I)) Q:'I D
  1. . S J=0 F S J=$O(USERS(J)) Q:'J D
  1. . . I $P(USERS(J),U)=$P(SURFOR(I),U) S K=K+1,RES(K)=SURFOR(I)
  1. S RES=K
  1. Q
  1. ;
  1. MINEND(SURFOR,ENDDATE) ; Minimum of ENDDATE and end dates in surrogacy. p734
  1. N XQI
  1. Q:'$G(SURFOR) $G(ENDDATE)
  1. S ENDDATE=$G(ENDDATE,$$FMADD^XLFDT($$NOW^XLFDT,100))
  1. F XQI=1:1:SURFOR D
  1. . N X
  1. . S X=$P(SURFOR(XQI),U,4)
  1. . Q:X="" ; surrogacy with no end date
  1. . S X=$$ETFM(X) Q:'X
  1. . I X<ENDDATE S ENDDATE=X
  1. Q ENDDATE
  1. ;
  1. ETFM(EXDATE) ; p734 external to internal FM date
  1. N %DT,X,Y S %DT="TS"
  1. S X=$G(EXDATE) D ^%DT
  1. Q Y
  1. ;
  1. FORWARD(SURFOR,SURR) ; p734 Forward deferred-alerts to current surrogate
  1. Q:'$G(SURFOR)
  1. N I,IEN,XQAUSER
  1. ; for each original recipient
  1. S I=0 F S I=$O(SURFOR(I)) Q:'I S XQAUSER=$P(SURFOR(I),U) D
  1. . S IEN=0 F S IEN=$O(^XTV(8992,XQAUSER,"XQA",IEN)) Q:'IEN D
  1. . . ; for each deferred alert by recipient, forward to surrogate
  1. . . N BEGDATE,DEFDATE,ENDDATE,FWD,XQA,XQAID,XQALERT,XQACMNT,XQALTID,XQALTYPE
  1. . . S BEGDATE=$$ETFM($P(SURFOR(I),U,3)),ENDDATE=$$ETFM($P(SURFOR(I),U,4))
  1. . . S XQALERT=$G(^XTV(8992,XQAUSER,"XQA",IEN,0)),DEFDATE=$P(XQALERT,U,6),XQAID=$P(XQALERT,U,2)
  1. . . Q:(DEFDATE="")!(XQAID="") ; p772 only deferred, no bad data in XQAID or XQALTID
  1. . . 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?
  1. . . I ENDDATE<0 S ENDDATE=DEFDATE ; surrogacy has no end date
  1. . . I (DEFDATE>=BEGDATE),(DEFDATE<=ENDDATE),'FWD D
  1. . . . S $P(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)="" ; clear deferred date before forwarding
  1. . . . S XQA(SURR)="",XQACMNT="DEFERRED BY INITIAL RECIPIENT",XQALTYPE="FWD TO SURROGATE"
  1. . . . D FORWARD^XQALFWD($P(XQALERT,U,2),SURR,"A",XQACMNT)
  1. . . . S $P(^XTV(8992,XQAUSER,"XQA",IEN,0),U,6)=DEFDATE ; restore after forwarding
  1. . . . ;N XQAID S XQAID=$P(XQALERT,U,2) D DELETE^XQALERT
  1. Q
  1. ;
  1. RETURN(XQAUSER) ; p734 - return surrogate-deferred alerts to the user
  1. Q:'$G(XQAUSER)
  1. N IEN,IEN2,END,RCPNT,SURR,SURR0
  1. ; for each surrogate that had XQAUSER as original recipient in the past
  1. S SURR=0,IEN=0 F S IEN=$O(^XTV(8992,XQAUSER,2,IEN)) Q:'IEN D
  1. . S SURR0=$G(^XTV(8992,XQAUSER,2,IEN,0)),SURR=$P(SURR0,U,2),END=$P(SURR0,U,3) D:SURR
  1. . . S RCPNT="",IEN2=0 F S IEN2=$O(^XTV(8992,SURR,"XQA",IEN2)) Q:IEN2="" D
  1. . . . S RCPNT=$G(^XTV(8992,SURR,"XQA",IEN2,2)) I $P(RCPNT,U)=XQAUSER,END'="",END<$$NOW^XLFDT D
  1. . . . . ; for each alert still in surrogate, return to original recipient
  1. . . . . N XQA,XQAID,XQALERT,XQACMNT,XQALTYPE
  1. . . . . S XQALERT=$G(^XTV(8992,SURR,"XQA",IEN2,0)),XQAID=$P(XQALERT,U,2) Q:XQAID=""
  1. . . . . S XQA(1)=XQAUSER,XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
  1. . . . . N XQAUSER S XQAUSER=SURR D FORWARD^XQALFWD(XQAID,.XQA,"A",XQACMNT)
  1. . . . . D DELETE^XQALERT
  1. Q
  1. ;