SYSTEM TRANS,ENTITY =TXNFILE(APPEND);
<<
This application collects employee payroll deduction transactions
and places the edited transactions into a file.
For this application: Enter key = edit and file transaction;
f8 = exit application;
all other f keys = redo transaction.
Each transaction entered by the operator is subjected to the data
edits embedded within the input form.
The application continues to collect transactions until either
the operator signals to exit or a system error is detected.
>>
DEFINE(ITEM) MAXWINDOWLEN I(4),INIT=150;
DEFINE(ITEM) COMAREA 60 I(4):
CSTATUS I(4)=COMAREA:
LANGUAGE I(4)=COMAREA(3):
COMAREALEN I(4)=COMAREA(5):
USERBUFLEN I(4)=COMAREA(7):
CMODE I(4)=COMAREA(9):
LASTKEY I(4)=COMAREA(11):
NUMERRS I(4)=COMAREA(13):
WINDOWENH I(4)=COMAREA(15):
MULTIUSAGE I(4)=COMAREA(17):
LABELOPTIONS I(4)=COMAREA(19):
CFNAME X(16)=COMAREA(21):
NFNAME X(16)=COMAREA(37):
REPEATAPP I(4)=COMAREA(53):
FREEZEAPP I(4)=COMAREA(55):
CFNUMLINES I(4)=COMAREA(57):
DBUFLEN I(4)=COMAREA(59):
LOOKAHEAD I(4)=COMAREA(63):
DELETEFLAG I(4)=COMAREA(65):
SHOWCONTROL I(4)=COMAREA(67):
PRINTFILENUM I(4)=COMAREA(71):
FILERRNUM I(4)=COMAREA(73):
ERRFILENUM I(4)=COMAREA(75):
FORMSTORESIZE I(4)=COMAREA(77):
NUMRECS I(8)=COMAREA(85):
RECNUM I(8)=COMAREA(89):
TERM-FILEN I(4)=COMAREA(97):
RETRIES I(4)=COMAREA(109):
TERM-OPTIONS I(4)=COMAREA(111):
ENVIRON I(4)=COMAREA(113):
USERTIME I(4)=COMAREA(115):
IDENTIFIER I(4)=COMAREA(117):
LABELINFO X(2)=COMAREA(119):
DATABUF X(200):
DATABUFLEN I(4):
DONE-WITH-TRANS I(4):
ERROR-LOCATION X(70):
FIELDINFO X(80):
NUM-ENTRIES I(4)=FIELDINFO:
ENTRY-LEN I(4)=FIELDINFO(3):
FORM-NAME X(16)=FIELDINFO(5):
FIELDDATA 3 X(20)=FIELDINFO(21):
FIELDENTRY X(20)=FIELDDATA:
FIELD-NAME X(16)=FIELDENTRY:
SCREEN-ORDER I(4)=FIELDENTRY(17):
FIELD-NUM I(4)=FIELDENTRY(19):
FIELDSPECS-ITEM 3 X(8):
FIELDSPECS X(8)=FIELDSPECS-ITEM:
FIELD-ID I(4)=FIELDSPECS:
CHANGE-TYPE I(4)=FIELDSPECS(3):
CHANGE-SPEC X(4)=FIELDSPECS(5):
FILENAME X(86):
FOUND-DATA-ERRS I(4):
INFOBUFLEN I(4):
MSGBUF X(150):
MSGBUFLEN I(4):
NBR-TXN-COLLECT I(8):
NUMENTRIES I(4):
NUMSPECS I(4):
STOP-NOW I(4):
GLOBAL 3 I(4):
ZERO I(4)=GLOBAL:
ONE I(4)=GLOBAL(3):
EIGHT I(4)=GLOBAL(5):
FALSE I(4)=ZERO:
TRUE I(4)=ONE;
LIST MAXWINDOWLEN;
LIST COMAREA,INIT: << Initialize to all zeros >>
DATABUF:
DATABUFLEN:
DONE-WITH-TRANS:
ERROR-LOCATION:
FIELDINFO:
FIELDSPECS-ITEM:
FILENAME:
FOUND-DATA-ERRS:
INFOBUFLEN:
MSGBUF:
MSGBUFLEN:
NBR-TXN-COLLECT:
NUMENTRIES:
NUMSPECS:
STOP-NOW:
GLOBAL;
SET(OPTION) NOHEAD;
<< Sample program main line >>
PERFORM SETUP-FOR-WORK;
LEVEL; <<setup loop until done collecting transactions>>
IF (STOP-NOW) = (TRUE) THEN
END(LEVEL)
ELSE IF (DONE-WITH-TRANS) = (TRUE) THEN
END(LEVEL)
ELSE
DO
PERFORM COLLECT-TRANSACTIONS;
END; <<loop to next transaction>>
DOEND;
PERFORM CLEANUP-AFTER-WORK;
DISPLAY "Deduction transactions collected this sesion =":
NBR-TXN-COLLECT;
IF (STOP-NOW) = (TRUE) THEN
PERFORM DISPLAY-SYSTEM-ERROR;
EXIT;
DISPLAY-SYSTEM-ERROR:
<<*****************>>
DISPLAY "**** Transaction collection facility detected system "
"error at: ":
ERROR-LOCATION:
"**** The error message returned is:",line=1:
"****",line=1:
MSGBUF;
RETURN;
CLEANUP-AFTER-WORK:
<<***************>>
FILE(CLOSE) TXNFILE;
LET (CSTATUS) = (ZERO);
PROC VCLOSEFORMF((COMAREA));
LET (CSTATUS) = (ZERO);
PROC VCLOSETERM((COMAREA));
RETURN;
GET-ERROR-MESSAGE:
<<**************>>
LET (MSGBUFLEN) = (MAXWINDOWLEN);
MOVE (MSGBUF) = " ";
PROC VERRMNSG((COMAREA),%(MSGBUF),(MSGBUFLEN),(MSGBUFLEN));
RETURN;
PROMPT-OPERATOR:
<<************>>
PERFORM GET-ERROR-MESSAGE;
PROC VPUTWINDOW((COMPAREA),%(MSGBUF),(MSGBUFLEN));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Prompt Operator - "
"Window Load";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
PROC VSHOWFORM((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Display Update";
PERFORM GET-ERROR-MESSAGE;
DOEND;
RETURN;
READ-EDIT-FILE-TRANSACTION:
<<***********************>>
PROC VREADFIELDS((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Read, Edit, and File"
" - Terminal Read";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Determine if operator wants to stop transaction collection >>
IF (LASTKEY) = (EIGHT) THEN
DO
LET (DONE-WITH-TRANS) = (TRUE);
RETURN;
DOEND;
IF (LASTKEY) <> (ZERO) THEN
<< Operator pressed some key other than Enter or Exit
so clear data error flag to break loop >>
DO
LET (FOUND-DATA-ERRS) = (FALSE);
RETURN;
DOEND;
<< Edit data >>
PROC VFIELDEDITS((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Read, Edit, and"
" File - data Edit";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Determine if edit errors >>
IF (NUMERRS) < (ONE) THEN
LET (FOUND-DATA-ERRS) = (FALSE);
IF (FOUND-DATA-ERRS) = (FALSE) THEN
DO
<< Finish form data >>
PROC VFINISHFORM((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Read, Edit,"
" and File - Data Finishing";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
IF (NUMERRS) > (ZERO) THEN
LET (FOUND-DATA-ERRS) = (TRUE);
DOEND; << Finish form data >>
<< Do we have a transaction that can be filed? >>
IF (FOUND-DATA-ERRS) = (FALSE) THEN
DO
<< get transaction from form and file it >>
MOVE (DATABUF) = " ";
LET (DATABUFLEN) = 200;
PROC VGETBUFFER((COMAREA),%(DATABUF),(DATABUFLEN));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Read, Edit, and"
"File - Data Get";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
PUT TXNFILE,LIST=(DATABUF);
LET (NBR-TXN-COLLECT) = (NBR-TXN-COLLECT) + 1;
DOEND << Get transaction from form and file it >>
ELSE
<< Prompt the operator to correct errors >>
PERFORM PROMPT-OPERATOR;
RETURN;
COLLECT-TRANSACTIONS:
<<*****************>>
<< setup form and get transaction entry form >>
LET (REPEATAPP) = (ZERO);
LET (FREEZEAPP) = (ZERO);
MOVE (NFNAME) = "DEDUCTION";
PROC VGETNEXTFORM((COMAREA));''
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Form Retrieval";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Toggle three fields in form to "input allowed" >>
<< Screen order is indicated to field change intrinsic as
negative number
LET OFFSET(FIELDSPECS) = 0;
LET OFFSET(FIELDENTRY) = 0;
LET (FIELD-ID) = (SCREEN-ORDER) * [-1];
LET (CHANGE-TYPE) = 5;
MOVE (CHANGE-SPEC) = "O";
LET OFFSET(FIELDSPECS) = 8;
LET OFFSET(FIELDENTRY) = 20;
LET (FIELD-ID) = (SCREEN-ORDER) * [-1]
LET (CHANGE-TYPE) = 5;
MOVE (CHANGE-SPEC) = "O";
LET OFFSET(FIELDSPECS) = 16;
LET OFFSET(FIELDENTRY) = 40;
LET (FIELD-ID) = (SCREEN-ORDER) * [-1];
LET (CHANGE-TYPE) = 5;
MOVE (CHANGE-SPEC) = "O";
LET (NUMSPECS) = 3;
PROC VCHANGEFIELD((COMAREA),(FIELDSPECS-ITEM),(NUMSPECS));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Field Type Updates";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Load window message >>
<...sc><...x>
<ex><esc>
LET (MSGBUFLEN) = 79;
MOVE (MSGBUF) = "Fill in Deduction Transaction according to "
"worksheet";
PROC VPUTWINDOW((COMAREA),%(MSGBUF),(MSGBUFLEN));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Window Load";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Init form >>
PROC VINITFORM((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Form Init";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Show form >>
PROC VSHOWFORM((COMAREA));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Collect Transactions"
" - Form Display";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Setup and loop on transaction until it can be filed >>
LET (FOUND-DATA-ERRS) = (TRUE);
LEVEL;
IF (FOUND-DATA-ERRS) = (FALSE) THEN
END(LEVEL)
ELSE IF (STOP-NOW) = (TRUE) THEN
END(LEVEL)
ELSE IF (DONE-WITH-TRANS) = (TRUE) THEN
END(LEVEL)
ELSE
DO
PERFORM READ-EDIT-FILE-TRANSACTION;
END;
DOEND;
RETURN;
SETUP-FOR-WORK:
<<***********>>
LET (ZERO) = 0;
LET (ONE) = 1;
LET (EIGHT) = 8;
LET (STOP-NOW) = (FALSE);
LET (DONE-WITH-TRANS) = (FALSE);
LET (NBR-TXN-COLLECT) = (ZERO);
<< Init Comarea >>
<< Set language to SPL. This is the default language if TRANSACT
opens the formfile. However, in this language, all character
arrays must be passed as byte addresses, ie %(NAME) >>
LET (LANGUAGE) = 3;
LET (COMAREALEN) = 60;
LET (LABELOPTIONS) = 1;
MOVE (CFNAME) = " ";
MOVE (NFNAME) = " ";
LET (FORMSTORESIZE) = 4;
<< Open of Transaction file done in SYSTEM statement. Opened
so that new records are appended to those already in the file >>
<< Open forms file >>
MOVE (FILENAME) = "PAYROLL.VPLUS.MILLER";
PROC VOPENFORMF((COMAREA),%(FILENAME));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Setup For Work - "
"Forms File Open";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Open terminal >>
MOVE (FILENAME) = "HPTERM";
PROC VOPENTERM((COMAREA),%(FILENAME));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Setup For Work - "
"Terminal Open";
PERFORM GET-ERROR-MESSAGE;
RETURN;
DOEND;
<< Translate field names to screen order >>
<< Three of the fields in the form used by this application
need to be toggled from "display only" to "input allowed".
In order to do this, we first translate field names to
screen order. >>
<< Setup to retrieve screen order for three specified fields >>
MOVE (CFNAME) = "DEDUCTION";
MOVE (FIELDINFO) = " ";
LET (NUM-ENTRIES) = 3;
LET (ENTRY-LEN) = 10;
MOVE (FORM-NAME) = "DEDUCTION";
LET OFFSET(FIELDENTRY) = 0;
MOVE (FIELD-NAME) = "BADGE NUMBER";
LET OFFSET(FIELDENTRY) = 20;
MOVE (FIELD-NAME) = "LAST_NAME";
LET OFFSET(FIELDENTRY) = 40;
MOVE (FIELD-NAME) = "SUR_NAME";
<< Set length of entire info buffer >>
LET (INFOBUFLEN) = (NUM-ENTRIES) * (ENTRY-LEN) + 10;
PROC VGETFIELDINFOR((COMAEA),(FIELDINFO),(INFORBUFLEN));
IF (CSTATUS) <> (ZERO) THEN
DO
LET (STOP-NOW) = (TRUE);
MOVE (ERROR-LOCATION) = "**** procedure: Setup For Work - "
"Field Info Retrieval";
PERFORM GET-ERROR-MESSAGE;
DOEND;
RETURN;
