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