Powered By Blogger

Sunday, March 27, 2011

COBOL: Update a KSDS record / Read it back


000100*UPDATES A RECORD TO THE KSDS                                    
000200*READS THE RECORD IF PRESENT                                    
000300 IDENTIFICATION DIVISION.                                        
000400 PROGRAM-ID. CBLKSDS4.                                          
000500 ENVIRONMENT DIVISION.                                          
000600 INPUT-OUTPUT SECTION.                                          
000700 FILE-CONTROL.                                                  
000800     SELECT INPUT-FILE ASSIGN TO READER                          
000900     ORGANIZATION IS INDEXED                                    
001000     ACCESS MODE IS DYNAMIC                                      
001100     RECORD KEY IS EMP-ID                                        
001200     FILE STATUS IS FS.                                          
001300 DATA DIVISION.                                                  
001400 FILE SECTION.                                                  
001500 FD INPUT-FILE.                                                  
001600 01 INPUT-REC.                                                  
001700     02  EMP-ID      PIC X(06).                                  
001800     02  FIRST-NAME  PIC X(20).                                  
001900     02  MIDDLE-NAME PIC X(20).                                  
002000     02  LAST-NAME   PIC X(20).                                  
002100     02  FILLER      PIC X(14).                                  
002200 WORKING-STORAGE SECTION.                                        
002300 01 FS PIC X(2).                                                
002400     88  RECORDFOUND VALUE '00'.                                
002500 01 WS-INPUT-REC.                                                
002600     02  WS-EMP-ID      PIC X(06).                              
002700     02  WS-FIRST-NAME  PIC X(20).                              
002800     02  WS-MIDDLE-NAME PIC X(20).                              
002900     02  WS-LAST-NAME   PIC X(20).                              
003000     02  FILLER         PIC X(14).                              
003100 PROCEDURE DIVISION.                                            
003200 MAINLINE SECTION.                                              
003300     OPEN I-O INPUT-FILE.                                        
003400     DISPLAY 'ENTER ENTIRE RECORD' WITH NO ADVANCING.            
003500     ACCEPT INPUT-REC.                                          
003600     DISPLAY 'TRYING TO UPDATE WITH RECORD: ' INPUT-REC.        
003700     REWRITE INPUT-REC                                          
003800     END-REWRITE.                                                
003900     READ INPUT-FILE                                            
004000         KEY IS EMP-ID                                          
004100         INVALID KEY DISPLAY 'BAD EMPID GIVEN, FILE STATUS ' FS  
004200     END-READ.                                                  
004300     IF RECORDFOUND THEN                                        
004400         MOVE EMP-ID      TO WS-EMP-ID                          
004500         MOVE FIRST-NAME  TO WS-FIRST-NAME                      
004600         MOVE MIDDLE-NAME TO WS-MIDDLE-NAME                      
004700         MOVE LAST-NAME   TO WS-LAST-NAME                        
004800         DISPLAY 'DISPLAYING CURRENT RECORD'                    
004900         DISPLAY ' '                                            
005000         DISPLAY 'EMP_ID       ' WS-EMP-ID                      
005100         DISPLAY 'FIRST_NAME   ' WS-FIRST-NAME                  
005200         DISPLAY 'MIDDLE_NAME  ' WS-MIDDLE-NAME                  
005300         DISPLAY 'LAST_NAME    ' WS-LAST-NAME                    
005400     END-IF.                                                    
005500     CLOSE INPUT-FILE.                                          
005600     STOP RUN.                                                  

No comments:

Post a Comment