High Voltage Shareware

home *** CD-ROM | disk | FTP | other *** search

/ High Voltage Shareware / high1.zip / high1 / DIR2 / CLATPL.ZIP / CLARION5.TPX < prev next >

Wrap

Text File | 1993-07-26 | 62KB | 1,469 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 #<!Commit the transaction ELSE #<!else on any error GLO:Message1 = 'Unable to complete the transaction' GLO:Message2 = 'Error: ' & ERRORCODE() & ' ' & ERROR() GLO:Message3 = 'Files have been restored to their original values' ROLLBACK #<!Rollback the transaction ShowWarning #<!Notify the user END #<!End IF ERRORCODE() #ELSE #! NoLogoutSupport IF ERRORCODE() #<!Was the update ok? 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 IF ERRORCODE() #<!Was there an error? IF ERRORCODE() = BadRecErr #<!Record Not Available #FOR(%RelationKeyField) #IF(%RelationKeyFieldLink <> %NULL) CLEAR(%RelationKeyField) #<!Clear the component #ENDIF #ENDFOR ELSE #<!On any other error 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 BadRecErr END #<!End IF 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 & ' AND ' & %RelationKeyField &' = '& %Relation & ':Lnk:' & %RelationKeyFieldLink)) #ENDIF #ENDIF #ENDFOR %IfLine #<!Compare Link field(s) #INSERT(%RestrictUpdateCode) END #<!End related record check #ENDIF #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 EXIT #<!Exit the routine #!*************************************************************************** #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 #!*************************************************************************** #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 ! Reset restrict flag #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 IF ERRORCODE() #<!Was there an error? IF ERRORCODE() = BadRecErr #<!If Record Not Available #FOR(%RelationKeyField) #IF(%RelationKeyFieldLink <> %NULL) CLEAR(%RelationKeyField) #<!Clear the component #ENDIF #ENDFOR ELSE #<!On any other error 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 BadRecErr END #<!End IF 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 EXIT #<!Exit the Routine #!*************************************************************************** #GROUP(%SetupLogout) #FIX(%File,%SetFile) #FOR(%Relation) #IF(%RelationType = '1:MANY') #IF(%RelationConstraintUpdate = 'CASCADE') #SET(%Temp, %Relation) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #ELSIF(%RelationConstraintUpdate = 'CLEAR') #SET(%Temp, %Relation) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #ELSIF(%RelationConstraintUpdate = 'RESTRICT') #SET(%Temp, %Relation) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #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) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #ELSIF(%RelationConstraintDelete = 'CLEAR') #SET(%Temp, %Relation) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #ELSIF(%RelationConstraintDelete = 'RESTRICT') #SET(%Temp, %Relation) #IF(INSTRING(%%Temp,%LogoutList,1,1) = '0') #SET(%Logoutlist,(%Logoutlist &','& %Temp)) #ENDIF #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' ROLLBACK #<!End LOGOUT ShowWarning #<!Notify the user SELECT(?Ok) #<!Place cursor on OK 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() ROLLBACK #<!End LOGOUT ShowWarning #<!Notify the user DISABLE(1,FIELDS()) #<!Disable the screen fields ENABLE(?Cancel) #<!Enable the Cancel button SELECT(?Cancel) #<!Place the cursor on Cancel 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' ROLLBACK #<!Restore original records ShowWarning #<!Notify the user DISABLE(1,FIELDS()) #<!Disable all screen fields ENABLE(?Cancel) #<!Activate the Cancel button SELECT(?Cancel) #<!Place the cursor on Cancel 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') #IF(%CloseFiles) #!Generate function for close %Relation::Opened = CheckOpen(%Relation) #<!Ensure %Relation file is open #ELSE CheckOpen(%Relation) #<!Ensure %Relation file is open #ENDIF #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 #FOR(%Secondary) #! for fields in the list box #IF(%SecondaryType = 'MANY:1') #!Check for lookup files #FIX(%File,%SecondaryTo) #FIX(%Relation,%Secondary) #FOR(%RelationKeyField) DISPLAY(%RelationKeyField) #ENDFOR #ENDIF #ENDFOR #!*************************************************************************** #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 #<!Save for Subset numbering #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) #<!Allow for Subset numbering #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') IF KEYCODE() <> EscKey #FOR(%RelationKeyField) %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) #IF(%CloseFiles) #!Generate function for close %Relation::Opened = CheckOpen(%Relation) #<!Ensure %Relation file is open #ELSE CheckOpen(%Relation) #<!Ensure %Relation file is open #ENDIF #SET(%ErrorMessage,%NULL) #ERROR(%ErrorMessage) #SET(%ErrorMessage,( 'WARNING the File: '& UPPER(%Relation) & ' used in Procedure: '& %Procedure )) #ERROR(%ErrorMessage) #SET(%ErrorMessage,( 'does not exist in the Procedure File Schematic')) #ERROR(%ErrorMessage) #SET(%ErrorMessage, %NULL) #ERROR(%ErrorMessage) #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)&' ]' GLO:Message1 = 'This record creates a duplicate key entry' GLO:Message2 = 'The unique key field(s) are listed below: ' ShowWarning #<!inform the user END #ENDIF #ENDFOR 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) #IF(UPPER(%FormulaClass) = '') #SET(%LoopFormulasExist,'TRUE') #ENDIF #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(UPPER(%FormulaClass) <> 'SETUP') #IF(UPPER(%FormulaClass) <> 'RETURN') #IF(%CodePosition = %NULL OR %CodePosition = %FormulaClass) #IF(%FormulaType = 'COMPUTED') %Formula = %FormulaComputation #<!Computed Formula (no class) #ELSE IF %FormulaCondition #<!If Formula condition %Formula = %FormulaTrue #<! is TRUE #IF(%FormulaFalse) ELSE ! else %Formula = %FormulaFalse #<! condition is FALSE #ENDIF END #<!End formula condition #ENDIF #SET(%CurrentFormula,('?' & %Formula)) #FIX(%Screenfield,%CurrentFormula) #IF(%Screenfield) DISPLAY(?%Formula) #<!Update screen display #ENDIF #ENDIF #ENDIF #!Not PrimeKey class #ENDIF #!Not Setup class #ENDIF #!Not Return class #ENDFOR #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(RelationKeyFieldLink) IF %RelationKeyField <> %RelationKeyFieldLink #<!Check for changes DO SecondaryLookups #<!Call lookup Routine END #ENDIF #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' ROLLBACK #<!Rollback the transaction ShowWarning #<!Notify the user 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 #!*************************************************************************** #GROUP(%CloseRelatedFiles) #IF(%CloseFiles) #!Generate function for close #FIX(%File,%SetFile) #FOR(%Relation) #IF(%RelationType = '1:MANY') #SET(%FileToClose,%Relation) #IF(INSTRING(%FileToClose,%ClosedFilesList,1,1) = '0') IF %Relation::Opened THEN CLOSE(%Relation). #<!Close files opened by proc #SET(%ClosedFilesList,(%ClosedFilesList & %FileToClose)) #ENDIF #SET(%SetFile,%Relation) #INSERT(%CloseRelatedFiles) #ENDIF #ENDFOR #ENDIF #!*************************************************************************** #GROUP(%CloseRelatedFlags) #IF(%CloseFiles) #!Generate function for close #FIX(%File,%SetFile) #FOR(%Relation) #IF(%RelationType = '1:MANY') #SET(%FlagToClose,%Relation) #IF(INSTRING(%FlagToClose,%ClosedFlagsList,1,1) = '0') %Relation::Opened BYTE #<!Close flag for related files #SET(%ClosedFlagsList,(%ClosedFlagsList & %FlagToClose)) #ENDIF #SET(%SetFile,%Relation) #INSERT(%CloseRelatedFlags) #ENDIF #ENDFOR #ENDIF #!*************************************************************************** #CHAIN('CLARION6.TPX')