home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Media Share 9
/
MEDIASHARE_09.ISO
/
clarion
/
ppstpx.zip
/
OM5.TPX
< prev
next >
Wrap
Text File
|
1993-05-13
|
58KB
|
1,380 lines
#!***************************************************************************
#GROUP(%RelUpdate) #<!RelationalUpdate ROUTINE
#IF(%RelatedUpdateRoutine)
RelationalUpdate ROUTINE
AbortTransaction# = 0 !Reset transaction indicator
#IF(%CascadeUpdate OR %ClearOnUpdate)
#SET(%SetFile,%Primary)
#IF(%NoLogoutSupport = %NULL)
#SET(%LogoutList,'LOGOUT(2')
#INSERT(%SetupLogout)
#Set(%Logoutlist,(%Logoutlist & ')'))
%LogoutList
#INSERT(%InitLogout)
#ENDIF
#SET(%SetFile,%Primary)
#IF(%RestrictUpdate)
DO CheckRestrictedUpdate #<!Check RESTRICT update
IF RestrictUpdate# #<!Restrict this update
#IF(%NoLogoutSupport = %NULL)
ROLLBACK #<!Terminate the transaction
#ENDIF
EXIT #<!Exit the update
END
#ENDIF
#INSERT(%RelationUpdate)
PUT (%Primary) #<!Write the Parent record
#IF(%NoLogoutSupport = %NULL)
IF ~ERRORCODE() #<!If the Parent update is Ok
COMMIT
ELSE
GLO:Message1 = 'Unable to complete the transaction'
GLO:Message2 = 'Error: ' & ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'Files will be restored to their original values'
ShowWarning #<!Notify the user
ROLLBACK #<!Rollback the transaction
END #<!End IF ERRORCODE()
#ELSE #! NoLogoutSupport
IF ERRORCODE()
GLO:Message1 = 'Unable to complete the Referential Update'
GLO:Message2 = 'Error: ' & ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'File: %Primary could not be updated !'
ShowWarning #<!Notify the user
END
#ENDIF !# NoLogoutSupport
#ELSE
#IF(%RestrictUpdate)
DO CheckRestrictedUpdate #<!Check RESTRICT update
IF RestrictUpdate# #<!Restrict this update
AbortTransaction# = 1 #<!Turn AbortTransaction# ON
EXIT #<!Exit the update
END
#ENDIF
PUT(%Primary) #<!Write the Primary file
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%RelationUpdate)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#IF(%RelationConstraintUpdate = 'CASCADE')
#INSERT(%ClearCascadeUpdate)
#ELSIF(%RelationConstraintUpdate = 'CLEAR')
#INSERT(%ClearCascadeUpdate)
#ENDIF
#SET(%SetFile,%Relation)
#INSERT(%RelationUpdate)
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%ClearCascadeUpdate)
#SET(%LinkToParent,%NULL)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink)
#SET(%TheLink,%RelationKeyFieldLink)
#IF(INSTRING(%TheLink,%LevelOneLinks,1,1) <> '0')
#SET(%LinkToParent,'TRUE')
#ENDIF
#IF(INSTRING(%TheLink,%LinkPool,1,1) <> '0')
#SET(%LinkToParent,'TRUE')
#ENDIF
#ENDIF
#ENDFOR
#IF(%LinkToParent)
#INSERT(%ChildCheck)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
IF %RelationKeyFieldLink <> %Relation:Lnk:%RelationKeyFieldLink #<!Has Link changed?
LinkFieldChged# = 1 #<!Turn on LinkFieldChged#
UpdRelation = POSITION(%Relation) #<!Save position of update
ELSE
CLEAR(UpdRelation) #<!Clear position variable
END
#ENDIF
#ENDFOR
IF LinkFieldChged# #<!did the LINK field change
SET(%RelationKey,%RelationKey) #<!Set by key to related record
LOOP UNTIL EOF(%Relation) #<!Loop thru the file
#IF(%NoLogoutSupport)
HOLD(%Relation,10) #<!Set HOLD retry for 10 seconds
#ENDIF
NEXT(%Relation) #<!Read the record
DO CheckTransaction #<!Error check
#IF(%NoLogoutSupport = %NULL)
IF AbortTransaction# THEN EXIT. #<!IF error EXIT
#ENDIF
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
IF %RelationKeyField <> %Relation:Lnk:%RelationKeyFieldLink #<!Is this a related record?
BREAK #<!Not related, BREAK from Loop
END #<!End link field check
#ENDIF
#ENDFOR
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#IF(%RelationConstraintUpdate = 'CLEAR')
CLEAR(%RelationKeyField) #<!Enforce CLEAR constraint
#ELSIF(%RelationConstraintUpdate = 'CASCADE')
%RelationKeyField = %RelationKeyFieldLink #<!Enforce CASCADE constraint
#ENDIF
#ENDIF
#ENDFOR
PUT(%Relation) #<!Write the record
DO CheckTransaction #<!Check for an error
#IF(%NoLogoutSupport = %NULL)
IF AbortTransaction# THEN EXIT. #<!IF error EXIT
#ENDIF
END #<!End file process Loop
IF UpdRelation #<!Position of last update
RESET(%Relation,UpdRelation) #<!Position to updated record
NEXT(%Relation) #<!read updated record into buffer
END #<!End IF UpdRelation
END #<!End IF LinkFieldChgd#
END #<!End IF record related?
LinkFieldChged# = 0 #<!Turn LinkFieldChged# OFF
#ENDIF
#!***************************************************************************
#GROUP(%ChildCheck)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
%RelationKeyField = %Relation:Lnk:%RelationKeyFieldLink #<!Prime access component
#ELSE
CLEAR(%RelationKeyField) #<!CLEAR the NO LINK component
#ENDIF
#ENDFOR
SET(%RelationKey,%RelationKey) #<!Set to record by key
NEXT(%Relation) #<!Read the record
#SET(%Counter,%NULL)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#SET(%Counter,(%Counter + 1))
#IF(%Counter = '1')
#SET(%IfLine,('IF '& %RelationKeyField &' = '& %Relation &':Lnk:' & %RelationKeyFieldLink))
#ELSE
#SET(%IfLine,(%IfLine & ' AND ' & %RelationKeyField &' = '& %Relation&':Lnk:' & %RelationKeyFieldLink))
#ENDIF
#ENDIF
#ENDFOR
%IfLine #<!Is this a related record?
#!***************************************************************************
#GROUP(%RestrictUpdateCheck)
CheckRestrictedUpdate ROUTINE
RestrictUpdate# = 0
SetWarning# = 0
#FIX(%File,%Primary)
#FOR(%Relation)
#IF(%RelationConstraintUpdate = 'RESTRICT')
#IF(%RelationType = '1:MANY')
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
%RelationKeyField = %Relation:Lnk:%RelationKeyFieldLink #<!Prime the Key component
#ELSE
CLEAR(%RelationKeyField) #<!Clear this Key component
#ENDIF
#ENDFOR
SET(%RelationKey,%RelationKey) #<!Set to record by key
NEXT(%Relation) #<!Read the record
CASE ERRORCODE()
OF BadRecErr !No records update is OK
EXIT !Exit the routine
ELSE !else check for other errors
IF ERRORCODE() !if any errorcode was set
GLO:Message1 = 'Unable to process the file: %Relation '
GLO:Message2 = 'Error: '& ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'The transaction cannot be completed'
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable screen fields
ENABLE(?Cancel) #<!Enable the CANCEL button
RestrictUpdate# = 1 #<!Turn on RestrictUpdate#
EXIT #<!Exit the Routine
END !End IF ERRORCODE()
END !End CASE ERRORCODE()
#SET(%Counter,%NULL)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#SET(%Counter,(%Counter + 1))
#IF(%Counter = '1')
#SET(%IfLine,('IF '& %RelationKeyField &' <> '& %Relation & ':Lnk:' & %RelationKeyFieldLink))
#ELSE
#SET(%IfLine,(%IfLine & ' OR ' & %RelationKeyField &' <> '& %Relation & ':Lnk:' & %RelationKeyFieldLink))
#ENDIF
#ENDIF
#ENDFOR
%IfLine #<!Compare Link field(s)
EXIT #<!Not related so exit
END #<!End error check
#INSERT(%RestrictUpdateCode)
#ENDIF
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%RestrictUpdateCode)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
IF %RelationKeyFieldLink <> %Relation:Lnk:%RelationKeyFieldLink #<!Parent restricted field
SetWarning# = 1 #<!Turn on warning switch
RestrictUpdate# = 1 #<!Turn on Restrict switch
%RelationKeyFieldLink = %Relation:Lnk:%RelationKeyFieldLink #<!Reset to original value
DISPLAY !Refresh the screen
END #<!End field compare
#ENDIF
#ENDFOR
IF SetWarning# #<!If SetWarning is ON
GLO:Message1 = 'This record is referenced from other file(s)'
GLO:Message2 = 'Link field(s) are RESTRICTED from change'
GLO:Message3 = ' and have been reset to original values '
ShowWarning #<!Notify the user
DISPLAY #<!Update the screen
END #<!End SetWarning
#!***************************************************************************
#GROUP(%ConcurrentWrite)
#IF(%ConcurrentWriteOn)
ConcurrentWrite ROUTINE
AbortWrite# = 0 #<!Initialize AbortWrite#
IF ~AutoIncAdd #<!Not an Autoincrement ADD
Sav:SaveRecord = %FilePre:Record #<!Save Record to the Queue
#IF(%MemoChk)
#FOR(%Field)
#IF(%FieldType = 'MEMO')
SAV:%FieldID = %Field #<!Save Memo to the Queue
#ENDIF
#ENDFOR
#ENDIF
ADD(RecordQueue,2) #<!Add the changed record
GET(RecordQueue,1) #<!Get the original record
RESET(%Primary,SavePointer) #<!Position to record on disk
HOLD(%Primary,2) #<!Set HOLD retry for 2 seconds
NEXT(%Primary) #<!Read the record into buffer
IF ERRORCODE() #<!Was there an error?
CASE ERRORCODE() #<!Process recoverable errors
OF IsHeldErr #<!Record is already held
GLO:Message1 = 'The Record is locked by another workstation '
GLO:Message2 = 'when you return to the entry FORM choose OK '
GLO:Message3 = 'to try the update again, or CANCEL to abort '
ShowWarning #<!Show user a warning
SELECT(1) #<!Place cursor on 1st field
RELEASE(%Primary) #<!Release the HOLD
AbortWrite# = 1 #<!Turn on AbortWrite#
EXIT #<!Back to main Loop
ELSE #<!On any other error
IF DiskError('File Access Error') #<!Call the Diskerror function
RELEASE(%Primary) #<!Release the hold
FREE(RecordQueue) #<!Free the memory Queue
DISABLE(1,FIELDS()) #<!Disable all screen fields
ENABLE(?Cancel) #<!Enable the Cancel button
SELECT(?Cancel) #<!Place cursor on Cancel
AbortWrite# = 1 #<!Turn on AbortWrite#
EXIT #<!and exit the routine
END #<!End IF Diskerror
END #<!End CASE Errorcode()
ELSIF Sav:SaveRecord <> %FilePre:Record #<!Has the record been changed
Sav:SaveRecord = %FilePre:Record #<!Then update the Queue record
#IF(%MemoChk = 'TRUE')
#FOR(%Field)
#IF(%FieldType = 'MEMO')
IF SAV:%FieldID <> %Field #<!Has the Memo been changed?
SAV:%FieldID = %Field #<!Then update the Queue memo
END #<!End IF Memo changed
#ENDIF
#ENDFOR
#ENDIF
#INSERT(%ConflictUpdate)
#IF(%MemoChk = 'TRUE')
#FOR(%Field)
#IF(%FieldType = 'MEMO')
ELSIF SAV:%FieldID <> %Field #<!Has the Memo been changed?
SAV:%FieldID = %Field #<!Then update the Queue memo
#INSERT(%ConflictUpdate)
#ENDIF
#ENDFOR
#ENDIF
ELSE #<!Its ok to update the file
GET(RecordQueue,2) #<!Retrieve the users changes
%FilePre:Record = Sav:SaveRecord #<!Move changes to record buffer
#IF(%MemoChk)
#FOR(%Field)
#IF(%FieldType = 'MEMO')
%Field = SAV:%FieldID #<!Move Memo to buffer
#ENDIF
#ENDFOR
#ENDIF
END #<!End IF Errorcode()
END #<!End IF ~AutoIncAdd
#ENDIF
#!***************************************************************************
#GROUP(%RelDelete) #<!RealationalDelete ROUTINE
#IF(%RelatedDeleteRoutine)
RelationalDelete ROUTINE
#SET(%SetFile,%Primary)
#IF(%NoLogoutSupport = %NULL)
#SET(%LogoutList,'LOGOUT(2')
#INSERT(%SetupLogoutDel)
#Set(%Logoutlist,(%Logoutlist & ')'))
%LogoutList
#INSERT(%InitLogout)
#ENDIF
#SET(%SetFile,%Primary)
#INSERT(%RelationDelete)
#IF(%CascadeDelete OR %ClearOnDelete)
DELETE(%Primary) #<!Delete record Primary file
#INSERT(%CommitCheck)
#ELSE
DELETE(%Primary) #<!Delete record Primary file
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%RelationDelete)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#IF(%RelationConstraintDelete = 'CASCADE')
#INSERT(%ClearCascadeDelete)
#ELSIF(%RelationConstraintDelete = 'CLEAR')
#INSERT(%ClearCascadeDelete)
#ENDIF
#SET(%SetFile,%Relation)
#INSERT(%RelationDelete)
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%ClearCascadeDelete)
#INSERT(%ChildCheck)
SET(%RelationKey,%RelationKey) #<!Set to first occurence
LOOP UNTIL EOF(%Relation) #<!Loop thru the file
#IF(%NoLogoutSupport)
HOLD(%Relation,10) #<!Set HOLD retry for 10 seconds
#ENDIF
NEXT(%Relation) #<!Read the record
DO CheckTransaction #<!Check for error
#IF(%NoLogoutSupport = %NULL)
IF AbortTransaction# THEN EXIT. #<!IF error exit the routine
#ENDIF
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
IF %RelationKeyField <> %Relation:Lnk:%RelationKeyFieldLink #<!Is this a related record?
BREAK #<!Not Related, BREAK from Loop
END
#IF(%RelationConstraintDelete = 'CLEAR')
CLEAR(%RelationKeyField) #<!Enforce the relation constraint
#ENDIF
#ENDIF
#ENDFOR
#IF(%RelationConstraintDelete = 'CLEAR')
PUT(%Relation) #<!Enforce CLEAR constraint
#ELSIF(%RelationConstraintDelete = 'CASCADE')
DELETE(%Relation) #<!Enforce CASCADE constraint
#ENDIF
DO CheckTransaction
#IF(%NoLogoutSupport = %NULL)
IF AbortTransaction# THEN EXIT.
#ENDIF
END #<!End Loop
END #<!Is record related?
#!***************************************************************************
#GROUP(%RestrictDeleteCode)
CheckRestrictedDelete ROUTINE
RestrictDelete# = 0
#FIX(%File,%Primary)
#FOR(%Relation)
#IF(%RelationConstraintDelete = 'RESTRICT')
#IF(%RelationType = '1:MANY')
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
%RelationKeyField = %Relation:Lnk:%RelationKeyFieldLink #<!Prime the Key component
#ELSE
CLEAR(%RelationKeyField) #<!Clear this Key component
#ENDIF
#ENDFOR
SET(%RelationKey,%RelationKey) #<!Set to record by key
NEXT(%Relation) #<!Read the record
CASE ERRORCODE()
OF BadRecErr !No records delete is OK
EXIT
ELSE
IF ERRORCODE()
GLO:Message1 = 'Unable to process the file: %Relation '
GLO:Message2 = 'Error: '& ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'The transaction cannot be completed'
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable screen fields
ENABLE(?Cancel) #<!Enable the CANCEL button
RestrictDelete# = 1 #<!Turn on RestrictDelete#
EXIT #<!Exit the Routine
END !End IF ERRORCODE()
END !End CASE ERRORCODE()
#SET(%Counter,%NULL)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#SET(%Counter,(%Counter + 1))
#IF(%Counter = '1')
#SET(%IfLine,('IF '& %RelationKeyField &' = '& %RelationKeyFieldLink))
#ELSE
#SET(%IfLine,(%IfLine & ' AND ' & %RelationKeyField &' = '& %RelationKeyFieldLink))
#ENDIF
#ENDIF
#ENDFOR
%IfLine
GLO:Message1 = 'This record is restricted from deletion'
GLO:Message2 = 'It is referenced from other files'
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable screen fields
ENABLE(?Cancel) #<!Enable the CANCEL button
RestrictDelete# = 1 #<!Turn on RestrictDelete#
EXIT #<!Exit the Routine
END #<!End error check
#ENDIF
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%SetupLogout)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#IF(%RelationConstraintUpdate = 'CASCADE')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ELSIF(%RelationConstraintUpdate = 'CLEAR')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ELSIF(%RelationConstraintUpdate = 'RESTRICT')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ENDIF
#SET(%SetFile,%Relation)
#INSERT(%SetupLogout)
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%SetupLogoutDel)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#IF(%RelationConstraintDelete = 'CASCADE')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ELSIF(%RelationConstraintDelete = 'CLEAR')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ELSIF(%RelationConstraintDelete = 'RESTRICT')
#SET(%Temp, %Relation)
#SET(%Logoutlist,(%Logoutlist &','& %Temp))
#ENDIF
#SET(%SetFile,%Relation)
#INSERT(%SetupLogoutDel)
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%InitLogout)
IF ERRORCODE() #<!Was Logout OK?
AbortTransaction# = 1 #<!Turn AbortTransaction ON
CASE ERRORCODE() #<!Process recoverable error
OF IsLockedErr #<!Was the file locked?
GLO:Message1 = 'The transaction cannot be completed'
GLO:Message2 = 'at this time. One or more of the files'
GLO:Message3 = 'is already locked. You may retry the operation'
ShowWarning #<!Notify the user
SELECT(?Ok) #<!Place cursor on OK
ROLLBACK #<!End LOGOUT
EXIT #<!Exit the Routine
ELSE #<!Any other error
GLO:Message1 = 'The transaction cannot be completed'
GLO:Message2 = 'at this time. The error posted was: '
GLO:Message3 = ERROR()
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable the screen fields
ENABLE(?Cancel) #<!Enable the Cancel button
SELECT(?Cancel) #<!Place the cursor on Cancel
ROLLBACK #<!End LOGOUT
EXIT #<!Exit the Routine
END #<!End CASE errorcode
END #<!No errors, start transaction
AbortTransaction# = 0 #<!Set Abort switch to off
#!***************************************************************************
#GROUP(%ConcurrentDelete)
#IF(%ConcurrentDeleteOn)
ConcurrentDelete ROUTINE
AbortDelete# = 0
RESET(%Primary,SavePointer) #<!Set position in Primary file
HOLD(%Primary,2) #<!Hold the record
NEXT(%Primary) #<!Read the record into buffer
IF POSITION(%Primary) <> SavePointer #<!Is the record already deleted?
RELEASE(%Primary) #<!Relase record Hold
FREE(RecordQueue) #<!Free the memory Queue
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN #<!Return to the calling procedure
END #<!End IF position check
IF ERRORCODE() #<!Check for file access error
CASE ERRORCODE() #<!Case for recoverable errors
OF IsHeldErr #<!Record is already held
GLO:Message1 = 'The Record is locked by another workstation '
GLO:Message2 = 'when you return to the entry FORM choose OK '
GLO:Message3 = 'to try the update again, or CANCEL to abort '
ShowWarning #<!Notify the user
SELECT(1) #<!Place cursor on 1st field
RELEASE(%Primary) #<!Release HOLD request
AbortDelete# = 1 #<!Set AbortDelete# ON
EXIT #<!Re-start main LOOP
ELSE #<!for any other error
IF DiskError('Unable to process current Record') #<!Call error function
GLO:Message2 = 'Unable to continue, Press OK to exit'
ShowWarning #<!Notify the user
#IF(SharedFiles = 'TRUE')
FREE(RecordQueue) #<!Free the memory queue
#ENDIF
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN #<!Return to calling procedure
END #<!End IF Diskerror
END #<!End CASE errorcode
END #<!End IF errorcode()
#ENDIF
#!***************************************************************************
#GROUP(%CheckTransaction)
CheckTransaction ROUTINE
IF ERRORCODE()
#IF(%NoLogoutSupport = %NULL)
AbortTransaction# = 1
GLO:Message1 = 'The transaction cannot be completed'
GLO:Message2 = 'Error: '&ERROR()
GLO:Message3 = 'Files will be restored to original values'
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable all screen fields
ENABLE(?Cancel) #<!Activate the Cancel button
SELECT(?Cancel) #<!Place the cursor on Cancel
ROLLBACK #<!Restore original records
IF ERRORCODE() <> NoDriverSupport
GLO:Message1 = 'Files could not be restored to original values'
GLO:Message2 = 'Error: '&ERROR()
ShowWarning #<!Notify the user
END
END #<!End error check
#ELSE #! NoLogoutSupport
GLO:Message1 = 'The Referential Update/Delete encountered an error'
GLO:Message2 = 'Error: '& ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'Relational integrity for: ' & ERRORFILE() & 'is suspect'
ShowWarning #<!Notify the user
END
#ENDIF
#!***************************************************************************
#GROUP(%RelUpdSave)
RelationAccessSave ROUTINE
#SET(%SetFile,%Primary)
#INSERT(%RelUpdateSave)
#!***************************************************************************
#GROUP(%RelUpdateSave)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
CheckOpen(%Relation)
#SET(%SetFile,%Relation)
#INSERT(%ChildSave)
#INSERT(%RelUpdateSave)
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%ChildSave)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#IF(INSTRING(%SetFile,%LevelOne,1,1) <> '0')
%Relation:Lnk:%RelationKeyFieldLink = %RelationKeyFieldLink #<!save original link
%RelationKeyField = %RelationKeyFieldLink #<!Prime key component
#ELSE
#SET(%SaveLine,(%RelationKeyField &' <> '& %RelationKeyFieldLink))
%Relation:Lnk:%RelationKeyFieldLink = %RelationKeyFieldLink #<!save original link
%RelationKeyField = %RelationKeyFieldLink #<!Prime key component
#ENDIF
#ELSE
CLEAR(%RelationKeyField) #<!Clear NoLink field
#ENDIF
#ENDFOR
SET(%RelationKey,%RelationKey) #<!Set by RelationAccess Key
NEXT(%Relation) #<!Read the record
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
IF %RelationKeyField <> %RelationKeyFieldLink #<!Is the record related?
NotRelated# = 1 #<!No, then set NotRelated# ON
END
#ENDIF
#ENDFOR
IF ERRORCODE() OR NotRelated# #<!Check error or not related
#FIX(%File,%Relation)
CLEAR(%FilePre:Record) #<!Clear the record if needed
END #<!End IF Errorcode
#!***************************************************************************
#GROUP(%InitQue)
#IF(%SharedFiles = 'TRUE')
InitializeQueue ROUTINE #<!save initial record values
Sav:SaveRecord = %FilePre:Record #<!Save the current record
#IF(%MemoChk)
#FOR(%Field)
#IF(%FieldType = 'MEMO')
SAV:%FieldID = %Field #<!Save the memo
#ENDIF
#ENDFOR
#ENDIF
ADD(RecordQueue,1) #<!add record to Queue
ADD(RecordQueue,2) #<!add record again
IF ERRORCODE() #<!check Queue add error
CASE ERRORCODE()
OF NoMemErr #<!Is there enough memory?
GLO:Message1 = 'Not Enough Memory to proceed'
GLO:Message2 = 'with this operation . . . . '
ShowWarning #<!Notify the user
DISABLE(1,FIELDS()) #<!Disable the screen fields
ENABLE(?Cancel) #<!Enable the Cancel button
SELECT(?Cancel) #<!Place cursor on Cancel
DISPLAY #<!Update screen display
ELSE #<!On any other error
GLO:Message1 = ERRORCODE() & ' ' & ERROR()
GLO:Message2 = 'Unable to continue . . . .'
ShowWarning #<!Show user the error
DISABLE(1,FIELDS()) #<!Disable screen fields
ENABLE(?Cancel) #<!Enable Cancel button
SELECT(?Cancel) #<!Place cursor on Cancel
DISPLAY #<!re-display the screen
END #<!End CASE Errorcode
END #<!End IF Errorcode
#ENDIF
#!***************************************************************************
#GROUP(%InitFields)
#IF(%InitRoutine = 'TRUE')
InitializeFields ROUTINE
#FOR(%Field)
#IF(%FieldInitial <> %NULL)
%Field = %FieldInitial
#ENDIF
#ENDFOR
#ENDIF
#!***************************************************************************
#GROUP(%SecondaryLookups)
SecondaryLookups ROUTINE
#INSERT(%GetSecondaryRecords) #<!Lookup into Secondary files
DISPLAY
#!***************************************************************************
#GROUP(%InsertMessage)
#IF(%InsertMsg <> %NULL)
LOC:Message = CENTER('%InsertMsg',SIZE(LOC:Message)) #<!Assign ADD message
#ELSE
LOC:Message = CENTER(GLO:InsertMsg,SIZE(LOC:Message))#<!Assign ADD message
#ENDIF
#!***************************************************************************
#GROUP(%ChangeMessage)
#IF(%ChangeMsg <> %NULL)
LOC:Message = CENTER('%ChangeMsg',SIZE(LOC:Message)) #<!Assign CHANGE message
#ELSE
LOC:Message = CENTER(GLO:ChangeMsg,SIZE(LOC:Message))#<!Assign CHANGE message
#ENDIF
#!***************************************************************************
#GROUP(%DeleteMessage)
#IF(%DeleteMsg <> %NULL)
LOC:Message = CENTER('%DeleteMsg',SIZE(LOC:Message)) #<!Assign DELETE message
#ELSE
LOC:Message = CENTER(GLO:DeleteMsg,SIZE(LOC:Message))#<!Assign DELETE message
#ENDIF
#!***************************************************************************
#GROUP(%AutoIncCode)
#IF(%AutoInc = 'TRUE')
AutoNumber Routine
LOOP #<!Loop for autonumbering
#FIX(%File,%Primary)
#FOR(%Key)
#IF(%KeyAuto) #! <> %NULL
#FOR(%KeyField)
#FIX(%Field,%KeyField)
#IF(UPPER(%FieldType) = 'PICTURE') #!Autonumber Picture data type
#IF(INSTRING('@N',UPPER(%FieldRecordPicture),1,1)) #!If its an @n picture
%KeyField = ALL('9') #<!Fill strings with 9's
#ELSE
CLEAR(%KeyField,1) #<!Clear Ascending to high value
#ENDIF
#ELSE
CLEAR(%KeyField,1) #<!Clear Ascending to high value
#ENDIF
#ENDFOR
#FOR(%Formula)
#IF(UPPER(%FormulaClass) = 'PRIMEKEY')
#INSERT(%GenerateFormula)
#ENDIF
#ENDFOR
#IF(%PrimeKeysExist)
#FOR(%KeyField)
#IF(%KeyField <> %KeyAuto)
Prime::%KeyField = %KeyField
#ENDIF
#ENDFOR
#ENDIF
SET(%Key,%Key) #<!For each autoincrement key
PREVIOUS(%Primary) #<!Read last record (Ascending)
IF ERRORCODE() = BadRecErr #<!If Errorcode No Records
%KeyAuto:AutoInc# = 1 #<!then start numbering at 1
ELSIF ERRORCODE() #<!On any other error
GLO:Message1 = 'Unable to READ keyed record'
GLO:Message2 = 'Cannot continue update....'
GLO:Message3 = 'Error: '&ERRORCODE() & ' ' & ERROR()
ShowWarning #<!Show user the error
#IF(%PullDownStructure)
CLOSE(%PullDown)
#ENDIF
RETURN #<!and return to caller
ELSE
#IF(%PrimeKeysExist)
#SET(%Pass,'1')
#FOR(%KeyField)
#IF(%KeyField <> %KeyAuto)
#IF(%Pass = '1')
#SET(%MatchSubset,('IF ' & 'Prime::'& %KeyField & ' = ' & %KeyField))
#ELSE
#SET(%MatchSubset,(%MatchSubset & ' AND ' & 'Prime::'& %KeyField & ' = ' & %KeyField))
#ENDIF
#SET(%Pass,(%Pass + 1))
#ENDIF
#ENDFOR
%MatchSubset
%KeyAuto:AutoInc# = %KeyAuto + 1 #<!Subset incremented value
ELSE !Is this is a new subset?
%KeyAuto:AutoInc# = 1 #<!then start numbering at 1
END !End test subset match
#ELSE #!No subset support
%KeyAuto:AutoInc# = %KeyAuto + 1 #<!Save incremented value
#ENDIF
END #<!End IF errorcode
#ENDIF #!end if keyauto
#ENDFOR #!end for key
#INSERT(%ClearValues)
#FOR(%Formula)
#IF(UPPER(%FormulaClass) = 'PRIMEKEY')
#INSERT(%GenerateFormula)
#ENDIF
#ENDFOR
#FOR(%Key)
#IF(%KeyAuto <> %NULL)
%KeyAuto = %KeyAuto:AutoInc# #<!Move the incremented value
#ENDIF
#ENDFOR
ADD(%Primary) #<!Add the record now
IF ERRORCODE() #<!Was there an error?
CASE ERRORCODE() #<!Process errors
OF DupKeyErr #<!Is it a duplicate key?
CYCLE #<!then try again
ELSE #<!Else
IF DiskError('Record could not be ADDed') #<!Check any other error
#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 CASE errorcode
ELSE #<!Else no error
BREAK #<!so BREAK Loop
END #<!End IF errorcode
END #<!End LOOP for Autonumbering
AutoIncAdd = 1 #<!Switch AutoIncAdd ON
AutoAddPtr = POSITION(%Primary) #<!Save the record position
RESET(%Primary,AutoAddPtr) #<!Position to record we added
HOLD(%Primary,4) #<!Hold the record
NEXT(%Primary) #<!and read it in to buffer
IF DiskError('Could not READ Record') #<!Check for 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
Action = ChangeRecord #<!Action is now change
EXIT #<!Exit the routine
#ENDIF
#!***************************************************************************
#GROUP(%RestoreAuto)
#FOR(%Key)
#IF(%KeyAuto <> %NULL)
%KeyAuto = %KeyAuto:AutoInc# #<!Restore incremented value
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%SetupConcurrency)
DO InitializeQueue #<!Save record to QUEUE
SavePointer = POSITION(%Primary) #<!Save the record position
#!***************************************************************************
#GROUP(%ConflictUpdate)
PUT(RecordQueue) #<!Update the memory Queue
GLO:Message1 = 'The Record was changed by another station '
GLO:Message2 = 'your screen now reflects the changed data '
GLO:Message3 = 'OK button to continue, or CANCEL to abort '
ShowWarning #<!Notify the user of changes
SELECT(1) #<!Place cursor on 1st field
DISPLAY #<!Update the screen
AbortWrite# = 1 #<!Turn AbortWrite# ON
EXIT #<!Exit the Routine
#!***************************************************************************
#GROUP(%FormEditRoutines)
#FOR(%ScreenField)
#IF(%ScreenFieldUse <> '?Ok')
#IF(%ScreenFieldUse <> '?Cancel')
#IF(%ScreenFieldUse <> '?Next_Page')
#IF(%ScreenFieldUse <> '?Previous_Page')
#IF(%ScreenFieldUse <> '?Base_Page')
#IF(%ScreenFieldUse <> '?Last_Page')
#SET(%RangeCodeOn,%NULL)
#SET(%FieldLookUpOn,%NULL)
#INSERT(%RangeLookupCheck)
#IF(%ScreenFieldEdit OR %RangeCodeOn OR %FieldLookUpOn)
OF %ScreenField !Screen field selected
#IF(%FieldLookupOn)
#INSERT(%FieldLookupCode)
#ENDIF
#IF(%RangeCodeOn)
#INSERT(%RangeCode)
#ENDIF
#IF(%ScreenFieldEdit)
%ScreenFieldEdit !Screen field edit proc
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
#FOR(%PulldownField) #! add all procedure or
#IF(%PulldownFieldType = 'PROCEDURE') #! source code calls
OF %PulldownField #<!For a Pulldown field
%PulldownFieldProc #<! execute its procedure
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%RangeLookupCheck)
#IF(%ScreenFieldType = 'ENTRY')
#FIX(%Field,%ScreenFieldUse)
#IF(%Field = %ScreenFieldUse)
#IF(%FieldRangeLow <> %NULL OR %FieldRangeHigh <> %NULL)
#SET(%RangeCodeOn,'TRUE')
#ELSE
#SET(%RangeCodeOn,%NULL)
#ENDIF
#IF(%FieldLookup)
#SET(%FieldLookupOn,'TRUE')
#ELSE
#SET(%FieldLookupOn,%NULL)
#ENDIF
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%RangeCode)
#IF(%ScreenFieldType = 'ENTRY')
#FIX(%Field,%ScreenFieldUse)
#IF(%Field = %ScreenFieldUse)
#IF(%FieldRangeLow <> %NULL OR %FieldRangeHigh <> %NULL)
#IF(%FieldRangeLow = %NULL)
IF KEYCODE() <> EscKey
IF %ScreenFieldUse > %FieldRangeHigh
GLO:Message1 = 'The value entered in %FieldID'
GLO:Message2 = 'cannot exceed %FieldRangeHigh'
#ELSIF(%FieldRangeHigh = %NULL)
IF KEYCODE() <> EscKey
IF %ScreenFieldUse < %FieldRangeLow
GLO:Message1 = 'The value entered in %FieldID'
GLO:Message2 = 'cannot be less than %FieldRangeHigh'
#ELSE
IF KEYCODE() <> EscKey
IF ~INRANGE(%ScreenFieldUse,%FieldRangeLow,%FieldRangeHigh)
GLO:Message1 = 'Valid entries for %FieldID'
GLO:Message2 = 'are from %FieldRangeLow TO %FieldRangeHigh'
#ENDIF
ShowWarning
SELECT(%ScreenField)
CYCLE
END
END !Not EscKey
#ENDIF
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%FieldLookupCode)
#IF(%ScreenFieldType = 'ENTRY')
#FIX(%Field,%ScreenFieldUse)
#IF(%Field = %ScreenFieldUse)
#IF(%FieldLookup)
#FIX(%File,%FieldFile)
#FIX(%Relation,%FieldLookup)
#IF(%RelationType = 'MANY:1')
#FOR(%RelationKeyField)
IF KEYCODE() <> EscKey
%RelationKeyField = %RelationKeyFieldLink #<!Assign linking field value
#ENDFOR
GET(%Relation,%RelationKey) #<!Lookup record
IF ERRORCODE() #<!Did the GET succeed ?
#FIX(%File,%FieldLookup)
CLEAR(%FilePre:Record) #<!Clear record if unsuccessful
GLO:Message1 = 'Error: ' & ERRORCODE() & ' '& ERROR() #<!Build error message
GLO:Message2 = 'The value you enter must exist in the'
GLO:Message3 = 'File: %FieldLookup' #<!Identify the Lookup file
ShowWarning !Notify the user
SELECT(%ScreenField) !Reselect the screen field
END !End IF Errorcode
END !Not EscKey
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%FieldLookupOpen)
#FOR(%ScreenField)
#IF(%ScreenFieldType = 'ENTRY')
#FIX(%Field,%ScreenFieldUse)
#IF(%Field = %ScreenFieldUse)
#IF(%FieldLookup)
#FIX(%File,%FieldFile)
#FIX(%Relation,%FieldLookup)
#IF(%RelationType = 'MANY:1')
#FIX(%Secondary,%Relation)
#IF(%Secondary = %NULL)
CheckOpen(%Relation) #<!Is Lookup file is OPEN ?
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%DupKeyCode)
#FIX(%File,%Primary)
IF ERRORCODE() = DupKeyErr #<! Duplicate key detected
#FOR(%Key)
#IF(UPPER(%KeyDuplicate) <> 'Y')
IF DUPLICATE(%Key) #<!check unique keys
GLO:Message3 = '[ '
#FOR(%KeyField)
GLO:Message3 = Clip(GLO:Message3) & (' %KeyField ')
#ENDFOR
GLO:Message3 = Clip(GLO:Message3)&' ]'
END
#ENDIF
#ENDFOR
GLO:Message1 = 'This record creates a duplicate key entry'
GLO:Message2 = 'The unique key field(s) are listed below: '
ShowWarning #<!inform the user
SELECT(1) #<!select first field
DISPLAY #<!re-display the screen
CYCLE #<!back to main loop
END #<!End IF Duplicate errorcode
#!***************************************************************************
#GROUP(%PositionCheck)
IF POSITION(%Primary) <> SavePointer #<!compare the positions
GLO:Message1 = 'The Record was Deleted by another workstation'
GLO:Message2 = 'when you return to the entry FORM choose OK '
GLO:Message3 = 'to ADD as a new record, or CANCEL to abort '
ShowWarning
#INSERT(%InsertMessage)
Action = AddRecord
GET(RecordQueue,2) #<!Get the users changes
%FilePre:Record = Sav:SaveRecord #<!Update the Record buffer
#IF(%MemoChk = 'TRUE')
#FOR(%Field)
#IF(%FieldType = 'MEMO')
%Field = SAV:%FieldID #<!Update the Memo buffer
#ENDIF
#ENDFOR
#ENDIF
DISPLAY #<!Update the screen
SELECT(1) #<!Place the cursor on 1st field
RELEASE(%Primary) #<!Release HOLD request
CYCLE #<!Re-start the Loop
END #<!End Position check
#!***************************************************************************
#GROUP(%ClearValues)
CLEAR(%FilePre:Record) #<!CLEAR Record buffer
#FOR(%FileMemo)
CLEAR(%FileMemo) #<!CLEAR Memo buffer
#ENDFOR
#!***************************************************************************
#GROUP(%InitFormSymbols)
#FIX(%File,%Primary)
#SET(%PrimaryDriver,%FileType)
#FOR(%HotKey)
#IF(%HotKeyProc)
#SET(%HotKeysExist,'TRUE')
#BREAK
#ENDIF
#ENDFOR
#FOR(%Key)
#IF(%KeyAuto <> %NULL)
#SET(%AutoInc,'TRUE')
#ENDIF
#IF(%KeyDuplicate <> 'Y')
#SET(%DupKeyCheck,'TRUE')
#ENDIF
#ENDFOR
#FOR(%Formula)
#SET(%FormulasExist,'TRUE')
#IF(UPPER(%FormulaClass) = 'PRIMEKEY')
#SET(%PrimeKeysExist,'TRUE')
#ENDIF
#ENDFOR
#FOR(%Filememo)
#SET(%MemoChk,'TRUE')
#BREAK
#ENDFOR
#FOR(%Field)
#IF(%FieldInitial <> %NULL)
#SET(%InitRoutine,'TRUE')
#BREAK
#ENDIF
#ENDFOR
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#SET(%Instance,%Relation)
#SET(%LevelOne,(%LevelOne & ','& %Instance))
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink)
#SET(%Link,%RelationKeyField)
#SET(%RKFL,%RelationKeyFieldLink)
#SET(%LevelOneLinks,(%LevelOneLinks & ','& %Link))
#SET(%LinkPool,(%LinkPool & ','& %RKFL))
#ENDIF
#ENDFOR
#IF(%RelationConstraintUpdate OR %RelationConstraintDelete)
#SET(%RelatedFiles,'TRUE')
#INSERT(%PrimaryDriverChk)
#ENDIF
#IF(%RelationConstraintDelete = 'RESTRICT')
#SET(%RestrictDelete,'TRUE')
#ENDIF
#IF(%RelationConstraintUpdate = 'RESTRICT')
#SET(%RestrictUpdate,'TRUE')
#ENDIF
#IF(%RelationConstraintDelete = 'CASCADE')
#SET(%CascadeDelete,'TRUE')
#ENDIF
#IF(%RelationConstraintUpdate = 'CASCADE')
#SET(%CascadeUpdate,'TRUE')
#ENDIF
#IF(%RelationConstraintDelete = 'CLEAR')
#SET(%ClearOnDelete,'TRUE')
#ENDIF
#IF(%RelationConstraintUpdate = 'CLEAR')
#SET(%ClearOnUpdate,'TRUE')
#ENDIF
#ENDIF
#ENDFOR
#FOR(%Secondary)
#IF(%SecondaryType = 'MANY:1')
#SET(%SecondaryExist,'TRUE')
#ENDIF
#ENDFOR
#SET(%SetFile,%Primary)
#INSERT(%SpatialRelate)
#!***************************************************************************
#GROUP(%DeclareRelatedData)
#FIX(%File,%Primary)
#FOR(%Relation)
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
%Relation:Lnk:%RelationKeyFieldLink LIKE(%RelationKeyFieldLink) !Relation Link field
#ENDIF
#ENDFOR
#ENDFOR
#!***************************************************************************
#GROUP(%RelationalAccessFlds)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink <> %NULL)
#SET(%Constructor,(%Relation & ':Lnk:' & %RelationKeyFieldLink))
#IF(INSTRING(%Constructor,%Array,1,1) = '0')
%Relation:Lnk:%RelationKeyFieldLink LIKE(%RelationKeyFieldLink) #<!Define a link field
#SET(%Element,(',' & %Constructor))
#SET(%Array,(%Array & %Element))
#ENDIF
#ENDIF
#ENDFOR
#SET(%SetFile,%Relation)
#INSERT(%RelationalAccessFlds)
#ENDIF
#ENDFOR
#!**************************************************************************
#GROUP(%GenFormulas)
#IF(%GenerateFormulasOn)
FormulaFields ROUTINE
#FOR(%Formula)
#IF(UPPER(%FormulaClass) <> 'PRIMEKEY')
#IF(%CodePosition = %NULL OR %CodePosition = %FormulaClass)
#IF(%FormulaType = 'COMPUTED')
%Formula = %FormulaComputation
#ELSE
IF %FormulaCondition #<!If formula condition
%Formula = %FormulaTrue
#IF(%FormulaFalse)
ELSE
%Formula = %FormulaFalse
#ENDIF
END #<!End formula condition
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
DISPLAY #<!Update screen display
#ENDIF
#!***************************************************************************
#GROUP(%SpatialRelate)
#FIX(%File,%SetFile)
#FOR(%Relation)
#IF(%RelationType = '1:MANY')
#INSERT(%DriverCheck)
#IF(INSTRING(%SetFile,%LevelOne,1,1) = '0')
#FOR(%RelationKeyField)
#IF(%RelationKeyFieldLink)
#SET(%RKFL,%RelationKeyFieldLink)
#IF(INSTRING(%RKFL,%LinkPool,1,1) = '0')
#SET(%LinkPool,(%LinkPool & ','& %RKFL))
#ENDIF
#ENDIF
#ENDFOR
#ENDIF
#SET(%SetFile,%Relation)
#INSERT(%SpatialRelate)
#ENDIF
#ENDFOR
#!**************************************************************************
#GROUP(%SecondaryChanged)
#FOR(%Secondary) #! for fields on the form
#IF(%SecondaryType = 'MANY:1') #!Check for lookup files
#FIX(%File,%SecondaryTo)
#FIX(%Relation,%Secondary)
#FOR(%RelationKeyField)
IF %RelationKeyField <> %RelationKeyFieldLink #<!Check for changes
DO SecondaryLookups #<!Call lookup Routine
END
#ENDFOR
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%FieldDups)
#FOR(%ScreenField)
#IF(%ScreenFieldUse)
#SET(%Fld,%ScreenFieldUse)
#FIX(%Field,%ScreenFieldUse)
#IF(SUB(%Fld,1,1) <> '?')
#IF(%FieldID)
#IF(%FieldFile = %Primary)
#IF(%FieldDimension1)
#SET(%DimField,%Field)
#IF(INSTRING(%DimField,%DimPool,1,1) = '0')
#SET(%DimPool,(%DimPool & ',' & %DimField))
Dup::%Field LIKE(%Field)
#ENDIF
#ELSE
Dup::%ScreenFieldUse LIKE(%ScreenFieldUse)
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%SaveScrFlds)
SaveScrFlds ROUTINE
#FOR(%ScreenField)
#IF(%ScreenFieldUse)
#SET(%Fld,%ScreenFieldUse)
#FIX(%Field,%ScreenFieldUse)
#IF(SUB(%Fld,1,1) <> '?')
#IF(%FieldID)
#IF(%FieldFile = %Primary)
Dup::%ScreenFieldUse = %ScreenFieldUse #<!Save screen entry
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%DupFldCall)
IF KEYCODE() = %CopyKey #<!User requested field copy
DO DupField #<!Call duplication Routine
END #<!End copy key check
#!***************************************************************************
#GROUP(%DupField)
DupField ROUTINE
CASE SELECTED() !Which field is selected?
#FOR(%ScreenField)
#IF(%ScreenFieldUse)
#SET(%Fld,%ScreenFieldUse)
#FIX(%Field,%ScreenFieldUse)
#IF(SUB(%Fld,1,1) <> '?')
#IF(%FieldID)
#IF(%FieldFile = %Primary)
OF ?%ScreenFieldUse
%ScreenFieldUse = Dup::%ScreenFieldUse #<!Move saved entry to screen
#ENDIF
#ENDIF
#ENDIF
#ENDIF
#ENDFOR
END #<!End Case Selected
DISPLAY #<!Update screen display
#!***************************************************************************
#GROUP(%CommitCheck)
#IF(%NoLogoutSupport = %NULL)
IF ~ERRORCODE()
COMMIT #<!Commit the transaction
ELSE !If there was an error
GLO:Message1 = 'Unable to complete the transaction'
GLO:Message2 = 'Error: ' & ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'Files will be restored to their original values'
ShowWarning #<!Notify the user
ROLLBACK #<!Rollback the transaction
END !End error check
#ELSE
IF ERRORCODE() !Check for error
GLO:Message1 = 'The Referential Update/Delete encountered an error'
GLO:Message2 = 'Error: '& ERRORCODE() & ' ' & ERROR()
GLO:Message3 = 'Relational integrity for: ' & ERRORFILE() & 'is suspect'
ShowWarning #<!Notify the user
END !End error check
#ENDIF
#!***************************************************************************
#GROUP(%AltKeys)
#IF(%Page2Proc)
OF Alt2 !Hotkey to Page 2
PRESS(AltN) !Press Next_Page Key
#ENDIF
#IF(%Page3Proc)
OF Alt3 !Hotkey to Page 3
LOC:Page = 2 !Press Next_Page Key
PRESS(AltN)
#ENDIF
#IF(%Page4Proc)
OF Alt4 !Hotkey to Page 4
LOC:Page = 3 !Press Next_Page Key
PRESS(AltN)
#ENDIF
#IF(%Page5Proc)
OF Alt5 !Hotkey to Page 5
LOC:Page = 4 !Press Next_Page Key
PRESS(AltN)
#ENDIF
#IF(%Page6Proc)
OF Alt6 !Hotkey to Page 6
LOC:Page = 5 !Press Next_Page Key
PRESS(AltN)
#ENDIF
#IF(%Page7Proc)
OF Alt7
LOC:Page = 6 !Hotkey to Page 7
PRESS(AltN) !Press Next_Page Key
#ENDIF
#IF(%Page8Proc)
OF Alt8
LOC:Page = 7 !Hotkey to Page 8
PRESS(AltN) !Press Next_Page Key
#ENDIF
#IF(%Page9Proc)
OF Alt9
LOC:Page = 8 !Hotkey to Page 9
PRESS(AltN) !Press Next_Page Key
#ENDIF
#!***************************************************************************
#GROUP(%ProcCounter)
#IF(%Page2Proc)
#SET(%ProcCount,'2')
#IF(%Page3Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page4Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page5Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page6Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page7Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page8Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#IF(%Page9Proc)
#SET(%ProcCount,(%ProcCount + 1))
#ENDIF
#ENDIF
#!***************************************************************************
#GROUP(%ButtonCheck)
#FOR(%ScreenField)
#IF(UPPER(%ScreenFieldUse) = '?BASE_PAGE')
#SET(%BasePageExists,'TRUE')
#ENDIF
#IF(UPPER(%ScreenFieldUse) = '?LAST_PAGE')
#SET(%LastPageExists,'TRUE')
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%SavePrimedFields)
#FOR(%Key)
#IF(%KeyAuto)
#FOR(%KeyField)
#IF(%KeyField <> %KeyAuto)
Prime::%KeyField LIKE(%KeyField)
#ENDIF
#ENDFOR
#ENDIF
#ENDFOR
#!***************************************************************************
#GROUP(%DriverCheck)
#IF(%FileType <> %PrimaryDriver)
#SET(%ErrorMessage,%NULL)
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,(' WARNING during Source Code Generation in Procedure: '& %Procedure ))
#ERROR(%ErrorMessage)
#SET(%ErrorMessage, ' the FILE Relationship uses multiple file drivers')
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,(' see FORM Template Help, TOPIC: No Transaction Framing'))
#ERROR(%ErrorMessage)
#SET(%ErrorMessage, %NULL)
#ERROR(%ErrorMessage)
#SET(%NoLogoutSupport,'TRUE')
#ENDIF
#!***************************************************************************
#GROUP(%PrimaryDriverChk)
#IF((UPPER(%PrimaryDriver) <> 'BTRIEVE') AND (UPPER(%PrimaryDriver) <> 'CLARION'))
#SET(%ErrorMessage,%NULL)
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,(' WARNING during Code Generation in Procedure: '& %Procedure ))
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,( ' PRIMARY file driver (' & %PrimaryDriver & ') does not support LOGOUT() '))
#ERROR(%ErrorMessage)
#SET(%ErrorMessage,(' see FORM Template Help, Topic: No Transaction Framing'))
#ERROR(%ErrorMessage)
#SET(%NoLogoutSupport,'TRUE')
#ENDIF
#CHAIN('OM6.TPX')