| 1 | ****************************************************************** |
| 2 | *Procedure Division Copybook for DATE related code |
| 3 | ****************************************************************** |
| 4 | *Date validation paragraph for reuse and hopefully not misuse |
| 5 | *Accompanying WORKING Storage is CSUTLDTR |
| 6 | ****************************************************************** |
| 7 | * *** PERFORM EDIT-DATE-CCYYMMDD |
| 8 | * THRU EDIT-DATE-CCYYMMDD-EXIT |
| 9 | * to validate CCYYMMDD dates |
| 10 | * Reusable paras |
| 11 | * a) EDIT-YEAR-CCYY |
| 12 | * b) EDIT-MONTH |
| 13 | * c) EDIT-DAY |
| 14 | * d) EDIT-DATE-OF-BIRTH |
| 15 | * e) EDIT-DATE-OF-BIRTH |
| 16 | ****************************************************************** |
| 17 | |
| 18 | EDIT-DATE-CCYYMMDD. |
| 19 | SET WS-EDIT-DATE-IS-INVALID TO TRUE |
| 20 | . |
| 21 | |
| 22 | ****************************************************************** |
| 23 | *Check for valid year and century |
| 24 | ****************************************************************** |
| 25 | EDIT-YEAR-CCYY. |
| 26 | |
| 27 | SET FLG-YEAR-NOT-OK TO TRUE |
| 28 | |
| 29 | * Not supplied |
| 30 | IF WS-EDIT-DATE-CCYY EQUAL LOW-VALUES |
| 31 | OR WS-EDIT-DATE-CCYY EQUAL SPACES |
| 32 | SET INPUT-ERROR TO TRUE |
| 33 | SET FLG-YEAR-BLANK TO TRUE |
| 34 | IF WS-RETURN-MSG-OFF |
| 35 | STRING |
| 36 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 37 | ' : Year must be supplied.' |
| 38 | DELIMITED BY SIZE |
| 39 | INTO WS-RETURN-MSG |
| 40 | END-IF |
| 41 | * Intentional violation of structured programming norms |
| 42 | GO TO EDIT-YEAR-CCYY-EXIT |
| 43 | ELSE |
| 44 | CONTINUE |
| 45 | END-IF |
| 46 | |
| 47 | * Not numeric |
| 48 | IF WS-EDIT-DATE-CCYY IS NOT NUMERIC |
| 49 | SET INPUT-ERROR TO TRUE |
| 50 | SET FLG-YEAR-NOT-OK TO TRUE |
| 51 | IF WS-RETURN-MSG-OFF |
| 52 | STRING |
| 53 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 54 | ' must be 4 digit number.' |
| 55 | DELIMITED BY SIZE |
| 56 | INTO WS-RETURN-MSG |
| 57 | END-IF |
| 58 | GO TO EDIT-YEAR-CCYY-EXIT |
| 59 | ELSE |
| 60 | CONTINUE |
| 61 | END-IF |
| 62 | |
| 63 | ****************************************************************** |
| 64 | * Century not reasonable |
| 65 | ****************************************************************** |
| 66 | * Not having learnt our lesson from history and Y2K |
| 67 | * And being unable to imagine COBOL in the 2100s |
| 68 | * We code only 19 and 20 as valid century values |
| 69 | ****************************************************************** |
| 70 | IF THIS-CENTURY |
| 71 | OR LAST-CENTURY |
| 72 | CONTINUE |
| 73 | ELSE |
| 74 | SET INPUT-ERROR TO TRUE |
| 75 | SET FLG-YEAR-NOT-OK TO TRUE |
| 76 | IF WS-RETURN-MSG-OFF |
| 77 | STRING |
| 78 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 79 | ' : Century is not valid.' |
| 80 | DELIMITED BY SIZE |
| 81 | INTO WS-RETURN-MSG |
| 82 | END-IF |
| 83 | GO TO EDIT-YEAR-CCYY-EXIT |
| 84 | END-IF |
| 85 | |
| 86 | SET FLG-YEAR-ISVALID TO TRUE |
| 87 | . |
| 88 | EDIT-YEAR-CCYY-EXIT. |
| 89 | EXIT |
| 90 | . |
| 91 | EDIT-MONTH. |
| 92 | SET FLG-MONTH-NOT-OK TO TRUE |
| 93 | |
| 94 | IF WS-EDIT-DATE-MM EQUAL LOW-VALUES |
| 95 | OR WS-EDIT-DATE-MM EQUAL SPACES |
| 96 | SET INPUT-ERROR TO TRUE |
| 97 | SET FLG-MONTH-BLANK TO TRUE |
| 98 | IF WS-RETURN-MSG-OFF |
| 99 | STRING |
| 100 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 101 | ' : Month must be supplied.' |
| 102 | DELIMITED BY SIZE |
| 103 | INTO WS-RETURN-MSG |
| 104 | END-IF |
| 105 | GO TO EDIT-MONTH-EXIT |
| 106 | ELSE |
| 107 | CONTINUE |
| 108 | END-IF |
| 109 | |
| 110 | * Month not reasonable |
| 111 | IF WS-VALID-MONTH |
| 112 | CONTINUE |
| 113 | ELSE |
| 114 | SET INPUT-ERROR TO TRUE |
| 115 | SET FLG-MONTH-NOT-OK TO TRUE |
| 116 | IF WS-RETURN-MSG-OFF |
| 117 | STRING |
| 118 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 119 | ': Month must be a number between 1 and 12.' |
| 120 | DELIMITED BY SIZE |
| 121 | INTO WS-RETURN-MSG |
| 122 | END-IF |
| 123 | GO TO EDIT-MONTH-EXIT |
| 124 | END-IF |
| 125 | |
| 126 | IF FUNCTION TEST-NUMVAL (WS-EDIT-DATE-MM) = 0 |
| 127 | COMPUTE WS-EDIT-DATE-MM-N |
| 128 | = FUNCTION NUMVAL (WS-EDIT-DATE-MM) |
| 129 | END-COMPUTE |
| 130 | ELSE |
| 131 | SET INPUT-ERROR TO TRUE |
| 132 | SET FLG-MONTH-NOT-OK TO TRUE |
| 133 | IF WS-RETURN-MSG-OFF |
| 134 | STRING |
| 135 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 136 | ': Month must be a number between 1 and 12.' |
| 137 | DELIMITED BY SIZE |
| 138 | INTO WS-RETURN-MSG |
| 139 | END-IF |
| 140 | GO TO EDIT-MONTH-EXIT |
| 141 | END-IF |
| 142 | |
| 143 | SET FLG-MONTH-ISVALID TO TRUE |
| 144 | . |
| 145 | EDIT-MONTH-EXIT. |
| 146 | EXIT |
| 147 | . |
| 148 | |
| 149 | |
| 150 | EDIT-DAY. |
| 151 | |
| 152 | SET FLG-DAY-ISVALID TO TRUE |
| 153 | |
| 154 | IF WS-EDIT-DATE-DD EQUAL LOW-VALUES |
| 155 | OR WS-EDIT-DATE-DD EQUAL SPACES |
| 156 | SET INPUT-ERROR TO TRUE |
| 157 | SET FLG-DAY-BLANK TO TRUE |
| 158 | IF WS-RETURN-MSG-OFF |
| 159 | STRING |
| 160 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 161 | ' : Day must be supplied.' |
| 162 | DELIMITED BY SIZE |
| 163 | INTO WS-RETURN-MSG |
| 164 | END-IF |
| 165 | GO TO EDIT-DAY-EXIT |
| 166 | ELSE |
| 167 | CONTINUE |
| 168 | END-IF |
| 169 | |
| 170 | IF FUNCTION TEST-NUMVAL (WS-EDIT-DATE-DD) = 0 |
| 171 | COMPUTE WS-EDIT-DATE-DD-N |
| 172 | = FUNCTION NUMVAL (WS-EDIT-DATE-DD) |
| 173 | END-COMPUTE |
| 174 | ELSE |
| 175 | SET INPUT-ERROR TO TRUE |
| 176 | SET FLG-DAY-NOT-OK TO TRUE |
| 177 | IF WS-RETURN-MSG-OFF |
| 178 | STRING |
| 179 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 180 | ':day must be a number between 1 and 31.' |
| 181 | DELIMITED BY SIZE |
| 182 | INTO WS-RETURN-MSG |
| 183 | END-IF |
| 184 | GO TO EDIT-DAY-EXIT |
| 185 | END-IF |
| 186 | |
| 187 | IF WS-VALID-DAY |
| 188 | CONTINUE |
| 189 | ELSE |
| 190 | SET INPUT-ERROR TO TRUE |
| 191 | SET FLG-DAY-NOT-OK TO TRUE |
| 192 | IF WS-RETURN-MSG-OFF |
| 193 | STRING |
| 194 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 195 | ':day must be a number between 1 and 31.' |
| 196 | DELIMITED BY SIZE |
| 197 | INTO WS-RETURN-MSG |
| 198 | END-IF |
| 199 | GO TO EDIT-DAY-EXIT |
| 200 | END-IF |
| 201 | . |
| 202 | |
| 203 | SET FLG-DAY-ISVALID TO TRUE |
| 204 | . |
| 205 | EDIT-DAY-EXIT. |
| 206 | EXIT |
| 207 | . |
| 208 | |
| 209 | EDIT-DAY-MONTH-YEAR. |
| 210 | ****************************************************************** |
| 211 | * Checking for any other combinations |
| 212 | ****************************************************************** |
| 213 | IF NOT WS-31-DAY-MONTH |
| 214 | AND WS-DAY-31 |
| 215 | SET INPUT-ERROR TO TRUE |
| 216 | SET FLG-DAY-NOT-OK TO TRUE |
| 217 | SET FLG-MONTH-NOT-OK TO TRUE |
| 218 | IF WS-RETURN-MSG-OFF |
| 219 | STRING |
| 220 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 221 | ':Cannot have 31 days in this month.' |
| 222 | DELIMITED BY SIZE |
| 223 | INTO WS-RETURN-MSG |
| 224 | END-IF |
| 225 | GO TO EDIT-DATE-CCYYMMDD-EXIT |
| 226 | END-IF |
| 227 | |
| 228 | IF WS-FEBRUARY |
| 229 | AND WS-DAY-30 |
| 230 | SET INPUT-ERROR TO TRUE |
| 231 | SET FLG-DAY-NOT-OK TO TRUE |
| 232 | SET FLG-MONTH-NOT-OK TO TRUE |
| 233 | IF WS-RETURN-MSG-OFF |
| 234 | STRING |
| 235 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 236 | ':Cannot have 30 days in this month.' |
| 237 | DELIMITED BY SIZE |
| 238 | INTO WS-RETURN-MSG |
| 239 | END-IF |
| 240 | GO TO EDIT-DATE-CCYYMMDD-EXIT |
| 241 | END-IF |
| 242 | |
| 243 | IF WS-FEBRUARY |
| 244 | AND WS-DAY-29 |
| 245 | IF WS-EDIT-DATE-YY-N = 0 |
| 246 | MOVE 400 TO WS-DIV-BY |
| 247 | ELSE |
| 248 | MOVE 4 TO WS-DIV-BY |
| 249 | END-IF |
| 250 | |
| 251 | DIVIDE WS-EDIT-DATE-CCYY-N |
| 252 | BY WS-DIV-BY |
| 253 | GIVING WS-DIVIDEND |
| 254 | REMAINDER WS-REMAINDER |
| 255 | |
| 256 | IF WS-REMAINDER = ZEROES |
| 257 | CONTINUE |
| 258 | ELSE |
| 259 | SET INPUT-ERROR TO TRUE |
| 260 | SET FLG-DAY-NOT-OK TO TRUE |
| 261 | SET FLG-MONTH-NOT-OK TO TRUE |
| 262 | SET FLG-YEAR-NOT-OK TO TRUE |
| 263 | IF WS-RETURN-MSG-OFF |
| 264 | STRING |
| 265 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 266 | ':Not a leap year.Cannot have 29 days in this month.' |
| 267 | DELIMITED BY SIZE |
| 268 | INTO WS-RETURN-MSG |
| 269 | END-IF |
| 270 | GO TO EDIT-DATE-CCYYMMDD-EXIT |
| 271 | END-IF |
| 272 | END-IF |
| 273 | |
| 274 | IF WS-EDIT-DATE-IS-VALID |
| 275 | CONTINUE |
| 276 | ELSE |
| 277 | GO TO EDIT-DATE-CCYYMMDD-EXIT |
| 278 | END-IF |
| 279 | . |
| 280 | EDIT-DAY-MONTH-YEAR-EXIT. |
| 281 | EXIT |
| 282 | . |
| 283 | |
| 284 | EDIT-DATE-LE. |
| 285 | ****************************************************************** |
| 286 | * In case some one managed to enter a bad date that passsed all |
| 287 | * the edits above ...... |
| 288 | * Use LE Services to verify the supplied date |
| 289 | ****************************************************************** |
| 290 | INITIALIZE WS-DATE-VALIDATION-RESULT |
| 291 | MOVE 'YYYYMMDD' TO WS-DATE-FORMAT |
| 292 | |
| 293 | 005100 CALL 'CSUTLDTC' |
| 294 | USING WS-EDIT-DATE-CCYYMMDD |
| 295 | , WS-DATE-FORMAT |
| 296 | , WS-DATE-VALIDATION-RESULT |
| 297 | |
| 298 | IF WS-SEVERITY-N = 0 |
| 299 | CONTINUE |
| 300 | ELSE |
| 301 | SET INPUT-ERROR TO TRUE |
| 302 | SET FLG-DAY-NOT-OK TO TRUE |
| 303 | SET FLG-MONTH-NOT-OK TO TRUE |
| 304 | SET FLG-YEAR-NOT-OK TO TRUE |
| 305 | IF WS-RETURN-MSG-OFF |
| 306 | STRING |
| 307 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 308 | ' validation error Sev code: ' |
| 309 | WS-SEVERITY |
| 310 | ' Message code: ' |
| 311 | WS-MSG-NO |
| 312 | DELIMITED BY SIZE |
| 313 | INTO WS-RETURN-MSG |
| 314 | END-IF |
| 315 | GO TO EDIT-DATE-LE-EXIT |
| 316 | END-IF |
| 317 | |
| 318 | IF NOT INPUT-ERROR |
| 319 | SET FLG-DAY-ISVALID TO TRUE |
| 320 | END-IF |
| 321 | . |
| 322 | |
| 323 | EDIT-DATE-LE-EXIT. |
| 324 | EXIT |
| 325 | . |
| 326 | * If we got here all edits were cleared |
| 327 | SET WS-EDIT-DATE-IS-VALID TO TRUE |
| 328 | . |
| 329 | EDIT-DATE-CCYYMMDD-EXIT. |
| 330 | EXIT |
| 331 | . |
| 332 | |
| 333 | ****************************************************************** |
| 334 | *Date of Birth Reasonableness check |
| 335 | ****************************************************************** |
| 336 | * At the time of writing this program |
| 337 | * Time travel was not possible. |
| 338 | * Date of birth in the future is not acceptable |
| 339 | ****************************************************************** |
| 340 | * |
| 341 | EDIT-DATE-OF-BIRTH. |
| 342 | |
| 343 | MOVE FUNCTION CURRENT-DATE TO WS-CURRENT-DATE-YYYYMMDD |
| 344 | |
| 345 | COMPUTE WS-EDIT-DATE-BINARY = |
| 346 | FUNCTION INTEGER-OF-DATE (WS-EDIT-DATE-CCYYMMDD-N) |
| 347 | COMPUTE WS-CURRENT-DATE-BINARY = |
| 348 | FUNCTION INTEGER-OF-DATE (WS-CURRENT-DATE-YYYYMMDD-N) |
| 349 | |
| 350 | IF WS-CURRENT-DATE-BINARY > WS-EDIT-DATE-BINARY |
| 351 | * IF FUNCTION FIND-DURATION(FUNCTION CURRENT-DATE |
| 352 | * ,WS-EDIT-DATE-CCYYMMDD) |
| 353 | * ,DAYS) > 0 |
| 354 | CONTINUE |
| 355 | ELSE |
| 356 | SET INPUT-ERROR TO TRUE |
| 357 | SET FLG-DAY-NOT-OK TO TRUE |
| 358 | SET FLG-MONTH-NOT-OK TO TRUE |
| 359 | SET FLG-YEAR-NOT-OK TO TRUE |
| 360 | IF WS-RETURN-MSG-OFF |
| 361 | STRING |
| 362 | FUNCTION TRIM(WS-EDIT-VARIABLE-NAME) |
| 363 | ':cannot be in the future ' |
| 364 | DELIMITED BY SIZE |
| 365 | INTO WS-RETURN-MSG |
| 366 | END-IF |
| 367 | GO TO EDIT-DATE-OF-BIRTH-EXIT |
| 368 | END-IF |
| 369 | . |
| 370 | EDIT-DATE-OF-BIRTH-EXIT. |
| 371 | EXIT |
| 372 | . |
| 373 | * |
| 374 | * Ver: CardDemo_v1.0-15-g27d6c6f-68 Date: 2022-07-19 23:15:59 CDT |
| 375 | * |