* SERMAIN.PRG * * Serial Payment System * * Although the serial check-in functions are substantially * written they have NOT been completed. Only the serial * payment/accounting functions are in active use at the * Washington & Lee Law Library. * * * * * * * * * * * * * * * clear all set talk off ************************************************************************* * Area for Possible Modification * header1='WASHINGTON & LEE UNIVERSITY, LAW SCHOOL LIBRARY' header2='ACQUISITIONS SYSTEM' set default to C: && (make sure these DOS directories exist, and names end with '\') ProgPath='C:\DBASE\ACQ\' && path to .PRG .DBO program files DataPath='C:\DBASE\ACQ\' && path to .DBF .DBT .MDX data & index files TextPath='C:\WP50\DATA\' && path to transaction & report files TempPath='C:\DBASE\ACQ\' && path to temporary work area _pdriver='ascii.pr2' && name of dBase printer driver MaxFund =21 && Largest fund numb. in Serial Funds (max = 99) && SERBUDG.DBF must have this numb. of fields for each LIBRARY *************************************************************************** ***** Declare Arrays declare ExpArr[MaxFund+1] declare Aarray[30] declare Barray[30] ***** set color to set color to W+/B set autosave on set development on set exact off && IMPORTANT - all compares of strings return .T. if char-char * compares are identical up to end of RIGHT string; * i.e. what's on right must be a substring of what's on left set escape on on escape do esc set confirm off set exclusive on set heading off set memowidth to 240 set near on set path to &ProgPath set status off set scoreboard off x=0 y=fkmax() do while x < y x=x+1 set function Fklabel(x) to chr(13) enddo set function F9 to chr(23) set function F10 to chr(23) set typeahead to 60 set intensity off set delimiters to '[]' set delimiters on set bell off define window W1 from 0,0 to 5,79 NONE define window W2 from 6,0 to 24,79 double color W+/N,W+/N,N/BG define window W3 from 0,47 to 24,79 double define window Wmsg from 10,2 to 12,77 double color N/RB store { / / } to temppaiddate,begdate,enddate,receivedate store .F. to DateError mdate=date() AcceptDates=.F. deactivate window all clear fields close databases close alternate ************************ Recycle=.T. do while recycle recycle=.F. do Startup enddo ************************ && existence of report & transact file checked for wordprocessor use if .not. file(TextPath+'transact.ser') do alterfile with 'TRANSACT.SER' ? endif if .not. file(TextPath+'report.ser') do alterfile with 'REPORT.SER' ? endif close alternate Quit * * * * procedure ChangeDate clear @10,10 say 'MODIFY DATE : ' get tmpdate Read if Lastkey()<>-8 mdate=tmpdate endif return * * * * procedure MenuBox Parameters header3 set color to GR+/B clear clear typeahead @ 0,15 say header1 @ 2,15 say header2+" "+daystring @ 4,15 say header3 @0,0 fill to 5,79 color GR+/B set color to N/BG @ 6,1 to 17,78 double @ 7,2 fill to 16,77 color N/N set color to W+/N return * * * * procedure PassProcedure parameters header3 && Pass returns .T. if OK do MenuBox with header3 respon=space(18) @9,18 to 13,60 double color N/R @10,20 say 'AUTHORIZED ACCESS.' @11,20 say 'Enter Password, or to exit.' @12,20 get respon color X/X read set exact on pass=IIF((rtrim(ltrim(respon))='10' .and. lastkey()=-9),.T.,.F.) set exact off set color to W+/B return * * * * procedure MessageWindow parameters Msg activate window Wmsg ErrorFnd=.T. @0,0 say Msg+space(74-len(Msg)) xx=0 do while xx<=73 @ 0,xx fill to 0,xx color B/W xx=xx+1 enddo clear typeahead x=inkey(1) deactivate window Wmsg return * * * * procedure WaitMsg @24,0 say 'PRESS KEY TO CONTINUE' color R/B xxxx=inkey(300) return * * * * procedure ReadMenu parameters Respons,WhatsValid && intended for a 1-9 response menu option Goodkey=.F. && do while .not. Goodkey read save Lkey=Lastkey() if Lkey=-8 .or. AT(Respons,WhatsValid)>0 clear gets Goodkey=.T. if Lkey=-8 respons='9' endif endif enddo return * * * * procedure alterfile parameters Newfile && calls to this procedure must specify new file name to save to Newfile=TextPath+Newfile close alternate if .not. file(Newfile) set alternate to (Newfile) else set alternate to (newfile) ADDITIVE endif set alternate on return * * * * procedure DeleteFile parameters FilePath,FileName if file(FilePath+FileName) erase (FilePath+FileName) endif return * * * * procedure esc recycle=.T. close all return to MASTER * * * * procedure InitExpArr xxx=0 do while xxx=6,right(dtoc(mdate),2),; str(val(right(dtoc(mdate),2))-1,2)) BegDate=ctod('07/01/'+startyr) EndDate=mdate endif @ 2,2 to 4,30 double color N/BG @ 3,4 say 'Starting date 'get BegDate color GR+/N @ 6,2 to 8,30 double color N/BG @ 7,4 say 'Ending date 'get EndDate color GR+/N read DateError=IIF((EndDate3 NoColon=IIF(':' $ qtitle,.F.,.T.) do case case upper(qtitle)='A ' qtitle=substr(qtitle,3) if NoColon .and. lenqtitle<59 qtitle=qtitle+', A' endif case upper(qtitle)='AN ' qtitle=substr(qtitle,4) if NoColon .and. lenqtitle<58 qtitle=qtitle +', An' endif case upper(qtitle)='THE ' qtitle=substr(qtitle,5) if NoColon .and. lenqtitle<57 qtitle=qtitle+', The' endif endcase endif if islower(qtitle) qtitle=Upper(left(qtitle,1))+substr(qtitle,2) endif return * * * ************************************************************************ * Adds a new header procedure addheadrec endaddrec=.F. do while .not. endaddrec set exact off Select (HeaderFile) set order to XTITLE clear qtitle=space(70) store space(30) to qpublisher,qsupplier qfund=0 qnotes='N' @ 0,10 say 'CREATING NEW TITLE' @ 0,40 say 'F9 = EXIT' @ 1,0 say 'TITLE' @ 1,8 get qtitle color GR+/N read qtitle=rtrim(ltrim(qtitle)) lenqtitle= len(qtitle) if lenqtitle=0 .or. lastkey()=-8 && F9 to exit endaddrec=.T. loop else do InvArticles && moves front articles, a an the , to end of line endif respon='C' do DupTitles with qtitle && check for duplicate titles in database if respon='D' loop endif clear @ 0,0 say 'TITLE' @ 0,7 say qtitle do GetSuppl @ 1,0 clear @ 1,0 say 'SUPPLIER' @ 1,10 say qsupplier @ 4,0 say 'PUBLISHER' @ 4,10 get qpublisher color GR+/N @ 5,20 say "** Leave PUBLISHER blank if also the SUPPLIER **" read if len(ltrim(qpublisher))<1 qpublisher=qsupplier endif @ 2,0 clear @ 2,0 say 'PUBLISHER' @ 2,10 say qpublisher @ 3,0 clear @ 4,1 say 'FUND' @ 4,14 get qfund picture '@B 99' range 1,MaxFund color GR+/N @ 6,1 say 'NOTES (Y/N)?' @ 6,14 get qnotes picture 'Y' color GR+/N read @ 3,9 say qfund picture '@B' @ 4,0 clear to 8,79 memnote='' if qnotes='Y' memnote=space(240) @5,0 to 5,79 double @5,30 say '<< NOTES >>' color GR+/N set delimiters off @6,0 get memnote color GR+/B set delimiters on @9,0 to 9,79 panel read @ 4,0 clear memnote=rtrim(memnote) if len(memnote)>0 @5,0 say memnote color GR+/B endif endif &&(qnotes = Y) clear typeahead @ 9,3 to 14,27 double color N/BG respon='S' @ 10,5 say 'S SAVE' @ 11,5 say 'E EDIT' @ 12,5 say 'D DELETE' @ 13,4 get respon picture '!' color GR+/N do readMenu with respon,'SED' if .not. (respon='D' .or. respon='9') && not delete or F9 set order to XHEADNUMB set exact on seek 50000 && records > 50000 are cross references only if (HEADNUMB>=50000 .or. eof()) .and. .not. bof() skip-1 endif newtitleno=HEADNUMB+1 if seek(newtitleno) &&(protection against duplicate headnumb) newtitleno=1 notfound=.T. do while notfound if seek(newtitleno) newtitleno=newtitleno+1 else notfound=.F. endif enddo endif append blank mnHeadNumb=newtitleno mnTitle=qtitle mnPublisher=qpublisher mnSupplier=qsupplier mnFund=qfund replace HEADNUMB with mnHeadNumb,TITLE with mnTitle,; PUBLISHER with mnPublisher, SUPPLIER with mnSupplier,; FUND with mnFund set console off ? ? '*****' ? mdy(mdate),' ',time() ? '-- NEW HEADER --' ? rtrim(mnTitle) ? rtrim(mnPublisher) ? rtrim(mnSupplier) ? mnFund picture '99' if len(memnote)>0 ? rtrim(memnote) replace NOTES with memnote endif set console on if respon='E' do EditHeader endif do XRefAdd endif &&(Respon<>'D') clear set exact off enddo return * * * ********************************************************************** * Checks for existence of similar header titles procedure DupTitles parameters TitString q20title=upper(left(TitString,20)) if seek(q20title) .and. upper(title)=q20title && possible duplicates @ 7,0 clear @ 10,10 say 'Following begin with the same characters' ? scan rest while upper(title)=q20title ? title endscan @ 7,23 to 9,52 double clear typeahead @ 8,24 say '(C) Continue (D) Delete ' get respon picture '!' color GR+/N do readMenu with respon,'CD' if respon $ "D9" && or F9 respon='D' qtitle=space(70) endif endif && possible duplicates return * * * ************************************************************************** * Adding or editing cross reference titles procedure XRef set alternate off if mnHeadNumb>0 .and. mnHeadNumb<50000 oldrecno=recno() referheadnumb=mnHeadNumb+50000 clear set order to xheadnumb set exact on respon='9' @0,5 say title color GR+/B if seek(referheadnumb) ReferExists=.T. startrec=recno() @1,25 say 'Existing cross-references' color GR+/N scan rest while HEADNUMB=referheadnumb ? TITLE endscan @11,33 to 19,58 double color N/BG @12,35 say 'TITLE CROSS-REFERENCES' @14,35 say '1 Add' @15,35 say '2 Edit/Delete' @17,35 say '9 Exit' @18,34 get respon picture '9' color GR+/N do readMenu with respon,'129' do case case respon='1' goto oldrecno do XRefAdd case respon='2' goto startrec &&(first cross-ref.) do XRefEdit case respon='9' endcase else && (no cross references exist) ReferExists=.F. goto oldrecno do XRefAdd endif &&(seek referheadnumb) set exact off goto oldrecno endif &&(HEADNUMB>0 and <50000) set alternate on return * * * * *************************************** procedure XRefEdit clear @0,5 say upper(mnTitle) color GR+/N @1,15 say 'CROSS REFERENCES' color GR+/B ReferCntr=0 scan rest while ReferCntr<20 .and. HEADNUMB=Referheadnumb ReferCntr=ReferCntr+1 @ ReferCntr+1,0 say str(ReferCntr,2)+' ' Aarray[ReferCntr]=TITLE Barray[ReferCntr]=recno() @ ReferCntr+1,4 get Aarray[ReferCntr] color GR+/N endscan if ReferCntr>0 @22,0 to 24,70 double color N/BG @23,15 say 'Modify or delete cross reference titles' @24,15 say ' F10 to finish ' color R/B read loopcntr=0 do while loopcntrtitle replace TITLE with Aarray[loopcntr] endif endif &&(title blanked out) enddo endif &&(ReferCntr>0) return * * * * procedure XRefAdd declare P[9] set alternate off if mnHeadNumb>0 .and. mnHeadNumb<50000 mainrec=recno() Dheadnumb=HEADNUMB+50000 PermuteNo=0 do XRefLdPerm && (Load permuted possibilities) AnotherCross=.T. do while AnotherCross qtitle=space(70) AnotherCross=.F. clear @0,10 say 'CREATING CROSS-REFERENCE TITLES' @1,0 say 'TITLE: '+mnTitle color GR+/N @3,3 say 'Enter alternative titles.' @3,58 say 'F9 = EXIT' @5,3 clear @6,3 get qtitle color GR+/N ? if PermuteNo>0 @4,3 say 'To select and edit any title below, enter the line-number'; color N/BG displayNo=0 do while displayNo-8 && <> F9 qtitle=rtrim(ltrim(qtitle)) lenqtitle= len(qtitle) Responval=val(qtitle) && (choose from loaded permuted titles) if (lenqtitle=1) .and. Responval>0 .and. Responval<=PermuteNo qtitle=P[Responval] + space(70-len(P[Responval])) @4,3 clear @6,3 get qtitle color GR+/N read Lkey=lastkey() qtitle=rtrim(ltrim(qtitle)) lenqtitle=len(qtitle) P[Responval]='' endif endif && <> F9 if lenqtitle>0 .and. .not. Lkey=-8 AnotherCross=.T. if islower(qtitle) qtitle=Upper(left(qtitle,1))+substr(qtitle,2) endif set order to XTITLE respon='C' do DupTitles with qtitle && check for duplicate titles in database if respon='D' loop endif append blank replace HEADNUMB with DHeadNumb,TITLE with qtitle,; PUBLISHER with mnPublisher,SUPPLIER with mnSupplier,; FUND with mnFund endif &&(lenqtitle>0) enddo &&(AnotherCross) goto mainrec endif &&(mnHeadnumb>0 and <50000) set alternate on return * * * procedure XRefLdPerm &&( Load P array with permuted x-reference titles) &&(PermuteNo has the number of permuted possibilities) Part1=rtrim(ltrim(mnTitle))+' ' Part2='' Posit=AT(' ',Part1) do while (PermuteNo<9) .and. (Posit>0) Part2=Part2 + ' ' + left(Part1,Posit-1) Part1=ltrim(right(Part1,len(Part1)-Posit)) Posit=AT(' ',Part1) && Check for next word OKtoLoad=.T. if Posit<=4 if Posit=4 if upper(left(Part1,3))='AND' .or. upper(left(Part1,3))='THE' OKtoLoad=.F. endif else OKtoLoad=.F. endif endif if OKtoLoad PermuteNo=PermuteNo+1 P[PermuteNo]=rtrim(Part1) + ', ' + ltrim(Part2) endif enddo return * * * ********************************************************************* * Deletes header record procedure DelHeader dlt=space(6) @10,0 clear @11,12 to 17,50 double color N/R @12,15 say 'WARNING -- PERMANENT Deletion' color R/N @15,15 say 'Type DELETE in full' @16,15 say 'F9 = EXIT' @15,36 get dlt picture '@!' color GR+/N read if dlt='DELETE' set order to xheadnumb clear ? ? '*****' ? mdy(mdate),' ',time() ? '-- DELETING HEADER --' ? rtrim(title) ? rtrim(publisher) ? rtrim(supplier) ? Fund picture '99' dheadnumb=headnumb replace HEADNUMB with 0,TITLE with ' ',PUBLISHER with ' ',SUPPLIER with ' ' replace FUND with 0 if len(notes)>0 set memowidth to 240 memnote=mline(notes,1) ? rtrim(memnote) replace notes with '' endif set exact on Refheadnumb=dheadnumb+50000 if seek(refheadnumb) ? ' -- DELETING CROSS REFERENCES --' do while refheadnumb=HEADNUMB ? rtrim(TITLE) replace TITLE with ' ',publisher with ' ',supplier with ' ',fund with 0 replace headnumb with 0 seek (refheadnumb) enddo endif Select (Payfile) set order to tag XDATANUMB finished=.F. do while .not. finished seek dheadnumb &&(seek related records in the data file) if found() ? '-- DELETING DATA --' do PrintPayLine replace material with ' ',paid with { / / },cost with 0 replace qty with 0,library with ' ' replace DATANUMB with 0 else finished=.T. endif enddo Select (HeaderFile) SearchMenu=.T. else RecFdLoop=.T. endif &&('DELETE' entered) set exact off clear return * * * *********************************************************************** * Edit header record procedure EditHeader clear qtitle=title qpublisher=publisher qsupplier=supplier qfund=FUND @ 1,0 say 'TITLE' @1,10 get qtitle color GR+/N @ 2,0 say 'PUBLISHER' @2,10 get qpublisher color GR+/N @ 3,0 say 'SUPPLIER' @3,10 get qsupplier color GR+/N @ 4,0 say 'FUND' @4,10 get qfund picture '99' color GR+/N if len(notes)>0 set memowidth to 240 oldmemnote=mline(notes,1) memnote=oldmemnote+space(240-len(oldmemnote)) else oldmemnote='' memnote=space(240) endif @5,0 to 5,79 double @5,30 say '<< NOTES >>' color GR+/N set delimiters off @6,0 get memnote color GR+/N set delimiters on @9,0 to 9,79 panel @ 9,30 say ' F9=EXIT F10=SAVE ' read if lastkey()<>-8 && <> F9 set exact on set console off changedfields=' ' if title<>qtitle changedfields=changedfields+'T' do savetransact replace title with qtitle endif if publisher<>qpublisher changedfields=changedfields+'P' do savetransact replace publisher with qpublisher endif if supplier<>qsupplier changedfields=changedfields+'S' do savetransact replace supplier with qsupplier endif if FUND<>qfund && fund change must be copied to SERDATA file ndxtitleno=HEADNUMB Select (Payfile) set order to XDATANUMB && (in data file) seek ndxtitleno scan rest while DATANUMB=ndxtitleno replace DATAFUND with qfund endscan Select (HeaderFile) changedfields=changedfields+'F' do savetransact replace FUND with qfund endif memnote=rtrim(memnote) if len(oldmemnote)>0 if oldmemnote<>memnote changedfields=changedfields+'N' do savetransact replace notes with memnote endif else &&(no notes field) if len(memnote)>0 changedfields=changedfields+'N' do savetransact replace notes with memnote endif endif set exact off set console on endif && <> F9 return * * * * procedure savetransact if len(changedfields)<3 && first field edited ? ? '*****' ? mdy(mdate),' ',time() ? '-- EDITING HEADER --' ? 'TITLE: ',rtrim(TITLE) endif do case case right(changedfields,1)='T' ? 'became >>',rtrim(qtitle) case right(changedfields,1)='P' ? 'PUBLISHER: ',rtrim(PUBLISHER) ? 'became >>',rtrim(qpublisher) case right(changedfields,1)='S' ? 'SUPPLIER: ',rtrim(SUPPLIER) ? 'became >>',rtrim(qsupplier) case right(changedfields,1)='F' ? 'FUND: ',FUND picture '99' ? 'became >>',qfund picture '99' case right(changedfields,1)='N' ? 'NOTES: ',rtrim(oldmemnote) ? 'became >>',rtrim(memnote) endcase return * * * ************************************************************************** * Outputs a subset of payment or checkin databases (by date) to disk procedure outputdb parameters DataType && choice of outputting payment or check-in data clear set exact on do GetDateRange with BegDate,EndDate,DateError,'COPY DATA',.F. if DateError return endif @10,2 to 12,70 double color N/BG Sortchoice='T' @11,4 say 'Arrange by:(F) Fund, (P) Publisher, (S) Supplier, (T) Title' ; get Sortchoice picture '!' color GR+/N do readMenu with SortChoice,'FPST' do case case Sortchoice='9' return case Sortchoice='P' mfield='Publisher' mindex='xpublisher' case Sortchoice='S' mfield='Supplier' mindex='xsupplier' Case Sortchoice='T' mfield='Title' mindex='xtitle' Case Sortchoice='F' mfield='Fund' mindex='xfund' endcase clear ? ? header1 ? 'Arranged by',upper(mfield),' ',mdy(BegDate),'to',mdy(EndDate) ? do case case DataType='PAYMENT' Select (Payfile) set order to XDATANUMB Select (HeaderFile) set order to &mindex goto top scan for headnumb>0 .and. headnumb<50000 mnumb=headnumb if seek(mnumb,PayFile) &&(material found) Select (Payfile) ToPrintHeader=.T. scan while datanumb=mnumb for paid>=BegDate .and. paid<=EndDate if ToPrintHeader && prints header record only once ? ? upper(rtrim(SERHEAD->Title)) ? ' ',SERHEAD->Publisher, SERHEAD->Supplier, SERHEAD->Fund ToPrintHeader=.F. endif do PrintPayLine endscan Select (HeaderFile) endif &&(material found) endscan ? '*************' Case DataType='CHECK-IN' Endcase set exact off return * * * * ************************************************************************* procedure FindHeader && locates a single header record for user && Barray[] used to hold scan of header recno() x=0 do while x<17 && initialize Barray[] x=x+1 Barray[x]=0 enddo clear Exiting=.F. UTYPEFIELD=upper(Typefield) Srch=' ' && find first occurance if any if CombField do SrchCombFld &&(places multi-field search query into 'Srch' variable) else do SrchSingFld &&(Srch in typefield for srch term) endif && Srch has been loaded with desired search string, and pointer moved if .not. Exiting RptSrchList=.T. do while RptSrchList RptSrchList=.F. do SrchEntry && if exit from rec. sets RptSrchList to .T. then && SrchEntry will be repeated enddo endif return * * * ************************************************************************* procedure SrchEntry if eof() .and. .not. bof() skip-1 endif activate window W2 clear activate window W1 do DisplMenu && (Display PgUp/PgDn menu for header titles) * At this point have found (or failed to find) 1st match in header file * or if multi-field search then at top and Srch loaded with query activate window W2 clear Forward=.T. FirstRec=recno() LastRec=recno() ShowTitLoop=.T. do while ShowTitLoop keypressed=.F. &&(used in showtitles to show if key pressed to terminate) do ShowTitles &&(clears & displays to max of 17 headers in window W2) activate window W1 responLn='0' if .not. keypressed Lkey=0 do while Lkey=0 Lkey=inkey() enddo else Lkey=Lastkey() endif do case case Lkey=57 && ascii value for '9' ResponLn='9' case Lkey>96 .and. Lkey<123 &&(lower case) ResponLn=chr(Lkey-32) Case Lkey>64 .and. Lkey<91 &&(upper case) ResponLn=chr(Lkey) endcase do case case Lkey= -8 &&(f9 key = exit) ShowTitLoop=.F. SearchMenu=.T. deactivate window all clear case Lkey= 24 .or. Lkey= 3 .or. Lkey= 45 &&(down arrow or page down or '+' = page down) if .not. Forward .and. LastRec>0 goto LastRec && previously scanned back, jump over displ recs skip if eof() skip-1 endif endif Forward=.T. ShowTitLoop=.T. case Lkey= 5 .or. Lkey= 18 .or. Lkey= 43 &&(up arrow or page up or '-' = page up) if Forward .and. FirstRec>0 goto FirstRec &&previously scanned forward,jump over displ recs skip-1 if bof() skip endif endif Forward=.F. ShowTitLoop=.T. case Lkey= -1 &&(F2 = create new header) deactivate window all clear do addheadrec ShowTitLoop=.F. SearchMenu=.T. case Lkey= -4 &&(F5 = top) goto top Forward=.T. ShowTitLoop=.T. case Lkey= -5 &&(F6 = bottom) goto bottom Forward=.F. ShowTitLoop=.T. case ResponLn='9' ShowTitLoop=.F. SearchMenu=.T. deactivate window all clear otherwise Rval= asc(ResponLn)-64 if Rval>=1 .and. Rval<=17 if Barray[Rval]>0 &&if recno() is loaded in Barray[] go Barray[Rval] deactivate window all clear do recfound ShowTitLoop=.F. SearchMenu=.T. endif endif &&(ensure Rval is between 1 and 17) endcase enddo &&(ShowTitLoop) set exact off clear CombField=.F. return * * * *********************************************************************** procedure SrchSingFld activate window W1 clear @0,10 say 'SEARCHING MODE' color W/N @1,40 say '<< F9 to EXIT >>' color GR+/N if UTYPEFIELD='FUND' responfund=0 @3,5 say 'What Fund? : ' get responfund picture '@B 99' color GR+/N read if responfund<1 .or. responfund>MaxFund .or. lastkey()=-8 SearchMenu=.T. clear deactivate window W1 Exiting=.T. else &&(fund to search is in range) set exact on seek(responfund) endif else &&(search for title,publisher or supplier) respon=space(20) @3,5 say "What "+typefield+"? : " get respon color GR+/N read srch=upper(rtrim(respon)) if len(srch)<1 .or. lastkey()=-8 SearchMenu=.T. if UTYPEFIELD='TITLE' TitleSearch=.F. &&(to prevent an assumption of title search) &&(as user does not want to search for a title) endif clear deactivate window W1 Exiting=.T. else set exact off seek(srch) endif endif &&(search) return * * * ************************************************************************* procedure SrchCombFld activate window W2 @ 0,0 fill to 16,77 color N/N @ 2,5 say 'This is a ' color BG/N @2,15 say 'FULL-TEXT ' color W+/N @2,25 say 'search. It is likely to be slow.' color BG/N @ 4,5 say 'Data entered is searched for anywhere in the field.' color BG/N activate window W1 clear @0,0 say 'SEARCHING (FULL-TEXT, COMBINING FIELDS)' color BG/N @1,0 say '<< F9 to EXIT without searching>> ; << F10 when search entered>>' color BG/N qtitle=space(50) qpublisher=space(35) qsupplier=space(35) qfundspace=' ' @ 2,0 say 'TITLE' @ 2,10 get qtitle picture '@!' color GR+/N @ 3,0 say 'PUBLISHER' @ 3,10 get qpublisher picture '@!' color GR+/N @ 4,0 say 'SUPPLIER' @ 4,10 get qsupplier picture '@!' color GR+/N @ 5,0 say 'FUND' @ 5,10 get qfundspace picture '99' color GR+/N read activate window W2 @0,0 fill to 16,77 color N/N qtitle=rtrim(ltrim(qtitle)) qpublisher=rtrim(ltrim(qpublisher)) qsupplier=rtrim(ltrim(qsupplier)) qfund=val(qfundspace) if qfund<0 .or. qfund>MaxFund qfund=0 endif Srch=' ' if (len(qtitle) + len(qpublisher) + len(qsupplier) + qfund>0) .and. ; .not. lastkey()=-8 activate window W2 clear Select (HeaderFile) set exact off goto top if len(qtitle)>0 Srch=Srch+' '+'"'+qtitle+'"' + ' $ upper(TITLE)' endif &&( len(qtitle)>0) if Len(qpublisher)>0 if len(srch)>1 srch=srch+' .and. ' endif Srch=Srch+' '+'"'+qpublisher+'"' + ' $ upper(PUBLISHER)' endif if len(qsupplier)>0 if len(srch)>1 srch=srch+' .and. ' endif Srch=Srch+' '+'"'+qsupplier+'"' + ' $ upper(SUPPLIER)' endif if qfund>0 .and. qfund<=MaxFund if len(srch)>1 srch=srch+' .and. ' endif qfundstr=str(qfund,2) Srch=Srch+' '+qfundstr+ ' = FUND' endif else Exiting=.T. &&(no search query entered) endif &&(some gets exist) deactivate window all return * * * *********************************************************************** * procedure DisplMenu &&(Menu for choice of 17 Header Lines - in Window W1) @0,0 fill to 5,79 color N/N @0,0 say 'CODE' color W+/N @0,4 say space(20)+'TITLE'+space(27) color W+/B @0,55 say 'PUBLISHER' color B/W @0,64 say ' SUPPLIER ' color BG+/B @0,76 say 'FUND' color N/W @2,7 say 'ARRANGED BY '+upper(Typefield) color W/N @2,45 say 'Create New Title' color RB/N @3,45 say 'Exit' color RB/N @4,45 say 'Scan Up / Down' color RB/N @5,45 say 'Goto Begin / End' color RB/N @2,63 say 'F2' color GR+/N @3,63 say 'F9' color GR+/N @4,63 say chr(24)+' PgUp / '+chr(25)+' PgDn' color GR+/N @5,63 say 'F5 / F6' color GR+/N @5,7 say 'Choose Below by Letter Code' color GR+/N return * * * ************************************************************************ * Displays up to 17 header titles procedure ShowTitles && displays up to 17 lines of titles in window W2 && RecCntr is subscript for Barray[] && Displays Headers and loads recno() into Aarray[] && LineNo is one less than RecCntr and shows line in window W2 activate window W2 HitFound=.F. If Forward RecCntr=0 &&forward load of Aarray[] Direction=1 else RecCntr=18 &&reverse load of Aarray[] Direction=-1 endif clear typeahead SrchMatches=.F. do while .not. (eof() .or. bof() .or. (RecCntr>=17 .and. Forward); .or. (RecCntr<=1 .and. .not. Forward) .or. keypressed) do case case CombField if &Srch .and. HEADNUMB>0 SrchMatches=.T. endif otherwise if HEADNUMB>0 SrchMatches=.T. endif endcase if SrchMatches SrchMatches=.F. if .not. HitFound &&clears screen & Barray[] when first hit found HitFound=.T. clear x=0 do while x<17 && initialize Barray x=x+1 Barray[x]=0 enddo endif &&(.not. HitFound) RecCntr=RecCntr + Direction Barray[RecCntr]=recno() LineNo=RecCntr-1 && LineNo is 0-16 (RecCntr is 1-17) @ LineNo,0 say chr(64+RecCntr) color GR+/N && (Lines are labeled A .. Q) @ LINENO,2 say TITLE color W+/B @ LINENO,54 say left(PUBLISHER,9) color B/W @ LineNo,63 say left(SUPPLIER,13) color BG+/B @ LineNo,76 say FUND picture '99' color N/W endif &&(Srch matches with record) if inkey() <> 0 keypressed=.T. else skip direction endif enddo &&(while not DisplEnd) if HitFound if Forward FirstRec=Barray[1] LastRec=IIF(RecCntr>0 .and. RecCntr<=17,Barray[RecCntr],FirstRec) else &&(Reverse display) LastRec=Barray[17] FirstRec=IIF(RecCntr>0 .and. RecCntr<=17,Barray[RecCntr],LastRec) endif endif &&(HitFound) return * * * * ************************************************************************** * One Header Record has now been selected procedure Recfound RecFdLoop=.T. do while RecFdLoop Select (HeaderFile) RecFdLoop=.F. set order to xheadnumb set exact on oldrec=recno() if HEADNUMB>50000 .and. HEADNUMB<100000 &&(cross-reference code) clear newheadnumb=HEADNUMB-50000 if .not. seek(newheadnumb) goto oldrec @1,5 say title color GR+/B @2,5 say publisher color GR+/B @4,25 say '** WARNING **' color R/N @5,5 say 'Cross-reference not pointing to any title record' Ch='C' @7,2 say '(D) Delete cross-reference, (C) Convert to main title (D/C)?'; get Ch picture '!' color R/N do readMenu with Ch,'CD' if Ch $'C9' replace HEADNUMB with newheadnumb clear else replace HEADNUMB with 0 SearchMenu=.T. loop endif &&(convert cross-ref. to main title) endif &&(.not. seek(newheadnumb) i.e. no main title found) endif clear set exact off @1,0 say 'TITLE' @1,10 say TITLE @2,0 say 'PUBLISHER' @2,10 say PUBLISHER @3,0 say 'SUPPLIER' @3,10 say SUPPLIER @4,0 say 'FUND' @4,10 say FUND picture '@B' @1,10 fill to 4,79 color W+/GR if len(notes)>0 set memowidth to 240 memnote=mline(notes,1) @5,0 to 5,79 double color N/BG @ 5,30 say '<< NOTES >>' color GR+/N @ 6,0 say memnote color GR+/B @9,0 to 9,79 panel endif ******** set memory variables for main rec. to carry to pay & chk programs mnHeadNumb =HEADNUMB mnTitle =rtrim(ltrim(TITLE)) mnPublisher=rtrim(ltrim(PUBLISHER)) mnSupplier =rtrim(ltrim(SUPPLIER)) mnFund =FUND ************************ Select (Chkfile) set order to XCHKNUMB Select (Payfile) set order to xDATANUMB set exact on Select (HeaderFile) mnHeadNumb=HEADNUMB DataExists=IIF(seek(mnHeadNumb,2),.T.,.F.) ChkExists =IIF(seek(mnHeadNumb,3),.T.,.F.) set exact off @10,13 to 13,70 double color N/BG @10,35 say '>> Payments <<' color N/BG @11,15 say '1 Add new payment' @12,15 say '2 Payment menu' @11,14 fill to 12,69 color W+/N if .not. DataExists @12,38 say '** no payments recorded **' color N+/N endif @13,13 to 16,70 double color N/BG @13,35 say '>> Check-in <<' color N/BG @14,15 say '3 Add check-in data' @15,15 say '4 Check-in menu' @14,14 fill to 15,69 color W+/N if .not. ChkExists @15,38 say '** no check-in data recorded **' color N+/N endif @16,13 to 20,70 double color N/BG @16,35 say '>> Header Information <<' color N/BG @17,15 say '5 Cross reference (Title)' @18,15 say '6 Edit header/notes' @19,15 say '7 Delete header and data' @17,14 fill to 19,69 color W+/N @20,13 to 24,70 double color N/BG @20,35 say '>> Other Lists <<' color N/BG @21,15 say '8 Search Menu '+chr(27)+' Goto Header List' @22,15 say '9 Exit' @21,14 fill to 23,69 color W+/N respon='1' @23,14 get respon picture '9' color GR+/N Goodkey=.F. do while .not. Goodkey read save Lkey=Lastkey() if Lkey=-8 .or. Lkey=19 .or. AT(Respon,'123456789')>0 clear gets Goodkey=.T. if Lkey=-8 respons='9' endif endif enddo Transloop=.T. do while Transloop && (allows for switching between payment & check-in) Transloop=.F. Transfer=.F. do case case lastkey()= 19 &&(Left arrow key press= goto Header List) set order to 'X'+(Typefield) RptSrchList=.T. case respon $ '12' Addingonly=IIF(respon='1',.T.,.F.) do SERPAY && payments program if Transfer &&(Transfer to Check-in) respon='4' Addingonly=.F. Transloop=.T. else if .not. RecFdLoop && if RecFdLoop=.T. then do header again SearchMenu=.T. endif endif case respon $ '34' Addingonly=IIF(respon='3',.T.,.F.) do serchk && check-in program if Transfer &&(Transfer to Payments) Addingonly=.F. respon='2' Transloop=.T. else SearchMenu=.T. endif case respon='5' do XRef clear RecFdLoop=.T. case respon='6' do EditHeader clear RecFdLoop=.T. case respon='7' do DelHeader SearchMenu=.T. case respon='8' SearchMenu=.T. case respon='9' * endcase enddo && (Transloop - decision to transfer) enddo return * * * * ************************************************************************* * serial check-in program procedure SerChk declare DfTitleArr[20],DfClaimArr[20] * dftitleArr and dfclaimArr contain definitions of subtypes and claim times do alterfile with 'TRANSACT.CHK' set alternate off && set transaction record off until needed Select (HeaderFile) trimTitle=upper(rtrim(ltrim(TITLE))) mnHeadStr=str(mnHeadNumb,5) mChkTypeNo=0 mChkData=space(20) store 1 to mChkCopy tempchkdate=mdate prevchkdate=tempchkdate CenterT=floor((80-len(trimTitle))/2) Restart=.T. do while Restart && (Restarts SERCHK after an edit) Restart=.F. clear activate window W1 clear @ 0,CenterT say trimTitle color GR+/N activate window W2 clear set exact on do loadchkdf with mnHeadNumb && loads dftitleArr & dfclaimArr arrays Select (Chkfile) set order to xchknumb if seek(MnHeadNumb) && display data if any exists LastRec=0 seek(mnHeadNumb+1) && to find last instance of related records) skip -18 scan next 19 for mnHeadNumb=CHKNUMB if ChkTypeNo>0 .and. ChkTypeNo<=20 ? dfTitleArr[chkTypeNo] ?? ' ' else ? space(21) endif @ row(),col() say ChkData color GR+/N ?? chkdate,ChkCopy LastRec=recno() endscan DataExists=.T. if Lastrec>0 goto Lastrec endif else DataExists=.F. endif &&data exists set order to xchkord ContAdding=.T. do while ContAdding set exact off activate window W1 clear @ 0,CenterT say trimTitle color GR+/N if .not. Addingonly respon='9' @ 1,0 to 5,79 double color N/BG @ 1,25 say '>> Check-in <<' color N/BG if DataExists @ 2,4 say '1 Scan/Edit/Delete' validresp='123789' else validresp='23789' endif @ 2,30 say '2 Add new entry 3 Define Check-in' @ 3,4 say '7 Return to Header 8 Payments menu 9 Exit' @ 4,3 get respon picture '9' color GR+/N @2,1 fill to 4,78 color W+/N do readMenu with respon,validResp else respon='2' && goes directly to AddChkData procedure in case process below Addingonly=.F. endif do case case respon='1' do EditChk ContAdding=.F. Restart=.T. case respon='2' do AddChkData ContAdding=.T. case respon='3' do DefineTypes ContAdding=.T. case respon='7' RecFdLoop=.T. && repeats Header loop ContAdding=.F. Restart=.F. case respon='8' Transfer=.T. ContAdding=.F. case respon='9' ContAdding=.F. endcase respon='9' enddo && (ContAdding - to loop back to Check-in menu, doesn't clear W2) enddo && (to restart SERCHK - redisplays data in W2) deactivate window all do alterfile with 'TRANSACT.SER' return * * * * ****************************************************************************** * Adding new check-in data procedure AddChkData && initially ask for selection of TypeChoice i.e. Type of Sub-publication && and Copy number clear typeahead TypeChoice=0 CountDef=0 do DispDef && displays definitions if more than 1 do case case lastkey()=-7 .or. CountDef<1 && F8 or no defs. = define sub-types do DefineTypes do DispDef case lastkey()=-8 && F9 to exit TypeChoice=0 endcase if TypeChoice>0 .and. CountDef>0 if len(ltrim(DfTitleArr[TypeChoice]))>0 activate window W2 clear if seek(mnHeadStr+str(TypeChoice,2)) &&type data exists seek(mnHeadStr+str(TypeChoice,2)+'~') && to find last instance skip -18 scan next 19 for mnHeadNumb=CHKNUMB .and. TypeChoice=CHKTYPENO if ChkTypeNo>0 .and. ChkTypeNo<=20 ? dfTitleArr[chkTypeNo] ?? ' ' else ? space(21) endif @ row(),col() say ChkData+' ' color GR+/N ?? chkdate,ChkCopy endscan endif &&data exists activate window W1 clear @ 0,CenterT say trimTitle color GR+/N @ 1,0 say 'COPY NUMBER' if len(ltrim(dfTitleArr[TypeChoice]))<1 @2,0 say 'DATA' else @2,0 say upper(dfTitleArr[TypeChoice]) endif @ 3,0 say 'ACTIVITY DATE' @ 4,0 say 'PUBLISHER' @ 4,22 say serhead->publisher @ 5,0 say 'SUPPLIER' @ 5,22 say serhead->supplier mChkCopy=1 @ 1,21 get mChkCopy picture '@B 99' range 1,99 color GR+/N read @ 1,21 fill to 1,24 color W+/B ChkOrder=str(mnHeadNumb,5)+str(TypeChoice,2)+str(mChkCopy,2) set order to xchkord if seek(chkOrder) && data exists of that sub-type & copy numb. ClaimTime=DfClaimArr[TypeChoice] if ClaimTime<0 ClaimTime=0 endif activate window W2 clear LastRec=0 seek(chkOrder+'~') &&last instance skip -18 FirstHit=.T. scan next 19 for mnHeadNumb=CHKNUMB .and. TypeChoice=CHKTYPENO; .and. mChkCopy=CHKCOPY if FirstHit FirstHit=.F. PrevActDate=CHKDATE else if ClaimTime>0 .and. (CHKDATE > (PrevActDate + (2 * ClaimTime))) ? space(13),'**** NOT received? **** [',PrevActDate+ClaimTime,']' endif PrevActDate=CHKDATE endif if ChkTypeNo>0 .and. ChkTypeNo<=20 ? dfTitleArr[chkTypeNo] ?? ' ' else ? space(21) endif @ row(),col() say ChkData+' ' color GR+/N ?? chkdate,ChkCopy LastRec=recno() endscan if LastRec>0 goto LastRec if ClaimTime>0 .and. (mdate > CHKDATE + (ClaimTime * 1)) ? space(13),'**** NOT received? **** [',PrevActDate+ClaimTime,']' endif endif && lastrec>0 activate window W1 endif &&data exists PredictFound=.F. do predictChk && (attempts to predict next issue, puts in mChkData) @ 2,21 get mChkData color GR+/N @ 1,44 to 3,56 double color RG/N+ @ 2,45 say 'F9 to EXIT' @ 2,45 fill to 2,55 color W+/N read TrimChkData=rtrim(ltrim(mChkData)) LenChkData=len(TrimChkData) if LenChkData>0 .and. .not. lastkey()=-8 @ 1,43 && to blank out F9 Exit message box @ 2,43 @ 3,43 @ 2,21 fill to 2,42 color W+/B @ 3,21 get tempchkdate color GR+/N read @ 3,21 fill to 3,30 color W+/B do ErrChkData prevchkdate=tempchkdate activate window W2 append blank TypeString=IIF(TypeChoice>0 .and. TypeChoice<=20,; dfTitleArr[TypeChoice]+' ',space(21)) replace CHKNUMB with mnHeadNumb,CHKTYPENO with TypeChoice, ; CHKDATA with mChkData,; CHKDATE with tempchkdate,CHKCOPY with mChkCopy set alternate on && write to transaction file set console off ? ' ******' ? mdy(mdate),' ',time() ? TrimTitle ? rtrim(TypeString),' ',rtrim(mChkData),' ',tempchkdate,' ',mChkCopy ? set console on set alternate off DataExists=.T. ? TypeString && write to screen @ row(),col() say CHKDATA+' ' color GR+/N ?? CHKDATE,CHKCOPY else ContAdding=.F. endif else &&(nothing in dfTitleArr[TypeChoice]) ContAdding=.F. endif else &&(TypeChoice = 0) ContAdding=.F. endif return * * * *************************************************************************8* procedure DefineTypes set exact on Select (ChkDfFile) set order to XDFNUMB activate window W3 clear @0,0 say 'DEFINE PUBL. SUB-TYPES CLAIM' color GR+/N cntr=0 do while cntr<20 cntr=cntr+1 @cntr,0 get DfTitleArr[cntr] color W+/N @cntr,25 get DfClaimArr[cntr] picture '999' color W+/N enddo @21,0 say 'Modify Publication Sub-types' color GR+/B @22,0 say 'and Claim Periods (in days) ' color GR+/B read cntr=0 do while cntr<20 cntr=cntr+1 && scan thru definition numbers if dfClaimArr[cntr]<0 && accepts claim period of 0, neg values become 0 dfClaimArr=0 endif if seek(mnHeadNumb) scan rest while DFNUMB=mnHeadNumb for DFTYPENO=cntr &&(any records using that definition) exit &&(exit from scan when first good definition found) endscan endif if DFNUMB<>mnHeadNumb .or. DFTYPENO<>cntr append blank &&(otherwise pointing at record to replace) replace DFNUMB with mnHeadNumb,DFTYPENO with cntr replace DFTITLE with DfTitleArr[cntr],DFCLAIM with DfClaimArr[cntr] replace DFFUND with mnFund else &&(record found to replace) if DFTITLE<>dfTitleArr[cntr] replace DFTITLE with dfTitleArr[cntr] endif if DFCLAIM<>DfClaimArr[cntr] replace DFCLAIM with DfClaimArr[cntr] endif if DFFUND<>mnFund replace DFFUND with mnFund endif endif &&(record found to replace) enddo Select (Chkfile) set exact off deactivate window W3 return * * * *************************************************************************** procedure DispDef && (displays for choice in adding data, definitions 1-20 Lastx=1 x=0 do while x<20 x=x+1 if len(ltrim(dftitleArr[x]))>0 &&(valid definition) CountDef=CountDef+1 Lastx = x && (if CountDef=1 then Lastx is TypeChoice) endif enddo do case case CountDef<1 TypeChoice=0 case CountDef=1 TypeChoice=Lastx &&(don't need to ask for Def No. if only one) case CountDef>1 TChoice=' ' activate window W3 clear @0,5 say 'SELECT PUBL. SUB-TYPE' color GR+/N x=0 do while x<20 x=x+1 @x,1 say chr(x+64) color W+/B @x,5 say dfTitleArr[x] color GR+/B enddo @ 21,10 say ' RE-DEFINE' color GR+/N @ 22,10 say ' EXIT ' color GR+/N @ 22,0 get TChoice picture '!' color W+/B read if lastkey()=-7 && F8 endif TypeChoice=IIF(TChoice>='A' .and. TChoice<='T',asc(TChoice)-64,0) clear deactivate window W3 endcase return * * * ************************************************************************** procedure EditChk set order to xchknumb set exact on if seek(mnHeadNumb) &&data found to scan seek(mnHeadNumb+1) && last instance if mnHeadNumb<>CHKNUMB .and. .not. bof() skip -1 endif endif if mnHeadNumb=CHKNUMB && start at last instance deactivate window all clear @0,0 say left(trimTitle,47) @0,0 fill to 0,46 color GR+/N @ 1,0 to 6,46 double color N/BG @ 2,1 fill to 5,45 color N/N @ 17,0 to 24,46 double color RB/N+ @ 18,1 say 'F9 Abandon changes made above' @ 20,1 say 'F10 Save changes and Exit' @ 22,1 say 'PAGE-UP or Save changes' @ 23,1 say 'PAGE-DOWN and scan more data' @ 18,1 fill to 23,45 color B/W activate window W3 clear @0,0 say 'Number Type name claim' color GR+/N cntr=0 do while cntr<20 cntr=cntr+1 @cntr,0 say cntr picture '99' @cntr,4 say DfTitleArr[cntr] color W+/N @cntr,27 say DfClaimArr[cntr] picture '999' color W+/N enddo @21,0 say 'Changing a type number causes a' color GR+/N @22,0 say 'new serial type & claim period' color GR+/N activate screen ContEditing=.T. Finished=.F. do while ContEditing qchktypeno=CHKTYPENO qchkdata =CHKDATA qchkdate =CHKDATE qchkcopy =CHKCOPY TypeString=upper(rtrim(DfTitleArr[qchktypeno])) if len(TypeString)<1 TypeString='DATA' endif @ 2,1 fill to 5,45 color N/N @ 2,1 say 'COPY NUMBER' color W+/N @ 3,1 say TypeString+space(20-len(TypeString)) color W+/N @ 4,1 say 'ACTIVITY DATE' color W+/N @ 5,1 say 'TYPE NUMBER' color W+/N @ 2,1 fill to 5,20 color W+/N @ 16,0 say 'X alone in '+TypeString+' field to DELETE'; + space(20-len(TypeString)) color R/N @ 2,22 get qchkcopy picture '@B 99' color GR+/N @ 3,22 get qchkdata color GR+/N @ 4,22 get qchkdate color GR+/N @ 5,22 get qchktypeno picture '@B 99' range 1,20 color GR+/N read Lkey=Lastkey() If Lkey <> -8 && F9 = Abandon these edit changes only if upper(rtrim(ltrim(qchkdata)))='X' &&(deletion) CurrRec=recno() skip if eof() .or. mnHeadNumb<>CHKNUMB skip -2 endif NextRec=recno() goto CurrRec do deleteChkData goto Nextrec ContEditing=IIF(mnHeadNumb<>CHKNUMB,ContEditing=.F.,ContEditing=.T.) else &&( not a deletion) if .not. (qchktypeno=CHKTYPENO .and. qchkdata=CHKDATA .and. ; qchkdate=CHKDATE .and. qchkcopy=CHKCOPY) OldEntry=dfTitleArr[qchktypeno]+ qchkdata+dtoc(qchkdate)+; str(qchkcopy,2) do Errchkedit if Lkey <> -8 && F9 = Abandon this edit EditedEntry=dfTitleArr[qchktypeno]+ qchkdata+dtoc(qchkdate)+; str(qchkcopy,2) if OldEntry<>EditedEntry set alternate on && write to transaction file set console off ? '*****' ? mdy(mdate),' ',time() ? '-- EDITING CHECK-IN DATA --' ? TrimTitle ? OldEntry,' >>' ? EditedEntry ? set console on set alternate off endif if qchktypeno<>CHKTYPENO .and. qchktypeno>0 .and. qchktypeno<=20 replace CHKTYPENO with qchktypeno endif if qchkdata<>CHKDATA replace CHKDATA with qchkdata endif if qchkdate<>CHKDATE .or. CHKDATE={ / / } .or.; qchkdate={ / / } replace CHKDATE with qchkdate endif if qchkcopy<>CHKCOPY replace CHKCOPY with qchkcopy endif endif && (Lkey<>-8 i.e. F9 on errchkedit) endif && any change do errchk endif &&( not a deletion) if ContEditing Do Case Case Lkey=-9 && F10 to Terminate deactivate window all clear ContEditing=.F. Case Lkey=3 && Page Down (for earlier data) if .not. bof() skip -1 if mnHeadNumb<>CHKNUMB skip endif endif Case Lkey=18 && Page Up (for later data) if .not. eof() skip if mnHeadNumb<>CHKNUMB skip -1 endif endif Endcase endif &&(if ContEditing) endif && (F9 pressed to abandon changes made) enddo && loop for more edits endif && start at last instance set order to xchkord set exact off clear return * * * *************************************************************************** Procedure DeleteChkData activate Window W1 clear respon='Y' @1,4 to 3,32 double color RB/N+ @2,6 say 'CONFIRM DELETE (Y/N)' @2,5 fill to 2,31 color RB/N @2,28 get respon picture 'Y' color R/N read if respon='Y' clear set alternate on ? '*****' ? mdy(mdate),' ',time() ? '-- DELETING CHECK-IN DATA --' ? TrimTitle TitleType=IIF(CHKTYPENO>0 .and. CHKTYPENO<=20,dfTitleArr[CHKTYPENO],'') ? TitleType ?? CHKDATA,CHKDATE,CHKCOPY ? set alternate off replace CHKTYPENO with 0,CHKDATA with ' ',CHKDATE with { / / } replace CHKCOPY with 0,CHKNUMB with 0 endif && (confirm delete) clear deactivate window W1 activate screen return * * * * **************************************************************************** * error checks original check-in data entry procedure ErrChkData ErrorFnd=.F. if mChkCopy<1 .or. mChkCopy>12 ErrorFnd=.T. @1,21 get mChkCopy picture '99' color R/N endif tdata=rtrim(ltrim(mChkData)) if len(tdata)<3 .and. .not. left(tdata,1)$'123456789' ErrorFnd=.T. @ 2,21 get mChkData color R/N endif if tempchkdate={ / / } .or. tempchkdate>mdate .or.; tempchkdate12 ErrorFnd=.T. @ 2,22 get qchkcopy picture '99' color R/N endif tdata=rtrim(ltrim(qchkdata)) if len(tdata)<3 .and. .not. left(tdata,1)$'123456789' ErrorFnd=.T. @ 3,22 get qchkdata color R/N endif if qchkdate={ / / } .or. qchkdate>mdate .or. qchkdate>CHKDATE+100; .or. qchkdate20 ErrorFnd=.T. @ 5,22 get qchktypeno picture '@B 99' color R/N endif if ErrorFnd @12,4 say 'Possible Error' color R/N read @12,4 clear to 12,17 Lkey=Lastkey() endif return * * * ************************************************************************** * loads DfClaimArr[] and DfTitleArr[] with existing chk definitions procedure loadchkdf parameters mNum && Number of Header Record Select (ChkDfFile) set order to XDFNUMB cntr=0 do while cntr<20 && (initialize dfclaimArr & dftitleArr arrays) cntr=cntr+1 dfClaimArr[cntr]=0 dftitleArr[cntr]=space(20) enddo set exact on if seek(mNum) scan rest while DFNUMB=mNum for DFTYPENO>0 .and. DFTYPENO<=20 if len(ltrim(DfTitleArr[DfTypeno]))<1 DfTitleArr[Dftypeno] = DFTITLE DfClaimArr[Dftypeno] = DFCLAIM endif && if not already loaded, load array endscan endif &&(seek mNum) set exact off return * * * **************************************************************************** procedure predictChk set order to xchkord seek ChkOrder+'~' &&( string val of mnHeadNumb+Type+CopyNo) if .not. bof() .and. .not. (CHKNUMB=mnHeadNumb .and. CHKTYPENO=TypeChoice; .and. CHKCOPY=mChkCopy) skip-1 && (to find last instance of sought type and copy numb) endif if CHKNUMB=mnHeadNumb .and. CHKTYPENO=TypeChoice .and. CHKCOPY=mChkCopy mChkData=CHKDATA PredictFound=.T. else mChkData=space(20) && no prediction PredictFound=.F. endif return * * * * ************************************************************************* * List of all payments (by Suppl., Publ., Title or Fund) procedure ListPayments do DeleteFile with TempPath,'tmpndx.ndx' Costmem=0 do GetDateRange with BegDate,EndDate,DateError,'PAYMENTS',.F. if DateError return endif Select (Payfile) set order to xdatanumb Select (HeaderFile) do MenuBox with 'LIST SERIAL PAYMENTS BY :' DisplChoice='9' @ 7,5 say '1 Title' @ 8,5 say '2 Publisher' @ 9,5 say '3 Supplier' @10,5 say '4 Fund' @15,5 say '9 Exit' @16,4 get DisplChoice picture '9' color GR+/N do readMenu with DisplChoice,'12349' set color to W+/B Finish=.F. clear do case case DisplChoice='1' store space(70) to BegTitle, EndTitle @ 5,10 say 'BEGIN TITLE' color GR+/N @ 6,2 get BegTitle picture '@!' color W+/N @ 8,10 say 'END TITLE ' color GR+/N @ 9,2 get EndTitle picture '@!' color W+/N read index on upper(title) to (TempPath+'TmpNdx') BegTitle=rtrim(ltrim(BegTitle)) EndSrch=rtrim(ltrim(EndTitle)) LenEnd=len(EndSrch) seek (BegTitle) case DisplChoice='2' store space(30) to BegPub, EndPub @ 5,5 say 'BEGIN PUBLISHER' get BegPub picture '@!' color W+/N @ 6,5 say 'END PUBLISHER ' get EndPub picture '@!' color W+/N read index on upper(publisher+title) to (TempPath+'TmpNdx') BegPub=rtrim(ltrim(BegPub)) EndSrch=rtrim(ltrim(EndPub)) LenEnd=Len(EndSrch) seek (BegPub) case DisplChoice='3' store space(30) to BegSupp, EndSupp @ 5,5 say 'BEGIN SUPPLIER' get BegSupp picture '@!' color W+/N @ 6,5 say 'END SUPPLIER ' get EndSupp picture '@!' color W+/N read index on upper(supplier+title) to (TempPath+'TmpNdx') BegSupp=rtrim(ltrim(BegSupp)) EndSrch=rtrim(ltrim(EndSupp)) LenEnd=len(EndSrch) seek (BegSupp) case DisplChoice='4' BegFund=1 EndFund=1 @ 0,10 say 'LIST OF PAYMENTS ARANGED BY FUND' @1,2 to 5,60 double color GR+/N @2,4 say 'FUND Range: >= ' get BegFund picture '99' range 1,MaxFund @2,31 say '<= ' get EndFund picture '99' range 1,MaxFund @2,3 fill to 4,59 color W+/N read if BegFund>EndFund .or. EndFund>MaxFund .or. lastkey()=-8 Finish=.T. else index on str(FUND,2)+TITLE to (TempPath+'TmpNdx') set exact off seek( str(BegFund,2)) set exact on FundRange=IIF(BegFund<>EndFund,'S '+str(BegFund,2)+' -'+str(EndFund,2); ,' '+str(BegFund,2)) ? 'Searching for FUND'+FundRange endif case DisplChoice='9' Finish=.T. endcase if .not. Finish scan rest for HeadNumb>0 .and. HeadNumb<50000 if DisplChoice<'4' do case case DisplChoice='1' EndTest=upper(left(TITLE,LenEnd)) case DisplChoice='2' EndTest=upper(left(PUBLISHER,LenEnd)) case DisplChoice='3' EndTest=upper(left(SUPPLIER,LenEnd)) endcase if EndTest>EndSrch Exit endif else && DisplCHoice='4' i.e. FUND Srch if FUND>EndFund Exit endif endif mnNumb=HEADNUMB Firsthit=.T. if seek(mnNumb,PayFile) && if any data for the header Select (Payfile) scan rest while DATANUMB=mnNumb for PAID>=begDate .and. PAID<=EndDate if FirstHit FirstHit=.F. ? SERHEAD->Title ? SERHEAD->PUBLISHER,SERHEAD->SUPPLIER endif do PrintPayLine Costmem=Costmem+(qty*cost) endscan Select (HeaderFile) endif endscan ? ? 'Total Cost $',Costmem Select (HeaderFile) set index to do deletefile with TempPath,'tmpndx.ndx' set order to xheadnumb endif && if not Finish set exact off return * * * * ********************************************************************** * Physically Sorts Database procedure SortDbfs set safety off @1,0 clear ********************************************** Header Records Select (HeaderFile) do deletefile with TempPath,'SerMnSrt.dbf' do deletefile with TempPath,'SerMnSrt.dbt' @1,0 say 'SORTING HEADER RECORDS BY TITLE' sort to (TempPath+'SerMnSrt') on TITLE /C for HEADNUMB>0 if file(TempPath+'sermnsrt.dbf') Select (HeaderFile) use Select (ScratchFile) use TempPath+'sermnsrt' copy to (DataPath+'serhead') use if file(DataPath+'serhead.dbf') erase (TempPath+'sermnsrt.dbf') if file(DataPath+'serhead.dbt') erase (TempPath+'sermnsrt.dbt') endif endif do deleteFile with DataPath,'serHead.mdx' Select (HeaderFile) use DataPath+'serhead' @2,0 say 'INDEXING HEADER RECORDS' index on UPPER(LEFT(TITLE,20)) TAG XTITLE index on UPPER(LEFT(SUPPLIER,20)) TAG XSUPPLIER index on UPPER(LEFT(PUBLISHER,20)) TAG XPUBLISHER index on FUND TAG XFUND index on HEADNUMB TAG XHEADNUMB set order to XHEADNUMB else @2,0 say 'SORT FAILED' color R/N endif &&(sort file ok) ********************************************** Payment Data Select (Payfile) do deleteFile with TempPath,'SerPySrt.dbf' @3,0 say 'SORTING PAYMENT RECORDS BY DATE' sort to (TempPath+'SerPySrt') on PAID for DATANUMB>0 if file(TempPath+'SerPySrt.dbf') use Select (ScratchFile) use TempPath+'serpysrt' copy to (DataPath+'serData.dbf') use if file(DataPath+'serData.dbf') erase (TempPath+'serPysrt.dbf') erase (DataPath+'serData.mdx') use endif if file(DataPath+'serData.mdx') erase (TempPath+'serPysrt.mdx') endif Select (Payfile) use DataPath+'serdata' @4,0 say 'INDEXING PAYMENT RECORDS' index on UPPER(LEFT(MATERIAL,20)) TAG XMATERIAL index on UPPER(LIBRARY)+DTOS(PAID) TAG XLIBRARY index on QTY TAG XQTY index on PAID TAG XPAID index on COST TAG XCOST index on DATANUMB TAG XDATANUMB set order to XDATANUMB endif &&(sort file ok) ********************************************** Supplier List select 5 do DeleteFile with DataPath,'SUPPBAK.DBF' SORT to (DataPath+'SUPPBAK') on NAME /C for len(ltrim(NAME))>0 if file(DataPath+'SUPPBAK.DBF') use do DeleteFile with DataPath,'SUPPLIST.MDX' do DeleteFile with DataPath,'SUPPLIST.BAK' rename (DataPath+'SUPPLIST.DBF') to (DataPath+'SUPPLIST.BAK') rename (DataPath+'SUPPBAK.DBF') to (DataPath+'SUPPLIST.DBF') use DataPath+'SUPPLIST' index on upper(OTHERNAME) TAG XSUPPOTHER index on upper(NAME) TAG XSUPPNAME else @7,0 say 'SUPPLIER NAME REINDEXING FAILED' clear typeahead x=inkey(5) endif select 1 set order to XTITLE set safety on return * * * ********************************************************************** * procedure copyNotes && copies headnumb and notes field out of serhead into && SerMemo.dbf, SerMemo.dbf is created by this procedure, && structure of SerMemo.dbf is HD N 5, NT C 240 && a safety feature, makes available a manipulabe copy of.dbt set safety off Select (HeaderFile) copy to (DataPath+'exthead') structure extended Select (ScratchFile) use DataPath+'exthead' zap append blank replace FIELD_NAME with 'HD' replace FIELD_TYPE with 'N' replace FIELD_LEN with 5 replace FIELD_DEC with 0 replace FIELD_IDX with 'N' append blank replace FIELD_NAME with 'NT' replace FIELD_TYPE with 'C' replace FIELD_LEN with 240 replace FIELD_DEC with 0 replace FIELD_IDX with 'N' use Select (ScratchFile) create (DataPath+'SerMemo') from (DataPath+'exthead') erase (DataPath+'exthead.dbf') Select (HeaderFile) set order to scan for headnumb>0 if memlines(NOTES)>0 Mnt=mline(NOTES,1) Mhd=HeadNUMB Select (ScratchFile) append blank replace HD with MHd replace NT with Mnt Select (HeaderFile) endif endscan Select (ScratchFile) use Select (HeaderFile) set order to xheadnumb set safety on return * * * * ************************************************************************* * Total Expended for each Library & Fund procedure FundExpend do InitExpArr ExpArrtot=0 declare DispBudgYr[9] BudgYrRec=0 do GetDateRange with BegDate,EndDate,DateError,'EXPENDITURE',.F. if DateError return endif Select (BudgetFile) goto top x=0 scan while x<9 x=x+1 DispBudgYr[x]=ltrim(BUDGETYEAR) @x+1,10 say x @x+1,30 say DispBudgYr[x] if year(BegDate)=val(left(DispBudgYr[x],4)) BudgYrRec=x endif endscan if BudgYrRec<1 .or. BudgYrRec>reccount() BudgYrRec=1 endif @0,10 say 'What is the Closest Financial Year? ' get BudgYrRec picture '9'; Range 1,x read Compchoice='N' @24,0 say 'Compare with '+BUDGETYEAR+' (B)udget, other (D)ate range,'+; 'or (N)one (B/D/N) ? ' get Compchoice picture '!' color GR+/N do readMenu with CompChoice,'BDN' do case case CompChoice='D' YrSpread=ceiling((EndDate - BegDate)/365) OthEndStr=left(dtoc(EndDate),6) + str(year(EndDate)-YrSpread,4) OthBegStr=left(dtoc(BegDate),6) + str(year(BegDate)-YrSpread,4) OtherEndDate=ctod(OthEndStr) OtherBegDate=ctod(OthBegStr) do GetDateRange with OtherBegDate,OtherEndDate,DateError,; 'COMPARISON DATES',.T. StatSize=54 && No of recs to be made in STATFILE case CompCHoice='B' StatSize=54 otherwise StatSize=27 endcase Select (Payfile) clear ? ? header1 @ 10,10 say 'Creating Expenditure Database' do createStatDb with StatSize do LoadStatDb with BegDate,EndDate,1,27 && loads payments into STATFILE (A-Z records accross and && 1-MaxFund fields down + 1 extra rec & field for totals) do case case CompChoice='D' && comparing Dates do InitExpArr ExpArrtot=0 do LoadStatDb with OtherBegDate,OtherEndDate,28,54 case CompChoice='B' do LoadBudget endcase do dispfund && uses STATFILE.DBF to print out fund totals use in (StatFile) && closes STATFILE Select (Payfile) set order to XDATANUMB &&(in data file) set exact off return * * * * procedure dispfund Select (BudgetFile) goto BudgYrRec store 0 to ExpArrtot dayspercent=((EndDate-BegDate)/365)*100 datehead1='Expenditure for '+mdy(BegDate)+' to '+mdy(EndDate)+; ' ['+ str(round(dayspercent,2),6)+'% of a year]' Select (StatFile) StatRec=0 do while StatRec<27 && A - Z LIBRARIES + 1 for totals StatRec=StatRec+1 goto StatRec && StatRec 1 = A Library; StatRec 26 = Z library FieldName=Field(MaxFund+1) RecTot=&FieldName if CompChoice $ 'BD' &&either Budget or Date comparison goto StatRec +27 FieldName=Field(MaxFund+1) RecTot=RecTot + &FieldName && test to see if any content in either goto StatRec endif if RecTot>0 && there is a total > 0 ? datehead1 if StatRec<27 ? 'LIBRARY ',chr(StatRec+64) && A - Z else ? 'LIBRARY TOTALS' && on rec 27 containing totals endif if CompChoice='D' ?? space(30),'OTHER DATE' else if CompChoice='B' ?? space(30),'BUDGET' endif endif xx=0 do while xx&FieldName else && a total if =MaxFund+1 ? ' TOTAL',space(15) endif FieldName=field(xx) && field in STATFILE having xx fund No. MainVal=&FieldName ?? ' ',MainVal picture '@$ 9,999,999.99' if CompChoice $ 'BD' goto StatRec+27 FieldName=field(xx) && field in STATFILE having xx fund No. CompVal=&FieldName ?? ' ',CompVal picture '@$ 9,999,999.99' if CompVal<>0 ?? round((MainVal/CompVal)*100,2) picture '99999.99' endif goto StatRec endif enddo do waitmsg endif && only do if there is any total for the LIBRARY enddo Select (HeaderFile) set exact off set century off return * * * * ************************************************************************ * Loads $ Expended amounts into STATFILE.DBF * Records 1-27 contain LIBRARY accounts A -Z * for a particular date period * Any compare dates are in Records 28 -54 procedure LoadStatDb Parameters BDate,EDate,FirstRec,LastRec select (PayFile) set order to XLIBRARY BegStr=dtos(BDate) CharAscii=64 do while CharAscii<90 && searches for LIBRARY A thru Z CharAscii=CharAscii+1 LibChar=chr(CharAscii) seek(LibChar+BegStr) && seeks each LIBRARY + begin paid date Anyfound=.F. scan rest while upper(LIBRARY)=LibChar .and. PAID<=EDate; FOR datafund>=1 .and. datafund<=MaxFund .and. ; datanumb>0 .and. datanumb<50000 AnyFound=.T. ExpArr[DataFund]=ExpArr[DataFund]+(Cost*qty) endscan if AnyFound && put statistics for that LIBRARY in related STATFILE rec. Select (StatFile) goto (FirstRec -1) + (CharAscii - 64) && (ascii 65 = A = record 1) y=0 do while y0 && continue as long as field exists FieldName=Field(FldNumb) FieldContents=&FieldName if Left(FieldName,3)='LIB' .and. Type("FieldContents")='N' Lib=substr(FieldName,4,1) FundNoStr=substr(FieldName,5) if Lib>='A' .and. Lib<='Z' .and. len(FundNoStr)<3 .and. .not. ; isalpha(right(FundNoStr,1)) FundNo=val(FundNoStr) if FundNo>0 .and. FundNo<=MaxFund select (StatFile) goto asc(Lib) - 37 && LIB A = asc(65) -37 goes to rec 28 DestField=Field(FundNo) replace &DestField with FieldContents select (BudgetFile) endif endif endif FldNumb=FldNumb+1 enddo select (statFile) LastFieldN=Field(MaxFund+1) tot=0 Recx=27 do while Recx<53 && i.e. records 28 - 53 (A-Z) Recx=Recx+1 goto Recx Fieldy=0 do while Fieldy'' x=0 NCnt=0 do while x0 @ 0,7 say PAID color GR+/N tmat=rtrim(ltrim(material)) ErrorCond=.F. do case case len(tmat)<3 .and. .not. (left(tmat,1)$'123456789') ErrorCond=.T. ? 'Error: Material line lacks content?' case QTY<1 ErrorCond=.T. ? 'Error: No quantity' case QTY>20 ErrorCond=.T. ? 'Error: High quantity?' case upper(LIBRARY) <'A' .or. upper(LIBRARY)>'Z' ErrorCond=.T. ? 'Error: LIBRARY field not A - Z' case DATAFUND<1 .or. DATAFUND>MaxFund ErrorCond=.T. ? 'Error: Fund number out of range' case DATANUMB>=50000 .and. DATANUMB<100000 ErrorCond=.T. newdatanumb=datanumb-50000 ? 'Error: Unattached data' ? ' Data has now been attached to TITLE record "~~Data Error" ' set exact on if seek(newdatanumb,HeaderFile) ? ' Data line was connected only to a cross refence title' ? ' X Ref = ' ?? upper(SERHEAD->TITLE) replace DATANUMB with -1 endif ErrorCond=.T. case datanumb>LastHeadNumb ErrorCond=.T. ? 'Error: ' endcase if ErrorCond set exact on ErrorCntr=ErrorCntr+1 mnumb=DATANUMB if seek(mnumb,HeaderFile) .and. mnumb>0 ? upper(SERHEAD->Title) ? ' ',SERHEAD->Publisher,' ',SERHEAD->Supplier do PrintPayLine else ? 'SEARCH FOR THIS DATA AT THE END OF THE TITLE LIST' do PrintPayLine if .not. seek(49999,1) && cannot find error record in header file Select (HeaderFile) append blank replace HEADNUMB with 49999 replace TITLE with '~~Data Error',PUBLISHER with '~~Data Error' replace SUPPLIER with '~~Data Error',FUND with 0 Select (Payfile) endif replace DATANUMB with 49999 endif &&(seek header info) endif &&(ErrorCond) endscan do case case ErrorCntr<1 ? 'No errors found.' case ErrorCntr=1 ? 'One possible error found.' otherwise ? ErrorCntr,'possible errors found.' Endcase ? '**********************' if ErrorCntr>1 @ 0,0 say 'Error listing in '+DataPath+'SER.OUT' endif return * * * * ************************************************************************** procedure ExpendHeader ? ? header1 set century on ? 'Expenditure: Arranged by',mfield if CompareCost='Y' ? ' First column = ',mdy(BegDate),'to',mdy(EndDate) ? ' Second column = ',mdy(prevBegdate),'to',mdy(prevEndDate) ? ? 'Percentage increase or decrease of the First Column' ? 'is compared against the Second Column.' else ? space(10),mdy(BegDate),'to',mdy(EndDate) endif if lowcost<>-99999.00 .or. uppcost<>999999.00 ? 'Displays only when totals are between ' ?? lowcost picture '@$' ?? ' and ' ?? uppcost picture '@$' endif if .not. PrintZero .and. .not. lowcost > 0 ? 'Will not display for Zero $ totals' endif set century off return * * * ************************************************************************** procedure PrintExpend MaterialFnd=.F. && resets for next search TotalA=0 TotalB=0 x=0 do while x<26 x=x+1 TotalA=TotalA+Aarray[x] TotalB=TotalB+Barray[x] enddo TotalA=TotalA+NoLibA TotalB=TotalB+NoLibB if (TotalA>=lowcost .and. TotalA<=uppcost) .or. ; (TotalB>=lowcost .and. TotalB<=uppcost) if .not.(TotalA=0 .and. TotalB=0 .and. .not. PrintZero) NumbOfLibs=0 ? ? PrevSrchField && print header title that data relates to x=0 do while x<26 x=x+1 if Aarray[x]>0 .or. (CompareCost='Y' .and. Barray[x]>0) ? ' LIBRARY',chr(x+64) ?? ' ',Aarray[x] picture '@$ 9,999,999.99' if CompareCost='Y' ?? ' ',Barray[x] picture '@$ 9,999,999.99' ?? ' ' if Barray[x]<>0 ?? round((Aarray[x]/Barray[x])*100,2) picture '99999.99' endif endif NumbofLibs=NumbofLibs+1 store 0 to Aarray[x],Barray[x] endif enddo if NoLibA>0 .or. (CompareCost='Y' .and. NoLibB>0) ? ' UNKNOWN LIB. ' ?? NoLibA picture '@$ 9,999,999.99' if CompareCost='Y' ?? ' ',NoLibB picture '@$ 9,999,999.99' ?? ' ' if NoLibB<>0 ?? round((NoLibA/NoLibB)*100,2) picture '99999.99' endif endif NumbofLib=NumbofLib+1 endif if NumbofLibs>1 ? ' TOTAL ' ?? TotalA picture '@$ 9,999,999.99' if CompareCost='Y' ?? ' ',TotalB picture '@$ 9,999,999.99' ?? ' ' if TotalB<>0 ?? round((TotalA/TotalB)*100,2) picture '99999.99' endif endif endif store 0 to NoLibA,NoLibB endif && Print Zero activity endif && cost range OK return * * * ************************************************************************ * Total Expended on each Supplier, Publisher, or Title procedure TotExpended set century off do getDateRange with BegDate,EndDate,DateError,'EXPENDITURE',.F. if DateError return endif x=0 do while X<26 x=x+1 store 0 to Aarray[x],Barray[x] enddo store 0 to NoLibA,NoLibB PrintZero=.F. BegSrch=space(30) EndSrch=chr(255)+space(29) set exact on SortChoice='S' @ 6,2 to 8,70 double color N/BG @ 7,4 say 'Payments by: (P)ublisher (S)upplier or (T)itle (P/S/T)? ' ; get Sortchoice picture '!'; valid Sortchoice$'PST' error 'Enter P, S or T ' @ 7,3 fill to 7,69 color GR+/N @ 17,2 to 19,70 double color N/BG CompareCost='N' @ 18,4 say 'Compare Costs with Some Other Range of Dates (Y/N)? ' ; get CompareCost picture 'Y' @ 18,3 fill to 18,69 color GR+/N read clear prevBegDate=BegDate prevEndDate=EndDate if compareCost='Y' YrSpread=ceiling((EndDate - BegDate)/365) currEndStr=dtoc(EndDate) currBegStr=dtoc(BegDate) prevEndStr=left(currEndStr,6)+str(year(EndDate)-YrSpread,4) prevBegStr=left(currBegStr,6)+str(year(BegDate)-YrSpread,4) prevEndDate=ctod(prevEndStr) prevBegDate=ctod(prevBegStr) @ 1,28 say BegDate @ 1,48 say EndDate @ 2,2 to 4,70 double color N/BG @ 3,4 say 'OTHER DATE Range: >= 'get prevBegdate @ 3,38 say 'AND <= ' get prevEndDate @ 3,3 fill to 3,69 color GR+/N endif do case case Sortchoice='P' mfield='Publisher' mindex='xpublisher' case Sortchoice='S' mfield='Supplier' mindex='xsupplier' Case Sortchoice='T' mfield='Title' mindex='xtitle' endcase @10,0 to 14,78 double color N/BG @11,1 fill to 13,77 color N/N @11,4 say 'Begin and End of '+mfield+' Search' color W+/N @12,4 say ' (leave as is, to search entire database)' color W+/N @13,1 say 'BEGIN' get BegSrch picture '@!' color GR+/N @13,40 say 'END' get EndSrch picture '@!' color GR+/N lowcost=-99999.00 uppcost=999999.00 @17,2 to 21,70 double color N/BG @18,3 fill to 20,69 color N/N @18,4 say 'Change these values if you wish to restrict the output'; color W+/N @19,4 say 'to titles with total $ values between (and including)'; color W+/N @20,10 say '>= ' get lowcost picture '999999.99'; color GR+/N @20,27 say 'AND <= ' get uppcost picture '999999.99'; color GR+/N read if lowcost<=0 clear ZeroAnswer='N' @10,10 say 'Display Records with total $ activity of zero?' ; get zeroanswer picture 'Y' color GR+/N read PrintZero=IIF(ZeroAnswer='N',.F.,.T.) endif BegSrch=rtrim(ltrim(BegSrch)) EndSrch=rtrim(ltrim(EndSrch)) if (uppcostEndSrch ; .or. ((prevBegDate={ / / } .or. prevEndDate0 .and. headnumb<50000 ; while left(PrevSrchField,lenSrch) <= EndSrch if upper(&mfield)<>PrevSrchField && transition causes printing of data if MaterialFnd do printExpend && and reset of counters endif PrevSrchField=upper(&mfield) endif mnumb=headnumb if seek(mnumb,PayFile) &&(material found) Select (Payfile) scan rest while datanumb=mnumb && original dates if paid>=BegDate .and. paid<=EndDate do case case upper(Library)>='A' .and. upper(Library)<='Z' AscLib=ASC(upper(LIBRARY))-64 && A = 1 .. Z = 26 Aarray[AscLib]=Aarray[AscLib]+(cost*qty) MaterialFnd=.T. otherwise NoLibA=NoLibA+(cost*qty) MaterialFnd=.T. endcase endif if CompareCost='Y' if paid>=prevBegdate .and. paid<=prevEndDate && comparison dates do case case upper(Library)>='A' .and. upper(Library)<='Z' AscLib=ASC(upper(LIBRARY))-64 && A = 1 .. Z = 26 Barray[AscLib]=Barray[AscLib]+(cost*qty) MaterialFnd=.T. otherwise NoLibB=NoLibB+(cost*qty) MaterialFnd=.T. endcase endif endif endscan Select (HeaderFile) endif endscan if left(PrevSrchField,lenSrch)<=EndSrch do PrintExpend && eof condition, print last record endif && <=EndSrch set exact off do waitmsg return * * * * * ***************************************************************************** * Serial Payments Recording procedure SerPay Select (HeaderFile) clear trimTitle=upper(rtrim(ltrim(mnTitle))) store 1 to dqty,prevqty store 0 to dcost,prevcost store 'M' to dlibrary,prevlibrary dmaterial=space(45) prevpaiddate=temppaiddate CenterT=floor((80-len(trimTitle))/2) Restart=.T. do while Restart Restart=.F. Select (Payfile) set order to XDATANUMB &&(in data file) activate window W1 clear @ 0,CenterT say trimTitle color GR+/N activate window W2 clear set exact on if seek(MnHeadNumb) && display data if any exists LastRec=0 seek(mnHeadNumb+1) && to find last instance of related records) skip -18 scan next 19 for mnHeadNumb=DATANUMB set alternate off do PrintPayLine set alternate on LastRec=recno() endscan DataExists=.T. if LastRec>0 goto LastRec endif store COST to dcost,prevcost store QTY to dqty,prevqty store LIBRARY to dlibrary,prevlibrary store MATERIAL to dmaterial else DataExists=.F. endif &&data exists ContAdding=.T. do while ContAdding set exact off activate window W1 @ 1,0 clear to 5,79 if .not. Addingonly respon='9' @ 1,0 to 5,79 double color N/BG @1,25 say '>> Payments <<' color N/BG if DataExists @ 2,4 say '1 Scan/Edit/Delete' validresp='12789' else validresp='2789' endif @ 2,30 say '2 Add new entry' @ 3,4 say '7 Return to Header 8 Check-in records 9 Exit' @ 4,3 get respon picture '9' color GR+/N @ 2,1 fill to 4,78 color W+/N do readMenu with respon,validResp @1,0 clear to 5,79 else respon='2' Addingonly=.F. endif do case case Lastkey()= -8 contAdding=.F. case respon='1' do EditPay ContAdding=.F. Restart=.T. case respon='2' do AddPayData case respon='7' RecFdLoop=.T. && repeats Header loop ContAdding=.F. Restart=.F. case respon='8' Transfer=.T. ContAdding=.F. case respon='9' ContAdding=.F. endcase respon='9' enddo && (to loop to continue adding) enddo && (to Restart SERPAY) deactivate window all return * * * ************************************************************************** procedure AddPayData PredictFound=.F. do PredictPay &&(tries to predict next entry, returns in dmaterial) activate window W1 @ 1,0 say 'MATERIAL' @1,17 get dmaterial color GR+/N @3,1 to 5,78 double @4,2 say 'Enter New Data' @4,30 say '<< F9 to EXIT >>' read trimdmat=rtrim(ltrim(dmaterial)) lendmat=len(trimdmat) if lendmat>0 .and. .not. lastkey()=-8 @ 1,0 clear to 5,79 CenterM=floor((80-lendmat)/2) @ 1,CenterM say upper(trimdmat) @ 2,0 say 'DATE PAID' @2,17 get temppaiddate color GR+/N @ 3,0 say 'QTY' @3,17 get dqty picture '99' color GR+/N @3,47 say 'PUBLISHER '+serhead->publisher @ 4,0 say 'COST(per copy)' @4,17 get dcost picture '99999.99' color GR+/N @4,47 say 'SUPPLIER '+serhead->supplier @ 5,0 say 'LIBRARY(A-Z)' @5,17 get dlibrary picture '!' color GR+/N @ 5,47 say 'FUND' @ 5,55 say SERHEAD->FUND picture '@B' read do ErrPayData prevqty=dqty prevpaiddate=temppaiddate prevcost=dcost prevlibrary=dlibrary activate window W2 append blank replace DATANUMB with mnHeadNumb,material with dmaterial,qty with dqty,; paid with temppaiddate,cost with dcost,library with upper(dlibrary),; datafund with SERHEAD->FUND DataExists=.T. set console off ? ? '*****' ? mdy(mdate),' ',time() ? '-- ADDING DATA --' ? rtrim(mnTitle) set console on do PrintPayLine else ContAdding=.F. endif return * * * ************************************************************************ procedure EditPay set order to xdatanumb set exact on if seek(mnHeadNumb) &&data found to scan seek(mnHeadNumb+1) && last instance if mnHeadNumb<>DATANUMB .and. .not. bof() skip -1 endif endif if mnHeadNumb=DATANUMB && start at last instance deactivate window all clear @0,0 say trimTitle @0,0 fill to 0,79 color GR+/N @ 1,0 to 7,60 double color N/BG @ 2,1 fill to 6,59 color N/N @ 17,0 to 24,46 double color RB/N+ @ 18,1 say 'F9 Abandon changes made above' @ 20,1 say 'F10 Save changes and Exit' @ 22,1 say 'PAGE-UP or Save changes' @ 23,1 say 'PAGE-DOWN and scan more data' @ 18,1 fill to 23,45 color B/W ContEditing=.T. do while ContEditing qmaterial =MATERIAL qqty =QTY qpaid =PAID qcost =COST qlibrary =LIBRARY @ 2,1 fill to 6,59 color N/N @ 2,1 say 'MATERIAL' color W+/N @ 3,1 say 'DATE' color W+/N @ 4,1 say 'COST' color W+/N @ 5,1 say 'QTY' color W+/N @ 6,1 say 'LIBRARY' color W+/N @ 2,1 fill to 5,10 color W+/N @ 16,0 say 'X alone in MATERIAL field to DELETE' color R/N @ 2,12 get qmaterial color GR+/N @ 3,12 get qpaid color GR+/N @ 4,12 get qcost picture '99999.99' color GR+/N @ 5,12 get qqty picture '99' color GR+/N @ 6,12 get qlibrary picture '!' color GR+/N read Lkey=Lastkey() If Lkey <> -8 && F9 = Abandon these edit changes only if upper(rtrim(ltrim(qmaterial)))='X' CurrRec=recno() skip if eof() .or. mnHeadNumb<>DATANUMB skip -2 endif NextRec=recno() goto CurrRec do DelPayData goto Nextrec if mnHeadNumb<>DATANUMB ContEditing=.F. else ContEditing=.T. endif else &&( not a deletion) if .not. (qmaterial=material .and. qpaid=PAID .and. qqty=QTY .and. ; qcost=COST .and. qlibrary=LIBRARY) do ErrPayEdit if Lkey <> -8 && F9 = Abandon this edit changedfields=' ' set console off if qmaterial<>material changedfields=changedfields+'M' do editTrans replace MATERIAL with qmaterial endif if qpaid<>paid .or. paid={ / / } .or. qpaid={ / / } changedfields=changedfields+'P' do editTrans replace PAID with qpaid endif if qqty<>qty changedfields=changedfields+'Q' do editTrans replace QTY with qqty endif if qcost<>cost changedfields=changedfields+'C' do editTrans replace COST with qcost endif if qlibrary<>library changedfields=changedfields+'L' do editTrans replace LIBRARY with qlibrary endif set console on endif && (Lkey<>-8 i.e. F9 on ErrPayEdit) endif && if changes made do errchk and replace endif &&( not a deletion) if ContEditing Do Case Case Lkey=-9 && F10 to Terminate ContEditing=.F. Case Lkey=3 && Page Down (for earlier data) if .not. bof() skip -1 if mnHeadNumb<>DATANUMB skip endif endif Case Lkey=18 && Page Up (for later data) if .not. eof() skip if mnHeadNumb<>DATANUMB skip -1 endif endif Endcase endif endif && (F9 pressed to abandon changes made) enddo && loop for more edits endif && start at last instance set exact off clear return * * * * procedure editTrans if len(changedfields)<3 && first field edited ? ? '*****' ? mdy(mdate),' ',time() ? '-- EDITING DATA --' ? rtrim(mnTITLE) endif do case case right(changedfields,1)='M' ? rtrim(MATERIAL) ? 'became >>',rtrim(qmaterial) case right(changedfields,1)='P' ? PAID ? 'became >>',qpaid case right(changedfields,1)='Q' ? QTY picture '99' ? 'became >>',qqty picture '99' case right(changedfields,1)='C' ? COST picture '99,999.99' ? 'became >>',qcost picture '99,999.99' case right(changedfields,1)='L' ? LIBRARY ? 'became >>',library endcase return * * * ************************************************************************* Procedure DelPayData activate Window W1 clear respon='Y' @1,4 to 3,32 double color RB/N+ @2,6 say 'CONFIRM DELETE (Y/N)' @2,5 fill to 2,31 color RB/N @2,28 get respon picture 'Y' color R/N read if respon='Y' clear ? ? '*****' ? mdy(mdate),' ',time() ? '-- DELETING DATA --' ? rtrim(SERHEAD->title) do PrintPayLine replace material with ' ',paid with { / / },cost with 0 replace qty with 0,library with ' ' replace DATANUMB with 0 endif &&(confirm delete) clear deactivate window W1 activate screen return * * * * ***************************************************************************** * Error checks new payment data procedure ErrPaydata ErrorFnd=.F. @1,0 clear to 5,77 @ 1,0 say 'MATERIAL' @1,10 say dmaterial @ 2,0 say 'DATE PAID' @2,10 say temppaiddate @ 3,0 say 'QTY' @3,10 say dqty picture '@B 99' @ 4,0 say 'COST' @4,10 say dcost picture '@B 99999.99' @ 5,0 say 'LIBRARY' @5,10 say dlibrary picture '!' tmat=rtrim(ltrim(dmaterial)) if len(tmat)<3 .and. .not. left(tmat,1)$'123456789' ErrorFnd=.T. @ 1,10 get dmaterial color R/N endif if temppaiddate={ / / } .or. ; temppaiddate>mdate .or. temppaiddate1) .or. (dqty<>prevqty) ErrorFnd=.T. @3,10 get dqty picture '99' color R/N endif absdiff=abs(dcost-prevcost) absdiffper=IIF(absdiff>1 .and. prevcost<>0,(absdiff/abs(prevcost))*100,0) if dcost<4 .or. absdiffperc>20 ErrorFnd=.T. @4,10 get dcost picture '99999.99' color R/N endif if upper(dlibrary)<'A' .or. upper(dlibrary)>'Z' .or.; (dlibrary<>prevlibrary) ErrorFnd=.T. @5,10 get dlibrary picture '!' color R/N endif if ErrorFnd do MessageWindow with 'Possible Error' read endif return * * * * ************************************************************************ * Error Checks the Edit of a Payment Record procedure ErrPayEdit ErrorFnd=.F. tmat=rtrim(ltrim(qmaterial)) if len(tmat)<3 .and. .not. left(tmat,1)$'123456789' ErrorFnd=.T. @ 2,12 get qmaterial color R/N endif if qpaid={ / / } .or. qpaid>mdate ErrorFnd=.T. @3,12 get qpaid color R/N endif if qcost<4 .or. qcost>200 ErrorFnd=.T. @4,12 get qcost picture '99999.99' color R/N endif if (qqty<>1) ErrorFnd=.T. @5,12 get qqty picture '99' color R/N endif if qlibrary<'A' .or. qlibrary>'Z' ErrorFnd=.T. @6,12 get qlibrary picture '!' color R/N endif if ErrorFnd @12,4 say 'Possible Error' color R/N read Lkey=Lastkey() @12,4 clear to 12,18 endif return * * * *************************************************************************** procedure PredictPay declare yearhold[3] trimMaterial=rtrim(ltrim(dmaterial)) store .F. to YearFound CurrYrstr=right(str(year(mdate),4),2) && last 2 digits of current yr Yearhold[1]=str(val(CurrYrStr)+1,2) &&next year Yearhold[2]=CurrYrstr &¤t year YearHold[3]=str(val(currYrStr)-1,2) &&previous year x=0 NumbYrsFound=0 do while x<3 x=x+1 YrFoundAt=at(Yearhold[x],trimMaterial) if YrFoundAt>0 && looking for next,current,prev yr, if found add 1 if YrFoundAt=1 YearFound=.T. else if substr(trimMaterial,YrFoundAt-1,1) $ " '-/9" YearFound=.T. endif endif if YearFound NumbYrsFound=NumbYrsFound+1 YrplusStr=str(val(YearHold[x])+1,2) trimMaterial=stuff(trimMaterial,YrFoundAt,2,YrplusStr) &&changes yr to yr+1 endif endif YearFound=.F. enddo &&(do while x, runs thru next, current, prev year and adds 1) if NumbYrsFound<1 && didnt find a year to modify xpos=0 lent=len(trimMaterial) PredictFound=.F. do while (.not. PredictFound) .and. (xpos'9' allnines=.F. endif endif enddo &&(numbstill) Numblen=numbend-numbbegin+1 newnumb=val(substr(trimMaterial,numbbegin,numblen))+1 if allnines newnumblen=numblen+1 else newnumblen=numblen endif newnumbstr=str(newnumb,newnumblen) T1material=left(trimMaterial,numbend) T2material=right(trimMaterial,lent-numbend) T1material=stuff(T1material,numbbegin,numblen,newnumbstr) dmaterial=T1material+T2material lendmat=len(dmaterial) if lendmat<45 dmaterial=dmaterial+space(45-lendmat) endif else &&(if no PredictFound) dmaterial=space(45) endif &&(PredictFound is .T.) else && year numbers were found to modify PredictFound=.T. &&(to allow EXIT msg to know there is content in mat.) dmaterial=trimMaterial+space(45-len(trimMaterial)) endif &&(number found was a year) return * * * * ***************************************************************************** * Add to and Edit Supplier List procedure SuppList Parameters InputSupp mSupp=InputSupp AlreadySearched=.F. AlreadyAdded =.F. set exact off SuppFinish=.F. do while .not. SuppFinish clear Select (SupplFile) set order to XSUPPNAME @ 5,10 say 'SUPPLIER LIST' responSupp='S' @10,10 say '(A)dd (S)earch (E)xit (A/S/E ?)' get responSupp picture '!' read do case case responSupp='E' .or. lastkey()=-8 SuppFinish=.T. InputSupp=mSupp && any changes are returned case responSupp='A' if seek(space(30)) && blanked out record can be re-used replace OTHERNAME with space(30),ADDRESS1 with space(30),; ADDRESS2 with space(30),ADDRESS3 with space(30) else append blank endif if len(ltrim(InputSupp))>0 if .not. AlreadyAdded mSupp=InputSupp AlreadyAdded=.T. endif else mSupp=NAME endif mOther=OTHERNAME mAdd1=ADDRESS1 mAdd2=ADDRESS2 mAdd3=ADDRESS3 clear @2,5 say 'F9 = Exit' @4,5 say 'SUPPLIER ' get mSupp @5,5 say 'OTHERNAME' get mOther @6,5 say 'ADDRESS1 ' get mAdd1 @7,5 say 'ADDRESS2 ' get mAdd2 @8,5 say 'ADDRESS3 ' get mAdd3 read if lastkey() <> -8 replace NAME with mSupp,OTHERNAME with mOther,ADDRESS1 with mAdd1,; ADDRESS2 with mAdd2,ADDRESS3 with mAdd3 endif case responSupp='S' set function F8 to chr(23) set function F7 to chr(23) set function F6 to chr(23) clear if len(ltrim(InputSupp))<1 .or. AlreadySearched mSupp=space(30) else mSupp=InputSupp AlreadySearched=.T. endif @10,5 say 'WHAT SUPPLIER ?' get mSupp picture '@!' read if lastkey() <> -8 .and. len(ltrim(mSupp)) > 0 GoNext=.T. seek upper(mSupp) do while GoNext .and. (.not. eof()) mSupp=NAME mOther=OTHERNAME mAdd1=ADDRESS1 mAdd2=ADDRESS2 mAdd3=ADDRESS3 clear @2,5 say 'F10=Save F9=Goto Menu F8=Next F7=Prev F6=Delete' @4,5 say 'SUPPLIER ' get mSupp @5,5 say 'OTHERNAME' get mOther @6,5 say 'ADDRESS1 ' get mAdd1 @7,5 say 'ADDRESS2 ' get mAdd2 @8,5 say 'ADDRESS3 ' get mAdd3 Goodkey=.F. && loops until valid function key pressed do while .not. Goodkey read save if Lastkey() >= -9 .and. Lastkey() <= -5 && valid Function key clear gets Goodkey=.T. endif enddo do case case lastkey()=-9 &&F10 replace NAME with mSupp,OTHERNAME with mOther,; ADDRESS1 with mAdd1,ADDRESS2 with mAdd2,ADDRESS3 with mAdd3 case lastkey()=-8 &&F9 GoNext=.F. case lastkey()=-7 &&F8 if .not. eof() skip GoNext=IIF(eof(),.F.,.T.) endif case lastkey()=-6 &&F7 if .not. bof() skip -1 GoNext=IIF(bof(),.F.,.T.) endif case lastkey()=-5 &&F6 Resp='N' @10,10 say 'DELETE (Y/N)?' get resp picture 'Y' color R/N read if resp='Y' replace NAME with space(30),OTHERNAME with space(30),; ADDRESS1 with space(30),ADDRESS2 with space(30),; ADDRESS3 with space(30) GoNext=.F. else @10,10 endif endcase enddo endif set function F6 to chr(13) set function F7 to chr(13) set function F8 to chr(13) endcase enddo return * * * * *************************************************************************** * if no matching Supplier, uses SuppList Procedure procedure GetSuppl SuppLoop=.T. do while SuppLoop SuppLoop=.F. @ 4,0 say 'SUPPLIER' @ 4,10 get qsupplier color GR+/N Goodkey=.F. do while .not. Goodkey read save if len(ltrim(qsupplier))>0 clear gets Goodkey=.T. endif enddo Select (SupplFile) set order to XSUPPNAME if .not. seek(upper(qsupplier)) set order to XSUPPOTHER if seek(upper(qsupplier)) qsupplier=NAME set order to XSUPPNAME else set order to XSUPPNAME activate window W2 TestSupp=.T. do while TestSupp && loops until something added or selected in SuppList clear do messagewindow with 'Supplier not listed' do SuppList with qsupplier TestSupp=IIF(len(ltrim(qsupplier))>0,.F.,.T.) enddo SuppLoop=.T. clear deactivate window W2 endif && supplier not found in OTHERNAME else qsupplier=NAME && to return same case as in Supplier File endif && supplier not found in NAME enddo && SuppLoop Select (HeaderFile) return * * * * procedure costrange clear lowcost=200.00 uppcost=99999.99 @2,4 say 'Enter a lower and upper price.' @3,4 say 'The output will be all individual material charges' @4,4 say 'costing between the (inclusive) lower and upper prices.' @7,10 say '>= ' get lowcost picture '99999.99' @7,25 say 'AND <= ' get uppcost picture '99999.99' read Msg='PAYMENT DATE RANGE' AcceptDates=.F. do getDateRange with BegDate,EndDate,DateError,Msg,AcceptDates if DateError return endif set exact on Select (HeaderFile) set order to XHEADNUMB &&(in serhead file) Select (Payfile) set order to XCOST seek lowcost scan rest for datanumb>0 .and. datanumb<50000 .and.; PAID>=BegDate .and. PAID<=EndDate WHILE COST<=uppcost mnumb=datanumb if seek(mnumb,HeaderFile) &&(header exists) ? SERHEAD->title do PrintPayLine endif &&(found()) endscan set exact off do waitmsg return * * * * ************************************************************************** * sets new annual budget amounts for each Library & fund in SERBUDG.DBF procedure setbudgets set alternate off BudgYrRec=0 clear Select (BudgetFile) goto top scan while recno()<8 ? str(recno(),1),space(10),ltrim(BUDGETYEAR) if len(ltrim(BUDGETYEAR))>0 BudgYrRec=recno() endif endscan ? ? '9',space(10),'NEW BUDGET YEAR' @ 20,5 say 'What Budget? ' get BudgYrRec picture '9' read if BudgYrRec=9 append blank BudgYrRec=recno() else if BudgYrRec>0 .and. BudgYrRec<=reccount() goto BudgYrRec endif endif if .not. eof() edit record BudgYrRec noappend nomenu nodelete endif Select (Payfile) set alternate on return ********************************************************** * Claiming on overdue issues procedure SerClaim declare DfTitleArr[20],DfClaimArr[20] clear set exact on Sortchoice='S' @10,2 to 12,70 double color N/BG @11,4 say 'Arrange by:(F) Fund, (P) Publisher, (S) Supplier, (T) Title' ; get Sortchoice picture '!' color GR+/N do readMenu with SortChoice,'FPST' if SortChoice='9' return endif select 4 set order to xdfnumb select 3 set order to xchkord select 1 do case case Sortchoice='P' set order to xpublisher case Sortchoice='S' set order to xsupplier Case Sortchoice='T' set order to xtitle Case Sortchoice='F' set order to xfund endcase clear ? ? header1 ? 'Claim Report' ? goto top scan for headnumb>0 .and. headnumb<50000 mNumb=HEADNUMB if seek(mNumb,4) &&(must be a check-in definition record to compare) HeaderPrinted=.F. do LoadChkDf with mNumb && loads claim definition array select 3 seek(str(mNumb,5)+space(4)) OldChkTypeNo=CHKTYPENO OldChkData =CHKDATA OldChkCopy =CHKCOPY OldChkDate =CHKDATE scan rest while CHKNUMB=mNumb if OldChkTypeNo<>CHKTYPENO .or. OldChkCopy<>CHKCOPY do PrtClaimData OldChkTypeNo=CHKTYPENO OldChkData =CHKDATA OldChkCopy =CHKCOPY OldChkDate =CHKDATE else OldChkData =CHKDATA OldChkDate =CHKDATE endif endscan do PrtClaimData && deals with last instance select 1 endif &&(check-in definition record exists) endscan set exact off return * * * * procedure PrtClaimData if OldChkTypeNo>0 .and. OldChkTypeNo<=20 ClaimPeriod = dfClaimArr[OldChkTypeNo] if ClaimPeriod>0 && don't claim if no claim period defined if OldChkDate + ClaimPeriod < mdate && overdue if .not. HeaderPrinted && each Header Printed just once HeaderPrinted=.T. ? '************' ? upper(rtrim(SERHEAD->Title)) ? ' ',SERHEAD->Publisher, SERHEAD->Supplier, SERHEAD->Fund ? endif ? dfTitleArr[OldChkTypeNo],OldChkData,; ' Copy No: ',str(OldChkCopy,2),' Received: ',OldChkDate endif endif endif return * * * *