DataMuseum.dk

top - metrics - download

    Length: 5504 (0x1580)
    Types: TextFile
    Names: »DATABAS2.PLI«

└─⟦57f0389e8⟧ Bits:30005761 SW1611 Access Manager v. 1.0
    └─⟦this⟧ »DATABAS2.PLI« 

TextFile

ENTDAT:
	PROC (ENTER_MODE,DRN) RETURNS (CHAR(4)) EXTERNAL;

/*
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  
   		DATA ENTRY ROUTINE
  
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 */


DCL
	UNIQUE BIT(1),
	(DRN,FLD,OP_VAL,FLD_NO) FIXED,
	OP CHAR(2) VAR,
	OP1 CHAR(1),
	TEMP_MODE FIXED,
	ENTER_MODE CHAR(3);

%INCLUDE 'DATABASE.DCL';
%INCLUDE 'AM86EXTR.PLI';

DCL
	CLRSCR ENTRY,
	LOKTYP ENTRY (FIXED);

	IF ENTER_MODE = 'NEW' THEN
		DO FLD = 0 TO MAX_FIELD;
			OLD_FLD(FLD) = '';
		END;

	IF ENTER_MODE = 'OLD' THEN
		DO FLD = 0 TO MAX_FIELD;
			NEW_FLD(FLD) = OLD_FLD(FLD);
		END;

	CALL CLRSCR();

	IF ENTER_MODE = 'NEW' THEN
		DO;
		PUT SKIP EDIT ('Enter New Customer Information') (X(19),A);
		PUT SKIP EDIT ('******************************') (X(19),A);
		PUT SKIP(3) LIST (
		    '    ÆEnter zero for customer # to see main menu.Å');
		PUT SKIP(2);

		DO FLD = 0 TO MAX_FIELD;
			FLD_NO = FLD + 1;
REDO_DATA:
			PUT EDIT (FLD_NO,' - ',FLD_NAME(FLD),
				'(',FLD_LEN(FLD),') >>')
				(F(6),2A,COLUMN(30),A,F(2),A);
			GET EDIT (NEW_FLD(FLD))(A);
			IF FLD = KEY_MAP(UNIQ_KEY) & NEW_FLD(FLD) = '0' THEN
				RETURN('STOP');

			IF FLD = KEY_MAP(UNIQ_KEY) THEN
				DO;
				NEW_FLD(FLD) = RIGHT('0000' øø NEW_FLD(FLD),
					FLD_LEN(FLD));
				UNIQUE = TEST_UNIQUENESS();
				END;
			ELSE
				DO;
				NEW_FLD(FLD) = SUBSTR(NEW_FLD(FLD),1,
					FLD_LEN(FLD));
				UNIQUE = YESBIT;
				END;

			IF üUNIQUE THEN GOTO REDO_DATA;
		END;
		TEMP_MODE = NEW_MODE;
		END;
	ELSE
		TEMP_MODE = OLD_MODE;
 
	DO WHILE (FOR_EVER);
		PUT SKIP(4) EDIT ('Current customer information')
			(X(19),A);
		PUT SKIP;

		DO FLD = 0 TO MAX_FIELD;
			FLD_NO = FLD + 1;
			PUT SKIP EDIT (FLD_NO,' - ',FLD_NAME(FLD),NEW_FLD(FLD))
				(F(6),2A,COLUMN(30),A);
		END;

		IF TEMP_MODE = OLD_MODE THEN
			BEGIN;
			OP_VAL = 0;
			ON ERROR(1)
				BEGIN;
				OP_VAL = 0;
				GOTO RETRY_OLD;
				END;
RETRY_OLD:
			DO WHILE (OP_VAL < 1 ø OP_VAL > NO_FIELDS);
				PUT SKIP(3) EDIT (
'Enter C to continue scan, Field # to change data, S to save changes,',
'D to delete data, B for back scan, or E to end scan >>') (A,SKIP,A);
				GET LIST (OP);
				OP1 = OP;
				IF OP1 = 'C' ø OP1 = 'c' THEN RETURN('CONT');
				IF OP1 = 'S' ø OP1 = 's' THEN 
					RETURN('SAVE');
				IF OP1 = 'D' ø OP1 = 'd' THEN 
					RETURN(SET_XLOCK(OP1,DRN));
				IF OP1 = 'B' ø OP1 = 'b' THEN RETURN('BACK');
				IF OP1 = 'E' ø OP1 = 'e' THEN RETURN('STOP');
				OP_VAL = OP;
			END;
			CALL UPDATE_FIELD(OP_VAL);
			END;
		ELSE
			BEGIN;
			OP_VAL = 0;
			ON ERROR(1)
				BEGIN;
				OP_VAL = 0;
				GOTO RETRY_NEW;
				END;
RETRY_NEW:
			DO WHILE (OP_VAL < 1 ø OP_VAL > NO_FIELDS);
				PUT SKIP (3) EDIT (
'Enter S to save data, Field # to change data,',
'D to delete data, or E to end input >>') (A,SKIP,A);
				GET LIST (OP);
				OP1 = OP;
				IF OP1 = 'S' ø OP1 = 's' THEN RETURN('SAVE');
				IF OP1 = 'D' ø OP1 = 'd' THEN RETURN('DELT');
				IF OP1 = 'E' ø OP1 = 'e' THEN RETURN('STOP');
				OP_VAL = OP;
			END;
			CALL UPDATE_FIELD(OP_VAL);
			END;
	END;


SET_XLOCK:
	PROC (OP,DRN) RETURNS (CHAR(ACTION_LEN));
DCL
	DRN FIXED,
	(DUMMY,OP) CHAR(1);

	DUMMY = 'W';
	DO WHILE (DUMMY = 'W' & SETLOK(FILE_NO,XLOCK,DRN) ü=  0);
		PUT SKIP (2) EDIT (
'Customer update on hold due to record lock',
'Enter W if you wish to wait or any other key to cancel update>>')
(A,SKIP,A);
		GET LIST (DUMMY);
		IF DUMMY = 'w' THEN DUMMY = 'W';
	END;
	
	IF DUMMY = 'W' THEN
		DO;
		IF OP = 'S' THEN
			RETURN('SAVE');
		ELSE
			RETURN('DELT');
		END;
	ELSE
		RETURN(OLD_ACTION);
END SET_XLOCK;


/*
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  
   		UPDATE DATA FIELD ROUTINE
  
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 */

UPDATE_FIELD:
	PROC (FLD_NO);
DCL
	TEST BIT(1),
	(FLD_NO,FIELD_NO) FIXED;

	FIELD_NO = FLD_NO-1;
	TEST = NOBIT;

	DO WHILE (üTEST);
		PUT SKIP(2) EDIT ('Input new ',FLD_NAME(FIELD_NO),'>>')
			(3A);
		GET EDIT (NEW_FLD(FIELD_NO))(A);
	
		IF FIELD_NO = KEY_MAP(UNIQ_KEY) THEN
			NEW_FLD(FIELD_NO) = RIGHT('0000' øø NEW_FLD(FIELD_NO),
				FLD_LEN(FIELD_NO));
		ELSE
			NEW_FLD(FIELD_NO) = SUBSTR(NEW_FLD(FIELD_NO),1,
				FLD_LEN(FIELD_NO));

		IF FIELD_NO = KEY_MAP(UNIQ_KEY) & NEW_FLD(FIELD_NO) ü=
		    OLD_FLD(FIELD_NO) THEN
			TEST = TEST_UNIQUENESS();
		ELSE
			TEST = YESBIT;
	END;
END UPDATE_FIELD;


/*
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  
   		CUST # UNIQUENESS TEST ROUTINE
  
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 */

TEST_UNIQUENESS:
	PROC RETURNS (BIT(1));
DCL
	TEMP FIXED,
	TEST CHAR(MAX_FLD_LEN) VAR;

	TEST = NEW_FLD(KEY_MAP(UNIQ_KEY));
	TEMP = GETKEY(UNIQ_KEY,0,NLOCK,TEST);

	IF LOKCOD() ü= 0 THEN
		CALL LOKTYP(12);
	IF TEMP = 0 THEN
		RETURN(YESBIT);
      	ELSE
		DO;
		PUT SKIP(2) LIST (' *** Already Assigned ***');
		PUT SKIP;
		RETURN(NOBIT);
		END;
END TEST_UNIQUENESS;


/*
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
  
   		RIGHT STRING ROUTINE
  
   :::::::::::::::::::::::::::::::::::::::::::::::::::::::::::::
 */

RIGHT:
	PROC (FLDSTR,FLDLEN) RETURNS (CHAR(MAX_FLD_LEN) VAR);
DCL
	FLDLEN FIXED,
	FLDSTR CHAR(MAX_FLD_LEN) VAR;

	RETURN(SUBSTR(FLDSTR,LENGTH(FLDSTR)-FLDLEN+1));
END RIGHT;

END ENTDAT;
«eof»