A Test Program
**
** Program . . : CBX131T
** Description : Retrieve system information - test
** Author . . : Carsten Flensburg
** Published . : Club Tech iSeries Programming Tips Newsletter
** Date . . . : February 24, 2005
**
** Program summary
** ---------------
**
** User interface manager APIs:
** QUILNGTX Display long text Displays the text string passed
** to the API in a pop-up window.
** Optionally a panel title can be
** retrieved from a message file.
**
** Maximum string length is 15360k.
**
** Message handling API:
** QMHSNDPM Send program message Sends a message to a program stack
** entry (current, previous, etc.) or
** an external message queue.
**
** Both messages defined in a message
** file and immediate messages can be
** used. For specific message types
** only one or the other is allowed.
**
** QMHRCVPM Receive program Returns information describing
** message the selected message in a call
** message queue or, as in this
** case, an external message queue.
**
**
** Programmer's notes:
** To run this API Example program issue the following command from
** a command line:
**
** Call Pgm( CBX131T )
**
**
** Compile options required:
** CrtRpgMod Module( CBX131T )
** DbgView( *LIST )
**
** CrtPgm Pgm( CBX131T )
** Module( CBX131T )
** BndSrvPgm( CBX131 )
** ActGrp( QILE )
**
**
**-- Control spec: -----------------------------------------------------**
H Option( *SrcStmt ) BndDir( 'QC2LE' )
**-- API error data structure: -----------------------------------------**
D ERRC0100 Ds Qualified
D BytPrv 10i 0 Inz( %Size( ERRC0100 ))
D BytAvl 10i 0
D MsgId 7a
D 1a
D MsgDta 128a
**-- Global variables:
D SysCcsId s 10i 0
D NetVrtAutDev s 10i 0
D SysVal s 128a Varying
**-- Global constants:
D NULL c ''
**-- Get system release level:
D GetRlsLvl Pr 6a
**-- Get system state:
D GetSysStt Pr 1a Varying
**-- Get system value:
D GetSysVal Pr 4096a Varying
D PxSysVal 10a Const
**-- Get network attribute:
D GetNetAtr Pr 4096a Varying
D PxNetAtr 10a Const
**-- Get IPL timestamp:
D GetIplDts Pr z
**-- Get cumulative PTF package level:
D GetCumLvl Pr 5s 0
**-- Get processor group:
D GetPrcGrp Pr 4a
**-- Get processor type:
D GetPrcTyp Pr 4a
**-- Get key position:
D GetKeyPos Pr 6a
**-- Get IPL type:
D GetIplTyp Pr 1a
**-- Display long text:
D DspLngTxt Pr ExtPgm( 'QUILNGTX' )
D DtLngTxt 32767a Const Options( *VarSize )
D DtLngTxtLen 10i 0 Const
D DtMsgId 7a Const
D DtMsgF 20a Const
D DtError 32767a Const Options( *VarSize )
**-- Send program message:
D SndPgmMsg Pr ExtPgm( 'QMHSNDPM' )
D SpMsgId 7a Const
D SpMsgFq 20a Const
D SpMsgDta 512a Const Options( *VarSize )
D SpMsgDtaLen 10i 0 Const
D SpMsgTyp 10a Const
D SpCalStkE 10a Const Options( *VarSize )
D SpCalStkCtr 10i 0 Const
D SpMsgKey 4a
D SpError 512a Options( *VarSize )
**
D SpCalStkElen 10i 0 Const Options( *NoPass )
D SpCalStkEq 20a Const Options( *NoPass )
D SpDspWait 10i 0 Const Options( *NoPass )
**
D SpCalStkEtyp 20a Const Options( *NoPass )
D SpCcsId 10i 0 Const Options( *NoPass )
**-- Receive program message:
D RcvPgmMsg Pr ExtPgm( 'QMHRCVPM' )
D RpRcvVar 32767a Options( *VarSize )
D RpRcvVarLen 10i 0 Const
D RpFmtNam 10a Const
D RpCalStkE 256a Const Options( *VarSize )
D RpCalStkCtr 10i 0 Const
D RpMsgTyp 10a Const
D RpMsgKey 4a Const
D RpWait 10i 0 Const
D RpMsgAct 10a Const
D RpError 32767a Options( *VarSize )
**
D RpCalStkElen 10i 0 Const Options( *NoPass ) call stack counter
D RpCalStkEq 20a Const Options( *NoPass ) call stack counter
**
D RpCalStkEtyp 20a Const Options( *NoPass ) call stack counter
D RpCcsId 10i 0 Const Options( *NoPass ) call stack counter
**-- Prototype atoi:
D Int Pr 10i 0 ExtProc( 'atoi' )
D Num * Value Options( *String )
**-- Prototype atoll:
D Long Pr 20i 0 ExtProc( 'atoll' )
D Num * Value Options( *String )
**-- Display message window:
D DspMsgWdw Pr
D PxMsgStr 512a Const Varying
**-- Get inquiry message reply:
D GetInqRpy Pr 10a Varying
D PxMsgDta 512a Const Varying
/Free
DspMsgWdw ( 'Last system IPL date and time: ' + %Char( GetIplDts()));
DspMsgWdw ( 'Current system CUM level: ' + %Char( GetCumLvl()));
DspMsgWdw ( 'Current system state: ''' + GetSysStt() +
''' 0=Non-restricted, 1=Restricted' );
DspMsgWdw ( 'Current system release level: ' + GetRlsLvl());
DspMsgWdw ( 'System processor group: ' + GetPrcGrp());
DspMsgWdw ( 'System processor type: ' + GetPrcTyp());
DspMsgWdw ( 'System panel key lock position: ' + GetKeyPos());
DspMsgWdw ( 'System panel current IPL type: ''' + GetIplTyp() + '''' );
DspMsgWdw ( 'System value ''QUSRLIBL'': ' +
GetSysVal( 'QUSRLIBL' ));
DspMsgWdw ( 'System value ''QCCSID'': ' +
GetSysVal( 'QCCSID' ));
SysCcsId = Int( GetSysVal( 'QCCSID' ));
DspMsgWdw ( 'System value ''QSRLNBR'': ' +
GetSysVal( 'QSRLNBR' ));
DspMsgWdw ( 'Net attribute ''DDMACC'': ' +
GetNetAtr( 'DDMACC' ));
DspMsgWdw ( 'Net attribute ''VRTAUTODEV'': ' +
GetNetAtr( 'VRTAUTODEV' ));
NetVrtAutDev = Int( GetNetAtr( 'VRTAUTODEV' ));
DspMsgWdw ( 'Net attribute ''SYSNAME'': ' +
GetNetAtr( 'SYSNAME' ));
SysVal = GetInqRpy( 'Please enter a system value to retrieve:' );
DspMsgWdw ( 'System value ''' + SysVal + ''': ' +
GetSysVal( SysVal ));
Return;
/End-Free
**-- Display message window: -------------------------------------------**
P DspMsgWdw B
D Pi
D PxMsgStr 512a Const Varying
/Free
DspLngTxt( PxMsgStr: %Len( PxMsgStr ): *Blanks: *Blanks: ERRC0100 );
/End-Free
P DspMsgWdw E
**-- Get inquiry message reply: ----------------------------------------**
P GetInqRpy B
D Pi 10a Varying
D PxMsgDta 512a Const Varying
**
D MsgKey s 4a
**-- Message information structure:
D RCVM0100 Ds Qualified
D BytPrv 10i 0
D BytAvl 10i 0
D MsgSev 10i 0
D MsgId 7a
D MsgTyp 2a
D MsgKey 4a
D 7a
D CcsIdCnvSts 10i 0
D CcsIdDta 10i 0
D MsgLenRtn 10i 0
D MsgLenAvl 10i 0
D MsgRpy 32a
/Free
SndPgmMsg( *Blanks
: *Blanks
: PxMsgDta
: %Len( PxMsgDta )
: '*INQ'
: '*EXT'
: *Zero
: MsgKey
: ERRC0100
);
RcvPgmMsg( RCVM0100
: %Size( RCVM0100 )
: 'RCVM0100'
: '*'
: *Zero
: '*RPY'
: MsgKey
: -1
: '*OLD'
: ERRC0100
);
If RCVM0100.MsgLenRtn > 10;
RCVM0100.MsgLenRtn = 10;
EndIf;
Return %Subst( RCVM0100.MsgRpy: 1: RCVM0100.MsgLenRtn );
/End-Free
P GetInqRpy E
Thanks to Carsten Flensburg writing for
Club Tech iSeries Programming Tips Newsletter
阅读(1771) | 评论(0) | 转发(0) |
