Shareware Overload/ShartewareOverload.cdr/database/dsubset.zip/SUBSET.PRG

Text File | 1987-02-02 | 16KB | 734 lines

* (C) JOHN A. BRISTOR 1984,1985,1986,1987
* ALL RIGHTS RESERVED
*
* 8414 Williamsburg Circle
* Pensacola, FL 32514
* Voice [phone]
* Data [phone]    FIDO : 151/305
*
* SUBSET.PRG : Procedure FC237 from File Control Procedure Archives
*
* SUBSET.PRG written for Chesapeake Bay Citizen's Program, Baltimore, MD
*         suppliment to Mailmerge Mailing Control System (Multimate Version)
*
*         Used by Highland Fraser Firs, Newland, NC utility in Mailmerge
*         Mailing Control System (Word Perfect Version)
*
*         Wedgewood Productions, Crownsville, Md utility in Speaker/Entertainer
*         Tracking System, Mailmerge Mailing System (Wordstar 2000 version)
*
*         Environmental Protection Agency, Wash. DC, Personnel Tracking,
*         Program Management System, & Grant Tracking System
*         Ranking Decision Support System.
*
*         American Association Of Retired Persons, Wash DC . Personnel
*         Tracking System, Grant Tracking
*
*         Appalachian Poster Company, Lenoir, NC , used in Billboard Expense
*         Statistical Tracking System
*
*         Rivers Printing Company, Boone, NC ; used in Circulation Control
*         System.
*
*         Various other Mailmerge Systems
*
*      This is a limited example of the Subset File Control Procedure that will
* work with any file but is LIMITED to the first 15 fields.  Modifications can
* easily be made to extend this limit. The object of this procedure is to
* allow the user an interactive way of creating a subset of a file determined
* by criteria entered by the user. The resultant subset file can then be used
* input into other procedures, reports, label forms, etc... Modifications can
* also be made to include the '$' substr function and to handle more than three
* criteria.  If you need the version that is not limited, feel free to contact
* me.
*
* The Subset file created is normally sent into the Sorter Routine (FC198)
* The sorter routine works almost identically as this one except it sorts
* the file in whichever order that the user desires.
*
* PINFILE is the name of incoming file
* POUTFILE is the name of the Subset file created
* PJUNKFILE is name of temp file

* PROCEDURE FILE SUBSET
PROCEDURE SUBSET1
PARAMETERS PINFILE,POUTFILE,PJUNKFILE
SET CONFIRM ON
STORE SPACE(1) TO POS,POS1,POS2,POS3,POS4,POS5,POS6,POS7,POS8,POS9,POS10,POS11,POS12,POS13
STORE SPACE(1) TO QUEST1,QUEST2,QUEST3,A
STORE 0 TO QFIELD,STOP,DECIMAL,STOPFLAG,OOPS
STORE SPACE(1) TO CURRENT,OPER1
STORE 1 TO TP,WHERE
STORE 13 TO LINE
CLEAR
SET SAFETY OFF
SET TALK OFF
SET BELL OFF
SELECT 1
USE &PINFILE
GO TOP
COPY STRU EXTENDED TO &PJUNKFILE
SELECT 2
USE &PJUNKFILE
GO BOTTOM
STORE RECNO() TO RECNUM
GO TOP

@  1, 0 SAY "╔══════════════════════════════════════════════════════"
@  1,55 SAY "════════════════════════╗"
@  2, 0 SAY "║"
@  2,79 SAY "║"
@  3, 0 SAY "║"
@  3,79 SAY "║"
@  4, 0 SAY "║"
@  4,79 SAY "║"
@  5, 0 SAY "║"
@  5,79 SAY "║"
@  6, 0 SAY "║"
@  6,79 SAY "║"
@  7, 0 SAY "║"
@  7,79 SAY "║"
@  8, 0 SAY "║"
@  8,79 SAY "║"
@  9, 0 SAY "║"
@  9,79 SAY "║"
@ 10, 0 SAY "╚══════════════════════════════════════════════════════"
@ 10,55 SAY "════════════════════════╝"

STORE 3 TO LCP
STORE -15 TO CP
STORE -10 TO CCP

DO WHILE .NOT. EOF()
     IF CP > 56
      STORE LCP + 1 TO LCP
      STORE 9 TO CP
      STORE 14 TO CCP
     ELSE
      STORE CP + 24 TO CP
      STORE CCP + 24 TO CCP
     ENDIF

     @ LCP, CP SAY STR(RECNO(),2) + ')'
     @ LCP,CCP SAY FIELD_NAME

     SKIP

ENDDO


DO WHILE STOP <> 99
     STORE 0 TO OOPS
     @ 11, 0 CLEAR
     SET COLOR TO W/N
     @ 11,32 SAY "SEARCH CRITERIA"
     SET COLOR TO N/W
     @ 13, 0 SAY SPACE(80)
     SET COLOR TO W/N

     DO FIELD

     DO OPERATOR

     DO VARIABLE

     DO QUEST1

     IF UPPER(QUEST1) = "Y"
      DO APPROVE
      IF STOPFLAG = 99
           CLOSE DATABASES
           STORE 0 TO STOP
           RETURN
      ENDIF
      LOOP
     ENDIF

     DO BOOLEAN

     DO FIELD

     DO OPERATOR

     DO VARIABLE

     DO QUEST1

     IF UPPER(QUEST1) = "Y"
     DO APPROVE
     IF STOPFLAG = 99
          CLOSE DATABASES
          STORE 0 TO STOP
          RETURN
     ENDIF
     LOOP
     ENDIF

     DO BOOLEAN

     DO FIELD

     DO OPERATOR

     DO VARIABLE

     IF OOPS = 0
     DO PUNCT
     ENDIF

     DO APPROVE
     IF STOPFLAG = 99
      CLOSE DATABASES
      STORE 0 TO STOP
      RETURN
     ENDIF

ENDDO

@ 15, 0 CLEAR
STORE 0 TO STOP
DO BOTTOMA
@ 23,25 SAY "SEARCHING AND SELECTING DATA..."
SET COLOR TO *W/N
@ 23,53 SAY "..."
SET COLOR TO W/N

STORE TRIM(POS1) + A + TRIM(POS2) + A + TRIM(POS3) + A + TRIM(POS4) + A + TRIM(POS5) + A + TRIM(POS6) + A + TRIM(POS7) + A + TRIM(POS8) + A + TRIM(POS9) + A + TRIM(POS10) + A + TRIM(POS11) + A + TRIM(POS12) + A + TRIM(POS13) TO BIGSTRING
STORE TRIM(BIGSTRING) TO BIGSTRING
STORE " " + TRIM(BIGSTRING) TO BIGSTRING

SELECT 1
GO TOP
COPY TO &POUTFILE ALL FOR &BIGSTRING

CLOSE DATABASES

RETURN

PROCEDURE BOOLEAN
@ 15, 0 CLEAR
@ 15,24 SAY "╔══════════════════════════════"
@ 15,55 SAY "╗"
@ 16,24 SAY "║"
@ 16,55 SAY "║"
@ 17,24 SAY "║"
@ 17,55 SAY "║"
@ 18,24 SAY "║"
@ 18,55 SAY "║"
@ 19,24 SAY "║"
@ 19,55 SAY "║"
@ 20,24 SAY "║"
@ 20,55 SAY "║"
@ 21,24 SAY "╚══════════════════════════════"
@ 21,55 SAY "╝"
@ 17,36 SAY "1) AND"
@ 19,36 SAY "2) OR"

DO BOTTOMA

@ 23,23 SAY "Enter the Number of BOOLEAN : "

STORE " " TO OPER2
DO WHILE .NOT. OPER2$'12'
     STORE " " TO OPER2
     @ 23,54 GET OPER2 PICTURE '9'
     READ
ENDDO
@ 22, 0 CLEAR

DO CASE
     CASE OPER2 = "1"
      STORE ".AND." TO POS
     CASE OPER2 = "2"
      STORE ".OR." TO POS
ENDCASE


IF LEN(TRIM(POS)) + TP + 1 >= 78
     STORE LINE + 1 TO LINE
     STORE 1 TO TP
     SET COLOR TO N/W
     @    LINE, 0 SAY SPACE(80)
     SET COLOR TO W/N
ENDIF

SET COLOR TO N/W
@ LINE,TP SAY TRIM(POS)
SET COLOR TO W/N
STORE COL() + 1 TO TP

DO POSITION

STORE " " TO POS
@ 15, 0 CLEAR

RETURN



PROCEDURE OPERATOR

@ 15, 0 CLEAR
@ 15,24 SAY "╔══════════════════════════════"
@ 15,55 SAY "╗"
@ 16,24 SAY "║"
@ 16,55 SAY "║"
@ 17,24 SAY "║"
@ 17,55 SAY "║"
@ 18,24 SAY "║"
@ 18,55 SAY "║"
@ 19,24 SAY "║"
@ 19,55 SAY "║"
@ 20,24 SAY "║"
@ 20,55 SAY "║"
@ 21,24 SAY "╚══════════════════════════════"
@ 21,55 SAY "╝"
@ 17,30 SAY "1)  >"
@ 17,43 SAY "2)  <"
@ 18,30 SAY "3)  ="
@ 18,43 SAY "4)  <>"
@ 19,30 SAY "5)  >="
@ 19,43 SAY "6)  <="
IF CURRENT = "C" .AND. OOPS = 0
     @ 20,30 SAY "       7) $"
ENDIF

DO BOTTOMA

@ 23,23 SAY "Enter the Number of OPERATOR : "

IF CURRENT = "C" .AND. OOPS = 0
     STORE " " TO OPER1
     DO WHILE .NOT. OPER1$'1234567'
      STORE " " TO OPER1
      @ 23,54 GET OPER1 PICTURE '9'
      READ
     ENDDO
ELSE
     STORE " " TO OPER1
     DO WHILE .NOT. OPER1$'123456'
      STORE " " TO OPER1
      @ 23,54 GET OPER1 PICTURE '9'
      READ
     ENDDO
ENDIF
@ 22, 0 CLEAR

DO CASE
     CASE OPER1 = "1"
      STORE ">" TO POS
     CASE OPER1 = "2"
      STORE "<" TO POS
     CASE OPER1 = "3"
      STORE "=" TO POS
     CASE OPER1 = "4"
      STORE "<>" TO POS
     CASE OPER1 = "5"
      STORE ">=" TO POS
     CASE OPER1 = "6"
      STORE "<=" TO POS
     CASE OPER1 = "7"
      STORE "$" TO POS
      STORE OOPS + 1 TO OOPS
ENDCASE

IF LEN(TRIM(POS)) + TP + 1 >= 78
     STORE LINE + 1 TO LINE
     STORE 1 TO TP
     SET COLOR TO N/W
     @    LINE, 0 SAY SPACE(80)
     SET COLOR TO W/N
ENDIF

SET COLOR TO N/W
IF OPER1 = "7"
     @ LINE,TP-1 SAY TRIM(POS)
     STORE COL() TO TP
ELSE
     @ LINE,TP SAY TRIM(POS)
     STORE COL() + 1 TO TP
ENDIF
SET COLOR TO W/N

DO POSITION

STORE " " TO POS
@ 15, 0 CLEAR

RETURN


PROCEDURE FIELD

DO BOTTOMA

@ 23,25 SAY "Enter the Number of FIELD : "
STORE 0 TO QFIELD
DO WHILE QFIELD = 0
     STORE 0 TO QFIELD
     @ 23,53 GET QFIELD PICTURE '99' RANGE 1,RECNUM
     READ
ENDDO
@ 22, 0 CLEAR

GO TOP
GO QFIELD
STORE FIELD_NAME TO POS
STORE FIELD_TYPE TO CURRENT
STORE FIELD_DEC TO DECIMAL

IF LEN(TRIM(POS)) + TP + 1 >= 78
     STORE LINE + 1 TO LINE
     STORE 1 TO TP
     SET COLOR TO N/W
     @    LINE, 0 SAY SPACE(80)
     SET COLOR TO W/N
ENDIF

SET COLOR TO N/W
@ LINE,TP SAY TRIM(POS)
SET COLOR TO W/N
STORE COL() + 1 TO TP

DO POSITION

RETURN


PROCEDURE VARIABLE

DO BOTTOMA

DO CASE
     CASE CURRENT = "C"
      IF OPER1 = "7"
           @ 23, 2 SAY "Enter the SEARCH CHARACTERS : "
           STORE SPACE(10) TO QSTRING
           DO WHILE QSTRING = SPACE(10)
            STORE SPACE(10) TO QSTRING
            @ 23,32 GET QSTRING
            READ
           ENDDO
           STORE "'" + TRIM(QSTRING) + "'" TO POS

      ELSE
           @ 23, 2 SAY "Enter the Comparison STRING : "

           STORE SPACE(FIELD_LEN) TO QSTRING
           DO WHILE QSTRING = SPACE(FIELD_LEN)
            STORE SPACE(FIELD_LEN) TO QSTRING
            @ 23,32 GET QSTRING
            READ
           ENDDO

           STORE '"' + TRIM(QSTRING) + '"' TO POS
      ENDIF

     CASE CURRENT = "N" .AND. DECIMAL = 0

      @ 23, 2 SAY "Enter the Comparison INTEGER : "

      STORE SPACE(FIELD_LEN) TO QSTRING
      DO WHILE QSTRING = SPACE(FIELD_LEN)
           STORE SPACE(FIELD_LEN) TO QSTRING
           @ 23,33 GET QSTRING
           READ
      ENDDO

      STORE TRIM(QSTRING) TO POS

     CASE CURRENT = "N" .AND. DECIMAL <> 0

      @ 23, 2 SAY "Enter the Comparison INTEGER : "

      STORE SPACE(FIELD_DEC) TO TEMP2
      STORE SPACE(FIELD_LEN - LEN(TEMP2) - 1) TO TEMP1
      DO WHILE TEMP1 = SPACE(FIELD_LEN - LEN(TEMP2) - 1)
           STORE SPACE(FIELD_LEN - LEN(TEMP2) - 1) TO TEMP1
           @ 23,33 GET TEMP1
           READ
      ENDDO

      @ 23, 2 SAY "Enter the Comparison DECIMAL : "

      DO WHILE TEMP2 = SPACE(FIELD_DEC)
           STORE SPACE(FIELD_DEC) TO TEMP2
           @ 23,33 GET TEMP2
           READ
      ENDDO

      STORE TRIM(TEMP1) + "." + TRIM(TEMP2) TO POS

     CASE CURRENT = "D"

      @ 23, 3 SAY "Enter the Comparison DATE : "

      STORE DATE() TO DATER
      @ 23,31 GET DATER
      READ

      STORE "CTOD(" + "'" + DTOC(DATER) + "'" + ")" TO POS

     CASE CURRENT = "L"

      @ 23, 2 SAY "Enter the (T)rue or (F)alse : "


      STORE SPACE(FIELD_LEN) TO QSTRING
      DO WHILE .NOT. QSTRING$'TFtf'
           STORE SPACE(FIELD_LEN) TO QSTRING
           @ 23,32 GET QSTRING
           READ
      ENDDO

      STORE "." + TRIM(QSTRING) + "." TO POS

ENDCASE

IF LEN(TRIM(POS)) + TP + 1 >= 78
     STORE LINE + 1 TO LINE
     STORE 1 TO TP
     SET COLOR TO N/W
     @    LINE, 0 SAY SPACE(80)
     SET COLOR TO W/N
ENDIF

SET COLOR TO N/W
@ LINE,TP SAY TRIM(POS)
SET COLOR TO W/N
STORE COL() + 1 TO TP

DO POSITION

STORE " " TO POS,OPER1
@ 15, 0 CLEAR

RETURN


PROCEDURE PUNCT

DO BOTTOMA

@ 23,24 SAY "Do you want PARENTHESIS? (Y/N) "
STORE " " TO ANSWER
DO WHILE .NOT. ANSWER$'YNyn'
     STORE " " TO ANSWER
     @ 23,56 GET ANSWER PICTURE 'A'
     READ
ENDDO

@ 22, 0 CLEAR

IF UPPER(ANSWER) = "Y"
     DO BOTTOMA
     @ 23,20 SAY "Around (1) Group #1 or (2) Group #2 : "
     STORE " " TO ANS1
     DO WHILE .NOT. ANS1$'12'
      STORE " " TO ANS1
      @ 23,59 GET ANS1 PICTURE '9'
      READ
     ENDDO
     @ 22, 0 CLEAR
ELSE
     STORE "0" TO ANS1
ENDIF

DO CASE
     CASE ANS1 = "1"
     IF AT('$',POS5) <> 0
         STORE TRIM(POS11) TO POS13
         STORE TRIM(POS10) TO POS12
         STORE TRIM(POS9) TO POS11
         STORE TRIM(POS8) TO POS10
         STORE TRIM(POS7) TO POS9
         STORE TRIM(POS6) TO POS8
         STORE ")" TO POS7
         STORE TRIM(POS5) TO POS6
         STORE TRIM(POS4) TO POS5
         STORE TRIM(POS3) TO POS4
         STORE TRIM(POS2) TO POS3
         STORE TRIM(POS1) TO POS2
         STORE "(" TO POS1
     ELSE
         STORE TRIM(POS11) TO POS13
         STORE TRIM(POS10) TO POS12
         STORE TRIM(POS9) TO POS11
         STORE TRIM(POS8) TO POS10
         STORE ")" TO POS9
         STORE TRIM(POS7) TO POS8
         STORE TRIM(POS6) TO POS7
         STORE TRIM(POS5) TO POS6
         STORE TRIM(POS4) TO POS5
         STORE TRIM(POS3) TO POS4
         STORE TRIM(POS2) TO POS3
         STORE TRIM(POS1) TO POS2
         STORE "(" TO POS1
     ENDIF

     CASE ANS1 = "2"
       STORE ")" TO POS13
       STORE TRIM(POS11) TO POS12
       STORE TRIM(POS10) TO POS11
       STORE TRIM(POS9) TO POS10
       STORE TRIM(POS8) TO POS9
       STORE TRIM(POS7) TO POS8
       STORE TRIM(POS6) TO POS7
       STORE TRIM(POS5) TO POS6
       STORE "(" TO POS5
       STORE TRIM(POS4) TO POS4
       STORE TRIM(POS3) TO POS3
       STORE TRIM(POS2) TO POS2
       STORE TRIM(POS1) TO POS1

ENDCASE

STORE TRIM(POS1) + A + TRIM(POS2) + A + TRIM(POS3) + A + TRIM(POS4) + A + TRIM(POS5) + A + TRIM(POS6) + A + TRIM(POS7) + A + TRIM(POS8) + A + TRIM(POS9) + A + TRIM(POS10) + A + TRIM(POS11) + A + TRIM(POS12) + A + TRIM(POS13) TO BIGSTRING
STORE TRIM(BIGSTRING) TO BIGSTRING

@ 13, 0 CLEAR
SET COLOR TO N/W
@ 13, 0 SAY " "
@ 13, 1 SAY BIGSTRING
SET COLOR TO W/N

RETURN


PROCEDURE APPROVE

DO BOTTOMA

STORE " " TO QUEST3
@ 23,20 SAY "IS SEARCH CRITERIA CORRECT? (Y/N/Q)"
DO WHILE .NOT. QUEST3$'YNynQq'
     STORE " " TO QUEST3
     @ 23,56 GET QUEST3 PICTURE 'A'
     READ
ENDDO
@ 22, 0 CLEAR

DO CASE
     CASE UPPER(QUEST3) = "Y"
      STORE 99 TO STOP
      STORE 0 TO STOPFLAG

     CASE UPPER(QUEST3) = "Q"
      STORE 99 TO STOP
      STORE 99 TO STOPFLAG

     CASE UPPER(QUEST3) = "N"
      STORE 1 TO TP
      STORE 13 TO LINE
      STORE 0 TO STOP,QFIELD,DECIMAL,STOP,STOPFLAG
      STORE SPACE(1) TO CURRENT
      STORE SPACE(1) TO POS,POS1,POS2,POS3,POS4,POS5,POS6,POS7,POS8,POS9,POS10,POS11,POS12,POS13
ENDCASE

RETURN



PROCEDURE QUEST1

DO BOTTOMA

STORE " " TO QUEST1
@ 23,30 SAY "IS THIS ALL? (Y/N)"
DO WHILE .NOT. QUEST1$'YNyn'
     STORE " " TO QUEST1
     @ 23,50 GET QUEST1 PICTURE 'A'
     READ
ENDDO
@ 22, 0 CLEAR
RETURN



PROCEDURE BOTTOMA
@ 22, 0 CLEAR
@ 22, 0 SAY "╔══════════════════════════════════════════════════════"
@ 22,55 SAY "════════════════════════╗"
@ 23, 0 SAY "║"
@ 23,79 SAY "║"
@ 24, 0 SAY "╚══════════════════════════════════════════════════════"
@ 24,55 SAY "════════════════════════╝"
RETURN

PROCEDURE POSITION
DO CASE
     CASE POS1 = " "
      STORE POS TO POS1
     CASE POS2 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS1) TO POS1
      ELSE
           STORE POS TO POS2
      ENDIF

     CASE POS3 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS2) TO POS2
      ELSE
           STORE POS TO POS3
      ENDIF

     CASE POS4 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS3) TO POS3
      ELSE
           STORE POS TO POS4
      ENDIF

     CASE POS5 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS4) TO POS4
      ELSE
           STORE POS TO POS5
      ENDIF

     CASE POS6 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS5) TO POS5
      ELSE
           STORE POS TO POS6
      ENDIF

     CASE POS7 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS6) TO POS6
      ELSE
           STORE POS TO POS7
      ENDIF

     CASE POS8 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS7) TO POS7
      ELSE
           STORE POS TO POS8
      ENDIF

     CASE POS9 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS8) TO POS8
      ELSE
           STORE POS TO POS9
      ENDIF

     CASE POS10 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS9) TO POS9
      ELSE
           STORE POS TO POS10
      ENDIF

     CASE POS11 = " "
      IF OPER1 = "7"
           STORE TRIM(POS) + TRIM(POS10) TO POS10
      ELSE
           STORE POS TO POS11
      ENDIF

ENDCASE
RETURN