Version 2.4.1
 —  Adabas Native SQL Reference Manual  —

APPENDIX J - PL/I EXAMPLES

This document covers the following topics:


Example 1

 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;

Top of page

Example 2

 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;

Top of page

Example 3

 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;

Top of page