| 1 | IMRKIDS ;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
|
|---|
| 7 | BMES(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 | ;
|
|---|
| 23 | CLRFILE(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 | ;
|
|---|
| 54 | CP(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 | ;
|
|---|
| 94 | DBSERR(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 | ;
|
|---|
| 128 | DELFILE(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 | ;
|
|---|
| 156 | DELFLDS(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 | ;
|
|---|
| 172 | ERRDL(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 | ;
|
|---|
| 194 | ERROR(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
|
|---|
| 211 | MES(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
|
|---|
