source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL01.m@ 649

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

initial load of FOIAVistA 6/30/08 version
File size: 7.3 KB
Line 
1RORUTL01 ;HCIOFO/SG - UTILITIES ; 5/12/05 3:29pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #3301 Access to the .6 field of the file #2
7 ; #3744 $$TESTPAT^VADPT
8 ; #10035 Access to the .01 and .09 fields of the file #2
9 ; #10038 Access to the HOLIDAY file (supported)
10 Q
11 ;
12 ;***** SENDS ALERT TO REGISTRY COORDINATORS
13 ;
14 ; [.]REGLST Either name of the registry or reference to a local
15 ; array containing registry names as subscripts and
16 ; optional registry IENs as values
17 ;
18 ; MSG Text of the message or negative error code. The '^'
19 ; characters are replaced with spaces in the text.
20 ;
21 ; [XQAROU] Indicates a ROUTINE or TAG^ROUTINE to run when
22 ; the alert is processed
23 ;
24 ; [XQADATA] Use this to store a package-specific data string,
25 ; in any format
26 ;
27 ; [PATIEN] Patient IEN
28 ;
29 ; [ARG2-ARG5] Optional parameters as for the $$ERROR^RORERR
30 ;
31ALERT(REGLST,MSG,XQAROU,XQADATA,PATIEN,ARG2,ARG3,ARG4,ARG5) ;
32 N IR,RC,REGIEN,REGNAME,RORBUF,RORMSG,TMP,XQA,XQAFLG,XQAMSG
33 ;--- Prepare the notification list
34 I $D(REGLST)=1 Q:REGLST="" S REGLST(REGLST)=""
35 S REGNAME="",RC=0
36 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
37 . S REGIEN=+$G(REGLST(REGNAME))
38 . I REGIEN'>0 D Q:REGIEN'>0
39 . . S REGIEN=$$REGIEN^RORUTL02(REGNAME)
40 . ;--- Load the notification list from the registry parameters
41 . K RORBUF S TMP=","_REGIEN_","
42 . D LIST^DIC(798.114,TMP,"@;.01I","U",,,,"B",,,"RORBUF","RORMSG")
43 . S RC=$$DBS^RORERR("RORMSG",-9) Q:RC<0
44 . S IR=""
45 . F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D
46 . . S TMP=+$G(RORBUF("DILIST","ID",IR,.01)) S:TMP>0 XQA(TMP)=""
47 Q:$D(XQA)<10
48 ;--- Get text of the error message (if necessary)
49 I +MSG=MSG Q:MSG'<0 D
50 . S MSG=$$MSG^RORERR20(+MSG,,.PATIEN,.ARG2,.ARG3,.ARG4,.ARG5)
51 S MSG=$TR(MSG,"^"," "),XQAMSG="ROR: ",TMP=70-$L(XQAMSG)-3
52 S XQAMSG=XQAMSG_$S($L(MSG)>TMP:$E(MSG,1,TMP)_"...",1:MSG)
53 ;--- Setup default alert processing routine
54 I $G(XQAROU)="",$G(XQADATA)="" D
55 . S XQADATA=$E(MSG,1,78)_U_$G(PATIEN)
56 . S REGNAME=""
57 . F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
58 . . S XQADATA=XQADATA_U_REGNAME
59 . S XQAROU="ALERTRTN^RORUTL01"
60 ;--- Send the alert
61 S XQAFLG="D" D SETUP^XQALERT
62 Q
63 ;
64 ;***** DEFAULT ALERT PROCESSING ROUTINE
65 ;
66 ; XQADATA Alert data
67 ; ^1: Message
68 ; ^2: Patient DFN
69 ; ^3: Registry name
70 ; ...
71 ; ^N: Registry name
72 ;
73ALERTRTN ;
74 Q:$G(XQADATA)=""
75 N I,REGNAME
76 W !!,$P(XQADATA,"^"),!
77 W:$P(XQADATA,"^",2) "Patient DFN: ",$P(XQADATA,"^",2),!
78 W "Processed Registries",!
79 F I=3:1 S REGNAME=$P(XQADATA,"^",I) Q:REGNAME="" W ?3,REGNAME,!
80 Q
81 ;
82 ;***** INITIALIZES THE VARIABLES
83 ;
84 ; NAMESP Namespace to kill in the ^TMP global
85 ; (must start with "ROR")
86 ; [XPURGE] Purge namespaced nodes in the ^XTMP global.
87 ; The ^XTMP(NAMESP_$J) node is always killed.
88 ;
89INIT(NAMESP,XPURGE) ;
90 N I,L,NOW K ^TMP($J)
91 S:$G(U)="" U="^" S:'$G(DT) DT=$$DT^XLFDT
92 Q:$E($G(NAMESP),1,3)'="ROR"
93 ;--- Kill namespaced nodes in the ^TMP global
94 S I=NAMESP,L=$L(NAMESP)
95 F K ^TMP(I,$J) S I=$O(^TMP(I)) Q:$E(I,1,L)'=NAMESP
96 ;--- Purge old namespaced nodes in the ^XTMP global
97 K ^XTMP(NAMESP_$J)
98 D:$G(XPURGE)
99 . S NOW=$$NOW^XLFDT,I=NAMESP,L=$L(NAMESP)
100 . F D S I=$O(^XTMP(I)) Q:$E(I,1,L)'=NAMESP
101 . . K:$G(^XTMP(I,0))<NOW ^XTMP(I)
102 Q
103 ;
104 ;***** INVERTS THE DATE
105 ;
106 ; DATE Date in FileMan format
107 ; [MODE] Mode of inversion
108 ; 1 Strip the time BEFORE inversion
109 ; 2 Strip the time AFTER inversion
110 ; 3 Do not invert the time
111 ;
112INVDATE(DATE,MODE) ;
113 Q:$G(MODE)=1 9999999-$P(DATE,".")
114 Q:$G(MODE)=2 $P(9999999-DATE,".")
115 I $G(MODE)=3 Q:$P(DATE,".",2) (9999999-$P(DATE,"."))_"."_+$P(DATE,".",2)
116 Q 9999999-DATE
117 ;
118 ;***** RETURNS THE PATIENT IEN (DFN) FROM THE REGISTRY RECORD
119 ;
120 ; IEN IEN of the registry record
121 ;
122PTIEN(IEN) ;
123 Q +$P($G(^RORDATA(798,+IEN,0)),U)
124 ;
125 ;***** RETURNS IEN OF THE PATIENT'S RECORD IN THE REGISTRY
126 ;
127 ; PATIEN Patient IEN
128 ; REGIEN Registry IEN
129 ;
130 ; Return Values:
131 ; "" The registry record has not been found
132 ; >0 IEN of the patient's registry record
133 ;
134PRRIEN(PATIEN,REGIEN) ;
135 Q:(PATIEN'>0)!(REGIEN'>0) 0
136 Q $O(^RORDATA(798,"KEY",+PATIEN,+REGIEN,0))
137 ;
138 ;***** RETURNS NAME AND SHORT DESCRIPTION OF THE REGISTRY
139 ;
140 ; REGIEN Registry IEN
141 ;
142 ; Return Values:
143 ;
144 ; An empty string is returned in case of an error or if there
145 ; is no registry with such IEN. Otherwise, the name and short
146 ; description of the registry separated by "^" are returned.
147 ;
148REGNAME(REGIEN) ;
149 N IENS,NAME,RORBUF,RORMSG
150 Q:'$D(^ROR(798.1,+REGIEN)) ""
151 S IENS=+REGIEN_","
152 D GETS^DIQ(798.1,IENS,".01;4",,"RORBUF","RORMSG")
153 I $G(DIERR) D Q ""
154 . D DBS^RORERR("RORMSG",-9,,,798.1,IENS)
155 Q RORBUF(798.1,IENS,.01)_U_$G(RORBUF(798.1,IENS,4))
156 ;
157 ;***** CHECKS IF THE PATIENT IS A TEST ONE
158 ;
159 ; PATIEN Patient IEN
160 ;
161 ; Return Values:
162 ; 0 The patient is NOT a test patient
163 ; 1 The patient IS a test patient
164 ;
165TESTPAT(PATIEN) ;
166 Q:$$TESTPAT^VADPT(PATIEN) 1
167 Q:$E($G(^DPT(PATIEN,0)),1,2)="ZZ" 1 ; NAME starts with "ZZ"
168 Q 0
169 ;
170 ;***** VERIFY THE ENTRY POINT
171 ;
172 ; ENTRY Entry point of the external MUMPS function
173 ; [RECERR] Record the errors (do not record by default)
174 ;
175 ; Return Values:
176 ; -18 Routine does not exist
177 ; -17 Invalid entry point
178 ; 0 Ok
179 ;
180VERIFYEP(ENTRY,RECERR) ;
181 N X
182 S X="S Y="_ENTRY D ^DIM
183 Q:'$D(X) $S($G(RECERR):$$ERROR^RORERR(-17,,,,ENTRY),1:-17)
184 S X=$P(ENTRY,U,2)
185 X ^%ZOSF("TEST") E Q $S($G(RECERR):$$ERROR^RORERR(-18,,,,X),1:-18)
186 Q 0
187 ;
188 ;***** CHECKS IF THE DATE IS A WORKING DAY
189 ;
190 ; DATE The date to be checked
191 ;
192 ; Return Values:
193 ; 0 Weekend or Holiday
194 ; 1 Working day
195 ;
196WDCHK(DATE) ;
197 N DOW,RORMSG
198 ;--- Return zero if Saturday (6) or Sunday (0)
199 S DOW=$$DOW^XLFDT(DATE,1) Q:'DOW!(DOW>5) 0
200 ;--- Return 1 if cannot be found in the HOLIDAY file
201 Q $$FIND1^DIC(40.5,,"QX",DATE\1,"B",,"RORMSG")'>0
202 ;
203 ;***** RETURNS THE NEXT WORKING DAY DATE
204 ;
205 ; DATE The source date
206 ;
207 ; The function returns a date of the next working day.
208 ;
209WDNEXT(DATE) ;
210 N DOW,RORMSG
211 F D Q:$$FIND1^DIC(40.5,,"QX",DATE,"B",,"RORMSG")'>0
212 . S DOW=$$DOW^XLFDT(DATE,1) S:'DOW DOW=7
213 . ;--- Get the next day and skip a weekend if necessary
214 . S DATE=$$FMADD^XLFDT(DATE,$S(DOW<5:1,1:8-DOW))
215 Q DATE
216 ;
217 ;***** CREATES A HEADER OF THE NODE IN THE ^XTMP GLOBAL
218 ;
219 ; SUBSCR Subscript of the node in the ^XTMP global
220 ; [DKEEP] Number of days to keep the node (1 by default)
221 ; [DESCR] Description of the node
222 ;
223XTMPHDR(SUBSCR,DKEEP,DESCR) ;
224 N DATE S DATE=$$DT^XLFDT S:$G(DKEEP)'>0 DKEEP=1
225 S ^XTMP(SUBSCR,0)=$$FMADD^XLFDT(DATE,DKEEP)_U_DATE_U_$G(DESCR)
226 Q
227 ;
228 ;***** EMULATES AND EXTENDS THE ZWRITE COMMAND :-)
229 ;
230 ; ROR8NODE Closed root of the sub-tree to display
231 ; (either local array or global variable)
232 ; [TITLE] Title of the output
233 ;
234ZW(ROR8NODE,TITLE) ;
235 Q:ROR8NODE="" Q:'$D(@ROR8NODE)
236 N FLT,L,PI W !
237 W:$G(TITLE)'="" TITLE,!!
238 W:$D(@ROR8NODE)#10 ROR8NODE_"="_@ROR8NODE,!
239 S L=$L(ROR8NODE) S:$E(ROR8NODE,L)=")" L=L-1
240 S FLT=$E(ROR8NODE,1,L),PI=ROR8NODE
241 F S PI=$Q(@PI) Q:$E(PI,1,L)'=FLT W PI_"="_@PI,!
242 Q
Note: See TracBrowser for help on using the repository browser.