|
midrange.com
Here is the code.
H bnddir('SVCBNDDIR')
H DFTACTGRP(*NO)
H actgrp(*NEW)
H option(*srcstmt : *nodebugio)
*****************************************************************
* PROGRAM: RUBRTSCHSL *
* PROGRAMMER: Michael Smith *
* DATE: Jan 30, 2006 *
* COMMENTS: Maintain Rate Schedule by Route for RUBS *
*****************************************************************
FRubSqrDt00UF A E K Disk
FRubSqrHd00UF A E K Disk
FUPTP IF E K Disk
FURTE IF E K Disk
FRUBSQENTDFCF E WorkStn Infds( PInfds )
F Sfile( Sdata1 : RcvRrn )
F INDDS(WORKSTNIND)
*
* Subfile page control array
D Ctl S 5 Dim(999)
*
* File information data structure for display file
D PINFDS DS
D #FUNCT 369 369
D #NORIf 156 159B 0
D KEYPRESS 369 369
D CURSOR 370 371B 0
D #SFRRN 376 377B 0
D #RCDNO 378 379B 0
D PGMST SDS
D #PGMNM *PROC
D #ParmS *ParmS
D DSPDEV 244 253
D #USER 254 263
D/copy qrpglesrc,g#prototyp
D/copy qrpglesrc,e#prototyp
*---------------------------------------------------------------------
* Work fields
*---------------------------------------------------------------------
D #Error S 1
D #First S 1
D #No S 1
D #Yes S 1
D Lctl# S Like(RBRTE )
D Pg S 5 0
D RcvRrn S 5 0
D Rmdr S 1 0
D Rrn# S 5 0
D Rrn#E S 5 0
D Rrn#O S 5 0
D Wrk1 S 5 0
D
*---------------------------------------------------------------------
* END of work fields
***********************************************************************
*Display file indicator usage.
***********************************************************************
DMapindsp S * INZ(%Addr(Workstnind))
DMapinds DS BASED(MAPINDSP)
DFunctionKeys 01 30
DErrinds 60 65
DWorkstnind DS
DF2Sort 02 02N
DF3Exit 03 03N
DF4Prompt 04 04N
DF5Refresh 05 05N
DF12Return 12 12N
DPageDown 27 27N
DPageUp 28 28N
DSFLCLR 40 40N
DSFLDSPCTL 41 41N
DSFLDSP 42 42N
DSFLINZ 43 43N
DSFLDLT 44 44N
DErrTyp 61 61N
DErrEntry 62 62N
DRteErr 63 63N
DSFLEND 99 99N
*---------------------------------------------------------------------
*
*
C DoU F3Exit
C Write MSGCTL1
C Write Foot1
C Eval SFLDSPCTL = *ON
C ExFmt SCTL1
C Callp g#ClrMsgSF
* Mainline logic
*
* Display subfile control record format to get batch
* number. Then position file to read any existing
* records in that batch.
*
C If Not F3Exit
C ExSr @Setup
C If RteErr = *off
*
*
* Display selection window
C DoU F3Exit Or
C F12Return
* Fill subfile
C ExSr @Load
*
C DoU F3Exit Or
C F12Return
C Write MSGCTL1
C Eval SFLDSPCTL = *On
C Eval SFLDSP = *On
C Write Foot1
C ExFmt SCTL1
C Eval SFLDSPCTL = *Off
C Eval SFLDSP = *Off
C* these are error messages- change to normal methods
C Eval *IN71 = *Off
C Eval *IN72 = *Off
C Eval ErrTyp = *Off
C Callp g#ClrMsgSF
*
* - - - - - - - - - - - - - - - *
* Process function key requests *
* - - - - - - - - - - - - - - - *
*
* Exit or Cancel request
C If F3Exit Or
C F12Return
C Leave
C EndIf
*
* Prompt request
C If F4Prompt
C ExSr @Prmpt
C Iter
C EndIf
*
* Refresh request
C If F5Refresh
C
C Eval RBPRMTYP = Ctl( Pg )
C ExSr @Repos
C**** Eval SFLDSP = *ON
C Leave
C EndIf
*
* User request position to new name
C If Route <> RBRTE
C ExSr @Setup
C Leave
C EndIf
*
* Page up for previous records
C If PageUp
C If Pg > 1
C Eval Pg = Pg - 1
C Eval RBPRMTYP = Ctl( Pg )
C ExSr @Repos
C Leave
C Else
C MOVE 'RGM0001' #MSGID 7
C CallP G#AddMsgSF(#MSGID:' ':'RGCMSGF')
C**** Eval *IN63 = *On
C Iter
C EndIf
C EndIf
*
* Page down for more records
C If PageDown
C If Sflend = *Off
C Eval Pg = Pg + 1
C 15 Chain Sdata1 21
C Eval RBPRMTYP = CtlSav
C ExSr @Repos
C Leave
C Else
C MOVE 'RGM0002' #MSGID
C CallP G#AddMsgSF(#MSGID:' ':'RGCMSGF')
C*** Eval *IN64 = *On
C Iter
C EndIf
C EndIf
*
* - - - - - - - - - - - - - - - - - - - *
* Process subfile records from screen *
* - - - - - - - - - - - - - - - - - - - *
*
C ExSr @Read
*
* End of DO Loops for F03 or F12 key
*
C EndDo
C EndDo
C Eval SFLDSP = *OFF
C Eval SFLDSPCTL = *OFF
C Eval SFLCLR = *ON
C Write SCTL1
C Eval SFLCLR = *OFF
C EndIf
C EndIf
C EndDo
*
* Update batch header file record when exiting program
C ExSr @BchUp
*
* - - - - - - - - - *
* End of Program *
* - - - - - - - - - *
*
C Eval *INLR = *On
C Return
*
* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
*
* Subroutines
*
*==============================================================*
* Set up for new batch number *
*==============================================================*
*
C @Setup BegSr
*
C* validate the Route prior to anything else
C Route Setll URTE
C If %equal(urte)
* Update batch header file record
C ExSr @BchUp
*
* Initialize batch number
C Eval RBRTE = Route
* Retrieve or create batch header record
C RBRTE Chain RUBSQRHD00 21
C If *IN21 = *Off
C Eval TotSqrFoot = RBTSQRFT
C Else
C Eval RBTSQRFT = 0
C Eval TotSqrFoot = 0
C Write RBSQHDF
C RBRTE Chain RUBSQRHD00 21
C EndIf
*
C RBRTE Setll RUBSQRDT00
C Clear Ctl
C Reset Pg
C Else
C Eval RteErr = *On
C MOVE 'RGM0015' #MSGID
C CallP G#AddMsgSF(#MSGID:' ':'RGCMSGF')
C EndIf
*
C EndSr
*
*==============================================================*
* Reposition file for next subfile page *
*==============================================================*
*
C @Repos BegSr
*
* Reposition file
C BdKey Setll RUBSQRDT00
*
C EndSr
*
*==============================================================*
* Load database records into new subfile page *
*==============================================================*
*
C @Load BegSr
*
* Clear subfile
C Eval SFLCLR = *On
C Write SCTL1
C Eval SFLCLR = *Off
*
* Reset error indicators
C Eval *IN61 = *Off
C Eval *IN62 = *Off
*
* Reset work values
C Reset RcvRrn
C Reset Rrn#
C Reset Rrn#O
C Reset Rrn#E
C Reset #First
*
* Load up to 15 records into subfile page
C DO 15 Rrn#
*
C RBRTE ReadE RUBSQRDT00
99
* Load existing DB record
C If *IN99 = *Off
C Eval CtlSav = RBPRMTYP
C Eval Route = RBRTE
C Eval PRMTYP = RBPRMTYP
C Eval SQFOOT = RBSQRFT
C Eval UNITS = RBNBRUNT
C Else
C Eval SflEnd = *On
C Clear Sdata1
C EndIf
*
C Eval RcvRrn = RcvRrn + 1
* Only for very first record
C If RcvRrn = 1
C Eval Ctl(Pg) = RBPRMTYP
C EndIf
* Only when encountering first blank subfile record
C If #First = #Yes And
C CtlSav = *Blanks
C Eval LCtl# = RBRTE
C Eval RcdNbr = RcvRrn
C Eval #First = #No
C EndIf
* Write subfile record
C Write Sdata1
*
C EndDo
*
C EndSr
*
*=====================================*
* Read subfile records from screen *
*=====================================*
*
C @Read BegSr
*
* Reset work values
C Reset #Error
C Reset RcvRrn
C Reset Rrn#
C Reset Rrn#O
C Reset Rrn#E
C Reset #First
*
* Read all 15 records from display in alternating (left, right)
* sequence to emulate the correct keying order in columns
*
C Do 15 Rrn#
*
C Eval RcvRrn = Rrn#
*
* Process changed subfile records
C RcvRrn Chain Sdata1 21
C Clear Errinds
*
* - - - - - - - - - - - - - - - - - - - - - - - - -
* If user made selection,
* If NCust# <> 0, then adding or changing record
* Verify that all fields have values
* Verify that customer exists
* If CtlSav (hidden in subfile) = 0,
* then adding a new record
* If CtlSav <> 0, then changing record
* Else NCust# = 0, either no entry or deleting
* If CtlSav (hidden in subfile) = 0,
* then just clear all subfile fields
* If CtlSav <> 0, then delete existing record
* - - - - - - - - - - - - - - - - - - - - - - - - -
*
* Reset error indicators
C Eval *IN61 = *Off
C Eval *IN62 = *Off
*
* Adding or changing a record.
C If PRMTYP <> *Blanks
C Eval #First = #Yes
* Verify values
C If UNITS = 0 Or
C SQFOOT = 0
C MOVE ' ' #MSGID 7
C CALLP G#AddMsgSF(#MSGID:'Must enter Units
and-
C Footage':'RGCMSGF')
C Eval Errentry = *On
C Eval #Error = #Yes
C Eval RcdNbr = RcvRrn
C Update Sdata1
C Eval Errentry = *Off
C Leave
C Else
* Verify customer number
C PRMTYP Chain UPTP 61
C If Not %Found(UPTP)
C Eval ErrTyp = *On
C MOVE 'RGM0037' #MSGID 7
C CALLP G#AddMsgSF(#MSGID:' ':'RGCMSGF')
C Eval #Error = #Yes
C Eval RcdNbr = RcvRrn
C Update SData1
C Eval ErrTyp = *Off
C Leave
C Else
C If CtlSav = *Blanks
C Bdkey1 Chain RUBSQRDT00
C If %Found(RUBSQRDT00)
C Eval #Error = #Yes
C Eval RcdNbr = RcvRrn
C Eval ErrTyp = *On
C MOVE 'RGM0006' #MSGID
C CALLP G#AddMsgSF(#MSGID:' ':'RGCMSGF')
C Update SData1
C Eval ErrTyp = *Off
C Leave
* Add
C Else
C If CtlSav = *Blanks
C ExSr @Add
* Change
C Else
C ExSr @Updat
C EndIf
C EndIf
C Else
C ExSr @Updat
C EndIf
C EndIf
C EndIf
* Deleting record
C Else
C If PRMTYP = *BLanks
C If CtlSav <> *Blanks
C ExSr @Delet
* Just clearing record and rewriting
C Else
C Clear SData1
C Update Sdata1
C If #First = #Yes
C Eval RcdNbr = RcvRrn
C Eval #First = #No
C EndIf
C EndIf
C EndIf
C EndIf
*
*
* End of DO 15 loop for next subfile record
C EndDo
*
C If #Error = #No
C 15 Chain Sdata1 21
C If *IN21 = *Off And
C PRMTYP <> *BLanks
C Eval *in99 = *Off
C EndIf
C EndIf
*
C EndSr
*
*========================*
* Add a record *
*========================*
*
C @Add BegSr
*
* Add record to file
C Eval RBRTE = Route
C Eval RBPRMTYP = PRMTYP
C Eval RBSQRFT = SqFoot
C Eval RBNBRUNT = Units
C Write RBSQDTF
*
* Adjust batch total
C Eval TOTSQRFOOT = TOTSQRFOOT + (SqFoot *
Units)
*
* Update subfile record
C Eval *IN61 = *Off
C Eval *IN62 = *Off
C Eval CtlSav = RBPRMTYP
C Eval RcdNbr = RcvRrn
C Update Sdata1
*
C EndSr
*
*========================*
* Change a record *
*========================*
*
C @Updat BegSr
*
C******** Eval ArCtl# = CtlSav
C BdKey2 Chain RUBSQRDT00 21
*
C Eval TotSqrFoot = TotSqrFoot -(RBSQRFT *
RBNBRUNT)
C Eval RBRTE = Route
C Eval RBPRMTYP = PRMTYP
C Eval RBSQRFT = SqFoot
C Eval RBNBRUNT = Units
C Eval TotSqrFoot = TotSqrFoot +(RBSQRFT *
RBNBRUNT)
*
C Update RBSQDTF
*
* Update subfile record
C Eval *IN61 = *Off
C Eval *IN62 = *Off
C Eval RcdNbr = RcvRrn
C Update Sdata1
*
C EndSr
*
*
*========================*
* Delete a record *
*========================*
*
C @Delet BegSr
*
C BdKey2 Chain RUBSQRDT00 21
*
C Delete RUBSQRDT00
*
* Adjust batch total
C Eval TotSqrFoot = TotSqrFoot -(RBSQRFT *
RBNBRUNT)
*
* Update subfile record
C Eval *IN61 = *Off
C Eval *IN62 = *Off
C Clear Sdata1
C Eval RcdNbr = RcvRrn
C Update Sdata1
*
C EndSr
*
*
*==============================================================*
* Update Batch Header *
*==============================================================*
*
C @BchUp BegSr
*
* Update batch header file record
C If RBRTE <> 0
C Eval RBTSQRFT = TotSqrFoot
C Update RBSQHDF
C EndIf
*
C EndSr
*
*==============================================================*
* Prompt for Customer Number *
*==============================================================*
*
C @Prmpt BegSr
*
C CsrRrn Chain Sdata1 21
* If CURSOR ON Route FIELD THEN ALLOW PROMPT
C If (CSRFLD = 'PRMTYP') AND
C (CSRRCD = 'SDATA1 ')
C
C call 'WINPROMPT'
C Parm 'UPTP ' #FILE 10
C Parm '*LIBL ' #LIB 10
C Parm 'UIPPT ' #FIELD 10
C Parm 'UIDES ' #FIELD1 10
C Parm #RTNVAL 128
* Did program return a number?
C If #RTNVAL > *BLANKS
C Eval PRMTYP = #RTNVAL
C EndIf
C If PRMTYP <> *Blanks
C Eval *IN60 = *On
C Update SData1
C Eval *IN60 = *Off
C EndIf
C Eval RcdNbr = RcvRrn
C EndIf
C EndSr
C
*
*========================*
* *INZSR *
*========================*
*
C *INZSR BegSr
C move *blanks #title 50
C move *blanks #titl2 50
C Eval #TITLE = G#AlignCtr(E#CoName(1))
C Eval #TITL2 = 'Rubs Square Footage
Entry'
C Eval #TITL2 = G#ALignCtr(#TITL2)
* Variable declarations
C Eval RcvRrn = 0
C Eval Rrn# = 0
C Eval Rrn#O = 0
C Eval Rrn#E = 16
C Eval Pg = 1
C Eval RcdNbr = 1
C Eval #No = '0'
C Eval #Yes = '1'
C Eval #Error = #No
C Eval #First = #yes
*
* Key list for batch detail file RUBSQRDT00
C BdKey Klist
C Kfld RbRte
C Kfld RbPrmTyp
* Key list for batch detail file RUBSQRDT00
C BdKey1 Klist
C Kfld RbRte
C Kfld PrmTyp
* Key list for batch detail file RUBSQRDT00
C BdKey2 Klist
C Kfld RbRte
C Kfld CtlSav
*
C EndSr
Michael Smith
iSeries.mySeries.
-----Original Message-----
From: rpg400-l-bounces@xxxxxxxxxxxx
[mailto:rpg400-l-bounces@xxxxxxxxxxxx] On Behalf Of Phil Kestenbaum
Sent: Thursday, November 02, 2006 10:35 AM
To: RPG programming on the AS400 / iSeries
Subject: RE: Sfldsp problem
Can you post the code?
-----Original Message-----
From: rpg400-l-bounces@xxxxxxxxxxxx
[mailto:rpg400-l-bounces@xxxxxxxxxxxx] On Behalf Of Smith, Mike
Sent: Thursday, November 02, 2006 10:35 AM
To: rpg400-l@xxxxxxxxxxxx
Subject: Sfldsp problem
I have written a Data entry subfile. First Dataentry subfile I have
written in years and years.
On the SFLCTl is 1 field to enter a route.
Upon entering the route and validating a subfile is displayed with any
existing records and empty subfile lines
When F12 is entered the subfile display is turned off and only the
Subfile Control should be displayed. This is where my problem is. The
Subfile Display continues to show. I have verified that the SFLDSP is
*off . I am using the same indicator to control the headings on the
SFLCTL. These dissappear when F12 is selected, but the subfile does
not.
Anybody encountered this before?
Michael Smith
iSeries.mySeries.
As an Amazon Associate we earn from qualifying purchases.
This mailing list archive is Copyright 1997-2024 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.
