|
DataMuseum.dkPresents historical artifacts from the history of: CP/M |
This is an automatic "excavation" of a thematic subset of
See our Wiki for more about CP/M Excavated with: AutoArchaeologist - Free & Open Source Software. |
top - metrics - download
Length: 7680 (0x1e00)
Types: TextFile
Names: »COMPLETE.PRG«
└─⟦9ce0f2175⟧ Bits:30004308/disk3.imd Listaid database backup
└─⟦this⟧ »COMPLETE.PRG«
*******************************************************************************
*DESIGN: NIF/ASD/SEPTEMBER 1985
*******************************************************************************
* PROCEDURE: COMPLETE
* PARAMETERS:PRIMARY DATABASE IN USE,PPLNAME,CONFIGNAME,MDBASE
* FUNCTION: COMPLETES INFO IN PARTSLIST FROM THE CURRENTLY USED PPL & CUSTOM
*******************************************************************************
ERASE
IF MDBASE<>'DPL'
@ 10,10 SAY 'SORTING THE DATABASE'
SELECT PRIM
COPY TO WORK
USE WORK
SORT ON REF:CODE TO &OPERDBF
USE &OPERDBF
DELETE FILE WORK
ENDIF
@ 10,10 SAY 'INSERTING INFORMATION FROM PPL'
@ 1,10 SAY 'REFERENCE CODE BEING PROCESSED:'
*INSERT 'DEL' INTO GENERIC-NAME FIELD FOR ALL UNUSED COMPONENTS
SELECT PRIM
REPLACE ALL GEN:NAME WITH 'UNUSED' FOR $(REF:CODE,1,3)='DEL'
DELETE ALL FOR $(REF:CODE,1,3)='DEL'
*GIVE SOT'S A GENERIC NAME
REPLACE ALL GEN:NAME WITH REF:CODE FOR $(REF:CODE,1,3)='SOT'
DELETE ALL FOR $(REF:CODE,1,3)='SOT'
*INITIALIZE FOR PPL COMPLETION
SET LINKAGE OFF
SET DELETED OFF
SELECT SECONDARY
STORE 'PPL_'+PPLNAME+'.DBF' TO MPPL
USE &MPPL
GO BOTTOM
STORE INT(#/2) TO MHALF
GO TOP
SELECT PRIMARY
GO TOP
DO WHILE $(REF:CODE,1,1)='C'.AND..NOT.EOF
SKIP
ENDDO
*FILL FROM PPL
DO WHILE (.NOT.EOF)
SELECT SECONDARY
*SEARCH ROUTINE
IF S.REF:CODE<>P.REF:CODE
IF #>MHALF
CONTINUE
IF S.REF:CODE<>P.REF:CODE
LOCATE FOR S.REF:CODE=P.REF:CODE
ENDIF
ELSE
LOCATE FOR S.REF:CODE=P.REF:CODE
ENDIF
@ 1,55 SAY P.REF:CODE USING 'XXXXXX'
ENDIF
*COMPLETION
IF S.REF:CODE=P.REF:CODE
SELECT PRIMARY
REPLACE P.GEN:NAME WITH S.GEN:NAME
REPLACE P.SPEC:CODE WITH S.SPEC:CODE
REPLACE P.PACKAGE WITH S.PACKAGE
DO CASE
CASE MDBASE='DPL'
REPLACE P.ISSUE WITH S.ISSUE
REPLACE P.MANUF WITH S.MANUF
REPLACE P.AGENCY WITH S.AGENCY
REPLACE P.MAIN:CHAR WITH S.MAIN:CHAR
REPLACE P.CPP:NO WITH S.CPP:NO
REPLACE REQUIRED WITH COUNTER*UNITMULT
IF S.ATTRITION
IF $(PPLNAME,3,4)='TLC2'
DO CASE
CASE REQUIRED<11
REPLACE NATTR WITH INT(0.60*REQUIRED+0.5*COUNTER)
CASE REQUIRED<31
REPLACE NATTR WITH INT(0.30*REQUIRED+0.5*COUNTER)
CASE REQUIRED<101
REPLACE NATTR WITH INT(0.25*REQUIRED+0.5*COUNTER)
OTHERWISE
REPLACE NATTR WITH INT(0.20*REQUIRED+0.5*COUNTER)
ENDCASE
ELSE
DO CASE
CASE REQUIRED<5
REPLACE NATTR WITH REQUIRED
CASE REQUIRED<11
REPLACE NATTR WITH INT(0.60*REQUIRED)
CASE REQUIRED<31
REPLACE NATTR WITH INT(0.30*REQUIRED)
CASE REQUIRED<101
REPLACE NATTR WITH INT(0.25*REQUIRED)
OTHERWISE
REPLACE NATTR WITH INT(0.20*REQUIRED)
ENDCASE
ENDIF
ENDIF
CASE MDBASE='PLL'
REPLACE P.MANUF WITH S.MANUF
REPLACE P.MAIN:CHAR WITH S.MAIN:CHAR
CASE MDBASE='KIT'
*INSERT ADDITIONAL KITLIST INFO AS WANTED
ENDCASE
STORE P.REF:CODE TO MREF
IF .NOT.($(MREF,1,1)$'458')
REPLACE P.TOLERANCE WITH S.TOLERANCE
REPLACE P.RATED:VOLT WITH S.RATED:VOLT
REPLACE P.CVALUE WITH S.CVALUE
ENDIF
DELETE
ENDIF
SELECT PRIMARY
SKIP
DO WHILE (*.OR.$(REF:CODE,1,1)='C').AND.(.NOT.EOF)
SKIP
ENDDO
ENDDO
*INITIALIZE FOR CUSTOM-COMPLETION
STORE $(CONFIGNAME,1,2)-'CUS_'-$(CONFIGNAME,3,4)-'.DBF' TO MCUS
SET DELETED ON
GO TOP
LOCATE FOR $(REF:CODE,1,1)='C'
IF $(REF:CODE,1,1)='C'.AND.FILE(MCUS)
@ 10,10 SAY 'INSERTING INFORMATION FROM CUSTOM DESIGNED PARTSLIST'
SELECT SECONDARY
USE &MCUS
SELECT PRIMARY
DO WHILE .NOT.EOF
SELECT SECONDARY
LOCATE FOR S.REF:CODE=P.REF:CODE
@ 1,55 SAY P.REF:CODE USING 'XXXXXX'
SELECT PRIMARY
IF S.REF:CODE=P.REF:CODE
REPLACE P.GEN:NAME WITH S.GEN:NAME
REPLACE P.SPEC:CODE WITH S.SPEC:CODE
REPLACE P.CVALUE WITH S.CVALUE
DO CASE
CASE MDBASE='DPL'
REPLACE P.DRAWING WITH S.DRAWING
REPLACE P.MAIN:CHAR WITH S.MAIN:CHAR
REPLACE P.CPP:NO WITH S.CPP:NO
REPLACE REQUIRED WITH COUNTER*UNITMULT
IF S.ATTRITION
IF $(PPLNAME,3,4)='TLC2'
DO CASE
CASE REQUIRED<11
REPLACE NATTR WITH INT(0.60*REQUIRED+0.5*COUNTER)
CASE REQUIRED<31
REPLACE NATTR WITH INT(0.30*REQUIRED+0.5*COUNTER)
CASE REQUIRED<101
REPLACE NATTR WITH INT(0.25*REQUIRED+0.5*COUNTER)
OTHERWISE
REPLACE NATTR WITH INT(0.20*REQUIRED+0.5*COUNTER)
ENDCASE
ELSE
DO CASE
CASE REQUIRED<5
REPLACE NATTR WITH REQUIRED
CASE REQUIRED<11
REPLACE NATTR WITH INT(0.60*REQUIRED)
CASE REQUIRED<31
REPLACE NATTR WITH INT(0.30*REQUIRED)
CASE REQUIRED<101
REPLACE NATTR WITH INT(0.25*REQUIRED)
OTHERWISE
REPLACE NATTR WITH INT(0.20*REQUIRED)
ENDCASE
ENDIF
ENDIF
CASE MDBASE='PLL'
IF P.REM=' '
REPLACE P.REM WITH S.DRAWING
ENDIF
REPLACE P.MAIN:CHAR WITH S.MAIN:CHAR
ENDCASE
DELETE
ENDIF
SKIP
DO WHILE $(REF:CODE,1,1)#'C'.AND..NOT.EOF
SKIP
ENDDO
ENDDO
ELSE
IF $(REF:CODE,1,1)='C'
STORE 'CUSTOM COMPONENTS FILE MISSING FOR THIS CONFIGURATION' TO STATUS
ENDIF
ENDIF
*LIST MISING DEFINITIONS
GO TOP
SET DELETED ON
ERASE
LOCATE FOR .NOT.*
IF .NOT.*
ERASE
STORE ' ' TO DUMMY
@ 2,10 SAY 'COMPONENTS FOR WICH SPECIFICATIONS ARE MISSING:'
STORE 4 TO MROW
STORE 10 TO MCOL
DO WHILE .NOT.*
@ MROW,MCOL SAY REF:CODE USING 'XXXXXX'
STORE MCOL+10 TO MCOL
IF MCOL>=50
STORE 10 TO MCOL
STORE MROW+2 TO MROW
ENDIF
IF MROW>20
@ 22,0 SAY 'RETURN FOR MORE OUTPUT' GET DUMMY
READ
STORE 4 TO MROW
ENDIF
DELETE
CONTINUE
ENDDO
DO WHILE MROW <=20
@ MROW,MCOL SAY ' '
STORE MROW+2 TO MROW
STORE 1 TO MCOL
ENDDO
@ 22,0 SAY ' RETURN TO CONTINUE' GET DUMMY
READ
ENDIF
RELEASE DUMMY
*RETURN
SET DELETED OFF
RECALL ALL
SELECT SECONDARY
USE
SELECT PRIM
USE &OPERDBF
RETURN
«eof»