Changeset 623 for WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m
- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/KERNEL-XU-A4A7-USC-XG-XLF-XNOA-XPD-XQ-XVIR-ZI-ZOSF-ZOSV-ZT-ZU-%Z-XIP--XQAB--XUC--XUR--ZIN--ZTED/XQALSUR1.m
r613 r623 1 XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;11/21/07 08:35 2 ;;8.0;KERNEL;**366,443**;Jul 10, 1995;Build 4 3 Q 4 ; 5 RETURN(XQAUSER) ; P366 - return alerts to the user 6 N XQAI,X0,XQASTRT,XQASURO,XQAEND 7 ; identify periods in the surrogate multiple that haven't been returned 8 F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D 9 . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) 10 . ; and clear the flag indicating we need to restore these alerts 11 . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") 12 . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) 13 . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) 14 . Q 15 Q 16 ; 17 PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them 18 N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP 19 S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") 20 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 21 . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 22 . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) 23 . 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 24 . . 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 25 . . Q 26 . I 'XNOSURO D 27 . . N XQA,XQACMNT,XQALTYPE 28 . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" 29 . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) 30 . . Q 31 . ; walk through each of those it was sent to as a surrogate for XQAUSER 32 . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D 33 . . ; and identify each time they were considered a recipient of the alert 34 . . 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 35 . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well 36 . . . ; walk through the SURROGATE FOR entries for this user 37 . . . 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 38 . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned 39 . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert 40 . . . . Q 41 . . . Q 42 . . I 'XNOSURO D 43 . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL 44 . . . Q 45 . . Q 46 . Q 47 Q 48 ; 49 SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST 50 ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) 51 ; 52 ; returns XQALIST=count 53 ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME 54 ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 55 ; 56 N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU 57 D CHEKSUBS^XQALSUR2(XQAUSER) 58 S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) 59 S XQANOW=$$NOW^XLFDT(),XQALCNT=0 60 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 61 . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q 62 . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND 63 . Q 64 ; now rearrange by earliest to last 65 K XQALIST S XQALIST=0 66 S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D 67 . ; if end date not specified, and start date follows, set end date to next start date 68 . 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) 69 . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) 70 . Q 71 Q 72 ; 73 DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy 74 N XQALNEXT,XQALIST,I,XQALAST 75 I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" 76 S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D 77 . 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 78 . Q 79 Q XQALSURO 80 ; 81 DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated 82 N XQALY,XQA0,XQALIEN,XQALS 83 S XQALY="" I XQALEND'>0 S XQALEND=4000101 84 F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D 85 . F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) 86 . Q 87 Q XQALY 88 ; 89 SURRO1(XQAUSER) ; 90 N XQALSURO,XQALSTRT,XQALEND 91 D CHKREMV^XQALSURO 92 SURRO11 ; 93 S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q 94 I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO11 95 S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q 96 S XQALEND=+$$ENDDLG() I XQALEND<0 Q 97 D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) 98 G SURRO11 ; 99 Q 100 ; 101 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 102 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 103 I $G(XQAUSER)'>0 Q 104 S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) 105 N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 106 D CHEKSUBS^XQALSUR2(XQAUSER) 107 S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 108 S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 109 S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) 110 S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D 111 . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) 112 . Q 113 S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. 114 Q 115 ; 116 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; 117 N XQALNOW,XQALFM 118 S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER 119 I XQALXREF>0 D 120 . S XQALNOW=$$NOW^XLFDT() 121 . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now 122 . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now 123 . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 124 . Q 125 I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D 126 . S XQALFM(8992,XQAUSER,.02)="@" 127 . S XQALFM(8992,XQAUSER,.03)="@" 128 . S XQALFM(8992,XQAUSER,.04)="@" 129 . Q 130 I $D(XQALFM) D FILE^DIE("","XQALFM") 131 ; ZEXCEPT: XTMUNIT (EXTERNAL VALUE - INDICATING UNIT TEST BEING RUN) 132 I XQALSURO>0,'$D(XTMUNIT) D 133 . N XQAMESG,XMSUB,XMTEXT 134 . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" 135 . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." 136 . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" 137 . D SENDMESG^XQALSURO 138 . Q 139 Q 140 ; 141 NEWDLG() ; new surrogate dialog 142 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" 143 S Y=$$ASKDIR(.DIR) I 'Y Q 0 144 ; 145 S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 146 I Y>0 W " ",$P(Y,U,2) 147 Q +Y 148 ; 149 STRTDLG() ; new surrogate start date/time dialog 150 N DIR 151 S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 152 S DIR("A",1)="",DIR("A",2)="" 153 S DIR("A",3)="if no date/time is entered, alerts will start going to" 154 S DIR("A",4)="the SURROGATE immediately." 155 Q +$$ASKDIR(.DIR) 156 ; 157 ENDDLG() ; new surrogate end date/time dialog 158 N DIR 159 S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 160 S DIR("A",1)="",DIR("A",2)="" 161 S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" 162 S DIR("A",4)="to terminate alerts going to the SURROGATE" 163 Q +$$ASKDIR(.DIR) 164 ; 165 ASKDIR(DIR) ; 166 N Y,DTOUT,DUOUT 167 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 168 Q Y 1 XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 14:26 2 ;;8.0;KERNEL;**366**;Jul 10, 1995 3 Q 4 ; 5 RETURN(XQAUSER) ; P366 - return alerts to the user 6 N XQAI,X0,XQASTRT,XQASURO,XQAEND 7 ; identify periods in the surrogate multiple that haven't been returned 8 F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"AC",1,XQAI)) Q:XQAI'>0 S X0=^XTV(8992,XQAUSER,2,XQAI,0) I $P(X0,U,4)=1 D 9 . S XQASTRT=$P(X0,U) S XQAEND=$P(X0,U,3) 10 . ; and clear the flag indicating we need to restore these alerts 11 . N XQAFDA S XQAFDA(8992.02,XQAI_","_XQAUSER_",",.04)="@" D FILE^DIE("","XQAFDA") 12 . ; restore alerts to intended user, remove from surrogate if completed (i.e., no other surrogates and not intended recipient) 13 . D PUSHBACK(XQAUSER,XQASTRT,XQAEND) 14 . Q 15 Q 16 ; 17 PUSHBACK(XQAUSER,XQASTRT,XQAEND) ; P366 - identify alerts in alert tracking file for return and return them 18 N XQAINIT,XQAI,X0,X30,XNOSURO,XQADT,XQAJ,XQAK,XQAL,XQAOTH,XQASUROP 19 S XQAINIT=$$FIND1^DIC(8992.2,,"X","INITIAL RECIPIENT") 20 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 21 . S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQAUSER,0)) Q:XQAJ'>0 22 . N XSURO,XNOSURO,XQAID S XNOSURO=0,XQAID=$P(^XTV(8992.1,XQAI,0),U) 23 . 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 24 . . 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 25 . . Q 26 . I 'XNOSURO D 27 . . N XQA,XQACMNT,XQALTYPE 28 . . S XQA(XQAUSER)="",XQACMNT="RESTORED FROM SURROGATE",XQALTYPE="RESTORE FROM SURROGATE" 29 . . N XQAUSER,XQAI S XQAUSER=$O(^XTV(8992,"AXQA",XQAID,0)) Q:XQAUSER'>0 D RESETUP^XQALFWD(XQAID,.XQA,XQACMNT) 30 . . Q 31 . ; walk through each of those it was sent to as a surrogate for XQAUSER 32 . F XQASUROP=0:0 S XQASUROP=$O(XSURO(XQASUROP)) Q:XQASUROP'>0 S XQAJ=$O(^XTV(8992.1,XQAI,20,"B",XQASUROP,0)) D 33 . . ; and identify each time they were considered a recipient of the alert 34 . . 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 35 . . . I $P(X0,U,3)'="Y" S XNOSURO=1 Q ; this one got it directly as a recipient as well 36 . . . ; walk through the SURROGATE FOR entries for this user 37 . . . 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 38 . . . . I +X30=XQAUSER S $P(^XTV(8992.1,XQAI,20,XQAJ,3,XQAOTH,0),U,3)=$$NOW^XLFDT() Q ; mark this user as returned 39 . . . . I $P(X30,U,3)'>0 S XNOSURO=1 Q ; another surrogate hasn't been returned yet, so leave the alert 40 . . . . Q 41 . . . Q 42 . . I 'XNOSURO D 43 . . . N XQAKILL,XQAUSER,XQAI S XQAKILL=1,XQAUSER=XQASUROP D DELETE^XQALDEL 44 . . . Q 45 . . Q 46 . Q 47 Q 48 ; 49 SUROLIST(XQAUSER,XQALIST) ; returns for XQAUSER a list of current and/or future surrogates in XQALIST 50 ; usage D SUROLIST^XQALSUR1(DUZ,.XQALIST) 51 ; 52 ; returns XQALIST=count 53 ; XQALIST(1)=IEN2^NEWPERSON,USER2^STARTDATETIME^ENDDATETIME 54 ; XQALIST(2)=3^NAME,USER3^3050407.1227^3050406 55 ; 56 N XQA0,XQADATE,XQAIEN,XQAL,XQALCNT,XQALEND,XQANOW,XQASTART,XQASURO,XQAVALU 57 D CHEKSUBS^XQALSUR2(XQAUSER) 58 S XQALCNT=$$CURRSURO^XQALSURO(XQAUSER) 59 S XQANOW=$$NOW^XLFDT(),XQALCNT=0 60 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 61 . S XQA0=^XTV(8992,XQAUSER,2,XQAIEN,0),XQASTART=$P(XQA0,U),XQASURO=$P(XQA0,U,2),XQALEND=$P(XQA0,U,3) I XQALEND>0,XQALEND'>XQANOW Q 62 . S XQALCNT=XQALCNT+1,XQAVALU=$$GET1^DIQ(200,XQASURO_",",.01),XQAL(XQALCNT)=XQASURO_U_XQAVALU_U_XQASTART_U_XQALEND 63 . Q 64 ; now rearrange by earliest to last 65 K XQALIST S XQALIST=0 66 S XQALCNT="" F S XQALCNT=$O(XQAL(XQALCNT)) Q:XQALCNT'>0 D 67 . ; if end date not specified, and start date follows, set end date to next start date 68 . 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) 69 . S XQALIST=XQALIST+1,XQALIST(XQALIST)=XQAL(XQALCNT) 70 . Q 71 Q 72 ; 73 DCYCLIC(XQALSURO,XQAUSER,XQALSTRT,XQALEND) ; code added to prevent cyclical surrogates - use dates for surrogacy 74 N XQALNEXT,XQALIST,I,XQALAST 75 I XQALSURO=XQAUSER Q "This forms a circle which leads back to this user during this period - can't do it!" 76 S XQALNEXT=$$CURRSURO^XQALSURO(XQALSURO,XQALSTRT,XQALEND) I XQALNEXT>0 D 77 . 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 78 . Q 79 Q XQALSURO 80 ; 81 DATESURO(XQAUSER,XQALSTRT,XQALEND) ; returns surrogate(s) for XQAUSER in date range XQALSTRT to XQALEND, may be multiple values ^-separated 82 N XQALY,XQA0,XQALIEN,XQALS 83 S XQALY="" I XQALEND'>0 S XQALEND=4000101 84 F XQALS=0:0 S XQALS=$O(^XTV(8992,XQAUSER,2,"B",XQALS)) Q:XQALS'>0 Q:XQALS'<XQALEND D 85 . F XQALIEN=0:0 S XQALIEN=$O(^XTV(8992,XQAUSER,2,"B",XQALS,XQALIEN)) Q:XQALIEN'>0 S XQA0=^XTV(8992,XQAUSER,2,XQALIEN,0) Q:$P(XQA0,U,3)'>XQALSTRT S XQALY=XQALY_$S(XQALY="":"",1:U)_$P(XQA0,U,2) 86 . Q 87 Q XQALY 88 ; 89 SURRO1(XQAUSER) ; 90 N XQALSURO,XQALSTRT,XQALEND 91 D CHKREMV^XQALSURO 92 SURRO11 ; 93 S XQALSURO=$$NEWDLG() I XQALSURO'>0 Q 94 I $$CYCLIC^XQALSURO(XQALSURO,XQAUSER)'>0 W $C(7),!,$$CYCLIC^XQALSURO(XQALSURO,XQAUSER),! G SURRO1 95 S XQALSTRT=+$$STRTDLG() I XQALSTRT<0 Q 96 S XQALEND=+$$ENDDLG() I XQALEND<0 Q 97 D SETSURO^XQALSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) 98 G SURRO11 ; 99 Q 100 ; 101 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date 102 REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship 103 I $G(XQAUSER)'>0 Q 104 S XQALSURO=$G(XQALSURO),XQALSTRT=$G(XQALSTRT) 105 N XQALFM,XQALXREF,XQALSTR1,XQALSUR1,XQALNOW,XQALEND,XQA0 106 ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) 107 D CHEKSUBS^XQALSUR2(XQAUSER) 108 S XQALSUR1=+$P($G(^XTV(8992,XQAUSER,0)),U,2) S:XQALSURO'>0 XQALSURO=XQALSUR1 109 S XQALSTR1=$P($G(^XTV(8992,XQAUSER,0)),U,3) S:XQALSTRT'>0 XQALSTRT=XQALSTR1 110 S XQALEND=$P($G(^XTV(8992,XQAUSER,0)),U,4) 111 S XQALXREF=0 I XQALSTRT>0 F S XQALXREF=$O(^XTV(8992,XQAUSER,2,"B",XQALSTRT,XQALXREF)) Q:XQALXREF'>0 I $P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,2)=XQALSURO D 112 . S XQALEND=$P(^XTV(8992,XQAUSER,2,XQALXREF,0),U,3) D DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) 113 . Q 114 S XQALSURO=$$CURRSURO^XQALSURO(XQAUSER) ; make sure current surrogate is updated if necessary. 115 Q 116 ; 117 DELETENT(XQAUSER,XQALXREF,XQALSURO,XQALSTRT,XQALSUR1,XQALSTR1,XQALEND) ; 118 N XQALNOW,XQALFM 119 ; ZEXCEPT: XQATEST (EXTERNAL VALUE - INDICATING TEST BEING RUN) 120 S XQAUSER=XQAUSER_",",XQALXREF=XQALXREF_","_XQAUSER 121 I XQALXREF>0 D 122 . S XQALNOW=$$NOW^XLFDT() 123 . I XQALSTRT>XQALNOW S XQALFM(8992.02,XQALXREF,.01)=XQALNOW ; if scheduled for later, mark start as now 124 . I (XQALEND>XQALNOW)!(XQALEND'>0) S XQALFM(8992.02,XQALXREF,.03)=XQALNOW ; update end time for surrogate to now 125 . I XQALSTRT'>XQALNOW S XQALFM(8992.02,XQALXREF,.04)=1 126 . Q 127 I XQALSUR1=XQALSURO,XQALSTRT=XQALSTR1 D 128 . S XQALFM(8992,XQAUSER,.02)="@" 129 . S XQALFM(8992,XQAUSER,.03)="@" 130 . S XQALFM(8992,XQAUSER,.04)="@" 131 . Q 132 I $D(XQALFM) D FILE^DIE("","XQALFM") 133 I XQALSURO>0,'$D(XQATEST) D 134 . N XQAMESG,XMSUB,XMTEXT 135 . S XQAMESG(1,0)="You have been REMOVED as a surrogate recipient for alerts for" 136 . S XQAMESG(2,0)=$$GET1^DIQ(200,XQAUSER,.01,"E")_" (IEN="_$P(XQAUSER,",")_")." 137 . S XMTEXT="XQAMESG(",XMSUB="Removal as surrogate recipient" 138 . D SENDMESG^XQALSURO 139 . Q 140 Q 141 ; 142 NEWDLG() ; new surrogate dialog 143 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" 144 S Y=$$ASKDIR(.DIR) I 'Y Q 0 145 ; 146 S DIR(0)="P^200:AEMQ",DIR("A")="Select USER to be SURROGATE" S Y=$$ASKDIR(.DIR) ; COS-0401-41366 147 I Y>0 W " ",$P(Y,U,2) 148 Q +Y 149 ; 150 STRTDLG() ; new surrogate start date/time dialog 151 N DIR 152 S DIR(0)="DO^::ATEX",DIR("A")="Specify Date/Time SURROGATE becomes active" ; BRX-1000-10427 153 S DIR("A",1)="",DIR("A",2)="" 154 S DIR("A",3)="if no date/time is entered, alerts will start going to" 155 S DIR("A",4)="the SURROGATE immediately." 156 Q +$$ASKDIR(.DIR) 157 ; 158 ENDDLG() ; new surrogate end date/time dialog 159 N DIR 160 S DIR(0)="DO^::AETX",DIR("A")="Specify Date/Time SURROGATE should be removed" ; BRX-1000-10427 161 S DIR("A",1)="",DIR("A",2)="" 162 S DIR("A",3)="if no date/time is entered, YOU must remove the SURROGATE" 163 S DIR("A",4)="to terminate alerts going to the SURROGATE" 164 Q +$$ASKDIR(.DIR) 165 ; 166 ASKDIR(DIR) ; 167 N Y,DTOUT,DUOUT 168 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1 169 Q Y
Note:
See TracChangeset
for help on using the changeset viewer.
