XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ; Jul 13, 2021@11:01
;;8.0;KERNEL;**366,443,602,730,754**;Jul 10, 1995;Build 0
;Per VHA Directive 2004-038, this routine should not be modified
Q
RETURN(XQAUSER) ; P366 - return alerts to the user
N XQAI,X0,XQASTRT,XQASURO,XQAEND
; identify periods in the surrogate multiple that haven't been returned
F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 D
. I '$D(^XTV(8992,XQAUSER,2,XQAI,0)) K ^XTV(8992,XQAUSER,2,"AC",1,XQAI) Q ;p754 somebody removed surr by gbl kill, cleanup
. S X0=$G(^XTV(8992,XQAUSER,2,XQAI,0)) Q:$P(X0,U,4)'=1 ; P754
. S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3)
. ; and clear the flag indicating we need to restore these alerts
. N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA")
. ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient)
. D PUSHBACK(XQAUSER,XQASTRT,XQAEND)
. Q
Q
;
PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them
N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP
S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT")
F XQADT=XQASTRT-.0000001:0 S XQADT=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT)) Q:XQADT'>0 Q:XQADT>XQAEND F XQAI=0:0 S XQAI=$O(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI)) Q:XQAI'>0 D
. S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0
. N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U)
. F XQAK=0:0 S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 D
. . S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) S:$P(X0,U,2)>0 XSURO($P(X0,U,2))="" S:$P(X0,U,2)'>0 XNOSURO=1 ; sent to XSURO as surrogate
. . Q
. I 'XNOSURO D
. . N XQA,XQACMNT,XQALTYPE
. . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE"
. . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT)
. . Q
. ; walk through each of those it was sent to as a surrogate for XQAUSER
. F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D
. . ; and identify each time they were considered a recipient of the alert
. . S XNOSURO=0 F XQAK=0:0 Q:XNOSURO S XQAK=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK)) Q:XQAK'>0 F XQAL=0:0 S XQAL=$O(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL)) Q:XQAL'>0 S X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0) D Q:XNOSURO
. . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well
. . . ; walk through the SURROGATE FOR entries for this user
. . . F XQAOTH=0:0 S XQAOTH=$O(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH)) Q:XQAOTH'>0 S X30=^(XQAOTH,0) D Q:XNOSURO
. . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned
. . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert
. . . . Q
. . . Q
. . I 'XNOSURO D
. . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL
. . . Q
. . Q
. Q
Q
;
SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST
; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST)
;
; returns XQALIST=count
; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME
; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406
;
N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU
D CHEKSUBS^XQALSUR2(XQAUSER)
S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER)
S XQANOW=$$NOW^XLFDT(),XQALCNT=0
S XQADATE="" F S XQADATE=$O(^XTV(8992,XQAUSER,2,"B",XQADATE)) Q:XQADATE'>0 S XQAIEN="" F S XQAIEN=$O(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN)) Q:XQAIEN'>0 D
. S XQA0=$G(^XTV(8992,XQAUSER,2,XQAIEN,0)) Q:XQA0="" S XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q
. S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND
. Q
; now rearrange by earliest to last
K XQALIST S XQALIST=0
S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D
. ; if end date not specified, and start date follows, set end date to next start date
. I $D(XQAL(XQALCNT+1)),($P(XQAL(XQALCNT),U,4)>$P(XQAL(XQALCNT+1),U,3))!($P(XQAL(XQALCNT),U,4)'>0) S $P(XQAL(XQALCNT),U,4)=$P(XQAL(XQALCNT+1),U,3)
. S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT)
. Q
Q
;
DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy
Q $$DCYCLIC2(XQALSURO,XQAUSER,XQALSTRT,XQALEND)
; p754 replaced with DCYCLIC2
;N XQALNEXT,XQALIST,I,XQALAST
;I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
;S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D
;. F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q
;. Q
;Q XQALSURO
;
DCYCLIC2(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; p754 uses overlapped dates for surrogacy
; XQALSURO is intended surrogate for XQAUSER but cannot be the same
; returns last actual surrogate (good) or the error string (cyclic)
N I,END,GOODSURO,OVERLAP,START,SURO,SUROLIST
I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
S GOODSURO=XQALSURO
; but recursively check the same for surrogates of XQALSURO for
; SUROLIST(I)=suro^name^start^end
D SUROLIST^XQALSURO(XQALSURO,.SUROLIST) I SUROLIST>0 D
. F I=1:1:SUROLIST D Q:'GOODSURO ; quit when cyclic
. . S SURO=$P(SUROLIST(I),U),START=$P(SUROLIST(I),U,3),END=$P(SUROLIST(I),U,4)
. . S OVERLAP=$$OVERLAP(XQALSTRT,XQALEND,START,END) I OVERLAP>0 D
. . . S START=$P(OVERLAP,U),END=$P(OVERLAP,U,2)
. . . S GOODSURO=$$DCYCLIC2(SURO,XQAUSER,START,END)
. . . I 'GOODSURO D
. . . . S SURO=SUROLIST(I)
. . . . S GOODSURO="Can't do it. Cyclic with existing surrogacy: "_$C(10,13)
. . . . S GOODSURO=GOODSURO_$$GET1^DIQ(200,XQALSURO_",",.01)_" has surrogate: "_$P(SURO,U,2)_$C(10,13)
. . . . S GOODSURO=GOODSURO_"From "_$$FMTE^XLFDT($P(SURO,U,3),"2")_" To "_$$FMTE^XLFDT($P(SURO,U,4),"2")
Q GOODSURO ; int or string
;
OVERLAP(STR1,END1,STR2,END2) ; returns time intersection (overlap) p754
; STR1---------END1
; STR2----------END2
; STR END
N END,NOVERLAP,NOW,STR
S NOVERLAP="^",STR1=$G(STR1),STR2=$G(STR2),END1=$G(END1),END2=$G(END2)
S NOW=$$NOW^XLFDT
I $G(STR1)'>0 S STR1=NOW
I $G(STR2)'>0 S STR2=NOW
I $G(END1)>0,END1<=STR2 Q NOVERLAP
I $G(END2)>0,END2<=STR1 Q NOVERLAP
S STR=$S(STR1>STR2:STR1,1:STR2),END=$S(END1>0&(END1<END2):END1,1:END2)
Q STR_"^"_END
;
DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated
N XQALY,XQA0,XQALIEN,XQALS
S XQALY="" I XQALEND'>0 S XQALEND=4000101
F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D
. F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2)
. Q
Q XQALY
;
SURRO1(XQAUSER) ;
N XQALSURO,XQALSTRT,XQALEND,XQASLIST
D CHKREMV^XQALSURO
SURRO11 ;
S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q
I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11
S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q
S XQALEND=+$$ENDDLG() I XQALEND<0 Q
; p602 check again for cyclical surrogates
S:XQALSTRT'>0 XQALSTRT=$$NOW^XLFDT ; p754
I $$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND)'>0 W $C(7),!!,$$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND),! G SURRO11
D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND)
D DISPSUR^XQALSUR2(XQAUSER,.XQASLIST) ; p730
G SURRO11 ;
Q
;
; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
I $G(XQAUSER)'>0 Q
S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT)
N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
D CHEKSUBS^XQALSUR2(XQAUSER)
S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1
S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1
S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4)
S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P($G(^XTV(8992,XQAUSER,2,XQALXREF,0)),U,2)=XQALSURO D
. S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)
. Q
S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary.
D CLEANUP^XQALSUR2(XQAUSER) ;p602 clean up surrogate history (moved from SR. RETURN)
Q
;
DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
N XQALNOW,XQALFM
S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER
I XQALXREF>0 D
. S XQALNOW=$$NOW^XLFDT()
. I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now
. I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now
. I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1
. Q
I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D
. S XQALFM(8992,XQAUSER,.02)="@"
. S XQALFM(8992,XQAUSER,.03)="@"
. S XQALFM(8992,XQAUSER,.04)="@"
. Q
I $D(XQALFM) D FILE^DIE("","XQALFM")
; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN)
I XQALSURO>0,'$D(XTMUNIT) D
. N XQAMESG,XMSUB,XMTEXT
. S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"
. S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")."
. S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient"
. D SENDMESG^XQALSURO
. Q
Q
;
NEWDLG() ; new surrogate dialog
N DIR,Y S DIR(0)="Y",DIR("A")="Do you want to SET a new surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate.",DIR("B")="NO"
S Y=$$ASKDIR(.DIR) I 'Y Q 0
;
S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366
I Y>0 W " ",$P(Y,U,2)
Q +Y
;
STRTDLG() ; new surrogate start date/time dialog
N DIR ; p754 shortened prompt
S DIR(0)="DAO^NOW::AEFRX",DIR("A")="Enter Date/Time SURROGATE is to start: " ; BRX-1000-10427
S DIR("A",1)="",DIR("A",2)=""
S DIR("A",3)=" - If no date/time is entered, new alerts will start going to"
S DIR("A",4)=" the SURROGATE immediately."
S DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted."
S DIR("A",6)=" - A time is also required. Ex: T+1@1pm, 5/15@12am, 12/12/2021@12am"
S DIR("A",7)=""
Q +$$ASKDIR(.DIR)
;
ENDDLG() ; new surrogate end date/time dialog
N DIR ; p754 shortened prompt
S DIR(0)="DAO^NOW::AEFRX",DIR("A")="Enter Date/Time SURROGATE is to end: " ; BRX-1000-10427
S DIR("A",1)="",DIR("A",2)=""
S DIR("A",3)=" - If no date/time is entered, YOU must remove the SURROGATE"
S DIR("A",4)=" to terminate the surrogacy."
S DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted."
S DIR("A",6)=" - A time is also required. Ex: T+1@1pm, 5/15@12am, 12/12/2021@12am"
S DIR("A",7)=""
Q +$$ASKDIR(.DIR)
;
ASKDIR(DIR) ;
N Y,DTOUT,DUOUT
D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXQALSUR1 11725 printed Sep 23, 2025@19:41:35 Page 2
XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ; Jul 13, 2021@11:01
+1 ;;8.0;KERNEL;**366,443,602,730,754**;Jul 10, 1995;Build 0
+2 ;Per VHA Directive 2004-038, this routine should not be modified
+3 QUIT
RETURN(XQAUSER) ; P366 - return alerts to the user
+1 NEW XQAI,X0,XQASTRT,XQASURO,XQAEND
+2 ; identify periods in the surrogate multiple that haven't been returned
+3 FOR XQAI=0:0
SET XQAI=$ORDER(^XTV(8992,XQAUSER,2,"AC",1,XQAI))
if XQAI'>0
QUIT
Begin DoDot:1
+4 ;p754 somebody removed surr by gbl kill, cleanup
IF '$DATA(^XTV(8992,XQAUSER,2,XQAI,0))
KILL ^XTV(8992,XQAUSER,2,"AC",1,XQAI)
QUIT
+5 ; P754
SET X0=$GET(^XTV(8992,XQAUSER,2,XQAI,0))
if $PIECE(X0,U,4)'=1
QUIT
+6 SET XQASTRT=$PIECE(X0,U)
SET XQAEND=$PIECE(X0,U,3)
+7 ; and clear the flag indicating we need to restore these alerts
+8 NEW XQAFDA
SET XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@"
DO FILE^DIE("","XQAFDA")
+9 ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient)
+10 DO PUSHBACK(XQAUSER,XQASTRT,XQAEND)
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them
+1 NEW XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP
+2 SET XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT")
+3 FOR XQADT=XQASTRT-.0000001:0
SET XQADT=$ORDER(^XTV(8992.1,"AUD",XQAUSER,XQADT))
if XQADT'>0
QUIT
if XQADT>XQAEND
QUIT
FOR XQAI=0:0
SET XQAI=$ORDER(^XTV(8992.1,"AUD",XQAUSER,XQADT,XQAI))
if XQAI'>0
QUIT
Begin DoDot:1
+4 SET XQAJ=$ORDER(^XTV(8992.1,XQAI,20,"B",XQAUSER,0))
if XQAJ'>0
QUIT
+5 NEW XSURO,XNOSURO,XQAID
SET XNOSURO=0
SET XQAID=$PIECE(^XTV(8992.1,XQAI,0),U)
+6 FOR XQAK=0:0
SET XQAK=$ORDER(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK))
if XQAK'>0
QUIT
FOR XQAL=0:0
SET XQAL=$ORDER(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL))
if XQAL'>0
QUIT
Begin DoDot:2
+7 ; sent to XSURO as surrogate
SET X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0)
if $PIECE(X0,U,2)>0
SET XSURO($PIECE(X0,U,2))=""
if $PIECE(X0,U,2)'>0
SET XNOSURO=1
+8 QUIT
End DoDot:2
+9 IF 'XNOSURO
Begin DoDot:2
+10 NEW XQA,XQACMNT,XQALTYPE
+11 SET XQA(XQAUSER)=""
SET XQACMNT="RESTORED FROM SURROGATE"
SET XQALTYPE="RESTORE FROM SURROGATE"
+12 NEW XQAUSER,XQAI
SET XQAUSER=$ORDER(^XTV(8992,"AXQA",XQAID,0))
if XQAUSER'>0
QUIT
DO RESETUP^XQALFWD(XQAID,.XQA,XQACMNT)
+13 QUIT
End DoDot:2
+14 ; walk through each of those it was sent to as a surrogate for XQAUSER
+15 FOR XQASUROP=0:0
SET XQASUROP=$ORDER(XSURO(XQASUROP))
if XQASUROP'>0
QUIT
SET XQAJ=$ORDER(^XTV(8992.1,XQAI,20,"B",XQASUROP,0))
Begin DoDot:2
+16 ; and identify each time they were considered a recipient of the alert
+17 SET XNOSURO=0
FOR XQAK=0:0
if XNOSURO
QUIT
SET XQAK=$ORDER(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK))
if XQAK'>0
QUIT
FOR XQAL=0:0
SET XQAL=$ORDER(^XTV(8992.1,XQAI,20,XQAJ,1,"B",XQAK,XQAL))
if XQAL'>0
QUIT
SET X0=^XTV(8992.1,XQAI,20,XQAJ,1,XQAL,0)
Begin DoDot:3
+18 ; this one got it directly as a recipient as well
IF $PIECE(X0,U,3)'="Y"
SET XNOSURO=1
QUIT
+19 ; walk through the SURROGATE FOR entries for this user
+20 FOR XQAOTH=0:0
SET XQAOTH=$ORDER(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH))
if XQAOTH'>0
QUIT
SET X30=^(XQAOTH,0)
Begin DoDot:4
+21 ; mark this user as returned
IF +X30=XQAUSER
SET $PIECE(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT()
QUIT
+22 ; another surrogate hasn't been returned yet, so leave the alert
IF $PIECE(X30,U,3)'>0
SET XNOSURO=1
QUIT
+23 QUIT
End DoDot:4
if XNOSURO
QUIT
+24 QUIT
End DoDot:3
if XNOSURO
QUIT
+25 IF 'XNOSURO
Begin DoDot:3
+26 NEW XQAKILL,XQAUSER,XQAI
SET XQAKILL=1
SET XQAUSER=XQASUROP
DO DELETE^XQALDEL
+27 QUIT
End DoDot:3
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST
+1 ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST)
+2 ;
+3 ; returns XQALIST=count
+4 ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME
+5 ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406
+6 ;
+7 NEW XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU
+8 DO CHEKSUBS^XQALSUR2(XQAUSER)
+9 SET XQALCNT=$$CURRSURO^XQALSURO(XQAUSER)
+10 SET XQANOW=$$NOW^XLFDT()
SET XQALCNT=0
+11 SET XQADATE=""
FOR
SET XQADATE=$ORDER(^XTV(8992,XQAUSER,2,"B",XQADATE))
if XQADATE'>0
QUIT
SET XQAIEN=""
FOR
SET XQAIEN=$ORDER(^XTV(8992,XQAUSER,2,"B",XQADATE,XQAIEN))
if XQAIEN'>0
QUIT
Begin DoDot:1
+12 SET XQA0=$GET(^XTV(8992,XQAUSER,2,XQAIEN,0))
if XQA0=""
QUIT
SET XQASTART=$PIECE(XQA0,U)
SET XQASURO=$PIECE(XQA0,U,2)
SET XQALEND=$PIECE(XQA0,U,3)
IF XQALEND>0
IF XQALEND'>XQANOW
QUIT
+13 SET XQALCNT=XQALCNT+1
SET XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01)
SET XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND
+14 QUIT
End DoDot:1
+15 ; now rearrange by earliest to last
+16 KILL XQALIST
SET XQALIST=0
+17 SET XQALCNT=""
FOR
SET XQALCNT=$ORDER(XQAL(XQALCNT))
if XQALCNT'>0
QUIT
Begin DoDot:1
+18 ; if end date not specified, and start date follows, set end date to next start date
+19 IF $DATA(XQAL(XQALCNT+1))
IF ($PIECE(XQAL(XQALCNT),U,4)>$PIECE(XQAL(XQALCNT+1),U,3))!($PIECE(XQAL(XQALCNT),U,4)'>0)
SET $PIECE(XQAL(XQALCNT),U,4)=$PIECE(XQAL(XQALCNT+1),U,3)
+20 SET XQALIST=XQALIST+1
SET XQALIST(XQALIST)=XQAL(XQALCNT)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy
+1 QUIT $$DCYCLIC2(XQALSURO,XQAUSER,XQALSTRT,XQALEND)
+2 ; p754 replaced with DCYCLIC2
+3 ;N XQALNEXT,XQALIST,I,XQALAST
+4 ;I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!"
+5 ;S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D
+6 ;. F I=1:1 Q:$P(XQALNEXT,U,I)="" S XQALAST=$$DCYCLIC($P(XQALNEXT,U,I),XQAUSER,XQALSTRT,XQALEND) I XQALAST'>0 S XQALSURO=XQALAST Q
+7 ;. Q
+8 ;Q XQALSURO
+9 ;
DCYCLIC2(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; p754 uses overlapped dates for surrogacy
+1 ; XQALSURO is intended surrogate for XQAUSER but cannot be the same
+2 ; returns last actual surrogate (good) or the error string (cyclic)
+3 NEW I,END,GOODSURO,OVERLAP,START,SURO,SUROLIST
+4 IF XQALSURO=XQAUSER
QUIT "This forms a circle which leads back to this user during this period - can't do it!"
+5 SET GOODSURO=XQALSURO
+6 ; but recursively check the same for surrogates of XQALSURO for
+7 ; SUROLIST(I)=suro^name^start^end
+8 DO SUROLIST^XQALSURO(XQALSURO,.SUROLIST)
IF SUROLIST>0
Begin DoDot:1
+9 ; quit when cyclic
FOR I=1:1:SUROLIST
Begin DoDot:2
+10 SET SURO=$PIECE(SUROLIST(I),U)
SET START=$PIECE(SUROLIST(I),U,3)
SET END=$PIECE(SUROLIST(I),U,4)
+11 SET OVERLAP=$$OVERLAP(XQALSTRT,XQALEND,START,END)
IF OVERLAP>0
Begin DoDot:3
+12 SET START=$PIECE(OVERLAP,U)
SET END=$PIECE(OVERLAP,U,2)
+13 SET GOODSURO=$$DCYCLIC2(SURO,XQAUSER,START,END)
+14 IF 'GOODSURO
Begin DoDot:4
+15 SET SURO=SUROLIST(I)
+16 SET GOODSURO="Can't do it. Cyclic with existing surrogacy: "_$CHAR(10,13)
+17 SET GOODSURO=GOODSURO_$$GET1^DIQ(200,XQALSURO_",",.01)_" has surrogate: "_$PIECE(SURO,U,2)_$CHAR(10,13)
+18 SET GOODSURO=GOODSURO_"From "_$$FMTE^XLFDT($PIECE(SURO,U,3),"2")_" To "_$$FMTE^XLFDT($PIECE(SURO,U,4),"2")
End DoDot:4
End DoDot:3
End DoDot:2
if 'GOODSURO
QUIT
End DoDot:1
+19 ; int or string
QUIT GOODSURO
+20 ;
OVERLAP(STR1,END1,STR2,END2) ; returns time intersection (overlap) p754
+1 ; STR1---------END1
+2 ; STR2----------END2
+3 ; STR END
+4 NEW END,NOVERLAP,NOW,STR
+5 SET NOVERLAP="^"
SET STR1=$GET(STR1)
SET STR2=$GET(STR2)
SET END1=$GET(END1)
SET END2=$GET(END2)
+6 SET NOW=$$NOW^XLFDT
+7 IF $GET(STR1)'>0
SET STR1=NOW
+8 IF $GET(STR2)'>0
SET STR2=NOW
+9 IF $GET(END1)>0
IF END1<=STR2
QUIT NOVERLAP
+10 IF $GET(END2)>0
IF END2<=STR1
QUIT NOVERLAP
+11 SET STR=$SELECT(STR1>STR2:STR1,1:STR2)
SET END=$SELECT(END1>0&(END1<END2):END1,1:END2)
+12 QUIT STR_"^"_END
+13 ;
DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated
+1 NEW XQALY,XQA0,XQALIEN,XQALS
+2 SET XQALY=""
IF XQALEND'>0
SET XQALEND=4000101
+3 FOR XQALS=0:0
SET XQALS=$ORDER(^XTV(8992,XQAUSER,2,"B",XQALS))
if XQALS'>0
QUIT
if XQALS'<XQALEND
QUIT
Begin DoDot:1
+4 FOR XQALIEN=0:0
SET XQALIEN=$ORDER(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN))
if XQALIEN'>0
QUIT
SET XQA0=$GET(^XTV(8992,XQAUSER,2,XQALIEN,0))
if $PIECE(XQA0,U,3)'>XQALSTRT
QUIT
SET XQALY=XQALY_$SELECT(XQALY="":"",1:U)_$PIECE(XQA0,U,2)
+5 QUIT
End DoDot:1
+6 QUIT XQALY
+7 ;
SURRO1(XQAUSER) ;
+1 NEW XQALSURO,XQALSTRT,XQALEND,XQASLIST
+2 DO CHKREMV^XQALSURO
SURRO11 ;
+1 SET XQALSURO=$$NEWDLG()
IF XQALSURO'>0
QUIT
+2 IF $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0
WRITE $CHAR(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),!
GOTO SURRO11
+3 SET XQALSTRT=+$$STRTDLG()
IF XQALSTRT<0
QUIT
+4 SET XQALEND=+$$ENDDLG()
IF XQALEND<0
QUIT
+5 ; p602 check again for cyclical surrogates
+6 ; p754
if XQALSTRT'>0
SET XQALSTRT=$$NOW^XLFDT
+7 IF $$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND)'>0
WRITE $CHAR(7),!!,$$DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND),!
GOTO SURRO11
+8 DO SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND)
+9 ; p730
DO DISPSUR^XQALSUR2(XQAUSER,.XQASLIST)
+10 ;
GOTO SURRO11
+11 QUIT
+12 ;
+13 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
+1 IF $GET(XQAUSER)'>0
QUIT
+2 SET XQALSURO=$GET(XQALSURO)
SET XQALSTRT=$GET(XQALSTRT)
+3 NEW XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0
+4 DO CHEKSUBS^XQALSUR2(XQAUSER)
+5 SET XQALSUR1=+$PIECE($GET(^XTV(8992,XQAUSER,0)),U,2)
if XQALSURO'>0
SET XQALSURO=XQALSUR1
+6 SET XQALSTR1=$PIECE($GET(^XTV(8992,XQAUSER,0)),U,3)
if XQALSTRT'>0
SET XQALSTRT=XQALSTR1
+7 SET XQALEND=$PIECE($GET(^XTV(8992,XQAUSER,0)),U,4)
+8 SET XQALXREF=0
IF XQALSTRT>0
FOR
SET XQALXREF=$ORDER(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF))
if XQALXREF'>0
QUIT
IF $PIECE($GET(^XTV(8992,XQAUSER,2,XQALXREF,0)),U,2)=XQALSURO
Begin DoDot:1
+9 SET XQALEND=$PIECE(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3)
DO DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND)
+10 QUIT
End DoDot:1
+11 ; make sure current surrogate is updated if necessary.
SET XQALSURO=$$CURRSURO^XQALSURO(XQAUSER)
+12 ;p602 clean up surrogate history (moved from SR. RETURN)
DO CLEANUP^XQALSUR2(XQAUSER)
+13 QUIT
+14 ;
DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ;
+1 NEW XQALNOW,XQALFM
+2 SET XQAUSER=XQAUSER_","
SET XQALXREF=XQALXREF_","_XQAUSER
+3 IF XQALXREF>0
Begin DoDot:1
+4 SET XQALNOW=$$NOW^XLFDT()
+5 ; if scheduled for later, mark start as now
IF XQALSTRT>XQALNOW
SET XQALFM(8992.02,XQALXREF,.01)=XQALNOW
+6 ; update end time for surrogate to now
IF (XQALEND>XQALNOW)!(XQALEND'>0)
SET XQALFM(8992.02,XQALXREF,.03)=XQALNOW
+7 IF XQALSTRT'>XQALNOW
SET XQALFM(8992.02,XQALXREF,.04)=1
+8 QUIT
End DoDot:1
+9 IF XQALSUR1=XQALSURO
IF XQALSTRT=XQALSTR1
Begin DoDot:1
+10 SET XQALFM(8992,XQAUSER,.02)="@"
+11 SET XQALFM(8992,XQAUSER,.03)="@"
+12 SET XQALFM(8992,XQAUSER,.04)="@"
+13 QUIT
End DoDot:1
+14 IF $DATA(XQALFM)
DO FILE^DIE("","XQALFM")
+15 ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN)
+16 IF XQALSURO>0
IF '$DATA(XTMUNIT)
Begin DoDot:1
+17 NEW XQAMESG,XMSUB,XMTEXT
+18 SET XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for"
+19 SET XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$PIECE(XQAUSER,",")_")."
+20 SET XMTEXT="XQAMESG("
SET XMSUB="Removal as surrogate recipient"
+21 DO SENDMESG^XQALSURO
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
NEWDLG() ; new surrogate dialog
+1 NEW DIR,Y
SET DIR(0)="Y"
SET DIR("A")="Do you want to SET a new surrogate recipient"
SET DIR("?")="A surrogate will receive your alerts until they are removed as surrogate."
SET DIR("B")="NO"
+2 SET Y=$$ASKDIR(.DIR)
IF 'Y
QUIT 0
+3 ;
+4 ; COS-0401-41366
SET DIR(0)="P^200:AEMQ"
SET DIR("A")="Select USER to be SURROGATE"
SET Y=$$ASKDIR(.DIR)
+5 IF Y>0
WRITE " ",$PIECE(Y,U,2)
+6 QUIT +Y
+7 ;
STRTDLG() ; new surrogate start date/time dialog
+1 ; p754 shortened prompt
NEW DIR
+2 ; BRX-1000-10427
SET DIR(0)="DAO^NOW::AEFRX"
SET DIR("A")="Enter Date/Time SURROGATE is to start: "
+3 SET DIR("A",1)=""
SET DIR("A",2)=""
+4 SET DIR("A",3)=" - If no date/time is entered, new alerts will start going to"
+5 SET DIR("A",4)=" the SURROGATE immediately."
+6 SET DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted."
+7 SET DIR("A",6)=" - A time is also required. Ex: T+1@1pm, 5/15@12am, 12/12/2021@12am"
+8 SET DIR("A",7)=""
+9 QUIT +$$ASKDIR(.DIR)
+10 ;
ENDDLG() ; new surrogate end date/time dialog
+1 ; p754 shortened prompt
NEW DIR
+2 ; BRX-1000-10427
SET DIR(0)="DAO^NOW::AEFRX"
SET DIR("A")="Enter Date/Time SURROGATE is to end: "
+3 SET DIR("A",1)=""
SET DIR("A",2)=""
+4 SET DIR("A",3)=" - If no date/time is entered, YOU must remove the SURROGATE"
+5 SET DIR("A",4)=" to terminate the surrogacy."
+6 SET DIR("A",5)=" - A past date/time (earlier than NOW) is not permitted."
+7 SET DIR("A",6)=" - A time is also required. Ex: T+1@1pm, 5/15@12am, 12/12/2021@12am"
+8 SET DIR("A",7)=""
+9 QUIT +$$ASKDIR(.DIR)
+10 ;
ASKDIR(DIR) ;
+1 NEW Y,DTOUT,DUOUT
+2 DO ^DIR
KILL DIR
IF $DATA(DTOUT)!$DATA(DUOUT)
SET Y=-1
+3 QUIT Y
