H NOMAIN                                                                                       
     F********** サービス・プログラム **************************************                        
     F*                                                                                             
     F**********************************************************************                        
                                                                                                    
      * CRTRPGMOD  OBJ(QTEMP/TESTSRV)   SRCFILE(R610SRC/QRPGLESRC)                                  
      * DBGVIEW(*SOURCE) AUT(*ALL)                                                                  
                                                                                                    
      * CRTSRVPGM SRVPGM(OBJLIB/TESTSRV) MODULE(QTEMP/TESTSRV) SRCFILE(SRCLIB/QSR                   
      * VSRC) ACTGRP(*CALLER) AUT(*ALL)                                                             
                                                                                                    
      *-------------------------------------------------------------------*                         
      *  2020/08/09 : 作成                                                                          
      *-------------------------------------------------------------------*                         
      *( 作業変数 )                                                                                 
     D MSR             S             80    DIM(1) CTDATA PERRCD(1)               配列               
     D AR              S              1A   DIM(256)                                                 
     D N               S              4S 0                                                          
                                                                                                    
      ****************************************************                                          
      *       プロシージャーのプロトタイプ宣言           *                                          
      ****************************************************                                          
     D*( SNDPGMMSG     のプロトタイプ宣言 )                                                         
     D SNDPGMMSG       PR                                                                           
     D  MSG                        3000A   Vｱﾂﾏｵ                                                    
     D  MSGTYPE_IN                   10A   ﾐｱﾂﾏｵ OPTIONS(*NOPASS)                                   
     D  CALLSTACKC_IN                10I 0 CONST OPTIONS(*NOPASS)                                   
                                                                                                    
      ****************************************************                                          
      *       プロシージャーの本体の記述                 *                                          
      ****************************************************                                          
      *********************************************************                                     
      *   SNDPGMMSG:  メッセージを現在の CALLSTACK に送信     *                                     
      *********************************************************                                     
      *---( SNDPGMMSG PROCEDURE  ここから )------------------------*                                
     P SNDPGMMSG       B                   EXPORT                                                   
     D                 PI                                                                           
     D  MSG                        3000A   Vｱﾂﾏｵ                                                    
     D  MSGTYPE_IN                   10A   ﾐｱﾂﾏｵ OPTIONS(*NOPASS)                                   
     D  CALLSTACKC_IN                10I 0 CONST OPTIONS(*NOPASS)                                   
                                                                                                    
     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 QMHSNDPM        PR                  EﾒﾎPｷﾃ('QMHSNDPM')                                       
     D  MSGID                         7A   CONST                                                    
     D  MSGFILE                      20A   CONST                                                    
     D  MSGDATA                    6000A   CONST OPTIONS(*ﾐｱﾈﾍｹﾔｵ)                                  
     D  MSGDATALEN                   10I 0 CONST                                                    
     D  MSGTYPE                      10A   CONST                                                    
     D  CALLSTACKE                   10A   CONST                                                    
     D  CALLSTACKC                   10I 0 CONST                                                    
     D  MSGKEY                        4A                                                            
     D  APIERR                             LIKEDS(APIERR)                                           
     D                                     OPTIONS(*VARSIZE)                                        
     D PARMS           S              4S 0                                                          
     D MSGKEY          S              4A                                                            
     D CALLSTACKC      S             10I 0 INZ(1)                                                   
     D MSGTYPE         S             10A   INZ('*DIAG     ')                                        
                                                                                                    
     C                   EVAL      PARMS = %PARMS()                                                 
     C                   SELECT                                                                     
     C                   WHEN      PARMS = 1                                                        
     C                   WHEN      PARMS = 2                                                        
     C                   EVAL      MSGTYPE = MSGTYPE_IN                                             
     C                   WHEN      PARMS = 3                                                        
     C                   EVAL      CALLSTACKC = CALLSTACKC_IN                                       
     C                   EVAL      MSGTYPE = MSGTYPE_IN                                             
     C                   ENDSL                                                                      
      /FREE                                                                                         
        QMHSNDPM('CPF9897':'QCPFMSG   *LIBL':MSG:                                                   
                 %LEN(%TRIM(MSG)):MSGTYPE:'*PGMBDY':                                                
                 CALLSTACKC:MSGKEY:APIERR);                                                         
      /END-FREE                                                                                     
     C                   RETURN                                                                     
     P                 E                                                                            
      *---( SNDPGMMSG    PROCEDURE  ここまで )------------------------*