1 iso_date: proc;
2
3
4
5
6
7
8
9
10
11
12 dcl cu_$af_return_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
13 nargs fixed bin,
14 max_length fixed bin (21),
15 rtn_string_ptr ptr,
16 return_string char (max_length) varying based (rtn_string_ptr),
17 (cu_$arg_ptr, cu_$af_arg_ptr) entry (fixed bin, ptr, fixed bin (21), fixed bin (35)),
18 ap ptr,
19 al fixed bin (21),
20 arg char (al) based (ap),
21 err fixed bin (35);
22 dcl is_af bit (1) aligned;
23 dcl get_arg entry (fixed bin, ptr, fixed bin (21), fixed bin (35)) variable;
24
25 dcl separator char (1) varying aligned,
26 year char (4) varying aligned,
27 month char (4) varying aligned,
28 day char (2);
29 dcl final_date char (12) varying aligned;
30
31 dcl (com_err_, active_fnc_err_) entry options (variable),
32 err_routine entry options (variable) variable;
33 dcl prog char (8) aligned initial ("iso_date") static internal options (constant);
34 dcl ii fixed bin;
35 dcl have_date bit (1) aligned,
36 roman_month bit (1),
37 actual_date fixed bin (71);
38 dcl mmddyy_string char (8);
39 dcl date_time_ entry (fixed bin (71), char (*)),
40 convert_date_to_binary_ entry (char (*), fixed bin (71), fixed bin (35));
41 dcl full_year bit (1);
42 dcl (error_table_$not_act_fnc,
43 error_table_$badopt) static external fixed bin (35);
44 dcl ioa_ entry options (variable);
45
46 dcl month_pict picture "99",
47 roman_months (12) char (4) varying aligned static internal options (constant)
48 init ("I", "II", "III", "IV", "V", "VI", "VII", "VIII", "IX", "X", "XI", "XII");
49
50 dcl (addr, null, substr, decimal) builtin;
51
52
53
54
55 call cu_$af_return_arg (nargs, rtn_string_ptr, max_length, err);
56 if err = 0 then do;
57 err_routine = active_fnc_err_;
58 get_arg = cu_$af_arg_ptr;
59 is_af = "1"b;
60 end;
61 else if err = error_table_$not_act_fnc then do;
62 err_routine = com_err_;
63 get_arg = cu_$arg_ptr;
64 is_af = "0"b;
65 end;
66 else do;
67 call com_err_ (err, prog, "");
68 return;
69 end;
70
71
72 full_year,
73 roman_month,
74 have_date = "0"b;
75 separator = ".";
76
77 do ii = 1 to nargs;
78 call get_arg (ii, ap, al, err);
79
80 if substr (arg, 1, 1) ^= "-" then do;
81 if have_date then do;
82 call err_routine (0, prog, "date already specified: ^a", arg);
83 return;
84 end;
85 call convert_date_to_binary_ (arg, actual_date, err);
86 if err ^= 0 then do;
87 call err_routine (err, prog, arg);
88 return;
89 end;
90 have_date = "1"b;
91 end;
92
93 else if arg = "-nsep" | arg = "-no_separator" then
94 separator = "";
95
96 else if arg = "-separator" | arg = "-sep" then do;
97 call get_arg (ii+1, ap, al, err);
98 if err ^= 0 then do;
99 call err_routine (err, prog, arg);
100 return;
101 end;
102 separator = arg;
103 ii = ii + 1;
104 end;
105
106 else if arg = "-roman_month" | arg = "-roman" then
107 roman_month = "1"b;
108
109 else if arg = "-full_year" then
110 full_year = "1"b;
111 else if arg = "-short_year" then
112 full_year = "0"b;
113
114 else if arg = "-help" then do;
115 call err_routine (0, prog,
116 "Usage: ^a {date} {-nsep|-separator} {-full_year|-short_year} {-roman_month}", prog);
117 return;
118 end;
119
120 else do;
121 call err_routine (error_table_$badopt, prog, arg);
122 return;
123 end;
124 end;
125
126
127 if ^have_date then do;
128 call convert_date_to_binary_ ("", actual_date, err);
129 if err ^= 0 then do;
130 call err_routine (err, prog, "current date");
131 return;
132 end;
133 end;
134
135
136 call date_time_ (actual_date, mmddyy_string);
137
138
139 if ^roman_month then
140 month = substr (mmddyy_string, 1, 2);
141 else do;
142 month_pict = decimal (substr (mmddyy_string, 1, 2), 2);
143 month = roman_months (month_pict);
144 end;
145 day = substr (mmddyy_string, 4, 2);
146 if full_year then
147 year = "19" || substr (mmddyy_string, 7, 2);
148 else year = substr (mmddyy_string, 7, 2);
149
150
151
152 final_date = year || separator || month || separator || day;
153
154 if is_af then
155 return_string = final_date;
156 else
157 call ioa_ ("^a", final_date);
158
159 return;
160 end iso_date;