/* REXX */                                                                      
/**********************************************************************/        
/* This program converts a binary number to a zoned decimal           */        
/* (character) format. The inputs to the program are:                 */        
/*                                                                    */        
/* bin_num     - The binary number to be converted. Binary numbers    */        
/*               must be 2, 4 or 8 bytes in length.                   */        
/* 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 binary 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 32                                                               
PARSE ARG bin_num char_length                                                   
PARSE UPPER SOURCE . zorg .                                                     
                                                                                
zrc      = 0                                                                    
char_num = ''                                                                   
zmsg2    = ''                                                                   
                                                                                
IF bin_num = ''                                                                 
THEN DO                                                                         
       zmsg1 = 'No binary value passed to B2C.'                                 
       zrc   = 16                                                               
       SIGNAL Done                                                              
     END                                                                        
                                                                                
bin_length = LENGTH(bin_num)                                                    
                                                                                
SELECT                                                                          
WHEN bin_length = 2                                                             
THEN NOP                                                                        
WHEN bin_length = 4                                                             
THEN NOP                                                                        
WHEN bin_length = 8                                                             
THEN NOP                                                                        
OTHERWISE                                                                       
     zmsg1 = 'Value passed to B2C must be 2, 4 or 8 bytes.'                     
     zmsg2 = 'LENGTH('bin_num') =' bin_length';'                                
     zrc   = 12                                                                 
     SIGNAL Done                                                                
END /* SELECT */                                                                
                                                                                
hex_num    = C2X(bin_num)                                                       
hex_length = LENGTH(hex_num)                                                    
             /* Specifying length treats as signed. */                          
char_num   = X2D(hex_num,hex_length)                                            
                                                                                
SELECT                                                                          
WHEN char_length = ''                                                           
THEN char_length = LENGTH(char_num)                                             
WHEN \DATATYPE(char_length,'W')                                                 
THEN DO                                                                         
       zmsg1 = 'Length passed to B2C 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 binary number exceeds length passed.'                  
       zmsg2 = 'LENGTH('char_num') >' char_length';'                            
       char_num = ''                                                            
       zrc   = 8                                                                
       SIGNAL Done                                                              
     END                                                                        
OTHERWISE NOP                                                                   
END /* SELECT */                                                                
                                                                                
char_num = RIGHT(char_num,char_length,' ')            /* Blank Fill. */         
zmsg1    = 'The value of the binary 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 */