BLKALC2 G BEGIN ;Importeren en converteren van het COA-SO bericht; [ 11/05/2001  2:14 PM ]
 ;Parameters : 
 ; BLCOA(1)= BerichtVolgNummer
 ;      (2)= Alleen aanpassingen d
BEGIN ; 
C1 ; Vergelijken BLUMBestand
 Set FP=2301 Write @F,@F1,"Koppelen van de KAL-lijst met het Toeleveringenbestand"
 Set RecNaam="MSGB",RecInp=^BLImp(MsgId) Do TF
 Set ^BLTO(LevNr,SoDo)=+$H
 Set ^BLToe=MIIDEF_D_MIDTCR_D_MINETC_D
 Set RecNr=-1,DummyBon="500000"
L3 Do NextRec Goto YZ:RecNr=-1
 G L3:RecType'="11"
BON Set RecNaam="COA-SO-11",ComNr=1,DummyLijn=500,(Status,Test)="" Do TF,VwBON
L4 Do NextRec Goto YZ:RecNr=-1
 Goto BON:RecType="11" Do VwComB:RecType="19" 
 Goto L4:RecType'="22"
LIJN Set RecNaam="COA-SO-22",ComNr=1,(Status,Test)="" Do TF,VwLIJN
L5 Do NextRec Goto YZ:RecNr=-1
 Goto BON:RecType="11" Do VwComL:RecType="29" 
 Goto LIJN:RecType="22",L5
 ; Verwerk bon
VwBON Set ToeRec="",STR=$P(ToeNr,"/") Do StrNum Set ToeNr=+NUM
 Goto VB2:ABNr'?2.10N ;ABNr changed to max 10 pos num
 Set Key=$N(^BLToe("IA",ABNr_D))
 Goto VB2:$P(Key,D,1)'=ABNr ;Bestaat ABNummer?
VB1 ; Volgens ABNummer
 If ToeNr'=$P(Key,D,2) Set ToeNr=$P(Key,D,2) ;ToeleveringsNummer verkeerd
 Goto VB3
VB2 ; Volgens toelevering
 Set ABNr="" 
 Goto VB5:ToeNr'?6N,VB5:'$D(^BLTO(LevNr,SoDo,ToeNr)) ;Onbestaande bon
 Goto VB3
 ; Nakijken reeds ingevuld
VB3 Set ToeRec=$G(^BLTO(LevNr,SoDo,ToeNr,1))
 If $P(ToeRec,D,30)'="VH" Goto VB5
VB4 ; Invullen
 Set $P(NewRec,D,1)=Status,$P(ToeRec,D,30,99)=NewRec,^BLTO(LevNr,SoDo,ToeNr,1)=ToeRec
 Set FP=2401 Write @F,"Nr : ",ToeNr 
 Q
VB5 ; Dummy bon
 Set Status="BL",(ToeNr,DummyBon)=DummyBon+1,ToeRec=""
 Set $P(ToeRec,D,9)=$P(NewRec,D,8) ; ABNummer overbrengen
 Goto VB4
 
 ; Verwerk lijn
VwLIJN Set ToeRec="" If ToeNr>499999 Set Status="BL" Goto VL6 ; Dummy order
 Set STR=ToeLNr,ToeLNr="" If STR?6N1P2N Do StrPNum Set ToeLNr=+$P(NUM,".",2)
 Goto VL3:'ABNr!'ABLNr ; Geen ABreferentie ingevuld gekend
 Set Key=$N(^BLToe("IA",ABNr_D_ToeNr,ABLNr_D))
 Goto VL2:$P(Key,D,1)'=ABLNr ; Bestaat ABLijnNummer?
 Set SortNr=$P(Key,D,3) Goto VL4
VL2 ; Nakijken Backorder
 ; Bij een backorderlijn blijven de 2 eerste cijfers gelijk van het ABLNr (Formaat NNxxx)
 Goto VL3 ; Tijdelijk tot dat backorder automatisch gekreeerd worden
 Set Key=$N(^BLToe("IA",ABNr_D_ToeNr,ABLNr\1000*1000_D))
 Goto VL3:ABLNr\1000'=($P(Key,D,1)\1000) ; Geen gelijke begin cijfers
VL21 Set SortNr=$P(Key,D,3),ToeRec=^BLTO(LevNr,SoDo,ToeNr,SortNr)
 Goto VL5:$P(ToeRec,D,30)="VH" ; Nog niet gebruikt
 Set Key=$N(^BLToe("IA",ABNr_ToeNr,Key)) Goto VL21:ABLNr\1000=($P(Key,D,1)\1000)
 Set Status="BO" Goto VL7 ; Indien lijnen in gebruik dan extra lijn
VL3 ; Volgens toelevering
 Set Temp=ABLNr,ABLNr=""
 Goto VL8:'ToeLNr ; Geen lijnnummer gekend -> Best match
 Set Key=$N(^BLToe("IL",ToeNr,ToeLNr_D))
 Goto VL8:ToeLNr'=$P(Key,D,1) ;Foutief LijnNr -> Best Match
VL31 Set SortNr=$P(Key,D,3),ToeRec=^BLTO(LevNr,SoDo,ToeNr,SortNr)
 Goto VL5:$P(ToeRec,D,30)="VH" ; Nog niet gebruikt
 Set Key=$N(^BLToe("IL",ToeNr,Key)) Goto VL31:ToeLNr=$P(Key,D,1) 
 Set Status="BO" Goto VL8 ; Indien lijnen in gebruik dan extra lijn
VL4 ; Nakijken lijn reeds gemanipuleerd
 Set ToeRec=^BLTO(LevNr,SoDo,ToeNr,SortNr)
 If $P(ToeRec,D,30)'="VH" Set:Status'="BO" Status="BL" Goto VL6
VL5 ; Invullen
 Set:COPRDI=1 COPRIC=COPRIC*10
 Set $P(NewRec,D,9)=COPRIC,COPRDI=$S(COPRDI=3:"M",COPRDI=2:"H",COPRDI=1:"H",1:"E"),$P(NewRec,D,10)=COPRDI
VL51 Set $P(NewRec,D,1)=Status,$P(ToeRec,D,30,99)=NewRec
VL53 Set ^BLTO(LevNr,SoDo,ToeNr,SortNr)=ToeRec
 ;W !,?5,SortNr,"  ",NewRec
 Q
VL6 ; Dummy lijn
 Set ToeRec=""
VL7 ; BackOrder
 Set (SortNr,DummyLijn)=DummyLijn+1  Goto VL5
VL8 ; Best unused Match in Toelevering
 Kill Once
 Set (Max,MaxCount)=0 Set:Status'="BO" Status="BL"
 Set PR=$$GETVH^BLPROD(COIDNO,KlantNr)
 Goto VL6:'PR
 Goto VL84:'$D(^BLToe("IP",ToeNr,PR))
 Set SortNr=$N(^(PR,-1))
VL81 Goto VL83:SortNr=-1 
 Set ToeRec=^BLTO(LevNr,SoDo,ToeNr,SortNr),Count=8
 Goto VL82:$P(ToeRec,D,30)'="VH" ; Reeds ingevulde lijn
 Set:$P(ToeRec,D,3)=COORQT Count=Count+4
 Set:$P(ToeRec,D,25)=CODELD Count=Count+2
 Set:Count'<8&(Max<Count) Max=Count,T=SortNr,MaxCount=0
 Set:Count'<8&(Max=Count) MaxCount=MaxCount+1
VL82 Set SortNr=$N(^BLToe("IP",ToeNr,PR,SortNr)) Goto VL81
VL83 If Max'<8&(MaxCount=1)!(Max>10) Set Status="" Set SortNr=T,ToeRec=^BLTO(LevNr,SoDo,ToeNr,SortNr) Goto VL5 ; Slecht 1 lijn welke voldoet aan de match.
VL84 
 Goto VL6
 
VwComB Q  ;Set RecNaam="X9",ComNr=ComNr+1 Do TF Set ^BLToe("D",ToeNr,"O"_ComNr)=NewRec Q
VwComL Q  ;Set RecNaam="X9",ComNr=ComNr+1 Do TF Set ^BLToe("D",ToeNr,ToeLNr_D_ABLNr,"O"_ComNr)=NewRec Q
MENU Q
NextRec Set RecNr=$N(^BLImp(MsgId,RecNr)) Q:RecNr=-1  Set RecInp=^(RecNr),RecType=$E(RecInp,2,3) Q
StrPNum Set NUM="",SN1=1
SPN1 Set:+$E(STR,SN1)!($E(STR,SN1)=0)!($E(STR,SN1)=".") NUM=NUM_$E(STR,SN1) Set SN1=SN1+1 Goto SPN1:SN1'>$L(STR)
 Q
StrNum Set NUM="",SN1=1
SN1 Set:+$E(STR,SN1)!($E(STR,SN1)=0) NUM=NUM_$E(STR,SN1) Set SN1=SN1+1 Goto SN1:SN1'>$L(STR)
 Q
 
TF SET Tptr=0,Tptr=$N(^BLRecDef(LevNr,RecNaam,Tptr)),NewRec=""
TLoop Q:Tptr=-1
 Set TRec=^(Tptr),Piece=$P(TRec,D,4),Local=$P(TRec,D,5),Type=$P(TRec,D,6)
 If 'Piece&(Local="") Set Tptr=$N(^(Tptr)) Goto TLoop
 Set TF1=$E(RecInp,$P(TRec,D,1),$P(TRec,D,2))
LTRIM If $E(TF1,1)=" " Set TF1=$E(TF1,2,999) Goto LTRIM
RTRIM If $E(TF1,$L(TF1))=" " Set TF1=$E(TF1,1,$L(TF1)-1) Goto RTRIM
 Set:Type="N" TF1=+TF1
 Set:Type="D" TF1=$E(TF1,5,6)_"."_$E(TF1,3,4)_"."_$E(TF1,1,2)
 if Type="W" Set TF1=$E(TF1,5,6)_"."_$E(TF1,3,4)_"."_$E(TF1,1,2) S TF1=$$EXTDATE^vhLib.DataTypes($$INTDATE^vhLib.DataTypes(TF1,"DK"),"DW")
 Set:Piece $P(NewRec,D,Piece)=TF1
 Set:Local'="" @Local=TF1
 Set Tptr=$N(^(Tptr)) Goto TLoop
YZ Q