source: FOIAVistA/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@ 1499

Last change on this file since 1499 was 628, checked in by George Lilly, 15 years ago

initial load of FOIAVistA 6/30/08 version
File size: 8.5 KB
Line 
1XQALSUR1 ;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 ;
5RETURN(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 ;
17PUSHBACK(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 ;
49SUROLIST(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 ;
73DCYCLIC(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 ;
81DATESURO(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 ;
89SURRO1(XQAUSER) ;
90 N XQALSURO,XQALSTRT,XQALEND
91 D CHKREMV^XQALSURO
92SURRO11 ;
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
102REMVSURO(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 ;
116DELETENT(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 ;
141NEWDLG() ; 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 ;
149STRTDLG() ; 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 ;
157ENDDLG() ; 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 ;
165ASKDIR(DIR) ;
166 N Y,DTOUT,DUOUT
167 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
168 Q Y
Note: See TracBrowser for help on using the repository browser.