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/XQALSURO.m@ 1383

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

WorldVistAEHR overlayed on FOIAVistA
File size: 8.3 KB
Line 
1XQALSURO ;ISC-SF.SEA/JLI - SURROGATES FOR ALERTS ;9/6/05 15:13
2 ;;8.0;KERNEL;**114,125,173,285,366**;Jul 10, 1995
3 ;;
4 Q
5OTHRSURO ; OPT:- XQALERT SURROGATE SET/REMOVE -- OTHERS SPECIFY SURROGATE FOR SELECTED USER
6 N XQAUSER,DIR,Y
7 S DIR(0)="PD^200:AEMQ",DIR("A",1)="SURROGATE related to which"
8 S DIR("A")="NEW PERSON entry"
9 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
10 S XQAUSER=+Y
11 G SURROGAT
12 Q
13 ;
14SURROGAT ; USER SPECIFICATION OF SURROGATE
15 I '$D(XQAUSER) N XQAUSER S XQAUSER=DUZ
16 D SURRO1^XQALSUR1(XQAUSER)
17 Q
18 ; P366 - optional start and end dates added to permit identification of cyclical surrogates in specific times
19CYCLIC(XQALSURO,XQAUSER,XQASTRT,XQAEND) ; code added to prevent cyclical surrogates
20 I $G(XQASTRT)>0 Q $$DCYCLIC^XQALSUR1(XQALSURO,XQAUSER,XQASTRT,$G(XQAEND))
21 N XQALSTRT
22 I XQALSURO=XQAUSER Q "You cannot specify yourself as your own surrogate!"
23 S XQALSTRT=$$CURRSURO(XQALSURO) I XQALSTRT>0 D
24 . I XQALSTRT=XQAUSER S XQALSURO="YOU are designated as the surrogate for this user - can't do it!" Q
25 . F S XQALSTRT=$$CURRSURO(XQALSTRT) Q:XQALSTRT'>0 I XQALSTRT=XQAUSER S XQALSURO="This forms a circle which leads back to you - can't do it!" Q
26 . Q
27 Q XQALSURO
28 ;
29SETSURO(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR
30 N XQALFM,XQALIEN,XQAIENS
31 I $G(XQAUSER)'>0 Q
32 I $G(XQALSURO)'>0 Q
33 I '$D(^XTV(8992,XQAUSER,0)) D
34 . N XQALFM,XQALFM1
35 . S XQALFM1(1)=XQAUSER
36 . S XQALFM(8992,"+1,",.01)=XQAUSER
37 . D UPDATE^DIE("","XQALFM","XQALFM1")
38 . Q
39 S XQAIENS=XQAUSER_","
40 ; P366 - force no start date/time to NOW
41 ; P366 - change to force anything less than NOW to NOW - 8/22/05
42 I $G(XQALSTRT)<$$NOW^XLFDT() S XQALSTRT=$$NOW^XLFDT()
43 ; P366 - add values to new multiple
44 S XQALFM(8992.02,"+1,"_XQAIENS,.01)=XQALSTRT
45 S XQALFM(8992.02,"+1,"_XQAIENS,.02)=XQALSURO
46 I XQALEND>0 S XQALFM(8992.02,"+1,"_XQAIENS,.03)=XQALEND
47 K XQALIEN D UPDATE^DIE("","XQALFM","XQALIEN")
48 ; P366 - if start date time is already in effect - place in old locations to make active
49 I XQALSTRT'>$$NOW^XLFDT() D ACTIVATE(XQAUSER,XQALIEN(1))
50 N XQAMESG,XMSUB,XMTEXT
51 S XQAMESG(1,0)="You have been specified as a surrogate recipient for alerts for"
52 S XQAMESG(2,0)=$$GET1^DIQ(200,XQAIENS,.01,"E")_" (IEN="_XQAUSER_") effective "_$$FMTE^XLFDT(XQALSTRT)
53 I $G(XQALEND)'>0 S XQAMESG(2,0)=XQAMESG(2,0)_"."
54 E S XQAMESG(3,0)="until "_$$FMTE^XLFDT(XQALEND)
55 S XMSUB="Surrogate Recipient for "_$$GET1^DIQ(200,XQAIENS,.01,"E")
56 S XMTEXT="XQAMESG("
57 D:'$D(XQATEST) SENDMESG
58 Q
59 ;
60ACTIVATE(XQAUSER,XQALIEN) ; activates a surrogate
61 N X0,XQALFM,XQALSURO,XQALSTRT,XQALEND
62 S X0=$G(^XTV(8992,XQAUSER,2,XQALIEN,0)) Q:X0="" S XQALSTRT=$P(X0,U),XQALSURO=$P(X0,U,2),XQALEND=$P(X0,U,3)
63 S X0=^XTV(8992,XQAUSER,0)
64 I $P(X0,U,2)>0,$P(X0,U,3)'>$$NOW^XLFDT() D REMVSURO(XQAUSER) ; If we are activaing a new surrogate, if one exists simply remove.
65 K XQALFM S XQALFM(8992,XQAUSER_",",.03)=XQALSTRT
66 S XQALFM(8992,XQAUSER_",",.02)=XQALSURO
67 S XQALFM(8992,XQAUSER_",",.04)=$S($G(XQALEND)>0:XQALEND,1:"@")
68 D FILE^DIE("","XQALFM")
69 Q
70 ;
71 ; usage $$SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) returns 0 if invalid, otherwise > 0
72SETSURO1(XQAUSER,XQALSURO,XQALSTRT,XQALEND) ; SR. This should be used instead of SETSURO
73 I $G(XQALSTRT)'>0 S XQALSTRT=$$NOW^XLFDT()
74 N XQAVAL
75 S XQAVAL=$$CYCLIC(XQALSURO,XQAUSER,XQALSTRT,$G(XQALEND)) I XQAVAL'>0 Q XQAVAL ; Can't use as surrogate
76 D SETSURO(XQAUSER,XQALSURO,XQALSTRT,$G(XQALEND))
77 Q XQALSURO
78 ;
79CHKREMV ;
80 N DIR,XQAI,XQASLIST,XQAVAL,YVAL,Y
81 ; ZEXCEPT: XQAUSER (EXTERNAL VALUE)
82 D SUROLIST^XQALSUR1(XQAUSER,.XQASLIST)
83 W !,"Current Surrogate(s):",?35,"START DATE",?60,"END DATE"
84 F XQAI=0:0 S XQAI=$O(XQASLIST(XQAI)) Q:XQAI'>0 W !,XQAI," ",$P(XQASLIST(XQAI),U,2),?35,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,3)),?60,$$FMTE^XLFDT($P(XQASLIST(XQAI),U,4))
85 W ! I XQASLIST'>0 W !," No current surrogates",! Q
86 S DIR(0)="Y",DIR("A")="Do you want to REMOVE "_$S(XQASLIST>1:"a",1:"THIS")_" surrogate recipient",DIR("?")="A surrogate will receive your alerts until they are removed as surrogate." D ^DIR K DIR Q:Y'>0
87 S Y=1 I XQASLIST>1 S DIR(0)="L^1:"_XQASLIST,DIR("A")="Enter a list (comma separated, e.g., 1,2) of the surrogate(s) to remove" D ^DIR K DIR
88 I Y>0 S YVAL=Y F XQAI=1:1 S XQAVAL=+$P(YVAL,",",XQAI) Q:XQAVAL'>0 D REMVSURO(XQAUSER,$P(XQASLIST(XQAVAL),U),$P(XQASLIST(XQAVAL),U,3))
89 Q
90 ;
91 ; P366 - added OPTIONAL second and third arguments to permit deletion of a specific pending surrogate and start date
92REMVSURO(XQAUSER,XQALSURO,XQALSTRT) ; SR - ends the currently active surrogate relationship
93 I $G(XQAUSER)'>0 Q
94 D REMVSURO^XQALSUR1(XQAUSER,$G(XQALSURO),$G(XQALSTRT))
95 Q
96 ;
97 ; P366 - added OPTIONAL second and third arguments to determine surrogate for specified time range
98CURRSURO(XQAUSER,XQASTRT,XQAEND) ;SR. - returns current surrogate for user or -1 usage $$CURRSURO^XQALSURO(DUZ)
99 N X,ACTIVE,XQANOW,XQASTR1,XQAIVAL,XQA0,XQAI
100 D CHEKSUBS^XQALSUR2(XQAUSER)
101 I $G(XQASTRT)>0 Q $$DATESURO^XQALSUR1(XQAUSER,XQASTRT,$G(XQAEND)) ; P366 - check for current in specified date/times
102 ;
103 ; P366 - find the latest start time which is now or past or the first one in the future
104 S XQANOW=$$NOW^XLFDT()
105 ;I $P($G(^XTV(8992,XQAUSER,0)),U,2)'>0 D
106 D
107 . S XQAIVAL=0,XQASTR1=0
108 . F XQASTRT=0:0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT)) Q:XQASTRT'>0 Q:XQASTRT'<XQANOW S XQASTR1=XQASTRT F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D
109 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
110 . . Q
111 . ; to be compatible with the past, if there is not a current surrogate, show the next scheduled on the zero node if there is one
112 . I XQAIVAL=0 S XQASTRT=$O(^XTV(8992,XQAUSER,2,"B",XQASTR1)) Q:XQASTRT="" F XQAI=0:0 S XQAI=$O(^XTV(8992,XQAUSER,2,"B",XQASTRT,XQAI)) Q:XQAI'>0 D Q:XQAIVAL>0
113 . . S XQAEND=$P(^XTV(8992,XQAUSER,2,XQAI,0),U,3) I (XQAEND="")!(XQAEND>XQANOW) S XQAIVAL=XQAI
114 . . Q
115 . I XQAIVAL>0 S XQA0=^XTV(8992,XQAUSER,2,XQAIVAL,0),XQASTRT=^XTV(8992,XQAUSER,0) I ($P(XQA0,U,2)'=$P(XQASTRT,U,2))!($P(XQA0,U)'=$P(XQASTRT,U,3))!(+$P(XQA0,U,3)'=+$P(XQASTRT,U,4)) D ACTIVATE(XQAUSER,XQAIVAL)
116 . Q
117 ; P366 - end
118 S X=$G(^XTV(8992,XQAUSER,0))
119 ; now check for a CURRENT surrogate, already started and not expired or cyclic
120 I $P(X,U,2)>0,+$P(X,U,3)'>XQANOW D I $P($G(^XTV(8992,XQAUSER,0)),U,2)>0 Q +$P(^XTV(8992,XQAUSER,0),U,2)
121 . N DATE ; Get Current date/time to check date/times if present
122 . ; Current Date/time past End date for surrogate or cyclic relationship remove checks for new surrogate
123 . S DATE=$P(X,U,4) I (DATE>0&(DATE<XQANOW))!('$$CYCLIC($P(X,U,2),XQAUSER)) D REMVSURO(XQAUSER)
124 . Q
125 Q -1
126 ;
127ACTVSURO(XQAUSER) ;SR. - returns the actual surrogate at this time
128 N CURRSURO,NEXTSURO,SURODATA,NOW
129 S NOW=$$NOW^XLFDT()
130 S CURRSURO=$$CURRSURO(XQAUSER),SURODATA=$$GETSURO(XQAUSER) I (CURRSURO'>0)!(+$P(SURODATA,U,3)>NOW)!('(+$$ACTIVE^XUSER(CURRSURO))) Q -1
131 F S NEXTSURO=$$CURRSURO(CURRSURO),SURODATA=$$GETSURO(CURRSURO) Q:NEXTSURO'>0 Q:+$P(SURODATA,U,3)>NOW Q:'(+$$ACTIVE^XUSER(NEXTSURO)) S CURRSURO=NEXTSURO
132 Q CURRSURO
133 ;
134GETSURO(XQAUSER) ;SR. - returns data for surrogate for user including times
135 I $$CURRSURO(XQAUSER)'>0 Q ""
136 N GLOBREF,IENS,X
137 S IENS=XQAUSER_",",GLOBREF=$NA(^TMP($J,"XQALSURO")) K @GLOBREF
138 D GETS^DIQ(8992,IENS,".02;.03;.04","IE",GLOBREF)
139 S GLOBREF=$NA(@GLOBREF@(8992,IENS))
140 S X=$G(@GLOBREF@(.02,"I"))_U_$G(@GLOBREF@(.02,"E"))_U_$G(@GLOBREF@(.03,"I"))_U_$G(@GLOBREF@(.04,"I"))
141 K @GLOBREF
142 Q X
143 ;
144GETFOR ;OPT.
145 N XQAUSER,VALUES,XQACNT,DIR,DIRUT,I,Y
146 S DIR(0)="PD^200:AEMQ",DIR("A",1)="View Users who have selected a specified User as their Surrogate."
147 S DIR("A")="Select User (NEW PERSON entry)"
148 D ^DIR K DIR Q:Y'>0 W " ",$P(Y,U,2)
149 S XQAUSER=+Y
150 D SUROFOR(.VALUES,XQAUSER) I VALUES'>0 W !,"No entries found.",!! Q
151 S XQACNT=0 K DIRUT F I=0:0 S I=$O(VALUES(I)) Q:I'>0 D:(XQACNT>(IOSL-4)) Q:$D(DIRUT) W !,?5,$P(VALUES(I),U,2) S XQACNT=XQACNT+1
152 . S DIR(0)="E" D ^DIR K DIR
153 . Q
154 K DIRUT
155 Q
156 ;
157SUROLIST(XQAUSER,XQALIST) ; SR. returns list of current and scheduled surrogates for XQAUSER
158 D SUROLIST^XQALSUR1(XQAUSER,.XQALIST)
159 Q
160 ;
161SUROFOR(LIST,XQAUSER) ;SR. - returns list of users XQAUSER is acting as a surrogate for
162 I $G(XQAUSER)="" Q
163 N I,COUNT S I=0,COUNT=0 F S I=$O(^XTV(8992,"AC",XQAUSER,I)) Q:I'>0 I $$CURRSURO(I)>0 D
164 . S COUNT=COUNT+1,LIST(COUNT)=I_U_$$GET1^DIQ(200,(I_","),".01","E")_U_$$GET1^DIQ(8992,(I_","),".03","E")_U_$$GET1^DIQ(8992,(I_","),".04","E")
165 S LIST=COUNT
166 Q
167 ;
168SENDMESG ;
169 N XMY,XMDUZ,XMCHAN
170 ; ZEXCEPT: XQALSURO (EXTERNAL VALUE)
171 S XMY(XQALSURO)="",XMDUZ=.5
172 D ^XMD
173 Q
Note: See TracBrowser for help on using the repository browser.