H DATEDIT(*YMD/)                                                                               
     F**********  レコード様式のリスト  ************************************                        
     F*   QUSLRCD  のサンプル                                                                       
     F**********************************************************************                        
      /COPY QSYSINC/QRPGLESRC,QUS                                                                   
      /COPY QSYSINC/QRPGLESRC,QUSLRCD                                                               
     D FILFILLIB       S             20A   INZ('SHOHIN    QTRFIL    ')                              
                                                                                                    
     D APIERR          DS                                                                           
     D  GETBYT                 1      4B 0 INZ(160)                                                 
     D  AVLBYT                 5      8B 0 INZ(0)                                                   
     D  MSGID                  9     15                                                             
     D  MSGDTA                17    160                                                             
                                                                                                    
     D USRSPC          DS                                                                           
     D  USNAME                       10A   INZ('USLSPC    ')                                        
     D  USLIB                        10A   INZ('QTEMP     ')                                        
                                                                                                    
     D MSGFFLIB        DS                                                                           
     D  MSGF                         10A   INZ('QCPFMSG   ')                                        
     D  MSGFLIB                      10A   INZ('QSYS      ')                                        
                                                                                                    
     D HEDSTR          DS           256                                                             
     D  OFFSET                 1      4B 0                                                          
     D  NOENTR                 9     12B 0                                                          
     D  LSTSIZ                13     16B 0                                                          
                                                                                                    
     D RCD0100         DS                  QUALIFIED                                                
     D  RCD                          10A                                                            
                                                                                                    
     D SPCBIN          DS                                                                           
     D  INZSIZ                       10I 0 INZ(1000)                                                
     D  MSGDTALEN                    10I 0 INZ(100)                                                 
     D  PGMSTKCNT                    10I 0 INZ(1)                                                   
     D  STRPOS                       10I 0                                                          
     D  LENDTA                       10I 0                                                          
     D  N                             4S 0                                                          
     D  DATE                          6A                                                            
     D  TIME                          6A                                                            
                                                                                                    
     C*(1) QUSCRTUS: ユーザー・スペースの作成                                                       
     C*----------------------------------------------------+                                        
     C                   CALL      'QUSCRTUS'                                                       
     C                   PARM                    USRSPC                                             
     C                   PARM      'PF        '  EXATTR           10                                
     C                   PARM                    INZSIZ                                             
     C                   PARM      ' '           INZCHR            1                                
     C                   PARM      '*ALL      '  AUT              10                                
     C                   PARM                    TEXT             50                                
     C                   PARM      '*YES      '  REPLACE          10                                
     C                   PARM                    APIERR                                             
     C*----------------------------------------------------+                                        
     C     AVLBYT        CABNE     *ZEROS        SNDERR                                             
                                                                                                    
     C*(2) QUSLRCD:  レコード様式のリスト                                                           
     C*----------------------------------------------------+                                        
     C                   CALL      QUSLRCD                                                          
     C                   PARM                    USRSPC                                             
     C                   PARM      'RCDL0100'    FOTMAT            8                                
     C                   PARM                    FILFILLIB                                          
     C                   PARM      '0'           CHG               1                                
     C                   PARM                    APIERR                                             
     C*----------------------------------------------------+                                        
     C     AVLBYT        CABNE     *ZEROS        SNDERR                                             
                                                                                                    
     C*(3) QUSRTVUS : ヘッダー構造の読み取り                                                        
     C*----------------------------------------------------+                                        
     C                   CALL      'QUSRTVUS'                                                       
     C                   PARM                    USRSPC                                             
     C                   PARM      125           STRPOS                         |                   
     C                   PARM      16            LENDTA                         |                   
     C                   PARM                    HEDSTR                                             
     C                   PARM                    APIERR                                             
     C*----------------------------------------------------+                                        
     C     AVLBYT        CABNE     *ZEROS        SNDERR                                             
                                                                                                    
     C*(4) QUSRTVUS : リスト・セクションの読み取り                                                  
     C*    HEADER によって OFFSET,LSTSIZ を受取った                                                 
     C                   Z-ADD     OFFSET        STRPOS                                             
     C                   ADD       1             STRPOS                                             
     C                   Z-ADD     LSTSIZ        LENDTA                                             
     C*     リスト・サイズの分だけ LOOP して検索                                                    
     C     1             DO        NOENTR        N                              N=1-NOENTR          
     C*----------------------------------------------------+                                        
     C                   CALL      'QUSRTVUS'                           99      |                   
     C                   PARM                    USRSPC                         |                   
     C                   PARM                    STRPOS                         |                   
     C                   PARM                    LENDTA                         |                   
     C                   PARM                    RCD0100                        |                   
     C*----------------------------------------------------+                                        
     C*      ------( 処理の開始 - ここから )------                                                  
     C     'RECORD='     CAT(P)    RCD0100.RCD:0 DSP40            40                                
     C     DSP40         DSPLY                                                                      
     C*      ------( 処理の終了 - ここまで )------                                                  
     C                   ADD       LENDTA        STRPOS                                             
     C                   END                                                    N=1-NOENTR          
                                                                                                    
     C                   MOVE      *ON           *INLR                                              
     C     '** END **'   DSPLY                   ANS               1                                
     C                   RETURN                                                                     
     C     SNDERR        TAG                                                                        
     C     GETBYT        SUB       15            MSGDTALEN                                          
     C*----------------------------------------------------+                                        
     C                   CALL(E)   'QMHSNDPM'                                                       
     C                   PARM                    MSGID                          |                   
     C                   PARM                    MSGFFLIB                       |                   
     C                   PARM                    MSGDTA                         |                   
     C                   PARM                    MSGDTALEN                      |                   
     C                   PARM      '*ESCAPE   '  MSGTYPE          10            |                   
     C                   PARM      '*         '  PGMQUE           10            |                   
     C                   PARM                    PGMSTKCNT                      |                   
     C                   PARM      '    '        MSGKEY            4            |                   
     C                   PARM                    APIERR                                             
     C*----------------------------------------------------+                                        
     C                   MOVE      *ON           *INLR                                              
     C                   RETURN