This document covers the following topics:
PEX1 : PROC OPTIONS(MAIN);
/* AN EXAMPLE OF SOFT COUPLING WITH A SEARCH CRITERION WHICH
CONTAINS FIELDS TAKEN FROM TWO FILES. THE FIELDS PERSONNEL-ID
NAME, FIRST-NAME, BIRTH AND SEX (FROM THE MAIN FILE,
PERSONNEL-ID) ARE PRINTED FOR RECORDS THAT SATISFY THE
FOLLOWING CONDITION:
PERSONNEL-ID BETWEEN 10000001 AND 19999999
MODEL-YEAR-MAKE >
CLASS = 'C' */
/* */
DCL 1 START_STRUC,
2 START_MODEL CHAR(20) INIT('MERCEDES-BENZ'),
2 START_YEAR_MAKE PIC '(2)9' INIT(86);
DCL START_MODEL_YEAR_MAKE CHAR(22) BASED(ADDR(START_STRUC));
/* */
DCL 1 HEADER,
2 FILLER1 CHAR(12) INIT('PERSONNEL-ID'),
2 FILLER2 CHAR(8) INIT(' '),
2 FILLER3 CHAR(4) INIT('NAME'),
2 FILLER4 CHAR(13) INIT(' '),
2 FILLER5 CHAR(10) INIT('FIRST-NAME'),
2 FILLER6 CHAR(8) INIT(' '),
2 FILLER7 CHAR(5) INIT('BIRTH'),
2 FILLER8 CHAR(1) INIT(' '),
2 FILLER9 CHAR(3) INIT('SEX');
DCL 1 HEADER2 CHAR(64) INIT((64)'*');
DCL 1 LINE1,
2 FILLER1 CHAR(2) INIT(' '),
2 PERSONNEL_NR CHAR(8) INIT(' '),
2 FILLER2 CHAR(3) INIT(' '),
2 LAST_NAME CHAR(20) INIT(' '),
2 FILLER3 CHAR(1) INIT(' '),
2 F_NAME CHAR(20) INIT(' '),
2 FILLER4 CHAR(1) INIT(' '),
2 BIRTHDAY CHAR(6) INIT(' '),
2 FILLER5 CHAR(1) INIT(' '),
2 KIND CHAR(1) INIT(' ');
/* */
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
/* */
EXEC ADABAS
DECLARE EMPL CURSOR FOR
SELECT PERSONNEL-ID, NAME, FIRST-NAME, BIRTH, SEX
FROM EMPLOYEES, VEHICLES
WHERE EMPLOYEES.PERSONNEL-ID = VEHICLES.PERSONNEL-ID
AND PERSONNEL-ID BETWEEN '10000001' AND '19999999'
AND VEHICLES.MODEL-YEAR-MAKE > :START_MODEL_YEAR_MAKE
AND VEHICLES.CLASS = 'C'
END-EXEC
/* */
PUT SKIP EDIT (HEADER) (A);
PUT SKIP EDIT (HEADER2) (A);
PUT SKIP;
/* */
EXEC ADABAS
OPEN EMPL
END-EXEC
/* */
EXEC ADABAS
FETCH EMPL
END-EXEC
/* */
DO WHILE (ADACODE *= 3);
PERSONNEL_NR = PERSONNEL_ID;
LAST_NAME = NAME;
F_NAME = FIRST_NAME;
BIRTHDAY = BIRTH;
KIND = SEX;
PUT SKIP EDIT (LINE1) (A);
EXEC ADABAS
FETCH EMPL
END-EXEC
END;
/* */
EXEC ADABAS
CLOSE EMPL
END-EXEC
/* */
EXEC ADABAS
DBCLOSE
END-EXEC
/* */
END PEX1;
PEX2 : PROC OPTIONS(MAIN);
/* DELETE AN EMPLOYEE RECORD AND RELEASE ALL CARS WHICH ARE
ASSIGNED TO THIS EMPLOYEE. A PRIVATE CARS WILL BE DELETED
AND A COMPANY CAR WILL BE MADE A POOL-CAR WHICH IS IDENTIFIED
BY ITS PERSONNEL-ID CONTAINING ONLY THE COUNTRY CODE.
*/
/* */
DCL PERSONNEL_NUMBER CHAR(8) INIT ('20007100');
DCL EMPLOYEE_ISN FIXED BIN(31) INIT(0);
DCL 1 COUNTRY_NUM,
2 COUNTRY_NO CHAR(1) INIT (' ') ,
2 FILLER CHAR(14) INIT (' ');
DCL COUNTRY_NUMBER CHAR(15) BASED(ADDR(COUNTR_NUM));
/* */
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
/* */
EXEC ADABAS
READ LOGICAL
DECLARE VEH1 CURSOR FOR
SELECT REG-NUM, PERSONNEL-ID, CLASS
FROM VEHICLES
WHERE PERSONNEL-ID GE :PERSONNEL-NUMBER
OPTIONS HOLD
ORDER BY PERSONNEL-ID
END-EXEC
/*
*** FIND EMPLOYEE
*/
EXEC ADABAS
FIND
SELECT
FROM EMPLOYEES EMPLOYEES_1
WHERE PERSONNEL-ID = :PERSONNEL_NUMBER
OPTIONS HOLD
END-EXEC
/*
*** IF THE PERSONNEL-ID EXISTS DELETE THE EMPLOYEE AND READ THE
*** VEHICLES FILE
*/
IF EMPLOYEES_1.QUANTITY = 1 THEN
DO;
EMPLOYEE_ISN = EMPLOYEES_1.ISN;
CALL DELETE_EMPLOYEE;
CALL READ_VEHICLES_FILE;
END;
ELSE
PUT SKIP EDIT
('NO EMPLOYEE FOUND WITH PERSONNEL-ID ',PERSONNEL_NUMBER)(A);
/* */
EXEC ADABAS
DBCLOSE
END-EXEC
/*********************************************************************/
DELETE_EMPLOYEE : PROC;
/* */
EXEC ADABAS
DELETE
FROM EMPLOYEES
WHERE ISN = :EMPLOYEE_ISN
END-EXEC
/* */
PUT SKIP EDIT
('EMPLOYEE ',PERSONNEL_NUMBER,' HAS BEEN DELETED')(A);
/* */
END DELETE_EMPLOYEE;
/*********************************************************************/
READ_VEHICLES_FILE : PROC;
/* */
EXEC ADABAS
OPEN VEH1
END-EXEC
/* */
EXEC ADABAS
FETCH VEH1
END-EXEC
/* */
DO WHILE (ADACODE *= 3 &
VEHICLES.PERSONNEL_ID = PERSONNEL_NUMBER);
IF CLASS = 'P' THEN
DO;
EXEC ADABAS
DELETE
FROM VEHICLES
WHERE CURRENT OF VEH1
END-EXEC
PUT SKIP EDIT
('PRIVATE CAR ',REG_NUM,' HAS BEEN DELETED')(A);
END;
ELSE
DO;
COUNTRY_NUMBER = VEHICLES.PERSONNEL_ID;
VEHICLES.PERSONNEL_ID = COUNTRY_NO;
EXEC ADABAS
UPDATE VEHICLES
WHERE CURRENT OF VEH1
END-EXEC
PUT SKIP EDIT
('COMPANY CAR ',REG_NUM,' HAS BEEN UPDATED')(A);
END;
/* */
EXEC ADABAS
FETCH VEH1
END-EXEC
/* */
END;
/* */
EXEC ADABAS
CLOSE VEH1
END-EXEC
/* */
EXEC ADABAS
COMMIT WORK
END-EXEC
/* */
END READ_VEHICLES_FILE;
/* */
END PEX2;
PEX3 : PROC OPTIONS(MAIN);
/* SALARY INCREASE.
THIS PROGRAM INCREASES THE SALARY OF EVERY EMPLOYEE BY
4 PERCENT.
THE DEPARTMENT, THE OVERALL AMOUNT OF PAY RISE FOR THE
DEPARTMENT AND THE PAY RISE FOR ALL DEPARTMENTS WILL BE PRINTED
OUT.
THE PROGRAM IS RESTARTABLE. AFTER AN ABNORMAL TERMINATION THE
PROGRAM EXECUTION WOULD RESTART WITH THE LAST DEPARTMENT
WHOSE SALARY UPDATE HAD BEEN COMPLETED BEFORE THE ABEND
OCCURED.
*/
/* */
DCL 1 COMM_DATA,
2 COMMIT_DEPARTMENT CHAR(6) INIT (' '),
2 COMMIT_SUM FIXED DEC(10) INIT (0);
DCL COMMIT_DATA CHAR(12) BASED(ADDR(COMM_DATA));
DCL START_DEPT CHAR(6) INIT (' ');
DCL IND FIXED BIN(15) INIT (0);
DCL I FIXED BIN(15) INIT (0);
DCL J FIXED BIN(15) INIT (0);
DCL NEW_SALARY FIXED DEC(9) INIT (0);
DCL INCREASE FIXED DEC(9) INIT (0);
DCL SUM_DEPARTMENT FIXED DEC(10) INIT (0);
DCL SUM_TOTAL FIXED DEC(11) INIT (0);
/* */
DCL 1 HEADER,
2 FILLER1 CHAR(10) INIT ('DEPARTMENT'),
2 FILLER2 CHAR(15) INIT (' '),
2 FILLER3 CHAR(15) INIT ('SALARY INCREASE');
DCL 1 LINE1,
2 FILLER1 CHAR(3) INIT (' '),
2 DEPARTMENT CHAR(6) INIT (' '),
2 FILLER2 CHAR(16) INIT (' '),
2 SUM_DEPT PIC 'Z,ZZZ,ZZZ,ZZ9';
DCL 1 FOOT_LINE,
2 FILLER1 CHAR(21) INIT ('TOTAL SALARY INCREASE'),
2 FILLER CHAR(3) INIT (' : '),
2 TOTAL_SUM_DEPT PIC 'ZZ,ZZZ,ZZZ,ZZZ';
/* */
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
/* */
EXEC ADABAS
HISTOGRAM
DECLARE EMP1 CURSOR FOR
SELECT DEPT
FROM EMPLOYEES EMPLOYEES_1
WHERE DEPT GE :COMMIT_DEPARTMENT
GROUP BY DEPT
END-EXEC
/* */
EXEC ADABAS
READ LOGICAL
DECLARE EMP2 CURSOR FOR
SELECT PERSONNEL-ID, DEPT, SALARY, INCOME(COUNT)
FROM EMPLOYEES
WHERE DEPT GE :START_DEPT
OPTIONS HOLD
ORDER BY DEPT
END-EXEC
/* */
EXEC ADABAS
CONNECT 'INCREASE'
UPD=EMPLOYEES
AND USERDATA INTO :COMMIT_DATA
END-EXEC
/*
A HISTOGRAM STATEMENT IS USED TO ASCERTAIN THE NUMBER OF
EMPLOYEES PER DEPARTMENT
*/
EXEC ADABAS
OPEN EMP1
END-EXEC
/* */
EXEC ADABAS
FETCH EMP1
END-EXEC
/* */
IF COMMIT_DATA *= ' ' THEN CALL RESTART;
/* */
START_DEPT = EMPLOYEES_1.DEPT;
/* */
EXEC ADABAS
OPEN EMP2
END-EXEC
/* */
PUT SKIP EDIT (HEADER) (A);
PUT SKIP LIST ((40)'*');
PUT SKIP;
/* */
DO WHILE (ADACODE *= 3);
CALL HIST_EMPL;
END;
/* */
EXEC ADABAS
CLOSE EMP1
END-EXEC
/* */
EXEC ADABAS
CLOSE EMP2
END-EXEC
/* */
PUT SKIP;
PUT SKIP LIST ((50)'-');
PUT SKIP;
TOTAL_SUM_DEPT = SUM_TOTAL;
PUT SKIP EDIT (FOOT_LINE) (A);
COMMIT_DATA = ' ';
/* */
EXEC ADABAS
DBCLOSE
USERDATA = :COMMIT_DATA
END-EXEC
/*********************************************************************/
RESTART : PROC;
PUT SKIP LIST ('LAST PROGRAM RUN TERMINATED ABNORMALLY');
PUT SKIP EDIT ('LAST DEPARTMENT WAS: ',COMMIT_DEPARTMENT)(A);
/* */
EXEC ADABAS
FETCH EMP1
END-EXEC
END RESTART;
/*********************************************************************/
HIST_EMPL : PROC;
/*
THE EMPLOYEES FILE WILL BE READ UNTIL ALL RECORDS FOR THE
DEPARTMENT HAVE BEEN PROCESSED AND THE SALARY HAS BEEN
UPDATED
*/
DO J=1 BY 1 TO EMPLOYEES_1.QUANTITY;
EXEC ADABAS
FETCH EMP2
END-EXEC
/* THE SALARY INCREASE CAN BE EXECUTED WHEN THE COUNT OF THE
PERIODIC GROUP IS LESS THAN 40. */
IF C_INCOME <= 40 THEN
CALL SALARY_INCREASE;
ELSE
PUT SKIP EDIT
('UPDATE PERSON ',PERSONNEL_ID,' NOT POSSIBLE')(A);
END;
/* */
DEPARTMENT = EMPLOYEES.DEPT;
SUM_DEPT = SUM_DEPARTMENT;
SUM_DEPARTMENT = 0;
PUT SKIP EDIT (LINE1) (A);
/* */
COMMIT_DEPARTMENT = EMPLOYEES.DEPT;
COMMIT_SUM = SUM_TOTAL;
EXEC ADABAS
COMMIT WORK
USERDATA = :COMMIT_DATA
END-EXEC
/* */
EXEC ADABAS
FETCH EMP1
END-EXEC
/* */
END HIST_EMPL;
/*********************************************************************/
SALARY_INCREASE : PROC;
INCREASE = SALARY(1) * 0.04;
NEW_SALARY = SALARY(1) + INCREASE;
IND = C_INCOME + 1;
/* */
DO I=C_INCOME BY -1 TO 0;
SALARY(IND) = SALARY(I);
IND = IND - 1;
END;
/* */
SALARY(1) = NEW_SALARY;
/* */
EXEC ADABAS
UPDATE EMPLOYEES
WHERE CURRENT OF EMP2
END-EXEC
/* */
SUM_DEPARTMENT = SUM_DEPARTMENT + INCREASE;
SUM_TOTAL = SUM_TOTAL + INCREASE;
END SALARY_INCREASE;
/* */
END PEX3;