/* REXX */                                                                      
/**********************************************************************/        
/* This program converts a zoned decimal (character) number to a      */        
/* packed decimal format. The inputs to the program are:              */        
/*                                                                    */        
/* char_num  - The zoned decimal number to be converted.              */        
/* pd_length - The number of bytes of the packed 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 packed decimal value. If an  */        
/*              error occurs the detail line is null. A return code   */        
/*              is provided in variable RESULT.                       */        
/* FUNCTION   - Returns only the packed decimal value. If an error    */        
/*              occurs a null is returned.                            */        
/**********************************************************************/        
NUMERIC DIGITS 31                                                               
PARSE ARG char_num pd_length                                                    
PARSE UPPER SOURCE . zorg .                                                     
                                                                                
zrc    = 0                                                                      
zmsg2  = ''                                                                     
pd_num = ''                                                                     
                                                                                
SELECT                                                                          
WHEN char_num = ''                                                              
THEN DO                                                                         
       zmsg1 = 'No zoned decimal value passed to C2PD.'                         
       zrc   = 16                                                               
       SIGNAL Done                                                              
     END                                                                        
WHEN \DATATYPE(char_num,'W')                                                    
THEN DO                                                                         
       zmsg1 = 'Value passed to C2PD is not a valid whole number.'              
       zmsg2 = 'char_num =' char_num';'                                         
       zrc   = 12                                                               
       SIGNAL Done                                                              
     END                                                                        
WHEN POS('+',char_num) > 0                                                      
THEN DO                                                                         
       pd_sign   = 'C'                                                          
       /* Remove leading, trailing, embedded blanks & positive. */              
       char_num  = char_num + 0                                                 
       char_num  = '+'char_num                                                  
     END                                                                        
WHEN POS('-',char_num) > 0                                                      
THEN DO                                                                         
       pd_sign   = 'D'                                                          
       /* Remove leading, trailing & embedded blanks. */                        
       char_num  = char_num + 0                                                 
     END                                                                        
OTHERWISE                                                                       
     pd_sign     = 'F'                                                          
     /* Remove leading & trailing blanks. */                                    
     char_num    = char_num + 0                                                 
END /* SELECT */                                                                
                                                                                
hex_num = STRIP(char_num,'L','-')                                               
hex_num = STRIP(hex_num,'L','+')                                                
                                                                                
IF DATATYPE(LENGTH(hex_num) / 2,'W')                                            
THEN hex_num = '0'hex_num            /* Odd number of digits. */                
                                                                                
hex_num = hex_num''pd_sign                                                      
                                                                                
SELECT                                                                          
WHEN pd_length = ''                                                             
THEN pd_length = LENGTH(hex_num)                                                
WHEN \DATATYPE(pd_length,'W')                                                   
THEN DO                                                                         
       zmsg1  = 'Length passed to C2PD not a whole number.'                     
       zmsg2  = 'pd_length =' pd_length';'                                      
       pd_num = ''                                                              
       zrc    = 8                                                               
       SIGNAL Done                                                              
     END                                                                        
WHEN LENGTH(hex_num) > pd_length * 2                                            
THEN DO                                                                         
       zmsg1  = 'Value of packed decimal number exceeds length passed.'         
       zmsg2  = "LENGTH('"hex_num"'X) >" pd_length";"                           
       pd_num = ''                                                              
       zrc    = 8                                                               
       SIGNAL Done                                                              
     END                                                                        
OTHERWISE NOP                                                                   
     pd_length = pd_length * 2                                                  
END /* SELECT */                                                                
                                                                                
hex_num  = RIGHT(hex_num,pd_length,'0')  /* Zero fill. */                       
INTERPRET "pd_num = '"hex_num"'X"                                               
zmsg1   = 'The value of the packed decimal number is:'                          
zmsg2   = "C'"char_num"' = X'"hex_num"'."                                       
                                                                                
Done:                                                                           
SELECT                                                                          
WHEN zorg = 'COMMAND'                                                           
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY zmsg2                                                                
       EXIT zrc                                                                 
     END                                                                        
WHEN zorg = 'SUBROUTINE'                                                        
THEN DO                                                                         
       SAY zmsg1                                                                
       SAY pd_num                                                               
       RETURN zrc     /* Placed in RESULT. */                                   
     END                                                                        
OTHERWISE /* FUNCTION */                                                        
     RETURN pd_num                                                              
END /* SELECT */