gure B-3 Structure of Example Pascal Program
Structure of Example Pascal Program

$uslinit$
$standard_level 'HP3000'; tables on; code_offsets on; xref on$
$global 'SPL'$
$PAGE$

program credit(input,output);

{ Date written: August, 1987.}
{ Date compiled: August, 1987.}

const
ACCEPT_CODE = '3';
DATA_COMPLETE = 1;
FULL_RECORD = 80;
LENGTH_REMOTE_TPNAME = 4;
NO_SW = false;
YES_SW = true;
ON = 2;
CONVSYNCLEVEL = 0;
SEND = 4;
SOC_SEC_ERROR_CD = 1;
SYSTEM_ERROR_CD = 3;
TRANSLATE_TO_ASCII = 1;
TRANSLATE_TO_EBCDIC = 2;
TRANSLENGTH = 30;
YES = ['y', 'Y'];

AllocateErrMsg = text ['Allocate Error '];
CTranslateErrMsg = text ['CTranslate Error '];
DeallocateErrMsg = text ['Deallocate Error '];
EndedErrMsg = text ['TP Ended Error '];
RcvAndWaitErrMsg = text ['RcvAndWait Error '];
SendDataErrMsg = text ['Send Data Error '];
StartedErrMsg = text ['TP Started Error '];
WhatReceivedErrMsg = text ['What Received Error '];

type
shortint = -32768..32767;
pac4type = packed array [1..4] of char;
nametype = packed array [1..10] of char;
errmsgtype = packed array [1..20] of char;
ssnumtype = packed array [1..9] of char;
balancetype = packed array [1..6] of char;

MasterDataType = record
case shortint of
0: (SocSecMaster : ssnumtype;
LastNameMaster : nametype;
FirstNameMaster : nametype;
MINameMaster : char;
CoCodeMaster1 : char;
BalanceMaster1 : balancetype;
CoCodeMaster2 : char;
BalanceMaster2 : balancetype;
CoCodeMaster3 : char;
BalanceMaster3 : balancetype;
CoCodeMaster4 : char;
BalanceMaster4 : balancetype;
CoCodeMaster5 : char;
BalanceMaster5 : balancetype;
Filler : packed array [1..14] of char;
RiskCodeMaster : char);
1: (ErrorCode : pac4type;
ErrorFiller : packed array [1..76] of char);
end;

short_text = packed array [1..8] of char;
text = packed array [1..20] of char;
TPNameType = packed array [1..LENGTH_REMOTE_TPNAME] of char;

TransDataType = record
SocSecTrans : ssnumtype;
LastNameTrans : nametype;
FirstNameTrans: nametype;
MINameTrans : char;
end;
hpe_status = record
case integer of
0 : (all : integer);
1 : (info : shortint;
subsys : shortint);
end;

var
LocalTPName,
SessionType : short_text;
RemoteTPNameASCII : TPNameType;
ResourceID,
TPID,
TraceOn,
ReceiveLength,
WhatReceived,
DeallocateType : shortint;
TransData : TransDataType;
Ready : char;
Quit_SW : boolean;

procedure TPStarted; intrinsic;
procedure TPEnded; intrinsic;
procedure MCAllocate; intrinsic;
procedure MCDeallocate; intrinsic;
procedure MCSendData; intrinsic;
procedure MCRcvAndWait; intrinsic;
procedure CTranslate; intrinsic;
function bin $alias 'binary'$ : shortint; intrinsic;
$PAGE$

{************************************************************
ErrorHandler
This procedure returns the error message associated
with a status info value.
************************************************************}

procedure ErrorHandler (IntrinsicMsg : text;
Status : shortint;
var Quit_SW : boolean);

begin
Quit_SW := YES_SW;
writeln (IntrinsicMsg, Status:3);
end;

$PAGE$

{************************************************************
GetFullScreenData
This procedure prompts the user for data and receives
the data from the terminal. ************************************************************}

procedure GetFullScreenData (var TransData : TransDataType);

begin
with TransData do
begin
SocSecTrans := ' ';
LastNameTrans := ' ';
FirstNameTrans := ' ';
MINameTrans := ' ';

writeln ('Credit Risk Check.');
writeln;

writeln ('Social Security Number:');
readln (SocSecTrans);

writeln ('Last Name:');
readln (LastNameTrans);

writeln ('First Name:');
readln (FirstNameTrans);

writeln ('Middle Initial:');
readln (MINameTrans);

end;
end;

$PAGE$

{************************************************************
BeginHouseKeeping
This procedure calls TPStarted to initialize resources
for the local TP, and then it calls MCAllocate to
allocate a conversation with the remote TP. ************************************************************}

procedure BeginHouseKeeping (LocalTPName : short_text;
RemoteTPNameASCII : TPNameType;
SessionType : short_text;
var TPID, ResourceID : shortint;
TraceOn : shortint;
var Quit_SW : boolean);

var
IntrinsicStatus : hpe_status;
RemoteTPNameEBCDIC : TPNameType;

begin
Quit_SW := NO_SW;

TPStarted (LocalTPName, TPID, IntrinsicStatus, TraceOn);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (StartedErrMsg, IntrinsicStatus.info, Quit_SW)

else
begin
CTranslate (TRANSLATE_TO_EBCDIC, RemoteTPNameASCII,
RemoteTPNameEBCDIC, LENGTH_REMOTE_TP_NAME);

if CCode = 1 then
begin
Quit_SW := YES_SW;
writeln (CTranslateErrMsg, 'CCL - Remote TP Name not translated.');
end

else
begin
MCAllocate (TPID, SessionType, RemoteTPNameEBCDIC,
LENGTH_REMOTE_TP_NAME, ResourceID, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (AllocateErrMsg, IntrinsicStatus.info, Quit_SW);

end;
end;
end;

$PAGE$

{************************************************************
SendData
This procedure translates the data received from the
user's screen into EBCDIC and sends it to the remote TP. ************************************************************}

procedure SendData (ResourceID : shortint;
TransData : TransDataType;
var Quit_SW : boolean);

var
IntrinsicStatus : hpe_status;
ReqToSendRec : shortint;

begin
CTranslate (TRANSLATE_TO_EBCDIC, TransData, TransData, TRANSLENGTH);

if CCode = 1 then
begin
Quit_SW := YES_SW;
writeln (CTranslateErrMsg, 'CCL - TransData not translated.');
end

else
begin
MCSendData (ResourceID, TransData, TRANSLENGTH,
ReqToSendRec, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (SendDataErrMsg, IntrinsicStatus.info, Quit_SW);
end;
end;

$PAGE$

{************************************************************
QuitScreen
This procedure asks the user if he or she is ready to
quit. If the user responds 'Y', this procedure changes
Quit_SW to YES_SW. ************************************************************}

procedure QuitScreen (var Quit_SW : boolean);

begin
writeln ('Ready to quit (Y/N)?');
readln (Ready);

if Ready in YES then
Quit_SW := YES_SW;
end;

$PAGE$

{************************************************************
DisplayAcceptance
This procedure evaluates the Risk Code received from the
remote TP to determine whether to approve or deny credit,
and then it writes a message to the user's terminal. ************************************************************}

procedure DisplayAcceptance (RiskCode : shortint;
var Quit_SW : boolean);

begin
if ord(RiskCode) << ord(ACCEPT_CODE) then
writeln ('Credit Denied.')

else
writeln ('Credit Approved.');

QuitScreen (Quit_SW);
end;

$PAGE$

{************************************************************
DisplayErrorMessage
This procedure evaluates the errorcode returned by the
remote TP and writes an error message to the user's
terminal. The remote TP can return any of 3 error codes:
001 - The SS# is not in the database.
002 - The SS# is in the database, but the name does
not match the name sent by the HP 3000.
003 - Miscellaneous system errors.
Error codes 001 and 002 cause this procedure to call
QuitScreen. Error code 003 causes this procedure to
set Quit_SW to YES_SW. ************************************************************}

procedure DisplayErrorMessage (ErrorCode : shortint;
var Quit_SW : boolean);

begin
if ErrorCode = SYSTEM_ERROR_CD then
begin
writeln (errorcode:4);
Quit_SW := YES_SW;
end

else
begin
if ErrorCode = SOCSEC_ERROR_CD then
writeln ('SS# not on file - Credit Denied.')
else
writeln ('Invalid Name');
QuitScreen (Quit_SW);
end;
end;

$PAGE$

{************************************************************
ReceiveData
This procedure calls MCRcvAndWait twice: once to
receive a data record from the remote TP and once to
receive the instruction to change to Send state. If
this procedure receives a complete data record, it
calls CTranslate to translate it to ASCII. ************************************************************}

procedure ReceiveData (ResourceID : shortint;
var Quit_SW : boolean);

var
IntrinsicStatus : hpe_status;
MasterData : MasterDataType;
ReqToSendRec : shortint;

begin
ReceiveLength := FULL_RECORD;

MCRcvAndWait (ResourceID, ReceiveLength, ReqToSendRec, MasterData,
WhatReceived, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (RcvAndWaitErrMsg, IntrinsicStatus.info, Quit_SW)

else
begin
if WhatReceived <<>> DATA_COMPLETE then
ErrorHandler (WhatReceivedErrMsg, WhatReceived, Quit_SW)

else
begin
MCRcvAndWait (ResourceID, ReceiveLength, ReqToSendRec,
MasterData, WhatReceived, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (RcvAndWaitErrMsg, IntrinsicStatus.info, Quit_SW)

else
begin
if WhatReceived <<>> SEND then
ErrorHandler (WhatReceivedErrMsg, WhatReceived,
Quit_SW)

else
begin
CTranslate (TRANSLATE_TO_ASCII, MasterData, MasterData,
ReceiveLength);

if CCode = 1 then
begin
Quit_SW := YES_SW;
writeln (CTranslateErrMsg,
'CCL - MasterData not translated.');
end;

if not Quit_SW then
begin
if ReceiveLength = FULL_RECORD then
DisplayAcceptance (MasterData.RiskCodeMaster,
Quit_SW)

else
DisplayErrorMessage (bin(MasterData.ErrorCode, 4),
Quit_SW);
end
end
end
end
end
end;

$PAGE$

{************************************************************
ProcessRecords
This procedure calls GetFullScreenData, SendData, and
ReceiveData.
************************************************************}

procedure ProcessRecords (ResourceID : shortint;
var Quit_SW : boolean);

begin
GetFullScreenData (TransData);
SendData (ResourceID, TransData, Quit_SW);

if not Quit_SW then
ReceiveData (ResourceID, Quit_SW);
end;

$PAGE$

{************************************************************
EndHousekeeping
This procedure deallocates the conversation and calls
TPEnded to free the resources used by the local TP.
************************************************************}

procedure EndHousekeeping (ResourceID, TPID : shortint);

var
IntrinsicStatus : hpe_status;

begin
MCDeallocate (ResourceID, DeallocateType, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (DeallocateErrMsg, IntrinsicStatus.info, Quit_SW)

else
begin
TPEnded (TPID, IntrinsicStatus);

if IntrinsicStatus.all <<>> 0 then
ErrorHandler (EndedErrMsg, IntrinsicStatus.info, Quit_SW)
end;
end;

$PAGE$

{************************************************************
Main Program
************************************************************}

begin
LocalTPName := 'USERTP ';
RemoteTPNameASCII := 'Z027';
Traceon := ON;
SessionType := 'APISESS ';
DeallocateType := CONVSYNCLEVEL;

BeginHousekeeping (LocalTPName, RemoteTPNameASCII, SessionType,
TPID, ResourceID, Traceon, Quit_SW);

While not Quit_SW do
ProcessRecords (ResourceID, Quit_SW);

EndHousekeeping (ResourceID, TPID, DeallocateType);

end.