home *** CD-ROM | disk | FTP | other *** search
/ Sams Cobol 24 Hours / Sams_Cobol_24_Hours.iso / source / ch13 / CHAPT13F.COB < prev    next >
Encoding:
Text File  |  1998-09-15  |  3.7 KB  |  106 lines
  1. 000010 @OPTIONS MAIN
  2. 000020 Identification Division.
  3. 000030 Program-Id.  Chapt13f.
  4. 000031* Update Example
  5. 000043 Environment Division.
  6. 000050 Configuration Section.
  7. 000051 Special-Names.
  8. 000052       Crt Status Is Keyboard-Status.
  9. 000054 Source-Computer.  IBM-PC.
  10. 000055 Object-Computer.  IBM-PC.
  11. 000056 Input-Output  Section.
  12. 000059 File-Control.
  13. 000060     Select Optional Name-File Assign To "NAMES.SEQ"
  14. 000061         Organization Is Sequential
  15. 000062         File Status  Is Name-File-Status.
  16. 000065 Data Division.
  17. 000066 File Section.
  18. 000067 Fd  Name-File.
  19. 000068 01  Name-Record           Pic X(30).
  20. 000070 Working-Storage Section.
  21. 000071 01  Full-Name             Pic X(30) Value Spaces.
  22. 000073 01  Keyboard-Status.
  23. 000074     03  Accept-Status     Pic 9.
  24. 000075     03  Function-Key      Pic X.
  25. 000076         88 F1-Pressed     Value X"01".
  26. 000077         88 F2-Pressed     Value X"02".
  27. 000078     03  System-Use        Pic X.
  28. 000080 01  File-Error-Flag       Pic X Value Space.
  29. 000081     88  File-Error        Value "Y".
  30. 000082 01  Name-File-Status      Pic XX Value Spaces.
  31. 000083     88  Name-File-Success Value "00" "05".
  32. 000088     88  End-Of-File       Value "10".
  33. 000089 01  Error-Message         Pic X(50) Value Spaces.
  34. 000090 Screen Section.
  35. 000091 01  Name-Entry Blank Screen.
  36. 000092     03  Line 01 Column 01 Value " Enter Name: ".
  37. 000093     03  Line 01 Column 14 Pic X(30) Using Full-Name.
  38. 000094     03  Line 05 Column 01 Pic X(50) From Error-Message.
  39. 000095     03  Line 20 Column 01
  40. 000096         Value "Press F1 to Exit    Press F2 to Update".
  41. 000098 Procedure Division.
  42. 000159 Chapt13f-Start.
  43. 000160     Perform Open-File
  44. 000161     If Not File-Error
  45. 000162        Perform Process-File Until F1-Pressed Or
  46. 000163                                   File-Error Or
  47. 000164                                   End-Of-File
  48. 000165        Perform Close-File
  49. 000166     End-If
  50. 000167     Stop Run
  51. 000168     .
  52. 000177 Open-File.
  53. 000187     Open I-O Name-File
  54. 000197     If Not Name-File-Success
  55. 000207        Move Spaces To Error-Message
  56. 000217        String "Open Error " Name-File-Status
  57. 000227               Delimited By Size
  58. 000237               Into Error-Message
  59. 000247        Perform Display-And-Accept-Error
  60. 000257     End-If
  61. 000267     .
  62. 000277 Process-File.
  63. 000287     Move Spaces To Full-Name
  64. 000288     Perform Read-File
  65. 000289     If Not File-Error
  66. 000290        Display Name-Entry
  67. 000297        Accept Name-Entry
  68. 000298        Move Spaces To Error-Message
  69. 000299        If F2-Pressed And Not End-Of-File
  70. 000300           Perform Rewrite-Record
  71. 000301        End-If
  72. 000304     End-If
  73. 000317     .
  74. 000327 Read-File.
  75. 000337     Read Name-File Into Full-Name
  76. 000338          At End Move "End Of File" To Error-Message
  77. 000339     End-Read
  78. 000340     If Name-File-Success Or End-Of-File
  79. 000341        Continue
  80. 000342     Else
  81. 000343        Move Spaces To Error-Message
  82. 000344        String "Read Error " Name-File-Status
  83. 000345           Delimited By Size Into Error-Message
  84. 000346        End-String
  85. 000347        Perform Display-And-Accept-Error
  86. 000348     End-If
  87. 000349     .
  88. 000355 Rewrite-Record.
  89. 000365     Rewrite Name-Record From Full-Name
  90. 000366     If Name-File-Success
  91. 000367        Move "Prior Record Updated" To Error-Message
  92. 000368     Else
  93. 000375        Move Spaces To Error-Message
  94. 000395        String "Rewrite Error " Name-File-Status
  95. 000405          Delimited By Size Into Error-Message
  96. 000415        End-String
  97. 000417     End-If
  98. 000418     .
  99. 000427 Display-And-Accept-Error.
  100. 000428     Set File-Error To True
  101. 000437     Display Name-Entry
  102. 000447     Accept Name-Entry
  103. 000457     .
  104. 000467 Close-File.
  105. 000477     Close Name-File
  106. 000487     .
  107.