|
midrange.com
Does your AS/400 have SQL? Test by executing the command STRSQL. If it does
then use embedded SQL. Use the following sequence:
* ...
D CustMastDS E DS extname(CMastR) prefix(DS)
* ...
C/EXEC SQL
C+ Declare Cur1 Cursor for
C+ Select * from CMastR where Cphone like :phone
C/END-EXEC
C/EXEC SQL
C+ Open Cur1
C/END-EXEC
C/EXEC SQL
C+ Fetch Cur1 into :CustMastDS
C/END-EXEC
C DOW SQLCOD=0
C* process the entry.
C* ...
* Get next list entry.
C/EXEC SQL
C+ Fetch Cur1 into :CustMastDS
C/END-EXEC
C EndDo
C/EXEC SQL
C+ Close Cur1
C/END-EXEC
C* ...
If your phone number is numeric then you might have to change to:
Select * from CMastR where digits(Cphone) like :phone
To test using the STRSQL command use
Select * from CMastR where digits(Cphone) like '708'
PHayes1@Prodigy.net on 04/28/2000 07:29:54 AM
Please respond to RPG400-L@midrange.com@Internet
To: RPG400-L@midrange.com@Internet
cc:
Fax to:
Subject: Numeric search on Phone number
Greetings,
I am finishing up my last program as part of a group project at school.
The problem is being able to search a phone number by 1 or all 10 digits of
a phone number. E.g., if the user types 708 the user should see all of the
708 and above.
I know there are some very smart programmers who know how to solve this.
Qddssrc(display file)
A DSPSIZ(24 80 *DS3)
A REF(DATADICT)
A CA03(03)
A CA05(05)
A CF06(06)
A CF07(07)
A CA12(12)
A INDARA
A HELP
A ALTHELP(CA01)
A HLPTITLE('Search Name Help')
A HLPPNLGRP(EXTENDED PNL001)
û A*****************************************************************
û A* RECORD FORMAT FOR THE HEADER SCREEN
û A*****************************************************************
A R HEADER
A 1 3'SearchPDW'
A COLOR(BLU)
A 1 34'MORAINE VALLEY'
A COLOR(WHT)
A 1 71TIME
A COLOR(BLU)
A 2 3'PAH'
A COLOR(BLU)
A 2 33'MORTGAGE COMPANY'
A COLOR(WHT)
A 2 70DATE(*SYS *YY)
A EDTCDE(Y)
A COLOR(BLU)
A 3
-
-
A '
A DSPATR(UL)
A COLOR(BLU)
û A*****************************************************************
û A* WINDOW RECORD
û A*****************************************************************
A R PROMPT
A****** OVERLAY
A KEEP
A WINDOW(9 15 5 46 *NOMSGLIN)
A WDWBORDER((*COLOR BLU) +
A (*DSPATR RI) +
A (*CHAR ' '))
A WDWTITLE((*TEXT 'Customer
Search'))
A WDWTITLE((*TEXT +
A 'F3=Exit F5=Refresh')(*BOTTOM))
A H HLPARA(*FLD PHONE)
A HLPPNLGRP('PHONE' PNL001 )
A 3 1'Search Phone'
A PHONE R B 3 16REFFLD(CPHONE CMASTR)
A 50 DSPATR(RI PC) COLOR(RED)
û A*****************************************************************
A*Subfile Record Format - LIST OF NAMES THAT MEET THE INQUIRY
û A*****************************************************************
A R SFL01 SFL
A 77 SFLNXTCHG
A SELECT 1 0B 10 13DSPATR(UL)
A EDTCDE(4)
A 60 DSPATR(RI PC) COLOR(RED)
A SCLNAME R B 10 21REFFLD(@LNAME)
A 41 DSPATR(PR)
A SCFNAME R B 10 43REFFLD(@FNAME)
A 41 DSPATR(PR)
A SCPHONE R Y B 10 60REFFLD(@PHONE)
A 41 DSPATR(PR)
A EDTWRD('0( )& - ')
A EDTMSK('& && & ')
A SCNUMBR R H REFFLD(@CNUM)
A SCADDR1 R H REFFLD(@ADD1)
A SCCITY R H REFFLD(@CITY)
A SCSTATE R H REFFLD(@STATE)
A SCZIPCD R H REFFLD(@ZIP)
A SCEMAIL R H REFFLD(@EMAIL)
A*
û A*****************************************************************
û A* SUBFILE CONTROL RECORD - LIST OF NAMES MEETING INQUIRY
û A*****************************************************************
A R CTL01 SFLCTL(SFL01)
A SFLSIZ(0007)
A SFLPAG(0006)
A OVERLAY
A 40 SFLCLR
A 43 SFLDSPCTL
A 42 SFLDSP
A 92 SFLEND(*MORE)
A CSRLOC(OUTROW OUTCOL)
A DSPREC 4S 0H SFLRCDNBR
A OUTROW 3S 0H
A OUTCOL 3S 0H
A 4 14'CUSTOMERS WITH LAST NAME
BEGINNING-
A WITH:'
A COLOR(WHT)
A PHONE 10Y 0O 4 55COLOR(RED)
A 6 2'Type option, press Enter.'
A COLOR(BLU)
A N42 DSPATR(ND)
A 7 2'1=Select'
A COLOR(BLU)
A N42 DSPATR(ND)
A 9 11'SELECT'
A COLOR(WHT)
A DSPATR(UL)
A 9 21'LAST NAME'
A COLOR(WHT)
A DSPATR(UL)
A 9 43'FIRST NAME'
A COLOR(WHT)
A DSPATR(UL)
A 9 60'PHONE NO.'
A COLOR(WHT)
A DSPATR(UL)
û A*****************************************************************
û A* RECORD FORMAT FOR THE 3RD SCREEN DISPLAY
û A*****************************************************************
A R CHANGEWDW
A OVERLAY
A WINDOW(8 24 13 53 *NOMSGLIN)
A WDWTITLE((*TEXT 'Customer
Date -
A -
A SearchWDW') *LEFT)
A WDWBORDER((*COLOR BLU) (*DSPATR
RI)-
A (*CHAR ' '))
A WDWTITLE((*TEXT 'F3=Exit
F5=Refre-
A sh F12=Cancel') *LEFT *BOTTOM)
A H HLPARA(*FLD WCLNAME)
A HLPPNLGRP(DLNAME PNL001)
A H HLPARA(*FLD WCFNAME)
A HLPPNLGRP(DFNAME PNL001)
A H HLPARA(*FLD WCADDR1)
A HLPPNLGRP(DDSTRET PNL001)
A H HLPARA(*FLD WCCITY)
A HLPPNLGRP(DCITY PNL001)
A H HLPARA(*FLD WCZIPCD)
A HLPPNLGRP(DZIP PNL001)
A H HLPARA(*FLD WCPHONE)
A HLPPNLGRP(DPHONE PNL001)
A H HLPARA(*FLD WCEMAIL)
A HLPPNLGRP(DEMAIL PNL001)
A 2 2'Make Changes, Press ENTER'
A COLOR(BLU)
A 4 2'Custoemr Number:'
A 5 2'First Name.....:'
A 6 2'Last Name......:'
A 7 2'Address........:'
A 8 2'City...........:'
A 9 2'State..........:'
A 10 2'Zip Code.......:'
A 11 2'Phone Number...:'
A 12 2'Email Address..:'
A WCNUMBR R O 4 19REFFLD(@CNUM)
A EDTCDE(4)
A WCFNAME R B 5 19REFFLD(@FNAME)
A WCLNAME R B 6 19REFFLD(@LNAME)
A WCADDR1 R B 7 19REFFLD(@ADD1)
A WCCITY R B 8 19REFFLD(@CITY)
A WCSTATE R B 9 19REFFLD(@STATE)
A WCZIPCD R B 10 19REFFLD(@ZIP)
A WCPHONE R Y B 11 19REFFLD(@PHONE)
A EDTWRD('0( )& - ')
A EDTMSK('& && & ')
A WCEMAIL R B 12 19REFFLD(@EMAIL)
A COLOR(RED)
û A*****************************************************************
û A* RECORD FORMAT FOR THE FOOTER
û A*****************************************************************
A R FOOTER
A OVERLAY
A 23 2'F3=Exit'
A COLOR(BLU)
A 23 12'F5=Refresh'
A COLOR(BLU)
A 23 26'F12=Cancel'
A COLOR(BLU)
û A*****************************************************************
û A* ERROR MESSAGE SUBFILE RECORD FOR THE WINDOW
û A*****************************************************************
A R WMSGSFL SFL
A SFLMSGRCD(13)
A MSGKEY SFLMSGKEY
A PGMQ SFLPGMQ
û A*****************************************************************
û A* ERROR MESSAGE CONTROL RECORD FOR THE WINDOW
û A*****************************************************************
A R WMSGCTL SFLCTL(WMSGSFL)
A WINDOW(CHANGEWDW)
A OVERLAY
A N39 SFLDSPCTL SFLDSP SFLINZ SFLEND
A SFLSIZ(2)
A SFLPAG(1)
A @PGMQ SFLPGMQ
û A*****************************************************************
û A* RECORD FORMAT FOR THE ERROR MESSAGE SUBFILE
û A*****************************************************************
A R MSGSFL SFL
A SFLMSGRCD(24)
A MSGKEY SFLMSGKEY
A @PGMQ SFLPGMQ
û A*****************************************************************
û A* RECORD FORMAT FOR THE ERROR MESSAGE CONTROL RECORD
û A*****************************************************************
A R MSGCTL SFLCTL(MSGSFL)
A OVERLAY
A N39 SFLDSPCTL SFLDSP SFLINZ SFLEND
A SFLSIZ(2)
A SFLPAG(1)
A @PGMQ SFLPGMQ
A*----------------------------------------------------------*
A* Subfile Control Record for the Error Message
A*----------------------------------------------------------*
A R DUMMY
A ASSUME
A 1 2' '
*
and here is the RPGLESRC program
û ***************** FILE SPECIFICATIONS ***********************
û *
û * Progam Name: SearchPhone For: Moraine Valley Mortgage
û * Author: Phil Hayes
û * Completion Date:
û *
û * Purpose: Display customers based on search criteria of first two
û * letters of the last name. User can then select the
û * customer in which they want to view the complete
information
û * on in another display record.
û *
û *----------------------------------------------------------------
û * File Specification for this program
û *----------------------------------------------------------------
7 FCMastR IF E K DISK
7 FCMastLP# UF E K DISK RENAME(CMAST1:CMAST2)
7 FSearchPDW CF E WORKSTN
7 F SFILE(SFL01 :RRN1)
7 F INFDS(CMDkey)
7 F INDDS(DispInds)
û *--------------------------------------------------------------------*
û * Data structure for the message API's. *
û *--------------------------------------------------------------------*
Æ D DS INZ
Æ D @Stk 1 4B 0
Æ D @Len 5 8B 0 inz(80)
Æ D @Err 9 12B 0
û
Æ D @MsgF S 20 Inz('ERRMSGS *LIBL')
Æ D @Key S 4 Inz(' ')
Æ D @Rmv S 10 Inz('*ALL')
Æ D @MsgID S 7
Æ D @Dta S 80
Æ D @Type S 10 Inz('*DIAG')
û *----------------------------------------------------------------
û * Convert Lower Case to Upper Case
û *----------------------------------------------------------------
D Aphone S 10
Æ D Uc C
CONST('ABCDEFGHIJKLMNOPQRSTUVWXYZ')
Æ D Lc C
CONST('abcdefghijklmnopqrstuvwxyz')
*
Æ D CMDkey DS
Æ D Key 369 369
û *
Æ D Sdata1 E DS Extname(CmastL) Prefix(S)
Æ D Wdata1 E DS Extname(CmastL) Prefix(w)
Æ D Fdata1 E DS Extname(CmastL)
û *
û *---------------------------------------------------------------------
û * Defining Stand alone Variables used inside this PGM.
û *---------------------------------------------------------------------
Æ D LLimit S 20 INZ(*LoVal)
Æ D HLimit S 10 0 INZ(*HiVal)
Æ D VError S 1N INZ(*Off)
D IGotNmbr S 1N INZ(*Off)
D PHiNmbr S 10 0 inz(9999999999)
D RRN1 S 4P 0 INZ(0)
û *----------------------------------------------------------------
û * Data structure INDARA Indicator Array
û *----------------------------------------------------------------
Æ D DispInds DS
Æ D IExit 3 3N
Æ D IRefresh 5 5N
Æ D ICancel 12 12N
Æ D IMsgClr 39 39N
Æ D ISflClr 40 40N
D IDProtKey 41 41n
Æ D ISflDsp 42 42N
Æ D ISflDspCtl 43 43N
Æ D IDSelName 50 50N
Æ D ISflLinErr 60 60N
Æ D ISflNxtChg 77 77N
Æ D ISflMore 92 92N
û *
û *---------------------------------------------------------------------
û * Hexadecimal Constants for all Function Keys used in this PGM.
û *---------------------------------------------------------------------
I/copy inter26/qcpylesrc,cmdkey1
û *----------------------------------------------------------------
û * Mailine Section of the Program
û *----------------------------------------------------------------
C DoU IExit
C
C Write Header
C Write MsgCTL
C ExFmt Prompt
C
C Select
C
C When IExit
C Leave
C
C When ICancel
C Iter
C
C When IRefresh
C ExSr @Refresh
C
C When Key = Enter
C ExSr @LoadSFL
C ExSr @PickName
C
C EndSL
C EndDo
C
û C Eval *Inlr = *On
û *----------------------------------------------------------------
û * @LoadSFL Subrountine
û *----------------------------------------------------------------
Þ CSR @LoadSFL BegSR
C ExSr @ClearSFL
C ExSr @ClearMsg
C Phone SetLL CMastLP#
C Phone CHAIN CMastLP#
C Eval IGotNmbr = Cphone < PHiNmbr
C
C DoW Not %EOF and IGotNmbr = *ON
C Eval ISflLinErr = *Off
C Eval ISflNxtChg = *Off
C Eval IDProtKey= *On
C Eval Sdata1 = Fdata1
C Eval Select = *Zeros
û C Eval RRN1 = RRN1 + 1
û C Write SFL01
C Read CMastLP#
C Eval IGotNmbr = CPhone < PHiNmbr
û C EndDo
û
C If RRN1 = *Zeros
C Eval ISFLDSP = *off
C Eval ISflLinErr = *On
C Eval @msgid = 'ERR0101'
C Eval @dta = APhone
C Eval Outrow = 24
C Eval Outcol = 2
C Call 'QMHSNDPM' ParmSND
û C Else
C Eval ISflDsp = *On
C Eval DspRec = 1
C Eval Outrow = *zeros
C Eval Outcol = *zeros
C End
û C Eval ISflMore = *Off
û C If Not %EOF
C Read CMastLP#
C Eval ISflMore = CPhone < PHiNmbr
C EndIf
û
Þ CSR EndSr
û *--------------------------------------------------------------------*
û * Remove the Message Subfile. *
û *--------------------------------------------------------------------*
Þ CSR @ClearMsg BegSR
û C Eval IMsgclr = *On
û C Write Msgctl
û C Eval IMsgclr = *Off
C Eval @Key = *Blanks
C Call 'QMHRMVPM' ParmRMV
C
Þ CSR EndSR
û *--------------------------------------------------------------------*
û * @ClearSFL Subroutine *
û *--------------------------------------------------------------------*
Þ CSR @ClearSFL BegSR
C Eval RRN1 = 0
û
û C Eval ISflClr = *On
û C Write Ctl01
û C Eval ISflClr = *Off
Þ CSR EndSr
û *----------------------------------------------------------------
û * @Refresh Subroutine
û *----------------------------------------------------------------
Þ CSR @Refresh BegSR
C Clear Phone
Þ CSR EndSR
û *--------------------------------------------------------------------*
û * @PickName Subroutine *
û *--------------------------------------------------------------------*
Þ CSR @PickName BegSR
û
C DoU IExit or ICancel
C Write Header
C Write MsgCTL
C Write Footer
C ExFmt CTL01
C
C Select
C
C When IExit
C Leave
C
C When ICancel
C ExSr @ClearMsg
C Iter
û C When IRefresh
û C Exsr @ClearMsg
û C ExSR @ClearSFL
û C ExSR @LoadSFL
û C When Key = Enter and ISfldsp = *on
û C Exsr @Validate
C EndSL
C EndDo
Þ C EndSr
û *--------------------------------------------------------------------*
û * Read Changed Records In The Subfile To Check For Selection *
û *--------------------------------------------------------------------*
Þ CSR @UpdateWDW BegSR
C DoW Not ICancel
C Eval Wdata1 = Sdata1
C ExFmt ChangeWDW
C Select
C When IExit or ICancel
C Leave
û C When Key = Enter
C Eval Fdata1 = Wdata1
C**************** UpDate CMAST2
C Eval Sdata1 = Wdata1
C Leave
C EndSL
û
û C EndDO
û
Þ CSR EndSR
û *--------------------------------------------------------------------*
û * @Validate Subroutine - Validate Selection Numbers on SFL *
û *--------------------------------------------------------------------*
Þ CSR @Validate BegSR
C ReadC SFL01
C
C DoW not %EOF
C
û C* Edit the Select Screen
C
C Eval ISflLinErr = *Off
C Eval ISflNxtChg = *Off
û C Eval VError = *Off
û C* Edits?
û C If Select <> 0
û C If Select <> 1
û C
û C Eval ISflNxtChg = *On
û C Eval ISflLinErr = *On
û C Eval @msgid = 'ERR0100'
û C Call 'QMHSNDPM' ParmSND
C Else
C Exsr @Updatewdw
C Eval Select = 0
C End
C End
C Update SFL01
û C If ISflNxtChg = *On
C Leave
C End
û C ReadC SFL01
û C
û C EndDO
û C
Þ CSR EndSr
û C
û *--------------------------------------------------------------------*
û * @EditCkWDW Subroutine - Check Window I/P before Posting to the *
û * Data Base File - CMastR.PF
û *--------------------------------------------------------------------*
û C
û *--------------------------------------------------------------------*
û * Initialization Routine
û *--------------------------------------------------------------------*
Þ CSR *InzSR BegSr
C Eval ISflDspCtl = *On
C Eval @PgmQ = '*'
û
C KeyFile KList
C KFld CLName
C KFld CNumbr
C
û * Clears messages from the PGM queue.
7 C ParmRMV Plist
7 C Parm @PgmQ
7 C Parm @Stk
7 C Parm @Key
7 C Parm @Rmv
7 C Parm @Err
û C
û * Sends messges to PGM queue.
7 C ParmSND Plist
7 C Parm @MsgID
7 C Parm @MsgF
7 C Parm @Dta
7 C Parm @Len
7 C Parm @Type
7 c Parm @PgmQ
7 C Parm @Stk
7 C Parm @Key
7 C Parm @Err
Þ CSR EndSr
I hope someone could solve this.
Thank You,
Phil
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.comm
+---
+---
| This is the RPG/400 Mailing List!
| To submit a new message, send your mail to RPG400-L@midrange.com.
| To subscribe to this list send email to RPG400-L-SUB@midrange.com.
| To unsubscribe from this list send email to RPG400-L-UNSUB@midrange.com.
| Questions should be directed to the list owner/operator: david@midrange.com
+---
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2025 by midrange.com and David Gibbs as a compilation work. Use of the archive is restricted to research of a business or technical nature. Any other uses are prohibited. Full details are available on our policy page. If you have questions about this, please contact [javascript protected email address].
Operating expenses for this site are earned using the Amazon Associate program and Google Adsense.
