Trailing-Edge
-
PDP-10 Archives
-
decuslib20-03
-
decus/20-0081/tpdemo.cbl
There is 1 other file named tpdemo.cbl in the archive. Click here to see a list.
IDENTIFICATION DIVISION.
PROGRAM-ID. TPDEMO.
DATE-WRITTEN. 19-APR-74.
DATE-COMPILED.
REMARKS. THIS IS A MULTI-USER COBOL -DEMO- TO BE USED WITH
THE TRANSACTION PROCESSOR (TP.MAC).
IT ALSO ILLUSTRATES THE USE OF AN "UNSTRING" ROUTINE WHICH BREAKS UP
A STRING OF CHARACTERS INTO FIELDS USING COMMAS
AS FIELD DELIMITERS.
DATA DIVISION.
WORKING-STORAGE SECTION.
77 HOLD-MM PIC 9(2).
01 DATE-TIME.
02 YY PIC 99.
02 MO PIC 99.
02 DD PIC 99.
02 HH PIC 99.
02 MM PIC 99.
02 SS PIC 99.
01 MISC.
03 A PIC S9(8)V99.
03 A-R REDEFINES A PIC X(11).
03 B PIC S9(8)V99.
03 B-R REDEFINES B PIC X(11).
03 C PIC S9(8)V99.
03 C-R REDEFINES C PIC X(11).
03 D PIC S9(8)V99 COMP.
**
** IN-LINE IS ANSWER RETURNED FROM USERS TERMINAL
**
01 IN-LINE.
02 IL-1-6.
03 IL-1-2 PIC X(2).
03 IL-3-6 PIC X(4).
02 FILLER PIC X(69).
*************************************************************
**
******************** FOR TRANSACTION PROCESSOR **************
**
** DO NOT CHANGE FROM HERE TO NEXT "***" LINE
** [EXCEPT FOR OCCURS VALUES]
**
*************************************************************
01 MORE-TO-COME PIC X USAGE IS DISPLAY-7.
01 LINES-OUT PIC S9(2) COMP.
01 I-O-TTY PIC S9(3) COMP VALUE 1.
01 OUT-STRING USAGE IS DISPLAY-7.
02 OUT-LINE OCCURS 12 TIMES.
03 OL-1-74 PIC X(74).
03 OL-CARRIAGE-CTL PIC X.
01 USER-TABLES.
02 USER-TABLE OCCURS 12 TIMES.
*****************************************************************
**
************ END FIXED AREA FOR TRANSACTION PROCESSOR ***********
**
**
** HAVE THE NUMBER OF OCCURANCES OF THE TABLE ONE
** MORE THAN THE # OF USERS SINCE THE FIRST
** OCCURANCE OF THE ARRAY IS USED AS A WORK AREA,
** THEREBY ALLOWING DIRECT SUBSCRIPTING. THE
** APPROPRIATE ENTRY IN THE ARRAY IS "ROLLED" INTO
** ENTRY 1 EACH TIME A MESSAGE IS PICKED UP AND "ROLLED"
** OUT BEFORE A MESSAGE IS SENT.
** FROM HERE TO THE NEXT "***" LINE IS THE VARIABLE
** AREA FOR EACH TERMINAL CONNECTED .
**
** ADD ALL YOUR TERMINAL DEPENDENT VARIABLES BELOW
** AS 03 LEVELS OR GREATER
**
****************************************************************
03 LOGIN-TRIES PIC 9.
03 LOGGED-IN PIC X.
03 LAST-MINUTE PIC 9(2).
03 LINES-TO-PRINT PIC S9(10) COMP.
03 LINES-LEFT-THIS-BURST PIC S9(10) COMP.
03 LINES-PER-BURST PIC S9(10) COMP.
03 CURRENT-LINE PIC S9(10) COMP.
*****************************************************************
**
************** END VARIABLE AREA FOR EACH TERMINAL **************
**
****************************************************************
***************************************************************
**
** MESSAGE LINES FOR USER TERMINALS MUST BE FORMATTED IN
** WORKING STORAGE SINCE DISPLAYS CANNOT BE USED. DISPLAYS
** WILL GO TO THE LOG FILE.
**
**************************************************************
01 DATE-MESSAGE DISPLAY-7.
02 FILLER PIC X(6) VALUE "DATE: ".
02 DM-MO PIC 9(2).
02 FILLER PIC X VALUE "-".
02 DM-DD PIC 9(2).
02 FILLER PIC X VALUE "-".
02 DM-YY PIC 9(2).
02 FILLER PIC X(9) VALUE " TIME: ".
02 DM-HH PIC 9(2).
02 FILLER PIC X VALUE ":".
02 DM-MM PIC 9(2).
01 DUMMY-LINE USAGE IS DISPLAY-7.
02 FILLER PIC X(6) VALUE "LINE #".
02 DUMMY-LINE-NO PIC ZZ9.
02 FILLER PIC X(18) VALUE " - DEMO MULTI-USER".
01 ADD-ANSWER-LINE USAGE IS DISPLAY-7.
03 FILLER PIC X(14)
VALUE "YOUR TOTAL IS ".
03 ADD-ANSWER PIC Z(8).99-.
******************************************************************
**
** SINCE ACCEPTS CANNOT BE USED IN CONNECTION WITH USER
** TERMINALS, THE INCOMING MESSAGE STRING MAY
** HAVE TO BE BROKEN UP INTO A NUMBER OF FIELDS.
** THE WORKING STORAGE ELEMENTS NECESSARY FOR THE UNSTRING
** ROUTINE BEGINS HERE.
**
******************************************************************
01 BREAK-UP.
*
* ** THE BREAK UP ARRAY IS USED TO PASS DATA TO AND
* ** GET DATA FROM THE UNSTRING ROUTINE.
* ** IT BREAKS A STRING OF CHARACTERS
* ** UP INTO THE APPROPRIATE NUMBER OF DATA FIELDS
* ** WHERE COMMAS ARE USED AS FIELD DELIMITERS.
* ** ITS ELEMENTS ARE:
* ** BU-NOFLDS THE NUMBER OF FIELDS TO BE BROKEN UP (MAX 7).
* ** BU-LGTH THE LENGTH OF EACH FIELD (MAX 35).
* ** BU-TYP THE TYPE OF EACH FIELD - ALPHA (A) OR NUMERIC (N).
* ** BU-JUST JUSTIFICATION (RIGHT (R) OR
* ** LEFT (L)) OF EACH FIELD - DEFAULT
* ** ON ALPHA FIELDS IS LEFT - NUMERIC
* ** FIELDS ARE ALWAYS RIGHT.
* ** BU-DEC NUMBER OF DECIMALS IN NUMERIC
* ** FIELDS - NOT USED FOR ALPHA FIELDS.
* ** BU-ANSWER PLACE WHERE BROKEN UP FIELD IS
* ** PUT. NUMERIC FIELDS ARE INITIALIZED
* ** TO ZEROS, ALPHA FIELDS TO SPACES.
* ** THE LAST CHARACTER OF BU-ANSWER IS USED AS AN
* ** ERROR FLAG WHERE:
* ** A - RIGHT TRUNCATION ON LEFT JUSTIFIED ALPHA
* ** B - LEFT TRUNCATION ON RIGHT JUSTIFIED
* ** ALPHA OR NUMERIC
* ** C - RIGHT TRUNCATION ON DECIMAL PART OF NUMBER
* ** D - RIGHT TRUNCATION ON RIGHT JUSTIFIED
* ** ALPHA OR NUMERIC WHEN MOVING TO TEMP FIELD
* ** BU-STOR TEMPORARY WORK AREA FOR RIGHT JUSTIFIED FIELDS
*
03 BU-NOFLDS PICTURE 9.
03 FILLER OCCURS 7.
04 BU-ARRAY.
05 BU-LGTH PICTURE 99.
05 BU-TYP PICTURE X.
05 BU-JUST PICTURE X.
05 BU-DEC PICTURE 9.
04 FILLER.
05 BU-ANSWER.
07 BU-ANS PIC X OCCURS 36 TIMES.
03 BU-STOR PICTURE X OCCURS 35.
03 CH-COMMA PICTURE X VALUE ",".
*
* ** THE STRING OF CHARACTERS TO BE BROKEN UP MUST BE IN IMA-DATA
*
01 IMA-DATA.
03 IMA-ARRAY PICTURE X OCCURS 72 TIMES.
01 INDEXES.
*
* ** INDEX1 IS USED TO SUBSCRIPT THRU THE INPUT DATA ARRAY (IMA-ARRAY)
*
03 INDEX1 INDEX.
*
* ** INDEX2 IS USED TO SUBSCRIPT THRU THE OUTPUT DATA FIELD ARRAY (BU-ANS)
* ** WHEN MOVING LEFT JUSTIFIED FIELDS TO THE OUTPUT
* ** DATA AREA OR RIGHT JUSTIFIED FIELDS TO THE TEMPORARY AREA
*
03 INDEX2 INDEX.
*
* ** INDEX3 IS USED TO REFER TO THE NUMBER OF THE DATA FIELD
* ** CURRENTLY BEING WORKED ON (BU-LGTH, BU-TYP, BU-JUST, BU-DEC, BU-ANSWER)
*
03 INDEX3 INDEX.
*
* ** INDEX4 IS USED TO SUBSCRIPT THRU THE TEMPORARY WORK AREA (BU-STOR)
*
03 INDEX4 INDEX.
*
* ** INDEX5 IS USED AS THE SUBSCRIPT IN THE OUTPUT DATA FIELD
* ** (BU-ANS) WHEN MOVING RIGHT JUSTIFIED FIELDS FROM
* ** THE TEMPORARY AREA TO THE OUTPUT DATA AREA
*
03 INDEX5 INDEX.
**********************************************************
**
** END WORKING STORAGE ELEMENTS FOR UNSTRING ROUTINE
**
**********************************************************
PROCEDURE DIVISION.
*ONLY SECTION.
BEGIN.
*****************************************************************
**
************** DO ALL INITALIZATION FUNCTIONS HERE ************
**
** [OPEN FILES / BUILD TABLES ETC.]
**
** WHEN INITALIZATION IS DONE GO TO ENTER-MACRO.
**
*****************************************************************
GO TO ENTER-MACRO.
*****************************************************************
**
**************** BEGIN FIXED PROCEDURE DIVISION *****************
**
** THE ONLY THING THAT MAY CHANGE BETWEEN HERE AND
** THE END OF FIXED PROCEDURE DIVISION IS THE NUMBER
** OF "START" ENTRIES IN THE GO TO DEPENDING ON - -
**
** THE TOTAL NUMBER OF "START" ENTRIES + 1 (FOR WRAP-UP)
** MUST EQUAL THE NUMBER OF OCCURS IN USER-TABLE IN THIS
** PROGRAM, AND MAXTTY + 1 IN TP.MAC
**
*****************************************************************
**
** IF A CONTROL C IS TYPED AT A USER TERMINAL THE
** TRANSACTION PROCESSOR WILL SEND THE USER TO HERE FOR THE
** COBOL PROGRAM TO PROCESS APPROPRIATELY
**
CONTROL-C-DISPATCH.
GO TO 1000-PROCESS-CONTROL-C.
**
** THIS IS THE PARAGRAPH THAT IS "ALTERED" BEFORE SENDING
** OUT A MESSAGE TO A USER. IT WILL INDICATE WHAT PARAGRAPH TO
** BEGIN WITH WHEN THE RESPONSE IS RECEIVED FROM THIS USER.
**
DISPATCHER.
GO TO DISPATCHER.
ENTER-MACRO.
**
** THIS ROLLS OUT THE WORK TABLE BACK TO WHERE IT BELONGS.
**
MOVE USER-TABLE(1) TO USER-TABLE(I-O-TTY).
**
** THE ENTER MACRO WILL SEND THE MESSAGE IN THE OUTPUT MESSAGE
** AREA TO THE APPROPRIATE USER AND PICK UP A MESSAGE
** FROM ANOTHER USER.
**
ENTER MACRO TP USING LINES-OUT, OUT-STRING, I-O-TTY.
**
** INITIALIZE COUNT OF LINES TO SEND
**
MOVE ZERO TO LINES-OUT.
**
** THIS "ROLLS" IN THE APPROPRIATE USER TABLE TO THE WORK TABLE
**
MOVE USER-TABLE(I-O-TTY) TO USER-TABLE(1).
**
** MOVE INCOMING MESSAGE TO WORK AREA
**
MOVE OUT-LINE(1) TO IN-LINE.
GO TO WRAP-UP START START START START
START START START START START
START START DEPENDING ON I-O-TTY.
DISPLAY "?? TRANSACTION PROCESSOR HAS MORE TTY'S THAN COBOL PROGRAM - -".
DISPLAY "?? CALL APPLICATIONS PROGRAMMER".
STOP RUN.
*************************************************************
**
** END FIXED PROCEDURE DIVISION AREA FOR T/P
**
*************************************************************
***************************************************************
**
** IN PLACE OF A DISPLAY AND ACCEPT SEQUENCE YOU SEND
** AND RECEIVE MESSAGES TO A USER IN THE FOLLOWING MANNER:
**
** 1. IF NECESSARY FILL A WORKING STORAGE FORMATTED MESSAGE
** WITH DATA.
**
** 2. INCREMENT THE COUNT OF LINES TO SEND TO USER (LINES-OUT).
** THIS CAN BE USED AS A SUBSCRIPT FOR THE OUTPUT ARRAY,
** HOWEVER, DIRECT SUBSCRIPTING SHOULD BE USED WHEREVER POSSIBLE.
**
** 3. MOVE MESSAGE FOR USER TO THE OUTPUT ARRAY (OUT-LINE).
**
** 4. IF THERE ARE MORE LINES TO GO TO THE USER BEFORE HE
** INPUTS A MESSAGE SET THE MORE-TO-COME SWITCH TO "Y"
** OTHERWISE LEAVE IT BLANK.
**
** 5. IF YOU WANT THE CARRIAGE RETURN /LINE FEED
** WHICH WOULD NORMALLY FOLLOW AN OUTPUT MESSAGE
** LINE SUPPRESSED SET OL-CARRIAGE-CTL (1) TO "N"
** OTHERWISE LEAVE IT BLANK.
**
** 6. ALTER DISPATCHER TO PROCEED TO THE PARAGRAPH NAME
** TO PROCESS THE USERS RESPONSE.
**
** 7. GO TO ENTER MACRO.
**
**
** SEE THE START PARAGRAPH NOTES WHICH FOLLOW AS AN EXAMPLE.
**
****************************************************************
**
** TURN OFF USERS ECHO SO HE CAN ENTER PASSWORD
**
START.
**
** THE MESSAGE "!STOPECHOF" WILL BE INTERCEPTED BY THE
** TRANSACTION PROCESSOR AND THE APPROPRIATE ACTION TAKEN
**
MOVE '!STOPECHOF' TO OUT-LINE(1).
**
** INCREMENT COUNT OF OUTPUT LINES
**
SET LINES-OUT UP BY 1.
**
** INDICATE THAT MORE LINES WILL BE SENT TO THE USER
** BEFORE A RESPONSE IN EXPECTED
**
MOVE 'Y' TO MORE-TO-COME.
**
** SET SWITCH TO SUPPRESS CARRIAGE RETURN/LINE FEED AFTER
** THE MESSAGE PRINTS ON THE TERMINAL
**
MOVE 'N' TO OL-CARRIAGE-CTL(1).
**
** ALTER DISPATCHER TO PROCEED TO THE APPROPRIATE PARAGRAPH
**
ALTER DISPATCHER TO PROCEED TO NO-ECHO.
GO TO ENTER-MACRO.
**
** SEND USER WELCOME MESSAGE
**
NO-ECHO.
MOVE 'WELCOME TO MULTI-USER COBOL -DEMO- USING T/P - - PASSWORD: '
TO OUT-LINE(1).
MOVE 'N' TO OL-CARRIAGE-CTL(1).
SET LINES-OUT UP BY 1.
MOVE SPACES TO USER-TABLE(1).
ALTER DISPATCHER TO PROCEED TO PASSWORD-CHECK.
GO TO ENTER-MACRO.
**
** VALIDATE PASSWORD ENTERED
**
PASSWORD-CHECK.
IF IL-1-6 = "GOTYA" MOVE 'Y' TO LOGGED-IN(1) GO TO RESTORE-ECHO.
ADD 1 TO LOGIN-TRIES(1).
**
** 3 TRIES AT A PASSWORD WERE ALLOWED. AFTER THAT
** THE ECHO IS RESTORED AND THE USER IS UNSLAVED.
**
IF LOGIN-TRIES(1) = 3
MOVE '!STOPECHON' TO OUT-LINE(1)
SET LINES-OUT UP BY 1
MOVE 'Y' TO MORE-TO-COME
ALTER DISPATCHER TO PROCEED TO PASSWORD-ERRORS
GO TO ENTER-MACRO.
MOVE 'ERROR - - PASSWORD: ' TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
ALTER DISPATCHER TO PROCEED TO PASSWORD-CHECK.
GO TO ENTER-MACRO.
PASSWORD-ERRORS.
MOVE '!STOPBADPW' TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
ALTER DISPATCHER TO PROCEED TO START.
GO TO ENTER-MACRO.
**
** TURN USERS ECHO BACK ON
**
RESTORE-ECHO.
MOVE '!STOPECHON' TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
MOVE 'Y' TO MORE-TO-COME.
ALTER DISPATCHER TO PROCEED TO 100-BEGIN.
GO TO ENTER-MACRO.
**
** GIVE THE USER AN ASTERISK AND SEE WHICH BRANCH
** OF THE PROGRAM HE WANTS.
**
100-BEGIN.
SET LINES-OUT UP BY 1.
MOVE SPACES TO OUT-LINE(LINES-OUT).
SET LINES-OUT UP BY 1.
MOVE "*" TO OUT-LINE(LINES-OUT).
MOVE 'N' TO OL-CARRIAGE-CTL(LINES-OUT).
ALTER DISPATCHER TO PROCEED TO 200-MAJOR-BRANCH.
GO TO ENTER-MACRO.
200-MAJOR-BRANCH.
IF IL-1-6 = "DATE " GO TO 300-DATE.
IF IL-1-6 = "HELP " GO TO 400-HELP.
IF IL-1-6 = "PRINT " GO TO 500-PRINT.
IF IL-1-6 = "REPEAT" GO TO 600-REPEAT.
IF IL-1-6 = "ADD " GO TO 700-ADD.
IF IL-1-6 = "STOP " GO TO 999-STOP.
MOVE "INVALID COMMAND - TRY HELP" TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
GO TO 100-BEGIN.
**
** USER WANTS TO KNOW DATE AND TIME.
** IF HE ASKS MORE THAN ONCE WITHIN 5 MINUTES, LET HIM KNOW.
**
300-DATE.
MOVE TODAY TO DATE-TIME.
**
** OUTPUT MESSAGE MUST BE SET UP IN WORKING STORAGE
**
MOVE MO TO DM-MO.
MOVE DD TO DM-DD.
MOVE YY TO DM-YY.
MOVE HH TO DM-HH.
MOVE MM TO DM-MM.
MOVE DATE-MESSAGE TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
MOVE MM TO HOLD-MM.
IF LAST-MINUTE(1) = SPACE
GO TO 350-DATE.
IF LAST-MINUTE(1) GREATER THAN MM
ADD 60 TO MM.
SUBTRACT LAST-MINUTE(1) FROM MM.
IF MM > 5 GO TO 350-DATE.
SET LINES-OUT UP BY 1.
MOVE "(P.S. - YOU ASKED FOR DATE LESS THAN 5 MIN. AGO!!)" TO OUT-LINE(LINES-OUT).
350-DATE.
MOVE HOLD-MM TO LAST-MINUTE(1).
GO TO 100-BEGIN.
**
** USER WANTS TO KNOW WHAT THE PROGRAM CAN DO
**
400-HELP.
MOVE SPACES TO OUT-LINE(1).
MOVE "DATE = TODAYS DATE & TIME" TO OUT-LINE(2).
MOVE "HELP = THIS TEXT" TO OUT-LINE(3).
MOVE "PRINT= PRINT NN LINES; XX LINES @ A BURST" TO OUT-LINE(4).
MOVE "REPEAT= TYPE BACK TO THE USER EXACTLY WHAT HE TYPED" TO OUT-LINE(5).
MOVE "ADD = ADD 3 NUMBERS AND PRINT THE RESULT" TO OUT-LINE (6).
MOVE "STOP = GET OUT OF THIS PROGRAM & UNSLAVE SELF" TO OUT-LINE(7).
SET LINES-OUT UP BY 7.
GO TO 100-BEGIN.
**
** USER WANTS TO SEE SOME LINES PRINTED - FIND OUT HOW MANY.
**
500-PRINT.
SET LINES-OUT UP BY 1.
MOVE 'HOW MANY TEST LINES DO YOU WANT TO PRINT (01-99) ? ' TO OUT-LINE(LINES-OUT).
MOVE 'N' TO OL-CARRIAGE-CTL(LINES-OUT).
ALTER DISPATCHER TO PROCEED TO 505-PRINT.
GO TO ENTER-MACRO.
505-PRINT.
MOVE IL-1-2 TO LINES-TO-PRINT(1).
IF LINES-TO-PRINT(1) IS GREATER THAN ZERO
AND LINES-TO-PRINT(1) IS LESS THAN 100 GO TO 510-PRINT.
SET LINES-OUT UP BY 1.
MOVE '?? NOT WITHIN RANGE' TO OUT-LINE(LINES-OUT).
GO TO 500-PRINT.
510-PRINT.
SET LINES-OUT UP BY 1.
MOVE 'HOW MANY LINES PER BURST (01-99) ? ' TO OUT-LINE(LINES-OUT).
MOVE 'N' TO OL-CARRIAGE-CTL(LINES-OUT).
ALTER DISPATCHER TO PROCEED TO 515-PRINT.
GO TO ENTER-MACRO.
515-PRINT.
MOVE IL-1-2 TO LINES-PER-BURST(1).
IF LINES-PER-BURST(1) IS GREATER THAN ZERO
AND LINES-PER-BURST(1) IS LESS THAN 100
MOVE ZERO TO CURRENT-LINE(1)
GO TO 520-PRINT.
SET LINES-OUT UP BY 1.
MOVE '?? NOT WITHIN RANGE' TO OUT-LINE(LINES-OUT).
GO TO 510-PRINT.
520-PRINT.
MOVE LINES-PER-BURST(1) TO LINES-LEFT-THIS-BURST(1).
525-PRINT.
ADD 1 TO CURRENT-LINE(1).
MOVE CURRENT-LINE(1) TO DUMMY-LINE-NO.
SUBTRACT 1 FROM LINES-LEFT-THIS-BURST(1).
SET LINES-OUT UP BY 1.
MOVE DUMMY-LINE TO OUT-LINE(LINES-OUT).
**
** DUE TO BUFFER SPACE ONLY 15 LINES ARE SEND OUT AT ONE TIME.
** IF THERE ARE MORE THAN 15 THE MORE-TO-COME SWITCH IS SET
** SO THE USER NEVER KNOWS HE IS ONLY GETTING 15 LINES AT
** A WHACK.
**
IF LINES-OUT = 15
MOVE 'Y' TO MORE-TO-COME
ALTER DISPATCHER TO PROCEED TO 525-PRINT
GO TO ENTER-MACRO.
**
** SEE IF ALL USER WANTED IS SENT
**
IF CURRENT-LINE(1) = LINES-TO-PRINT(1)
GO TO 100-BEGIN.
**
** SEE IF ENTIRE BURST IS READY TO SEND. LOOK FOR A
** CARRIAGE RETURN TO SIGNAL HE WANTS THE NEXT BURST.
**
IF LINES-LEFT-THIS-BURST(1) = ZERO
SET LINES-OUT UP BY 1
MOVE '(TYPE <CR> FOR MORE) ' TO OUT-LINE(LINES-OUT)
MOVE 'N' TO OL-CARRIAGE-CTL(LINES-OUT)
ALTER DISPATCHER TO PROCEED TO 520-PRINT
GO TO ENTER-MACRO.
GO TO 525-PRINT.
**
** GIVE USER BACK WHAT HE ENTERED
**
600-REPEAT.
SET LINES-OUT UP BY 1.
GO TO 100-BEGIN.
**
** SHOW USER THAT YOU CAN ADD
**
700-ADD.
SET LINES-OUT UP BY 1.
MOVE "ENTER 3 NUMBERS (SEPARATED BY COMMAS) TO ADD TOGETHER" TO
OUT-LINE (LINES-OUT).
ALTER DISPATCHER TO PROCEED TO 720-ANSWER.
GO TO ENTER-MACRO.
720-ANSWER.
**
** SINCE MORE THAT ONE PIECE OF DATA IS ENTERED USE THE
** UNSTRING ROUTINE TO BREAK UP THE FIELDS.
**
*
* ** THE WAY YOU PASS PARAMETERS TO THE UNSTRING ROUTINE IS AS FOLLOWS:
* **
* ** 1. MOVE THE NUMBER OF FIELDS TO EXPECT TO BU-NOFLDS.
* **
* ** 2. MOVE THE INFORMATION ABOUT EACH FIELD TO BU-ARRAY
* ** THIS CAN BE DONE PIECE MEAL BUT IN ONE FELL SWOOP IS EASIER.
* **
* ** EX: NUMBER OF FIELDS TO EXPECT - 1
* **
* ** FIELD # - 1
* ** FIELD LENGTH - 2
* ** FIELD TYPE - A
* ** FIELD JUSTIFICATION - R
* ** NO DECIMALS
* **
* ** CODING WOULD BE:
* ** MOVE 1 TO BU-NOFLDS.
* ** MOVE "02AR " TO BU-ARRAY (1).
* ** -- -
* ** / - /
* ** LENGTH / - FIELD #
* ** TYPE / -
* ** JUSTIFICATION /
* ** DECIMALS
*
MOVE IN-LINE TO IMA-DATA.
MOVE 3 TO BU-NOFLDS.
MOVE "10N 2" TO BU-ARRAY (1), BU-ARRAY (2), BU-ARRAY (3).
PERFORM 9000-UNSTRING THRU 9035-EXIT-9000.
**
** FIELDS MUST BE FIRST CHECKED TO BE SURE THEY'RE NUMERIC BEFORE
** ADDING. MINUS SIGNS MUST BE LOOKED FOR AND DEALT WITH
** ACCORDINGLY.
**
MOVE BU-ANSWER (1) TO A-R.
EXAMINE A-R TALLYING ALL "-" REPLACING BY ZERO.
IF A NUMERIC NEXT SENTENCE ELSE
GO TO 740-ERROR.
IF TALLY > 0 COMPUTE A = 0 - A.
MOVE BU-ANSWER (2) TO B-R.
EXAMINE B-R TALLYING ALL "-" REPLACING BY ZERO.
IF B NUMERIC NEXT SENTENCE ELSE
GO TO 740-ERROR.
IF TALLY > 0 COMPUTE B = 0 - B.
MOVE BU-ANSWER (3) TO C-R.
EXAMINE C-R TALLYING ALL "-" REPLACING BY ZERO.
IF C NUMERIC NEXT SENTENCE ELSE
GO TO 740-ERROR.
IF TALLY > 0 COMPUTE C = 0 - C.
**
** IF ALL FIELDS NUMERIC ADD THEM.
**
COMPUTE D = A + B + C.
MOVE D TO ADD-ANSWER.
MOVE SPACE TO OUT-LINE (1).
MOVE ADD-ANSWER-LINE TO OUT-LINE (2).
SET LINES-OUT UP BY 2.
GO TO 100-BEGIN.
740-ERROR.
SET LINES-OUT UP BY 1.
MOVE "NUMBERS ENTERED NOT NUMERIC " TO OUT-LINE (LINES-OUT).
GO TO 700-ADD.
**
** USER WANTS OUT
**
999-STOP.
MOVE "!STOP " TO OUT-LINE(1).
SET LINES-OUT UP BY 1.
ALTER DISPATCHER TO PROCEED TO START.
GO TO ENTER-MACRO.
**
** IF CONTROL-C ENTERED USER WANTS TO START OVER.
** IF HE WAS LOGGED IN GO SEE WHICH BRANCH HE WANTS
** OTHERWISE CHECK HIS PASSWORD
**
1000-PROCESS-CONTROL-C.
IF LOGGED-IN(1) = 'Y'
GO TO 100-BEGIN.
GO TO PASSWORD-CHECK.
**
**********************************************************
** FOLLOWING IS THE UNSTRING ROUTINE
**
**********************************************************
9000-UNSTRING.
*
* ** THIS ROUTINE BREAKS APART A STRING OF CHARACTERS INTO
* ** DATA FIELDS, WHERE COMMAS ARE FIELD DELIMITERS,
* ** GIVEN THE NUMBER OF DATA FIELDS (BU-NOFLDS), PLUS
* ** THE LENGTH (BU-LGTH), TYPE (BU-TYP), JUSTIFICATION
* ** (BU-JUST), AND NUMBER OF DECIMALS (BU-DEC)
* ** OF EACH OF THE FIELDS. THE RESULTANT DATA FIELDS ARE PUT IN
* ** BU-ANSWER. IF ANY ERRORS WERE DETECTED THE LAST CHARACTER
* ** OF BU-ANSWER WILL CONTAIN THE ERROR CODE.
*
MOVE 0 TO INDEX1, INDEX3.
9002-SET-RETURN-AREAS.
*
* ** LOOP THRU ALL THE DATA FIELDS INITIALIZING THE
* ** OUTPUT AREA (BU-ANSWER) TO SPACES IF THE DATA FIELD
* ** IS ALPHA AND ZEROS IF THE DATA FIELD IS NUMERIC.
*
ADD 1 TO INDEX3.
IF BU-TYP (INDEX3) = "A"
MOVE SPACE TO BU-ANSWER (INDEX3)
ELSE MOVE ZERO TO BU-ANSWER (INDEX3).
IF INDEX3 < BU-NOFLDS GO TO 9002-SET-RETURN-AREAS.
MOVE 0 TO INDEX3.
9005-START.
ADD 1 TO INDEX3.
*
* ** IF ALL THE OUTPUT DATA FIELDS HAVE BEEN WORKED ON, EXIT.
*
IF INDEX3 > BU-NOFLDS GO TO 9035-EXIT-9000.
9006-IF.
*
* ** IF THE END OF THE INPUT DATA IS REACHED, EXIT.
*
IF INDEX1 = 72 GO TO 9035-EXIT-9000.
ADD 1 TO INDEX1.
*
* ** IF THERE ARE LEADING SPACES IGNORE THEM
*
IF IMA-ARRAY (INDEX1) = SPACE GO TO 9006-IF.
*
* ** IF THIS IS A NUMERIC FIELD GO TO THE NUMERIC PROCESSING AREA
*
IF BU-TYP (INDEX3) = "N" GO TO 9010-NUMERIC.
*
* ** THE FIELD IS THEREFORE ALPHA.
* ** IF IT IS A RIGHT JUSTIFIED FIELD GO TO 9012-RIGHT
*
IF BU-JUST (INDEX3) = "R" GO TO 9012-RIGHT.
MOVE 0 TO INDEX2.
*
* ** THIS SECTION HANDLES ALPHA DATA FIELDS LEFT JUSTIFIED
*
9007-ALPHA-LEFT.
*
* ** LOOK FOR A COMMA TO END THE FIELD
*
IF IMA-ARRAY (INDEX1) = CH-COMMA GO TO 9005-START.
ADD 1 TO INDEX2.
*
* ** IF THE OUTPUT DATA FIELD IS FULL, SET ERROR FLAG TO "A" AND
* ** BYPASS FILLING IT
*
IF INDEX2 > BU-LGTH (INDEX3) MOVE "A" TO BU-ANS (INDEX3,36) GO TO 9009-ADD.
*
* ** OTHERWISE PUT THE INPUT CHARACTER INTO THE OUTPUT DATA FIELD AREA
*
MOVE IMA-ARRAY (INDEX1) TO BU-ANS (INDEX3, INDEX2).
9009-ADD.
*
* ** IF ENTIRE INPUT RECORD IS READ, EXIT.
*
IF INDEX1 = 72 GO TO 9035-EXIT-9000.
*
* ** OTHERWISE PICK UP THE NEXT CHARACTER
*
ADD 1 TO INDEX1.
GO TO 9007-ALPHA-LEFT.
9010-NUMERIC.
*
* ** CHECK TO SEE IF THERE ARE ANY DECIMAL PLACES
*
IF BU-DEC (INDEX3) = 0 NEXT SENTENCE
ELSE GO TO 9020-NUMERIC-DECIMAL.
9012-RIGHT.
*
* ** THIS SECTION HANDLES ALPHA DATA FIELDS RIGHT JUSTIFIED
* ** AND NUMERICS WITH NO DECIMAL.
* ** THESE FIELDS ARE FIRST MOVED TO A TEMPORARY AREA (BU-STOR)
* ** THEN TO THE OUTPUT AREA (BU-ANS).
*
MOVE 0 TO INDEX4.
9014-IF.
*
* ** LOOK FOR THE COMMA TO END THE FIELD
*
IF IMA-ARRAY (INDEX1) = CH-COMMA GO TO 9018-MOVE.
*
* ** IF YOU HIT A SPACE AND THIS IS THE LAST DATA FIELD DON'T
* ** BOTHER LOOKING FOR THE COMMA BEFORE MOVING THIS FIELD TO THE
* ** OUTPUT AREA BECAUSE THESE FIELDS SHOULD NOT CONTAIN SPACES.
* ** IF THERE ARE MORE DATA FIELDS LOOP
* ** UNTIL THE COMMA OR END OF INPUT DATA IS FOUND.
*
IF IMA-ARRAY (INDEX1) NOT = SPACE NEXT SENTENCE
ELSE IF INDEX3 = BU-NOFLDS GO TO 9018-MOVE
ELSE GO TO 9016-ADD.
*
* ** IF THE TEMPORARY DATA FIELD IS FULL SET ERROR FLAG TO "D" BYPASS FILLING I
*
IF INDEX4 = 35 MOVE "D" TO BU-ANS (INDEX3,36) GO TO 9016-ADD.
*
* ** OTHERWISE MOVE INPUT CHARACTER TO TEMPORARY DATA FIELD
*
ADD 1 TO INDEX4.
MOVE IMA-ARRAY (INDEX1) TO BU-STOR (INDEX4).
9016-ADD.
*
* ** CHECK IF ALL THE INPUT DATA READ
*
IF INDEX1 = 72 GO TO 9018-MOVE.
*
* ** OTHERWISE READ THE NEXT CHARACTER
*
ADD 1 TO INDEX1.
GO TO 9014-IF.
*
* ** NOW MOVE THE DATA FIELD FROM ITS TEMPORARY HOME (BU-STOR) TO THE
* ** OUTPUT DATA AREA (BU-ANS)
*
9018-MOVE.
*
* ** IF NOTHING WAS PUT IN THE TEMP FIELD, PROCESS NEXT FIELD.
*
IF INDEX4 = 0 GO TO 9005-START.
*
* ** SET INDEX5 TO THE LENGTH OF THE OUTPUT FIELD
*
MOVE BU-LGTH (INDEX3) TO INDEX5.
*
* ** MOVE TEMP FIELD TO OUTPUT AREA ONE CHARACTER AT A TIME
* ** MOVING THE RIGHTMOST INPUTTED CHARACTER
* ** TO THE RIGHTMOST CHARACTER OF THE OUTPUT DATA FIELD AND
* ** WORK TO THE LEFT
*
9019-MOVE.
*
* ** IF THE TEMP FIELD IS EMPTY, PROCESS NEXT FIELD.
*
IF INDEX4 = 0 GO TO 9005-START.
*
* ** IF THE DATA OUTPUT FIELD IS FULL AND THERE WAS MORE DATA TO
* ** MOVE SET ERROR FLAG TO "B" AND PROCESS NEXT FIELD.
*
IF INDEX5 = 0 MOVE "B" TO BU-ANS (INDEX3,36) GO TO 9005-START.
MOVE BU-STOR (INDEX4) TO BU-ANS (INDEX3, INDEX5).
SUBTRACT 1 FROM INDEX4.
SUBTRACT 1 FROM INDEX5.
GO TO 9019-MOVE.
*
* ** THIS SECTION HANDLES NUMERICS WITH A POSSIBLE DECIMAL.
* ** THE PART OF THIS FIELD TO THE LEFT OF THE DECIMAL POINT
* ** (THE WHOLE PART) IS FIRST MOVED TO A TEMPORARY AREA (BU-STOR).
* ** THE DECIMAL PART IS THEN MOVED TO THE OUTPUT AREA (BU-ANS)
* ** AFTER WHICH THE WHOLE PART IS MOVED FROM THE TEMPORARY
* ** AREA TO THE OUTPUT AREA.
*
9020-NUMERIC-DECIMAL.
MOVE 0 TO INDEX2, INDEX4.
9022-IF.
*
* ** LOOK FOR THE COMMA TO END THE DATA FIELD
*
IF IMA-ARRAY (INDEX1) = CH-COMMA GO TO 9029-COMP.
*
* ** IF YOU HIT A SPACE AND THIS IS THE LAST DATA FIELD
* ** DON'T BOTHER LOOKING FOR THE COMMA BEFORE
* ** MOVING THIS FIELD TO THE TEMP AREA BECUASE NUMERIC FIELDS
* ** SHOULD NOT CONTAIN SPACES.
* ** IF THERE ARE MORE DATA FIELDS
* ** LOOP UNTIL THE COMMA OR END OF DATA IS FOUND
*
IF IMA-ARRAY (INDEX1) NOT = SPACE NEXT SENTENCE
ELSE IF INDEX3 = BU-NOFLDS GO TO 9029-COMP
ELSE GO TO 9024-ADD.
*
* ** LOOK FOR THE DECIMAL POINT. IF FOUND JUMP TO WHERE
* ** YOU READ THE DECIMAL PART OF THE NUMBER.
*
IF IMA-ARRAY (INDEX1) = "."
ADD 1 TO INDEX1 GO TO 9026-ADD.
*
* ** IF TEMPORARY DATA FIELD FULL, SET ERROR FLAG TO "D" AND BYPASS FILLING IT
*
IF INDEX4 = 35 MOVE "D" TO BU-ANS (INDEX3,36) GO TO 9024-ADD.
*
* ** OTHERWISE MOVE INPUT CHARACTER TO TEMP DATA FIELD
*
ADD 1 TO INDEX4.
MOVE IMA-ARRAY (INDEX1) TO BU-STOR (INDEX4).
9024-ADD.
*
* ** CHECK IF ENTIRE INPUT RECORD READ
*
IF INDEX1 = 72 GO TO 9029-COMP.
*
* ** OTHERWISE READ THE NEXT CHARACTER
*
ADD 1 TO INDEX1.
GO TO 9022-IF.
*
* ** THIS SECTION MOVES DECIMAL PART OF DATA FIELD TO THE
* ** OUTPUT DATA FIELD
*
9026-ADD.
*
* ** FIGURE OUT WHERE THE DECIMAL PART
* ** OF THE NUMBER SHOULD START IN THE OUTPUT DATA FIELD.
* ** THE FIELD LENGTH MINUS THE NUMBER OF DECIMAL PLACES
* ** WILL GIVE YOU ONE CHARACTER TO THE LEFT OF THE DESIRED POSITION.
*
COMPUTE INDEX5 = BU-LGTH (INDEX3) - BU-DEC (INDEX3).
9027-IF.
*
* ** CHECK IF COMMA HIT WHILE LOOKING FOR DECIMAL PART OF NUMBER
*
IF IMA-ARRAY (INDEX1) = CH-COMMA GO TO 9029-COMP.
*
* ** IF YOU HIT A SPACE AND THIS IS THE LAST DATA FIELD DON'T
* ** BOTHER LOOKING FOR THE COMMA BEFORE MOVING THE WHOLE
* ** PART OF THE NUMBER TO THE OUTPUT AREA BECAUSE NUMERIC FIELDS
* ** SHOULD NOT CONTAIN SPACES.
* ** IF THERE ARE MORE DATA FIELDS LOOP UNTIL
* ** THE COMMA OR END OF DATA IS FOUND.
*
IF IMA-ARRAY (INDEX1) NOT = SPACE NEXT SENTENCE
ELSE IF INDEX3 = BU-NOFLDS GO TO 9029-COMP
ELSE GO TO 9028-ADD.
ADD 1 TO INDEX5.
*
* ** IF OUTPUT DATA FIELD FULL AND THERE ARE MORE DECIMALS TO MOVE
* ** SET ERROR FLAG TO "C" AND JUMP TO WHERE THE
* ** WHOLE PART OF THE NUMBER IS MOVED TO THE OUTPUT AREA
*
IF INDEX5 > BU-LGTH (INDEX3) MOVE "C" TO BU-ANS (INDEX3,36) GO TO 9028-ADD.
*
* ** OTHERWISE MOVE INPUT CHARACTER TO OUTPUT DATA FIELD
*
MOVE IMA-ARRAY (INDEX1) TO BU-ANS (INDEX3, INDEX5).
9028-ADD.
*
* ** CHECK IF ALL INPUT DATA READ
*
IF INDEX1 = 72 GO TO 9029-COMP.
*
* ** OTHERWISE READ THE NEXT CHARACTER
*
ADD 1 TO INDEX1.
GO TO 9027-IF.
*
* ** THIS SECTION MOVES THE WHOLE PART OF THE NUMBER FROM THE
* ** TEMPORARY AREA TO THE OUTPUT AREA
*
9029-COMP.
*
* ** IF THERE IS NO WHOLE PART OF THE NUMBER, PROCESS NEXT FIELD.
*
IF INDEX4 = 0 GO TO 9005-START.
*
* ** OTHERWISE COMPUTE THE RIGHTMOST CHARACTER FOR THE WHOLE
* ** PART OF THE NUMBER IN THE OUTPUT FIELD.
* ** NAMELY, THE FIELD LENGTH MINUS THE NUMBER OF DECIMALS.
*
COMPUTE INDEX5 = BU-LGTH (INDEX3) - BU-DEC (INDEX3).
9030-IF.
*
* ** IF ALL THE DATA IS MOVED, PROCESS NEXT FIELD.
*
IF INDEX4 = 0 GO TO 9005-START.
*
* ** IF THE OUTPUT AREA IS FULL AND THERE STILL IS DATA TO MOVE
* ** SET ERROR FLAG TO "B" AND PROCESS NEXT FIELD.
*
IF INDEX5 = 0 MOVE "B" TO BU-ANS (INDEX3,36) GO TO 9005-START.
*
* ** MOVE WHOLE PART OF THE NUMBER FROM THE TEMP AREA TO THE
* ** OUTPUT DATA FIELD WORKING FROM RIGHT TO LEFT
*
MOVE BU-STOR (INDEX4) TO BU-ANS (INDEX3, INDEX5).
SUBTRACT 1 FROM INDEX4.
SUBTRACT 1 FROM INDEX5.
GO TO 9030-IF.
9035-EXIT-9000.
EXIT.
*********************************************************
**
** THE UNSTRING ROUTINE ENDETH
**
*********************************************************
*****************************************************************
**
** CLOSE FILES ETC. BETWEEN WRAP-UP AND STOP RUN
**
** THIS CODE IS ONLY REACHED WHEN THE OPERATOR AT
** THE MASTER TERMINAL WANTS TO STOP THIS JOB /
** WHEN YOU GET HERE, ALL OF YOUR SLAVE TERMINALS
** HAVE BEEN UN-SLAVED & RETURNED TO MONITOR MODE
** *
*****************************************************************
WRAP-UP.
STOP RUN.