1 /****^  ***********************************************************
  2         *                                                         *
  3         * Copyright, (C) BULL HN Information Systems Inc., 1989   *
  4         *                                                         *
  5         * Copyright, (C) Honeywell Information Systems Inc., 1982 *
  6         *                                                         *
  7         * Copyright (c) 1972 by Massachusetts Institute of        *
  8         * Technology and Honeywell Information Systems, Inc.      *
  9         *                                                         *
 10         *********************************************************** */
 11 
 12 
 13 
 14 
 15 /****^  HISTORY COMMENTS:
 16   1) change(89-04-28,Vu), approve(89-04-28,MCR8100), audit(89-05-05,Lee),
 17      install(89-06-09,MR12.3-1057):
 18      use the process date_time format rather than the concatenation of the
 19      process date and time format for all keywords starting with date_time_**.
 20                                                    END HISTORY COMMENTS */
 21 
 22 
 23 system: proc;
 24 
 25 /*
 26    Modified Feb 1980 by M. B. Armstrong to implement multiple rate structures.(UNCA)
 27    Changed to requote return string 03/19/80 S. Herbst
 28    Modified June 1981 by E. N. Kittlitz for UNCA rate structures
 29 
 30    Modified Sept 1982 by Linda Pugh to add date_time_XXX and default_absentee_queue
 31    keys.  The following key words are obsolete and are no longer documented;
 32    however, they are retained for compatibility (time_up, next_down_time,
 33    down_until time, shift_change_time, date_up, next_down_date, last_down_time,
 34    last_down date, shift_change_date, down_until_date)
 35 
 36    Modified May 1983 by Art Beattie to add version_id key word.
 37    Modified 10/3/83 by C Spitzer to add all keyword, printed in sorted list
 38                                  make last_down_reason return  ERFnn instead of just nn.
 39    Modified 06/19/84 by J A Falksen to utilize date_time_$format with keywords
 40                                  "date", "time", and "date_time".
 41    Modified 840619 for session_type keyword, and to make ERF DUMP... -E. A. Ranzenbach
 42    Modified 841113 to put back BIM's trusted_path_login keyword that was mistakenly backed out
 43    by the date_time_$format installation...
 44 */
 45 
 46 dcl  ap ptr,                                                /* ptr to argument */
 47      al fixed bin (21),                                     /* lth of argument */
 48      bchr char (al) based (ap) unal,                        /* argument */
 49      answer char (al) varying based (ap);                   /* return argument */
 50 
 51 dcl  time fixed bin (71),
 52      nactsw bit (1),
 53      all_switch bit (1) aligned,
 54      stp_sw bit (36) aligned,
 55      switch fixed bin,
 56      host_num fixed binary (16),
 57      ec fixed bin (35),
 58      rs_number fixed bin,
 59      rs_name char (32),
 60      tli fixed bin (71),
 61      wd char (9) aligned,
 62      dn char (168),
 63      j fixed bin,
 64     (t1, t2) fixed bin,
 65      i35 fixed bin (35),
 66      string char (300) varying init ("");
 67 dcl  max_rs_number fixed bin;
 68 dcl  default_q fixed bin;
 69 
 70 dcl  error entry options (variable) variable;
 71 dcl  get_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;
 72 
 73 dcl  inarg char (32) aligned;
 74 
 75 
 76 dcl  item (38) char (32) aligned int static options (constant) init (
 77      "ARPANET_host_number",                                 /* case 1 */
 78      "company",                                             /* case 2 */
 79      "date_time_last_down",                                 /* case 3 */
 80      "date_time_last_up",                                   /* case 4 */
 81      "date_time_next_down",                                 /* case 5 */
 82      "date_time_next_up",                                   /* case 6 */
 83      "date_time_shift_change",                              /* case 7 */
 84      "date_up",                                             /* case 8 */
 85      "default_absentee_queue",                              /* case 9 */
 86      "department",                                          /* case 10 */
 87      "down_until_date",                                     /* case 11 */
 88      "down_until_time",                                     /* case 12 */
 89      "ds_company",                                          /* case 13 */
 90      "ds_department",                                       /* case 14 */
 91      "installation_id",                                     /* case 15 */
 92      "last_down_date",                                      /* case 16 */
 93      "last_down_reason",                                    /* case 17 */
 94      "last_down_time",                                      /* case 18 */
 95      "max_rate_structure_number",                           /* case 19 */
 96      "max_units",                                           /* case 20 */
 97      "max_users",                                           /* case 21 */
 98      "n_units",                                             /* case 22 */
 99      "n_users",                                             /* case 23 */
100      "next_down_date",                                      /* case 24 */
101      "next_down_time",                                      /* case 25 */
102      "next_shift",                                          /* case 26 */
103      "rate_structure_name",                                 /* case 27 */
104      "rate_structure_number",                               /* case 28 */
105      "reason_down",                                         /* case 29 */
106      "shift",                                               /* case 30 */
107      "shift_change_date",                                   /* case 31 */
108      "shift_change_time",                                   /* case 32 */
109      "sysid",                                               /* case 33 */
110      "time_up",                                             /* case 34 */
111      "version_id",                                          /* case 35 */
112      "session_type",                                        /* case 36 */
113      "trusted_path_login",                                  /* case 37 */
114      "all");                                                /* MUST BE LAST */
115 
116 dcl  error_table_$badopt fixed bin (35) ext,
117      error_table_$bad_arg fixed bin (35) ext,
118      error_table_$not_act_fnc fixed bin (35) ext;
119 
120 dcl  cu_$arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
121      cu_$af_arg_ptr entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
122      cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
123      cv_dec_check_ entry (char (*), fixed bin (35)) returns (fixed bin (35)),
124      active_fnc_err_ entry options (variable),
125      com_err_ entry options (variable),
126      ioa_ entry options (variable),
127      date_time_$format entry (char(*), fixed bin(71), char(*), char(*)) returns(char(250) var),
128      requote_string_ entry (char (*)) returns (char (*)),
129      system_info_$installation_id entry (char (*)),
130      system_info_$sysid entry (char (*)),
131      system_info_$session entry (char (*)),
132      system_info_$trusted_path_flags entry (bit(36) aligned),
133      system_info_$version_id entry (char (*)),
134      system_info_$titles entry options (variable),
135      system_info_$users entry options (variable),
136      system_info_$timeup entry (fixed bin (71)),
137      system_info_$next_shutdown entry options (variable),
138      system_info_$next_shift_change entry options (variable),
139      system_info_$last_shutdown entry options (variable),
140      system_info_$ARPANET_host_number entry (fixed bin (16)),
141      system_info_$rs_number entry (char (*), fixed bin, fixed bin (35)),
142      system_info_$rs_name entry (fixed bin, char (*), fixed bin (35)),
143      system_info_$max_rs_number entry (fixed bin),
144      system_info_$default_absentee_queue entry (fixed bin),
145      ioa_$rsnnl entry options (variable);
146 
147 dcl (hbound, ltrim, rtrim) builtin;
148 
149 /* ======================================================= */
150 
151           call cu_$af_arg_ptr (1, ap, al, ec);
152           if ec = error_table_$not_act_fnc then do;
153                error = com_err_;
154                get_arg = cu_$arg_ptr;
155                call get_arg (1, ap, al, ec);
156                nactsw = "1"b;
157           end;
158           else do;
159                error = active_fnc_err_;
160                get_arg = cu_$af_arg_ptr;
161                nactsw = "0"b;
162           end;
163           if ec ^= 0 then do;
164 er:            call error (ec, "system");
165                return;
166           end;
167           inarg = bchr;
168 
169           all_switch = "0"b;
170           do switch = 1 to hbound (item, 1);
171                if inarg = item (switch) then go to have_good_item;
172           end;
173           call error (error_table_$badopt, "system", """^a""", inarg);
174           return;
175 
176 have_good_item:
177           if switch = hbound (item, 1)
178           then if nactsw
179                then do;
180                     all_switch = "1"b;
181                     switch = 1;
182                     end;
183                else do;
184                     call error (error_table_$bad_arg, "system", "^a", inarg);
185                     end;
186 
187 ok:       go to case (switch);
188 
189 case (15):                                                  /* installation_id */
190           call system_info_$installation_id (dn);
191 rtrim_string:
192           string = rtrim (dn);
193           go to exit;
194 case (33):                                                  /* sysid */
195           call system_info_$sysid (dn);
196           go to rtrim_string;
197 case (37):                                                  /* trusted_path_login */
198           call system_info_$trusted_path_flags (stp_sw);
199           if stp_sw then dn = "true";
200           else dn = "false";
201           go to rtrim_string;
202 
203 case (36):                                                  /* session_type */
204           call system_info_$session (dn);
205           go to rtrim_string;
206 case (2):                                                   /* company */
207           call system_info_$titles (dn, wd, wd, wd);
208           go to rtrim_string;
209 case (10):                                                  /* department */
210           call system_info_$titles (wd, dn, wd, wd);
211           go to rtrim_string;
212 case (13):                                                  /* ds_company */
213           call system_info_$titles (wd, wd, dn, wd);
214           go to rtrim_string;
215 case (14):                                                  /* ds_department */
216           call system_info_$titles (wd, wd, wd, dn);
217           go to rtrim_string;
218 case (21):                                                  /* max_users */
219           call system_info_$users (t1, t2, t2, t2);
220 cv_num:
221           call ioa_$rsnnl ("^d", string, j, t1);
222           go to exit;
223 case (23):                                                  /* n_users */
224           call system_info_$users (t2, t1, t2, t2);
225           go to cv_num;
226 case (20):                                                  /* max_units */
227           call system_info_$users (t2, t2, t1, t2);
228 cv_float:
229           call ioa_$rsnnl ("^.1f", string, j, t1*1e-1);
230           go to exit;
231 case (22):                                                  /* n_units */
232           call system_info_$users (t2, t2, t2, t1);
233           go to cv_float;
234 case (34):                                                  /* time_up */
235           call system_info_$timeup (tli);
236 cv_time:
237           string = date_time_$format ("time",tli,"","");
238           go to exit;
239 case (25):                                                  /* next_down_time */
240           call system_info_$next_shutdown (tli);
241           if tli = 0 then do;
242 notime:        string = "none";
243                go to exit;
244           end;
245           go to cv_time;
246 case (12):                                                  /* down_until_time */
247           call system_info_$next_shutdown (time, dn, tli);
248           if time = 0 then go to notime;
249           if tli = 0 then go to notime;
250           go to cv_time;
251 case (29):                                                  /* reason_down */
252           call system_info_$next_shutdown (tli, dn);
253           if tli = 0 then go to notime;
254           go to rtrim_string;
255 case (30):                                                  /* shift */
256           call system_info_$next_shift_change (t1, tli, t2);
257           go to cv_num;
258 case (32):                                                  /* shift_change_time */
259           call system_info_$next_shift_change (t1, tli, t2);
260           go to cv_time;
261 case (26):                                                  /* next_shift */
262           call system_info_$next_shift_change (t2, tli, t1);
263           go to cv_num;
264 case (8):                                                   /* date_up */
265           call system_info_$timeup (tli);
266 cv_date:
267           string = date_time_$format ("date",tli,"","");
268           go to exit;
269 case (24):                                                  /* next_down_date */
270           call system_info_$next_shutdown (tli);
271           if tli = 0 then go to notime;
272           go to cv_date;
273 case (11):                                                  /* down_until_date */
274           call system_info_$next_shutdown (time, dn, tli);
275           if time = 0 then go to notime;
276           if tli = 0 then go to notime;
277           go to cv_date;
278 case (31):                                                  /* shift_change_date */
279           call system_info_$next_shift_change (t1, tli, t2);
280           go to cv_date;
281 case (18):                                                  /* last_down_time */
282           call system_info_$last_shutdown (tli);
283           go to cv_time;
284 case (16):                                                  /* last_down_date */
285           call system_info_$last_shutdown (tli);
286           go to cv_date;
287 case (17):                                                  /* last_down_reason */
288           call system_info_$last_shutdown (tli, dn);
289           go to rtrim_string;
290 case (1):                                                   /* ARPANET_host_number */
291           call system_info_$ARPANET_host_number (host_num);
292           t1 = host_num;
293           go to cv_num;
294 case (28):                                                  /* rate_structure_number */
295           string = "";
296           call get_arg (2, ap, al, ec);
297           if ec ^= 0
298           then if all_switch
299                then goto exit;
300                else go to er;
301           call system_info_$rs_number (bchr, rs_number, ec);
302           if ec ^= 0 then do;
303                call error (ec, "system", "Rate structure name ""^a"".", bchr);
304                if all_switch then goto exit;
305                else return;
306           end;
307           t1 = rs_number;
308           go to cv_num;
309 case (27):                                                  /* rate_structure_name */
310           call system_info_$max_rs_number (max_rs_number);
311           string = "";
312           call get_arg (2, ap, al, ec);
313           if ec = 0 then do;
314                i35 = cv_dec_check_ (bchr, ec);
315                if ec ^= 0 then do;
316 rs_nm_error:        ec = error_table_$bad_arg;
317                     call error (ec, "system", "Rate structure number ^a.", bchr);
318                     if all_switch then goto exit;
319                     else return;
320                end;
321                if i35 < 0 | i35 > max_rs_number then go to rs_nm_error; /* outside capbility of rs_number? */
322                rs_number = i35;
323                call system_info_$rs_name (rs_number, rs_name, ec);
324                if ec ^= 0 then goto rs_nm_error;
325                string = rtrim (ltrim (rs_name));
326           end;
327           else do rs_number = 0 to max_rs_number;
328                call system_info_$rs_name (rs_number, rs_name, ec);
329                if ec ^= 0 then go to exit;
330                if string ^= "" then string = string || " ";
331                string = string || rtrim (rs_name);
332           end;
333           go to exit;
334 case (19):                                                  /* max_rate_structure_number */
335           call system_info_$max_rs_number (rs_number);
336           t1 = rs_number;
337           go to cv_num;
338 case (4):                                                   /* date_time_last_up */
339           call system_info_$timeup (tli);
340 cv_date_time:
341 
342 /**** vp: phx19051; use the process date_time format rather than the
343       concatenation of the process date and time for all keywords
344       starting with date_time_**                                      ****/
345 
346           string = date_time_$format ("date_time",tli,"","");
347           go to exit;
348 case (5):                                                   /* date_time_next_down */
349           call system_info_$next_shutdown (tli);
350           if tli = 0 then go to notime;
351           go to cv_date_time;
352 case (6):                                                   /* date_time_next_up */
353           call system_info_$next_shutdown (time, dn, tli);
354           if time = 0 then go to notime;
355           if tli = 0 then go to notime;
356           go to cv_date_time;
357 case (3):                                                   /* date_time_last_down */
358           call system_info_$last_shutdown (tli);
359           go to cv_date_time;
360 case (7):                                                   /* date_time_shift_change */
361           call system_info_$next_shift_change (t1, tli, t2);
362           go to cv_date_time;
363 case (9):                                                   /* default_absentee_queue */
364           call system_info_$default_absentee_queue (default_q);
365           t1 = default_q;
366           go to cv_num;
367 case (35):                                                  /* version_id */
368           call system_info_$version_id (dn);
369           go to rtrim_string;
370 
371 exit:     if all_switch then do;
372                if string ^= "" then call ioa_ ("^a:^28t^a", item (switch), string);
373                switch = switch + 1;
374                if switch = hbound (item, 1) then return;
375                else goto ok;
376                end;
377           else if nactsw then do;
378                     call ioa_ ("^a", string);
379                     return;
380                end;
381           call cu_$af_return_arg (j, ap, al, ec);
382           if ec ^= 0 then go to er;
383           answer = requote_string_ ((string));
384 
385      end;