Piper's Pit BBS/FTP: ibm 0020

home *** CD-ROM | disk | FTP | other *** search

/ Piper's Pit BBS/FTP: ibm 0020 - 0029 / ibm0020-0029 / ibm0028.tar / ibm0028 / SBTAR2.ZIP / SYSMULT.PRG < prev next >

Wrap

Text File | 1990-06-04 | 72.4 KB | 2,236 lines

********************** ' MultiNet Source Code ' *********************** ** ' SBT Corporation ' ** ** ' One Harbor Drive, Sausalito, California 94965 ' ** ** ' Telephone (415) 331-9900 ' ** *********************************************************************** ** ' (c) Copyright 1984, Revisions 1985 - 1990 SBT Corporation ' ** ** ' All Rights Reserved by SBT Corporation ' ** ** ' ' ** *********************************************************************** ** ' 05/21/90 = Last Update ** SYSMULT.PRG ** Version 6.35.00 ' ** *********************************************************************** * ' Procedure file for Multi-user * *********************************************************************** * * * ' NOTE: EVERY FUNCTIONAL CHANGE TO SYSMULT SHOULD RESULT IN A * * ' CORRESPONDING CHANGE TO MSYSDATE IN P0SETENV, AND TO * * ' M0CURDTE IN xx.PRG. (Insure latest SYSTEM files in use) * * * *********************************************************************** * * * * ' Procedure Name: P0SETENV * ' Purpose or Function: Sets up initial program environment and confirm * ' that most recent version of this file is being used * ' Parameters Passed: None * ' Variables Passed: None * ' Variables Returned: None * * ' MODIFICATION NOTE: You may change the following values if you wish: * ' SET CONFIRM * ' SET BELL * ' SET TYPEAHEAD * ' You should not change SET SAFETY (we do overwrite files) * PROCEDURE p0setenv * ' Sysdate is checked again in XX.PRG to insure system files up to date RELEASE msysdate PUBLIC msysdate * ' This date should be adjusted with every functional change to this file STORE '06/01/90' TO msysdate SET CONFIRM OFF SET SAFETY OFF SET ESCAPE ON SET EXACT OFF SET BELL OFF SET TYPEAHEAD TO 40 * ' Check for these variables in case calling program is early version IF TYPE('m0switchar') = 'U' PUBLIC m0switchar ENDIF IF TYPE('m0single') = 'U' PUBLIC m0single STORE .f. TO m0single ENDIF IF (.NOT. 'MULTI' $ UPPER(m0system)) .AND. m0pgmid <> 'CM' STORE .t. TO m0single ENDIF IF TYPE('m0trial') = 'U' PUBLIC m0trial STORE .f. TO m0trial ENDIF IF TYPE('m0stpprn') = 'U' PUBLIC m0stpprn STORE .f. TO m0stpprn ENDIF IF TYPE('m0prnesc') = 'U' PUBLIC m0prnesc STORE .f. TO m0prnesc ENDIF IF m0single SET EXCLUSIVE ON ELSE SET EXCLUSIVE OFF ENDIF * ' Initialize the print/screen environment in case of printer errors DO p0setprn WITH 'ON', 'SCREEN', 'OFF', 0 ON ESCAPE DO p0escape * ' Call to on-screen calculator, activate with Alt-A * ' Only operates if foxbase and compatable with IBM character set IF fox .AND. SUBSTR(m0border,170,1) = 'Y' ON KEY=286 DO p0popclc ENDIF IF foxpro * ' Set insert off and set cursor small SET CONSOLE OFF ? INSMODE(.f.) ? SYS(2008,'O', 2) SET CONSOLE ON ENDIF IF .NOT. 'OFF' $ UPPER(GETE('ONERROR')) ON ERROR DO p0errors WITH ERROR(), MESSAGE() ELSE * ' don't enable error trap if debugging variable set ON ERROR ENDIF RETURN * ' EOP - P0SETENV * * * ' Procedure Name: P0CLRENV * ' Purpose or Function: Clears program environment * ' Parameters Passed: None * ' Variables Passed: None * ' Variables Returned: None * PROCEDURE p0clrenv CLOSE DATABASES * ' Skip this multiuser function if setup as single user IF .NOT. m0single DO p0usrcnt WITH .f. ENDIF DO p0setprn WITH 'ON', 'SCREEN', 'OFF', 0 SET TALK ON SET EXCLUSIVE ON SET ESCAPE ON ON ERROR ON ESCAPE SET PATH TO RETURN * ' EOP - P0CLRENV * * * ' Procedure Name: P0CLRPRN * ' Purpose or Function: Resets CONSOLE/DEVICE/PRINT settings * ' Parameters Passed: None * ' Variables Passed: m0con = 'ON' or 'OFF' - new current CONSOLE * ' m0dev = 'SCREEN' or 'PRINT' - new current DEVICE * ' m0prt = 'ON' or 'OFF' - new current PRINT * ' Variables Returned: Same as Variables Passed * PROCEDURE p0clrprn IF TYPE('m0con') = 'U' .OR. TYPE('m0prt') = 'U' .OR. TYPE('m0dev') = 'U' DO p0setprn WITH 'ON', 'SCREEN', 'OFF', 0 ELSE IF m0con = 'OFF' SET CONSOLE OFF ELSE SET CONSOLE ON ENDIF IF m0dev = 'PRINT' SET DEVICE TO PRINT ELSE SET DEVICE TO SCREEN ENDIF IF m0prt = 'ON' SET PRINT ON ELSE SET PRINT OFF ENDIF ENDIF RETURN * ' EOP - P0CLRPRN * * * ' Procedure Name: P0POPCLC * ' Purpose or Function: Popup Calculator * ' Parameters Passed: None * ' Variables Passed: None * ' Variables Returned: None * PROCEDURE p0popclc PRIVATE mmemtotl, mtotal, mholder, mcans, minput, mchoice, mopmacro, mans SAVE SCREEN SET ESCAPE OFF SET DECIMAL TO 5 SET INTENSITY OFF IF ISCOLOR() SET COLOR TO W+/R,GR+/B ELSE SET COLOR TO W/N,N/W,N ENDIF STORE '╔═╗║╝═╚║ ' TO combo3 STORE 0 TO mmemtotl, mtotal, mholder STORE ' ' TO mcans, minput, mchoice, mopmacro @ 2,42,10,72 BOX combo3 @ 2,51 SAY '╤' @ 3,44 SAY 'Entry │ 0' @ 4,42 SAY '╠════════╪════════════════════╣' @ 5,44 SAY 'Total │ 0' @ 6,42 SAY '╠════════╪════════════════════╣' @ 7,44 SAY 'Memory │ 0' @ 8,42 SAY '╠════════╧════════════════════╣' @ 9,44 SAY SPACE(28) @ 9,52 SAY '<H> = Help' DO WHILE .t. @ 3,70 SAY '' WAIT '' TO mcans @ 9,44 SAY SPACE(28) @ 9,52 SAY '<H> = Help' @ 3,70 SAY ' ' STORE UPPER(mcans) TO mcans IF LEN(TRIM(mcans)) = 0 STORE '=' TO mcans ENDIF STORE .t. TO mclear * ' If number entered, loop for more numbers IF mcans $ '0123456789.' STORE TRIM(minput) + mcans TO minput @ 3,70 - LEN(minput) SAY minput PICTURE '#############.####' STORE ' ' TO mcans LOOP ELSE IF mchoice $ '+-/*^' STORE mchoice TO mopmacro ENDIF STORE mcans TO mchoice IF mchoice $ '+-/*^=' @ 3,53 SAY mchoice ENDIF @ 3,54 CLEAR TO 3,71 STORE ' ' TO mcans ENDIF DO CASE CASE mchoice = 'Q' * ' Quit back to program EXIT CASE mchoice = 'P' STORE SYS(18) TO mfield IF TYPE ('&mfield') = 'N' * ' Paste total KEYB LTRIM(STR(mtotal,7,2)) * ' and quit back to program EXIT ELSE ?? CHR(7) STORE ' ' TO mans @ 9,44 SAY '** Only Paste to Numeric **' LOOP ENDIF CASE mchoice = 'C' * ' Clear current STORE '0' TO mcans, minput STORE ' ' TO mcans @ 3,53 SAY mchoice CASE mchoice = 'Z' * ' Clear all registers STORE 0 TO mtotal, mmemtotl, mholder STORE '0' TO mcans, minput @ 3,53 SAY mchoice CASE mchoice $ '+-/*^=' * ' Compute DO CASE CASE LEN(TRIM(minput)) = 0 * ' If no entry, leave alone CASE mtotal # 0 * ' Calculate STORE mtotal &mopmacro VAL(minput) TO mtotal OTHERWISE * If zero just set to input value STORE VAL(minput) TO mtotal ENDCASE IF mchoice = '=' STORE '+' TO mchoice, mopmacro ENDIF CASE mchoice = '%' * ' Compute percentage STORE mtotal + (mtotal * (VAL(minput)/100)) TO mtotal CASE mchoice = 'M' * ' Store to memory STORE .f. TO mclear mmemtotl = VAL(minput) CASE mchoice = 'G' * ' Get from memory STORE .f. TO mclear STORE LTRIM(STR(mmemtotl,18,4)) TO minput CASE mchoice = 'A' * ' Add to Memory STORE .f. TO mclear STORE mmemtotl + VAL(minput) TO mmemtotl CASE mchoice = 'S' * ' Switch running total with memory total STORE mtotal TO mholder STORE mmemtotl TO mtotal STORE mholder TO mmemtotl CASE mchoice = 'F' * ' Reverse (flip) sign STORE STR(VAL(minput) * (-1),13,4) TO minput STORE .f. TO mclear CASE mchoice = 'R' * ' Compute Square Root STORE mtotal^(1/2) TO mtotal CASE mchoice = 'Y' * ' Compute Square STORE mtotal^2 TO mtotal CASE mchoice = 'H' * ' Help Screen SAVE SCREEN TO calc2 @ 8,42 SAY '╚════════╧════════════════════╝' @ 9,42 SAY SPACE(31) @ 9,52 SAY '«« HELP »»' @ 10,42,23,72 BOX '╒═╕│╛═╘│ ' @ 10,47 SAY '╤' @ 11,43 SAY 'C │ Clear entry' @ 12,43 SAY 'S │ Switch memory and entry' @ 13,43 SAY 'F │ Flip sign Of entry' @ 14,43 SAY '% │ Percentage' @ 15,43 SAY 'G │ Get from memory' @ 16,43 SAY 'R │ square Root of total' @ 17,43 SAY 'M │ store entry to Memory' @ 18,43 SAY 'A │ Add entry to memory' @ 19,43 SAY 'Y │ square of total' @ 20,43 SAY 'Z │ Zap/clear all registers' @ 21,43 SAY 'P │ Put total in numeric' @ 22,43 SAY 'Q │ Quit calculator' @ 23,47 SAY '╧' WAIT '' RESTORE SCREEN FROM calc2 ENDCASE @ 5,54 SAY mtotal PICTURE '#############.####' @ 7,54 SAY mmemtotl PICTURE '#############.####' IF .NOT. mclear @ 3,70 - LEN(minput) SAY minput PICTURE '#############.####' ELSE STORE ' ' TO mcans, minput ENDIF ENDDO DO CASE CASE m0monitor = 'C' .AND. LEN(m0color) > 0 SET COLOR TO &m0color CASE m0monitor = 'C' SET COLOR TO W+/B,N/W,B CASE 'MAC' $ UPPER(OS()) .AND. fox SET COLOR TO N/W,W/N,N OTHERWISE SET COLOR TO W+/N,N/W,N ENDCASE SET DECIMAL TO 2 SET INTENSITY ON RESTORE SCREEN RETURN * ' EOP - P0POPCLC * * * ' Procedure Name: P0DQUERY * ' Purpose or Function: Dot prompt emulator * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: None * ' Variables Returned: None * PROCEDURE p0dquery * ' Presumably next 4 lines will never be hit, they should use SYSCLIP IF clipper .OR. xquicks * ' display Option Not Available message DO syshelp WITH 9010 RETURN ENDIF SET ESCAPE OFF SELECT a CLOSE DATABASES CLEAR STORE '..' TO comm DO WHILE SUBSTR(comm,1,1) <> ' ' CLEAR GETS STORE SPACE(77) TO comm ? ? ? @ 22,0 @ 22,0 SAY 'Enter Database Command or <Enter> to return to menu...' @ 23,0 SAY '. ' @ 23,2 GET comm READ * ' Don't allow quit or cancel from emulated dot prompt IF LEN(TRIM(comm)) > 0 .AND. .NOT. TRIM(UPPER(comm)) $ ' QUIT CANCEL ' SET TALK ON &comm SET TALK OFF STORE 'xxx' TO comm ENDIF CLEAR GETS ENDDO * ' Reset startup environment in case interactive work changed it. DO p0setenv * ' Close databases and reset to a to avoid problems * ' with files left open on return CLOSE DATABASES SELECT a RETURN * ' EOP - P0DQUERY * * * ' Procedure Name: P0LSFILE * ' Purpose or Function: Lists file records with like key values * ' Parameters Passed: None * ' Variables Passed: m0field = character var with key field name * ' m0key = character var with sought key value * ' m0file = 'ARCUST' - AR/SO 6.XX Customer File * ' 'APVEND' - AP/PO 6.XX Vendor FIle * ' 'APACCT' - AP 6.21 Checking Accounts File * ' 'ARINVT' - AR/PO/SO 6.XX Inventory File * ' 'ASSETS' - AS 6.20 Assets File * ' 'PREMPL' - PR 6.15 Employee File * ' Environment Passed: &m0file with INDEX assumed to be selected * ' Variables Returned: m0new = .t. if OK to add new record * * ' This procedure was replaced by SYSLIST.PRG in mid 1989. * ' You may remove it if not needed for backward compatibility * PROCEDURE p0lsfile PRIVATE mans, mxkey, mfirst, mlast, mline, mheading, mrecno, mtoprec RELEASE m0new PUBLIC m0new STORE .f. TO m0new SET EXACT OFF STORE TRIM(m0key) TO mxkey SEEK mxkey DO WHILE LEN(mxkey) > 1 .AND. EOF() STORE SUBSTR(mxkey,1,LEN(mxkey) - 1) TO mxkey SEEK mxkey ENDDO @ 4,0 CLEAR DO CASE CASE m0file = 'APVEND' STORE 'Vendor' TO mtitle STORE 'Company Vendor No. City ' + ; ' Phone' TO mheading CASE m0file = 'APACCT' STORE 'Account' TO mtitle STORE 'Account Description Last ' + ; m0cheque TO mheading CASE m0file = 'ARCUST' STORE 'Customer' TO mtitle STORE 'Company Cust No. City ' + ; ' Phone' TO mheading CASE m0file = 'ARINVT' STORE 'Item' TO mtitle STORE 'Description Item No. ' + ; 'Vendor Part No.' TO mheading CASE m0file = 'ASSETS' STORE 'Tag' TO mtitle STORE 'Tag Number Description Cost' ; TO mheading CASE m0file = 'DBCLNT' STORE 'Customer' TO mtitle STORE 'Customer Company' TO mheading CASE m0file = 'JCPHAS' STORE 'Phase' TO mtitle STORE 'Phase Description' TO mheading CASE m0file = 'JCCATG' STORE 'Category record' TO mtitle STORE 'Category Description' TO mheading CASE m0file = 'PREMPL' STORE 'Employee' TO mtitle STORE 'Employee' TO mheading ENDCASE DO CASE CASE EOF() .AND. SUBSTR(m0key,1,1) = '?' @ 4,1 SAY 'Displaying all ' + TRIM(mtitle) + 's...' GO TOP STORE '' TO mxkey CASE EOF() @ 4,1 SAY 'No ' + TRIM(mtitle) + 's similar to ' + LTRIM(TRIM(m0key)) + ; ' found...' OTHERWISE @ 4,1 SAY TRIM(mtitle) + ' ' + LTRIM(TRIM(m0key)) + ' not found. ' + ; 'Displaying similar ' + TRIM(mtitle) + 's...' ENDCASE IF .NOT. EOF() @ 6,1 SAY mheading @ 7,1 SAY SUBSTR(m0border,10,78) ENDIF STORE .t. TO mfirst STORE .f. TO mlast STORE RECNO() TO mtoprec DO WHILE .t. STORE 8 TO mline STORE RECNO() TO mrecno DO WHILE mxkey = UPPER(SUBSTR(&m0field,1,LEN(mxkey))) ; .AND. mline < 21 .AND. .NOT. EOF() DO CASE CASE m0file = 'APVEND' @ mline,1 SAY company + ' ' + vendno + ' ' + ; SUBSTR(city,1,15) + ' ' + SUBSTR(phone,1,12) CASE m0file = 'APACCT' @ mline,1 SAY account + ' ' + descrip + ' ' + lpaydate CASE m0file = 'ARCUST' @ mline,1 SAY company + ' ' + custno + ' ' + ; SUBSTR(city,1,15) + ' ' + SUBSTR(phone,1,12) CASE m0file = 'ARINVT' @ mline,1 SAY descrip + ' ' + item + ' ' + vpartno CASE m0file = 'ASSETS' @ mline,1 SAY tagno + ' ' + SUBSTR(descrip,1,31) + ' ' + ; STR(cost,10,2) CASE m0file = 'DBCLNT' @ mline,1 SAY custno + SPACE(8) + company CASE m0file = 'JCPHAS' @ mline,1 SAY phase + SPACE(8) + descrip CASE m0file = 'JCCATG' @ mline,1 SAY catg + SPACE(8) + descrip CASE m0file = 'PREMPL' @ mline,1 SAY prempl + ' ' + TRIM(prlast) + ', ' + prfirst ENDCASE SKIP STORE mline + 1 TO mline ENDDO IF mxkey = UPPER(SUBSTR(&m0field,1,LEN(mxkey))) ; .AND. .NOT. (EOF() .OR. BOF()) STORE .f. TO mlast ELSE STORE .t. TO mlast ENDIF IF SUBSTR(m0key,1,1) <> '?' STORE 'Add new ' + TRIM(mtitle) + '/' TO msg STORE 'A' TO moptns ELSE STORE '' TO msg, moptns ENDIF STORE 'R' TO mans IF .NOT. mlast STORE msg + 'Fwd/' TO msg STORE moptns + 'F' TO moptns STORE 'F' TO mans ENDIF IF .NOT. mfirst STORE msg + 'Back/' TO msg STORE moptns + 'B' TO moptns ENDIF @ 22,1 SAY 'Enter Choice (' + msg + 'Reenter) ' + ; SUBSTR(m0border,181,5) GET mans PICTURE '!' READ SAVE DO WHILE .NOT. mans $ 'R' + moptns ?? CHR(7) READ SAVE ENDDO @ 22,0 CLEAR GETS STORE .f. TO mfirst DO CASE CASE mans = 'B' @ 22,1 SAY 'Paging Backwards in File. Please wait..' GO mrecno SKIP -13 IF mxkey <> UPPER(SUBSTR(&m0field,1,LEN(mxkey))) .OR. BOF() STORE .t. TO mfirst GO mtoprec ENDIF IF .NOT. mfirst .AND. .NOT. BOF() SKIP -1 IF mxkey <> UPPER(SUBSTR(&m0field,1,LEN(mxkey))) .OR. BOF() STORE .t. TO mfirst GO mtoprec ELSE SKIP ENDIF ENDIF CASE mans = 'A' STORE .t. TO m0new EXIT CASE mans = 'R' STORE .f. TO m0new EXIT ENDCASE @ 8,0 CLEAR ENDDO && WHILE .t. RETURN * ' EOP - P0LSFILE * * * ' Procedure Name: P0PASVAL * ' Purpose or Function: Checks Password Access and displays entry screen * ' Parameters Passed: maccess = character, '1'-'15' to validate access * ' or '0' to get a new password without validation * ' mtitle = Option title being validated (or null) * ' Variables Passed: m0passf = Password file name with drive/path * ' Environment Passed: Password file assumed not to be open in other areas * ' Variables Returned: mreturn = logical, .t. if okay to continue * ' m0pass = character, password plus access fields * ' Example: Called as DO P0pasval WITH '1', mchoice * PROCEDURE p0pasval PARAMETER maccess, mtitle PRIVATE mans, mpword RELEASE mreturn PUBLIC mreturn STORE .f. TO mreturn USE &m0passf * ' If maccess hasn't been defined in calling program, something is wrong IF TYPE('maccess') <> 'C' RETURN ENDIF * ' If maccess doesn't relate to field in password file, something wrong * ' maccess of '0' is for changing logged in password IF maccess <> '0' .AND. TYPE('access&maccess') <> 'C' RETURN ENDIF CLEAR @ 1,1 SAY DTOC(m0date) @ 1,40 - INT(LEN(m0system)/2) SAY m0system @ 1,73 SAY SUBSTR(m0company,79,6) @ 2,1 SAY SUBSTR(m0company,1,78) @ 3,40 - INT(LEN(mtitle)/2) SAY mtitle @ 7,1 SAY ' Please Enter Your Password ' + SUBSTR(m0border,177,9) @ 8,38 SAY SUBSTR(m0border,91,35) @ 9,38 SAY 'your password will not be displayed' DO WHILE .t. @ 7,37 SAY ' ' SET CONSOLE OFF ACCEPT TO mpword SET CONSOLE ON STORE UPPER(SUBSTR(TRIM(mpword) + SPACE(10),1,10)) TO mpword * ' Entry of blanks escapes from option IF mpword = SPACE(10) STORE .f. TO mreturn EXIT ELSE LOCATE FOR password = mpword .AND. .NOT. DELETED() * ' maccess of '0' is for changing logged in password IF maccess = '0' IF .NOT. EOF() STORE .t. TO mreturn STORE password + access1 + access2 + access3 + access4 + access5 + ; access6 + access7 + access8 + access9 + access10 + access11 + ; access12 + access13 + access14 + access15 TO m0pass ENDIF ELSE * ' If the relevant password (determined by maccess) has 'Y', passes IF access&maccess = 'Y' .AND. .NOT. EOF() STORE .t. TO mreturn ENDIF ENDIF IF mreturn EXIT ENDIF ?? CHR(7) @ 13,2 SAY 'Invalid password. Please try again...' ENDIF ENDDO && WHILE .t. USE RETURN * ' EOP - P0PASVAL * * * ' Procedure Name: P0REPTQU * ' Purpose or Function: Prompts at end of displayed report * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: File for report assumed to be selected * ' Variables Returned: mcont = .t. if ok to continue report * PROCEDURE p0reptqu PRIVATE mans STORE .t. TO mcont STORE ' ' TO mans IF .NOT. EOF() SKIP ENDIF IF .NOT. EOF() ? @ 23,1 SAY 'Press any key to continue or "Q" to Quit...' ; GET mans PICTURE '!' READ IF mans = 'Q' STORE .f. TO mcont ENDIF ELSE ? @ 23,1 SAY 'End of report. Press any key to continue...' GET mans READ STORE .f. TO mcont ENDIF && .NOT. EOF() RETURN * ' EOP - P0REPTQU * * * ' Procedure Name: P0SCGRID * ' Purpose or Function: Displays Option Grid screen * ' Parameters Passed: mtitle = character, screen title * ' mbottom = numeric, bottom row for screen box * ' Variables Passed: m0border, border string from MM record * ' Variables Returned: None * PROCEDURE p0scgrid PARAMETERS mtitle, mbottom PRIVATE mline, mcline STORE SUBSTR(m0border,7,1) TO medge STORE SUBSTR(m0border,8,1) TO mcedge STORE SUBSTR(m0border,90,20) + SUBSTR(m0border,127,1) + ; REPLICATE(SUBSTR(m0border,91,1),36) + SUBSTR(m0border,127,1) + ; SUBSTR(m0border,148,18) TO mcline CLEAR @ 1,4 SAY mtitle @ 2,2 SAY SUBSTR(m0border,1,1) + SUBSTR(m0border,10,19) + ; SUBSTR(m0border,2,1) + SUBSTR(m0border,10,36) + SUBSTR(m0border,2,1) + ; SUBSTR(m0border,10,17) + SUBSTR(m0border,3,1) @ 3,2 SAY medge @ 3,22 SAY mcedge @ 3,59 SAY mcedge @ 3,77 SAY medge STORE 4 TO mline DO WHILE mline < mbottom @ mline,2 SAY mcline @ mline + 1,2 SAY medge @ mline + 1,22 SAY mcedge @ mline + 1,59 SAY mcedge @ mline + 1,77 SAY medge STORE mline + 2 TO mline ENDDO @ mline,2 SAY SUBSTR(m0border,4,1) + SUBSTR(m0border,10,19) + ; SUBSTR(m0border,5,1) + SUBSTR(m0border,10,36) + SUBSTR(m0border,5,1) + ; SUBSTR(m0border,10,17) + SUBSTR(m0border,6,1) RETURN * ' EOP - P0SCGRID * * * ' Procedure Name: P0SETPRN * ' Purpose or Function: Sets CONSOLE, DEVICE, and PRINT on request * ' Parameters Passed: mcon = 'ON' or 'OFF' - desired CONSOLE * ' mdev = 'SCREEN' or 'PRINT' - desired DEVICE * ' mprt = 'ON' or 'OFF' - desired PRINT * ' mprtno = number, user definable, default is 0 * ' Variables Passed: m0prnesc = .t. if using printer <ESC> handler * ' Environment Passed: None * ' Variables Returned: m0con = 'ON' or 'OFF' - new current CONSOLE * ' m0dev = 'SCREEN' or 'PRINT' - new current DEVICE * ' m0prt = 'ON' or 'OFF' - new current PRINT * ' m0prnerr = .t. from P0ERRORS on printer error * ' Example: Called as DO P0setprn WITH 'OFF', 'PRINT', 'ON', 0 * PROCEDURE p0setprn PARAMETERS mcon, mdev, mprt, mprtno RELEASE m0con, m0dev, m0prt, m0prnerr PUBLIC m0con, m0dev, m0prt, m0prnerr STORE .f. TO m0con, m0dev, m0prt, m0prnerr SET TALK OFF SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF * ' Store settings made so we can recover if printer error occurs IF UPPER(mcon) = 'OFF' STORE 'OFF' TO m0con SET CONSOLE OFF ELSE STORE 'ON' TO m0con SET CONSOLE ON ENDIF IF UPPER(mdev) = 'PRINT' STORE 'PRINT' TO m0dev SET DEVICE TO PRINT ELSE STORE 'SCREEN' TO m0dev SET DEVICE TO SCREEN ENDIF IF UPPER(mprt) = 'ON' STORE 'ON' TO m0prt SET PRINT ON ELSE STORE 'OFF' TO m0prt SET PRINT OFF ENDIF * ' m0prnesc is set by those calling pgms which allow escaping from printing IF TYPE('m0prnesc') = 'L' IF m0prnesc DO p0prnesc ENDIF ENDIF IF UPPER(mdev) = 'PRINT' .OR. UPPER(mprt) = 'ON' * ' Add custom printer setup routine here using mprtno ENDIF RETURN * ' EOP - P0SETPRN * * * ' Procedure Name: P0AVCOST * ' Purpose or Function: Performs Average Weighted Cost calculation. * ' Parameters Passed: m0linkf = link file to be updated * ' mwrk = work area containing ARINVTnn.DBF * ' mgllink = .t. if linked to GL, .f. if not linked * ' mtdate = Transaction date * ' mvendno = Vendor/supplier number for item * ' mbatch = Current batch number * ' mcost = old cost of inventory item * ' ncost = new cost at which item received * ' mqty = current onhand qty of item * ' nqty = qty of item received * ' minvtacc = GL inventory account * ' miadjacc = GL Inventory Adjustment account * ' Environment Passed: ARINVTnn.DBF must be open in work area defined * ' with parameter MWRK, with pointer on correct item * ' ARITRNnn.DBF must not be open * ' xxGLLKnn.DBF must not be open * ' Files open in work areas H and I will be closed * ' Variables Passed: None * ' Variable Returned: mavcost = new average weighted cost for item * ' Example: Called as DO P0avcost WITH m0apgllkf, 'c', mlkgl, * ' SUBSTR(DTOC(m0date)), mvendno, mbatch, mcost, * ' ncost, mqty, nqty, minvtacc, miadjacc * PROCEDURE p0avcost PARAMETERS m0linkf, mwrk, mgllink, mtdate, mvendno, mbatch, mcost, ; ncost, mqty, nqty, minvtacc, miadjacc * ' Initialize MVALUE to contain total inventory value (old + new) PRIVATE mvalue * ' Initialize MAVCOST to contain new average-weighted cost for item RELEASE mavcost PUBLIC mavcost STORE 0.00 TO mavcost * ' MWRK contains work area definition for ARINVTnn.DBF STORE mwrk + '->' TO mwrk * ' Calculate total value of inventory after receipt STORE (mqty * mcost) + (nqty * ncost) TO mvalue * ' Define cost for item; update ARITRN and xxGLLK if necessary DO CASE CASE &mwrk.stkcode <> 'Y' * ' If item is non-stock, cost = new cost; no update to ARITRN or xxGLLK STORE ncost TO mavcost CASE mqty < 0 .AND. mcost <> ncost * ' If onhand below zero and new cost <> old cost, update ARITRN and * ' xxGLLK; calculate cost for item SELECT h USE &m0itrnf INDEX &m0itrnf..ndx DO p0flockn * ' Make adjusting entries to ARITRNnn.DBF APPEND BLANK REPLACE item WITH &mwrk.item, class WITH &mwrk.class, ref WITH ; 'Adjust Entry', cost WITH (mcost - ncost), qty WITH ; MIN(ABS(mqty),nqty), vendno WITH mvendno REPLACE code WITH 'A', seq WITH &mwrk.seq, tdate WITH mtdate, ; glasst WITH &mwrk.gllink, batch WITH mbatch IF mgllink * ' If linked to GL, make adjusting entry to xxGLLKnn.DBF SELECT i USE &m0linkf INDEX &m0linkf..ndx DO p0flockn * ' Make adjusting entry to GL Inventory account (debit) SEEK minvtacc IF EOF() APPEND BLANK REPLACE account WITH minvtacc ENDIF IF amount + (h->cost * h->qty) > 0 REPLACE amount WITH amount + .001 * INT(1000 * h->cost * ; h->qty + .5) ELSE REPLACE amount WITH amount + .001 * INT(1000 * h->cost * ; h->qty - .5) ENDIF * ' Make adjusting entry to GL Inventory Adj account (credit) SEEK miadjacc IF EOF() APPEND BLANK REPLACE account WITH miadjacc ENDIF IF amount + (0 - (h->cost * h->qty)) > 0 REPLACE amount WITH amount + (0 - .001 * INT(1000 * ; h->cost * h->qty + .5)) ELSE REPLACE amount WITH amount + (0 - .001 * INT(1000 * ; h->cost * h->qty - .5)) ENDIF USE SELECT h ENDIF && mgllink IF mqty + nqty >= 0.00 .OR. mvalue = 0.00 * ' If new qty + old qty >= 0 or value = 0, cost = new cost STORE ncost TO mavcost ELSE * ' Leave cost the same if new onhand < 0 STORE mcost TO mavcost ENDIF USE CASE mqty + nqty = 0.00 .OR. mvalue = 0.00 * ' If new onhand or new value is zero, cost = new cost STORE ncost TO mavcost OTHERWISE * ' Cost = average weighted cost if onhand > 0.00 IF mvalue / (mqty + nqty) < 0 STORE .001 * INT(1000 * mvalue / (mqty + nqty) - .5) TO mavcost ELSE STORE .001 * INT(1000 * mvalue / (mqty + nqty) + .5) TO mavcost ENDIF ENDCASE RETURN * ' EOP - P0AVCOST * * * ' Procedure Name: P0PRNESC * ' Purpose or Function: Printer <ESC> control, allows graceful exit * ' Parameters Passed: None * ' Variables Passed: m0prt = set printer 'ON' or 'OFF' * ' m0stpprn = Print error msg if printing stopped * ' Environment Passed: Sets value for ON ESCAPE * ' Variables Returned: m0prnesc = back to .f. if printer being turned off * ' m0stpprn = back to .f. if .t. and print off * * ' This procedure to be used ONLY for non-clipper code * PROCEDURE p0prnesc DO CASE CASE m0prt = 'ON' .OR. m0dev = 'PRINT' ON ESCAPE STORE .t. TO m0stpprn CASE m0prt = 'OFF' ON ESCAPE DO p0escape STORE .f. TO m0prnesc IF m0stpprn ?? CHR(7) STORE .f. TO m0stpprn STORE ' ' TO mans @ 23,0 CLEAR @ 23,2 SAY 'Printing interrupted by <ESC>. Press any key to ' + ; 'return to menu....' GET mans READ ENDIF ENDCASE RETURN * ' EOP - P0PRNESC * * * ' Procedure Name: P0ESCAPE * ' Purpose or Function: Escape Key event handler (from ON ESCAPE call) * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: None * ' Variables Returned: None * PROCEDURE p0escape PRIVATE mln, moptns, msg, mwait SET TALK OFF SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF CLEAR TYPEAHEAD STORE ' ' TO mwait STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF @ mln,0 ?? CHR(7) + CHR(7) IF 'OFF' $ UPPER(GETE('ONERROR')) * ' if debugging variable set, allow SUSPEND on S STORE 'Esc key pressed. (Ignore/Suspend/Quit) ' TO msg STORE 'ISQ' TO moptns ELSE STORE 'Esc key pressed. (Ignore/Quit) ' TO msg STORE 'IQ' TO moptns ENDIF @ mln,38 - INT(LEN(msg)/2) SAY msg GET mwait PICTURE '!' READ SAVE DO WHILE .NOT. mwait $ moptns ?? CHR(7) READ SAVE ENDDO @ mln,0 CLEAR GETS DO CASE CASE mwait = 'S' SUSPEND DO p0clrprn CASE mwait = 'I' DO p0clrprn RETRY CASE mwait = 'Q' DO p0clrenv QUIT ENDCASE RETURN * ' EOP - P0ESCAPE * * * ' Procedure Name: P0ERRORS * ' Purpose or Function: Error handling * ' Parameters Passed: errornum = Error Number (from ON ERROR) * ' errormes = Error Message (from ON ERROR) * ' Variables Passed: None * ' Environment Passed: None * ' Variables Returned: m0prnerr = .t. if printer error occured * PROCEDURE p0errors PARAMETER errornum, errormes CLEAR GETS SET TALK OFF PRIVATE mans, mln, mretry, mreturn, mrecno, mwait, mxcon, mxdev, mxprt RELEASE m0prnerr PUBLIC m0prnerr STORE .f. TO m0prnerr * ' Store printer condition for print errors, use to restore environment STORE m0con TO mxcon STORE m0dev TO mxdev STORE m0prt TO mxprt * ' Force set screen/print environment to display error messages SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF * ' And store the new environment STORE 'ON' TO m0con STORE 'SCREEN' TO m0dev STORE 'OFF' TO m0prt * ' If you have an error, discard assumptions leading to typeahead CLEAR TYPEAHEAD * ' In case of gets still open on error CLEAR GETS STORE ' ' TO mwait STORE .f. TO mreturn STORE 24 TO mln * ' Move error line for 23 line Xenix screens IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF @ mln,0 * ' Error Handling Section - specific errors first DO CASE CASE errornum = 1 * ' file does not exist DO syshelp WITH errornum ON ERROR RETRY CASE errornum = 5 * ' record out of range - damaged index file DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 6 * ' too many files open error CLOSE DATABASES DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 10 * ' syntax error DO syshelp WITH errornum ON ERROR RETRY CASE errornum = 12 * ' variable not found DO syshelp WITH errornum ON ERROR RETRY CASE errornum = 15 * ' not a dBASE III database file or corrupted DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 16 * ' unrecognized command verb DO syshelp WITH errornum ON ERROR RETRY CASE errornum = 19 * ' index file does not match data file DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 29 * ' file not accessible or filename is illegal DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 43 * ' insufficient memory DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 56 * ' disk full on attempted write DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 111 * ' attempted write to read only file DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 114 * ' index file corrupted DO syshelp WITH errornum DO p0clrenv QUIT CASE errornum = 125 .OR. errornum = 126 * ' printer not ready/not installed error - retry ?? CHR(7) STORE 'Y' TO mans @ mln,0 SAY 'Printer Not Ready. Please correct problem. ' + ; 'Ready to Print? (Y/N) ' GET mans PICTURE 'Y' READ IF mans = 'N' DO p0clrenv QUIT ENDIF STORE .t. TO m0prnerr STORE .f. TO mreturn CASE errornum = 108 .AND. '' <> DBF() * ' file locked and cannot access - wait and retry @ mln,0 SAY TRIM(UPPER(DBF())) + ; ' in EXCLUSIVE use by another. Retrying...' STORE 1 TO mretry DO WHILE mretry < 100 STORE mretry + 1 TO mretry ENDDO STORE .f. TO mreturn CASE errornum = 109 * ' record locked and cannot access - wait and retry @ mln,0 SAY TRIM(UPPER(DBF())) + ' Rec in use by another. ' + ; 'Retrying...' STORE 1 TO mretry DO WHILE mretry < 100 STORE mretry + 1 TO mretry ENDDO STORE .f. TO mreturn CASE errornum = 110 .AND. '' <> DBF() * ' file operation requires exclusive use STORE 'Y' TO mans @ mln,0 SAY TRIM(UPPER(DBF())) + '. EXCLUSIVE USE needed. ' + ; 'Retry? (Y/N) ' GET mans PICTURE 'Y' READ IF mans = 'N' DO p0clrenv QUIT ENDIF STORE RECNO() TO mrecno DO CASE CASE '' <> NDX(1) .AND. '' <> NDX(2) .AND. '' <> NDX(3) STORE DBF() + ' INDEX ' + NDX(1) + ', ' + NDX(2) + ', ' + NDX(3) TO ; mans CASE '' <> NDX(1) .AND. '' <> NDX(2) STORE DBF() + ' INDEX ' + NDX(1) + ', ' + NDX(2) TO mans CASE '' <> NDX(1) STORE DBF() + ' INDEX ' + NDX(1) TO mans OTHERWISE STORE DBF() TO mans ENDCASE USE &mans EXCLUSIVE STORE .f. TO mreturn CASE errornum = 128 * ' skip to locked record ?? CHR(7) @ mln,0 SAY TRIM(UPPER(DBF())) + '. Skip to locked record. Retrying...' STORE 1 TO mretry DO WHILE mretry < 200 STORE mretry + 1 TO mretry ENDDO STORE .f. TO mreturn CASE errornum = 130 * ' record not locked error - do locking without display procedure ?? CHR(7) @ mln,0 SAY ; TRIM(UPPER(DBF())) + '. Unlocked REPLACE attempted. Retrying...' DO p0rlockn STORE .f. TO mreturn OTHERWISE * ' General Errors Section DO WHILE .NOT. mwait $ 'IRSQ' ?? CHR(7) @ mln,0 CLEAR @ mln,0 SAY 'Error: ' + LTRIM(STR(errornum,4,0)) + ; ', ' + TRIM(errormes) @ mln,48 SAY ' (Ignore/Retry/Suspend/Quit) 'GET mwait PICTURE '!' READ ENDDO @ mln,0 CLEAR DO CASE CASE mwait = 'I' DO p0clrprn STORE .t. TO mreturn CASE mwait = 'R' DO p0clrprn STORE .f. TO mreturn CASE mwait = 'S' ? ? 'Error/Escape trapping disabled.' ON ERROR ON ESCAPE SUSPEND STORE .f. TO mreturn CASE mwait = 'Q' DO p0clrenv QUIT ENDCASE ENDCASE @ mln,0 STORE mxcon TO m0con STORE mxdev TO m0dev STORE mxprt TO m0prt DO p0clrprn IF mreturn RETURN ELSE RETRY ENDIF * ' EOP - P0ERRORS * * * ' Procedure Name: P0FLOCKD * ' Purpose or Function: Locks file with display of prompt * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: File to be locked open in current area * ' Variables Returned: lockedf = logical, .t. if file locked * PROCEDURE p0flockd PRIVATE mwait, mln, msg RELEASE lockedf PUBLIC lockedf STORE .f. TO lockedf STORE '' TO msg DO CASE CASE LEN(DBF()) = 0 STORE 'FLOCK Attempt with no file open. ' TO msg CASE FLOCK() STORE .t. TO lockedf ENDCASE IF .NOT. lockedf SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF @ mln,0 IF LEN(msg) > 0 ?? CHR(7) STORE ' ' TO mwait @ mln,0 SAY msg + ' Press any key...' GET mwait READ ELSE STORE 'Y' TO mwait DO WHILE .NOT. lockedf ?? CHR(7) @ mln,0 SAY TRIM(UPPER(DBF())) + ' in use. Retry File Lock? (Y/N) ' ; GET mwait PICTURE 'Y' READ IF mwait = 'N' EXIT ENDIF STORE FLOCK() TO lockedf ENDDO ENDIF && LEN(msg) > 0 @ mln,0 DO p0clrprn ENDIF && .NOT. lockedf RETURN * ' EOP - P0FLOCKD * * * ' Procedure Name: P0FLOCKN * ' Purpose or Function: Locks file WITHOUT display of prompt * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: File to be locked open in current area * ' Variables Returned: lockedf = logical, .t. if file locked * PROCEDURE p0flockn PRIVATE mwait, mln, msg RELEASE lockedf PUBLIC lockedf STORE .f. TO lockedf STORE '' TO msg DO CASE CASE LEN(DBF()) = 0 STORE 'FLOCK Attempt with no file open. ' TO msg CASE FLOCK() STORE .t. TO lockedf ENDCASE IF .NOT. lockedf IF TYPE ('m0color') = 'C' SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF @ mln,0 ENDIF IF LEN(msg) > 0 STORE .t. TO lockedf ?? CHR(7) STORE ' ' TO mwait @ mln,0 SAY msg + ' Press any key...' GET mwait READ ELSE DO WHILE .NOT. lockedf IF TYPE ('m0color') = 'C' @ mln,0 SAY ; TRIM(UPPER(DBF())) + ' in use. Attempting to lock file...' ENDIF STORE FLOCK() TO lockedf ENDDO ENDIF && LEN(msg) > 0 IF TYPE ('m0color') = 'C' @ mln,0 DO p0clrprn ENDIF ENDIF && .NOT. lockedf RETURN * ' EOP - P0FLOCKN * * * ' Procedure Name: P0RLOCKD * ' Purpose or Function: Locks Record with display of prompt * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: Record to be locked open in current area * ' Variables Returned: lockedr = logical, .t. if record locked * PROCEDURE p0rlockd PRIVATE mwait, mln, msg RELEASE lockedr PUBLIC lockedr STORE .f. TO lockedr STORE '' TO msg DO CASE CASE LEN(DBF()) = 0 STORE 'RLOCK Attempt with no file open. ' TO msg CASE BOF() .OR. EOF() STORE 'RLOCK at E/BOF() of ' + TRIM(UPPER(DBF())) TO msg CASE RLOCK() STORE .t. TO lockedr ENDCASE IF .NOT. lockedr SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF @ mln,0 IF LEN(msg) > 0 ?? CHR(7) STORE ' ' TO mwait @ mln,0 SAY msg + ' Press any key...' GET mwait READ ELSE STORE 'Y' TO mwait DO WHILE .NOT. lockedr ?? CHR(7) @ mln,0 SAY TRIM(UPPER(DBF())) + ' in use. Retry Rec Lock? (Y/N) ' ; GET mwait PICTURE 'Y' READ IF mwait = 'N' EXIT ENDIF STORE RLOCK() TO lockedr ENDDO ENDIF && LEN(msg) > 0 @ mln,0 DO p0clrprn ENDIF && .NOT. lockedr RETURN * ' EOP - P0RLOCKD * * * ' Procedure Name: P0RLOCKN * ' Purpose or Function: Locks record WITHOUT display of prompt * ' Parameters Passed: None * ' Variables Passed: None * ' Environment Passed: Record to be locked open in current area * ' Variables Returned: lockedr = logical, .t. if record locked * PROCEDURE p0rlockn PRIVATE mwait, mln, msg RELEASE lockedr PUBLIC lockedr STORE .f. TO lockedr STORE '' TO msg DO CASE CASE LEN(DBF()) = 0 STORE 'RLOCK Attempt with no file open. ' TO msg CASE BOF() .OR. EOF() STORE 'RLOCK at E/BOF() of ' + TRIM(UPPER(DBF())) TO msg CASE RLOCK() STORE .t. TO lockedr ENDCASE IF .NOT. lockedr STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF IF TYPE ('m0color') = 'C' SET CONSOLE ON SET DEVICE TO SCREEN SET PRINT OFF @ mln,0 ENDIF IF LEN(msg) > 0 STORE .t. TO lockedr ?? CHR(7) STORE ' ' TO mwait @ mln,0 SAY msg + ' Press any key...' GET mwait READ ELSE DO WHILE .NOT. lockedr IF TYPE ('m0color') = 'C' @ mln,0 SAY ; TRIM(UPPER(DBF())) + ' in use. Attempting to lock record...' ENDIF STORE RLOCK() TO lockedr ENDDO ENDIF && LEN(msg) > 0 IF TYPE ('m0color') = 'C' @ mln,0 DO p0clrprn ENDIF ENDIF && .NOT. lockedr RETURN * ' EOP - P0RLOCKN * * * ' Procedure Name: P0REREAD * ' Purpose or Function: Checks signature field of file before updating * ' Parameters Passed: msignature = numeric, previous signature value * ' Variables Passed: None * ' Environment Passed: Record to be checked open in current area * ' Variables Returned: unaltered = logical, .f. if record been altered * PROCEDURE p0reread PARAMETER msignature PRIVATE mwait, mln STORE 24 TO mln IF TYPE('m0switchar') = 'C' STORE IIF(m0switchar = '/',23,24) TO mln ENDIF RELEASE unaltered PUBLIC unaltered STORE ' ' TO mwait STORE .t. TO unaltered * ' Skip multiuser function if setup as single user IF .NOT. m0single IF signature <> msignature UNLOCK @ mln,0 ?? CHR(7) @ mln,3 SAY 'Record has been altered by another user. Press any key...' ; GET mwait READ @ mln,0 STORE .f. TO unaltered ENDIF ENDIF RETURN * ' EOP - P0REREAD * * * ' Procedure Name: P0SYSMNT * ' Purpose or Function: Checks for other users and sets Sys Maint. flag * ' Parameters Passed: mflag = logical with .t. = entering * ' .f. = leaving * ' Variables Passed: m0sysdr = System Drive for SYSDATA.DBF * ' Environment Passed: SYSDATA.DBF assumed not to be open in other areas * ' Variables Returned: mreturn = logical, .t. if okay to continue * PROCEDURE p0sysmnt PARAMETER mflag RELEASE mreturn PUBLIC mreturn PRIVATE mok, mans STORE .t. TO mok * ' Skip multiuser function if setup as single user IF .NOT. m0single STORE .f. TO mreturn IF TYPE('m0sysdr') <> 'C' STORE '' TO m0sysdr ENDIF IF FILE('&m0sysdr.sysdata.dbf') USE &m0sysdr.sysdata LOCATE FOR UPPER(sysid) = 'MM ' IF EOF() STORE .f. TO mok ELSE DO p0rlockd IF .NOT. lockedr USE RETURN ENDIF IF mflag IF num10 > 1 STORE ' ' TO mans USE * ' Display 'Requires only one user...' error message DO syshelp WITH 10001 RETURN ENDIF IF SUBSTR(str10,1,1) = 'Y' STORE ' ' TO mans USE * ' Display 'System Maintenance operation...' error message DO syshelp WITH 10002 RETURN ENDIF REPLACE str10 WITH 'Y' + SUBSTR(str10,2,9) ELSE REPLACE str10 WITH 'N' + SUBSTR(str10,2,9) ENDIF ENDIF ENDIF IF .NOT. mok STORE ' ' TO mans USE * ' Display 'SYSDATA record or file missing...' error message DO syshelp WITH 9001 DO p0clrenv CANCEL ENDIF ENDIF STORE .t. TO mreturn USE RETURN * ' EOP - P0SYSMNT * * * ' Procedure Name: P0USRCNT * ' Purpose or Function: Maintains count of users in all modules * ' Parameters Passed: mincr = logical, .t. = increment, .f. = decrement * ' Variables Passed: m0sysdr = System Drive for SYSDATA.DBF * ' Environment Passed: SYSDATA.DBF assumed not to be open in other areas * ' Variables Returned: none * PROCEDURE p0usrcnt PARAMETER mincr * ' Skip multiuser function if setup as single user IF .NOT. m0single IF TYPE('m0sysdr') <> 'C' STORE '' TO m0sysdr ENDIF IF FILE('&m0sysdr.sysdata.dbf') USE &m0sysdr.sysdata LOCATE FOR UPPER(sysid) = 'MM ' IF .NOT. EOF() DO p0rlockn IF mincr REPLACE num10 WITH num10 + 1 ELSE REPLACE num10 WITH IIF(num10 - 1 >= 0, num10 - 1, 0) ENDIF UNLOCK ENDIF ENDIF ENDIF RETURN * ' EOP - P0USRCNT * * * * ' Procedure Name: P0ARRAYS * ' Purpose or Function: Create arrays for menu litebars * ' Environment: Opens SYS??MN.DBF in area I * ' Parameters Passed: None * ' Variables Passed: None * ' Variables Returned: a0?????? = Arrays with names of menu prgs * * ' Data Structure for SYS??MN.DBF * ' Field Name Type Width * * ' MENUPRG Character 8 = Calling menu program (e.g. ARMENU) * ' COND Character 55 = Condition for prompt to be active; * ' .t. = Always active * ' TITLE Character 43 = Prompt contents (including option #) * ' DISPROW Numeric 2 = Row to display prompt * ' DISPCOL Numeric 2 = Column to display prompt * ' OPPCOL Numeric 2 = Count for opposite column, 0 if none * PROCEDURE p0arrays * ' Clear path and set default to dbf drive first SET PATH TO SET DEFAULT TO &m0dbfdr IF FILE('&m0passf..dbf') @ 22,0 @ 22,8 SAY 'Building Arrays for Light Bar Menus...' * ' Turn off ESCAPE in routine to prevent odd INKEY interactions SET ESCAPE OFF * ' Initialize menu file variables STORE 'SYS' + m0pgmid + 'MN' TO menuf STORE 'SYS' + m0pgmid + 'MO' TO menuo * ' columns in arrays NB: Col 5 used in row 1 to store array size (msize) STORE 1 TO ztitle STORE 2 TO zrow STORE 3 TO zcol STORE 4 TO zoppcol * ' Open Menu file with index by location in work area I SELECT i USE &m0sysdr.&menuf INDEX &m0sysdr.&menuo..ndx * ' Primary Index: menuprg+SUBSTR(STR(1000 + disprow + dispcol,4,0),2,3) IF EOF() * ' call error message if empty file DO syshelp WITH 9006 CANCEL ENDIF DO WHILE .NOT. EOF() STORE i->menuprg TO mmenu * ' define name of the array STORE 'a0' + TRIM(i->menuprg) TO zmenu * ' count the number of options in this menu COUNT TO msize WHILE i->menuprg = mmenu * ' Two-dimensional array. Array is # menu options by # fields in file. * ' Release array memvars before defining public RELEASE &zmenu PUBLIC &zmenu(msize,5) SEEK mmenu STORE 1 TO mcount * ' Add values to array from MENU file for current menu DO WHILE i->menuprg = mmenu .AND. .NOT. EOF() * ' Add values to sub-arrays from MENU file for current menu STORE i->title TO &zmenu(mcount,ztitle) STORE i->cond TO mcond IF &mcond .AND. .NOT. DELETED() * ' Add to array if menu option availbl under current system choices STORE i->disprow TO &zmenu(mcount,zrow) STORE i->dispcol TO &zmenu(mcount,zcol) IF TYPE('&zmenu(mcount,zoppcol)') = 'L' * ' If opposite column not yet initialized to 0 by unavailable option STORE i->oppcol TO &zmenu(mcount,zoppcol) ENDIF ELSE * ' Create zeroed entry if menu option not available STORE 0 TO &zmenu(mcount,zrow) STORE 0 TO &zmenu(mcount,zcol) STORE 0 TO &zmenu(mcount,zoppcol) IF i->oppcol <> 0 * ' Define current option unavailable from opposite option STORE 0 TO &zmenu(i->oppcol,zoppcol) ENDIF ENDIF STORE mcount + 1 TO mcount SKIP ENDDO && WHILE i->menuprg = mmenu .AND. .NOT. EOF() STORE msize TO &zmenu(1,5) STORE 0 TO &zmenu(2,5) ENDDO && WHILE .NOT. EOF() * ' Create memfile if not running under Clipper IF TYPE('m0arrayf') = 'C' SAVE ALL LIKE a0* TO &m0arrayf..mem ENDIF RELEASE ztitle, zrow, zcol, zoppcol * ' Close menu file and reopen primary work area USE SELECT a @ 22,0 ENDIF IF m0switchar $ m0cmddr SET PATH TO &m0cmddr SET DEFAULT TO &m0sysdr ELSE SET DEFAULT TO &m0cmddr ENDIF RETURN * ' EOP - P0ARRAYS * * * * ' Procedure Name: P0SELECT * ' Purpose or Function: Provides hilighted bar options for menu programs * ' Parameters Passed: mmenu = name of calling program * ' mstart = the default choice when entering * ' (Usually 'Q') * ' mvalopts = valid choices for the menu involved * ' choice = initial choice value (usually ' ') * ' mcol1 = left column * ' mcol2 = right column (zero if single col menu) * ' Variables Passed: None * ' Variables Returned: choice = The option chosen * * ' Example: DO p0select WITH 'ARMENU', 'Q', 'Q12345FICUABCPR', ' ', 5, 42 * PROCEDURE p0select PARAMETERS mmenu, mstart, mvalopts, choice, mcol1, mcol2 * ' Turn off ESCAPE in routine to prevent odd INKEY interactions SET ESCAPE OFF * ' most lite bars should be 33 characters long. If longer mbarlen is fed IF TYPE('mbarlen') = 'U' STORE 33 TO mbarlen ENDIF * ' Get array size from first entry for current menu STORE 'a0' + TRIM(mmenu) TO zmenu * ' Col 5 used in row 1 to store array size (msize) STORE &zmenu(1,5) TO msize STORE 1 TO ztitle STORE 2 TO zrow STORE 3 TO zcol STORE 4 TO zoppcol * DO WHILE .NOT. choice $ mvalopts * ' While value of 'choice' is not valid STORE 'Highlight' TO mmess1 @ 22,14 GET mmess1 @ 22,24 SAY 'and <Enter> or Press Menu Letter to Select' CLEAR GETS * ' Initialize counter to array location of default entry STORE msize TO mcount * ' Go to first available menu option in array DO WHILE (&zmenu(mcount,zrow) = 0 .AND. &zmenu(mcount,zcol) = 0) ; .AND. mcount > 1 STORE mcount - 1 TO mcount ENDDO * ' Action loop, highlight current menu option and move to next option DO WHILE .t. STORE 0 TO mkey IF TYPE('&zmenu(mcount,ztitle)') <> 'L' * ' If current location defined member of array STORE SUBSTR(&zmenu(mcount,ztitle),1,mbarlen) TO mtitle @ &zmenu(mcount,zrow),&zmenu(mcount,zcol) GET mtitle @ &zmenu(mcount,zrow),&zmenu(mcount,zcol) SAY '' CLEAR GETS DO WHILE mkey = 0 * ' Set inkey parameter to 10 to minimize delays * ' on single processor systems (Xenix, PCMOS, etc) STORE MAX(INKEY(10),0) TO mkey ENDDO @ &zmenu(mcount,zrow),&zmenu(mcount,zcol) SAY mtitle ENDIF DO CASE CASE UPPER(CHR(mkey)) $ mvalopts * ' If letter in valid option list was entered, use that STORE UPPER(CHR(mkey)) TO choice IF .NOT. choice $ '.' * ' Highlight choice from menu file entry STORE 1 TO mcount DO WHILE mcount <= msize .AND. (choice <> ; SUBSTR(&zmenu(mcount,ztitle),1,1) .OR. (choice = ; SUBSTR(&zmenu(mcount,ztitle),1,1) .AND. ; (&zmenu(mcount,zrow) = 0 .AND. &zmenu(mcount,zcol) = 0))) STORE mcount + 1 TO mcount ENDDO STORE SUBSTR(&zmenu(mcount,ztitle),1,mbarlen) TO mtitle ENDIF EXIT CASE mkey = 4 .OR. mkey = 19 * ' If left or right arrow, move to opposite column IF mcol2 <> 0 * ' if there is a 2nd column STORE IIF(&zmenu(mcount,zoppcol) = 0, ; mcount,&zmenu(mcount,zoppcol)) TO mcount ENDIF CASE mkey = 5 * ' Up arrow key STORE IIF(mcount > 1,mcount - 1,msize) TO mcount DO WHILE (&zmenu(mcount,zrow) = 0 .AND. &zmenu(mcount,zcol) = 0) ; .AND. mcount > 1 * ' Go to next available menu option in array STORE IIF(mcount > 1,mcount - 1,msize) TO mcount ENDDO CASE mkey = 24 * ' Down arrow key STORE IIF(mcount < msize,mcount + 1,1) TO mcount DO WHILE (&zmenu(mcount,zrow) = 0 .AND. &zmenu(mcount,zcol) = 0) ; .AND. mcount > 1 * ' Go to next available menu option in array STORE IIF(mcount < msize,mcount + 1,1) TO mcount ENDDO CASE mkey = 13 * ' Enter key selects hilighted option IF SUBSTR(mtitle,1,1) $ mvalopts STORE SUBSTR(mtitle,1,1) TO choice STORE mcount TO &zmenu(2,5) EXIT ENDIF OTHERWISE * ' Invalid keystroke/option ?? CHR(7) ENDCASE ENDDO && WHILE .t. CLEAR GETS ENDDO && WHILE .NOT. choice $ mvalopts IF .NOT. choice $ '.' * ' Highlight choice on menu @ &zmenu(mcount,zrow),&zmenu(mcount,zcol) GET mtitle @ &zmenu(mcount,zrow),&zmenu(mcount,zcol) SAY '' CLEAR GETS ENDIF RELEASE ALL LIKE z* SET ESCAPE ON RETURN * ' EOP - P0SELECT * ' PROCEDURE p0memclr * ' Dummy stub; used in Clipper - compiled, Alink - linked Payroll. RETURN * * * * ' Procedure Name: p0txarry * ' Purpose or Function: Builds arrays for storing tax rates and accumu- * ' lated tax liabilities by tax code * ' * ' Parameters Passed mtaxrate - tax rate from form header * ' mselarea - work area selected upon entry into proc * ' Variables Passed: * ' * ' Example: Called as DO p0txarry WITH mtaxrate, 'c' * PROCEDURE p0txarry PARAMETERS mtaxrate, mselarea IF m0lntax PUBLIC a0taxrate(26), a0taxable(26), a0taxsubt(26), a0taxacct(26) SELECT i USE &m0sysvatf STORE 1 TO mcode DO WHILE .NOT. EOF() * ' tax rate is -1 for undefined codes STORE IIF(i->taxcode <> ' ', i->taxrate, -1) TO a0taxrate(mcode) STORE i->acctout TO a0taxacct(mcode) STORE 0.00 TO a0taxable(mcode), a0taxsubt(mcode) SKIP STORE mcode + 1 TO mcode ENDDO USE SELECT &mselarea ELSE PUBLIC a0taxrate(2), a0taxable(2), a0taxsubt(2) STORE mtaxrate TO a0taxrate(1) STORE 0.00 TO a0taxrate(2), a0taxable(1), a0taxable(2), a0taxsubt(1), ; a0taxsubt(2) ENDIF RETURN * ' EOP p0txarray * * ' Procedure Name: p0frmclc * ' Purpose or Function: Calculates taxable and tax totals for each tax * ' type on an invoice, purchase order, or sales order * ' Parameters Passed mcond - condition under which processing of line * ' items continues * ' mformsub - sum of extended prices of lines on * ' form * ' mformtax - total tax on form * ' mformtotl - total of form * ' Variables Passed: * ' Environment Passed: transaction file selected and record pointer * ' positioned on first record of form * ' Variables Returned: * ' * ' Example: Called as DO p0frmclc WITH 'custno = mcust .AND. * ' sono = msono .AND. .NOT. EOF()', mordsub, mtax, mordamt * * PROCEDURE p0frmclc PARAMETER mcond, mformsub, mformtax, mformtotl IF .NOT. EOF() * ' Condition essentially protects against data errors. Should never be true STORE RECNO() TO mrec DO WHILE &mcond * ' Determine array subscript of this tran record's tax code DO CASE CASE .NOT. m0lntax STORE IIF(taxable = 'Y', 1, 2) TO mcode CASE m0lntax .AND. ASC(UPPER(taxcode)) > 64 .AND. ASC(UPPER(taxcode)) < 91 * ' Valid tax code which maps to a valid array subscript STORE ASC(UPPER(taxcode)) - 64 TO mcode OTHERWISE * ' Invalid tax codes are accumulated in rate 'Z' STORE 26 TO mcode ENDCASE * ' Calculate subtotal for each tax code in a0taxable(mcode) STORE a0taxable(mcode) + extprice TO a0taxable(mcode) * ' Update taxable and tax for current code plus form total tax and total STORE a0taxsubt(mcode) TO moldtax * ' Use taxrate from tran record for calculation of tax on current code * ' The stored rate may no longer be the same as the rate in the table. STORE .01 * INT(taxrate * a0taxable(mcode) + ; IIF(taxrate * a0taxable(mcode) < 0, -.5, .5)) TO a0taxsubt(mcode) * ' Calculate the totals for current form STORE mformsub + extprice TO mformsub STORE mformtax - moldtax + a0taxsubt(mcode) TO mformtax STORE mformsub + mformtax TO mformtotl SKIP ENDDO GOTO mrec ENDIF RETURN * ' EOP p0frmclc * * ' Procedure Name: p0linclc * ' Purpose or Function: Calculates taxable and tax totals for each tax * ' type on an invoice, purchase order, or sales order * ' when line is added or edited * ' * ' Parameters Passed maction - 'A': item being added to form * ' 'D': item being deleted from form * ' 'E': item being edited * ' form, rather than being edited * ' mformsub - sum of extended prices of lines on * ' form * ' mformtax - total tax on form * ' mformtotl - total of form * ' mextprice - extprice of new line item or new * ' extended price of line item after edit * ' Variables Passed: * ' Environment Passed: if editing or deleting, transaction file * ' selected and record pointer positioned on record * ' being edited/deleted; if adding, memvar copy * ' of detail record in memory * ' * ' Example: Called as DO p0linclc WITH 'A', iordsub, itax, * ' iordamt, 'b', iextprice, itaxcode * PROCEDURE p0linclc PARAMETERS maction, mformsub, mformtax, mformtotl, mextprice, mtaxcode * ' Determine array subscript of this line's tax code and of its previous * ' tax code, if its being edited DO CASE CASE .NOT. m0lntax STORE IIF(mtaxcode = 'Y', 1, 2) TO mcode STORE mcode TO mocode IF maction = 'E' STORE IIF(taxable = 'Y', 1, 2) TO mocode ENDIF CASE ASC(UPPER(mtaxcode)) > 64 .AND. ASC(UPPER(mtaxcode)) < 91 STORE ASC(UPPER(mtaxcode)) - 64 TO mcode STORE mcode TO mocode IF maction = 'E' .AND. ASC(UPPER(taxcode)) > 64 .AND. ASC(UPPER(taxcode)) < 91 * ' Protection against invalid stored code STORE ASC(UPPER(taxcode)) - 64 TO mocode ENDIF OTHERWISE STORE 26 TO mcode, mocode IF maction = 'E' .AND. ASC(UPPER(taxcode)) > 64 .AND. ASC(UPPER(taxcode)) < 91 * ' Protection against invalid stored code STORE ASC(UPPER(taxcode)) - 64 TO mocode ENDIF ENDCASE * IF maction = 'E' && editing line on current form STORE mformsub - extprice TO mformsub * ' Calculate subtotal and tax for taxcode before the edit (backing out line) STORE a0taxable(mocode) - extprice TO a0taxable(mocode) * ' Save the previous tax for this taxcode for difference calculation below STORE a0taxsubt(mocode) TO moldtax1 * ' Calculate the new tax on the taxable after the original line is backed out * ' Use stored rate when editing a line STORE .01 * INT(taxrate * a0taxable(mocode) + ; IIF(taxrate * a0taxable(mocode) < 0, -.5, .5)) TO a0taxsubt(mocode) ENDIF * * ' Calculate new subtotal and tax for taxcode after the add/edit STORE a0taxable(mcode) + mextprice TO a0taxable(mcode) * ' Save the previous tax for this taxcode for difference calculation below STORE a0taxsubt(mcode) TO moldtax2 IF maction $ 'AD' STORE moldtax2 TO moldtax1 ENDIF * ' Calculate the new tax on the new taxable for this code IF maction = 'A' .OR. mcode <> mocode STORE .01 * INT(a0taxrate(mcode) * a0taxable(mcode) + ; IIF(a0taxrate(mcode) * a0taxable(mcode) < 0, -.5, .5)) TO a0taxsubt(mcode) ELSE * ' Use stored tax rate if editing line STORE .01 * INT(taxrate * a0taxable(mcode) + ; IIF(taxrate * a0taxable(mcode) < 0, -.5, .5)) TO a0taxsubt(mcode) ENDIF * * ' Calculate new subtotal for all taxes and total for form * ' If tax code has not changed or this is a new line, add difference between * ' tax for code after add/edit and tax for code before add/edit. if tax code * ' has changed add difference in tax subtotals for old and new tax codes IF mocode = mcode STORE mformtax + a0taxsubt(mcode) - moldtax1 TO mformtax ELSE STORE mformtax + (a0taxsubt(mcode) - moldtax2) + (a0taxsubt(mocode) - ; moldtax1) TO mformtax ENDIF STORE mformsub + mextprice TO mformsub STORE mformsub + mformtax TO mformtotl RETURN * ' EOP p0linclc * * * ' Procedure Name: p0psttax * ' Purpose or Function: Posts tax to link file for line item transactions * ' * ' Parameters Passed mlnkarea - work area in which xxGLLK is open * ' mliabt - sales tax liability account, non-VAT * ' Variables Passed: a0taxsubt - Array of tax totals by taxcode * ' 26 elements for VAT, 2 for non-VAT * * PROCEDURE p0psttax PARAMETERS mlnkarea, mliabt STORE 1 TO mcnt DO WHILE mcnt <= IIF(m0lntax, 26, 1) IF a0taxsubt(mcnt) <> 0 SELECT &mlnkarea SEEK IIF(m0lntax, a0taxacct(mcnt), mliabt) IF EOF() APPEND BLANK REPLACE account WITH IIF(m0lntax, a0taxacct(mcnt), mliabt) ENDIF REPLACE amount WITH amount - a0taxsubt(mcnt) ENDIF STORE mcnt + 1 TO mcnt ENDDO RETURN * ' EOP p0psttax * * ' Procedure Name: p0prntax * ' Purpose or Function: Prints VAT table * ' Parameters Passed: mline: line to start printing table on * ' mcol: column to start printing table on * ' mvars: string of two variables separated by '|' * * ' Example: Called as DO p0prntax WITH mline, micol1, 'msub|mtax' * PROCEDURE p0prntax PARAMETERS mline, mcol, mvars STORE 1 TO mcnt * ' Set up and print VAT summary table STORE SUBSTR(mvars, 1, AT('|', mvars) - 1) TO mvatsub STORE SUBSTR(mvars, AT('|', mvars) + 1, LEN(TRIM(mvars))) TO mvatamt * ' Reinitializes variables passed in string STORE 0 TO &mvatsub STORE 0 TO &mvatamt @ mline,mcol + 1 SAY 'VAT Code Description % Rate ' + ; ' Subtotal Total Tax' @ mline + 1,mcol + 1 SAY '-------- ------------ ------ ' + ; '------------ ------------' STORE mline + 2 TO mline * ' Print body of VAT summary table DO WHILE mcnt <= 26 IF a0taxsubt(mcnt) <> 0 .OR. a0taxable(mcnt) <> 0 LOCATE FOR i->taxcode = CHR(mcnt + 64) @ mline,mcol + 4 SAY i->taxcode @ mline,mcol + 11 SAY i->taxdesc @ mline,mcol + 26 SAY i->taxrate PICTURE '99.99' @ mline,mcol + 33 SAY a0taxable(mcnt) PICTURE '99999999.99' @ mline,mcol + 48 SAY a0taxsubt(mcnt) PICTURE '99999999.99' * ' Accumulates running total of summary variables STORE &mvatsub + a0taxable(mcnt) TO &mvatsub STORE &mvatamt + a0taxsubt(mcnt) TO &mvatamt STORE mline + 1 TO mline ENDIF STORE mcnt + 1 TO mcnt ENDDO USE * ' Print totals of VAT summary table @ mline,mcol + 33 SAY '------------ ------------' @ mline + 1,mcol + 1 SAY 'Totals' @ mline + 1,mcol + 33 SAY &mvatsub PICTURE '99999999.99' @ mline + 1,mcol + 48 SAY &mvatamt PICTURE '99999999.99' * ' EOP p0prntax * * ' Procedure Name: f0numtax * ' Purpose or Function: calculates how many codes in tax table * ' have non-zero entries * ' Parameters Passed: * ' * ' Returns mcount = for mchoice = 1, # of codes with non-zero entries * ' Example: Called as STORE f0numtax TO mrecs * PROCEDURE f0numtax STORE 0 TO mcount STORE 1 TO mcnt DO WHILE mcnt <= 26 IF a0taxsubt(mcnt) <> 0 .OR. a0taxable(mcnt) <> 0 STORE mcount + 1 TO mcount ENDIF STORE mcnt + 1 TO mcnt ENDDO RETURN mcount * ' EOP f0numtax * * ' Procedure Name: f0taxval * ' Purpose or Function: returns single value from tax array * ' Parameters Passed: mval: value you want to retrieve, either 'rate', * ' 'acct', 'taxable', or 'subtax' * ' mrow: row of the array you want a value for * ' Returns mvalue = value of selected array entry * ' Example: Called as STORE f0taxval('subtax', 4) TO mtaxd * ' PROCEDURE f0taxval PARAMETERS mval, mrow IF mrow < 1 .OR. mrow > 26 * ' Protection against invalid taxcodes STORE 26 TO mrow ENDIF DO CASE CASE mval = 'rate' STORE a0taxrate(mrow) TO mvalue CASE mval = 'acct' STORE a0taxacct(mrow) TO mvalue CASE mval = 'taxable' STORE a0taxable(mrow) TO mvalue CASE mval = 'subtax' STORE a0taxsubt(mrow) TO mvalue ENDCASE RETURN mvalue * ' EOP f0taxval * * ' Procedure Name: f0extlin * ' Purpose or Function: Calculates extended cost or price for line item * ' * ' Parameters Passed mqty - quantity on current line * ' mprice - price or cost of item on current line * ' mdisc - discount rate for current line * ' Variables Passed: * ' Environment Passed: * * ' Returns: Calculated extended price or cost * ' * ' Example: STORE f0extline(iqtyshp, iprice, idisc) TO iextprice * * PROCEDURE f0extlin PARAMETERS mqty, mprice, mdisc IF mqty * mprice * (100 - mdisc) < 0 STORE .01 * INT(mqty * mprice * (100 - mdisc) - .5) TO mextprice ELSE STORE .01 * INT(mqty * mprice * (100 - mdisc) + .5) TO mextprice ENDIF RETURN mextprice * ' EOP f0extline * * ' Procedure Name: P0GRDLIN * ' Purpose or Function: Displays Single Line of Option Grid * ' Parameters Passed: mline = current line number * ' moption = first column option * ' mchoices = Choice list * ' mgetvars = Variables to GET choice into * ' mgetpict = picture clause * * ' Example: Called as DO p0grdline WITH mline, 'Beginning Account', * ' '(blank for all)', 'mbaccnt', '#####-###' * PROCEDURE p0grdlin PARAMETERS mline, moption, mchoices, mgetvars, mgetpict @ mline,4 SAY moption @ mline,24 SAY mchoices IF .NOT. '|' $ mgetpict STORE mgetpict TO mgetpict1, mgetpict2 ELSE STORE SUBSTR(mgetpict, 1, AT('|', mgetpict) - 1) TO mgetpict1 STORE SUBSTR(mgetpict, AT('|', mgetpict) + 1, LEN(TRIM(mgetpict))) ; TO mgetpict2 ENDIF IF .NOT. '|' $ mgetvars @ mline, 61 GET &mgetvars PICTURE '&mgetpict1' ELSE STORE SUBSTR(mgetvars, 1, AT('|', mgetvars) - 1) TO mgetvar1 STORE SUBSTR(mgetvars, AT('|', mgetvars) + 1, LEN(TRIM(mgetvars))) TO mgetvar2 @ mline,60 GET &mgetvar1 PICTURE '&mgetpict1' @ mline, COL() + 1 GET &mgetvar2 PICTURE '&mgetpict2' ENDIF STORE mline + 2 TO mline RETURN * ' EOP p0grdlin * * ' Procedure Name: P0REGET * ' Purpose or Function: Allows data entry into single GET; typically used * ' after field validation fails * ' Parameters Passed: mbellon = logical, beep * ' mmsgrow = Row to display error message * ' mmsgcol = column to start message on * ' mgetrow = row to reGET variable * ' mgetcol = column to reGET variable * ' mgetvar = variable to GET * ' mgetpict = picture clause * ' merrmsg = error message * * ' Example: Called as DO p0reget WITH .t., 23, 0, mline, 61, mrange, '!', * ' 'Must be B, S, or A. Please reenter...' * PROCEDURE p0reget PARAMETERS mbellon, mmsgrow, mmsgcol, mgetrow, mgetcol, mgetvar, mgetpict, ; merrmsg IF mbellon ?? CHR(7) ENDIF @ mmsgrow, mmsgcol @ mmsgrow, mmsgcol SAY merrmsg @ mgetrow, mgetcol GET mgetvar PICTURE '&mgetpict' READ @ mmsgrow, mmsgcol SAY SPACE(LEN(merrmsg)) RETURN * ' EOP p0reget * * ' Procedure Name: f0wkdays * ' Purpose or Function: Calculates number of working days in a month * ' up to and including the passed date * ' * ' Parameters Passed: mlast - date through which to calculate number * ' of working days * ' * ' Returns: Calculated number of working days through mlast * ' * ' Example: STORE f0wkdays(m0date) TO mwkday1 * ' PROCEDURE f0wkdays PARAMETERS mlast PRIVATE mmonth, myear, mdays, mfirst STORE MONTH(mlast) TO mmonth STORE YEAR(mlast) TO myear STORE DAY(mlast) TO mdays * ' Determine day of week number STORE DOW(CTOD(LTRIM(STR(mmonth)) + '/01/' + LTRIM(STR(myear)))) TO mfirst * ' Determine number of working days to mlast STORE mdays - (INT(mdays/7) * 2) - IIF(mfirst = 1 .OR. mfirst = 7, ; 1, 0) TO mwkdays DO CASE * ' February and day is greater than day on which Wash b-day is observed CASE mmonth = 1 STORE mwkdays - 1 TO mwkdays CASE mmonth = 2 .AND. mdays > IIF(mfirst > 2, 24 - mfirst, 17 - mfirst) STORE mwkdays - 1 TO mwkdays CASE mmonth = 5 .AND. mdays > IIF(mfirst > 2, 31 - mfirst, 24 - mfirst) STORE mwkdays - 1 TO mwkdays CASE mmonth = 7 .AND. mdays >= 4 STORE mwkdays - 1 TO mwkdays CASE mmonth = 9 .AND. mdays > IIF(mfirst > 2, 10 - mfirst, 3 - mfirst) STORE mwkdays - 1 TO mwkdays CASE mmonth = 11 .AND. mdays > 27 - mfirst STORE mwkdays - 1 TO mwkdays CASE mmonth = 12 .AND. mdays > 25 STORE mwkdays - 1 TO mwkdays ENDCASE RETURN mwkdays * EOF f0wkdays * * ' Procedure Name: f0wkmnth * ' Purpose or Function: Calculates number of working days in a month * ' * ' Parameters Passed: mmonth - number of the month to calculate working * ' days for, myear - last two digits of year to * ' calculate working days for * ' * ' Returns: Number of working days in month * ' represented by mmonth, myear * ' * ' Example: STORE f0wkmnth(4,90) TO mwkday1 * ' * Function to return number of working days in the month * ' Example: STORE f0wkmth(MONTH(m0date), YEAR(m0date)) TO mwkday2 PROCEDURE f0wkmnth PARAMETERS mmonth, myear * ' Build last day of the month STORE CTOD(LTRIM(STR(mmonth + 1)) + '/01/' + LTRIM(STR(myear))) -1 TO mlast * ' Call f0wkdays function to calculate working days through last day STORE f0wkdays(mlast) TO mwkdays RETURN mwkdays * ' EOF f0wkmnth ** ' $Revision: 1.60 $ * ' $Date: 21 May 1990 12:37:22 $ ********************** ** ' SYSMULT.PRG ' ** ** ' 2235 Lines ' ** **********************