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

XQALSUR1.m

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