source: FOIAVistA/trunk/r/CLINICAL_CASE_REGISTRIES-ROR/RORKIDS.m@ 702

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

initial load of FOIAVistA 6/30/08 version

File size: 8.1 KB
Line 
1RORKIDS ;HCIOFO/SG - INSTALL UTILITIES (LOW-LEVEL) ; 4/21/05 2:02pm
2 ;;1.5;CLINICAL CASE REGISTRIES;;Feb 17, 2006
3 ;
4 Q
5 ;
6 ;***** DISPLAYS THE MESSAGE IF THE INSTALLATION ABORTS
7ABTMSG() ;
8 ;;You can use the Print Log Files [RORMNT PRINT LOGS] option from
9 ;;the Clinical Case Registries Maintenance [RORMNT MAIN] menu to
10 ;;review the log file(s). The Install File Print [XPD PRINT INSTALL
11 ;;FILE] option from the Utilities [XPD UTILITY] can help also.
12 ;;Please fix the error(s) and restart the installation.
13 ;;
14 ;;NOTE: You must have the ROR VA IRM key to be able to access
15 ;; the Clinical Case Registries files and view the logs.
16 ;
17 N I,INFO,MODE,TMP
18 S MODE=+$G(RORPARM("KIDS"))
19 S MODE=$S(MODE=1:"PRE-INSTALL",MODE=2:"POST-INSTALL",1:"")
20 Q:MODE=""
21 F I=1:1 S TMP=$T(ABTMSG+I) Q:TMP'[";;" S INFO(I)=$P(TMP,";;",2,99)
22 D BMES("FATAL ERROR(S) DURING THE REGISTRY "_MODE_"!",.INFO)
23 Q
24 ;
25 ;***** SENDS AN ALERT
26 ;
27 ; DUZ DUZ of the addressee
28 ;
29 ; MSG Text of the message or negative error code. The '^'
30 ; characters are replaced with spaces in the text.
31 ;
32 ; [REGNAME] Registry name
33 ;
34 ; [PATIEN] Patient IEN
35 ;
36 ; [ARG2-ARG5] Optional parameters as for $$ERROR^RORERR
37 ;
38ALERT(DUZ,MSG,REGNAME,PATIEN,ARG2,ARG3,ARG4,ARG5) ;
39 Q:'$G(DUZ)
40 N XQA,XQADATA,XQAFLG,XQAMSG,XQAROU,TMP
41 S XQA(DUZ)=""
42 ;--- Get text of the error message
43 I +MSG=MSG Q:MSG'<0 D
44 . S MSG=$$MSG^RORERR20(+MSG,,.PATIEN,.ARG2,.ARG3,.ARG4,.ARG5)
45 S MSG=$TR(MSG,"^","~"),XQAMSG="ROR: ",TMP=70-$L(XQAMSG)-3
46 S XQAMSG=XQAMSG_$S($L(MSG)>TMP:$E(MSG,1,TMP)_"...",1:MSG)
47 ;--- Setup alert processing routine
48 S $P(XQADATA,U,1)=$E(MSG,1,78)
49 S $P(XQADATA,U,2)=$G(REGNAME)
50 S $P(XQADATA,U,3)=$G(PATIEN)
51 S XQAROU="ALERTRTN^RORKIDS"
52 ;--- Send the alert
53 S XQAFLG="D" D SETUP^XQALERT
54 Q
55 ;
56 ;***** ALERT PROCESSING ROUTINE
57 ;
58 ; XQADATA Alert data
59 ; ^1: Message
60 ; ^2: Registry name
61 ; ^3: Patient DFN
62 ;
63ALERTRTN ;
64 ;;Registry Name:
65 ;;Patient DFN:
66 ;
67 Q:$G(XQADATA)=""
68 N I,TMP
69 W !!,$P(XQADATA,"^"),!
70 F I=1:1:2 S TMP=$P(XQADATA,"^",I+1) D:TMP'=""
71 . W $P($T(ALERTRTN+I),";;",2),?15,TMP,!
72 Q
73 ;
74 ;***** OUTPUTS THE MESSAGE AND PUTS IT INTO THE LOG
75BMES(MSG,INFO) ;
76 N I
77 D BMES^XPDUTL(" "_MSG)
78 S I=""
79 F S I=$O(INFO(I)) Q:I="" D MES^XPDUTL(" "_INFO(I))
80 D LOG^RORLOG(,MSG,,.INFO)
81 Q
82 ;
83 ;***** CHECKS THE SCHEDULED OPTION
84 ;
85 ; OPTION Option name
86 ;
87 ; Return Values:
88 ; <0 Error code
89 ; 0 Ok
90 ;
91 ; This function can be used in the environment check routines to
92 ; check if the option is running and/or scheduled to run.
93 ;
94 ; The function displays appropriate error messages and warnings
95 ; using the WRITE command. So, it MUST NOT be called from the
96 ; pre-install or post-install routines.
97 ;
98 ; The function uses the ^UTILITY($J,"W") node (^DIWP and ^DIWW).
99 ;
100CHKOPT(OPTION) ;
101 N DIWF,DIWL,DIWR,RC,RORBUF,RORI,RORSDT,TMP,X,ZTSK
102 ;--- Check status of the option
103 D OPTSTAT^XUTMOPT(OPTION,.RORBUF)
104 S (RC,RORSDT)=0
105 F RORI=1:1:$G(RORBUF) K ZTSK D I $G(ZTSK(1))=2 S RC=-76 Q
106 . S ZTSK=$P(RORBUF(RORI),"^") Q:'ZTSK
107 . D STAT^%ZTLOAD
108 . S TMP=$P(RORBUF(RORI),"^",2)
109 . I TMP>0 S:'RORSDT!(TMP<RORSDT) RORSDT=TMP
110 ;--- Display an error message if the option is running
111 I RC D Q RC
112 . W !,$$MSG^RORERR20(RC,,,OPTION),!
113 ;--- Display an apropriate warning
114 S DIWL=5,DIWR=$G(IOM,80)-DIWL
115 K ^UTILITY($J,"W")
116CM1 I RORSDT>0 D
117 . ;;"The ["_OPTION_"] option is scheduled to run "_RORSDT_"."
118 . ;;"If you are going to schedule the installation, please, choose"
119 . ;;"an appropriate time so that the post-install will either"
120 . ;;"finish well before the ["_OPTION_"] scheduled time or start"
121 . ;;"after the option completion."
122 . ;---
123 . S RORSDT=$$FMTE^XLFDT(RORSDT)
124 . S RORSDT="on "_$P(RORSDT,"@")_" at "_$P(RORSDT,"@",2)
125 . F RORI=1:1 S X=$T(CM1+RORI) Q:X'[";;" D
126 . . X "S X="_$P(X,";;",2) D ^DIWP
127CM2 E D
128 . ;;"The ["_OPTION_"] option is not scheduled. Do not forget"
129 . ;;"to schedule it after completion of the installation."
130 . ;---
131 . F RORI=1:1 S X=$T(CM2+RORI) Q:X'[";;" D
132 . . X "S X="_$P(X,";;",2) D ^DIWP
133 W ! D ^DIWW
134 Q 0
135 ;
136 ;***** PROCESSES THE INSTALL CHECKPOINT
137 ;
138 ; CPNAME Checkpoint name
139 ;
140 ; CALLBACK Callback entry point ($$TAG^ROUTINE). This function
141 ; accepts no parameters and must return either 0 if
142 ; everything is Ok or a negative error code.
143 ;
144 ; [PARAM] Value to set checkpoint parameter to.
145 ;
146 ; The function checks if the checkpoint is completed. If it is not,
147 ; the callback entry point is XECUTEd. If everything is Ok, the
148 ; function will complete the checkpoint.
149 ;
150 ; Return Values:
151 ; <0 Error code
152 ; 0 Ok
153 ;
154CP(CPNAME,CALLBACK,PARAM) ;
155 N RC
156 ;--- Verify the checkpoint and quit if it is completed
157 S RC=$$VERCP^XPDUTL(CPNAME) Q:RC>0 0
158 ;--- Create the new checkpoint
159 I RC<0 D Q:'RC $$ERROR^RORERR(-50,,,,CPNAME)
160 . S RC=$$NEWCP^XPDUTL(CPNAME,,.PARAM)
161 ;--- Reset the KIDS progress bar
162 S XPDIDTOT=0 D UPDATE^XPDID(0)
163 ;--- Execute the callback entry point
164 X "S RC="_CALLBACK Q:RC<0 RC
165 ;--- Complete the check point
166 S RC=$$COMCP^XPDUTL(CPNAME)
167 Q:'RC $$ERROR^RORERR(-51,,,,CPNAME)
168 Q 0
169 ;
170 ;***** DELETES THE (SUB)FILE DD AND DATA (IF REQUESTED)
171 ;
172 ; FILE File number
173 ;
174 ; [FLAGS] String that contains flags for EN^DIU2:
175 ; "D" Delete the data as well as the DD
176 ; "E" Echo back information during deletion
177 ; "S" Subfile data dictionary is to be deleted
178 ; "T" Templates are to be deleted
179 ;
180 ; [SILENT] If this parameters is defined and non-zero, the
181 ; function will work in "silent" mode.
182 ; Nothing (except error messages if debug mode >1 is
183 ; enabled) will be displayed on the console or stored
184 ; into the INSTALLATION file.
185 ;
186 ; Return Values:
187 ; <0 Error code
188 ; 0 Ok
189 ;
190 ; NOTE: This entry point can also be called as a procedure:
191 ; D DELFILE^RORKIDS(...) if you do not need its return value.
192 ;
193DELFILE(FILE,FLAGS,SILENT) ;
194 I '$$VFILE^DILFD(+FILE) Q:$QUIT 0 Q
195 N DIU,FT,RC
196 S DIU=+FILE,DIU(0)=$G(FLAGS)
197 I '$G(SILENT) D
198 . S FT=$S(DIU(0)["S":"subfile",1:"file")
199 . D BMES("Deleting the "_FT_" #"_(+FILE)_"...")
200 D EN^DIU2
201 D:'$G(SILENT) MES("The "_FT_" has been deleted.")
202 Q:$QUIT 0 Q
203 ;
204 ;***** DELETES FIELD DEFENITIONS FROM THE DD
205 ;
206 ; FILE File number
207 ;
208 ; FLDLST String that contains list of field numbers to
209 ; delete (separated with the ';').
210 ;
211 ; [SILENT] If this parameters is defined and non-zero, the
212 ; function will work in "silent" mode.
213 ; Nothing (except error messages if debug mode >1 is
214 ; enabled) will be displayed on the console or stored
215 ; into the INSTALLATION file.
216 ;
217 ; Return Values:
218 ; <0 Error code
219 ; 0 Ok
220 ;
221 ; NOTE: This entry point can also be called as a procedure:
222 ; D DELFLDS^RORKIDS(...) if you do not need its return value.
223 ;
224DELFLDS(FILE,FLDLST,SILENT) ;
225 I '$$VFILE^DILFD(+FILE) Q:$QUIT 0 Q
226 N DA,DIK,I,RC
227 D:'$G(SILENT)
228 . D BMES("Deleting the field definitions...")
229 . D MES("File #"_(+FILE)_", Fields: '"_FLDLST_"'")
230 S DA(1)=+FILE,DIK="^DD("_DA(1)_","
231 F I=1:1 S DA=$P(FLDLST,";",I) Q:'DA D ^DIK
232 D:'$G(SILENT) MES("The definitions have been deleted.")
233 Q:$QUIT 0 Q
234 ;
235 ;***** OUTPUTS THE MESSAGE AND PUTS IT INTO THE LOG
236MES(MSG,INFO) ;
237 N I
238 D MES^XPDUTL(" "_MSG)
239 S I=""
240 F S I=$O(INFO(I)) Q:I="" D MES^XPDUTL(" "_INFO(I))
241 D LOG^RORLOG(,MSG,,.INFO)
242 Q
243 ;
244 ;***** RETURNS A VALUE OF THE INSTALLATION PARAMETER
245 ;
246 ; NAME Name of the parameter
247 ;
248PARAM(NAME) ;
249 Q $G(RORPARM("KIDS",NAME))
250 ;
251 ;***** UPDATES THE FILE'S PACKAGE REVISION DATA (IF NECESSARY)
252 ;
253 ; FILE File number
254 ;
255 ; [PRD] Package revision data
256 ; ^01: Revision number (N.N)
257 ; ^02: Patch name
258 ;
259 ; If this entry point is called as a function, it returns the
260 ; previous value of the PACKAGE REVISION DATA attribute.
261 ;
262PRD(FILE,PRD) ;
263 N OLDPRD,RORMSG
264 S OLDPRD=$$GET1^DID(FILE,,,"PACKAGE REVISION DATA",,"RORMSG")
265 D:$G(PRD)>OLDPRD PRD^DILFD(FILE,PRD)
266 Q:$QUIT OLDPRD Q
Note: See TracBrowser for help on using the repository browser.