home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Software of the Month Club 1994 October
/
SOFM_Oct1994.bin
/
pc
/
os2
/
pds
/
pdsrgstr.cmd
< prev
next >
Wrap
OS/2 REXX Batch file
|
1994-06-19
|
18KB
|
691 lines
/*REXX*/
/***
signal on HALT name HaltExit
signal on ERROR name ErrorExit
signal on FAILURE name FailureExit
signal on SYNTAX name SyntaxExit
***/
main:
parse arg p1
sGlobal.fDebug = 'N'
sGlobal.sFileSpec = 'PDSRGSTR.TXT'
sGlobal.iBSFctr= 15.00
sGlobal.iRXFctr= 5.00
sGlobal.iHLFctr= 10.00
fDebugQ = sGlobal.fDebug
fDispStax= 'N'
fDispHelp= 'N'
fFlSpecQ = 'N'
sFlSpec = sGlobal.sFileSpec
CALL rParseParms p1
if fDebugQ = 'Y' then
do
trace ?r
end
if fDispStax = 'Y' then
do
CALL rDispSyntax 0, 0
end
if fDispHelp = 'Y' then
do
CALL rDispSyntax 1, 0
end
/* Actual routine */
rc = rLoadFuncs('rxPDLoadFuncs', 'HSSPD', 'rxPDLoadFuncs')
if rc <> 0 then
do
Call rSiren 1, 1
say 'PDSRGSTR - Unable to initialize the "RXPD" subsystem'
exit 8
end
sGlobal.fModifiedQ = 'N'
sGlobal.sCursorFld='sName'
sGlobal.iCursorNdx=0
sGlobal.fDebug=fDebugQ
sGlobal.fDebug = fDebugQ
sGlobal.sFileSpec = TRANSLATE(sFlSpec)
sName = ''
sAddr1 = ''
sAddr2 = ''
sAddr3 = ''
sCity = ''
sState = ''
sCountry = ''
sZip = ''
sEMail = ''
sHowAcquired = ''
iBS = 0
iRX = 0
iHL = 0
iTBS = 0
iTRX = 0
iTHL = 0
iTotal = 0
sGlobal.zBid = rxPDInit('PDSRGSTR','GREENHI','YELLOWHI','LBLUEHI',,43,80)
if sGlobal.zBid = x2c(00000000) then
do
Call rSiren 2, 3
say 'PDSRGSTR - Error to initializing the "RXPD" subsystem'
exit 8
end
Call rxPDZVarDefine
iNumAttr = ZVTYPE_LONG+ZVTYPE_RIGHTADJUST
iDblAttr = ZVTYPE_DOUBLE+ZVTYPE_RIGHTADJUST
rc = rxPDVarDefine(sGlobal.zBid, 'iBS', iNumAttr, 0)
rc = rxPDVarDefine(sGlobal.zBid, 'iRX', iNumAttr, 0)
rc = rxPDVarDefine(sGlobal.zBid, 'iHL', iNumAttr, 0)
rc = rxPDVarDefine(sGlobal.zBid, 'iTBS', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'iTRX', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'iTHL', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'sGlobal.iBSFctr', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'sGlobal.iRXFctr', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'sGlobal.iHLFctr', iDblAttr, 2)
rc = rxPDVarDefine(sGlobal.zBid, 'iTotal', iDblAttr, 2)
akey = rxPDDisplay(sGlobal.zBid,'PANEL000')
do while 0 = rDoEdit(sGlobal.zBid)
end /* do while 0 = rDoEdit() */
/* Save the file */
if sGlobal.fModifiedQ = 'Y' then
do
Call rDoSAVE
end
rc = rxPDTerm(sGlobal.zBid)
exit 0
/**********************************************************************\
rDoEdit:
This routine displays a dialog panel for the file.
\**********************************************************************/
rDoEdit:
parse arg sGlobal.zBid
DROP sFlRecs.
Call rLoadFileStem
Call rLoadPDStem
do FOREVER
akey = ZESC
ZCMD = ''
ZAMT = 'CSR'
do while akey = ZESC
akey = rxPDDisplay(sGlobal.zBid, 'PANEL001', sGlobal.sCursorFld, sGlobal.iCursorNdx)
parse var ZCurVar ziCol zFld
sGlobal.sCursorFld = zFld
sGlobal.iCursorNdx = ziCol
if aKey = ZESC then
do
Call rLoadPDStem
end
end /*do while akey = ZESC*/
sGlobal.iMDTCnt = rxPDQueryMDT(sGlobal.zBid,'PANEL001')
if sGlobal.iMDTCnt > 0 then
do
sGlobal.fModifiedQ = 'Y'
end
select
when akey = ZENTER then
do
Call rDoENTER
end
when akey = Z_S_A then
do
Call rDoSAVE
end
when akey = Z_C_A then
do
Call rDoCLEAR
end
when akey = ZF3_A then
do
sGlobal.fModifiedQ = 'N'
return 8
end
when akey = ZF4_A then
do
return 8
end
otherwise
do
Call rSiren 4,3
sGlobal.sCursorFld='ZCMD'
sGlobal.iCursorNdx=0
end
end /* select */
end /*do FOREVER */
return 0;
/**********************************************************************\
rDoENTER
Routine to handle ENTER
\**********************************************************************/
rDoENTER:
if sGlobal.iMDTCnt = 0 then
do
return 0
end
select
when sGlobal.sCursorFld = 'sName' then
do
sGlobal.sCursorFld = 'sAddr1'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sAddr1' then
do
sGlobal.sCursorFld = 'sAddr2'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sAddr2' then
do
sGlobal.sCursorFld = 'sAddr3'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sAddr3' then
do
sGlobal.sCursorFld = 'sCity'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sCity' then
do
sGlobal.sCursorFld = 'sState'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sState' then
do
sGlobal.sCursorFld = 'sCountry'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sCountry' then
do
sGlobal.sCursorFld = 'sZip'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sZip' then
do
sGlobal.sCursorFld = 'sEMail'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'sEMail' then
do
sGlobal.sCursorFld = 'iBS'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'iBS' then
do
sGlobal.sCursorFld = 'iRX'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'iRX' then
do
sGlobal.sCursorFld = 'iHL'
sGlobal.iCursorNdx = 0
end
when sGlobal.sCursorFld = 'iHL' then
do
sGlobal.sCursorFld = 'sHowAcquired'
sGlobal.iCursorNdx = 0
end
otherwise
do
sGlobal.sCursorFld = 'sName'
sGlobal.iCursorNdx = 0
end
end /*select*/
Call rDoCOMPUTE
return
/**********************************************************************\
rDoSAVE
Routine to handle SAVE
\**********************************************************************/
rDoSAVE:
sGlobal.fModifiedQ = 'N'
return rStoreFileStem()
/**********************************************************************\
rDoCLEAR
Routine to handle CLEAR
\**********************************************************************/
rDoCLEAR:
sGlobal.fModifiedQ = 'Y'
sName = ''
sAddr1 = ''
sAddr2 = ''
sAddr3 = ''
sCity = ''
sState = ''
sCountry = ''
sZip = ''
sEMail = ''
sHowAcquired = ''
iBS = 0
iRX = 0
iHL = 0
Call rDoCOMPUTE
return 0
/**********************************************************************\
rDoCOMPUTE
Routine to handle COMPUTE
\**********************************************************************/
rDoCOMPUTE:
iTBS = FORMAT(iBS * sGlobal.iBSFctr,6,2)
iTRX = FORMAT(iRX * sGlobal.iRXFctr,6,2)
iTHL = FORMAT(iHL * sGlobal.iHLFctr,6,2)
iTotal = iTBS + iTRX + iTHL
iTotal = FORMAT(iTotal,6,2)
return 0
/**********************************************************************\
rLoadPDStem:
This routine loads the display variables from the file stem.
\**********************************************************************/
rLoadPDStem:
if sGlobal.fDebug = 'RLOADPDSTEM' then
do
Call Trace ?r
end
iAddr = 0
do i = 1 to sFlRecs.0
parse var sFlRecs.i sFld': 'sVal
select
when 'Name .' = LEFT(sFld,6) then
do
sName = sVal
end
when 'Address .' = LEFT(sFld,9) then
do
iAddr = 1
sAddr1 = sVal
end
when '' = sFld then
do
if iAddr > 0 & iAddr < 3 then
do
iAddr = iAddr + 1
INTERPRET 'sAddr'iAddr' = sVal'
end
end
when 'City .' = LEFT(sFld,6) then
do
sCity = sVal
end
when 'State .' = LEFT(sFld,7) then
do
sState = sVal
end
when 'Country .' = LEFT(sFld,9) then
do
sCountry = sVal
end
when 'Zip/Post' = LEFT(sFld,8) then
do
sZip = sVal
end
when 'EMail ID' = LEFT(sFld,8) then
do
sEMail = sVal
end
when 'PDS Base' = LEFT(sFld,8) then
do
iBS = STRIP(WORD(sVal,1))
if DATATYPE(iBS) <> 'NUM' then
do
iBS = 0
end
end
when 'PDS REXX' = LEFT(sFld,8) then
do
iRX = STRIP(WORD(sVal,1))
if DATATYPE(iRX) <> 'NUM' then
do
iRX = 0
end
end
when 'PDS HLL ' = LEFT(sFld,8) then
do
iHL = STRIP(WORD(sVal,1))
if DATATYPE(iHL) <> 'NUM' then
do
iHL = 0
end
end
when 'Acquired' = LEFT(sFld,8) then
do
sHowAcquired = sVal
end
otherwise
do
end
end /*select*/
end /*do i = 1 to sFlRecs.0*/
Call rDoCOMPUTE
return 0;
/**********************************************************************\
rLoadFileStem:
This routine loads the file stem variable.
\**********************************************************************/
rLoadFileStem:
if sGlobal.fDebug = 'RLOADFILESTEM' then
do
Call Trace ?r
end
DROP sFlRecs.
i = 0
sFlRecs.0 = i
if sGlobal.sFileSpec <> '' then
do
state = stream(sGlobal.sFileSpec,'c','query exists')
if state <> '' then
do
sGlobal.sFileSpec = state /* Fully qualified file name */
rc = rOpenFlSpec(sGlobal.sFileSpec)
if rc <> 0 then
do
return 8
end
sEOF='EOF>>'||sGlobal.sFileSpec||'<<EOF'
sRec = rGetFileRec(sGlobal.sFileSpec,sEOF)
do while sRec <> sEOF
if 0 < POS(':',sRec) then
do
i = i + 1
sFlRecs.i = STRIP(sRec)
end
sRec = rGetFileRec(sGlobal.sFileSpec,sEOF)
end /*do while sRec <> sEOF*/
rc = rCloseFlSpec(sGlobal.sFileSpec)
end
end
sFlRecs.0 = i
return 0
rGetFileRec: Procedure
parse arg sGetFile, sEOF
if 0 = lines(sGetFile) then
return sEOF
rec = linein(sGetFile)
do while '' = rec
if 0 = lines(sGetFile) then
return sEOF
rec = linein(sGetFile)
end
return rec
/**********************************************************************\
rStoreFileStem:
This routine store the file stem variable.
\**********************************************************************/
rStoreFileStem:
if sGlobal.fDebug = 'RSTOREFILESTEM' then
do
Call Trace ?r
end
i = 1
if sGlobal.sFileSpec = '' then
do
Call BEEP 882, 40
return 4
end
rc = rOpenFlSpec(sGlobal.sFileSpec,'REPL')
if rc <> 0 then
do
return 8
end
rc = rWriteForm(sGlobal.sFileSpec)
rc = rCloseFlSpec(sGlobal.sFileSpec)
return 0
/**********************************************************************\
rWriteForm:
This routine writes the form to disk
\**********************************************************************/
rWriteForm:
parse arg sFS
iBS=FORMAT(iBS,4)
iBSF=FORMAT(sGlobal.iBSFctr,2,2)
iRX=FORMAT(iRX,4)
iRXF=FORMAT(sGlobal.iRXFctr,2,2)
iHL=FORMAT(iHL,4)
iHLF=FORMAT(sGlobal.iHLFctr,2,2)
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Rick W. Hodgson'
Call rWriteFlSpec sFS,' 1635 Village Glen Dr.'
Call rWriteFlSpec sFS,' Raleigh, NC 27612'
Call rWriteFlSpec sFS,' CIS: 76450,3137'
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Registration Form for the HSS Panel Display System V1.05:'
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Name ..........: 'sName
Call rWriteFlSpec sFS,' Address .......: 'sAddr1
Call rWriteFlSpec sFS,' : 'sAddr2
Call rWriteFlSpec sFS,' : 'sAddr3
Call rWriteFlSpec sFS,' City ..........: 'sCity
Call rWriteFlSpec sFS,' State .........: 'sState
Call rWriteFlSpec sFS,' Country .......: 'sCountry
Call rWriteFlSpec sFS,' Zip/Postal Code: 'sZip
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' EMail ID ......: 'sEMail
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Component Count Total'
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' PDS Base system ...: 'iBS ' X $'iBSF' 'iTBS
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' PDS REXX API ......: 'iRX ' X $'iRXF' 'iTRX
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' PDS HLL API .......: 'iHL ' X $'iHLF' 'iTHL
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Total ...: 'iTotal
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' In order to get a better idea of how to distribute shareware, I would'
Call rWriteFlSpec sFS,' appreciate knowing the how you acquired this package. I.E. Compuserve,'
Call rWriteFlSpec sFS,' Internet, OS/2 User''s Group, etc..'
Call rWriteFlSpec sFS,''
Call rWriteFlSpec sFS,' Acquired via ..: 'sHowAcquired
Call rWriteFlSpec sFS,''
return 0
/**********************************************************************\
rOpenFlSpec:
This routine opens the file for processing and inits the pointer
\**********************************************************************/
rOpenFlSpec: Procedure Expose sGlobal.
parse arg sFlSpec, sRepl
state = stream(sFlSpec,'c','open')
if state <> 'READY:' then
do
svid = rxPDSaveScreen(sGlobal.zBid)
rc = rxPDDisplay(sGlobal.zBid,'PUPOPENERR')
rc = rxPDRestoreScreen(sGlobal.zBid,svid)
return 8
end
if TRANSLATE(sRepl) = 'REPL' then
do
rc = LINEIN(sFlSpec,1,0)
end
return 0
/**********************************************************************\
rCloseFlSpec:
This routine closes the TSD
\**********************************************************************/
rCloseFlSpec:
parse arg sFlSpec
state = stream(sFlSpec,'c','close')
return 0
/**********************************************************************\
rWriteFlSpec:
This routine sequentially writes the file
\**********************************************************************/
rWriteFlSpec:
parse arg sFlSpec, sRec
err = lineout(sFlSpec,sRec)
if err <> 0 then
do
svid = rxPDSaveScreen(sGlobal.zBid)
rc = rxPDDisplay(sGlobal.zBid,'PUPWRITEERR')
rc = rxPDRestoreScreen(sGlobal.zBid,svid)
rc = rxPDTerm(sGlobal.zBid)
exit 256
end
return 0
HaltExit:
Call BEEP 882, 40
Call BEEP 882, 40
say 'PDSRGSTR processing halted by request;'
exit 0
ErrorExit:
Call BEEP 882, 40
Call BEEP 882, 40
say 'PDSRGSTR processing failed due to unknown error;'
exit 24
FailureExit:
Call BEEP 882, 40
Call BEEP 882, 40
say 'PDSRGSTR processing failed due to unknown failure;'
exit 32
SyntaxExit:
Call BEEP 882, 40
Call BEEP 882, 40
say 'PDSRGSTR processing failed due to syntax error;'
exit 64
rParseParms:
parse arg p1
do Forever
w1 = word(p1,1)
parse var w1 with "/" f1 ":" v1
select
when (w1 = '') then
do
return 0
end
when TRANSLATE(w1) = '/DEBUG' then
do
fDebugQ='Y'
p1 = SUBWORD(p1,2)
end
when TRANSLATE(f1) = 'D' then
do
fDebugQ = TRANSLATE(v1)
p1 = SUBWORD(p1,2)
end
when TRANSLATE(f1) = '?' then
do
fDispStax='Y'
fDispHelp='N'
p1 = SUBWORD(p1,2)
end
when TRANSLATE(f1) = 'H' then
do
fDispStax='N'
fDispHelp='Y'
p1 = SUBWORD(p1,2)
end
otherwise
do
select
when fFlSpecQ <> 'Y' then
do
fFlSpecQ = 'Y'
sFlSpec = w1
p1 = SUBWORD(p1,2)
end
otherwise
do
Call rSiren 8, 1
say 'PDSRGSTR - Too many parms specified; Parm "'w1'" unknown;'
CALL rDispSyntax 0 8
end
end /*select*/
end
end
end
return 0
rDispSyntax: Procedure
parse upper arg iHelp iExit
say ' Syntax : PDSRGSTR {<options>} {filespec}'
say ' PDSRGSTR {/?|/h}'
if iHelp > 0 then
do
CALL rDispHelp
end
exit iExit
rDispHelp: Procedure
say ' Parms : filespec - Alternate file name for the registration form.'
say ''
say ' Options : /? - Display command syntax.'
say ' /h - Display this help info.'
say ' Examples:'
say ' PDSRGSTR /h'
say ' '
say ' PDSRGSTR config.sys'
return ''
/* rSiren: does the siren bit by running the scale based upon a */
/* frequency specified by the caller. */
rSiren: Procedure
Parse Arg freq, cycle
note.1 = 262 * freq /* middle C */
note.2 = 294 * freq /* D */
note.3 = 330 * freq /* E */
note.4 = 349 * freq /* F */
note.5 = 392 * freq /* G */
note.6 = 440 * freq /* A */
note.7 = 494 * freq /* B */
note.8 = 524 * freq /* C */
do j = 1 to cycle
call beep note.8,250 /* hold each note for a 1/4 second */
call beep note.1,250 /* hold each note for a 1/4 second */
end j
Return
rLoadFuncs:
parse arg sREP, sDll, sRtn
rxrc = RxFuncAdd(sREP, sDll, sRtn)
signal on syntax name xLoadFuncs
interpret 'Call 'sRtn
return 0
xLoadFuncs:
return 127