home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Power-Programmierung
/
CD1.mdf
/
cobol
/
library
/
assist
/
soc7.cbl
< prev
Wrap
Text File
|
1993-12-08
|
9KB
|
230 lines
000100$SET ANS85 NOOSVS MF
000200
000300 IDENTIFICATION DIVISION.
000400 PROGRAM-ID. SOC7.
000500 AUTHOR. GEORGE HARRIS.
000600
000700************************** SOC7.CBL ********************************
000710** Copyright 1993 George F. Harris
000720**
000800** THIS IS A GENERIC HELP SCREEN WHICH GIVES AN OVERVIEW OF THE
000900** PROGRAM ASSIST.EXE.
001000**
001100** THIS PROGRAM IS CALLED IF THE F1 HELP KEY IS USED WHEN THERE IS
001200** NO FILE STATUS CODE YET CHOSEN.
001770********************************************************************
001780 ENVIRONMENT DIVISION.
001790 CONFIGURATION SECTION.
001791**********************
001792* special names section CRT Status identifies exact usage of
001793* -cursor position a function key and th number of the
001794* - crt status key used.
001795**********************
001796 SPECIAL-NAMES.
001797 cursor is cursor-position
001798 crt status is key-status.
001799 DATA DIVISION.
001800 WORKING-STORAGE SECTION.
001801****************************
001802* messages
001805****************************
001806 01 MSG-X PIC X(80) VALUE SPACES.
001811****************************
001812* key to determine if program
001813* runs stand-alone or as a
001814* part of ABEND.EXE
001815****************************
001816 01 HELP-ME PIC X VALUE "E".
001817 01 TOPIC-SELECT PIC 99 VALUE ZEROS.
001819****************************
001820* SWITCHES AND COUNTERS
001821****************************
001829*************************
001830* cursor position fields allows positioning of cursor
001831*************************
001832 01 cursor-position.
001833 05 cursor-row pic 99 value zeros.
001834 05 cursor-column pic 99 value zeros.
001835*********************************************************************
001836** CRT STATUS KEYS
001837*********************************************************************
001838************************
001839* fields used to get a CALL X"AF" USING get-single-char
001840* single character with key-status
001841* call x"af" using Allows a single key from the keyboard
001842* command Holds action until key is pressed
001843************************
001844 01 Get-single-char pic 9(2) comp-x value 26.
001845 01 key-status.
001846 05 key-type pic x.
001847 05 key-code-1 pic 9(2) comp-x.
001848 05 key-code-2 pic 9(2) comp-x.
001849**********************************************************************
001850** The following fields are used with the call x"af" function to
001851** enable or disable various function and user keys
001852**********************************************************************
001853************************
001854* fields used to enable/
001855* disable adis messages, CALL X"AF" USING set-bit-pairs
001856* indicators and displays parameter-block
001857* using call x"af" command
001858************************
001859 01 set-bit-pairs pic 9(2) comp-x value 1.
001860 01 parameter-block.
001861 05 bit-pair-setting pic 9(2) comp-x.
001862 05 filler pic x value "2".
001863 05 bit-pair-number pic 9(2) comp-x.
001864 05 filler pic 9(2) comp-x value 1.
001865************************
001866* fields used to enable/
001867* disable function keys, CALL X"AF" USING set-bit-pairs-1
001868* using call x"af" command user-key-control
001869************************
001870 01 set-bit-pairs-1 pic 9(2) comp-x value 1.
001871 01 user-key-control.
001872 05 user-key-setting pic 9(2) comp-x.
001873 05 filler pic x value "1".
001874 05 first-user-key pic 9(2) comp-x.
001875 05 number-of-keys pic 9(2) comp-x.
001876**************************
001877* changes the key mapping CALL X"AF' USING set-map-byte
001878* from within the program ADIS-key-mapping
001879* using call x"af" using
001880* command
001881**************************
001882 01 set-map-byte pic 9(2) comp-x.
001883 01 adis-key-mapping.
001884 05 adis-mapping-byte pic 9(2) comp-x.
001885 05 adis-key-number pic 9(2) comp-x.
001886**********************************************************************
001887** SCREEN DISPLAY
001888**********************************************************************
001889 SCREEN SECTION.
001890 01 GENERAL-HELP-SCREEN.
001891 05 background-color 1 foreground-color 4.
001892 05 blank screen.
001893 05 line 1 col 29 value "WHAT ASSIST.EXE DOES".
001897 05 line 3 col 1 value
001898 "ASSIST.EXE allows you to get a simple description of File Re
001899- "turn Codes, or to ".
001900 05 line 4 col 1 value
001901 "see a more detailed explanation by choosing the proper FUNC
001902- "TION KEY. ".
001903 05 line 6 col 1 value
001904 "When ASSIST.EXE comes onto your screen, enter the two digit
001905- " FILE STATUS CODE at".
001906 05 line 7 col 1 value
001907 "the prompt and choose FUNCTION KEY F2. A one line explanat
001908- "ion of the meaning".
001909 05 line 8 col 1 value
001910 "of that File Status Code will appear on the screen. "
001911- .
001912 05 line 10 col 1 value
001913 "If you wish to see a more extensive explanation, choose FUN
001914- "TION KEY F1 and you".
001918 05 line 11 col 1 value
001919 "will see more detail as to the meaning of the File Status Co
001920- "de you have chosen. ".
001921 05 line 13 col 1 value
001922 "The File Status Codes supported in this program are standa
001923- "rd two digit codes.".
001924 05 line 14 col 1 value
001925 "VAX and IBM COBOL II codes are also supported, although, thi
001926- "s program does not".
001929 05 line 15 col 1 value
001930 "at this time support a BINARY redefinition of the File Statu
001931- "s Code, or the three".
001932 05 line 16 col 1 value
001933 "level definition (RETURN/FUNCTION/FEEDBACK CODES) which are
001934- "available for VSAM".
001935 05 line 17 col 1 value
001936 "files on an IBM 370/390 System. ".
001958 05 LINE 24 COL 1 PIC X(80) FROM MSG-X highlight.
001960 05 line 25 col 1 value
001961 " F1 MAIN MENU F10 QUIT TO DOS".
001965 01 BLANK-SCREEN.
001966 05 background-color 1 foreground-color 4.
001967 05 blank screen.
001980 PROCEDURE DIVISION.
001981 PERFORM 010-ENABLE.
001982 PERFORM 100-GET-SCREEN.
001983 010-ENABLE.
001984************************
001985*ENABLES FUNCITON KEYS
001986*F-1 THROUGH F-10
001987************************
001988 MOVE 1 TO USER-KEY-SETTING.
001989 MOVE 1 TO FIRST-USER-KEY.
001990 MOVE 10 TO NUMBER-OF-KEYS.
001992 CALL X"AF" USING SET-BIT-PAIRS-1
001993 USER-KEY-CONTROL.
001994
001995 100-GET-SCREEN.
001996***********************
001997* sets color of screen
001998***********************
001999 DISPLAY " " AT 0101
002000 upon CRT
002001 erase
002002 with
002003 foreground-color is 7
002004 background-color is 1.
002005***********************
002006* gets main screen
002007***********************
002008 MOVE 1 TO CURSOR-ROW.
002009 MOVE 1 TO CURSOR-POSITION.
002010 DISPLAY GENERAL-HELP-SCREEN.
002011**********************
002012* holds action until a
002013* keystroke
002014**********************
002015 CALL X"AF" USING GET-SINGLE-CHAR
002016 KEY-STATUS.
002017************************
002018* Sets up function keys
002019************************
002020 IF KEY-CODE-1 = 1
002021 PERFORM 200-GOBACK
002022 ELSE
002023 IF KEY-CODE-1 = 2
002024 MOVE "INVALID KEY" TO MSG-X
002025 PERFORM 100-GET-SCREEN
002026 ELSE
002027 IF KEY-CODE-1 = 3
002028 MOVE "INVALID KEY" TO MSG-X
002029 PERFORM 100-GET-SCREEN
002030 ELSE
002031 IF KEY-CODE-1 = 4
002032 MOVE "INVALID KEY" TO MSG-X
002033 PERFORM 100-GET-SCREEN
002034 ELSE
002035 IF KEY-CODE-1 = 5
002036 MOVE "INVALID KEY" TO MSG-X
002037 PERFORM 100-GET-SCREEN
002038 ELSE
002039 IF KEY-CODE-1 = 6
002040 MOVE "INVALID KEY" TO MSG-X
002041 PERFORM 100-GET-SCREEN
002042 ELSE
002043 IF KEY-CODE-1 = 7
002044 MOVE "INVALID KEY" TO MSG-X
002045 PERFORM 100-GET-SCREEN
002046 ELSE
002047 IF KEY-CODE-1 = 8
002048 MOVE "INVALID KEY" TO MSG-X
002049 PERFORM 100-GET-SCREEN
002050 ELSE
002051 IF KEY-CODE-1 = 9
002052 MOVE "INVALID KEY" TO MSG-X
002053 PERFORM 100-GET-SCREEN
002054 ELSE
002062 IF KEY-CODE-1 = 10
002063 DISPLAY BLANK-SCREEN
002064 PERFORM 999-ENDER.
002083 200-GOBACK.
002084 CHAIN "ABEND2.EXE".
002210 999-ENDER.
002300 DISPLAY BLANK-SCREEN.
002400 STOP RUN.