Shareware Overload/ShartewareOverload.cdr/database/dprog131.zip/PROGFORM.TXT

Text File | 1988-08-07 | 45KB | 1,915 lines

*%%OPENFROM,SYSNAME
*%%IF,PRG
*%%DOCUMENT,PRG,Main Program
SET ESCAPE OFF
SET STATUS OFF
SET TALK OFF
SET ECHO OFF
SET BELL OFF
SET HEADING OFF
SET SAFETY OFF
SET DEVICE TO SCREEN
CLEAR
*%%SETPROC
PUBLIC DBVersion, UserScrn
*%%DBVERSION
*%%MMLOAD
SELECT A
USE &MainFile
DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE"
SET FILTER TO .T.
*%%IF,PUB
DO PUB
*%%ENDIF
*%%MMINIT
CLEAR GETS
MHH=MH1
P=0
DO WHILE .T.
   *%%MMSHOW
   @ 24,0
   @ 2,3 SAY DTOC(DATE())
   @ 2,69 SAY Time()
   @p+5,C GET MHH
   CLEAR GETS
   DO WHIL .T.
   o=0
   DO WHIL o<=0
   o=INKE()
   ENDD
   t=0
   @p+5,C SAY MHH
   DO CASE
   CASE o=5
   p=p-1
   CASE o=24
   p=p+1
   CASE o=13
   t=P+1
   OTHE
   t=AT(UPPE(CHR(o)),VK)
   p=IIF(t=0,p,t-1)
   ENDC
   p=IIF(p<0,NOP,p)
   p=IIF(p>NOP,0,p)
   DO CASE
   CASE P=0
   @ 5,C GET MH1
   MHH=MH1
   CASE P=1
   @ 6,C GET MH2
   MHH=MH2
   CASE P=2
   @ 7,C GET MH3
   MHH=MH3
   CASE P=3
   @ 8,C GET MH4
   MHH=MH4
   CASE P=4
   @ 9,C GET MH5
   MHH=MH5
   CASE P=5
   @ 10,C GET MH6
   MHH=MH6
   CASE P=6
   @ 11,C GET MH7
   MHH=MH7
   CASE P=7
   @ 12,C GET MH8
   MHH=MH8
   CASE P=8
   @ 13,C GET MH9
   MHH=MH9
   CASE P=9
   @ 14,C GET MH10
   MHH=MH10
   ENDC
   CLEAR GETS
   IF t>0
   MH_Function=SUBS(VK,t,1)
   EXIT
   ENDI
   ENDD
   DO CASE
      *%%IF,ADD
      CASE MH_Function="A"
         DO ADD
         LOOP
      *%%ENDIF
      *%%IF,UPD
      CASE MH_Function="U"
         IF RECCOUNT()=0
            *%%IF,PRG
            DO WAI WITH 24, 0, "File empty, request denied. "
            *%%ENDIF
            LOOP
         ENDIF
         DO UPD
         LOOP
      *%%ENDIF
      *%%IF,RPT
      CASE MH_Function="R"
         DO RPT
         GO TOP
         LOOP
      *%%ENDIF
      *%%IF,MM
      CASE MH_Function="M"
         DO MM
         GO TOP
         LOOP
      *%%ENDIF
      *%%IF,LAB
      CASE MH_Function="L"
         DO LAB
         GO TOP
         LOOP
      *%%ENDIF
      *%%IF,HLP
      CASE MH_Function="H"
         DO HLP WITH 1
         LOOP
      *%%ENDIF
      CASE MH_Function="P"
         @24,0
         @24,0 SAY "Delete all marked records"
         STORE "N" TO MH_Ans
         @24,30 GET MH_Ans
         READ
         IF UPPER(MH_Ans) = "Y"
            PACK
            GO TOP
         ENDIF
         RELEASE MH_Ans
         LOOP
      CASE MH_Function="I"
         DO IND WITH MainFile, IndxFile, IndxExpr, "REINDEX"
         LOOP
      CASE MH_Function="Q"
         RELEASE MH_Function
         *%%IF,REL
         DO REL
         *%%ENDIF
         CLOSE DATABASES
         CLOSE PROC
         CLEAR
         QUIT
      *%%IF,SRT
      CASE MH_Function="S"
         DO DPSORT
         *%%SETPROC
         USE &MainFile
         DO IND WITH MainFile, IndxFile, IndxExpr, "ENSURE"
         LOOP
      *%%ENDIF
      CASE MH_Function="D"
         RELEASE MH_Function
         *%%IF,REL
         DO REL
         *%%ENDIF
         CLOSE DATABASES
         CLOSE PROC
         CLEAR
         SET ESCAPE ON
         SET STATUS ON
         SET TALK ON
         SET BELL ON
         SET HEADING ON
         SET SAFETY ON
         RETURN
   ENDCASE
ENDDO
RETURN
*%%ENDIF

*%%IF,PRG
*%%DOCUMENT,WAI,Wait / Message routine
PROCEDURE WAI
PARA y, x, msg
PRIV dummy
dummy=" "
SET INTE OFF
@Y,X
@Y,X SAY msg+" Press any key to continue..." GET dummy
READ
SET INTE ON
@Y,X
RETU
*%%ENDIF

*%%IF,PRG
*%%DOCUMENT,BMU,Parameterized bar menu routine
PROCEDURE BMU
PARA m,s,L,R,p,C
* parameters:
* in:  m(menustr),L(len 1 opt),R(row);
* out: p (pos. in m, global for continuity), C (choice char)
PRIV g,t,o,sc
sc=" "+s
E=LEN(M)/L-1
g=SUBS(m,p*L+1,L)
@r,0 SAY m
@r,p*L GET g
CLEA GETS
t=0
c=" "
DO WHIL c=" "
o=0
DO WHIL o<=0
o=INKE()
ENDD
t=0
DO CASE
CASE o=4.OR.o=32
p=p+1
CASE o=19
p=p-1
CASE o=13
t=p+1
OTHE
t=AT(UPPE(CHR(o)),s)
p=IIF(t=0,p,t-1)
ENDC
p=IIF(p<0,E,p)
p=IIF(p>E,0,p)
C=SUBS(sc,t+1,1)
g=SUBS(m,p*L+1,L)
@r,0 SAY m
@r,p*L GET g
CLEA GETS
ENDD
RETU
*%%ENDIF

*%%IF,FMT
*%%DOCUMENT,FMT,Screen Format File
PROCEDURE FMT
*%%FMT
RETURN
*%%ENDIF

*%%IF,PUB
*%%DOCUMENT,PUB,Define Public Fields
PROCEDURE PUB
PUBLIC Clipper
*%%PUB
RETURN
*%%ENDIF

*%%IF,CAL
*%%DOCUMENT,CAL,Calculate and display Calculated fields
PROCEDURE CAL
PARAMETERS Updating
*%%CAL
RETURN
*%%ENDIF

*%%IF,INI
*%%DOCUMENT,INI,Initialize memory fields from Init or empty
PROCEDURE INI
*%%INI
RETURN
*%%ENDIF

*%%IF,STO
*%%DOCUMENT,STO,Store file fields to memory variables
PROCEDURE STO
*%%STO
RETURN
*%%ENDIF

*%%IF,REP
*%%DOCUMENT,REP,Replace file fields with memory variables
PROCEDURE REP
*%%REP
RETURN
*%%ENDIF

*%%IF,REL
*%%DOCUMENT,REL,Release Memory variables
PROCEDURE REL
*%%REL
RETURN
*%%ENDIF

*%%IF,ADD
*%%DOCUMENT,ADD,Add New records to file
PROCEDURE ADD
STORE " " TO MH_Wait
IF "DB3+" $ DBVersion
   CALL &UserScrn
ELSE
   CLEAR
   DO DB3
ENDIF
DO WHILE .T.
   *%%IF,INI
   DO INI
   *%%ENDIF
   *%%IF,FMT
   DO FMT
   *%%ENDIF
   @24,0
   @24,0 SAY "Press Ctrl-W without entering data to exit"
   READ
   *%%ADD
      *%%IF,VAL
      DO VAL
      *%%ENDIF
      @24,0
      APPEND BLANK
      *%%IF,CAL
      DO CAL WITH "ALL"
      *%%ENDIF
      *%%IF,REP
      DO REP
      *%%ENDIF
      *%%IF,PRG
      DO WAI WITH 24,0,""
      *%%ENDIF
   ELSE
     EXIT
   ENDIF
ENDDO
RELEASE MH_Wait
RETURN
*%%ENDIF

*%%IF,UPD
*%%DOCUMENT,UPD,Search,Update,Edit,Find,Print,Examine file
PROCEDURE UPD
PRIVATE MH_Function, MH_Answer
STORE "N" TO MH_Function
STORE "N" TO MH_Answer
STORE SPACE(65) TO MH_Filt
IF "DB3+" $ DBVersion
   CALL &UserScrn
ELSE
   CLEAR
   DO DB3
ENDIF
DO WHILE .T.
   *%%IF,STO
   DO STO
   *%%ENDIF
   *%%IF,DIS
   DO DIS
   *%%ENDIF
   *%%IF,CAL
   DO CAL WITH "VIRTUAL"
   *%%ENDIF
   IF LEN(TRIM(MH_Filt)) = 0
      @24,55 SAY "    "
   ELSE
      @24,55 SAY "FILT"
   ENDIF
   IF Deleted()
      @24,60 SAY "DEL"
   ELSE
      @24,60 SAY "   "
   ENDIF
   @24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+"     "
   MH_Lcho=0
   DO BMU WITH "Next Prev Top  Bot  Quit Edit Set  List Find Help Del  ","NPTBQESLFHD",5,24,MH_Lcho,MH_Function
   @24,0 SAY SPACE(55)
   DO CASE
      CASE UPPER(MH_Function) = "N"
      IF .NOT. EOF()
          Skip 1
          IF EOF()
             GO BOTT
          ENDIF
      ENDIF
      LOOP
      CASE UPPER(MH_Function) = "P"
      IF .NOT. BOF()
         SKIP -1
         IF BOF()
            GO TOP
         ENDIF
      ENDIF
      LOOP
      CASE UPPER(MH_Function) = "E"
         *%%IF,STO
         DO STO
         *%%ENDIF
         *%%IF,FMT
         DO FMT
         *%%ENDIF
         READ
         *%%IF,VAL
         DO VAL
         *%%ENDIF
         *%%IF,CAL
         DO CAL WITH "ALL"
         *%%ENDIF
         *%%IF,REP
         DO REP
         *%%ENDIF
         LOOP
      CASE UPPER(MH_Function) = "T"
        GOTO TOP
        LOOP
      CASE UPPER(MH_Function) = "B"
        GOTO BOTTOM
        LOOP
      CASE UPPER(MH_Function) = "D"
         STORE "N" TO MH_Answer
         @24,0
         IF DELETED()
            @24,0 SAY "Recall this record?"
         ELSE
            @24,0 SAY "Delete this record?"
         ENDIF
         @24,22 GET MH_Answer
         READ
         IF UPPER(MH_Answer) = "Y"
            IF DELETED()
               RECALL
            ELSE
               DELETE
            ENDIF
         ENDIF
         LOOP
      CASE UPPER(MH_Function) = "S"
         STORE "N" TO MH_Answer
         STORE MH_Filt TO MH_FiltH
         @24,0
         @24,0 SAY "FILTER: "
         @24,9 GET MH_Filt
         READ
         @24,0
         IF MH_Filt <> MH_FiltH
            IF LEN(TRIM(MH_Filt))<>0
               IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L")
                  *%%IF,PRG
                  DO Wai WITH 24,0,"Filter expression defective, not usable. "
                  *%%ENDIF
                  MH_Filt=MH_FiltH
                  LOOP
               ENDIF
               SET FILTER TO &MH_Filt
            ELSE
               SET FILTER TO .T.
            ENDIF
            GOTO TOP
            IF EOF()
               *%%IF,PRG
               DO WAI WITH 24,0, "Nothing matches filter! "
               *%%ENDIF
            ENDIF
         ENDIF
         LOOP
      *%%IF,FND
      CASE UPPER(MH_Function) = "F"
        DO FND
        LOOP
      *%%ENDIF
      CASE UPPER(MH_Function) = "Q"
        EXIT
      CASE UPPER(MH_Function) = "L"
        *%%IF,3PLUS
        ON ERROR DO WAI WITH 24,0,"FIX PRINTER!!! "
        *%%ENDIF
        SET DEVICE TO PRINT
        *%%IF,DIS
        DO DIS
        *%%ENDIF
        SET DEVICE TO SCREEN
        *%%IF,3PLUS
        ON ERROR
        *%%ENDIF
        LOOP
      *%%IF,HLP
      CASE UPPER(MH_Function)="H"
        DO HLP WITH 2
        IF "DB3+" $ DBVersion
           CALL &UserScrn
        ELSE
           CLEAR
           DO DB3
        ENDIF
        LOOP
      *%%ENDIF
   ENDCASE
ENDDO
SET FILTER TO .T.
RETURN
*%%ENDIF

*%%IF,DIS
*%%DOCUMENT,DIS,Display-only Format file
PROCEDURE DIS
*%%DIS
RETURN
*%%ENDIF

*%%IF,FND
*%%DOCUMENT,FND,Find record by key routine
PROCEDURE FND
IF .NOT. Indexed
   *%%IF,PRG
   DO WAI WITH 24, 0, "Database is not indexed. Set a filter. "
   *%%ENDIF
   RETURN
ENDIF
PRIVATE MH_Find, MH_Answer, MH_Rec
@24,0
@24,0 SAY "Enter data to find in open fields"
*%%FND
IF LEN(TRIM(MH_Find)) # 0
   STORE RECNO() TO MH_Rec
   SEEK MH_Find
   IF EOF()
      GOTO MH_Rec
      *%%IF,PRG
      DO WAI WITH 24, 0, "Record Not Found. "
      *%%ENDIF
   ENDIF
ENDIF
@24,0
RETURN
*%%ENDIF

*%%IF,RPT
*%%DOCUMENT,RPT,Report module
PROCEDURE RPT
STORE .N. TO MH_Prt
STORE .Y. TO MH_Con
STORE .N. TO MH_Disk
STORE "        " TO MH_Frm
STORE ".T."+SPACE(73) TO MH_Cri
STORE "             " TO MH_DFname
IF "DB3+"$DBVersion
   *%%IF,3PLUS
   CALL DPOUT
   *%%ENDIF
ELSE
   CLEAR
   DO DPO
ENDIF
@5,22 SAY MH_Prt
@6,22 SAY MH_Con
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
DO WHILE .T.
   @5,22 GET MH_Prt PICTURE "L"
   @6,22 GET MH_Con PICTURE "L"
   @7,22 GET MH_Disk PICTURE "L"
   @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!"
   @9,15 GET MH_Frm PICTURE "!!!!!!!!"
   READ
   @24,0
   IF MH_Prt .AND. MH_Con
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Prt .AND. MH_Disk
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Con .AND. MH_Disk
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Disk .AND. MH_Dfname = "          "
      @24,0 SAY "You must specify a disk file name"
      LOOP
   ENDIF
   IF MH_Frm = "        "
      @24,0 SAY "You must enter a sort name or 'NOSORT'"
      LOOP
   ENDIF
   EXIT
ENDDO
IF MH_Frm = "NOSORT  "
   STORE .F. TO MH_NdxL
   ELSE
   IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
      *%%IF,PRG
      DO WAI WITH 24,0,"DPSORT files not found. "
      *%%ENDIF
      RETURN
   ENDIF
   SELE I
   USE DPSORT INDEX DPSORT
   SEEK MH_Frm
   IF EOF()
      *%%IF,PRG
      DO Wai WITH 24,0, "Sort name not on selection file (DPSORT.DBF). "
      *%%ENDIF
      SELE A
      RETURN
   ENDIF
   STORE SORTCRI TO MH_Cri
   STORE SORTNDX TO MH_NDX
   STORE SORTFRM TO MH_FRM
   STORE .F. TO MH_NdxL
   MH_Srt="*"
   SortOk=.F.
   DO SortChk WITH MH_Srt, MH_NdxL, SortOk
   IF .NOT. SortOk
      *%%IF,PRG
      DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
      *%%ENDIF
      RETURN
   ENDIF
ENDIF
@16,13 GET MH_Frm
@19,2  GET MH_Cri
READ
DO WHILE LEN(TRIM(MH_Frm)) = 0
   @24,0 SAY "You must specify a form for REPORTs and LABELS"
   @16,13 GET MH_Frm
   READ
ENDDO
@24,0
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
   @24,0 SAY "Criteria NOT a legal expression"
   @19,2 GET MH_Cri
   READ
ENDDO
@24,0
STORE TRIM(MH_Frm)+".FRM" TO MH_work
IF .NOT. FILE(MH_Work)
   *%%IF,PRG
   DO WAI WITH 24,0,"REPORT FORM "+TRIM(MH_Frm)+" not found. "
   *%%ENDIF
   RETURN
ENDIF
IF MH_NdxL
   @24,0
   @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
   IF MH_Cri=SPACE(76)
   STORE ".T."+SPACE(73) TO MH_Cri
   ENDIF
   IF RECCOUNT()>1
   SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
   ELSE
   COPY TO &MH_NDX FOR &MH_Cri
   ENDIF
   SELE J
   USE &MH_NDX
ELSE
    @24,0
    @24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
DO CASE
   CASE MH_Con
       REPORT FORM &MH_Frm FOR &MH_Cri
   CASE MH_Prt
        SET CONSOLE OFF
        REPORT FORM &MH_Frm TO PRINT FOR &MH_Cri
        SET CONSOLE ON
   CASE MH_Disk
      SET CONSOLE OFF
      SET ALTERNATE TO &MH_Dfname
      SET ALTERNATE ON
      REPORT FORM &MH_Frm FOR &MH_Cri
      SET ALTERNATE OFF
      CLOSE ALTERNATE
      SET CONSOLE ON
ENDCASE
IF MH_NdxL
   USE
ENDIF
SELE A
RETURN
*%%ENDIF

*%%IF,LAB
*%%DOCUMENT,LAB,Label Module
PROCEDURE LAB
STORE .N. TO MH_Prt
STORE .Y. TO MH_Con
STORE .N. TO MH_Disk
STORE "        " TO MH_Frm
STORE ".T."+SPACE(73) TO MH_Cri
STORE "             " TO MH_DFname
IF "DB3+"$DBVersion
   *%%IF,3PLUS
   CALL DPOUT
   *%%ENDIF
ELSE
   CLEAR
   DO DPO
ENDIF
@5,22 SAY MH_Prt
@6,22 SAY MH_Con
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
DO WHILE .T.
   @5,22 GET MH_Prt PICTURE "L"
   @6,22 GET MH_Con PICTURE "L"
   @7,22 GET MH_Disk PICTURE "L"
   @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!!!!!"
   @9,15 GET MH_Frm PICTURE "!!!!!!!!"
   READ
   @24,0
   IF MH_Prt .AND. MH_Con
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Prt .AND. MH_Disk
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Con .AND. MH_Disk
      @24,0 SAY "You must only specify one output device"
      LOOP
   ENDIF
   IF MH_Disk .AND. MH_Dfname = "          "
      @24,0 SAY "You must specify a disk file name"
      LOOP
   ENDIF
   IF MH_Frm = "        "
      @24,0 SAY "You must enter a sort name or 'NOSORT'"
      LOOP
   ENDIF
   EXIT
ENDDO
IF MH_Frm = "NOSORT  "
   STORE .F. TO MH_NdxL
ELSE
   IF .NOT.(FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
      *%%IF,PRG
      DO WAI WITH 24,0,"DPSORT files not found. "
      *%%ENDIF
      RETURN
   ENDIF
   SELE I
   USE DPSORT INDEX DPSORT
   SEEK MH_Frm
   IF EOF()
      *%%IF,PRG
      DO Wai WITH 24,0,"Sort name not on selection file (DPSORT.DBF). "
      *%%ENDIF
      SELE A
      RETURN
   ENDIF
   STORE SORTCRI TO MH_Cri
   STORE SORTNDX TO MH_NDX
   STORE SORTFRM TO MH_FRM
   STORE .F. TO MH_NdxL
   MH_Srt="*"
   SortOk=.F.
   DO SortChk WITH MH_Srt, MH_NdxL, SortOk
   IF .NOT. SortOk
      *%%IF,PRG
      DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
      *%%ENDIF
      RETURN
   ENDIF
ENDIF
@16,13 GET MH_Frm
@19,2  GET MH_Cri
READ
DO WHILE LEN(TRIM(MH_Frm)) = 0
   @24,0 SAY "You must specify a form for REPORTs and LABELS"
   @16,13 GET MH_Frm
   READ
ENDDO
@24,0
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
   @24,0 SAY "Criteria NOT a legal expression"
   @19,2 GET MH_Cri
   READ
ENDDO
@24,0
STORE TRIM(MH_Frm)+".LBL" TO MH_work
IF .NOT. FILE(MH_Work)
   *%%IF,PRG
   DO WAI WITH 24,0,"LABEL FORM "+TRIM(MH_Frm)+" not found. "
   *%%ENDIF
   RETURN
ENDIF
IF MH_NdxL
   @24,0
   @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
   IF MH_Cri=SPACE(76)
   STORE ".T."+SPACE(73) TO MH_Cri
   ENDIF
   IF RECCOUNT()>1
   SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
   ELSE
   COPY TO &MH_NDX FOR &MH_Cri
   ENDIF
   SELE J
   USE &MH_NDX
ELSE
    @24,0
    @24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
DO CASE
   CASE MH_Con
       LABEL FORM &MH_Frm FOR &MH_Cri
   CASE MH_Prt
        SET CONSOLE OFF
        LABEL FORM &MH_Frm TO PRINT FOR &MH_Cri
        SET CONSOLE ON
   CASE MH_Disk
      SET CONSOLE OFF
      SET ALTERNATE TO &MH_Dfname
      SET ALTERNATE ON
      LABEL FORM &MH_Frm FOR &MH_Cri
      SET ALTERNATE OFF
      CLOSE ALTERNATE
      SET CONSOLE ON
ENDCASE
IF MH_NdxL
   USE
ENDIF
SELE A
RETURN
*%%ENDIF

*%%IF,MM
*%%DOCUMENT,MM,Mail Merge module
PROCEDURE MM
STORE .N. TO MH_Prt
STORE .N. TO MH_Con
STORE .Y. TO MH_Disk
STORE "MMWORK    " TO MH_DFname
STORE "        " TO MH_Frm
STORE "WORDSTAR" TO MH_WP
STORE ".T."+SPACE(73) TO MH_Cri
IF "DB3+"$DBVersion
   *%%IF,3PLUS
   CALL DPOUT
   *%%ENDIF
ELSE
   CLEAR
   DO DPO
ENDIF
@11,2 SAY "Word Processor:"
@7,22 SAY MH_Disk
@7,42 SAY MH_DFname
@9,15 SAY MH_Frm
@11,19 SAY MH_WP
DO WHILE .T.
   @7,42 GET MH_Dfname PICTURE "!!!!!!!!!!"
   @9,15 GET MH_Frm PICTURE "!!!!!!!!"
   @11,19 GET MH_WP PICTURE "!!!!!!!!"
   READ
   @24,0
   IF MH_Disk .AND. MH_Dfname = "          "
      @24,0 SAY "You must enter a disk filename"
      LOOP
   ENDIF
   IF MH_Frm = "        "
      @24,0 SAY "You must enter a sort form or 'NOSORT'"
      LOOP
   ENDIF
   IF .NOT.(MH_WP = "WORDSTAR" .OR. MH_WP = "MSWORD  ")
      @24,0 SAY "Current WP formats are: WORDSTAR, MSWORD"
      LOOP
   ENDIF
   EXIT
ENDDO
IF MH_Frm = "NOSORT  "
   STORE .F. TO MH_NdxL
ELSE
   IF .NOT. (FILE("DPSORT.DBF") .AND. FILE("DPSORT."+IndxExt))
      *%%IF,PRG
      DO WAI WITH 24,0,"DPSORT files not found. "
      *%%ENDIF
      RETURN
   ENDIF
   SELE I
   USE DPSORT INDEX DPSORT
   SEEK MH_Frm
   IF EOF()
      *%%IF,PRG
      DO WAI WITH 24,0,"Sort name not on selection file (DPSORT.DBF). "
      *%%ENDIF
      USE
      SELE A
      RETURN
   ENDIF
   STORE SORTCRI TO MH_Cri
   STORE SORTNDX TO MH_NDX
   STORE .F. TO MH_NdxL
   MH_Srt="*"
   SortOk=.F.
   DO SortChk WITH MH_Srt, MH_NdxL, SortOk
   IF .NOT. SortOk
      *%%IF,PRG
      DO WAI WITH 24,0,"Unknown Sort Field, or Field Type not C,D,N. "
      *%%ENDIF
      RETURN
   ENDIF
ENDIF
@24,0
@19,2 GET MH_Cri
READ
DO WHILE IIF(Clipper,.F.,TYPE(MH_Cri)<>"L")
   @24,0 SAY "Criteria NOT a legal expression"
   @19,2 GET MH_Cri
   READ
ENDDO
@24,0
IF MH_NdxL
   @24,0
   @24,0 SAY "SELECTING/SORTING DATA! PLEASE WAIT . . . "
   IF MH_Cri=SPACE(76)
   STORE ".T."+SPACE(73) TO MH_Cri
   ENDIF
   IF RECCOUNT()>1
   SORT TO &MH_NDX ON &MH_SRT FOR &MH_Cri
   ELSE
   COPY TO &MH_NDX FOR &MH_Cri
   ENDIF
   SELE J
   USE &MH_NDX
ELSE
    @24,0
    @24,0 SAY "Using Unsorted File"
ENDIF
@24,0
@24,0 SAY "PRODUCING OUTPUT. PLEASE WAIT . . . "
IF (.NOT. MH_NdxL) .AND. (LEN(TRIM(MH_Cri)) <> 0)
   LOCATE FOR &MH_Cri
ENDIF
IF EOF()
   *%%IF,PRG
   DO WAI WITH 24,0,"No records meet criteria. "
   *%%ENDIF
   SELE A
   RETURN
ENDIF
*
* Turn on output device
*
SET CONSOLE OFF
STORE TRIM(MH_Dfname)+".DOC" TO MH_Ofn
SET ALTERNATE TO &MH_Ofn
SET ALTERNATE ON
*
* Output field header
*
DO CASE
   CASE MH_WP = "WORDSTAR"
      ?".OP"
      ?".DF "+MH_DFNAME+".DAT"
      ?".RV "
      *%%MMFIELDS
      ?
      SET ALTERNATE OFF
      CLOSE ALTERNATE
      STORE TRIM(MH_Dfname)+".DAT" TO MH_Ofn
      SET ALTERNATE TO &MH_Ofn
      SET ALTERNATE ON
   CASE MH_WP = "MSWORD  "
      ?
      *%%MMFIELDS
ENDCASE
*
* Output Selected data
*
DO WHILE .NOT. EOF()
   DO CASE
      CASE (MH_WP = "WORDSTAR") .OR. (MH_WP = "MSWORD  ")
         ? ""
         *%%MMDATA
   ENDCASE
   IF  MH_NdxL .OR. (LEN(TRIM(MH_Cri)) = 0)
       SKIP
   ELSE
       CONTINUE
   ENDIF
ENDDO
*
* Finish output
*
SET ALTERNATE OFF
CLOSE ALTERNATE
SET CONSOLE ON
IF MH_NdxL
   USE
ENDIF
SELE A
RETURN
*%%ENDIF

*%%IF,VAL
*%%DOCUMENT,VAL,Validate data module
PROCEDURE VAL
*%%VAL
RETURN
*%%ENDIF

*%%IF,HLP
*%%DOCUMENT,HLP,Give general information
PROCEDURE HLP
PARAMETERS What
*%%HLP
RETURN
*%%ENDIF

*%%IF,PRG
*%%DOCUMENT,IND,Build/re-build Index module
PROCEDURE IND
PARAMETERS DataFile, IndxFile, IndxExpr, action
IF .NOT. Indexed
   RETURN
ENDIF
USE &DataFile
@24,0
IF .NOT. File(IndxFile)
   @24,0 SAY "Please wait, file is being Indexed . . . "
   INDEX ON &IndxExpr TO &IndxFile
ELSE
   IF action="REINDEX"
      @24,0 SAY "Please wait, file is being Re-Indexed . . . "
      REINDEX
   ENDIF
ENDIF
SET INDEX TO &IndxFile
@24,0
RETURN
*%%ENDIF

*%%IF,PRG*(SRT+RPT+LAB+MM)
*%%DOCUMENT,SCH,Validate/Verify Sort Fields for Sort routine
PROCEDURE SortChk
PARAMETERS MH_Srt, MH_NdxL, SortOK
PRIVATE sfld, sortf, sorto, SVar
 SortOK=.T.
 SELE I
 USE DPSORT INDEX DPSORT
 MH_Srt=""
 sfld=1
 DO WHILE sfld<=10
    sortf="SORTF"+LTRIM(STR(sfld))
    sorto="SORTO"+LTRIM(STR(sfld))
    SVar=TRIM(&sortf)
    IF &SORTF <> "       "
       SELE A
       IF .NOT. TYPE(SVar)$"CDN"
          SELE I
          USE
          SELE A
          SortOK=.F.
          RETURN
       ENDIF
       SELE I
       IF LEN(MH_Srt)=0
          STORE TRIM(&SORTF)+"/"+&SORTO TO MH_Srt
       ELSE
          STORE MH_Srt+", "+TRIM(&SORTF)+"/"+&SORTO TO MH_Srt
       ENDIF
       STORE .T. TO MH_NdxL
     ENDIF
     sfld=sfld+1
 ENDDO
 USE
 SELE A
RETURN
*%%ENDIF
*%%IF,~(3PLUS)
*%%MAKEDB3
*%%ENDIF
*%%CLOSE

*%%IF,SRT*PRG
*%%OPENDIRECT,DPSORT
*%%DOCUMENT,PRG,Main Menu Program
* database: DPSORT
PRIVATE MH_Function, MH_Loop
SET STATUS OFF
SET TALK OFF
SET ECHO OFF
SET BELL OFF
SET HEADING OFF
SET SAFETY OFF
SET DEVICE TO SCREEN
SET PROCEDURE TO DPSORT
SELECT I
DO IND_ WITH "ENSURE"
USE DPSORT INDEX DPSORT
SET FILTER TO
DO PUB_
STORE .T. TO MH_Loop
DO WHILE MH_Loop
   DO CASE
      CASE "CLIPPER"$DBVersion
        *%%IF,CLIPPER
        CLEAR
        DO DPMMSRTS
        *%%ENDIF
      CASE "DB3+"$DBVersion
        *%%IF,3PLUS
        CALL DPMMSORT
        *%%ENDIF
      CASE "DB3"$DBVersion
        *%%IF,DB3
        CLEAR
        DO DPMMSRTS
        *%%ENDIF
   ENDCASE
   STORE " " TO MH_Function
   @ 24,0
   @ 2,3 SAY DTOC(DATE())
   @ 2,69 SAY Time()
   @ 23,47 SAY "Choice:"
   @ 23,55 GET MH_Function PICT "!"
   READ
   DO CASE
      CASE UPPER(MH_Function)="A"
         DO ADD_
         LOOP
      CASE UPPER(MH_Function)="U"
        IF RECCOUNT()=0
           DO WAI_ WITH 24, 0, "File empty, request denied."
           LOOP
        ENDIF
        DO UPD_
        LOOP
      CASE UPPER(MH_Function)="I"
        DO IND_ WITH "REINDEX"
        LOOP
      CASE UPPER(MH_Function)="H"
        DO HLP_ WITH 1
        LOOP
      CASE UPPER(MH_Function)="P"
        @24,0
        @24,0 SAY "Delete all marked records"
        PRIVATE MH_Ans
        STORE "N" TO MH_Ans
        @24,30 GET MH_Ans PICT "!"
        READ
        IF MH_Ans="Y"
           PACK
        ENDIF
        RELEASE MH_Ans
        LOOP
      CASE UPPER(MH_Function)="Q"
        DO REL_
        CLOSE DATABASES
        CLEAR
        QUIT
      CASE UPPER(MH_Function)="D"
        DO REL_
        CLOSE DATABASES
        RETURN
      CASE UPPER(mh_function)="R"
        IF Clipper
           DO WAI_ WITH 24, 0, "Report Create/Modify not implemented by Clipper."
           LOOP
        ENDIF
        STORE "        " TO MH_Name
        @24,0
        @24,0 SAY "Report Name:"
        @24,14 GET MH_Name
        READ
        IF MH_Name <> "        "
           SELE A
           *%%IF,~(CLIPPER)
           MODI REPORT &MH_Name
           *%%ENDIF
           SELE I
        ENDIF
        LOOP
      CASE UPPER(mh_function)="L"
        IF Clipper
           DO WAI_ WITH 24, 0, "Label Create/Modify not implemented by Clipper."
           LOOP
        ENDIF
        STORE "        " TO MH_Name
        @24,0
        @24,0 SAY "Label Name:"
        @24,14 GET MH_Name
        READ
        IF MH_Name <> "        "
           SELE A
           *%%IF,~(CLIPPER)
           MODI LABEL &MH_Name
           *%%ENDIF
           SELE I
        ENDIF
        LOOP
   ENDCASE
ENDDO
RETURN

*%%DOCUMENT,IND,Build/ReBuild Index
PROCEDURE IND_
PARAMETERS action
SELE I
USE DPSORT
IF (.NOT. FILE("DPSORT"+IIF(Clipper,".NTX",".NDX"))) .OR. action="REINDEX"
   @24,0
   @24,0 SAY "Please wait, file is being Indexed"
   INDEX ON SORTNAM TO DPSORT
   @24,0
ENDIF
SET INDEX TO DPSORT
RETURN

*%%DOCUMENT,FMT,Screen Format file
PROCEDURE FMT_
PARA Action
IF action="A"
   @4,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
ENDIF
@4,48 GET MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 GET MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 GET MA_SORTDES
@8,2 GET MA_SORTCRI
RETURN

*%%DOCUMENT,PUB,Define Public Fields
PROCEDURE PUB_
PUBLIC MA_SORTNAM
PUBLIC MA_SORTNDX
PUBLIC MA_SORTFRM
PUBLIC MA_SORTDES
PUBLIC MA_SORTCRI
PUBLIC MA_SORTF1
PUBLIC MA_SORTO1
PUBLIC MA_SORTF2
PUBLIC MA_SORTO2
PUBLIC MA_SORTF3
PUBLIC MA_SORTO3
PUBLIC MA_SORTF4
PUBLIC MA_SORTO4
PUBLIC MA_SORTF5
PUBLIC MA_SORTO5
PUBLIC MA_SORTF6
PUBLIC MA_SORTO6
PUBLIC MA_SORTF7
PUBLIC MA_SORTO7
PUBLIC MA_SORTF8
PUBLIC MA_SORTO8
PUBLIC MA_SORTF9
PUBLIC MA_SORTO9
PUBLIC MA_SORTF10
PUBLIC MA_SORTO10
RETURN

*%%DOCUMENT,CAL,Calculate and Display Calculated Fields
PROCEDURE CAL_
RETURN

*%%DOCUMENT,INT,Initialize Memory fields from Init or empty
PROCEDURE INT_
STORE SPACE(8) TO MA_SORTNAM
STORE "SORTWORK" TO MA_SORTNDX
STORE SPACE(8) TO MA_SORTFRM
STORE SPACE(63) TO MA_SORTDES
STORE ".T."+SPACE(LEN(DPSORT->SORTCRI)-1) TO MA_SORTCRI
STORE SPACE(7) TO MA_SORTF1
STORE "A" TO MA_SORTO1
STORE SPACE(7) TO MA_SORTF2
STORE "A" TO MA_SORTO2
STORE SPACE(7) TO MA_SORTF3
STORE "A" TO MA_SORTO3
STORE SPACE(7) TO MA_SORTF4
STORE "A" TO MA_SORTO4
STORE SPACE(7) TO MA_SORTF5
STORE "A" TO MA_SORTO5
STORE SPACE(7) TO MA_SORTF6
STORE "A" TO MA_SORTO6
STORE SPACE(7) TO MA_SORTF7
STORE "A" TO MA_SORTO7
STORE SPACE(7) TO MA_SORTF8
STORE "A" TO MA_SORTO8
STORE SPACE(7) TO MA_SORTF9
STORE "A" TO MA_SORTO9
STORE SPACE(7) TO MA_SORTF10
STORE "A" TO MA_SORTO10
RETURN

*%%DOCUMENT,STO,Store file Fields to memory variables
PROCEDURE STO_
STORE DPSORT -> SORTNAM to MA_SORTNAM
STORE DPSORT -> SORTNDX to MA_SORTNDX
STORE DPSORT -> SORTFRM to MA_SORTFRM
STORE DPSORT -> SORTDES to MA_SORTDES
STORE DPSORT -> SORTCRI to MA_SORTCRI
STORE DPSORT -> SORTF1  to MA_SORTF1
STORE DPSORT -> SORTO1  to MA_SORTO1
STORE DPSORT -> SORTF2  to MA_SORTF2
STORE DPSORT -> SORTO2  to MA_SORTO2
STORE DPSORT -> SORTF3  to MA_SORTF3
STORE DPSORT -> SORTO3  to MA_SORTO3
STORE DPSORT -> SORTF4  to MA_SORTF4
STORE DPSORT -> SORTO4  to MA_SORTO4
STORE DPSORT -> SORTF5  to MA_SORTF5
STORE DPSORT -> SORTO5  to MA_SORTO5
STORE DPSORT -> SORTF6  to MA_SORTF6
STORE DPSORT -> SORTO6  to MA_SORTO6
STORE DPSORT -> SORTF7  to MA_SORTF7
STORE DPSORT -> SORTO7  to MA_SORTO7
STORE DPSORT -> SORTF8  to MA_SORTF8
STORE DPSORT -> SORTO8  to MA_SORTO8
STORE DPSORT -> SORTF9  to MA_SORTF9
STORE DPSORT -> SORTO9  to MA_SORTO9
STORE DPSORT -> SORTF10 to MA_SORTF10
STORE DPSORT -> SORTO10  to MA_SORTO10
RETURN

*%%DOCUMENT,REP,Replace file Fields with memory variables
PROCEDURE REP_
REPLACE DPSORT -> SORTNAM WITH MA_SORTNAM
REPLACE DPSORT -> SORTNDX WITH MA_SORTNDX
REPLACE DPSORT -> SORTFRM WITH MA_SORTFRM
REPLACE DPSORT -> SORTDES WITH MA_SORTDES
REPLACE DPSORT -> SORTCRI WITH MA_SORTCRI
REPLACE DPSORT -> SORTF1  WITH MA_SORTF1
REPLACE DPSORT -> SORTO1  WITH MA_SORTO1
REPLACE DPSORT -> SORTF2  WITH MA_SORTF2
REPLACE DPSORT -> SORTO2  WITH MA_SORTO2
REPLACE DPSORT -> SORTF3  WITH MA_SORTF3
REPLACE DPSORT -> SORTO3  WITH MA_SORTO3
REPLACE DPSORT -> SORTF4  WITH MA_SORTF4
REPLACE DPSORT -> SORTO4  WITH MA_SORTO4
REPLACE DPSORT -> SORTF5  WITH MA_SORTF5
REPLACE DPSORT -> SORTO5  WITH MA_SORTO5
REPLACE DPSORT -> SORTF6  WITH MA_SORTF6
REPLACE DPSORT -> SORTO6  WITH MA_SORTO6
REPLACE DPSORT -> SORTF7  WITH MA_SORTF7
REPLACE DPSORT -> SORTO7  WITH MA_SORTO7
REPLACE DPSORT -> SORTF8  WITH MA_SORTF8
REPLACE DPSORT -> SORTO8  WITH MA_SORTO8
REPLACE DPSORT -> SORTF9  WITH MA_SORTF9
REPLACE DPSORT -> SORTO9  WITH MA_SORTO9
REPLACE DPSORT -> SORTF10 WITH MA_SORTF10
REPLACE DPSORT -> SORTO10 WITH MA_SORTO10
RETURN

*%%DOCUMENT,REL,Release Memory variables
PROCEDURE REL_
RELEASE MA_SORTNAM
RELEASE MA_SORTNDX
RELEASE MA_SORTFRM
RELEASE MA_SORTDES
RELEASE MA_SORTCRI
RELEASE MA_SORTF1
RELEASE MA_SORTO1
RELEASE MA_SORTF2
RELEASE MA_SORTO2
RELEASE MA_SORTF3
RELEASE MA_SORTO3
RELEASE MA_SORTF4
RELEASE MA_SORTO4
RELEASE MA_SORTF5
RELEASE MA_SORTO5
RELEASE MA_SORTF6
RELEASE MA_SORTO6
RELEASE MA_SORTF7
RELEASE MA_SORTO7
RELEASE MA_SORTF8
RELEASE MA_SORTO8
RELEASE MA_SORTF9
RELEASE MA_SORTO9
RELEASE MA_SORTF10
RELEASE MA_SORTO10
RETURN

*%%DOCUMENT,ADD,Add new records to file
PROCEDURE ADD_
PRIVATE MH_Loop, MH_Wait
STORE .T. TO MH_Loop
STORE " " TO MH_Wait
DO CASE
   CASE "CLIPPER"$DBVersion
     *%%IF,CLIPPER
     CLEAR
     DO DPSORTS
     *%%ENDIF
   CASE "DB3+"$DBVersion
     *%%IF,3PLUS
     CALL DPSORT
     *%%ENDIF
   CASE "DB3"$DBVersion
     *%%IF,DB3
     CLEAR
     DO DPSORTS
     *%%ENDIF
ENDCASE
DO WHILE MH_Loop
   DO INT_
   DO FMT_ WITH "A"
   @24,0
   @24,0 SAY "Press Ctrl-W without entering data to exit"
   READ
   IF LEN(TRIM(MA_SORTNAM)) <> 0
       SEEK MA_SORTNAM
       @ 24,0
       DO WHILE .NOT. EOF()
          ?? CHR(7)
          @24,0 SAY "Sort Name is a duplicate; change it to allow the addition."
          @04,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
          READ
          SEEK MA_SORTNAM
       ENDDO
       @ 24,0
       DO VAL_
       APPEND BLANK
       DO REP_
       DO CAL_
       DO WAI_ WITH 24, 0, ""
   ELSE
     STORE .F. TO MH_Loop
   ENDIF
ENDDO
RELEASE MH_Loop,MH_Wait
RETURN

*%%DOCUMENT,UPD,Search Update Edit Find Print Examine file
PROCEDURE UPD_
PRIVATE MH_Loop, MH_Function, MH_Answer
STORE .T. TO MH_Loop
STORE "N" TO MH_Function
STORE "N" TO MH_Answer
STORE SPACE(70) TO MH_Filt
STORE "Next,Previous,Top,Bottom,Quit,Help,Delete,Edit,More " TO MH_Menu1
STORE "Find,Set filter,pRint,More                          " TO MH_Menu2
STORE MH_Menu1 TO MH_Menu
DO CASE
   CASE "CLIPPER"$DBVersion
     *%%IF,CLIPPER
     CLEAR
     DO DPSORTS
     *%%ENDIF
   CASE "DB3+"$DBVersion
     *%%IF,3PLUS
     CALL DPSORT
     *%%ENDIF
   CASE "DB3"$DBVersion
     *%%IF,DB3
     CLEAR
     DO DPSORTS
     *%%ENDIF
ENDCASE
DO WHILE MH_Loop
   DO STO_
   DO DIS_
   DO CAL_
   @24,0 SAY MH_Menu
   @24,53 GET MH_Function PICT "!"
   IF LEN(TRIM(MH_Filt)) = 0
      @24,55 SAY "    "
   ELSE
      @24,55 SAY "FILT"
   ENDIF
   IF Deleted()
      @24,60 SAY "DEL"
   ELSE
      @24,60 SAY "   "
   ENDIF
   @24,65 SAY Ltrim(Str(RECNO()))+"/"+Ltrim(STR(RECCOUNT()))+"     "
   READ
   DO CASE
      CASE UPPER(MH_Function) = "N"
           IF .NOT. EOF()
              Skip 1
              IF EOF()
                 GO BOTT
              ENDIF
           ENDIF
           LOOP
      CASE UPPER(MH_Function) = "P"
           IF .NOT. BOF()
              SKIP -1
              IF BOF()
                 GO TOP
              ENDIF
           ENDIF
           LOOP
      CASE UPPER(MH_Function) = "E"
           DO STO_
           DO FMT_ WITH "E"
           READ
           IF READKEY()=12 .OR. READKEY()=268
              LOOP
           ENDIF
           DO VAL_
           DO CAL_
           DO REP_
           LOOP
      CASE UPPER(MH_Function) = "T"
           GOTO TOP
           LOOP
      CASE UPPER(MH_Function) = "B"
           GOTO BOTTOM
           LOOP
      CASE UPPER(MH_Function) = "D"
           STORE "N" TO MH_Answer
           @24,0
           IF DELETED()
              @24,0 SAY "Recall this record?"
           ELSE
              @24,0 SAY "Delete this record?"
           ENDIF
           @24,22 GET MH_Answer
           READ
           IF UPPER(MH_Answer) = "Y"
              IF DELETED()
                 RECALL
              ELSE
                 DELETE
              ENDIF
           ENDIF
           LOOP
      CASE UPPER(MH_Function) = "S"
           STORE "N" TO MH_Answer
           STORE MH_Filt TO MH_FiltH
           @24,0
           @24,0 SAY "FILTER: "
           @24,9 GET MH_Filt
           READ
           @24,0
           IF MH_Filt <> MH_FiltH
              IF LEN(TRIM(MH_Filt)) <> 0
                 IF IIF(Clipper,.F.,TYPE(MH_Filt)<>"L")
                    DO WAI_ WITH 24, 0, "Filter expression defective, not usable."
                    MH_Filt=MH_FiltH
                    LOOP
                 ENDIF
                 SET FILTER TO &MH_Filt
              ELSE
                 SET FILTER TO .T.
              ENDIF
              GO TOP
              IF EOF()
                 DO WAI_ WITH 24, 0, "Nothing matches filter!"
              ENDIF
           ENDIF
           LOOP
      CASE UPPER(MH_Function) = "F"
           DO FND_
           LOOP
      CASE UPPER(MH_Function) = "M"
           IF MH_Menu1 = MH_Menu
              STORE MH_Menu2 TO MH_Menu
           ELSE
              STORE MH_Menu1 TO MH_Menu
           ENDIF
           LOOP
      CASE UPPER(MH_Function) = "Q"
           STORE .F. TO MH_LOOP
           LOOP
      CASE UPPER(MH_Function) = "R"
           DO WAI_ WITH 24,0,"MAKE SURE PRINTER IS ON LINE!!!"
           DO CASE
             CASE "DB3+"$DBVersion
                *%%IF,3PLUS
                ON ERROR DO WAI_ WITH 24,0,"Fix PRINTER !!!"
                *%%ENDIF
             CASE "CLIPPER"$DBVersion
                *%%IF,CLIPPER
                DO WHILE .NOT. ISPRINTER()
                   ?? CHR(7)
                   DO WAI_ WITH 24,0,"Fix PRINTER !!!"
                ENDDO
                *%%ENDIF
           ENDCASE
           SET DEVICE TO PRINT
           DO DIS_
           SET DEVICE TO SCREEN
           *%%IF,3PLUS
           IF "DB3+"$DBVersion
             ON ERROR
           ENDIF
           *%%ENDIF
           LOOP
      CASE UPPER(MH_Function)="H"
           DO HLP_ WITH 2
           DO CASE
              CASE "CLIPPER"$DBVersion
                *%%IF,CLIPPER
                CLEAR
                DO DPSORTS
                *%%ENDIF
              CASE "DB3+"$DBVersion
                *%%IF,3PLUS
                CALL DPSORT
                *%%ENDIF
              CASE "DB3"$DBVersion
                *%%IF,DB3
                CLEAR
                DO DPSORTS
                *%%ENDIF
           ENDCASE
           LOOP
   ENDCASE
STORE "N" TO MH_Function
ENDDO
SET FILTER TO .T.
RELEASE MH_Function,MH_Loop,MH_Answer
RETURN

*%%DOCUMENT,DIS,Display-only Format file
PROCEDURE DIS_
@4,13 SAY MA_SORTNAM PICTURE "!!!!!!!!"
@4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 SAY MA_SORTDES
@8,2 SAY MA_SORTCRI
@13,30 SAY MA_SORTF1 PICTURE "!!!!!!!"
@13,46 SAY MA_SORTO1 PICTURE "!"
@14,30 SAY MA_SORTF2 PICTURE "!!!!!!!"
@14,46 SAY MA_SORTO2 PICTURE "!"
@15,30 SAY MA_SORTF3 PICTURE "!!!!!!!"
@15,46 SAY MA_SORTO3 PICTURE "!"
@16,30 SAY MA_SORTF4 PICTURE "!!!!!!!"
@16,46 SAY MA_SORTO4 PICTURE "!"
@17,30 SAY MA_SORTF5 PICTURE "!!!!!!!"
@17,46 SAY MA_SORTO5 PICTURE "!"
@18,30 SAY MA_SORTF6 PICTURE "!!!!!!!"
@18,46 SAY MA_SORTO6 PICTURE "!"
@19,30 SAY MA_SORTF7 PICTURE "!!!!!!!"
@19,46 SAY MA_SORTO7 PICTURE "!"
@20,30 SAY MA_SORTF8 PICTURE "!!!!!!!"
@20,46 SAY MA_SORTO8 PICTURE "!"
@21,30 SAY MA_SORTF9 PICTURE "!!!!!!!"
@21,46 SAY MA_SORTO9 PICTURE "!"
@22,30 SAY MA_SORTF10 PICTURE "!!!!!!!"
@22,46 SAY MA_SORTO10 PICTURE "!"
RETURN

*%%DOCUMENT,FND,Find record by key routine
PROCEDURE FND_
PRIVATE MH_Find,MH_Answer,MH_Rec
STORE " " TO MH_Find
STORE " " TO MH_Answer
STORE 0   TO MH_Rec
@4,13 GET MA_SORTNAM PICTURE "!!!!!!!!"
@4,48 SAY MA_SORTNDX PICTURE "!!!!!!!!"
@4,70 SAY MA_SORTFRM PICTURE "!!!!!!!!"
@5,15 SAY MA_SORTDES
@8,2 SAY MA_SORTCRI
@13,30 SAY MA_SORTF1 PICTURE "!!!!!!!"
@13,46 SAY MA_SORTO1 PICTURE "!"
@14,30 SAY MA_SORTF2 PICTURE "!!!!!!!"
@14,46 SAY MA_SORTO2 PICTURE "!"
@15,30 SAY MA_SORTF3 PICTURE "!!!!!!!"
@15,46 SAY MA_SORTO3 PICTURE "!"
@16,30 SAY MA_SORTF4 PICTURE "!!!!!!!"
@16,46 SAY MA_SORTO4 PICTURE "!"
@17,30 SAY MA_SORTF5 PICTURE "!!!!!!!"
@17,46 SAY MA_SORTO5 PICTURE "!"
@18,30 SAY MA_SORTF6 PICTURE "!!!!!!!"
@18,46 SAY MA_SORTO6 PICTURE "!"
@19,30 SAY MA_SORTF7 PICTURE "!!!!!!!"
@19,46 SAY MA_SORTO7 PICTURE "!"
@20,30 SAY MA_SORTF8 PICTURE "!!!!!!!"
@20,46 SAY MA_SORTO8 PICTURE "!"
@21,30 SAY MA_SORTF9 PICTURE "!!!!!!!"
@21,46 SAY MA_SORTO9 PICTURE "!"
@22,30 SAY MA_SORTF10 PICTURE "!!!!!!!"
@22,46 SAY MA_SORTO10 PICTURE "!"
@24,0
@24,0 SAY "Enter data to search for in open fields"
READ
IF LEN(TRIM(MA_SORTNAM)) <> 0
   STORE MA_SORTNAM TO MH_Find
   STORE RECNO() TO MH_Rec
   FIND &MH_Find
   IF EOF()
      GOTO MH_Rec
      DO WAI_ WITH 24, 0, "Record NOT Found! "
   ELSE
      DO WAI_ WITH 24, 0, "Record Found! "
   ENDIF
ENDIF
RELEASE MH_Find,MH_Answer,MH_Rec
@24,0
RETURN

*%%DOCUMENT,VAL,Validate Data module
PROCEDURE VAL_
@ 24,0
SELE A
DO WHILE IIF(Clipper,.F.,TYPE(MA_SORTCRI)<>"L")
   ?? CHR(7)
   @ 24,0 SAY "Sort Criteria defective; repair the expression"
   @ 8,2 GET MA_SORTCRI
   READ
ENDDO
@ 24,0
SELE I
IF .NOT. CLIPPER
   SET ESCA OFF
ENDIF
ofs=12
sel=1
fc=10
key=0
nums="1 2 3 4 5 6 7 8 9 10"
DO WHIL key<>27
FVar="MA_SORTF"+SUBS(nums,(sel-1)*2+1,2)
OVar="MA_SORTO"+SUBS(nums,(sel-1)*2+1,2)
@ 24,0
@ 24,0 SAY "Up, Down arrows change fields;  <RETURN> = access;  <Esc> = quit"
@ sel+ofs,29 SAY "@"
DO GetKey WITH CHR(5)+CHR(24)+CHR(13)+CHR(27),key
@sel+ofs,29 SAY " "
DO CASE
  CASE key=5
    sel=sel-1
  CASE key=24
    sel=sel+1
  CASE key=13
    DO SDF WITH sel+ofs,30,46,&Fvar,&OVar
ENDC
sel=IIF(sel>fc,1,sel)
sel=IIF(sel<1,fc,sel)
ENDD
SET ESCA ON
@ 24,0
RETU

*%%DOCUMENT,SDF,Scan and Select; (or Enter) Sort Field Names
PROCEDURE SDF
PARA Ln, Cl, Cl2, Fld, Ord
PRIV key
fld=fld+SPACE(7-LEN(fld))
Ord=Ord+SPACE(1-LEN(Ord))
key=0
DO WHILE .T.
@ Ln,Cl SAY Fld
@ Ln,Cl2 SAY Ord
@ 24,0
@ 24,0 SAY "<SPACE> = Field Scan;  <RETURN> = Field Edit   <Esc> = done field"
DO GetKey WITH " "+CHR(13)+CHR(27),key
@ 24,0
DO CASE
   CASE key=27
      RETURN
   CASE key=13
      @ 24,0 SAY "Edit the fieldname; <Esc> restores original"
      fno=0
      fldh=fld
      DO WHIL fno=0
         @ Ln,Cl GET fld PICTURE "!!!!!!!"
         READ
         IF LEN(TRIM(fld))=0
            EXIT
         ENDIF
         IF READKEY()=12.OR.READKEY()=268
            fld=fldh
            EXIT
         ENDIF
         @ 24,55 say "CHECKING..."
         DO ValidFld WITH fld, fno
         @ 24,55
         @ 24,55 say IIF(fno>0,"OK","BAD FIELD")
      ENDD
      @ Ln,Cl SAY Fld
   CASE key=32
      @ 24,0 SAY "Arrows Scan, <RETURN> selects, <Esc> quits Scan"
      STOR 1 TO I,K
      sks=CHR(4)+CHR(19)+CHR(13)+CHR(27)
      SELE A
      DO WHILE LEN(FIELD(I))>0
        @ Ln,Cl SAY "           "
        @ Ln,Cl SAY FIELD(I)
        DO GetKey WITH sks,k
        DO CASE
        CASE k=13
          fld=FIELD(I)+SPACE(7-LEN(FIELD(I)))
          EXIT
        CASE k=19
          I=IIF(i>1,i-1,i)
        CASE k=4
          I=IIF(LEN(FIELD(i+1))=0,i,i+1)
        CASE k=27
          EXIT
        ENDC
      ENDDO
      SELE dpsort
ENDCASE
IF LEN(TRIM(fld))=0
   Ord=" "
ELSE
   badord=.T.
   @ 24,0
   DO WHILE badord
      @ 24,0 SAY "Enter 'A' or 'D' for Ascending/Descending Sort Order"
      @ Ln,Cl2 GET ord PICTURE "!"
      READ
      badord=.NOT.(ord$"AD")
   ENDDO
   @ 24,0
ENDIF
ENDD
RETU

*%%DOCUMENT,INK,Low-level keyboard-reading routine
PROCEDURE GetKey
PARA S,K
k=INKE()
DO WHIL k=0 .AND..NOT. CHR(k)$S
k=INKE()
ENDD
RETU

*%%DOCUMENT,VFD,Ensure valid Sort Field Name entry
PROCEDURE ValidFld
PARA fld, fno
fno=0
i=1
SELE A
SET EXAC ON
DO WHIL LEN(FIEL(I))>0
IF TRIM(fld)=FIEL(I)
fno=I
EXIT
ENDI
I=I+1
ENDD
SELE I
SET EXAC OFF
RETU

*%%DOCUMENT,HLP,Give general help information
PROCEDURE HLP_
PARAMETERS What
DO CASE
CASE What = 1
     @0,0 SAY "Sorry, No help available"
CASE What = 2
     @0,0 SAY "Sorry, No help available"
OTHERWISE
     @0,0 SAY "LOGIC ERROR IN PROGRAM"
ENDCASE
DO WAI_ WITH 24, 0, ""
@0,0
RETURN

*%%DOCUMENT,WAI,Low-level WAIT and Message-display routine
PROCEDURE WAI_
PARA y,x,msg
PRIV dummy
dummy=" "
SET INTE OFF
@Y,X
@Y,X SAY msg+" Press any key to continue..." GET dummy
READ
SET INTE ON
@Y,X
RETU

*%%DOCUMENT,SMM,Sort/select Main Menu screen (used when LOAD/CALL unavailable)
PROCEDURE DPMMSRTS
@ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗"
@ 2,0 SAY "║                         Sort/select definition Menu                          ║"
@ 3,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 4,0 SAY "║                                                                              ║"
@ 5,0 SAY "║                   A - Add new definitions                                    ║"
@ 6,0 SAY "║                   U - Update, Edit, Scan, Find definitions                   ║"
@ 7,0 SAY "║                   R - Create/Modify a Dbase III Report Form                  ║"
@ 8,0 SAY "║                                                                              ║"
@ 9,0 SAY "║                   L - Create/Modify a Dbase III Label Form                   ║"
@ 10,0 SAY "║                   I - Rebuild the Index                                      ║"
@ 11,0 SAY "║                   P - Pack the database to remove deleted definitions        ║"
@ 12,0 SAY "║                                                                              ║"
@ 13,0 SAY "║                                                                              ║"
@ 14,0 SAY "║                   Q - Quit Program, return to DOS                            ║"
@ 15,0 SAY "║                   D - Return to your application                             ║"
@ 16,0 SAY "║                                                                              ║"
@ 17,0 SAY "║                                                                              ║"
@ 18,0 SAY "║                   Please choose one of the above options                     ║"
@ 19,0 SAY "║                                                                              ║"
@ 20,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝"
@ 23,0 SAY "                                               Choice:                          "
RETURN

*%%DOCUMENT,STS,Sort Definitions screen (used when LOAD/CALL unavailable)
PROCEDURE DPSORTS
@ 1,0 SAY "╔══════════════════════════════════════════════════════════════════════════════╗"
@ 2,0 SAY "║                         Sort/Selection Definitions                           ║"
@ 3,0 SAY "╠══════════════════════════════════════════════════════════════════════════════╣"
@ 4,0 SAY "║ Sort Name:                 Sorted File Name:            Form Name:           ║"
@ 5,0 SAY "║ Description:                                                                 ║"
@ 6,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 7,0 SAY "║                             Selection Criteria                               ║"
@ 8,0 SAY "║                                                                              ║"
@ 9,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 10,0 SAY "║                                Sort Fields                                   ║"
@ 11,0 SAY "╟──────────────────────────────────────────────────────────────────────────────╢"
@ 12,0 SAY "║                             Field Name    Order                              ║"
@ 13,0 SAY "║                          1)                                                  ║"
@ 14,0 SAY "║                          2)                                                  ║"
@ 15,0 SAY "║                          3)                                                  ║"
@ 16,0 SAY "║                          4)                                                  ║"
@ 17,0 SAY "║                          5)                                                  ║"
@ 18,0 SAY "║                          6)                                                  ║"
@ 19,0 SAY "║                          7)                                                  ║"
@ 20,0 SAY "║                          8)                                                  ║"
@ 21,0 SAY "║                          9)                                                  ║"
@ 22,0 SAY "║                         10)                                                  ║"
@ 23,0 SAY "╚══════════════════════════════════════════════════════════════════════════════╝"
RETURN
*%%CLOSE
*%%ENDIF