home *** CD-ROM | disk | FTP | other *** search
/ Sams Cobol 24 Hours / Sams_Cobol_24_Hours.iso / source / ch13 / CHAPT13C.COB < prev    next >
Encoding:
Text File  |  1998-09-15  |  3.0 KB  |  85 lines
  1. 000010 @OPTIONS MAIN
  2. 000020 Identification Division.
  3. 000030 Program-Id.  Chapt13c.
  4. 000031* File Creation Example Using Write ... From, Open Extend
  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.TXT"
  14. 000061         Organization Is Line 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     03  System-Use        Pic X.
  27. 000078 01  File-Error-Flag       Pic X Value Space.
  28. 000079     88  File-Error        Value "Y".
  29. 000080 01  Name-File-Status      Pic XX Value Spaces.
  30. 000081     88  Name-File-Success Value "00" "05".
  31. 000088 01  Error-Message         Pic X(50) Value Spaces.
  32. 000089 Screen Section.
  33. 000090 01  Name-Entry Blank Screen.
  34. 000091     03  Line 01 Column 01 Value " Enter Name: ".
  35. 000092     03  Line 01 Column 14 Pic X(30) Using Full-Name.
  36. 000094     03  Line 05 Column 01 Pic X(50) From Error-Message.
  37. 000095     03  Line 20 Column 01 Value "Press F1 to Exit".
  38. 000098 Procedure Division.
  39. 000159 Chapt13c-Start.
  40. 000160     Perform Open-File
  41. 000161     If Not File-Error
  42. 000162        Perform Process-Input Until F1-Pressed Or
  43. 000163                                    File-Error
  44. 000164        Perform Close-File
  45. 000165     End-If
  46. 000166     Stop Run
  47. 000167     .
  48. 000177 Open-File.
  49. 000187     Open Extend Name-File
  50. 000197     If Not Name-File-Success
  51. 000207        Move Spaces To Error-Message
  52. 000217        String "Open Error " Name-File-Status
  53. 000227               Delimited By Size
  54. 000237               Into Error-Message
  55. 000247        Perform Display-And-Accept-Error
  56. 000257     End-If
  57. 000267     .
  58. 000277 Process-Input.
  59. 000287     Move Spaces To Full-Name
  60. 000288     Display Name-Entry
  61. 000297     Accept Name-Entry
  62. 000298     Move Spaces To Error-Message
  63. 000299     If Not F1-Pressed
  64. 000307        Perform Write-Record
  65. 000308     End-If
  66. 000317     .
  67. 000327 Write-Record.
  68. 000337     Write Name-Record From Full-Name
  69. 000338     If Name-File-Success
  70. 000339        Move "Record Written" To Error-Message
  71. 000340     Else
  72. 000357        String "Write Error " Name-File-Status
  73. 000367               Delimited By Size
  74. 000377               Into Error-Message
  75. 000387        Perform Display-And-Accept-Error
  76. 000397     End-If
  77. 000407     .
  78. 000417 Display-And-Accept-Error.
  79. 000427     Set File-Error To True
  80. 000437     Display Name-Entry
  81. 000447     Accept Name-Entry
  82. 000457     .
  83. 000467 Close-File.
  84. 000477     Close Name-File
  85. 000487     .
  86.