home *** CD-ROM | disk | FTP | other *** search
/ Sams Cobol 24 Hours / Sams_Cobol_24_Hours.iso / source / ch21 / CHAPT21E.COB < prev    next >
Text File  |  1998-09-14  |  4KB  |  83 lines
  1. 000010 @OPTIONS MAIN,TEST
  2. 000020 Identification Division.
  3. 000030 Program-Id.  Chapt21e.
  4. 000031* Validate A Date
  5. 000040 Environment Division.
  6. 000050 Configuration Section.
  7. 000051 Source-Computer.  IBM-PC.
  8. 000055 Object-Computer.  IBM-PC.
  9. 000056 Data Division.
  10. 000057 Working-Storage Section.
  11. 000058 01  Date-Validation-Work-Fields.
  12. 000059     03  Date-To-Validate      Pic 9(8) Value Zeros.
  13. 000060     03  Date-To-Validate-X Redefines Date-To-Validate.
  14. 000061         05  Date-MM           Pic 99.
  15. 000062         05  Date-DD           Pic 99.
  16. 000063         05  Date-YYYY         Pic 9(4).
  17. 000069     03  YYYYMMDD-Format-Date  Pic 9(8) Value Zeros.
  18. 000078     03  YYYYMMDD-Format-Date-X Redefines YYYYMMDD-Format-Date.
  19. 000079         05  Date-YYYY         Pic 9(4).
  20. 000080         05  Date-MM           Pic 99.
  21. 000081         05  Date-DD           Pic 99.
  22. 000092     03  Day-Table-Values      Pic X(24) Value
  23. 000093         "312831303130313130313031".
  24. 000094     03  Day-Table Redefines Day-Table-Values.
  25. 000095         05  Days-In-Month     Pic 99   Occurs 12 Times.
  26. 000097 01  Valid-Status          Pic X(40) Value Spaces.
  27. 000099 01  Work-Number           Pic 9(5) Value Zeros.
  28. 000100 01  Work-Remainder        Pic 9(5) Value Zeros.
  29. 000101 01  Work-Remainder-100    Pic 9(5) Value Zeros.
  30. 000102 01  Work-Remainder-400    Pic 9(5) Value Zeros.
  31. 000103 01  Today-Date            Pic 9(8) Value Zeros.
  32. 000104 01  Today-Integer         Pic 9(7) Value Zeros.
  33. 000105 01  Test-Integer          Pic 9(7) Value Zeros.
  34. 000106 01  Test-Range            Pic 9(7) Value Zeros.
  35. 000107 Screen Section.
  36. 000108 01  Date-Entry Blank Screen Auto.
  37. 000109     03  Line 01 Column 01 Value "Enter Date: ".
  38. 000110     03  Line 01 Column 13 Pic 99/99/9999 Using Date-To-Validate.
  39. 000111     03  Line 01 Column 24 Pic X(40) From Valid-Status.
  40. 000112 Procedure Division.
  41. 000159 Chapt21e-Start.
  42. 000169     Display Date-Entry
  43. 000179     Accept Date-Entry
  44. 000199     Divide Date-YYYY Of Date-To-Validate-X By 4
  45. 000200            Giving Work-Number Remainder
  46. 000201                   Work-Remainder
  47. 000202     Divide Date-YYYY Of Date-To-Validate-X By 100
  48. 000203            Giving Work-Number Remainder
  49. 000204                   Work-Remainder-100
  50. 000205     Divide Date-YYYY Of Date-To-Validate-X By 400
  51. 000206            Giving Work-Number Remainder
  52. 000207                   Work-Remainder-400
  53. 000209     If Work-Remainder = Zeros And
  54. 000210        (Work-Remainder-100 Not = Zeros Or
  55. 000211         Work-Remainder-400 = Zeros)
  56. 000212           Move 29 To Days-In-Month (2)
  57. 000213     Else
  58. 000214           Move 28 To Days-In-Month (2)
  59. 000215     End-If
  60. 000217     If Date-MM Of Date-To-Validate-X  > 12 Or
  61. 000218        Date-MM Of Date-To-Validate-X  < 01 Or
  62. 000219        Date-YYYY Of Date-To-Validate-X < 1601 Or
  63. 000220        Date-DD Of Date-To-Validate-X Not > Zero Or
  64. 000221        Date-DD Of Date-To-Validate-X >
  65. 000222        Days-In-Month (Date-MM Of Date-To-Validate-X)
  66. 000223        Move "Invalid Date" To Valid-Status
  67. 000224     End-If
  68. 000235     If Valid-Status = Spaces
  69. 000236        Move Corresponding Date-To-Validate-X To
  70. 000237                           YYYYMMDD-Format-Date-X
  71. 000238        Move Function Current-Date (1:8) To Today-Date
  72. 000239        Compute Test-Range =
  73. 000240                Function Integer-Of-Date (YYYYMMDD-Format-Date) -
  74. 000242                Function Integer-Of-Date (Today-Date)
  75. 000246        If Test-Range > 30
  76. 000247           Move "Date Valid, but out of Range" To Valid-Status
  77. 000248        End-If
  78. 000249     End-If
  79. 000250     If Valid-Status = Spaces
  80. 000251        Move "Date Valid and Within Range" To Valid-Status
  81. 000252     End-If
  82. 000253     Display Date-Entry
  83. 000255     .