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

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

WorldVistAEHR overlayed on FOIAVistA
File size: 8.6 KB
Line 
1XQALSUR1 ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 14:26
2 ;;8.0;KERNEL;**366**;Jul 10, 1995
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 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
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 ; 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 ;
117DELETENT(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 ;
142NEWDLG() ; 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 ;
150STRTDLG() ; 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 ;
158ENDDLG() ; 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 ;
166ASKDIR(DIR) ;
167 N Y,DTOUT,DUOUT
168 D ^DIR K DIR I $D(DTOUT)!$D(DUOUT) S Y=-1
169 Q Y
Note: See TracBrowser for help on using the repository browser.