home *** CD-ROM | disk | FTP | other *** search
/ Piper's Pit BBS/FTP: ibm 0010 - 0019 / ibm0010-0019 / ibm0010.tar / ibm0010 / CLIPB52.ZIP / WEBER.ZIP / GET6.PRG < prev    next >
Encoding:
Text File  |  1990-06-01  |  4.9 KB  |  166 lines
  1. #command SAVE GETS => __PushGet()
  2. #command REST GETS => __PopGet()
  3. #define ZipFmt GETLIST[5][5]
  4. #define ZipRow GETLIST[5][1]
  5. #define ZipCol GETLIST[5][2]
  6. *...............................................
  7. * Simple.prg
  8. *
  9. LOCAL Key, choice := 1
  10. USE PGCUS
  11. SET DELETED ON
  12. CLS
  13. @ 05,10 TO 20,70 DOUBLE
  14. @ 07,15 SAY "Name......:"
  15. @ 09,15 SAY "Street....:"
  16. @ 11,15 SAY "City......:"
  17. @ 13,15 SAY "State.....:"
  18. @ 15,15 SAY "Zip.......:"
  19. @ 17,15 SAY "Date/Time.:"
  20. DO WHILE .T.
  21.    @ 07,27 SAY CUSNAME
  22.    @ 09,27 SAY CUSADDR1
  23.    @ 11,27 SAY CUSCITY
  24.    @ 13,27 SAY CUSSTATE
  25.    @ 15,27 SAY CUSZIP
  26.    @ 17,27 SAY DTOC(DATE())+SPACE(5)+TIME()
  27.    choice = BarMenu(@choice)
  28.    DO CASE
  29.       CASE choice==1        && if Add
  30.          Add_Cus()
  31.       CASE choice==2        && if Edit
  32.          EditFlds()
  33.       CASE choice==3        && if Delete
  34.          delete
  35.       CASE choice==4        && if Prev
  36.          SKIP -1
  37.       CASE choice==5        && if Next
  38.          Skip
  39.       CASE choice==6        && if Top
  40.          GO TOP
  41.       CASE choice==7        && if Bottom
  42.          GO BOTT
  43.       CASE choice==8        && if Credit
  44.          PopWindow()
  45.       OTHERWISE             && Quit
  46.          EXIT
  47.    ENDCASE
  48. ENDDO
  49. @ 23,0
  50. *....................................................
  51. FUNCTION BarMenu
  52. *....................................................
  53. PARAMETER opt
  54. SET MESSAGE TO 24
  55. SET WRAP ON
  56. @ 23,0
  57. @ 23,0       PROMPT "Add"    MESSAGE "Add a record"
  58. @ 23,COL()+2 PROMPT "Edit"   MESSAGE "Edit record"
  59. @ 23,COL()+2 PROMPT "Del"    MESSAGE "Delete Record"
  60. @ 23,COL()+2 PROMPT "Prev"   MESSAGE "Go To Previous record"
  61. @ 23,COL()+2 PROMPT "Next"   MESSAGE "Go To Next Record"
  62. @ 23,COL()+2 PROMPT "Top"    MESSAGE "Go To First Record"
  63. @ 23,COL()+2 PROMPT "Bottom" MESSAGE "Go To Last Record"
  64. @ 23,COL()+2 PROMPT "Credit" MESSAGE "View Credit Info"
  65. @ 23,COL()+2 PROMPT "Quit"   MESSAGE "Quit the System"
  66. MENU TO Opt
  67. @ 23,0 CLEAR TO 24,79
  68. RETURN (opt)
  69. *....................................................
  70. PROCEDURE Add_Cus
  71. *....................................................
  72. APPEND BLANK
  73. EditFlds()
  74. RETURN
  75. *....................................................
  76. PROCEDURE PopWindow
  77. *....................................................
  78. LOCAL oldwin
  79. oldwin = SAVESCREEN(11,30,19,65)
  80. @ 11,30 CLEAR TO 19,65
  81. @ 11,30 TO 19,65 DOUBLE
  82. @ 13,35 SAY "Credit Limit..: "+STR(CUSCRELIM,5)
  83. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  84. @ 16,35 SAY "Strike a key to return"
  85. INKEY(0)
  86. RESTSCREEN(11,30,19,65,oldwin)
  87. RETURN
  88. *....................................................
  89. PROCEDURE EditFlds
  90. *....................................................
  91. LOCAL CUSNAME,CUSADDR1,CUSCITY,CUSSTATE,CUSZIP
  92. SET KEY -3 TO ChgZip        && F4 runs ChgZip
  93. SET KEY -4 TO EditCred      && F5 runs EditCred
  94.  
  95. M->CUSNAME  := FIELD->CUSNAME
  96. M->CUSADDR1 := FIELD->CUSADDR1
  97. M->CUSCITY  := FIELD->CUSCITY
  98. M->CUSSTATE := FIELD->CUSSTATE
  99. M->CUSZIP   := FIELD->CUSZIP
  100.  
  101. @ 07,27 GET M->CUSNAME VALID NotNan(M->CUSNAME)
  102. @ 09,27 GET M->CUSADDR1 PICTURE "@!"
  103. @ 11,27 GET M->CUSCITY PICTURE "@!"
  104. @ 13,27 GET M->CUSSTATE WHEN !EMPTY(M->CUSCITY) PICTURE "@A!" ;
  105.                         VALID M->CUSSTATE $ "GA|CA|NY|IL"
  106. @ 15,27 GET M->CUSZIP PICTURE ZipPic()
  107. READ
  108.  
  109. FIELD->CUSNAME  := M->CUSNAME
  110. FIELD->CUSADDR1 := M->CUSADDR1
  111. FIELD->CUSCITY  := M->CUSCITY
  112. FIELD->CUSSTATE := M->CUSSTATE
  113. FIELD->CUSZIP   := M->CUSZIP
  114.  
  115. SET KEY -3 TO
  116. SET KEY -4 TO
  117. RETURN
  118. *.............................................................
  119. FUNCTION NotNan(Comp)
  120. *.............................................................
  121. LOCAL retval := .T.
  122. IF Comp = "Nantucket"
  123.    @ 23,0 SAY "Sorry, we won't sell to those dead beats!"
  124.    ?? chr(7)           && ring the bell
  125.    retval = .F.
  126. ELSE
  127.    @ 23,0
  128. ENDIF
  129. RETURN retval
  130.  
  131. *..............................................................
  132. PROCEDURE ChgZip(Call_Prg, Line_Num, Input_Var)
  133. *..............................................................
  134. IF ZipFmt == "99999"
  135.    ZipFmt := ZipPic("99999-9999")
  136. ELSE
  137.    ZipFmt := ZipPic("99999")
  138. ENDIF
  139. @ ZipRow, ZipCol SAY SPACE(10)
  140. RETURN
  141.  
  142. *..............................................................
  143. FUNCTION ZipPic(NewPic)      && returns current zip or new zip
  144. *                            && if passed
  145. *..............................................................
  146. STATIC ZPict := "99999-9999"
  147. RETURN IF(VALTYPE(NewPic)=="C", (ZPict := NewPic), ZPict)
  148.  
  149. *.............................................................
  150. PROCEDURE EditCred(Call_Prg, Line_Num, Input_Var)
  151. *.............................................................
  152. LOCAL oldwin
  153. SAVE GETS
  154. oldwin = SAVESCREEN(11,30,19,65)
  155. @ 11,30 CLEAR TO 19,65
  156. @ 11,30 TO 19,65 DOUBLE
  157. M->CUSCRELIM := FIELD->CUSCRELIM
  158. @ 13,35 SAY "Credit Limit..:" GET M->CUSCRELIM PICT "99999"
  159. @ 14,35 SAY "Credit Avail..: "+STR(CUSCREAVA,5)
  160. @ 16,35 SAY "Enter New Credit Limit"
  161. READ
  162. FIELD->CUSCRELIM := M->CUSCRELIM
  163. RESTSCREEN(11,30,19,65,oldwin)
  164. REST GETS
  165. RETURN
  166.