|
midrange.com
>What is the best (easiest) way to pull in the system name or
>serial number for a RPG program?
Here is one way, adapted from Phil Hall's original C program if I remember
rightly. Specifics about MATMATR are probably best directed to the MI list.
H BNDDIR('QC2LE') DFTACTGRP(*NO) ACTGRP(*CALLER) debug
* dbgview(*list)
DsndMsg pr
D msgText 80 const
D matmatr PR EXTPROC('matmatr')
D attributes * VALUE
D attrLen 5I 0 VALUE
D machineAttributes...
D DS INZ
D MMTR_Template_Size...
D 10I 0
D MMTR_Bytes_Used...
D 10I 0
D MMTR_VPD 4096
D VPDOffsets DS INZ
D vRes1 8
D vMemOff 10i 0
D vPrcOff 10i 0
D vColOff 10i 0
D vCecOff 10i 0
D vPnlOff 10i 0
D vRes2 12
D vMemInstalled 5i 0
D vMemRequired 5i 0
d cecVPD DS INZ
d cCEC_read 4
d cManufacturin 4
d creserved1 4
d cType 4
d cModel 4
d cPseudo_Model 4
d cGroup_Id 4
d creserved2 4
d cSys_Type_Ext 1
d cFeature_Code 4
d cSerial_No 10
d creserved3 1
d panelVPD DS INZ
d preserved1 2
d pPanel_Type 4
d pModel 3
d pPart 12
d preserved2 4
d pManufacturin 4
d pROS_Part 12
d pROS_Card 10
d pROS_ID 1
d pROS_Flag 1
d pROS_Fix 1
d pSerial_No 10
D $MMTR_SERIAL_ S 5I 0 INZ(4)
D $MMTR_VPD_ S 5i 0 INZ(x'012c')
D prErrStruc DS inz
D prErrSSize 10i 0 inz(%len(prErrStruc))
D PrErrSUse 10i 0
D prErrSmsgID 7
D prErrSResrv 1
D prErrSData 80
d prRcvr s 128
d prRcvrLen s 10i 0 inz(%size(prRcvr))
d prFormat s 8 inz('PRDR0100')
d prPrdInfo s 27 inz('*OPSYS *CUR 0000*CODE ')
d prErr s like(prErrStruc)
d prRelease s 6
C EVAL MMTR_Template_Size =
%SIZE(machineAttributes)
C CALLP matmatr( %ADDR(machineAttributes) :
C $MMTR_VPD_ )
c eval VPDOffsets = %subst(MMTR_VPD:
c 1:
c %len(VPDOffsets))
c eval cecVPD = %subst(MMTR_VPD:
c vCecOff-7:
c %len(cecVPD))
c eval panelVPD = %subst(MMTR_VPD:
c vPnlOff-7:
c %len(panelVPD))
C eval prErr = prErrStruc
c call 'QSZRTVPR'
c parm prRcvr
c parm prRcvrLen
c parm prFormat
c parm prPrdInfo
c parm prErr
C eval prErrStruc = prErr
C eval prRelease = %subst(prRcvr: 20: 6)
c callp sndMsg('Type ' + %trim(cType) +
c ' model ' + %trim(cModel) +
c ' prc grp ' + %trim(cGroup_ID) +
c ' fc ' + %trim(cFeature_Code)
+
c ' serial ' + %trim(cSerial_No) +
c ' ' + %trim(
c
%editc(vMemInstalled:
c 'Z')) + ' meg' +
c ' rel ' + %trim(prRelease)
c )
C SETON LR
C RETURN
PsndMsg b
DsndMsg pi
D inpText 80 const
* Send message API parameters
D msgID s 7 inz('CPF9898')
D msgFil s 20 inz('QCPFMSG *LIBL ')
D msgData s like(inpText)
D msgDataLen s 10i 0 inz(%size(msgData))
D msgType s 10 inz('*INFO')
D msgStackEnt s 10 inz('*')
D msgStackCnt s 10i 0 inz(3)
D msgKey s 4
D msgErrStruc s like(ErrStruc)
* API error structure
D errStruc DS inz
D errSSize 10i 0 inz(%len(errStruc))
D errSUse 10i 0
D errSmsgID 7
D errSResrv 1
D errSData 80
C eval msgData = inpText
C eval msgErrStruc = errStruc
C Call 'QMHSNDPM'
C Parm msgID
C Parm msgFil
C Parm msgData
C Parm msgDataLen
C Parm msgType
C Parm msgStackEnt
C Parm msgStackCnt
C Parm msgKey
C Parm msgErrStruc
C Eval errStruc = msgErrStruc
PsndMsg e
Buck Calabro
Commsoft; Albany, NY
"Love truth but pardon error"
-- Voltaire
Visit the Midrange archives at http://www.midrange.com
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
