CNCCreateProg()   ; parameters: BedKey,KlantID,DestinDir,ProgType
 Quit:(%this.IsLeeg()) 1
 New StackF,SortedF,Resl
 Kill StackF, SortedF
 Set StackF=""
 Set SortedF=""
 Do %this.CNCBuildList(.StackF)
 Do %this.CNCOptimize(.StackF, .SortedF)
 Set Resl=%this.CNCBuildProg(.SortedF,$G(KlantID),$G(DestinDir),$G(ProgType))
 Quit Resl
 
 
 /*
 ====================================================================================================
 CNCBuildList :
   Bepalen van de posities van de frezingen in het Kaliber
   Opbouwen van de lijst van alle frezingen in het bed, gesorteerd volgens FreesTool.ItemID
 ====================================================================================================
 */
CNCBuildList   ; Parameters: .StackF
 New VakKey,emVak,FKey,emFrez,ToolID,D,FToolCnt
 New emPos,X,Y,Z,emProf,ProfType,PHght,DefVak   ; vars used in cblTransFormXYZ()
 Set D="\"
 Set VakKey=""
 For  Set emVak=%this.Vakken.GetNext(.VakKey) Quit:(VakKey="")  Do
 . Quit:(emVak.BezetCode'="P")   ; Frezingen alleen als Vak bezet is met een profiel
 . Set FKey=""
 . For  Set emFrez=emVak.Profiel.Frezingen.GetNext(.FKey) Quit:(FKey="")  Do
 ..  Quit:(emFrez.StatusFreesTool="P")   ; Prevent frezing
 ..  Quit:('emFrez.FreesTool)
 ..  Set ToolID=emFrez.FreesTool.ItemID
 ..  Set StackF=$G(StackF,0)+1
 ..  ;Set StackF(ToolID)=$G(StackF(ToolID),0)+1   ; ORIG CACHE v4
 ..  ;Set StackF(ToolID,StackF(ToolID))=$$cblTransFormXYZ(emFrez,emVak,VakKey,D)_D_emFrez.Diameter_D_emVak_D_emFrez   ; ORIG CACHE v4
 ..  Set FToolCnt=$G(StackF(ToolID),0)+1
 ..  Set StackF(ToolID)=FToolCnt
 ..  Set StackF(ToolID,FToolCnt)=$$cblTransFormXYZ(emFrez,emVak,VakKey,D)_D_emFrez.Diameter
 ..  Set StackF(ToolID,FToolCnt,"VAK")=emVak
 ..  Set StackF(ToolID,FToolCnt,"FREZ")=emFrez
 Quit
cblTransFormXYZ(emFrez,emVak,VakKey,D)
 ; Returns X, Y and Z as the first, second and third piece of a string, separated by D
 ;New emPos,X,Y,Z,emProf,ProfType,PHght,DefVak   ; See CNCBuildList
 Set emPos=emFrez.Positie.GetNext("")
 Set X=emPos.X
 Set Y=emPos.Y
 Set Z=emPos.Z
 Set emProf=emVak.Profiel
 Set ProfType=emProf.KaderDeur.ProfType
 Set PHght=$$LosProfGroepHeight^VHSys.Library.VMLLib(ProfType.Breedte, ProfType.Dikte, emProf.ProfZijkant)
 If emVak.Richting="I" Do
 . ; Inverse plaatsing van het profiel
 . Set X=emProf.Lengte-X
 . Set Y=PHght-Y           
 
 ; Offset van emVak bijtellen
 Set DefVak=%this.BedDef.Vakken.GetAt(VakKey)
 Set X=X+DefVak.BeginPos.X
 If DefVak.Richting="I" Do   ; bij universeel kaliber liggen profielen RUG aan RUG:  afwisselend vertrekken van EindPos.Y
 . Set Y=Y+(DefVak.EindPos.Y-PHght)
 Else  Do
 . Set Y=Y+DefVak.BeginPos.Y
 
 ; Correctie op Z-positie  (Bvb. PBG-ON en PSV-ON opgehoogd m.b.v. een steuntje).
 Set Z=Z+%this.BedDef.ProfSpecs.GetAt(%this.ProfielBeperking).ZCorrectie
 ; Offset van BedDef (=BedDef.AbsoluutPos) bijtellen  ; Heeft geen invloed op de Optimalisatie, dus pas later uitvoeren; Controles!!!.
 ;Set X=X+%this.BedDef.AbsoluutPos.X
 ;Set Y=Y+%this.BedDef.AbsoluutPos.Y
 Quit X_D_Y_D_Z   ; delimited list
 
 
 /*
 ====================================================================================================
 CNCOptimize
   Optimalisatie van de freesbeweging: 
   De lijst van frezingen sorteren zodanig dat de afgelegde weg van de freesmachine aanzienlijk 
   verkleind wordt. 
 ====================================================================================================
 */
CNCOptimize   ; Parameters: .StackF,.SortedF
 New tmpStack,Nr,ToolID,D
 New X,Y,iNr,tmpNr,iDist,MinDist   ; vars used in copFindNext()
 Set D="\"
 Set ToolID=""
 For  Set ToolID=$O(StackF(ToolID)) Quit:(ToolID="")  Do
 . Kill tmpStack
 . Merge tmpStack=StackF(ToolID)   ; Copy complete sub-node to tmpStack
 . Set Nr=""
 . For  Quit:($$copFindNext(.Nr)="")  Do
 ..  Set SortedF=$G(SortedF,0)+1
 ..  Set SortedF(ToolID)=$G(SortedF(ToolID),0)+1
 ..  ;Set SortedF(ToolID,SortedF(ToolID))=tmpStack(Nr)   ; ORIG CACHE v4
 ..  Merge SortedF(ToolID,SortedF(ToolID))=tmpStack(Nr)
 Quit
copFindNext(Nr)
 ; Determines the position closed to the current frezing.
 ; Returns Nr, the index of the new node.
 ; parameter Nr is also modified, so it can be passed BY REFERENCE
 ;New X,Y,iNr,tmpNr,iDist,MinDist   ; see CNCOptimize
 Set X=$S($G(Nr)="":0, 1:$P(tmpStack(Nr),D,1))
 Set Y=$S($G(Nr)="":0, 1:$P(tmpStack(Nr),D,2))
 Set MinDist=""
 Set iNr=""
 For  Set iNr=$O(tmpStack(iNr)) Quit:(iNr="")  Do
 . Quit:($G(tmpStack(iNr,"Flag"))'="")   ; Skip if already sorted
 . Set iDist=$$copCalcDist(X,Y, $P(tmpStack(iNr),D,1),$P(tmpStack(iNr),D,2))
 . Quit:(iDist<0)
 . If (iDist<MinDist)||(MinDist="") Do
 ..  Set MinDist=iDist
 ..  Set tmpNr=iNr
 Set Nr=$S(MinDist="":"", 1:tmpNr)
 Set:(Nr'="") tmpStack(Nr,"Flag")="S"   ; Set Flag, to exclude frezing from optimization
 Quit Nr
copCalcDist(X1,Y1,X2,Y2)   ; Returns a float number (positive or 0) when coordinates are valid numbers; else returns -1
#define SQUARE(%v)    $ZPOWER(%v,2)
#define ValidCoords   $IsValidNum(X1) && $IsValidNum(Y1) && $IsValidNum(X2) && $IsValidNum(Y2)
 Quit:($$$ValidCoords) $ZSQR($$$SQUARE(X2-X1)+$$$SQUARE(Y2-Y1))
 Quit -1   ; else !
 
 // Previous code:
 ;If ((+X1=0)&(X1'="0"))||((+Y1=0)&(Y1'="0"))||((+X2=0)&(X2'="0"))||((+Y2=0)&(Y2'="0")) Quit -1
 ;Quit $ZSQR($$$SQUARE(X2-X1)+$$$SQUARE(Y2-Y1))
 
 
 /*
 ====================================================================================================
 CNCBuildProg
   Iedere frezing van de lijst wordt geconverteerd naar de CNC-code
   en wordt toegevoegd aan de volledige code.  Deze moet opgesplitst worden als de
   maximaal toegelaten lengte zal overschreden worden.  Frezingen van eenzelfde tool worden echter
   wel bijeen gehouden.
 ====================================================================================================
 */
CNCBuildProg()   ; Params: SortedF,KlantID,DestinDir,ProgType
#define MxSize          15000
#define ChrNewLine      "#"
#define CrLf            $C(13,10)
#define DebugErr        "DebugError"
#define FileExtCNC      ".ANC"
#define FileExtPPG      ".PPG"
#define ParseMACInit    "@@ParseMACInit@@"
#define ParseMACCmd     "@@ParseMACCmd@@"
#define FCodeZMin       -2.5
#define FCodeYMid       100.2
 ; From a sorted list of Frezingen translate the formulas and concatenate all texts into 1 string.
 ; Because of the limitations of the CNC-machine hardware, CNC-Progs can not be larger than a predefined size, so we have to split
 
 ;Do DEBUG^%Serenji("labelDebug+1^"_$zn,"192.168.1.97")
 ;labelDebug
 New D,MultiBed,objKlant,KLNaam,PPartNum,LnNumLast,MaxBytes,MsgProgOK,pYMID,LBSortID,FToolTabelID
 New ToolID,Nr,LB,arLB,ProgTool,ProgAll,sHeader,FTbegin,sBegin,FTend,sEnd,sFinish
 Do cbpClearLogError
 Set D="\"
 Set MultiBed=%this.EindeVolgNr-BedKey+1   ; BEDKEY komt uit het niets !!!
 Set objKlant=##class(Derde.Klant.Klant).%OpenId(KlantID)
 Set:(objKlant) KLNaam=objKlant.Naam
 Do:(objKlant) objKlant.%Close()
 ; Prepare Prog variables
 Set PPartNum=0
 Set LnNumLast=0
 Set MaxBytes=$$$MxSize
 Set MsgProgOK=1
 Set pYMID=$$$FCodeYMid   ; Parameter voor FCode: bij iedere Tool-wissel naar het midden van de kaliber (in de Y-richting) gaan.
 Set FToolTabelID=##class(Res.PI.Definitie).IDViaNaam("FreesTool")
 Set LBSortID=$$cbpBuildSortToolList
 ; Prepare Header
 Set sHeader="INFO: "_$$$CrLf
 Set sHeader=sHeader_"  Gemaakt op : "_$ZDATETIME($H,4)_$$$CrLf
 Set sHeader=sHeader_"  Klant      : "_$G(KLNaam)_$$$CrLf
 Set sHeader=sHeader_"  Toelevering: "_%this.ToelevListGet(";","D")_$$$CrLf
 Set sHeader=sHeader_"  Kaliber    : "_%this.BedDef.Omschrijving_$$$CrLf
 If (%this.BedDef.KaliberType="UN") Do   ; Only for "Universeel" type
 . Set sHeader=sHeader_"  Profielen  : "_%this.ProfielBeperking_$$$CrLf
 Set sHeader=sHeader_"  VolgNr     : "_BedKey_$S(MultiBed>1:"-"_%this.EindeVolgNr_" ("_MultiBed_"x)" , 1:"")_$$$CrLf
 Set sHeader=sHeader_"-------------------------------------"_$$$CrLf
 ; Prepare Begin CNC-code
 Set FTbegin=##class(Res.PI.FreesTool).%OpenId("13||BEGIN")
 Set:(FTbegin) sBegin=FTbegin.CNCCode.GetAt("S001")
 Do:(FTbegin) FTbegin.%Close()
 ; Prepare End CNC-code
 Set FTend=##class(Res.PI.FreesTool).%OpenId("13||END")
 Set:(FTend) sEnd=FTend.CNCCode.GetAt("S001")
 Do:(FTend) FTend.%Close()
 ; Prepare Close CNC-Progs code
 Set sFinish="/** EINDE PROGRAMMA **"_$$$CrLf
 
 ; Create complete files (CNCProgs)
 Do %this.CNCFiles.Clear()
 Do cbpProgBegin(.LnNumLast)
 Set ToolID=""
 For  Set ToolID=$$cbpGetNextToolID(.LBSortID,ToolID)  Quit:(ToolID="")  Do
 . Set ProgTool=""
 . Set Nr=""
 . For  Set Nr=$O(SortedF(ToolID,Nr)) Quit:(Nr="")  Do
 ..  ;Set LB=SortedF(ToolID,Nr)   ; ORIG CACHE v4
 ..  ;Do cbpAddToProgTool($$cbpTranslateFormulas(Nr,LB), Nr)   ; ORIG CACHE v4
 ..  Kill arLB
 ..  Merge arLB=SortedF(ToolID,Nr)
 ..  Do cbpAddToProgTool($$cbpTranslateFormulas(Nr,.arLB), Nr)
 . Do cbpAddToProgTool($$cbpTranslateFormulasShort(999,ToolID), "END")   ; Om code per Tool af te sluiten
 . If $L(ProgAll)+$L(ProgTool)>MaxBytes Do   ; Split up the ProgAll string if its size becomes too large
 ..  Do cbpProgEnd(.LnNumLast)     ; Close current ProgAll ...
 ..  Do cbpProgBegin(.LnNumLast)   ; ... and start a new ProgAll
 . ; Add numbered lines from this ProgTool to ProgAll
 . Set ProgAll=ProgAll_$$cbpLineNumbers(ProgTool, .LnNumLast, 10)_$$$CrLf
 Do cbpProgEnd(.LnNumLast)
 Quit MsgProgOK
 
cbpClearLogError
 Do cbpLogError("","$KILL")
 Quit
cbpLogError(ErrType,ErrMsg)
 Quit
 Set ClientIP="192.168.1.97"
 Do WL^vhDBG("arLogFT: "_ErrType_" - "_$G(ErrMsg))
 Quit
 Do DEBUG^WV("arLogFT",ErrType,"",$G(ErrMsg),1)
 Quit
 
cbpBuildSortToolList()
 New LB,LBUndef,Nr
 Set (LB,LBUndef)=""
 Set ToolID=""
 For  Set ToolID=$O(SortedF(ToolID))  Quit:(ToolID="")  Do
 . Set Nr=$$cbpToolIDVolgorde(FToolTabelID_"||"_ToolID)
 . If Nr>0  Set $LI(LB,Nr)=ToolID
 . Else  Set LBUndef=LBUndef_$LB(ToolID)
 Quit LB_LBUndef
cbpToolIDVolgorde(objID)
 Quit:($G(objID)="") ""
 New Num
 &sql(DECLARE crsFT CURSOR FOR SELECT FreesVolgorde INTO :Num FROM Res_PI.FreesTool WHERE (ID=:objID))
 &sql(OPEN crsFT)
 &sql(FETCH crsFT)   ; Fetch FreesVolgorde
 &sql(CLOSE crsFT)
 Quit $G(Num)
 
cbpGetNextToolID(LBSortID,ToolID)
 Quit:($L($G(LBSortID))=0) $O(SortedF(ToolID))
 ; Else  Do
 For  Set ToolID=$$cbpGetNextFromLB(LBSortID,ToolID)  Quit:(ToolID="")||($D(SortedF(ToolID)))
 Quit ToolID
cbpGetNextFromLB(LBSortID,ToolID)
 Quit:($L($G(LBSortID))=0) ""
 New CntIDs,i,Pos
 Set CntIDs=$LL(LBSortID)
 Set Pos=$S(ToolID="":0, 1:$LF(LBSortID,ToolID))
 For i=Pos+1:1:CntIDs+1  Quit:($L($LG(LBSortID,i)))
 Quit $LG(LBSortID,i)
 
cbpAddToProgTool(TCode,Nr)
 ; Adds one line of code to ProgTool
 If TCode=$$$DebugErr Do  Quit
 . Set MsgProgOK="0;Fout bij creatie van de CNC-code (ToolID="_ToolID_$S(Nr="END":", Array 999)", 1:")"_$C(13,10)_LB)
 . Do cbpLogError("FATAL","0;Fout bij creatie van de CNC-code (ToolID="_ToolID_$S(Nr="END":", Array 999)", 1:")"_$C(13,10)_LB))
 Set ProgTool=ProgTool_TCode_$$$ChrNewLine
 Quit
cbpProgBegin(LnNumLast)
 Set PPartNum=$INCREMENT(PPartNum,1)
 Set LnNumLast=0
 Set ProgAll=""
 Set ProgAll=sHeader
 Set ProgAll=ProgAll_"START"_$$$CrLf
 ; Bed.Zone afhankelijke code:  Links of rechtse bed
 Set ProgAll=ProgAll_"/$MAC:"_$$$ParseMACInit_"        ' laden macro "_$$$CrLf
 Set ProgAll=ProgAll_$$cbpLineNumbers($$$ParseMACCmd, .LnNumLast, 10)_$$$CrLf   
 ; Algemene begincode
 Set:($L(sBegin)) ProgAll=ProgAll_$$cbpLineNumbers(sBegin, .LnNumLast, 10)_$$$CrLf
 Quit
cbpProgEnd(LnNumLast)
 Set:($L(sEnd)) ProgAll=ProgAll_$$cbpLineNumbers(sEnd, .LnNumLast, 10)_$$$CrLf
 Set ProgAll=ProgAll_sFinish
 ;Do cbpProgToFile($S(%this.BedDef.KaliberType="UN":"L;R" ,1:%this.CNCZone))
 Do cbpProgToFile($S(%this.BedDef.KaliberType="UN":"L" ,1:%this.CNCZone))
 Quit
cbpLineNumbers(FCode,PrevNum,Increment)
 ; FCode and PrevNum should be passed BY REFEERENCE !
 ; Adds a line number in front of each line.
 ; PrevNum is modified and has a final value equal to the last line number.
 Quit:($G(FCode)="") ""
 New i
 Set PrevNum=$G(PrevNum,0)
 For i=1:1:$L(FCode,$$$ChrNewLine) Do
 . Set $P(FCode,$$$ChrNewLine,i)="N"_$INCREMENT(PrevNum,$G(Increment,10))_" "_$P(FCode,$$$ChrNewLine,i)
 ; Now replace all $$$ChrNewLine characters by real $$$CrLf.
 Set FCode=$$REPLACE^vhRtn1(FCode, $$$ChrNewLine, $$$CrLf)
 Quit FCode
 
cbpProgToFile(lstLR)
 ; lstLR is a stringlist (";"-delimited) containing values "L", "R" or "L;R"
 Do:($G(DestinDir)="") cbpLogError("WARN","DestinDir is leeg")
 Quit:($G(DestinDir)="")
 New OutF,FilePath,FileName,BaseName,ToelevNr,i,ProgFinal
 Set ToelevNr=$P(%this.ToelevListGet(";", ""),";")
 Do:($G(ToelevNr)="") cbpLogError("WARN","ToelevNr is leeg")
 Quit:(ToelevNr="")
 Set lstLR=$G(lstLR,"L")
 Set BaseName=ToelevNr_$$cbpGetNextNum(ToelevNr)
 Set BaseName=$E(BaseName,3,99)_$$CheckDigit(BaseName)
 For i=1:1:$L(lstLR,";") Do   ; Quit:($E($G(MsgProgOK),1,2)="0;")
 . Set FileName=BaseName_$P(lstLR,";",i)_$S($G(ProgType)="PPG":$$$FileExtPPG, 1:$$$FileExtCNC)
 . Set FilePath=##class(%Library.File).NormalizeDirectory(DestinDir)_FileName
 . Set OutF=##class(%Library.File).%New(FilePath)
 . Do OutF.Open("WSN")
 . If OutF.IsOpen Do
 ..  Do OutF.Rewind()
 ..  ; Bed.Zone afhankelijke code:  "L"inkse of "R"echtse bed
 ..  If $P(lstLR,";",i)="R" Set ProgFinal=$$REPLACE^vhRtn1($$REPLACE^vhRtn1(ProgAll, $$$ParseMACInit,"901,903"), $$$ParseMACCmd,"<MAC,903>")
 ..  Else                   Set ProgFinal=$$REPLACE^vhRtn1($$REPLACE^vhRtn1(ProgAll, $$$ParseMACInit,"901"), $$$ParseMACCmd,"")
 ..  Do:($G(ProgType)="PPG") %this.CNCFilterANC(.ProgFinal)
 ..  Do OutF.Write(ProgFinal)
 ..  Do:(i=1) %this.CNCFiles.Insert(FileName)
 . Else  Do
 ..  Set MsgProgOK="0;Kan bestand niet openen: "_FilePath
 ..  Do cbpLogError("FATAL","0;Kan bestand niet openen: "_FilePath)
 . Do OutF.%Close()
 Quit
cbpGetNextNum(ToeNr)
 ; Geeft een code terug voor de nummering van het CNC-bestand (volgens onderstaand systeem):
 ;   Nr: 1,...,26   ==> A,...,Z
 ;   Nr: 27,...,52  ==> BA,...,BZ
 ;   Nr: 53,...,78  ==> CA,...,CZ
 ;   ...
 ;   Laatste Nrs: ...,675,676 (=26*26)  ==> ...,ZY,ZZ
 ;   Nrs 677,678,... worden herleid naar 1,2,...
#define HALUXNR         6332
 Quit:($G(ToeNr)="") ""
 New NrKTO
 If $E(ToeNr,1)="9" Do   ; Test case: ToeNr=9##.###
 . Set NrKTO=$G(^KTO(0,"FTNr"),0)
 . Set ^KTO(0,"FTNr")=$INCREMENT(NrKTO)
 . ;Set NrKTO=$INCREMENT(^KTO(0,"FTNr"))   ; Werkt NIET; ^KTO is in MSM  -  $INC() alleen op CACHé globals.
 Else  Do   ; Reële Toelevering
 . Set:($G(^KTO($$$HALUXNR,ToeNr,1))="") ^KTO($$$HALUXNR,ToeNr,1)=$G(^KTO($$$HALUXNR,ToeNr,1),"")   ; Kan anders niet ge-locked worden.
 . Lock +^KTO($$$HALUXNR,ToeNr,1)
 . Set NrKTO=$P(^KTO($$$HALUXNR,ToeNr,1), D, 4)
 . Set $P(^KTO($$$HALUXNR,ToeNr,1), D, 4)=$INCREMENT(NrKTO)
 . Lock -^KTO($$$HALUXNR,ToeNr,1)
 Set NrKTO=((NrKTO-1)#676)   ; (26*26)
 Quit $S(NrKTO\26>0:$C($A("A")+(NrKTO\26)), 1:"")_$C($A("A")+(NrKTO#26))
CheckDigit(BaseName)
 New Sum,i,iChar
 For i=1:1:$L(BaseName) Do
 . Set iChar=$E(BaseName,i)
 . Set Sum=$G(Sum)+(i*$S(iChar?.N:iChar, 1:10+$A(iChar)-$A("A")))
 Quit $E("ABCDEFGHJKLMNPQRSTUVWXY",(Sum-1)#23+1)   ; Skip chars. "I", "O", "Z"
 
cbpTranslateFormulasShort(ArrayNr,ToolID)
 ; Om code per (Prog)Tool af te sluiten
 ; Verkorte routine.  Zoekt niet naar emVak, emFrez, ... 
 New FCode,TCode,Reslt,OffsetZ,objFreesTool
 New pTOOLD,pZ2,pVLH,pMACHABSZ
 Set objFreesTool=##class(Res.PI.FreesTool).%OpenId(FToolTabelID_"||"_ToolID)
 If 'objFreesTool Do  Quit $$$DebugErr
 . Do cbpLogError("FATAL","objFreesTool "_FToolTabelID_"||"_ToolID_" bestaat niet")
 ;Quit:('objFreesTool) $$$DebugErr
 Set FCode=$$cbpGetCNCCode(objFreesTool, ArrayNr, 0)
 If '$L(FCode) Do  Quit ""
 . Do cbpLogError("WARN","FCode is leeg voor "_objFreesTool.%Id()_" Nr:"_ArrayNr)
 ;Quit:(FCode="") ""
 ; Formula-code: contains formulas that should be translated
 Set pTOOLD=objFreesTool.Diameter
 Set pVLH=%this.BedDef.VrijeLoopHoogte
 Set pMACHABSZ=%this.BedDef.AbsoluutPos.Z
 Set Reslt=$$cbpTranslate(.FCode)
 Set TCode=FCode   ; Translated-code: formulas are translated to real values
 Quit:(Reslt="0;Error") $$$DebugErr
 Quit TCode
cbpTranslateFormulas(ArrayNr,arLB)
 New emFrez,emVak
 New FCode,TCode,Reslt,OffsetZ,Diepte
 New pX1,pY1,pZ1,pDIAM,pTOOLD,pZ2,pVLH,pMACHABSZ   ; Parameters that can be translated in FCode
 ;Set emVak=$P(arLB,D,5)   ; ORIG CACHE v4
 Set emVak=$G(arLB("VAK"))
 If 'emVak Do  Quit $$$DebugErr
 . Do cbpLogError("FATAL","emVak niet gevonden")
 ;Quit:('emVak) $$$DebugErr
 ;Set emFrez=$P(arLB,D,6)   ; ORIG CACHE v4
 Set emFrez=$G(arLB("FREZ"))
 If 'emFrez Do  Quit $$$DebugErr
 . Do cbpLogError("FATAL","emFrezing niet gevonden")
 ;Quit:('emFrez) $$$DebugErr
 If 'emFrez.FreesTool Do  Quit $$$DebugErr
 . Do cbpLogError("FATAL","emFrez.FreesTool niet gevonden")
 ;Quit:('emFrez.FreesTool) $$$DebugErr
 Set FCode=$$cbpGetCNCCode(emFrez.FreesTool, ArrayNr, emVak.Richting="I")
 If '$L(FCode) Do  Quit ""
 . Do cbpLogError("WARN","FCode is leeg voor "_emFrez.FreesTool.%Id()_" Nr:"_ArrayNr_" Richting"_emVak.Richting)
 ;Quit:(FCode="") ""
 ; Formula-code: contains formulas that should be translated
 Set OffsetZ=%this.BedDef.OffsetZ
 Set pX1=$P(arLB,D,1)   ; +%this.BedDef.AbsoluutPos.X
 Set pY1=$P(arLB,D,2)   ; +%this.BedDef.AbsoluutPos.Y
 Set pZ1=$P(arLB,D,3)+OffsetZ
 Set pDIAM=emFrez.Diameter
 Set:(pDIAM'>0) pDIAM=3
 Set Diepte=$S(emFrez.Diepte>1:emFrez.Diepte, 1:emFrez.FreesTool.BoorDiepte)
 Set pZ2=$S(emFrez.FreesTool.DiepteType="D":Diepte+OffsetZ, 1:pZ1-Diepte)
 ;Set pZ2=$S(emFrez.FreesTool.DiepteType="D":emFrez.FreesTool.BoorDiepte+OffsetZ, 1:pZ1-emFrez.FreesTool.BoorDiepte)
 Set pTOOLD=emFrez.FreesTool.Diameter
 Set pVLH=%this.BedDef.VrijeLoopHoogte   ; 65
 Set pMACHABSZ=%this.BedDef.AbsoluutPos.Z
 Set Reslt=$$cbpTranslate(.FCode)
 Set TCode=FCode   ; Translated-code: formulas are translated to real values
 Quit:(Reslt="0;Error") $$$DebugErr
 Quit TCode
cbpGetCNCCode(objFreesTool,Nr,blnInvers)
 Quit:($G(objFreesTool)="") ""
 New CNCKey,FCode
 Set FCode=""
 If blnInvers Do
 . Set CNCKey="I"_$E(Nr+1000,2,4)      ; Convert Number e.g. 7 ==> "I007"
 . Set FCode=objFreesTool.CNCCode.GetAt(CNCKey)
 . Set:(FCode="")&(Nr'=(1000-1)) FCode=objFreesTool.CNCCode.GetPrevious(.CNCKey)
 . Set:($E(CNCKey,1)'="I") FCode=""   ; When GetPrevious did modify CNCKey: check if it is still "Invers"
 If ('blnInvers)!(FCode="") Do
 . Set CNCKey="S"_$E(Nr+1000,2,4)      ; Convert Number e.g. 7 ==> "S007"
 . Set FCode=objFreesTool.CNCCode.GetAt(CNCKey)
 . Set:(FCode="")&(Nr'=(1000-1)) FCode=objFreesTool.CNCCode.GetPrevious(.CNCKey)
 . Set:($E(CNCKey,1)'="S") FCode=""   ; When GetPrevious did modify CNCKey: check if it is still "Std"
 Quit FCode
cbpTranslate(FCode)
#define LCASE(%v)   $ZCVT(%v,"L")
 ; Variabels  pX1,pY1,pZ1,pDIAM,pTOOLD,pZ2,pVLH,pMACHABSZ  should already exist
 New Accol,EndAccol,sEval,Formul,CheckCode,RetVal,Reslt
 Set $ZTRAP="cbpEVALTRAP^"_$zn
 Set Reslt=""
 Set Accol=0
 For  Set Accol=$F(FCode, "{", Accol)  Quit:(Accol'>0)  Do
 . Set EndAccol=$F(FCode, "}", Accol)
 . If EndAccol'>0 Do  Quit
 ..  Do cbpLogError("FATAL","Accolade geopend, maar niet gesloten. "_FCode)
 ..  Set Reslt="0;Error"
 . Set CheckCode=""
 . Set sEval=$E(FCode,Accol,EndAccol-2)
 . Set Formul=sEval
 . If Formul?1(1"["0.2E1"]".E) Do
 ..  Set CheckCode=$$$LCASE($E(Formul,2,$F(Formul,"]")-2))
 ..  Set $E(Formul,1,$F(Formul,"]")-1)=""
 . Xecute "Set RetVal="_Formul
 . Do:($L(CheckCode)) cbpCheckRetVal
 . Set:(RetVal="0;Error") Reslt="0;Error"
 . Set FCode=$$REPLACE^vhRtn1(FCode, "{"_sEval_"}", RetVal)
 Quit Reslt
cbpEVALTRAP
 ; Error trapping when evaluating Formul
 Set RetVal="0;Error"
 Do cbpLogError("FATAL","Fout bij de evaluatie van {"_sEval_"}.")
 Quit RetVal
cbpCheckRetVal
 ; Controle op RetVal.  CheckCode is LowerCase en mag nul tot twee karakters bevatten.
 Quit:(RetVal="0;Error")
 If CheckCode="z" Do
 . ; RetVal mag niet lager zijn dan de vastgelegde diepte.
 . ; OffsetZ bepaalt het grondvlak, $$$FCodeZMin is toegelaten diepte t.o.v. dat grondvlak (Negatief = ONDER grondvlak)
 . If RetVal<(OffsetZ+($$$FCodeZMin)) Do
 ..  Do cbpLogError("FATAL","De vastgelegde minimale diepte ("_(OffsetZ+($$$FCodeZMin))_") werd overschreden door Z="_RetVal_".")
 ..  Set RetVal="0;Error"   
 Else  If CheckCode="x" Do
 . ;
 Else  If CheckCode="y" Do
 . ;
 Quit
 
 
 
CNCFilterANC()   ; Parameters: Prog
#define CrLf   $C(13,10)
 Quit:($G(Prog)="") ""
 Do cfaFilterHeader
 Do cfaFilterComment
 Do cfaFilterOpenLines
 Quit Prog
cfaFilterHeader
 ; Clear the header, this is entire block before line "START" (included);
 ; Also removes all spaces
 New StartPos
 Set Prog=$$$CrLf_$TR(Prog," ","")_$$$CrLf
 Set StartPos=$F(Prog, $$$CrLf_"START"_$$$CrLf)
 Set:(StartPos>0) $E(Prog,1,StartPos-1)=""
 Quit
cfaFilterComment
 ; Clear comment in each line, i.e. all text between "'" and $$$CrLf
 New P
 Set P=1
 For  Set P=$F(Prog,"'",P) Quit:(P'>0)  Do
 . Set $E(Prog,P-1,$F(Prog,$$$CrLf,P)-$L($$$CrLf)-1)=""
 Quit
cfaFilterOpenLines
 ; Remove the open lines in the code
 New P,Len2Cl
 Set Len2CL=$L($$$CrLf)*2
 Set P=1
 ; P(osition) blijft in het BEGIN van de vervangen tekst; een normale Replace() positioneert zich vlak ACHTER de vervangen tekst.
 For  Set P=$F(Prog,$$$CrLf_$$$CrLf,P)-Len2CL Quit:(P'>0)  Do
 . Set $E(Prog,P,P-1+Len2CL)=$$$CrLf
 ; Remove first open line
 Set:($E(Prog,1,2)=$$$CrLf) $E(Prog,1,2)=""
 Quit