home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
clarion
/
ppstpx.zip
/
OM4.TPX
< prev
next >
Wrap
Text File
|
1993-06-08
|
50KB
|
1,173 lines
#!-------------------------------------------------------------------------------#!
#! OM4.TPX
#!
#! Form : Update a browse or lookup with a form
#! MultiPage Template : Update a file with a multiple page entry form
#! PageOf Template : data entry 'Page' used with the MultiPage Form
#!
#!------------------------------------------------------------------------------
#!
#PROCEDURE(Form,'Update a browse or lookup with a form'),SCREEN,PULLDOWN
#!------------------------------------------------------------------------------
#!
#! The Form Template
#!
#!------------------------------------------------------------------------------
#PROTOTYPE('')
#PROMPT('Insert message',@S20),%InsertMsg
#PROMPT('Chan&ge message',@S20),%ChangeMsg
#PROMPT('De&lete message',@S20),%DeleteMsg
#PROMPT('Action after ADD',OPTION),%AddAction
#PROMPT('Return to caller ',RADIO)
#PROMPT('Retain Record ',RADIO)
#PROMPT('Clear Record ',RADIO)
#PROMPT('Copy field hot&key:',KEYCODE),%CopyKey
#PROMPT('Next Procedure ',PROCEDURE),%NextProcedure
#INSERT(%StandardHeader)
#INSERT(%InitFormSymbols)
%Procedure PROCEDURE
#INSERT(%LocalPPSVariables) #<! Declare Variables PPS
%LocalData
NoMoreFields BYTE(0) !No more fields flag
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
SCREEN %ScreenAttributes,ALRT(%CopyKey)
%ScreenPaintDeclarations
%ScreenStringDeclarations
%ScreenFieldDeclarations
.
#IF(%SharedFiles = %NULL)
SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV)
#ENDIF
#ELSE
%ScreenStructure
#IF(%SharedFiles = %NULL)
SAV:SaveRecord LIKE(%FilePre:Record),PRE(SAV)
#ENDIF
#ENDIF
#ELSE
%ScreenStructure
#ENDIF
%PullDownStructure
#IF(%SharedFiles)
RecordQueue QUEUE,PRE(SAV) !Queue for concurrency checking
SaveRecord LIKE(%FilePre:Record),PRE(SAV) #<!size of primary file record
#FOR(%Field)
#IF(%FieldType = 'MEMO')
SAV:%FieldID STRING(SIZE(%Field))
#ENDIF
#ENDFOR
. #<!End Queue structure
#ENDIF
#IF(%RelatedFiles)
#SET(%SetFile,%Primary)
#INSERT(%RelationalAccessFlds) #<!Declare link fields
#IF(%PrimaryDriver = 'Paradox')
#FIX(%File,%Primary)
UpdRelation STRING(SIZE(%FilePre:Record)) #<!Position of last related record
#ELSE
UpdRelation STRING(10) #<!Position of last related record
#ENDIF
#ENDIF
#IF(%PrimaryDriver = 'Paradox')
#FIX(%File,%Primary)
SavePointer STRING(SIZE(%FilePre:Record)) !Position of current record
AutoAddPtr STRING(SIZE(%FilePre:Record)) !Position of autoinc record
#ELSE
SavePointer STRING(10) !Position of current record
AutoAddPtr STRING(10) !Position of autoinc record
#ENDIF
AutoIncAdd BYTE(0) !On for Autoincrement add
#IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER')
LastPosition STRING(10) !Position of last ADD
#ENDIF
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
#INSERT(%FieldDups)
#ENDIF
#ENDIF
#IF(%PrimeKeysExist)
#INSERT(%SavePrimedFields)
#ENDIF
#EMBED('Data Section')
CODE
ProcedureName = '%Procedure' #<!Fill ProcedureName var. PPS
#EMBED('Setup Procedure')
#INSERT(%FileMgrStart) #<!Insert File Manager. PPS
#IF(%SecondaryExist) #<!IF File schema Secondary
#INSERT(%OpenSecondaryFiles) #!Group from OM9.tpx
#ENDIF
#INSERT(%FieldLookupOpen)
CASE KEYCODE() !What Key was pressed?
OF InsKey !Insert a new record
Action = AddRecord !Set action code 1 (ADD)
#INSERT(%InsertMessage) #<!Message for ADD RECORD
#INSERT(%ClearValues) #<!Clear RECORD and MEMO(s)
#IF(%AutoInc)
DO AutoNumber !Set autonumber key field(s)
#ENDIF
#IF(%InitRoutine) #<!Field(s) initial value
DO InitializeFields !Initial values from dictionary
#ENDIF
OF EnterKey !Process a CHANGE request
OROF MouseLeft2 !on EnterKey or double mouse
Action = ChangeRecord !Set action code 2 (CHANGE)
#INSERT(%ChangeMessage) #<!Message for CHANGE RECORD
#IF(%SharedFiles)
#INSERT(%SetupConcurrency) #<!Setup multi-user Concurrency
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
DO RelationAccessSave !Save LINKS for relational update
#SET(%RelUpdateRoutine,'TRUE')
#ENDIF
OF DelKey !Process a DELETE request
Action = DeleteRecord !Set action code 3 (DELETE)
#INSERT(%DeleteMessage) #<!Message for DELETE RECORD
SavePointer = POSITION(%Primary) #<!Position in PRIMARY file
#IF(%CascadeDelete OR %ClearOnDelete OR %RestrictDelete)
DO RelationAccessSave !Save LINKS for relational update
#SET(%RelDeleteRoutine,'TRUE')
#ENDIF
END !End CASE Keycode
#IF(%SecondaryExist) #<!IF schema has a Secondary
DO SecondaryLookups !Read any lookup fields
#ENDIF
#IF(%PullDownStructure)
OPEN(%PullDown)
#ENDIF
OPEN(Screen) !Open the FORM screen
DISPLAY !Display screen fields
IF Action = DeleteRecord !IF request for DELETE
DISABLE(1,FIELDS()) !Disable all screen fields
ENABLE(?OK) !Enable the OK and the
ENABLE(?Cancel) !Cancel buttons
END !End IF request for delete
#FOR(%Formula)
#IF(UPPER(%FormulaClass) = 'SETUP')
#INSERT(%GenerateFormula)
#ENDIF
#ENDFOR
#EMBED('Setup Screen')
LOOP !Begin Main process loop
#IF(%FormulasExist = 'TRUE') #<!Are there Formula fields?
#SET(%GenerateFormulasOn,'TRUE')
DO FormulaFields !Calculate Formula fields
#ENDIF
#IF(%SecondaryExist) #<!IF File schema has Secondary
#INSERT(%SecondaryChanged)
#ENDIF
CASE SELECTED() !Process selected Field
#INSERT(%ScreenSetupRoutines)
OF NoMoreFields !User pressed Enter or OK
#EMBED('Right Before Action Case Loop') #<!PPS
CASE Action !Process requested Action
OF AddRecord !Action = 1 (ADD)
ADD(%Primary) #<!Add Record to Primary file
#IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER')
LastPosition = POSITION(%Primary)
#ENDIF
OF ChangeRecord !Action = 2 (Change)
#IF(%RestrictUpdate)
#SET(%ChkRestrictUpdate,'TRUE') #!Check for relational RESTRICT
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
#SET(%RelatedUpdateRoutine,'TRUE')
#ENDIF
#IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine))
IF AutoIncAdd #<!Was this an Autonumber?
#IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER')
LastPosition = POSITION(%Primary) #<!Save last record position
#ENDIF
PUT(%Primary) #<!Write the Record
ELSE #<!not AutoincAdd
#ENDIF
#IF(%SharedFiles)
#SET(%ConcurrentWriteOn,'TRUE')
DO ConcurrentWrite !Concurrent update ROUTINE
IF AbortWrite# !AbortWrite is on
CYCLE !Let user choose response
END !End AbortWrite#
#IF(%RelatedUpdateRoutine = %NULL)
PUT(%Primary) #<!Write the Record
#ENDIF
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
DO RelationalUpdate !Relational update ROUTINE
IF AbortTransaction# !AbortTransaction# is ON
SELECT(?Cancel) !Place cursor on Cancel
CYCLE !and restart Accept Loop
END !End AbortTransaction#
#ENDIF
#IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine))
END #<!IF AutoIncAdd
#ENDIF
#IF(%SharedFiles = %NULL)
#IF(%RelatedUpdateRoutine = %NULL)
#IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER')
LastPosition = POSITION(%Primary) #<!Save last record position
#ENDIF
PUT(%Primary) #<!Write the Record
#ENDIF
#ENDIF
OF DeleteRecord !Action = 3 (Delete)
#IF(%RestrictDelete) #<!IF RESTRICT Constraint
DO CheckRestrictedDelete !Check RESTRICT delete
IF RestrictDelete# !If RestrictDelete# is ON
SELECT(?Cancel) !Place cursor on cancel
CYCLE !Restart Loop
END !End IF RestrictDelete#
#SET(%ChkRestrictDelete,'TRUE') #<!RESTRICT delete code
#ENDIF
#IF(%CascadeDelete OR %ClearOnDelete)
#SET(%RelatedDeleteRoutine,'TRUE')
DO RelationalDelete !Relational delete ROUTINE
IF AbortTransaction# !AbortTransaction is on
CYCLE !Let user try again
END !End AbortTransaction
#ELSIF(%SharedFiles)
#SET(%ConcurrentDeleteOn,'TRUE')
DO ConcurrentDelete !Concurrent update ROUTINE
IF AbortDelete# !AbortWrite is on
CYCLE !Restart main Loop
ELSE !Its OK to Delete
DELETE(%Primary) !Delete this record
END !End AbortWrite#
#ELSE
DELETE(%Primary) !Delete this record
#ENDIF
END !End CASE Action
IF ERRORCODE() !Error check on File I/O
#IF(%DupKeyCheck)
#INSERT(%DupKeyCode)
#ENDIF
CASE Action !Error message based on Action
OF AddRecord
GLO:Message1 = 'Error attempting to ADD Record'
OF ChangeRecord
GLO:Message1 = 'Error attempting to CHANGE Record'
OF DeleteRecord
GLO:Message1 = 'Error attempting to DELETE Record'
END !End CASE Action
GLO:Message2 = 'The file: %Primary could not be updated'
GLO:Message3 = 'Code:'&Errorcode()&': '&Error()
ShowWarning !Notify the user
#IF(%SharedFiles)
RELEASE(%Primary) #<!Release the held record
FREE(RecordQueue) !FREE the memory Queue
#ENDIF
DISABLE(1,FIELDS()) !Disable all the fields
ENABLE(?Cancel) !Enable Cancel button
SELECT(?Cancel) !and place cursor on Cancel
DISPLAY !Re-display the screen
CYCLE !Re-start main LOOP
ELSE !Else no errorcode()
#IF(%SharedFiles)
FREE(RecordQueue) !Free memory from Queue
#ENDIF
#IF(%NextProcedure)
#EMBED('Setup Next Procedure')
%NextProcedure #<!Call the Next Procedure
#EMBED('Return from Next Procedure')
#ENDIF
#IF(UPPER(CLIP(%AddAction)) = 'CLEAR RECORD')
IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd)
ERASE #<!Erase screen fields
#INSERT(%InsertMessage) #<!Message for ADD RECORD
DISPLAY !Update screen display
#FIX(%File,%Primary)
CLEAR(%FilePre:Record) #<!Clear the record buffer
#IF(%AutoInc)
DO AutoNumber !Increment autonumber key
DISPLAY !Display screen field
#ENDIF
SELECT(1) !Place cursor on 1st field
CYCLE !Re-start main LOOP
END !End IF (Action = ....)
#ELSIF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
IF (Action = AddRecord) OR (Action = ChangeRecord AND AutoIncAdd)
#IF(%CopyKey <> %NULL)
DO SaveScrFlds #<!Save the Screen fields
ERASE
#INSERT(%InsertMessage) #<!Message for ADD RECORD
DISPLAY !Update screen display
#FIX(%File,%Primary)
CLEAR(%FilePre:Record) #<!Clear the record buffer
#ELSE
#IF(%AutoInc)
SAV:SaveRecord = %FilePre:Record #<!Save the record buffer
#ENDIF
#ENDIF
#IF(%AutoInc)
DO AutoNumber !Increment autonumber key
%FilePre:Record = SAV:SaveRecord #<!Restore saved record
#INSERT(%RestoreAuto) #<!Restore AutoNumber(s)
DISPLAY !Display screen fields
#ENDIF
SELECT(1) !Place cursor on 1st field
CYCLE !Re-start main LOOP
END !End IF (Action = ....)
#ENDIF #!End %AddAction code
BREAK !Break from main Loop
END !End IF Errorcode()
END !End CASE Selected()
ACCEPT !Enable screen entry
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
#INSERT(%DupFldCall)
#ENDIF
#ENDIF
#! Moved if hotkeyexist to after case keycode() PPS
CASE KEYCODE()
#IF(%HotKeysExist)
#FOR(%HotKey)
OF %HotKey !User defined HotKey
%HotKeyProc !HotKey Procedure
#ENDFOR
#ENDIF
#INSERT(%FileMgrView) #!Insert File Manager View PPS
END !End CASE Keycode
CASE FIELD() !Process fields
#INSERT(%FormEditRoutines)
OF ?Ok !On the OK button
#EMBED('OK Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Ok')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field Edit procedure
#ENDIF
#ENDIF
#ENDFOR
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
OF ?Cancel !On Cancel button
#IF(%AutoInc = 'TRUE')
IF AutoIncAdd !ADDed autoincrement record?
RESET(%Primary,AutoAddPtr) #<!Re-position record pointer
NEXT(%Primary) #<!Re-read the record we added
IF DiskError('Could not READ Record') !Check for file I/O error
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !Return to caller
END !End IF Diskerror
DELETE(%Primary) #<!DELETE the record
IF DiskError('Record could not be Deleted')
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !Return to caller
END !End IF Diskerror
END !End IF AutoIncAdd
#ENDIF
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Cancel')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field edit procedure
#ENDIF
#ENDIF
#ENDFOR
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
#IF(UPPER(CLIP(%AddAction)) <> 'RETURN TO CALLER')
RESET(%Primary,LastPosition) #<!Position to record we added
NEXT(%Primary) #<!and re-read
#ENDIF
BREAK !Break from main LOOP
END !End CASE FIELD
END !END MAIN PROCESS LOOP
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
#FOR(%Formula)
#IF(UPPER(%FormulaClass) = 'RETURN')
#INSERT(%GenerateFormula)
#ENDIF
#ENDFOR
#EMBED('End of Procedure')
#INSERT(%FileMgrExit) #!Insert File Manager Exit PPS
#INSERT(%AutoIncCode)
#INSERT(%ConcurrentWrite)
#IF(%RelUpdateRoutine OR %RelDeleteRoutine)
#INSERT(%RelUpdSave)
#ENDIF
#INSERT(%RelUpdate)
#IF(%ChkRestrictUpdate)
#INSERT(%RestrictUpdateCheck)
#ENDIF
#INSERT(%RelDelete)
#INSERT(%ConcurrentDelete)
#INSERT(%ClearOnDeleteCode)
#IF(%CascadeUpdate = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%ClearOnUpdate = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%ClearOnDelete = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%CascadeDelete = 'TRUE')
#INSERT(%CheckTransaction)
#ENDIF
#IF(%CascadeDeleteOn)
#INSERT(%CascadeDeleteCode)
#ENDIF
#IF(%ChkRestrictDelete)
#INSERT(%RestrictDeleteCode)
#ENDIF
#INSERT(%InitQue)
#INSERT(%InitFields)
#INSERT(%GenFormulas)
#IF(%SecondaryExist)
#INSERT(%SecondaryLookups)
#ENDIF
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
#INSERT(%SaveScrFlds)
#INSERT(%DupField)
#ENDIF
#ENDIF
#!***************************************************************************
#!-------------------------------------------------------------------------------#!
#!
#! Multi-Page Form Update a browse or lookup with multiple pages
#!
#!------------------------------------------------------------------------------
#!
#PROCEDURE(MultiPage,'Multiple Page update form '),SCREEN,PULLDOWN
#!------------------------------------------------------------------------------
#! OM4.TPX
#!
#! Multi-Page Template: Update a file with a multiple page entry form
#!
#!------------------------------------------------------------------------------
#PROTOTYPE('')
#PROMPT('Insert message',@S20),%InsertMsg
#PROMPT('Chan&ge message',@S20),%ChangeMsg
#PROMPT('De&lete message',@S20),%DeleteMsg
#PROMPT('2nd Page Procedure ',PROCEDURE),%Page2Proc
#PROMPT('3rd Page Procedure ',PROCEDURE),%Page3Proc
#PROMPT('4th Page Procedure ',PROCEDURE),%Page4Proc
#PROMPT('5th Page Procedure ',PROCEDURE),%Page5Proc
#PROMPT('6th Page Procedure ',PROCEDURE),%Page6Proc
#PROMPT('7th Page Procedure ',PROCEDURE),%Page7Proc
#PROMPT('8th Page Procedure ',PROCEDURE),%Page8Proc
#PROMPT('9th Page Procedure ',PROCEDURE),%Page9Proc
#PROMPT('Next Procedure ',PROCEDURE),%NextProcedure
#INSERT(%StandardHeader)
#INSERT(%InitFormSymbols)
#INSERT(%ProcCounter)
%Procedure PROCEDURE
#INSERT(%LocalPPSVariables) #<! Declare Variables PPS
%LocalData
SaveAction BYTE
CheckRequired BYTE(4)
NoMoreFields BYTE(0) !No more fields flag
SCREEN %ScreenAttributes,ALRT(Alt2,Alt%ProcCount)
%ScreenPaintDeclarations
%ScreenStringDeclarations
%ScreenFieldDeclarations
.
%PullDownStructure
#IF(%SharedFiles)
RecordQueue QUEUE,PRE(SAV)
SaveRecord LIKE(%FilePre:Record),PRE(SAV)
#FOR(%Field)
#IF(%FieldType = 'MEMO')
SAV:%FieldID STRING(SIZE(%Field))
#ENDIF
#ENDFOR
. #<!End Queue structure
#ENDIF
#IF(%RelatedFiles)
#SET(%SetFile,%Primary)
#INSERT(%RelationalAccessFlds) #<!Declare link fields
#IF(%PrimaryDriver = 'Paradox')
#FIX(%File,%Primary)
UpdRelation STRING(SIZE(%FilePre:Record)) #<!Position of last related record
#ELSE
UpdRelation STRING(10) #<!Position of last related record
#ENDIF
#ENDIF
#IF(%PrimaryDriver = 'Paradox')
#FIX(%File,%Primary)
SavePointer STRING(SIZE(%FilePre:Record)) !Position of current record
AutoAddPtr STRING(SIZE(%FilePre:Record)) !Position of autoinc record
#ELSE
SavePointer STRING(10) !Position of current record
AutoAddPtr STRING(10) !Position of autoinc record
#ENDIF
AutoIncAdd BYTE(0) !On for Autoincrement add
ProcCalls BYTE,DIM(%ProcCount)
#EMBED('Data Section')
CODE
ProcedureName = '%Procedure' #<!Fill ProcedureName var. PPS
#EMBED('Setup Procedure')
#INSERT(%FileMgrStart) #<!Insert File Manager. PPS
#IF(%SecondaryExist) #<!IF File schema Secondary
#INSERT(%OpenSecondaryFiles)
#ENDIF
LOC:Pages = %ProcCount #<!PageOf procedure count
LOC:Page = 1 !Initialize page
CASE KEYCODE() !What Key was pressed?
OF InsKey !Insert a new record
Action = AddRecord !Set action code 1 (ADD)
#INSERT(%InsertMessage) #<!Message for ADD RECORD
#INSERT(%ClearValues) #<!Clear RECORD and MEMO(s)
#IF(%AutoInc)
DO AutoNumber !Set autonumber key field(s)
#ENDIF
#IF(%InitRoutine) #<!Field(s) initial value
DO InitializeFields !Initial values from dictionary
#ENDIF
OF EnterKey !Process a CHANGE request
OROF MouseLeft2 !on EnterKey or double mouse
Action = ChangeRecord !Set action code 2 (CHANGE)
#INSERT(%ChangeMessage) #<!Message for CHANGE RECORD
#IF(%SharedFiles)
#INSERT(%SetupConcurrency) #<!Setup multi-user Concurrency
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
DO RelationAccessSave !Save LINKS for relational update
#SET(%RelUpdateRoutine,'TRUE')
#ENDIF
#IF(%SecondaryExist) #<!IF File schema Secondary
DO SecondaryLookups !Read any lookup fields
#ENDIF
OF DelKey !Process a DELETE request
Action = DeleteRecord !Set action code 3 (DELETE)
#INSERT(%DeleteMessage) #<!Message for DELETE RECORD
SavePointer = POSITION(%Primary) #<!Position in PRIMARY file
#IF(%CascadeDelete OR %ClearOnDelete OR %RestrictDelete)
DO RelationAccessSave !Save LINKS for relational update
#SET(%RelDeleteRoutine,'TRUE')
#ENDIF
#IF(%SecondaryExist) #<!IF File schema Secondary
DO SecondaryLookups !Read any lookup fields
#ENDIF
END !End CASE Keycode
#IF(%PullDownStructure)
OPEN(%PullDown)
#ENDIF
OPEN(Screen) !Open the FORM screen
DISPLAY !Display screen fields
IF Action = DeleteRecord !IF request for DELETE
DISABLE(1,FIELDS()) !Disable all screen fields
ENABLE(?OK) !Enable the OK and the
ENABLE(?Cancel) !Cancel buttons
ENABLE(?Next_Page)
END !End IF request for delete
#FOR(%Formula)
#IF(UPPER(%FormulaClass) = 'SETUP')
#INSERT(%GenerateFormula)
#ENDIF
#ENDFOR
#EMBED('Setup Screen')
LOOP !Begin Main process loop
#IF(%FormulasExist = 'TRUE') #<!Are there Formula fields?
#SET(%GenerateFormulasOn,'TRUE')
DO FormulaFields !Calculate Formula fields
#ENDIF
#IF(%SecondaryExist) #<!IF File schema Secondary
#INSERT(%SecondaryChanged)
#ENDIF
CASE SELECTED() !Process selected Field
#INSERT(%ScreenSetupRoutines)
OF NoMoreFields !User pressed Enter or OK
#EMBED('Right Before Action Case Loop') #<! PPS
CASE Action !Process requested Action
OF AddRecord !Action = 1 (ADD)
ADD(%Primary) #<!Add Record to Primary file
OF ChangeRecord !Action = 2 (Change)
#IF(%RestrictUpdate)
#SET(%ChkRestrictUpdate,'TRUE') #!Check for relational RESTRICT
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
#SET(%RelatedUpdateRoutine,'TRUE')
#ENDIF
#IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine))
IF AutoIncAdd #<!Was this an Autonumber?
PUT(%Primary) #<!Write the Record
ELSE #<!not AutoincAdd
#ENDIF
#IF(%SharedFiles)
#SET(%ConcurrentWriteOn,'TRUE')
DO ConcurrentWrite !Concurrent update ROUTINE
IF AbortWrite# !AbortWrite is on
CYCLE !Let user choose response
END !End AbortWrite#
#IF(%RelatedUpdateRoutine = %NULL)
PUT(%Primary) #<!Write the Record
#ENDIF
#ENDIF
#IF(%CascadeUpdate OR %ClearOnUpdate OR %RestrictUpdate)
DO RelationalUpdate !Relational update ROUTINE
IF AbortTransaction# !AbortTransaction# is ON
SELECT(?Cancel) !Place cursor on Cancel
CYCLE !and restart Accept Loop
END !End AbortTransaction#
#ENDIF
#IF((%AutoInc AND %SharedFiles) OR (%AutoInc AND %RelatedUpdateRoutine))
END #<!IF AutoIncAdd
#ENDIF
#IF((%SharedFiles = %NULL) OR (%RelatedUpdateRoutine = %NULL))
PUT(%Primary) #<!Write the Record
#ENDIF
OF DeleteRecord !Action = 3 (Delete)
#IF(%RestrictDelete) #<!IF RESTRICT Constraint
DO CheckRestrictedDelete !Check RESTRICT delete
IF RestrictDelete# !If RestrictDelete# is ON
SELECT(?Cancel) !Place cursor on cancel
CYCLE !Restart Loop
END !End IF RestrictDelete#
#SET(%ChkRestrictDelete,'TRUE') #<!RESTRICT delete code
#ENDIF
#IF(%CascadeDelete OR %ClearOnDelete)
#SET(%RelatedDeleteRoutine,'TRUE')
DO RelationalDelete !Relational delete ROUTINE
IF AbortTransaction# !AbortTransaction is on
CYCLE !Let user try again
END !End AbortTransaction
#ELSIF(%SharedFiles)
#SET(%ConcurrentDeleteOn,'TRUE')
DO ConcurrentDelete !Concurrent update ROUTINE
IF AbortDelete# !AbortWrite is on
CYCLE !Restart main Loop
ELSE !Its OK to Delete
DELETE(%Primary) !Delete this record
END !End AbortWrite#
#ELSE
DELETE(%Primary) !Delete this record
#ENDIF
END !End CASE Action
IF ERRORCODE() !Error check on File I/O
#IF(%DupKeyCheck)
#INSERT(%DupKeyCode)
#ENDIF
CASE Action !Error message based on Action
OF AddRecord
GLO:Message1 = 'Error attempting to ADD Record'
OF ChangeRecord
GLO:Message1 = 'Error attempting to CHANGE Record'
OF DeleteRecord
GLO:Message1 = 'Error attempting to DELETE Record'
END !End CASE Action
GLO:Message2 = 'The file: %Primary could not be updated'
GLO:Message3 = 'Code:'&Errorcode()&': '&Error()
ShowWarning !Notify the user
#IF(%SharedFiles)
RELEASE(%Primary) #<!Release the held record
FREE(RecordQueue) !FREE the memory Queue
#ENDIF
DISABLE(1,FIELDS()) !Disable all the fields
ENABLE(?Cancel) !Enable Cancel button
SELECT(?Cancel) !and place cursor on Cancel
DISPLAY !Re-display the screen
CYCLE !Re-start main LOOP
ELSE !Else no errorcode()
#IF(%SharedFiles)
FREE(RecordQueue) !Free memory from Queue
#ENDIF
#IF(%NextProcedure)
#EMBED('Setup Next Procedure')
%NextProcedure #<!Call the Next Procedure
#EMBED('Return from Next Procedure')
#ENDIF
BREAK !Break from main Loop
END !End IF Errorcode()
END !End CASE Selected()
ACCEPT !Enable screen entry
CASE KEYCODE()
#FOR(%HotKey)
OF %HotKey !User defined HotKey
%HotKeyProc #<!HotKey Procedure
#ENDFOR
#INSERT(%AltKeys)
#INSERT(%FileMgrView) #!Insert File Manager View PPS
END !End CASE Keycode
CASE FIELD() !Process fields
#INSERT(%FormEditRoutines)
OF ?Ok !On the OK button
#EMBED('OK Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Ok')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field Edit procedure
#ENDIF
#ENDIF
#ENDFOR
#IF(%Page2Proc)
IF Action <> DeleteRecord
SaveAction = Action
Action = CheckRequired
LOC:Message = 'Verify Required Field(s)'
LOOP LOC:Page = 1 to %ProcCount
IF ProcCalls[LOC:Page] !If the Page has been called
CYCLE !then check the next page
ELSE !Call the Page for CheckRequired
#IF(%Page2Proc)
EXECUTE (LOC:Page)
%Page2Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#IF(%Page3Proc)
%Page3Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page4Proc)
%Page4Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page5Proc)
%Page5Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page6Proc)
%Page6Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page7Proc)
%Page7Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page8Proc)
%Page8Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
#IF(%Page9Proc)
%Page9Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
#ENDIF
END !End Execute LOC:Page
END !END IF Page was called
#ENDIF
#ENDIF #<!Are there any Pages?
END !END LOOP for required fields
Action = SaveAction !Save the user Action
END !End if Action <> delete
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
OF ?Next_Page !On the Next Page button
#EMBED('Next Page Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Next_Page')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field Edit procedure
#ENDIF
#ENDIF
#ENDFOR
#IF(%Page2Proc)
LOC:Page += 1
LOOP
IF (LOC:Page - 1) = 0 THEN BREAK.
EXECUTE (LOC:Page - 1)
BEGIN
ProcCalls[LOC:Page - 1] = 1
%Page2Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#IF(%Page3Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page3Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page4Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page4Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page5Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page5Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page6Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page6Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page7Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page7Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page8Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page8Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
#IF(%Page9Proc)
BEGIN
ProcCalls[LOC:Page] = 1
%Page9Proc(Action,LOC:Page,LOC:Pages,LOC:Message) !Call Page procedure
.
#ENDIF
. !End Execute LOC:Page
END !End LOOP
#ENDIF
OF ?Cancel !On Cancel button
#IF(%AutoInc = 'TRUE')
IF AutoIncAdd !ADDed autoincrement record?
RESET(%Primary,AutoAddPtr) #<!Re-position record pointer
NEXT(%Primary) #<!Re-read the record we added
IF DiskError('Could not READ Record') !Check for file I/O error
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !And return to caller
END !End IF Diskerror
DELETE(%Primary) #<!DELETE the record
IF DiskError('Record could not be Deleted')
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !And return to caller
END !End IF Diskerror
END !End IF AutoIncAdd
#ENDIF
#IF(%SharedFiles = 'TRUE')
FREE(RecordQueue) !Free the memory Queue
#ENDIF
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Cancel')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field edit procedure
#ENDIF
#ENDIF
#ENDFOR
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
BREAK !Break from main LOOP
END !End CASE FIELD
END !END MAIN PROCESS LOOP
#EMBED('End of Procedure')
#INSERT(%FileMgrExit) #!Insert File Manager Exit PPS
#INSERT(%AutoIncCode)
#INSERT(%ConcurrentWrite)
#IF(%RelUpdateRoutine OR %RelDeleteRoutine)
#INSERT(%RelUpdSave)
#ENDIF
#INSERT(%RelUpdate)
#IF(%ChkRestrictUpdate)
#INSERT(%RestrictUpdateCheck)
#ENDIF
#INSERT(%RelDelete)
#INSERT(%ConcurrentDelete)
#INSERT(%ClearOnDeleteCode)
#IF(%CascadeUpdate = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%ClearOnUpdate = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%ClearOnDelete = 'TRUE')
#INSERT(%CheckTransaction)
#ELSIF(%CascadeDelete = 'TRUE')
#INSERT(%CheckTransaction)
#ENDIF
#IF(%CascadeDeleteOn)
#INSERT(%CascadeDeleteCode)
#ENDIF
#IF(%ChkRestrictDelete)
#INSERT(%RestrictDeleteCode)
#ENDIF
#INSERT(%InitQue)
#INSERT(%InitFields)
#INSERT(%GenFormulas)
#IF(%SecondaryExist)
#INSERT(%SecondaryLookups)
#ENDIF
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
#INSERT(%SaveScrFlds)
#INSERT(%DupField)
#ENDIF
#ENDIF
#!***************************************************************************
#!-------------------------------------------------------------------------------#!
#!
#! PageOf the Multi-Page Form - A single page of a multiple page form
#!
#!------------------------------------------------------------------------------
#!
#PROCEDURE(PageOf,'Page of Multi-Page forms '),SCREEN,PULLDOWN
#PROTOTYPE('(BYTE,*BYTE,BYTE,STRING)')
#!------------------------------------------------------------------------------
#! OM4.TPX
#!
#! PageOf Template: a data entry 'Page' used with the MultiPage Form
#!
#!------------------------------------------------------------------------------
#INSERT(%StandardHeader)
#INSERT(%InitFormSymbols)
#INSERT(%ButtonCheck)
%Procedure PROCEDURE(Action,Page,Pages,Message)
#INSERT(%LocalPPSVariables) #<! Declare Variables PPS
%LocalData
NoMoreFields BYTE(0) !No more fields flag
CheckRequired BYTE(4)
NonStop BYTE
SCREEN %ScreenAttributes
%ScreenPaintDeclarations
%ScreenStringDeclarations
%ScreenFieldDeclarations
.
%PullDownStructure
#EMBED('Data Section')
CODE
ProcedureName = '%Procedure' #<!Fill ProcedureName var. PPS
#EMBED('Setup Procedure')
#INSERT(%FileMgrStart) #<!Insert File Manager. PPS
#IF(%SecondaryExist) #<!IF File schema Secondary
#INSERT(%OpenSecondaryFiles)
#ENDIF
#INSERT(%FieldLookupOpen)
PAG:Message = Message !Move to local variable
PAG:Page = Page !Move to local variable
PAG:Pages = Pages !Move to local variable
CASE Action !What Action requested?
#IF(%SecondaryExist) #<!IF File schema Secondary
OF ChangeRecord !Process a CHANGE request
DO SecondaryLookups !Read any lookup fields
#ENDIF
#IF(%SecondaryExist) #<!IF File schema Secondary
OF DeleteRecord !Process a DELETE request
DO SecondaryLookups !Read any lookup fields
#ENDIF
OF CheckRequired !Check REQ fields
NonStop = 1
END !End CASE Action
OPEN(Screen) !Open the FORM screen
DISPLAY !Display screen fields
IF Action = DeleteRecord !IF request for DELETE
DISABLE(1,FIELDS()) !Disable all screen fields
ENABLE(?Next_Page) !Enable just the
ENABLE(?Previous_Page) !useful buttons
ENABLE(?Base_Page) !useful buttons
ENABLE(?Last_Page) !useful buttons
END !End IF request for delete
#EMBED('Setup Screen')
LOOP !Begin Main process loop
#IF(%FormulasExist = 'TRUE') #<!Are there Formula fields?
#SET(%GenerateFormulasOn,'TRUE')
DO FormulaFields !Calculate Formula fields
#ENDIF
#IF(%SecondaryExist) #<!IF File schema Secondary
#INSERT(%SecondaryChanged)
#ENDIF
IF NonStop !Just check for required fields
SELECT(1) !Start at first field
SELECT !and enter Nonstop mode
NonStop = 0 !Switch indicator off
END #<!End If
CASE SELECTED() !Process selected Field
#INSERT(%ScreenSetupRoutines)
OF NoMoreFields !All fields have been processed
#IF(%DupKeyCheck)
#INSERT(%DupKeyCode)
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !Return to caller
END !End CASE Selected()
ACCEPT !Enable screen entry
CASE KEYCODE() !Process Alerted keys
#FOR(%HotKey)
OF %HotKey #<!User HotKey
%HotKeyProc #<!Call HotKey procedure
#ENDFOR
#INSERT(%FileMgrView) #!Insert File Manager View PPS
OF CtrlPgUp
Page = 1 !Decrement Page
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
OF CtrlPgDn
Page = Pages !Decrement Page
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
OF EscKey
Page -= 1 !Decrement Page
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN !Return to caller
END ! End CASE
CASE FIELD() !Process fields
#INSERT(%FormEditRoutines)
#IF(%BasePageExists)
OF ?Base_Page !On the Base Page button
#EMBED('Base_Page Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Base_Page')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field Edit procedure
#ENDIF
#ENDIF
#ENDFOR
Page = 1 !Set to the MultiPage
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
#ENDIF
OF ?Previous_Page !On Previous Page button
#EMBED('Previous_Page Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Previous_Page')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field edit procedure
#ENDIF
#ENDIF
#ENDFOR
Page -= 1 !Decrement Page number
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
OF ?Next_Page !On Next Page button
#EMBED('Next_Page Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Next_Page')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field edit procedure
#ENDIF
#ENDIF
#ENDFOR
Page += 1 !Increment Page number
IF PAGE > PAGES THEN PAGE = 1.
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
#IF(%LastPageExists)
OF ?Last_Page !On Last Page button
#EMBED('Last_Page Button Press')
#FOR(%ScreenField)
#IF(%ScreenFieldUse = '?Last_Page')
#IF(%ScreenFieldEdit <> %NULL)
%ScreenFieldEdit #<!Field edit procedure
#ENDIF
#ENDIF
#ENDFOR
Page = Pages !Pages holds LAST page proc
SELECT(1) !Start with the first field
SELECT !and cycle non-stop
CYCLE !restart main process loop
#ENDIF
END !End CASE FIELD
END !END MAIN PROCESS LOOP
#EMBED('End of Procedure')
#INSERT(%FileMgrExit) #!Insert File Manager Exit PPS
#INSERT(%GenFormulas)
#IF(%SecondaryExist)
#INSERT(%SecondaryLookups)
#ENDIF
#IF(UPPER(CLIP(%AddAction)) = 'RETAIN RECORD')
#IF(%CopyKey)
#INSERT(%SaveScrFlds)
#INSERT(%DupField)
#ENDIF
#ENDIF
#INSERT(%InitFields)
#!***************************************************************************
#CHAIN('OM5.TPX')