* GOVMAIN.PRG * * For Database Structure See the section at the end of this program * labelled "DATABASE STRUCTURE" * * set alternate off clear all set talk off ************************************************************************* * Area for Possible Modification * * (make sure following DOS directories exist) 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 declare Pub[26,2] Pub[1,1]='AG' Pub[1,2]='Agriculture Dept.' Pub[2,1]=' ' Pub[2,2]='' Pub[3,1]=' ' Pub[3,2]=' ' Pub[4,1]=' ' Pub[4,2]=' ' Pub[5,1]=' ' Pub[5,2]=' ' Pub[6,1]=' ' Pub[6,2]=' ' Pub[7,1]=' ' Pub[7,2]=' ' Pub[8,1]=' ' Pub[8,2]=' ' Pub[9,1]=' ' Pub[9,2]=' ' Pub[10,1]=' ' Pub[10,2]=' ' Pub[11,1]=' ' Pub[11,2]=' ' Pub[12,1]=' ' Pub[12,2]=' ' Pub[13,1]=' ' Pub[13,2]=' ' Pub[14,1]='JU' Pub[14,2]='Justice Department' Pub[15,1]=' ' Pub[15,2]=' ' Pub[16,1]=' ' Pub[16,2]=' ' Pub[17,1]=' ' Pub[17,2]=' ' Pub[18,1]=' ' Pub[18,2]=' ' Pub[19,1]=' ' Pub[19,2]=' ' Pub[20,1]=' ' Pub[20,2]=' ' Pub[21,1]=' ' Pub[21,2]=' ' Pub[22,1]=' ' Pub[22,2]=' ' Pub[23,1]=' ' Pub[23,2]=' ' Pub[24,1]=' ' Pub[24,2]=' ' Pub[25,1]=' ' Pub[25,2]=' ' Pub[26,1]=' ' Pub[26,2]=' ' *************************************************************************** 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 exclusive on set confirm off 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 '' enddo set function F9 to chr(23) set function F10 to chr(23) set typeahead to 99 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 Wmsg from 10,2 to 13,77 double color N/RB public temppaiddate public array RecArr[17] mdate=date() deactivate window all clear fields close databases close alternate ************************** Recycle=.T. do while recycle recycle=.F. do Startup && starts up main program enddo ************************** && existence of report & transact file checked for WordPerfect use if .not. file(TextPath+'transact.gov') do alterfile with 'TRANSACT.GOV' ? endif if .not. file(TextPath+'report.gov') do alterfile with 'REPORT.GOV' ? endif close alternate Quit * * * * procedure ChangeDate clear @10,10 say 'MODIFY TO NEW DATE : ' get tmpdate Read if Lastkey()<>-8 mdate=tmpdate endif return * * * * procedure delay parameters DelayNo x=0 do while x to exit.' @12,20 get respon color X/X read set exact on if rtrim(ltrim(respon))='10' .and. lastkey()=-9 pass = .T. endif set exact off set color to W+/B 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 esc recycle=.T. close all return to MASTER * * * * procedure Startup ****** load data files into work areas 1-3 HeaderFile =1 && variable for select areas DataFile =2 MaterialFile =3 Select (HeaderFile) use dataPath+'GovHead' set order to XCLASSSORT Select (DataFile) use DataPath+'GovIn' set order to XDATANUMB select (MaterialFile) use DataPath+'Govmat' set order to XSRCHNUMB ******* store 0 to mHeadNumb store ' ' to mTitle,mClass,mClassSort,mAgency,mItem do alterfile with 'TRANSACT.GOV' set alternate off Select (HeaderFile) set near on MainSerLoop=.T. do while MainSerloop daystring=cdow(mdate)+', '+cmonth(mdate)+ ' '+; ltrim(str(day(mdate),2))+', '+str(year(mdate),4) temppaiddate=mdate tmpdate=mdate deactivate window all do MenuBox with 'MAIN MENU (DOCUMENTS)' respon='1' @ 7,15 say '1 Search by Class Number' @ 8,15 say '2 Search Menu' @ 9,15 say '3 Create New Class Record' @ 13,15 say '7 Report/Maintenance' @ 14,15 say '8 Change Date' @ 15,15 say '9 Quit' @16,14 get respon picture '9' color GR+/N set color to W+/B do readMenu with respon,'0123789' do case case respon='1' ClassSearch=.T. do searching case respon='2' ClassSearch=.F. do searching case respon='3' do addheadrec case respon='7' do govrpt case respon='8' do ChangeDate case respon='9' MainSerLoop=.F. case respon='0' clear typeahead if inkey(2)=48 && 0 within 2 secs. suspend endif endcase enddo && (while MainSerLoop) clear fields close databases close alternate 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 * * * * ************************************************************************** * Moves 'A' 'An' 'The' from front to end of field procedure InvArticles if lenqtitle>3 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 * * * * procedure addheadrec set exact off Select (HeaderFile) set order to XTITLE endaddrec=.F. do while .not. endaddrec clear typeahead clear store space(15) to qClass store space(70) to qAgency,qTitle store space(10) to qItem store 'N' to qnotes @ 0,10 say 'CREATING NEW CLASS RECORD' @ 0,50 say '<< F9 to EXIT >>' color R/N @ 1,0 say 'TITLE' @ 1,8 get qTitle color GR+/N read qTitle=ltrim(rtrim(qTitle)) lenqTitle= len(qTitle) if lenqTitle<1 .or. lastkey()=-8 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,9 say qTitle @ 1,0 to 1,78 double @ 2,1 say 'CLASS' @ 2,8 get qClass color GR+/N @ 3,1 say 'AGENCY' @ 3,8 get qAgency color GR+/N @ 4,0 to 4,79 double @ 7,0 to 24,79 @ 8,1 say 'Use the codes of each below, to substitute for AGENCY' ? xx=1 do while xx<=13 R= 10+xx @ R,6 say Pub[xx,1] color G/N @ R,11 say Pub[xx,2] @ R,40 say Pub[xx+13,1] color G/N @ R,45 say Pub[xx+13,2] xx=xx+1 enddo read set exact on QAgency=ltrim(rtrim(qAgency)) if len(QAgency)>0 .and. len(QAgency)<4 xx=0 do while xx<26 xx=xx+1 if upper(QAgency)=upper(Pub[xx,1]) QAgency=Pub[xx,2] xx=99 &&(to force end) endif enddo endif @ 1,0 clear @ 1,9 say qClass @ 2,9 say qAgency @ 3,0 clear @ 4,1 say 'ITEM' @ 4,14 get qItem color GR+/N @ 5,1 say 'NOTES (Y/N)?' @ 5,14 get qnotes picture 'Y' color GR+/N read @ 3,9 say qItem @ 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' && returns '9' if F9 if .not. (respon='D' .or. respon='9') 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 NewHeadno=HEADNUMB+1 if seek(NewHeadno) &&(protection against duplicate headnumb) NewHeadno=1 notfound=.T. do while notfound if seek(NewHeadno) NewHeadno=NewHeadno+1 else notfound=.F. endif enddo endif append blank mHeadNumb=NewHeadno mTitle=qTitle mClass=qClass mAgency=qAgency mItem=qItem FinalStr='' OutStr=mClass do AlphaNumeric && returns alphanumeric vers. of CLASS in FinalStr mClassSort=FinalStr replace CLASSSORT with mClassSort replace HEADNUMB with mHeadNumb,TITLE with mTitle,; CLASS with mClass, AGENCY with mAgency,ITEM with mItem if len(memnote)>0 replace NOTES with memnote endif if respon='E' do editheadrec endif endif &&(Respon<>'D') do XRefAdd clear set exact off enddo return * * * * procedure XRefEdit clear declare Reftit[20],RefRec[20] @0,5 say upper(mTitle) 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)+' ' RefRec[ReferCntr]=recno() RefTit[ReferCntr]=TITLE @ ReferCntr+1,4 get RefTit[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 key, or cursor down, to end ' color R/B read loopcntr=0 do while loopcntrTitle replace TITLE with RefTit[loopcntr] endif endif &&(Title blanked out) enddo endif &&(ReferCntr>0) return * * * * procedure XRefAdd if mHeadNumb>0 .and. mHeadNumb<50000 declare P[9] mainrec=recno() Dheadnumb=HEADNUMB+50000 PermuteNo=0 do XRefLdPerm && (Load permuted possibilities) AnotherCross=.T. do while AnotherCross DTitle=space(70) AnotherCross=.F. clear @0,10 say 'CREATING CROSS-REFERENCE TITLE ENTRIES' @1,0 say 'TITLE: '+mTitle color GR+/N @3,3 say 'Enter any alternative Title that a searcher might use,' @3,58 say '<< F9 to EXIT >>' color R/N @5,3 clear @6,3 get DTitle 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 displayNo0 .and. .not. Lkey=-8 Responval=val(DTitle) && (choose from loaded permuted Titles) if (lenDTitle=1) .and. Responval>0 .and. Responval<=PermuteNo DTitle=P[Responval] + space(70-len(P[Responval])) @4,3 clear @6,3 get DTitle color GR+/N read Lkey=lastkey() DTitle=rtrim(ltrim(DTitle)) lenDTitle=len(DTitle) P[Responval]='' endif AnotherCross=.T. if islower(DTitle) DTitle=stuff(DTitle,1,1,upper(left(DTitle,1))) endif D20Title=upper(left(DTitle,20)) set order to XTITLE if seek(D20Title) @ 7,0 clear @ 8,10 say 'The following begin with the same characters' ? scan rest while upper(TITLE)=D20Title ? TITLE endscan @ 12,18 to 14,79 double color N/R clear typeahead respon="C" @ 13,19 say '(C) Continue with alternative Title, (D) Delete entry '; get respon picture '!' color GR+/N do readMenu with respon,'CD' && returns '9' if F9 if respon="D" .or. respon='9' DTitle=space(70) AnotherCross=.T. loop endif endif &&(seek D20Title) append blank replace HEADNUMB with DHeadNumb,TITLE with DTitle,; CLASS with mClass,CLASSSORT with mClassSort replace AGENCY with mAgency,ITEM with mItem endif &&(lenDTitle>0) enddo &&(AnotherCross) goto mainrec endif &&(mHeadnumb>0 and <50000) return * * * procedure XRefLdPerm &&( Load P array with permuted x-reference Titles) &&(PermuteNo has the number of permuted possibilities) Part1=rtrim(ltrim(mTitle))+' ' 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 * * * * procedure XRef ***** Menu for adding or editing cross reference Titles * if mHeadNumb>0 .and. mHeadNumb<50000 oldrecno=recno() referheadnumb=mHeadNumb+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) return * * procedure deleteheader dlt=space(6) @10,0 clear @11,12 to 17,50 double color N/R @12,15 say 'WARNING -- Deletion is PERMANENT' color R/N @15,15 say 'Type DELETE in full' @16,15 say 'otherwise enter a ' @15,36 get dlt picture '@!' color GR+/N read if dlt='DELETE' set order to xheadnumb clear ? mdy(mdate),' ',time() @ 2,10 say 'DELETING' color R/N ** DELETE HEADER ** ? 'TITLE '+Title ? 'CLASS '+Class ? 'AGENCY '+Agency ? 'ITEM '+ Item dheadnumb=headnumb replace HEADNUMB with 0,TITLE with ' ',CLASS with ' ' replace CLASSSORT with ' ',AGENCY with ' ' replace ITEM with ' ' if len(notes)>0 set memowidth to 240 memnote=mline(notes,1) ? ' NOTES' ? memnote replace notes with '' endif set exact on Refheadnumb=dheadnumb+50000 if seek(refheadnumb) ** DELETE CROSS REFERENCES ** ? ' CROSS REFERENCES ' do while refheadnumb=HEADNUMB ? TITLE replace TITLE with ' ',Class with ' ',CLASSSORT with ' ' replace Agency with ' ',Item with ' ' replace headnumb with 0 seek (refheadnumb) enddo endif select (DataFile) set order to XDATANUMB ** DELETE DATA LINES ** do while seek(dheadnumb,DataFile) &&(seek related records in the data file) ? SUBCLASS,ADDED,FORM replace SUBCLASS with ' ',ADDED with { / / },FORM with ' ' ** DELETE ANY MATERIAL DATA ** if DATAPOINT > 0 mDataPoint=DATAPOINT SrchPointer=((dheadnumb*100000)+mDataPoint)*10 select (MaterialFile) seek (SrchPointer) scan rest while MATHEADNO=dheadnumb .and. MATDATANO=mDataPoint if MATLINENO>0 .and. MATLINENO<=3 ? ' ',MATERIAL endif replace MATERIAL with ' ',MATLINENO with 0,MATHEADNO with 0,; MATDATANO with 0 endscan select (DataFile) replace DATAPOINT with 0 endif replace DATANUMB with 0 enddo ? '**********************************' Select (HeaderFile) SearchMenu=.T. else RecFdLoop=.T. endif &&('DELETE' entered) set exact off clear return * * * * procedure editheadrec clear qTitle=Title qClass=Class qAgency=Agency qItem=ITEM @ 1,0 say 'TITLE' @1,10 get qTitle color GR+/N @ 2,0 say 'CLASS' @2,10 get qClass color GR+/N @ 3,0 say 'AGENCY' @3,10 get qAgency color GR+/N @ 4,0 say 'ITEM' @4,10 get qItem color GR+/N if len(notes)>0 set memowidth to 240 oldmemnote=mline(notes,1) memnote=oldmemnote+space(240-len(oldmemnote)) oldmemnote=rtrim(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 @ 11,3 to 16,55 double @ 12,5 say 'Arrow keys to move.' @ 14,5 say 'To finish:' @ 14,16 say 'DOWN ARROW or ENTER from notes field' @ 15,16 say 'or F10 key at any field' @18,0 to 24,79 double @ 19,33 say '*** WARNING *** ' @ 20,10 say 'Changes will affect ALL entries for this Title' @ 21,10 say 'If you do not want older entries to reflect the changes,' @ 22,10 say 'consider creating a new serial Title record.' read if Title<>qTitle replace Title with qTitle endif if Class<>qClass replace Class with qClass OutStr=qClass FinalStr='' do AlphaNumeric && convert alpha. class to alphanumeric Finalstr replace CLASSSORT with FinalStr endif if Agency<>qAgency replace Agency with qAgency endif if ITEM<>qItem replace ITEM with qItem endif memnote=rtrim(memnote) if len(oldmemnote)>0 if oldmemnote<>memnote replace notes with memnote endif else &&(no notes field) if len(memnote)>0 replace notes with memnote endif endif set exact off return * * * * procedure searching SearchMenu=.T. CombField=.F. do while SearchMenu deactivate window all clear Select (HeaderFile) SearchMenu=.F. respon='1' if .not. ClassSearch &&(bypasses search menu if Class # search required) do MenuBox with 'SEARCH MENU (DOCUMENTS)' @ 7,15 say '1 Class search' @ 8,15 say '2 Item search' @ 9,15 say '3 Agency search' @ 10,15 say '4 Title search' @ 11,15 say '5 Combined field' @ 12,15 say '6 Scan Material Descriptions' @ 15,15 say '9 Exit' @ 16,14 get respon picture '9' color GR+/N set color to W+/B do readMenu with respon,'1234569' endif do case case respon='1' set order to XCLASSSORT typefield='CLASSSORT' Arrangedby='CLASS' do findentr case respon='2' set order to XITEM typefield='ITEM' Arrangedby='ITEM NUMBER' do findentr case respon='3' set order to XAGENCY typefield='AGENCY' Arrangedby='AGENCY' do findentr case respon='4' set order to XTITLE typefield='TITLE' Arrangedby='TITLE OF CLASS' do findentr case respon='5' CombField=.T. set order to XTITLE typefield='TITLE' Arrangedby='TITLE OF CLASS' do Findentr case respon='6' do ScanMaterial case respon='9' MainSerLoop=.T. endcase enddo Select (HeaderFile) set order to XCLASSSORT return * * procedure findentr && locates a single header record for user && RecArr[] used to hold scan of header recno() x=0 do while x<17 && initialize RecArr x=x+1 RecArr[x]=0 enddo clear Exiting=.F. Srch=' ' 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 the exit from rec. sets RptSrchList to .T. then && SrchEntry will be repeated enddo endif return * * * * procedure ScanMaterial clear startchoice=space(20) @15,3 TO 18,70 double color N/GR @16,10 say 'Enter one or more characters at which to start browsing' @17,29 get startchoice picture '@!' color G/N read select (headerfile) set order to xheadnumb select (datafile) set order to xdatanumb select (materialfile) set order to xmaterial seek startchoice finished=.F. activate window W1 clear clear typeahead @0,4 say 'SPACEBAR -> Suspend/Restart' @1,4 say 'ENTER -> Quit' activate window W2 clear xx=0 do while xx<15 xx=xx+1 ? enddo scan rest while .not. finished for MATLINENO>0 .and. MATLINENO<=3 mhead=MATHEADNO mdata=MATDATANO mmat=MATERIAL mrec=recno() if seek(mhead,datafile) select(datafile) scan rest for DATAPOINT=mdata if seek(mhead,headerfile) select(headerfile) ? ? TITLE ? AGENCY ? CLASS,' ',GOVIN->SUBCLASS,' ',GOVIN->ADDED,' ',GOVIN->FORM select (materialfile) set order to xsrchnumb seek(((mhead*100000)+mdata)*10) scan rest while MATHEADNO=mhead .and. MATDATANO=mdata; for MATLINENO>0 .and. MATLINENO<=3 ? MATERIAL endscan ? '---------------' goto mrec && to return to scan position endif exit endscan select (materialfile) set order to xmaterial endif do delay with 10 testkey=inkey() do case case testkey=32 && spacebar waiting=.T. do while waiting testkey2=inkey() do case case testkey2=32 waiting=.F. case testkey2=13 waiting=.F. finished=.T. endcase enddo case testkey=13 && enter finished=.T. endcase endscan select(materialfile) set order to xsrchnumb && reestablish default clear typeahead xx=0 do while xx<20 xx=xx+1 ? enddo clear activate window W1 clear deactivate window W1,W2 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 clear typeahead 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 RecArr[Rval]>0 &&if recno() is loaded in RecArr go RecArr[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 R/N &&(search for Title,Class, Agency, or Item) rlen=len(&typefield) if rlen>20 rlen=20 && to reduce search len to 20 which is max index length endif respon=space(rlen) @3,5 say "What "+Arrangedby+"? : " get respon color GR+/N read srch=upper(rtrim(respon)) if len(srch)<1 .or. lastkey()=-8 && no search entered SearchMenu=.T. if TYPEFIELD='CLASS' &&(to prevent an assumption of Class search) ClassSearch=.F. &&(as user does not want to search for a Class) endif clear deactivate window W1 Exiting=.T. else set exact off if typefield='CLASS' OutStr=respon FinalStr='' do AlphaNumeric && converts alphabetic Outstr to alphanumeric FinalStr srch=FinalStr endif seek(srch) endif return * * procedure AlphaNumeric && object is to take an OutStr and return in Finalstr a conversion from && alphabetic to alphanumeric, max. capacity is 6 tokens of 4 chars each declare ParseArr[6],ParseType[6] x=0 do while x<6 x=x+1 ParseArr[x]='' ParseType[x]='' enddo Outstr=rtrim(ltrim(OutStr)) strlen=len(Outstr) subcntr=0 CharCntr=0 PrevChar='P' do while CharCntr> ; << F10 when search entered>>' color R/N qClass=space(15) qAgency=space(70) qTitle=space(70) qItem = space(10) @ 2,0 say 'CLASS' @ 2,10 get qClass picture '@!' color GR+/N @ 3,0 say 'AGENCY' @ 3,10 get qAgency picture '@!' color GR+/N @ 4,0 say 'TITLE' @ 4,10 get qTitle picture '@!' color GR+/N @ 5,0 say 'ITEM' @ 5,10 get qItem color GR+/N read activate window W2 @0,0 fill to 16,77 color N/N qTitle =rtrim(ltrim(qTitle)) qClass =rtrim(ltrim(qClass)) qAgency =rtrim(ltrim(qAgency)) qItem =rtrim(ltrim(qItem)) Srch=' ' if (len(qTitle) + len(qClass) + len(qAgency) +len(qItem)>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(qClass)>0 if len(srch)>1 srch=srch+' .and. ' endif Srch=Srch+' '+'"'+qClass+'"' + ' $ upper(CLASS)' endif if len(qAgency)>0 if len(srch)>1 srch=srch+' .and. ' endif Srch=Srch+' '+'"'+qAgency+'"' + ' $ upper(AGENCY)' endif if len(qItem)>0 if len(srch)>1 srch=srch+' .and. ' endif Srch=Srch+' '+'"'+qItem+'"' + ' $ upper(ITEM)' endif srch=srch+' .and. HEADNUMB>0' 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 GR+/N @0,col() say space(4)+'CLASS'+space(5) color W+/B @0,col() say ' ITEM ' color N/W @0,col() say ' AGENCY ' color BG+/B @0,col() say space(20)+'TITLE'+space(15) color B/W @2,7 say 'ARRANGED BY '+ Arrangedby 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 * * * * procedure PrintMaterial parameters Hdnumb,DNumb SrchPointer=((HdNumb*100000)+DNumb)*10 select (MaterialFile) seek SrchPointer scan rest while MATHEADNO=HdNumb .and. MATDATANO=DNumb; for MATLINENO>0 .and. MATLINENO<=3 ? ' ',MATERIAL endscan select(DataFile) return * * * * procedure ShowTitles && displays up to 17 lines of Titles in window W2 && RecCntr is subscript for RecArr && Displays Headers and loads recno() into R[] && LineNo is one less than RecCntr and shows line in window W2 activate window W2 HitFound=.F. If Forward RecCntr=0 &&forward load of R[] Direction=1 else RecCntr=18 &&reverse load of R[] 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 & RecArr when first hit found HitFound=.T. clear x=0 do while x<17 && initialize RecArr x=x+1 RecArr[x]=0 enddo endif &&(.not. HitFound) RecCntr=RecCntr + Direction RecArr[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 CLASS color W+/B @ LineNo,17 say ITEM color N/W @ LineNo,27 say left(AGENCY,11) color BG+/B @ LINENO,38 say left(TITLE,40) color B/W endif &&(Srch matches with record) if inkey() <> 0 &&abandon if keypressed or skip to next record keypressed=.T. else skip direction endif enddo &&(while not DisplEnd) if HitFound && something is on screen if Forward FirstRec=RecArr[1] LastRec=IIF(RecCntr>0 .and. RecCntr<=17,RecArr[RecCntr],FirstRec) else &&(Reverse display) LastRec=RecArr[17] FirstRec=IIF(RecCntr>0 .and. RecCntr<=17,RecArr[RecCntr],LastRec) endif endif &&(HitFound) return * * * * procedure recfound clear RecFdLoop=.T. do while RecFdLoop RecFdLoop=.F. Select (HeaderFile) set order to xheadnumb set exact on oldrec=recno() if HEADNUMB>50000 .and. HEADNUMB<100000 &&(cross-reference code) newheadnumb=HEADNUMB-50000 if .not. seek(newheadnumb) goto oldrec @1,5 say Title color GR+/B @2,5 say Class color GR+/B @4,25 say '** WARNING **' color R/N @5,5 say 'This is a cross-reference Title that does not point' @6,5 say 'to any main Title record' Ch='C' @7,2 say '(D) Delete cross-reference Title, (C) Convert to main Title (D/C)?'; get Ch picture '!' color R/N do readMenu with Ch,'CD' if Ch='C' .or. Ch='9' 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 && if cross-ref found ******** set memory variables for main rec. to carry to GovIn program mHeadNumb =HEADNUMB mTitle =rtrim(ltrim(TITLE)) mClass =rtrim(ltrim(CLASS)) if at(':',mClass)<1 mClass=mClass+':' &&if there is no ':' anywhere in class add one at end endif mClassSort=rtrim(CLASSSORT) mAgency =rtrim(ltrim(AGENCY)) mItem =rtrim(ltrim(ITEM)) ************************ set exact off @1,0 say 'CLASS' @1,10 say mCLASS color W+/GR @2,0 say 'ITEM' @2,10 say mITEM color W+/GR DataExists=.F. if seek(mHeadNumb,DataFile) DataExists=.T. && Data exists in data file endif @3,0 say 'AGENCY' @3,10 say AGENCY color W+/GR @4,0 say 'TITLE' @4,10 say TITLE 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 select (DataFile) set order to xDATANUMB set exact on Select (HeaderFile) set exact off @10,0 clear @10,13 to 13,77 double color N/BG @10,35 say '>> Documents <<' color N/BG @11,15 say '1 Add new document' @12,15 say '2 Document menu' @11,14 fill to 12,76 color W+/N if .not. DataExists @12,38 say 'no data recorded' endif @13,13 to 20,77 double color N/BG @13,35 say '>> Header Information <<' color N/BG @17,15 say '5 Cross reference titles' @18,15 say '6 Edit header/notes' @19,15 say '7 Delete header & documents' @14,14 fill to 19,76 color W+/N @20,13 to 24,77 double color N/BG @20,35 say '>> Other Listings <<' color N/BG @21,15 say '8 Search Menu '+chr(27)+' Goto Header List' @22,15 say '9 Exit' @21,14 fill to 23,76 color W+/N respon='2' @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,'1256789')>0 clear gets Goodkey=.T. if Lkey=-8 respon='9' endif endif enddo do case case lkey = 19 &&(Left arrow = goto Header List) set order to 'X'+(Typefield) RptSrchList=.T. case respon='1' Addingonly=.T. do GovIn && documents check-in program if .not. RecFdLoop SearchMenu=.T. endif case respon='2' Addingonly=.F. do GovIn && documents check-in program if .not. RecFdLoop SearchMenu=.T. endif case respon='5' do XRef clear RecFdLoop=.T. case respon='6' do editheadrec clear RecFdLoop=.T. case respon='7' do deleteheader SearchMenu=.T. case respon='8' SearchMenu=.T. case respon='9' * endcase enddo && (RecFdLoop) 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 read select 5 if .not. seek(upper(qsupplier)) activate window W2 TestSupp=.T. do while TestSupp && loops until something added or selected in SuppList clear do SuppList with qsupplier if len(ltrim(NAME))>0 qsupplier=NAME TestSupp=.F. else clear do messagewindow with 'No Supplier selected' endif enddo SuppLoop=.T. clear deactivate window W2 endif enddo && SuppLoop select 1 return * * * * *********************************************************** * Govt Doc. Check-in procedure GovIn Select (HeaderFile) clear store 'P' to mForm,prevform store space(20) to mSubClass declare mMaterial[3] store space(60) to mMaterial[1],mMaterial[2],mMaterial[3] CurrAdded=mdate PrevAdded=CurrAdded Restart=.T. do while Restart Restart=.F. do DispData ContAdding=.T. do while ContAdding ContAdding=.F. set exact off activate window W1 @ 0,0 clear to 5,79 @0,0 say mClass color W+/N @0,col()+2 say left(mTitle,77-col()) color GR+/N if .not. Addingonly respon='9' @ 1,0 to 5,79 double color N/BG @1,25 say '>> Document Check-in <<' color N/BG if DataExists @ 2,4 say '1 Scan/Edit/Delete' validresp='1279' else validresp='279' endif @2,30 say '2 Add new document' @ 3,4 say '7 Return to Header 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 respon='1' do Editing Restart=.T. case respon='2' do AddInData ContAdding=.T. case respon='7' Restart=.F. RecFdLoop=.T. && loops to look at header again case respon='9' endcase respon='9' enddo && (to loop to continue adding) enddo && (to Restart SERPAY) deactivate window all return * * procedure AddInData mDataPoint=0 mSubClass=space(20) mForm=prevForm store space(60) to mMaterial[1], mMaterial[2],mMaterial[3] activate window W1 @0,0 clear to 5,79 @0,0 say mClass color W+/B @0,col()+2 say left(mTitle,77-col()) color W+/B @ 1,10 say '<< F9 to Exit (without Saving) >> << F10 to Save >>' color R/N @ 2,0 say 'SUBCLASS' color GR+/B @ 2,40 say 'ADDED' color GR+/B @ 2,60 say 'FORM' color GR+/B @ 3,0 say 'MATERIAL' color GR+/B @ 2,10 get mSubClass color B/W @ 2,46 get CurrAdded color B/W @ 2,67 get mForm picture '!' color B/W @ 3,10 get mMaterial[1] color B/W @ 4,10 get mMaterial[2] color B/W @ 5,10 get mMaterial[3] color B/W read if len(ltrim(mSubClass))>0 .and. lastkey()<>-8 do errchkdata if lastkey()=-8 && F9 key pressed in errorchk ContAdding=.F. Restart=.T. && redisplays current header data else PrevAdded=CurrAdded && resets 'previous' values prevform=mForm activate window W2 set order to XDATANUMB append blank replace DATANUMB with mHeadNumb,; SUBCLASS with mSubClass,ADDED with CurrAdded,FORM with mForm DataExists=.T. ? Rw=Row() @ Rw,0 say SUBCLASS color W+/B @ Rw,20 say ADDED color N/W @ Rw,28 say FORM color BG+/B select (MaterialFile) MatFound=.F. store 0 to RNumb,SrchPointer xx=1 do while xx<=3 if len(ltrim(mMaterial[xx])) > 0 if .not. MatFound MatFound=.T. do MakeRandNo with mHeadNumb,SrchPointer,RNumb && returns SrchPointer as material pointer && and RNumb as DATANUMB @ Rw,29 say left(ltrim(mMaterial[xx]),48) color B/W endif append blank replace MATHEADNO with mHeadNumb,MATDATANO with RNumb,; MATLINENO with xx,MATERIAL with mMaterial[xx] endif && if len>0 xx=xx+1 enddo && save 1-3 material lines to Govmat.dbf select (DataFile) replace DATAPOINT with RNumb && if MatFound=.F. RNumb will be 0 if .not. MatFound @ Rw,29 say space(48) color B/W endif endif && no F9 key pressed in errorchk else &&(len mSubClass<1) ContAdding=.F. Restart=.T. && redisplays current header data endif return * * * * procedure DispData declare DataArr[3] select (DataFile) set order to XDATANUMB &&(in data file) activate window W1 clear activate window W2 clear set exact on do seeklast if mHeadNumb=DATANUMB skip -19 scan next 20 while mHeadNumb<>DATANUMB endscan scan rest while mHeadNumb=DATANUMB ? Rw=Row() @ Rw,0 say SUBCLASS color W+/B @ Rw,20 say ADDED color N/W @ Rw,28 say FORM color BG+/B if DATAPOINT > 0 store ' ' to DataArr[1],DataArr[2],DataArr[3] mDataPoint=DATAPOINT SrchPointer=((DATANUMB*100000)+mDataPoint)*10 select (MaterialFile) MatFound=.F. seek SrchPointer scan rest while MATHEADNO=mHeadnumb .and. MATDATANO=mDataPoint ; for MATLINENO>0 .and. MATLINENO<=3 DataArr[MATLINENO]=left(MATERIAL,48) MatFound=.T. endscan if .not. MatFound @ Rw,29 say space(48) color B/W else do case case len(ltrim(DataArr[1]))>0 @ Rw,29 say DataArr[1]+space(48-len(DataArr[1])) color B/W case len(ltrim(DataArr[2]))>0 @ Rw,29 say DataArr[2]+space(48-len(DataArr[2])) color B/W case len(ltrim(DataArr[3]))>0 @ Rw,29 say DataArr[3]+space(48-len(DataArr[3])) color B/W otherwise @ Rw,29 say space(48) color B/W endcase endif select (DataFile) else @ Rw,29 say space(48) color B/W endif endscan if eof() skip -1 endif if mHeadNumb<>DATANUMB skip-1 && to last instance of this DATANUMB endif store FORM to prevform DataExists=.T. else DataExists=.F. endif &&(related records found) return * * * * procedure editing declare recordmat[3] declare prevMat[3] set order to xdatanumb set exact on do SeekLast && find last matching data record if mHeadNumb=DATANUMB && start at last instance Prevrec=recno() LimitEdit=.F. do EditMenu ContEdit=.T. Lkey=-1 do while ContEdit .and. mHeadNumb=DATANUMB if LimitEdit && find next rec within subclass limitation Prevrec=recno() do NextLimit endif ***************** now looking at one data line mDataPoint =DATAPOINT mSubClass =SUBCLASS mAdded =ADDED mForm =FORM SrchPointer=((DATANUMB*100000)+mDataPoint)*10 && index entry in GOVMAT.DBF **************** x=0 do while x<3 x=x+1 mMaterial[x] =space(60) prevMat[x] =space(60) recordmat[x] =0 enddo @ 2,10 get mSubClass color GR+/N @ 3,10 get mAdded color GR+/N @ 4,10 get mForm picture '!' color GR+/N if mDataPoint>0 select (MaterialFile) seek(SrchPointer) scan rest while MATHEADNO=mHeadNumb .and. MATDATANO=mDataPoint ; for MATLINENO>0 .and. MATLINENO<=3 mMaterial[MATLINENO] =MATERIAL prevMat[MATLINENO] =MATERIAL && used to check if changes made recordmat[MATLINENO] =recno() endscan select (DataFile) endif && material line may exist @ 5,10 get mMaterial[1] color GR+/N @ 6,10 get mMaterial[2] color GR+/N @ 7,10 get mMaterial[3] color GR+/N @ 8,0 to 8,79 double color N/BG set function F2 to chr(23) set function F7 to chr(23) set function F8 to chr(23) Goodkey=.F. do while .not. Goodkey read save Lkey=Lastkey() if Lkey=-1 .or. Lkey=-6 .or. Lkey=-7 .or. Lkey=-9 .or. Lkey=18 .or.; Lkey=3 .or. Lkey=13 .or. Lkey=5 .or. Lkey=24 clear gets Goodkey=.T. endif enddo do Case case Lkey= -1 && F2 to abandon any changes by recycling case Lkey= -6 && F7 to delete data do deleteInData && returns ContEdit=.F. if no more after delete otherwise do SaveChanges Do Case && Lkey may be reset by errchkedit(SaveChanges) case Lkey=-1 && F2 recycle to re-display current data case Lkey=-6 && F7 to delete data do deleteInData && returns ContEdit=.F. if no more after delete case Lkey=-7 && F8 to SELECTIVELY display SubClassSrch=space(20) do SelectEdit Case Lkey=-9 && F10 to Finish ContEdit=.F. Case (Lkey=3 .or. Lkey=13 .or. Lkey=24) .and. .not. LimitEdit && Page Down (for earlier data) if .not. bof() skip -1 if mHeadNumb<>DATANUMB do MessageWindow with 'On PageDown, No data' skip endif endif Case (Lkey=18 .or. Lkey=5) .and. .not. LimitEdit && Page Up (for later data) if .not. eof() skip if mHeadNumb<>DATANUMB do MessageWindow with 'On PageUp, No data' skip -1 endif endif endcase endcase enddo && loop for more edits endif && start at last instance set exact off set function F2 to '' set function F7 to '' set function F8 to '' clear return * * * * procedure EditMenu deactivate window all clear @0,0 say mClass color W+/N @0,col()+5 say left(mTitle,77-col()) color GR+/N @ 1,0 to 1,79 double color N/BG @ 2,0 say 'SUBCLASS' color W+/N @ 3,0 say 'ADDED' color W+/N @ 4,0 say 'FORM' color W+/N @ 5,0 say 'MATERIAL' color W+/N @ 2,0 fill to 7,9 color W+/N @ 2,10 fill to 7,79 color N/N @ 12,0 to 14,66 double color RB/W @ 13,5 say 'F2 ABANDON any changes made above' @ 13,1 fill to 13,65 color B/W @ 15,0 to 17,66 double color RB/W @ 16,5 say 'F7 DELETE this data record' @ 16,1 fill to 16,65 color B/W @ 18,0 to 24,66 double color RB/W @ 19,21 say 'SAVE ANY CHANGES MADE ABOVE AND: ' @ 20,5 say 'F8 SELECT SUBCLASS' @ 21,5 say 'F10 FINISH' @ 22,5 say 'PAGE-UP '+chr(24) @ 23,5 say 'PAGE-DOWN '+chr(25) @ 19,1 fill to 23,65 color B/W return * * * * procedure Errchkdata ErrorFnd=.F. @0,0 clear to 5,79 @0,0 say mClass color W+/B @0,col()+2 say left(mTitle,77-col()) color W+/B @ 1,10 say '<< F9 to Exit (without Saving) >> << F10 to Save >>' color R/N @ 2,0 say 'SUBCLASS' color W+/B @ 2,40 say 'ADDED' color W+/B @ 2,60 say 'FORM' color W+/B @ 3,0 say 'MATERIAL' color W+/B @ 3,11 say mMaterial[1] color W+/B @ 4,11 say mMaterial[2] color W+/B @ 5,11 say mMaterial[3] color W+/B tsub=rtrim(ltrim(mSubClass)) if len(tsub)<2 ErrorFnd=.T. @ 2,10 get mSubClass color R/N else @2,11 say mSubClass endif if CurrAdded={ / / } .or. CurrAdded>mdate .or. CurrAddedprevform ErrorFnd=.T. @2,67 get mForm picture '!' color R/N else @2,68 say mForm picture '!' endif if ErrorFnd do MessageWindow with 'Check for Possible Errors' read endif return * * * * procedure Errchkedit ErrorFnd=.F. tsub=rtrim(ltrim(mSubClass)) if len(tsub)<2 ErrorFnd=.T. @ 2,10 get mSubClass color R/N endif if mAdded={ / / } .or. mAdded>mdate+10 .or. mAdded99999 RNumb=Int(Rand(-1)*100000) enddo SrchPointer=((mHeadNumb*100000)+RNumb)*10 x=0 cnt=0 do while x<3 && make 3 tries for MATLINENO 1, or 2 or 3 x=x+1 if seek(SrchPointer+x,MaterialFile) loop && loops until unused one found else cnt=cnt+1 endif enddo if cnt=3 OK=.T. && no use of SrchNumb in Material file index found endif enddo return * * * * procedure ReplaceRec RNumb=0 if mSubClass<>SUBCLASS replace SUBCLASS with mSubClass endif if mAdded<>ADDED .or. ADDED={ / / } .or. mAdded={ / / } replace ADDED with mAdded endif if mForm<>FORM replace FORM with mForm endif if MatChanges select (MaterialFile) x=0 do while x<3 x=x+1 if prevMat[x]<>mMaterial[x] lenMat=len(ltrim(mMaterial[x])) if recordmat[x]<1 && no prev. material data if lenMat>0 if mDataPoint<1 && create new pointer from data rec. to material do MakeRandNo with mHeadNumb,SrchPointer,RNumb mDataPoint=RNumb endif append blank replace MATHEADNO with mHeadNumb,MATDATANO with mDataPoint,; MATERIAL with mMaterial[x],MATLINENO with x replace GOVIN->DATAPOINT with mDataPoint endif else && material data record exists if lenMat>0 goto recordmat[x] replace MATHEADNO with mHeadNumb,MATDATANO with mDataPoint,; MATERIAL with mMaterial[x] else && editing has deleted material line goto recordmat[x] replace MATHEADNO with 0,MATDATANO with 0,MATERIAL with ' ',; MATLINENO with 0 seek (SrchPointer) && if none left replace DATAPOINT in data if MATHEADNO<>mHeadNumb .or. MATDATANO<>mDataPoint replace GOVIN->DATAPOINT with 0 endif endif endif endif enddo select (DataFile) endif && MatChanges =.T. return * * * * procedure SeekLast if seek(mHeadNumb) &&data found to scan seek(mHeadNumb+1) && last instance if mHeadNumb<>DATANUMB .and. .not. bof() skip -1 endif endif return * * * * * procedure SaveChanges && saves editing changes set exact on somechanges=.F. MatChanges=.F. do case case mSubClass<>SUBCLASS somechanges=.T. case mAdded<>ADDED somechanges=.T. case mForm<>FORM somechanges=.T. endcase x=0 do while x<3 .and. .not. MatChanges x=x+1 if prevMat[x]<>mMaterial[x] MatChanges=.T. endif enddo set exact off if SomeChanges .or. MatChanges do errchkedit && may change value of Lkey if Lkey<>-1 .and. Lkey<>-6 && i.e. not F2=cancel or F7=delete do ReplaceRec endif endif && Somechanges made in edit return * * * * procedure NextLimit do Case Case Lkey=18 && Page Up (for later data) skip if .not. eof() scan for SubClassSrch $ upper(SUBCLASS) while mheadNumb=DATANUMB exit && stop at first hit endscan if .not.(mHeadNumb=DATANUMB .and. SubClassSrch $ upper(SUBCLASS)) do MessageWindow with 'On PageUp, No SUBCLASS with '+SubClassSrch goto Prevrec else Prevrec=recno() endif else do MessageWindow with 'On PageUp, No SUBCLASS with '+SubClassSrch goto Prevrec endif && not eof() Case Lkey=3 && Page Down (for earlier data) skip -1 if .not. bof() do while mHeadNumb=DATANUMB .and.; .not.( SubClassSrch $ upper(SUBCLASS)) .and. .not. bof() skip -1 enddo if .not.(mHeadNumb=DATANUMB .and. SubClassSrch $ upper(SUBCLASS)) do MessageWindow with 'On PageDown, No SUBCLASS with '+SubClassSrch goto Prevrec else Prevrec=recno() endif else do MessageWindow with 'On PageDown, No SUBCLASS with '+SubClassSrch goto Prevrec endif && not bof() EndCase return * * procedure selectEdit activate window Wmsg clear @ 0,1 say 'What to seek in SUBCLASS field? << BLANK for NO seek>>' @ 1,5 get SubClassSrch picture '@!' color GR+/N read deactivate window Wmsg SubClassSrch=IIF(lastkey()=-8,'',rtrim(ltrim(SubClassSrch))) if len(SubClassSrch)>0 LimitEdit=.T. @ 9,1 say ' will ONLY display for :' @10,21 say 'SUBCLASS containing '+SubClassSrch color GR+/N else LimitEdit=.F. @ 9,1 @ 10,1 endif return * * Procedure DeleteInData entryKey=Lkey activate Window Wmsg clear respon='Y' @0,6 say 'CONFIRM DELETE (Y/N)' get respon picture 'Y' color R/N read if respon='Y' CurrRec=recno() skip if eof() .or. mHeadNumb<>DATANUMB skip -2 endif NextRec=recno() goto CurrRec clear ? ? '************************' ? mdy(mdate),' ',time() ? mClass ? mTitle ? '-- DELETING DATA --' ? Subclass,ADDED,FORM if DATAPOINT>0 mDataPoint=DATAPOINT SrchPointer=((mHeadNumb*100000)+mDataPoint)*10 select (MaterialFile) seek(SrchPointer) scan rest while MATHEADNO=mHeadNumb .and. MATDATANO=mDataPoint if MATLINENO>0 .and. MATLINENO<=3 ? ' ',MATERIAL endif replace MATHEADNO with 0,MATDATANO with 0,MATERIAL with ' ',; MATLINENO with 0 endscan select (DataFile) endif replace ADDED with { / / },FORM with ' ',; SUBCLASS with ' ',DATANUMB with 0,DATAPOINT with 0 goto Nextrec if mHeadNumb=DATANUMB ContEdit=.T. else if seek(mHeadNumb) && try to find another data rec. to edit ContEdit=.T. else ContEdit=.F. endif endif if ContEdit Lkey=IIF(EntryKey=-7 .or. EntryKey=-8,EntryKey,-1) endif clear deactivate window Wmsg else clear deactivate window Wmsg endif &&(confirm delete) return * * * * *************************************************************************** * Government Reporting procedure GovRpt pass=.F. do PassProcedure with 'REPORT ADMINSTRATION (DOCUMENTS)' if pass do alterfile with 'REPORT.GOV' &&(report file saved to REPORT.GOV) set alternate off rptloop=.T. do while rptloop do MenuBox with 'REPORT/ADMINISTRATION (DOCUMENTS)' respon='9' @ 7,5 say '1 Copy Database (within date range)' @14,5 say '8 Database Maintenance' @15,5 say '9 Exit' @16,4 get respon picture '9' color GR+/N set color to W+/N do readMenu with respon,'189' Select (DataFile) do case case respon='1' do Outputdb case respon='8' do Maintaindb case respon='9' rptloop=.F. Select (HeaderFile) endcase enddo && rptloop endif && pass close alternate return * * * * * procedure maintainDB mloop=.T. do while mloop do MenuBox with 'DATABASE MAINTENANCE (DOCUMENTS)' respon='9' @7,8 say '1 Copy Database (within date range)' @8,8 say '2 Error Check Database' @9,8 say '3 Refresh Indexes' @10,8 say '4 Physically sort Database' @11,8 say '5 Copy NOTES to a Database' @12,8 say '6 Run all of above (unattended)' @15,8 say '9 Exit' @18,15 say ' Procedures 1-5 should be run once each month ' color R/N @19,15 say ' ****** IMPORTANT to back-up disk first ******' color R/N @16,7 get respon picture '9' color GR+/N set color to W+/B do readMenu with respon,'1234569' do case case respon='1' do outputdb case respon='2' unattended=.F. do ErrchkDb case respon='3' Select (DataFile) reindex Select (HeaderFile) reindex case respon='4' do SortDbfs case respon='5' do CopyNotes case respon='6' unattended=.T. do outputdb do ErrchkDb do SortDbfs do CopyNotes Select (HeaderFile) unattended=.F. case respon='9' mloop=.F. endcase enddo &&(mloop) return * * * * procedure outputdb select(HeaderFile) set order to XHEADNUMB set safety off clear set exact off CurrBegDate=mdate CurrEndDate=mdate Sortchoice='C' @ 2,2 to 4,70 double color N/BG @ 3,4 say 'Enter starting date of receival period 'get CurrBegDate ; color GR+/N @6,2 to 8,70 double color N/BG @ 7,4 say 'Enter ending date 'get CurrEndDate ; color GR+/N @10,2 to 12,70 double color N/BG @11,4 say 'Arrange by:(A) Agency (C) Class (I) Item No. (T) Title' ; get Sortchoice picture '!'; valid Sortchoice$'ACIT' error 'Enter A, C, I or T ' color GR+/N ContOutput=.T. do readMenu with SortChoice,'ACIT' && returns '9' if none or ACI or T if (CurrEndDate0 .and. DATANUMB<50000 mnumb=DATANUMB if seek(mnumb,HeaderFile) msort=upper(left(GOVHEAD->&mfield.,24)) select 7 append blank replace SORTFIELD with msort,POINTER with mnumb endif select (DataFile) endscan select (dataFile) set order to XDATANUMB select 7 set unique on index on SORTFIELD+str(POINTER,5) to tmpNDX set unique off scan && i.e. temp file in work area 7 mnumb=POINTER if seek(mnumb,HeaderFile) if seek(mnumb,DataFile) &&(data found) currCLASS =GOVHEAD->CLASS currAGENCY=GOVHEAD->AGENCY currTITLE =GOVHEAD->TITLE currITEM =GOVHEAD->ITEM select (DataFile) ToPrintHeader=.T. scan while DATANUMB=mnumb ; for ADDED>=CurrBegDate .and. ADDED<=CurrEndDate if ToPrintHeader ToPrintHeader=.F. ? ? currCLASS,' Item No. : ',currITEM ? currAGENCY ? currTITLE set memowidth to 60 x=1 do while x<=MemLines(GOVHEAD->NOTES) ? rtrim(mline(GOVHEAD->NOTES,x)) x=x+1 enddo set memowidth to 240 && back to default endif ? ' ',SUBCLASS,' ',ADDED,' ',FORM if DATAPOINT>0 mPoint=DATAPOINT do PrintMaterial with mnumb,mPoint endif select (DataFile) endscan endif &&(data found) endif &&(header found) select 7 endscan select 7 use if file(TempPath+'TmpNDX.dbf') erase (TempPath+'TmpNDX.dbf') endif if file(TempPath+'TmpNDX.NDX') erase (TempPath+'TmpNDX.NDX') endif endif && if ContOutPut = .T. set alternate off set exact off select (HeaderFile) set safety on return * * * * procedure SortDbfs set safety off @1,0 clear if file(TempPath+'GOVMnSrt.dbf') erase (TempPath+'GOVMnSrt.dbf') endif if file(TempPath+'GOVMnSrt.dbt') erase (TempPath+'GOVMnSrt.dbt') endif ********************** Sorting GOVHEAD header file Select (HeaderFile) @1,0 say 'SORTING HEADER RECORDS BY CLASS' sort to (TempPath+'GOVmnSrt') on CLASSSORT /C for HEADNUMB>0 if file(TempPath+'GOVmnsrt.dbf') select (HeaderFile) use select 8 use TempPath+'GovmnSrt' copy to (DataPath+'GOVHEAD') use if file(DataPath+'GOVHEAD.DBF') erase (TempPath+'GOVmnsrt.dbf') if file(DataPath+'Govhead.dbt') erase (TempPath+'GovmnSrt.dbt') endif endif if file(DataPath+'GOVhead.mdx') erase (DataPath+'Govhead.mdx') endif Select (HeaderFile) use DataPath+'GOVhead' @2,0 say 'INDEXING HEADER RECORDS' index on UPPER(LEFT(TITLE,20)) TAG XTITLE index on UPPER(CLASSSORT) TAG XCLASSSORT index on UPPER(ITEM) TAG XITEM index on UPPER(LEFT(AGENCY,20)) TAG XAGENCY index on HEADNUMB TAG XHEADNUMB set order to XHEADNUMB else @2,0 say 'SORT FAILED' color R/N endif &&(sort file ok) * ************************* sorting GOVIN data Select (DataFile) if file(TempPath+'GOVinSrt.dbf') erase (TempPath+'GOVinSrt.dbf') endif @3,0 say 'SORTING SUBCLASS DATA BY DATE ADDED' sort to (TempPath+'GOVinSrt') on ADDED for DATANUMB>0 if file(TempPath+'GOVinSrt.dbf') Select (DataFile) use select 8 use TempPath+'GOVinSrt' copy to (DataPath+'GOVIN.dbf') use if file(DataPath+'GOVIN.dbf') erase (TempPath+'GOVinSrt.dbf') endif erase (DataPath+'GOVIN.mdx') Select (DataFile) use DataPath+'GOVIN' @4,0 say 'INDEXING SUBCLASS DATA' index on UPPER(SUBCLASS) TAG XSUBCLASS index on DATANUMB TAG XDATANUMB index on ADDED TAG XADDED set order to XDATANUMB else @4,0 say 'SORT FAILED' color R/N endif &&(sort file ok) * ************************* sorting GOVMAT material data Select (MaterialFile) if file(TempPath+'GOVMatSt.dbf') erase (TempPath+'GOVMatSt.dbf') endif @5,0 say 'ERASING DELETED MATERIAL DATA' copy to (TempPath+'GovMatSt') for MATDATANO>0 .and. MATLINENO>0 .and. ; MATLINENO<=3 if file(TempPath+'GovMatSt.dbf') Select (MaterialFile) use select 8 use TempPath+'GovMatSt' copy to (DataPath+'GOVMAT.dbf') use if file(DataPath+'GOVMAT.dbf') erase (TempPath+'GovMatSt.dbf') endif erase (DataPath+'GOVMAT.mdx') Select (MaterialFile) use DataPath+'GOVMAT' @6,0 say 'INDEXING MATERIAL DATA' index on ((MATHEADNO*100000)+MATDATANO)*10 TAG XSRCHNUMB index on upper(left(MATERIAL,20)) TAG XMATERIAL set order to XSRCHNUMB else @6,0 say 'ERASING FAILED' color R/N endif &&(sort file ok) set safety on return * * * * procedure copyNotes && copies headnumb and notes field out of Govhead into && GovMemo.dbf, GovMemo.dbf is created by this procedure, && structure of GovMemo.dbf is HD N 5, NT C 240 && area 7 used for GovHdNt && area 8 used for exthead.dbf to create *nt dbf set memowidth to 240 set safety off select (HeaderFile) copy to (DataPath+'exthead') structure extended select 7 use && make sure scratch area 7 is clear select 8 use DataPath+'exthead' zap append blank replace FIELD_NAME with 'HEADERNO' 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 'NOTATION' replace FIELD_TYPE with 'C' replace FIELD_LEN with 240 replace FIELD_DEC with 0 replace FIELD_IDX with 'N' if file(DataPath+'GOVHdNt.dbf') if file(DataPath+'GOVHdNt.bak') erase (DataPath+'GOVHdNt.bak') endif rename (DataPath+'GOVHdNt.dbf') to DataPath+'GOVHdNt.bak' endif select 8 use && closes 'exthead' must close to CREATE from select 7 create (DataPath+'GovHdNt') from (DataPath+'exthead') select (HeaderFile) set order to goto top scan for HEADNUMB>0 .and. len(NOTES)>0 Mnt=mline(NOTES,1) Mhd=HEADNUMB select 7 append blank replace HEADERNO with MHd replace NOTATION with Mnt select (HeaderFile) endscan select 7 use select 8 use select (DataFile) set order to xdatanumb select (HeaderFile) set order to xheadnumb set safety on return * * * procedure ErrChkDb set alternate on clear ? '********************' ? 'Error reporting DOCUMENTS CHECK-IN DATA' Select (HeaderFile) set order to XHEADNUMB set exact on seek 50000 skip-1 LastHeadNumb=HEADNUMB set exact off Select (DataFile) ? ErrorCntr=0 scan for DATANUMB>0 ErrorCond=.F. do case case .not. (FORM $'FP') ErrorCond=.T. ? 'Error: FORM field not F or P' case DATANUMB>=50000 .and. DATANUMB<100000 ErrorCond=.T. newdatanumb=datanumb-50000 ? 'Error: Unattached data' ? ' Data has now been attached to CLASS record "~~Error~~" ' set exact on if seek(newdatanumb,HeaderFile) ? ' Data line was connected only to a cross reference title' ? ' X Ref = ' ?? upper(GOVHEAD->TITLE) endif ErrorCond=.T. replace DATANUMB with -1 case datanumb>LastHeadNumb ErrorCond=.T. ? 'Error: ' endcase if ErrorCond set exact on ErrorCntr=ErrorCntr+1 mnumb=DATANUMB if seek(mnumb,HeaderFile) .and. mnumb>0 ? GOVHEAD->CLASS,'(SubClass)',SUBCLASS,'(Item)',GOVHEAD->ITEM ? ' ',GOVHEAD->Agency ? ' ',GOVHEAD->Title ? ADDED,FORM mPoint=DATAPOINT do PrintMaterial with mnumb,mPoint else ? 'SEARCH FOR THIS DATA AT THE END OF THE CLASS LIST' ? ADDED,FORM do PrintMaterial with mnumb,mPoint if .not. seek(49999,1) && cannot find error record in header file Select (HeaderFile) append blank replace HEADNUMB with 49999 replace CLASS with '~~Error~~',AGENCY with '~~Error~~' replace TITLE with '~~Error~~',ITEM with '~~Error~~' select (DataFile) 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 .not. unattended do waitmsg else clear if ErrorCntr>1 @0,0 say 'Error listing in '+TextPath+'REPORT.GOV' endif endif set alternate off return * ************************END OF PROGRAM************************* * *EXPLANATION & DATABASE STRUCTURE * *The program requires dBase IV to operate. * *It is assumed that dBase IV is contained in a C:\DBASE directory, *that *.prg and *.dbo program files are in a C:\DBASE\ACQ directory *and that *.dbf *.dbt and *.mdx data and index files are also in a *C:\DBASE\ACQ directory. * *The DBASE directory should be listed in the PATH command (normally part *of the AUTOEXEC.BAT file). The process to call the program would then *be: * C: {change to C: drive if not there already} * CD \DBASE\ACQ {change to directory containing programs} * DBASE /t GOVMAIN {call dBase & pass it GOVMAIN as main program name} * { the /t suppresses the dBase copyright screen} * * *dBase as part of its operation will compile the program source *code (the .PRG files) and will create .DBO files with the same *name, e.g. the executable version of NEWMAIN.PRG will be NEWMAIN.DBO. * * * There are three types of files in the group of files that contain *data. They are: * DATA files with file names ending in .DBF * NOTES files with file names ending in .DBT * INDEX files with file names ending in .MDX * * * Specific Government Documents Files Are: * * GOVHEAD.DBF (database of Govt. Docs. header information) * GOVHEAD.DBT (notes data, if used, for each Govt. Doc. class) * GOVHEAD.MDX (indexing for above data) * * GOVIN.DBF (database of Govt. Docs. check-in data) * GOVIN.MDX (indexing for check-in data) * * GOVMAT.DBF (Material description, if used, for check-in data) * GOVMAT.MDX (indexing for material descriptions) * * * * The .MDX files can be reconstituted by the program from data *contained in the .DBF and .DBT files. If the latter two types of data *files are lost, the data will be lost, a reliable procedure for *backing up the data is vital. * * *The source code, i.e. the .PRG files, may be freely modified. To do *this use either any text editor (a word processor in ASCII mode), or use *the built-in text editor in dBase. If using the latter option, and *assuming the directory and path structure is as above, change directory to *C:\DBASE\ACQ and call the dBase program with the command DBASE, at *the dBase dot prompt, enter MODIFY COMMAND GOVMAIN. To exit from *the dBase editor and save any modifications press Ctrl-End. To exit *from dBase enter QUIT. * *The GOVMAIN.PRG file contains an area at the beginning of the program *which can usefully be modified. This part of the program may contain *such information as the library name, and various paths for the program *to locate data and program files. * * *Most parts of the program rely heavily on the system clock being set to the *correct date. If the computer used to run the program does not have a *built-in clock, and the date is not set correctly, then when the Main Menu *is first accessed, the option to Modify Date should be chosen to correct *the date. This procedure will not affect the system clock, the new date *will only be active until the acquisitions program session is terminated. * * *At any Menu Choices that require single character responses, typically *numbers 1 through 9, there will be a default option shown, that default *may be selected by the ENTER key or by the F10 key. Pressing a character *that is shown on the menu as an acceptable response will be immediately *accepted, the ENTER key should not be pressed in addition. The F9 key *typically works as a command to back out of a menu screen. * * *Periodically the databases should be sorted and reindexed, this reduces *the size of the index files, increases efficiency and arranges the data *in correct title order. Reindexing is an option in the database maintenance *part of the menu structure. Always backup the data prior to reindexing. *Reindexing may clear up problems such as the program freezing in the middle *of operations. Should there ever be a loss of the indexing files, to *reindex, run the program and ignore any error messages, continue through *to the database maintenance part of the program and reindex. * * The Password to enter the reporting program is 1,0,F10 (i.e. the number 10 * followed by the F10 key). * ******************************************************* *DATABASE STRUCTURE * *Structure for database: C:\DBASE\ACQ\GOVHEAD.DBF *Field Field Name Type Width * 1 HEADNUMB Numeric 5 * 2 CLASS Character 15 * 3 CLASSSORT Character 24 * 4 ITEM Character 10 * 5 TITLE Character 70 * 6 AGENCY Character 70 * 7 DATATYPE Character 1 * 8 NOTES Memo 10 * * *Structure for database: C:\DBASE\ACQ\GOVIN.DBF *Field Field Name Type Width * 1 DATANUMB Numeric 5 * 2 SUBCLASS Character 20 * 3 ADDED Date 8 * 4 FORM Character 1 * 5 DATAPOINT Numeric 5 * *Structure for database: C:\DBASE\ACQ\GOVMAT.DBF *Field Field Name Type Width * 1 MATHEADNO Numeric 5 * 2 MATDATANO Numeric 5 * 3 MATLINENO Numeric 1 * 4 MATERIAL Character 60 * ********************************** *INDEX STRUCTURE *Select area: 1, Database in Use: C:\DBASE\ACQ\GOVHEAD.DBF Alias: GOVHEAD *Production MDX file: C:\DBASE\ACQ\GOVHEAD.MDX * Index TAG: XTITLE Key: UPPER(LEFT(TITLE,20)) * Index TAG: XCLASSSORT Key: UPPER(CLASSSORT) * Index TAG: XITEM Key: UPPER(ITEM) * Index TAG: XAGENCY Key: UPPER(LEFT(AGENCY,20)) * Index TAG: XHEADNUMB Key: HEADNUMB * Memo file: C:\DBASE\ACQ\GOVHEAD.DBT * *Select area: 2, Database in Use: C:\DBASE\ACQ\GOVIN.DBF Alias: GOVIN *Production MDX file: C:\DBASE\ACQ\GOVIN.MDX * Index TAG: XSUBCLASS Key: UPPER(SUBCLASS) * Index TAG: XDATANUMB Key: DATANUMB * Index TAG: XADDED Key: ADDED * *Select area: 3, Database in Use: C:\DBASE\ACQ\GOVMAT.DBF Alias: GOVMAT *Production MDX file: C:\DBASE\ACQ\GOVMAT.MDX * Index TAG: XSRCHNUMB Key: ((MATHEADNO*100000)+MATDATANO)*10 * Index TAG: XMATERIAL Key: upper(left(MATERIAL,20))