home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Share Gallery 1
/
share_gal_1.zip
/
share_gal_1
/
DB
/
DB012A.ZIP
/
VPI1_330.ZIP
/
REGISTER.PRG
< prev
next >
Wrap
Text File
|
1992-01-03
|
16KB
|
512 lines
*************************************************************************
** REGISTER.PRG
** (C) Copyright 1990-91, Sub Rosa Publishing Inc.
**
** A demonstration program provided to VP-Info users.
** This program may be copied freely. If it is used in commercial code,
** please credit the source, Sub Rosa Publishing Inc.
**
** REGISTER demonstrates the use of the VP-Info in filling out and
** printing a standard form...in this case, a registration for for
** VP-Info Level 1. Full documentation may be found by running
** SAMPLES program.
**
** REGISTER is compatible with all current versions of VP-Info.
**
** Sid Bursten and Bernie Melman
***************************************************************************
SET function off ; we want the raw function keys - not the pre-loaded messages.
SET text off ; reset this to default...turn on only when needed
SET trim off ; do not have output macros (&-type) automatically trimmed
SET upper on ; force all keyboard input to capital letters
SET exact off ; ensure default in use for comparisons
ON escape
:color=:serial ;restores default color to what it was on entry
WINDOW
CURSOR 22,0
SET text off
SET upper off
SET function on
CANCEL
ENDON
DIM num look[10] ;declare an array for credit card validation
REPEAT 5 times varying nn ;initialize its values in a loop
look[nn]=nn*2-2
look[nn+5]=nn*2-1
ENDREPEAT
DIM char 25 message[6] ;declare an array for messages and fill it
message[1]='5.25-inch disks'
message[2]='3.5-inch disks'
message[3]='VISA Credit Card'
message[4]='MasterCard'
message[5]='Check or Money Order'
message[6]='Company Purchase Order'
************************* set up colors properly ********************
DIM num ncolor[5],rcolor[5]
IF type(:serial)<>'N'
:serial=:color
ENDIF
IF :serial<>7 ;color monitor in use
ncolor[1]= 62 ; yellow on green
rcolor[1]= 99
ncolor[2]=107 ; blue on brown
rcolor[2]= 56
ncolor[3]= 31 ; white on blue
rcolor[3]=113
ncolor[4]=111 ; white on blue
rcolor[4]=119
ELSE
ncolor[1]=7
rcolor[1]=112
ncolor[2]=7
rcolor[2]=112
ncolor[3]=7
rcolor[3]=112
ncolor[4]=7
rcolor[4]=112
ENDIF
:color=ncolor[4]
********* define variables we need customer to fill in ********
name=blank(30)
company=blank(30)
add1=blank(30)
add2=blank(30)
city=blank(20)
state=blank(2)
fstate=blank(6)
zip=blank(10)
country=blank(15)
phone=blank(10)
hphone=blank(10)
fax=blank(10)
shiptoname=blank(30)
shiptocomp=blank(30)
shiptoadd1=blank(30)
shiptoadd2=blank(30)
shiptocity=blank(20)
shiptost=blank(2)
shiptozip=blank(10)
fshipstate=blank(6)
shiptocnt=blank(15)
disktype=0
cardtype=0
cardnum=blank(16)
cardexp=blank(4)
cardname=blank(30)
******************* initialize variables needed internally ********
qty1=0
qty2=0
qty3=0
qty4=0
qty5=0
qty6=0
qty7=0
qty8=0
qty9=0
tot1=0
tot2=0
tot3=0
tot4=0
tot5=0
tot6=0
tot7=0
tot8=0
tot9=0
price1=100
IF date(1)>'9202' ;introductory prices end effective March 1/92
price2=295
price3=649
price4=649
price5=995
ELSE
price2=189
price3=289
price4=369
price5=569
ENDIF
price6=35
price7=189
price8=25
price9=40
ship=0
mintax=0
onttax=0
gst=0
total=0
city_state=0
cl=0
cn=0
csum=0
digit=0
disksize=0
doublemod=0
expiry=' '
merror=0
ok=0
paytype=0
provinces='BC,AB,SK,MN,ON,QC,PE,NB,NS,NF,YT,NT'
scr_name=' '
screen=0
selection=0
shiptoc_s=0
total2=0
valid=t
*********************** start the program itself ********************
DO WHILE t ;put main menu in an infinite loop
SET WIDTH to 80
IF disktype=0 ;no need for menu when no information yet entered
selection=1
ELSE
SCREEN 2
screen=4
:color=ncolor[screen]
COLOR :color,0,0,24,79,177 ;fill screen with pattern
* ; 177 is the fill character '▒'.
COLOR 128,7,15,21,70 ;draw black box to become shadow
WINDOW 6,12,19,67 DOUBLE color :color ;declare space for menu text
TEXT
VP-INFO REGISTRATION & ORDER MENU
0. Exit to Sample Programs Menu
1. Fill in VP-Info Registration/Order Form
2. Print Completed Order
ENDTEXT
CURSOR 12,15 ; positions menu cursor over 1st character of 1st choice
SCREEN 1
SCREEN up
selection=menu(2,47) ;two choices, menu bar width 47
ENDIF
DO CASE
CASE selection=0 .or. :key=327 ; <home> key
WINDOW
SET function on
SET text off
SET upper off
:color=:serial ;restores default color to what it was on entry
CHAIN samples
CASE selection=1
SET text on ; allows output macros to be dynamically updated
SET width to 80 ; stops wide text from "wrapping"
screen=1
disktype=1 ; reset here to force menu to come up on <End>
DO WHILE t
scr_name='order.in'+str(screen,1)
SCREEN 2
WINDOW
:color=ncolor[screen]
CLS
CLEAR gets
TEXT &scr_name
CURSOR 23,0
TEXT
1 Screen 1 \2192 Screen 2 \2193 Screen 3 \2194 \2195 \2196 \2197 \2198 \2199 \21910 Next Screen
ENDTEXT
COLOR ncolor[3],23,0,24,79
COLOR rcolor[3],24,1,24,78
DO CASE
CASE screen=1
ON field
FIELD name
:field=field(company)
FIELD company
IF company=' ' .and. name=' '
:field=field(name)
@ 22,0 say cen('Must specify at least NAME or COMPANY.',80)
RING
ELSE
:field=field(add1)
@ 22,0
ENDIF
FIELD add1
:field=field(add2)
FIELD add2
:field=field(city)
FIELD city
:field=field(state)
FIELD state
:field=field(zip)
FIELD zip
IF state=' ' ;enter country only if state is
:field=field(fstate) ; blank. US and Canadian customers
ELSE ; do not need country filled in.
:field=field(phone)
ENDIF
FIELD fstate
:field=field(country)
FIELD country
:field=field(phone)
FIELD phone
:field=field(hphone)
FIELD hphone
:field=field(fax)
FIELD fax
:field=field(shiptoname)
FIELD shiptoname
:field=field(shiptocomp)
FIELD shiptocomp
:field=field(shiptoadd1)
FIELD shiptoadd1
IF shiptoadd1=' '
:field=65
ELSE
IF shiptocomp=' ' .and. shiptoname=' '
:field=field(shiptoname)
@ 22,0 say cen('Must specify at least NAME or COMPANY.',80)
RING
ELSE
:field=field(shiptoadd2)
@ 22,0
ENDIF
ENDIF
FIELD shiptoadd2
:field=field(shiptocity)
FIELD shiptost
:field=field(shiptozip)
FIELD shiptozip ;skip country when state filled in.
IF shiptost=' ' ; same reasons as in 1st column.
:field=field(shiptocnt)
ELSE
:field=65 ;get out immediately
ENDIF
FIELD shiptocnt
:field=65 ;get out immediately
ENDON
:field=1
SCREEN 1
SCREEN tear
READ
CASE screen=2
ON field
FIELD qty1
PERFORM sums
FIELD qty2
PERFORM sums
FIELD qty3
PERFORM sums
FIELD qty4
PERFORM sums
FIELD qty5
PERFORM sums
FIELD qty6
PERFORM sums
FIELD qty7
PERFORM sums
FIELD qty8
PERFORM sums
FIELD qty9
PERFORM sums
:field=field(qty9)
:color=rcolor[screen]
@ 0,20 say ' PRESS F10 WHEN READY FOR NEXT SCREEN '
:color=ncolor[screen]
RING
ENDON
:field=1
SCREEN 1
SCREEN left
READ
CASE screen=3
IF cardname=' '
cardname=name
ENDIF
merror=0
ON field
FIELD cardnum
PERFORM cardvalid
IF .not. valid
:color=rcolor[screen]
@ 5,30 say ' Invalid Card Number '
@ 6,30 say ' Press End to Change Choice.'
SOUND 1
:field=field(cardnum)
:color=ncolor[screen]
ELSE
IF cardtype=4
:field=field(cardname)
ENDIF
ENDIF
FIELD cardexp
merror=0
IF cardtype<3
expiry=right(cardexp,2)+left(cardexp,2)+'28'
DO CASE ;check 1st for valid date, then that it's not past
CASE date(ymd,expiry)=' ' ;DATE( returns blank for bad dates
:color=rcolor[screen]
@ 5,50 say ' Invalid Date '
SOUND 1
merror=1
CASE expiry<left(date(1),4) ;compares year and month only
:color=rcolor[screen]
@ 5,50 say ' Card Expired '
SOUND 1
merror=2
ENDCASE
ENDIF
IF merror>0
DELAY 2
:color=ncolor[screen]
@ 5,50 say blank(20)
:field=field(cardexp)
ENDIF
FIELD cardname
:color=rcolor[screen]
@ 20,20 say ' PRESS <End> KEY WHEN COMPLETED... '
:color=ncolor[screen]
:field=field(cardname)
ENDON
SCREEN 1
@ 5,30 say blank(45)
@ 6,30 say blank(45)
SCREEN right
disktype=0 ; reinitialize type variables so user can fix mistakes
cardtype=0
DO WHILE disktype=0
CURSOR 3,15
disktype=menu(2,20)
IF disktype=0
disktype=1 ;default disk type is 5.25"
ENDIF
ENDDO
@ disktype+2,14 say chr(16)
DO WHILE cardtype=0
CURSOR 8,15
cardtype=menu(4,60)
ENDDO
@ cardtype+7,14 say chr(16)
IF cardtype=3 ;cash requires no credit card or P.O. number
:field=field(cardname)
cardnum=blank(16)
cardexp=blank(4)
ENDIF
@ 20,20 say ' PRESS <End> KEY WHEN COMPLETED... '
READ
PERFORM cardvalid ; do test again to ensure it wasn't bypassed
IF merror>0 .or. .not. valid
disktype=0 ; reinitialize type variables
cardtype=0 ; so user can fix mistakes
merror=0
WINDOW 10,10,16,69 double color rcolor[screen],rcolor[screen]
WINDOW 10,12,16,67 blank
TEXT
Error in Credit Card Number. Press any key to make correction.
ENDTEXT
WINDOW
CURSOR 15,39
ok=inkey()
:color=ncolor[screen]
LOOP
ENDIF
ENDCASE
DO CASE
CASE :key=315
screen=1
CASE :key=316
screen=2
CASE :key=317
screen=3
CASE :key=335
BREAK
OTHERWISE
screen=screen+1 ;cycle through screens
IF screen>3
SOUND 1
screen=1 ;back to beginning
ENDIF
ENDCASE
ENDDO
SET text off
CASE selection=2
IF total>0 .and. cardtype>0 .and. valid ;check that we're ready to print
IF .not. printer() ;check that printer is ready
@ 16,20 say cen('No printer on line.',40)
@ 17,20 say cen('Press a key...',40)
CURSOR 18,39
selection=inkey()
ELSE
WINDOW
screen=4
:color=ncolor[screen]
CLS
if state>' '
city_state=trim(city)+', '+state
else
city_state=trim(city)+', '+fstate
endif
IF shiptost>' '
shiptoc_s=trim(shiptocity)+', '+shiptost
ELSE
shiptoc_s=shiptocity
ENDIF
disksize=message[disktype]
paytype=message[cardtype+2]
CLEAR gets
SET print on
SET width to 100 ;stop long lines from wrapping
TEXT order.out
TEXT order2.out
SET printer off
EJECT
CLS
ENDIF
ELSE
@ 16,20 say cen('No information to print.',40)
@ 17,20 say cen('Press a key, then select option 1...',40)
CURSOR 18,39
selection=inkey()
ENDIF
ENDCASE
ENDDO
*
PROCEDURE sums
tot1=price1*qty1
tot2=price2*qty2
tot3=price3*qty3
tot4=price4*qty4
tot5=price5*qty5
tot6=price6*qty6
tot7=price7*qty7
tot8=price8*qty8
tot9=price9*qty9
total2=tot1+tot2+tot3+tot4+tot5+tot6+tot7+tot8+tot9
DO CASE
CASE left(ltrim(shiptost+state),2)='MN' ;minnesota
mintax=total2*.07
CASE @(left(ltrim(shiptost+state),2),provinces)>0 ;Canadian
gst=(ship+total2)*.07
IF left(ltrim(shiptost+state),2)='ON' ;ontario
onttax=total2*.08
ENDIF
ENDCASE
ship=5+4*(qty1+qty2+qty3+qty4+qty5+qty6+qty7+qty9) ;shipping costs
IF country>' '
ship=ship*2 ;overseas shipping
ENDIF
total=total2+ship+mintax+onttax+gst
ENDPROC sums
*
PROCEDURE cardvalid
IF cardtype>2 ;if not M or V, accept as valid
valid=t ;initialize return value TRUE
ELSE
valid=f ;initialize FALSE and do tests
cn=replace(cardnum#2,' ','') ;remove embedded spaces
cl=len(cn)
IF cn=str(cardtype+3,1) .and. val(cn)>=3*pow(10,cl-1)
IF (cl=13 .and. cardtype=1) .or. (cl=16 .and. cardtype>0)
csum=0
doublemod=mod(cl,2)
REPEAT cl times varying nn
digit=val(substr(cn,nn,1))
csum=csum+iff(mod(nn-1,2)=doublemod,look[digit+1],digit)
ENDREPEAT
valid=(mod(csum,10)=0) ;returns TRUE if checkdigit test works
ENDIF
ENDIF
ENDIF
ENDPROC cardvalid
*
* *** end of program REGISTER.PRG ***