source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORUTL05.m@ 1397

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

initial load of FOIAVistA 6/30/08 version
File size: 8.6 KB
Line 
1RORUTL05 ;HCIOFO/SG - MISCELLANEOUS UTILITIES ; 1/26/07 4:24pm
2 ;;1.5;CLINICAL CASE REGISTRIES;**1,2**;Feb 17, 2006;Build 6
3 ;
4 ; This routine uses the following IAs:
5 ;
6 ; #4493 Read the .01 field of the file #771.7 (private)
7 ; #10040 Access to the HOSPITAL LOCATION file (supported)
8 ; #10061 DEM^VADPT (supported)
9 ;
10 Q
11 ;
12 ;***** CHECKS IF THE E-MAIL NOTIFICATION IS ENABLED
13 ;
14 ; REGIEN Registry IEN
15 ;
16 ; Return Values:
17 ; 0 Do not send e-mail notifications
18 ; 1 E-mail notifications are enabled
19 ;
20CCRNTFY(REGIEN) ;
21 N DOMAIN,RC
22 ;--- Check if not a production account
23 I $T(PROD^XUPROD)'="" Q:'$$PROD^XUPROD() 0
24 ;--- Check the domain name
25 S DOMAIN=$G(^XMB("NETNAME"))
26 Q:DOMAIN'?1.E1".VA.GOV" 0
27 Q:(DOMAIN?1"TEST.".E)!(DOMAIN?1"TST.".E) 0
28 ;--- Registry-specific checks
29 I $G(REGIEN)>0 S RC=1 D Q:'RC 0
30 . N HL,HLECH,HLFS,HLQ,NAME,RORMSG
31 . ;--- Get the HL7 protocol name
32 . S NAME=$$GET1^DIQ(798.1,+REGIEN,13,,,"RORMSG") Q:NAME=""
33 . ;--- Check the HL7 processing ID
34 . D INIT^HLFNC2(NAME,.HL)
35 . I $G(HL("PID"))'="",HL("PID")'="P" S RC=0 Q
36 ;--- Notification is enabled (production account)
37 Q 1
38 ;
39 ;***** CHECK IF THE PATIENT'S RECORD IN FILE #2 IS VALID
40 ;
41 ; DFN Patient IEN (in file #2)
42 ;
43 ; Return Values:
44 ; <0 Error code
45 ; 0 Ok
46 ;
47CHKPTR(DFN,SILENT) ;
48 N RC,VA,VADM,VAERR
49 D VADEM(DFN)
50 I $G(VADM(1))="" S RC=-102 D:'$G(SILENT) Q RC
51 . D ERROR^RORERR(RC,,,,"PATIENT",DFN)
52 Q 0
53 ;
54 ;***** DELETES ALL RECORDS FROM THE (SUB)FILE
55 ;
56 ; FILE File/Subfile number
57 ; [IENS] IENS of the subfile
58 ;
59 ; Return Values:
60 ; <0 Error code
61 ; 0 Ok
62 ;
63CLEAR(FILE,IENS) ;
64 Q:'$$VFILE^DILFD(FILE) 0
65 N DA,DIK,RC,ROOT,TMP
66 S IENS=$G(IENS)
67 ;--- Lock the (sub)file
68 S RC=$$LOCK^RORLOCK(FILE,IENS)
69 I RC D Q RC
70 . S TMP=$$GET1^DID(FILE,,,"NAME",,"RORMSG")
71 . S TMP=$S(TMP'="":"file",1:"subfile")_" #"_FILE
72 . S:IENS'="" TMP=TMP_"; IENS: '"_IENS_"'"
73 . S RC=$$ERROR^RORERR(-11,,"By "_$$TEXT^RORLOCK(RC),,TMP)
74 ;
75 ;--- Delete the records
76 S DIK=$$ROOT^DILFD(FILE,IENS)
77 S ROOT=$$CREF^DILF(DIK)
78 D DA^DILF(IENS,.DA) S DA=0
79 F S DA=$O(@ROOT@(DA)) Q:DA'>0 D ^DIK
80 ;
81 ;--- Unlock the (sub)file
82 D UNLOCK^RORLOCK(FILE,IENS)
83 Q $S(RC<0:RC,1:0)
84 ;
85 ;***** CLEARS THE FIELDS OF THE RECORDS FOUND BY NAME
86 ;
87 ; FILE File number
88 ; [IENS] IENS of the subfile
89 ; NAME Name of the record (value of the .01 field)
90 ; FIELDS List of field numbers separated by semicolons
91 ;
92 ; Return Values:
93 ; <0 Error code
94 ; 0 Ok
95 ;
96CLRFLDS(FILE,IENS,NAME,FIELDS) ;
97 N FLD,I,IEN,IENS1,IS,RC,RORBUF,RORFDA,RORMSG
98 ;--- Find the record(s)
99 D FIND^DIC(FILE,$G(IENS),"@","X",NAME,,"B",,,"RORBUF","RORMSG")
100 S RC=$$DBS^RORERR("RORMSG",-9,,,FILE) Q:RC<0 RC
101 S:$G(IENS)="" IENS="," S FIELDS=$TR(FIELDS," ")
102 ;--- Update the record(s)
103 S IS="",RC=0
104 F S IS=$O(RORBUF("DILIST",2,IS)) Q:IS="" D Q:RC<0
105 . S IEN=RORBUF("DILIST",2,IS) Q:IEN'>0
106 . S IENS1=IEN_IENS
107 . F I=1:1 S FLD=$P(FIELDS,";",I) Q:FLD'>0 D
108 . . S RORFDA(FILE,IENS1,+FLD)="@"
109 . D FILE^DIE(,"RORFDA","RORMSG")
110 . S RC=$$DBS^RORERR("RORMSG",-9,,,FILE,IENS1)
111 Q $S(RC<0:RC,1:0)
112 ;
113 ;***** RETURNS THE END DATE FOR THE EVENT PURGE
114EPDATE() ;
115 N DATE,IR,RC,RORBUF,RORMSG,TMP
116 D LIST^DIC(798.1,,"@;1I;2I","U",,,,"B",,,"RORBUF","RORMSG")
117 Q:$G(DIERR) $$DBS^RORERR("RORMSG",-9,,,798.1)
118 ;--- Get the oldest date of registry updates
119 S IR="",DATE=$$DT^XLFDT
120 F S IR=$O(RORBUF("DILIST","ID",IR)) Q:IR="" D
121 . S TMP=$G(RORBUF("DILIST","ID",IR,1)) ; REGISTRY UPDATED UNTIL
122 . I TMP>0 S:TMP<DATE DATE=TMP
123 . ;S TMP=$G(RORBUF("DILIST","ID",IR,2)) ; DATA EXTRACTED UNTIL
124 . ;I TMP>0 S:TMP<DATE DATE=TMP
125 ;--- Subtract additional 14 days (just in case)
126 S DATE=$$FMADD^XLFDT(DATE\1,-14)
127 ;--- No more than 60 days in the past
128 S TMP=$$FMADD^XLFDT($$DT^XLFDT,-60)
129 Q $S(DATE>TMP:DATE,1:TMP)
130 ;
131 ;***** RETURNS NAME OF THE HOSPITAL LOCATION
132 ;
133 ; HLIEN IEN of the hospital location
134 ;
135HLNAME(HLIEN) ;
136 N NAME
137 S NAME=$$GET1^DIQ(44,(+HLIEN)_",",.01,,,"RORMSG")
138 D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,44,(+HLIEN)_",")
139 Q NAME
140 ;
141 ;***** FORMATS THE TEXT THAT DESCRIBES STATUS OF THE HL7 MESSAGE
142 ;
143 ; MSGID A valid ID of the HL7 message
144 ;
145 ; .RORDST Reference to a local array that the text
146 ; is appended to
147 ;
148 ; [TITLE] Title of the output
149 ;
150 ; [DLGNUM] Number of an entry in the DIALOG file that
151 ; contains the text template (by default,
152 ; the 7980000.004 is used)
153 ;
154 ; [.PARAMS] Reference to a local variable containing
155 ; additional parameters that substitute the
156 ; placeholders in the text template
157 ; PARAMS(
158 ; "NOR") Number of retries to resend the message
159 ; "REGISTRY") Name of the registry
160 ;
161 ; [MSGSTAT] Status of the message (result value of the
162 ; $$MSGSTAT^HLUTIL function). If this parameter
163 ; is undefined or equal to an empty string, the
164 ; current status of the message is retrieved.
165 ;
166MSG7STS(MSGID,RORDST,TITLE,DLGNUM,PARAMS,MSGSTAT) ;
167 N RORMSG,TMP
168 Q:$G(MSGID)?." "
169 S:$G(MSGSTAT)="" MSGSTAT=$$MSGSTAT^HLUTIL(MSGID)
170 ;--- Prepare the parameters
171 S PARAMS("ID")=MSGID
172 S PARAMS("STATUS")=$$MSGSTXT^RORHL7A(MSGSTAT)
173 S TMP=+$P(MSGSTAT,U,2)
174 S:TMP>0 PARAMS("UPDATED")=$$FMTE^XLFDT(TMP)
175 S PARAMS("ERRMSG")=$P(MSGSTAT,U,3)
176 S TMP=+$P(MSGSTAT,U,4)
177 S:TMP>0 PARAMS("ERRTYPE")=$$GET1^DIQ(771.7,TMP_",",.01,,,"RORMSG")
178 S PARAMS($S(+MSGSTAT=1:"QPOS",1:"RETRIES"))=$P(MSGSTAT,U,5)
179 S PARAMS("OPENFAIL")=$P(MSGSTAT,U,6)
180 S PARAMS("ACK")=$P(MSGSTAT,U,7)
181 ;--- Additional parameters
182 I $G(DLGNUM)>0 D
183 . S PARAMS("STATCODE")=+MSGSTAT
184 . S TMP=+$P(MSGSTAT,U,2)
185 . S:TMP>0 PARAMS("STATUPD")=$$FMTHL7^XLFDT(TMP)
186 . S TMP=$$SITE^RORUTL03()
187 . S PARAMS("STNAME")=$P(TMP,U,2)
188 . S PARAMS("STNUM")=$P(TMP,U)
189 . S:$G(PARAMS("NOR"))'>0 PARAMS("NOR")="several"
190 . S:$G(PARAMS("REGISTRY"))="" PARAMS("REGISTRY")="<unknown>"
191 E S DLGNUM=7980000.004
192 ;--- Build the text
193 S:$G(TITLE)'="" RORDST(1)=TITLE,RORDST(2)=" "
194 D BLD^DIALOG(DLGNUM,.PARAMS,,"RORDST","S")
195 Q
196 ;
197 ;***** CHECK IF THE ARGUMENT IS A NUMBER
198 ;
199 ; Return Values:
200 ; 1 Value starts from a number
201 ; 0 Otherwise
202 ;
203NUMERIC(VAL,NUMVAL) ;
204 S NUMVAL=$$TRIM^XLFSTR(VAL)
205 I NUMVAL?.1(1"+",1"-")1(1.N.1".".N,.N.1"."1.N).1(1"E".1(1"+",1"-")1.N) S NUMVAL=+NUMVAL Q 1
206 S NUMVAL=""
207 Q 0
208 ;
209 ;***** MARKS THE REGISTRY RECORDS FOR RESENDING THE LOCAL DATA
210 ;
211 ; .REGLST Reference to a local array containing registry names
212 ; as subscripts and optional registry IENs as values
213 ;
214 ; WD Number of days to wait before marking the records
215 ; for resending the local registry data
216 ;
217 ; Return Values:
218 ; <0 Error code
219 ; 0 Ok
220 ;
221REMARK(REGLST,WD) ;
222 N DATE,IEN,IENS,REGIEN,REGNAME,ROOT,RORFDA,RORMSG,TMP
223 S ROOT=$$ROOT^DILFD(798,,1),RC=0
224 S DATE=$$FMADD^XLFDT($$DT^XLFDT,-WD)
225 ;--- Process the registries from the list
226 S REGNAME=""
227 F S REGNAME=$O(REGLST(REGNAME)) Q:REGNAME="" D
228 . S REGIEN=+REGLST(REGNAME)
229 . I REGIEN'>0 S REGIEN=$$REGIEN^RORUTL02(REGNAME) Q:REGIEN'>0
230 . S IENS=REGIEN_","
231 . ;--- Get the registry parameters
232 . D GETS^DIQ(798.1,IENS,"21.04;21.05","I","RORFDA","RORMSG")
233 . I $G(DIERR) S TMP=$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) Q
234 . ;--- Local data has been resent already
235 . Q:$G(RORFDA(798.1,IENS,21.04,"I"))
236 . ;--- The registry has not been populated yet
237 . Q:'$G(RORFDA(798.1,IENS,21.05,"I"))
238 . ;--- It is too early for resending the local data
239 . Q:RORFDA(798.1,IENS,21.05,"I")>DATE
240 . K RORFDA,RORMSG
241 . ;--- Mark registry records as modified
242 . S IEN=0
243 . F S IEN=$O(@ROOT@("AC",REGIEN,IEN)) Q:'IEN D
244 . . S IENS=IEN_","
245 . . S RORFDA(798,IENS,4)=1 ; UPDATE DEMOGRAPHICS
246 . . S RORFDA(798,IENS,5)=1 ; UPDATE LOCAL REGISTRY DATA
247 . . D FILE^DIE(,"RORFDA","RORMSG")
248 . . D:$G(DIERR) DBS^RORERR("RORMSG",-9,,,798,IENS)
249 . ;--- Update registry parameters
250 . S IENS=REGIEN_","
251 . S RORFDA(798.1,IENS,21.04)=$$NOW^XLFDT
252 . D FILE^DIE("K","RORFDA","RORMSG")
253 . I $G(DIERR) S TMP=$$DBS^RORERR("RORMSG",-9,,,798.1,IENS) Q
254 . ;--- Record the message
255 . S TMP="Local registry and demographic data will be resent to AAC"
256 . D LOG^RORLOG(2,TMP,,"Registry Name: "_REGNAME)
257 Q 0
258 ;
259 ;***** CALLS THE DEM^VADPT
260 ;
261 ; DFN Patient IEN (in file #2)
262 ; VALIDATE Make sure that required fields are not empty
263 ; VAPTYP
264 ; VAHOW
265 ;
266VADEM(DFN,VALIDATE,VAPTYP,VAHOW) ;
267 N I,J,X,A,K,K1,NC,NF,NQ,T,VAROOT
268 D DEM^VADPT
269 S VA("BID")=$E($P($G(VADM(2)),U),6,10) ; Always 'Last4'
270 Q:'$G(VALIDATE)
271 ;--- Make sure that required fields are not empty
272 S:$G(VADM(1))="" VADM(1)="Unknown ("_DFN_")"
273 S:$G(VA("BID"))="" VA("BID")="UNKN"
274 Q
Note: See TracBrowser for help on using the repository browser.