/* REXX */                                                                      
/**********************************************************************/        
/* This program converts a packed decimal number to a zoned decimal   */        
/* (character) format. The inputs to the program are:                 */        
/*                                                                    */        
/* pd_num      - The packed decimal number to be converted.           */        
/* char_length - The number of bytes of the zoned decimal value.      */        
/*               If not provided the minimum length is used.          */        
/*                                                                    */        
/* The output of the program varies with the type of invocation:      */        
/*                                                                    */        
/* COMMAND    - Displays a message line, and a detail line. Details   */        
/*              may include error information or the result of the    */        
/*              conversion. The packed decimal value is shown in      */        
/*              hexadecimal format. A return code is set.             */        
/* SUBROUTINE - Displays a message line and a detail line. The        */        
/*              detail line contains the zoned decimal value. If an   */        
/*              error occurs the detail line is null. A return code   */        
/*              is provided in variable RESULT.                       */        
/* FUNCTION   - Returns only the zoned decimal value. If an error     */        
/*              occurs a null is returned.                            */        
/**********************************************************************/        
NUMERIC DIGITS 31                                                               
PARSE ARG pd_num char_length                                                    
PARSE UPPER SOURCE . zorg .                                                     
                                                                                
zrc      = 0                                                                    
zmsg2    = ''                                                                   
char_num = ''                                                                   
                                                                                
IF pd_num = ''                                                                  
THEN DO                                                                         
       zmsg1 = 'No packed decimal value passed to PD2C.'                        
       zrc   = 16                                                               
       SIGNAL Done                                                              
     END                                                                        
                                                                                
hex_num    = C2X(pd_num)                                                        
pd_digits  = LEFT(hex_num,LENGTH(hex_num) - 1)                                  
pd_sign    = RIGHT(hex_num,1)                                                   
                                                                                
IF \DATATYPE(pd_digits,'W')                                                     
THEN DO                                                                         
       zmsg1 = 'Packed decimal number contains invalid digits.'                 
       zmsg2 = 'pd_digits =' pd_digits';'                                       
       zrc   = 12                                                               
       SIGNAL Done                                                              
     END                                                                        
                                                                                
SELECT                                                                          
WHEN pd_sign = 'C'                                                              
THEN pd_sign = '+'                                                              
WHEN pd_sign = 'D'                                                              
THEN pd_sign = '-'                                                              
WHEN pd_sign = 'F'                                                              
THEN pd_sign = ' '                                                              
OTHERWISE                                                                       
       zmsg1 = 'Packed decimal number contains invalid sign.'                   
       zmsg2 = 'pd_sign =' pd_sign';'                                           
       zrc   = 12                                                               
       SIGNAL Done                                                              
END /* SELECT */                                                                
                                                                                
char_num = pd_sign''pd_digits                                                   
                                                                                
SELECT                                                                          
WHEN char_length = ''                                                           
THEN char_length = LENGTH(char_num)                                             
WHEN \DATATYPE(char_length,'W')                                                 
THEN DO                                                                         
       zmsg1 = 'Length passed to PD2C not a whole number.'                      
       zmsg2 = 'char_length =' char_length';'                                   
       char_num = ''                                                            
       zrc   = 8                                                                
       SIGNAL Done                                                              
     END                                                                        
WHEN LENGTH(char_num) > char_length                                             
THEN DO                                                                         
       zmsg1 = 'Value of packed decimal number exceeds length passed.'          
       zmsg2 = 'LENGTH('char_num') >' char_length';'                            
       char_num = ''                                                            
       zrc   = 8                                                                
       SIGNAL Done                                                              
     END                                                                        
OTHERWISE NOP                                                                   
END /* SELECT */                                                                
                                                                                
/*                                                                              
char_num = pd_sign''RIGHT(pd_digits,char_length - 1,'0')   Zero fill. */        
char_num = RIGHT(char_num,char_length,' ')             /* Blank fill. */        
zmsg1    = 'The value of the packed decimal number is:'                         
zmsg2    = "X'"hex_num"' = C'"char_num"'."                                      
                                                                                
Done:                                                                           
SELECT                                                                          
WHEN zorg = 'COMMAND'                                                           
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY zmsg2                                                                
       EXIT zrc                                                                 
     END                                                                        
WHEN zorg = 'SUBROUTINE'                                                        
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY char_num                                                             
       RETURN zrc     /* Placed in RESULT. */                                   
     END                                                                        
OTHERWISE /* FUNCTION */                                                        
     RETURN char_num                                                            
END /* SELECT */