source: WorldVistAEHR/trunk/r/ICR_IMMUNOLOGY_CASE_REGISTRY-IMR/IMRKIDS.m@ 1211

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

initial load of WorldVistAEHR

File size: 6.5 KB
Line 
1IMRKIDS ;HCIOFO/SG - INSTALL UTILITIES (LOW-LEVEL) ; 7/23/02 8:31am
2 ;;2.1;IMMUNOLOGY CASE REGISTRY;**18**;Feb 09, 1998
3 ;
4 Q
5 ;
6 ;***** DISPLAYS THE INSTALLATION MESSAGE
7BMES(MSG,INFO) ;
8 N I
9 D BMES^XPDUTL(" "_MSG)
10 S I=""
11 F S I=$O(INFO(I)) Q:I="" D MES^XPDUTL(" "_INFO(I))
12 Q
13 ;
14 ;***** DELETES ALL RECORDS FROM THE (SUB)FILE
15 ;
16 ; FILE File/Subfile number
17 ; [IENS] IENS of the subfile
18 ;
19 ; Return Values:
20 ; <0 Error code
21 ; 0 Ok
22 ;
23CLRFILE(FILE,IENS) ;
24 N IEN,IMRFDA,IMRMSG,RC,ROOT
25 S ROOT=$$ROOT^DILFD(FILE,$G(IENS),1)
26 S:$G(IENS)="" IENS=","
27 ;--- Delete the records
28 S (IEN,RC)=0
29 F S IEN=$O(@ROOT@(IEN)) Q:'IEN D Q:RC<0
30 . S IMRFDA(FILE,IEN_IENS,.01)="@"
31 . D FILE^DIE(,"IMRFDA","IMRMSG")
32 . I $G(DIERR) D Q
33 . . S RC=$$DBSERR("IMRMSG",-9,"CLRFILE^IMRKIDS",FILE,IEN_IENS)
34 Q $S(RC<0:RC,1:0)
35 ;
36 ;***** PROCESSES THE INSTALL CHECKPOINT
37 ;
38 ; CPNAME Checkpoint name
39 ;
40 ; CALLBACK Callback entry point ($$TAG^ROUTINE). This function
41 ; accepts no parameters and must return either 0 if
42 ; everything is Ok or a negative error code.
43 ;
44 ; [PARAM] Value to set checkpoint parameter to.
45 ;
46 ; The function checks if the checkpoint is completed. If it is not,
47 ; the callback entry point is XECUTEd. If everything is Ok, the
48 ; function will complete the checkpoint.
49 ;
50 ; Return Values:
51 ; <0 Error code
52 ; 0 Ok
53 ;
54CP(CPNAME,CALLBACK,PARAM) ;
55 N RC
56 ;--- Verify the checkpoint and quit if it is completed
57 S RC=$$VERCP^XPDUTL(CPNAME) Q:RC>0 0
58 ;--- Create the new checkpoint
59 I RC<0 D Q:'RC $$ERROR(-3,"CP^IMRKIDS",,CPNAME)
60 . S RC=$$NEWCP^XPDUTL(CPNAME,,.PARAM)
61 ;--- Reset the KIDS progress bar
62 S XPDIDTOT=0 D UPDATE^XPDID(0)
63 ;--- Execute the callback entry point
64 X "S RC="_CALLBACK Q:RC<0 RC
65 ;--- Complete the check point
66 S RC=$$COMCP^XPDUTL(CPNAME)
67 Q:'RC $$ERROR(-4,"CP^IMRKIDS",,CPNAME)
68 Q 0
69 ;
70 ;***** CHECKS THE ERRORS AFTER A FILEMAN DBS CALL
71 ;
72 ; IMR8MSG Closed reference of the error messages array
73 ; (from DBS calls)
74 ; [ERRCODE] Error code to assign
75 ; PLACE Location of the error (see the $$ERROR)
76 ; [FILE] File number used in the DBS call
77 ; [IENS] IENS used in the DBS call
78 ;
79 ; The $$DBSERR^IMRKIDS function checks the DIERR and @IMR8MSG
80 ; variables for errors after a FileMan DBS call.
81 ;
82 ; Return Values:
83 ;
84 ; If there are no errors found, it returns an empty string.
85 ; In case of errors, the result depends on value of the ERRCODE
86 ; parameter:
87 ;
88 ; If ERRCODE is omitted or equals 0, the function returns a string
89 ; containing the list of error codes separated by comma.
90 ;
91 ; If ERRCODE is not zero, the $$ERROR^IMRKIDS function is called and
92 ; its return value is returned.
93 ;
94DBSERR(IMR8MSG,ERRCODE,PLACE,FILE,IENS) ;
95 Q:'$G(DIERR) ""
96 N ERRLST,ERRNODE,I,MSGTEXT
97 S ERRNODE=$S($G(IMR8MSG)'="":$NA(@IMR8MSG@("DIERR")),1:$NA(^TMP("DIERR",$J)))
98 Q:$D(@ERRNODE)<10 ""
99 I '$G(ERRCODE) D Q $P(ERRLST,",",2,99)
100 . S ERRLST="",I=0
101 . F S I=$O(@ERRNODE@(I)) Q:'I S ERRLST=ERRLST_","_@ERRNODE@(I)
102 . D CLEAN^DILF
103 D MSG^DIALOG("AE",.MSGTEXT,,,$G(IMR8MSG)),CLEAN^DILF
104 S I=$S($G(FILE):"; File #"_FILE,1:"")
105 S:$G(IENS)'="" I=I_"; IENS: """_IENS_""""
106 Q $$ERROR(ERRCODE,PLACE,.MSGTEXT,I)
107 ;
108 ;***** DELETES THE (SUB)FILE DD AND DATA (IF REQUESTED)
109 ;
110 ; FILE File number
111 ;
112 ; [FLAGS] String that contains flags for EN^DIU2:
113 ; "D" Delete the data as well as the DD
114 ; "E" Echo back information during deletion
115 ; "S" Subfile data dictionary is to be deleted
116 ; "T" Templates are to be deleted
117 ;
118 ; [SILENT] If this parameters is defined and non-zero, the
119 ; function will work in "silent" mode.
120 ; Nothing (except error messages if debug mode >1 is
121 ; enabled) will be displayed on the console or stored
122 ; into the INSTALLATION file.
123 ;
124 ; Return Values:
125 ; <0 Error code
126 ; 0 Ok
127 ;
128DELFILE(FILE,FLAGS,SILENT) ;
129 Q:'$$VFILE^DILFD(+FILE) 0
130 N DIU,FT,RC
131 S DIU=+FILE,DIU(0)=$G(FLAGS)
132 I '$G(SILENT) D
133 . S FT=$S(DIU(0)["S":"subfile",1:"file")
134 . D BMES("Deleting the "_FT_" #"_(+FILE)_"...")
135 D EN^DIU2
136 D:'$G(SILENT) MES("The "_FT_" has been deleted.")
137 Q 0
138 ;
139 ;***** DELETES FIELD DEFENITIONS FROM THE DD
140 ;
141 ; FILE File number
142 ;
143 ; FLDLST String that contains list of field numbers to
144 ; delete (separated with the ';').
145 ;
146 ; [SILENT] If this parameters is defined and non-zero, the
147 ; function will work in "silent" mode.
148 ; Nothing (except error messages if debug mode >1 is
149 ; enabled) will be displayed on the console or stored
150 ; into the INSTALLATION file.
151 ;
152 ; Return Values:
153 ; <0 Error code
154 ; 0 Ok
155 ;
156DELFLDS(FILE,FLDLST,SILENT) ;
157 Q:'$$VFILE^DILFD(+FILE) 0
158 N DA,DIK,I,RC,ROOT
159 D:'$G(SILENT)
160 . D BMES("Deleting the field definitions...")
161 . D MES("File #"_(+FILE)_", Fields: '"_FLDLST_"'")
162 S DA(1)=+FILE,DIK="^DD("_DA(1)_","
163 F I=1:1 S DA=$P(FLDLST,";",I) Q:'DA D ^DIK
164 D:'$G(SILENT) MES("The definitions have been deleted.")
165 Q 0
166 ;
167 ;***** DISPLAYS A LINE OF THE ERROR MESSAGE
168 ;
169 ; MSG Message to display
170 ; [SKIP] Skip a line before the output
171 ;
172ERRDL(MSG,SKIP) ;
173 I $D(XPDENV)!($G(XPDNM)="") W:$G(SKIP) ! W MSG,! Q
174 I $G(SKIP) D BMES^XPDUTL(MSG) Q
175 D MES^XPDUTL(MSG)
176 Q
177 ;
178 ;***** DISPLAYS THE ERROR
179 ;
180 ; ERRCODE Error code.
181 ;
182 ; PLACE Location of the error (TAG^ROUTINE).
183 ;
184 ; [[.]IMRINFO] Optional additional information (either a string or
185 ; a reference to a local array that contains strings
186 ; prepared for storing in a word processing field)
187 ;
188 ; [ARG2-ARG5] Optional parameters as for $$MSG^IMRKIDS1
189 ;
190 ; Return Values:
191 ; <0 Error code (value of the ERRCODE)
192 ; 0 Ok (if ERRCOCE'<0)
193 ;
194ERROR(ERRCODE,PLACE,IMRINFO,ARG2,ARG3,ARG4,ARG5) ;
195 Q:ERRCODE'<0 0
196 N IR,MSG,TMP,TYPE
197 I $D(IMRINFO)=1 S IR=IMRINFO K IMRINFO S IMRINFO(1)=IR,IR=1
198 E S IR=$O(IMRINFO(""),-1)
199 S MSG=$$MSG^IMRKIDS1(+ERRCODE,.TYPE,,.ARG2,.ARG3,.ARG4,.ARG5)
200 S IR=IR+1,IMRINFO(IR)="Location: "_PLACE
201 ;--- Display the message
202 U:$G(IO(0))'="" IO(0)
203 D ERRDL($P($$FMTE^XLFDT($$NOW^XLFDT,"2FS"),"@",2)_" "_$E(MSG,1,70),1)
204 S IR=""
205 F S IR=$O(IMRINFO(IR)) Q:IR="" D D ERRDL($J("",9)_TMP)
206 . S TMP=$G(IMRINFO(IR)) S:TMP="" TMP=$G(IMRINFO(IR,0))
207 U IO
208 Q ERRCODE
209 ;
210 ;***** DISPLAYS THE INSTALLATION MESSAGE
211MES(MSG,INFO) ;
212 N I
213 D MES^XPDUTL(" "_MSG)
214 S I=""
215 F S I=$O(INFO(I)) Q:I="" D MES^XPDUTL(" "_INFO(I))
216 Q
Note: See TracBrowser for help on using the repository browser.