KOFKL10 G 1 ;MODULE VIA PRODUKTSELEKTIES;KOFKL9;Quit naar KOFKL9 [ 08/05/2002  11:22 AM ]
 ;
T1 ;VANAF 
T2 ;TOT 
T3 ;IN ALFABETISCHE ORDE VANAF 
T4 ;IN ALFABETISCHE ORDE TOT 
T5 ;\".[] = vanaf het begin   [] = specifieke 
T6 ;VANAF HET BEGIN
T7 ;\"I[] = idem vorige   .[] = tot het einde   [] = specifieke 
T9 ;TOT HET EINDE
T10 ;\PRODUKTKODE\\produktkode
 ;
1 S H=@("^"_Q_"PR(0,""HG"")"),G=^("GR"),S=^("SG"),P=$P($T(T10),U,2)
3 S L=0 F I="H","G","S","P" S:$L($P(@I,D,2))>L L=$L($P(@I,D,2))
5 S LN=UD+3,I="H" D S1 S LN=UD+4 D S2
7 S NIV="" D S3 G YZ:K="-" I K="." S HG=0,R=$P($T(T6),U,2) G 11
9 D S5,S7 G 7:K="-" S HG=R
11 S LN=UD+3 D S6
13 S NIV="" D S4 I K="-" S R="" D S6 K HG G 7:LN=UD+3 S LN=UD+3 D S6 G 7
15 I K="." S HGX="ZZZZZ",R=$P($T(T9),U,2) G 21
17 I K="I" G 13:HG=0 S (HGX,R)=HG G 21
19 D S5,S7 G 13:K="-",19:HG]R S HGX=R
21 S LN=UD+4 D S6 G 83:HG'=HGX
23 S LN=UD+5,I="G" D S1 S LN=UD+6 D S2
25 S NIV="HG" D S3 I K="-" S LN=UD+4,I="H" D S2 K HGX G 13
27 I K="." S GR=0,R=$P($T(T6),U,2) G 31
29 D S5,S7 G 25:K="-" S GR=R
31 S LN=UD+5 D S6
33 S NIV="HG" D S4 I K="-" S R="" D S6 K GR G 25:LN=UD+5 S LN=UD+5 D S6 G 25
35 I K="." S GRX="ZZZZZ",R=$P($T(T9),U,2) G 41
37 I K="I" G 33:GR=0 S (GRX,R)=GR G 41
39 D S5,S7 G 33:K="-",39:GR]R S GRX=R
41 S LN=UD+6 D S6 G 83:GR'=GRX
43 S LN=UD+7,I="S" D S1 S LN=UD+8 D S2
45 S NIV="HG,GR" D S3 I K="-" S LN=UD+6,I="G" D S2 K GRX G 33
47 I K="." S SG=0,R=$P($T(T6),U,2) G 51
49 D S5,S7 G 45:K="-" S SG=R
51 S LN=UD+7 D S6
53 S NIV="HG,GR" D S4 I K="-" S R="" D S6 K SG G 45:LN=UD+7 S LN=UD+7 D S6 G 45
55 I K="." S SGX="ZZZZZ",R=$P($T(T9),U,2) G 61
57 I K="I" G 53:SG=0 S (SGX,R)=SG G 61
59 D S5,S7 G 53:K="-",59:SG]R S SGX=R
61 S LN=UD+8 D S6 G 83:SG'=SGX
63 S LN=UD+9,I="P" D S1 S LN=UD+10 D S2
65 S MK="  ",NIV="HG,GR,SG,MK" D S3 I K="-" S LN=UD+8,I="S" D S2 K SGX,MK,MKX G 53
67 I K="." S PRC=0,R=$P($T(T6),U,2) G 71
69 D S5,S7 G 65:K="-" S PRC=R D S8
71 S LN=UD+9 D S6
73 S NIV="HG,GR,SG,MK" D S4 I K="-" S R="" D S6 K PRC G 65:LN=UD+9 S LN=UD+9 D S6 G 65
75 I K="." S PRCX="ZZZZZ",R=$P($T(T9),U,2) G 81
77 I K="I" G 73:PRC=0 S (PRCX,R)=PRC D S8 G 81
79 D S5,S7 G 73:K="-",79:PRC]R S PRCX=R D S8
81 S LN=UD+10 D S6
83 F I="GR","SG","PRC" I '$D(@I) S @I=0,@(I_"X")="ZZZZZ"
85 S HGB=HG,HGE=HGX,GRB=GR,GRE=GRX,SGB=SG,SGE=SGX,PRB=PRC,PRE=PRCX
87 I $D(@("^"_Q_"PR1(PRB)")) S PRB=$P(^(PRB),D,1)
89 I $D(^(PRE)) S PRE=$P(^(PRE),D,1)
 ;
YZ K G,H,I,L,LN,NIV,P,PR,S,HG,HGX,GR,GRX,SG,SGX,PRC,PRCX,MK Q
 ;
S0 S FP=2001+F60 W @F,@F1
S0Z Q
 ;
S1 S FP=LN*100+1 W @F,@F2,$C(13),?2,$P($T(T3),U,2),$P(@I,D,2),?30+L,":"
S1Z Q
 ;
S2 S FP=LN*100+1 W @F,@F1,$C(13),?2,$P($T(T4),U,2),$P(@I,D,2),?30+L,":"
S2Z Q
 ;
S3 D S0 S R="K\23\3\"_$P($T(T1),U,2)_$P(@I,D,2)_$P($T(T5),U,2)_$P(@I,D,4)_"""\1\\""-.""[K" D R0^KRR0
S3Z Q
 ;
S4 D S0 S R="K\23\3\"_$P($T(T2),U,2)_$P(@I,D,2)_$P($T(T7),U,2)_$P(@I,D,4)_"""\1\\""-.I""[K" D R0^KRR0
S4Z Q
 ;
S5 S R="2000\"_$P(@I,D,2)_D_NIV
S5Z Q
 ;
S6 S FP=LN*100+33+L W @F,@F2,R
S6Z Q
 ;
S8 S R=+@("^"_Q_"PR1(R)"),R=$P(@("^"_Q_"PR(R,0)"),D,1)
S8Z Q
 ;
SC S K=$$UPTRIMAN^vhRtn1(K)
 Q
 ;
S7 S S4=$P(R,D,1)+1+F60,S0=0,SA=$P(R,D,2),S11=$P(R,D,3),S8="^"_Q_"PH("_S11 S:$L(S11) S8=S8_"," S S8=S8_"S2)",S10="^"_Q_"PR(PR,0)",FP=S4 W @F,@F1
S7A S FP=2403+F60 W @F,@F1 W:$D(ST) $P($T(T11),U,2) W SA W:S0 $P($T(T12),U,2) W " : ",@F0
S7B R K G S7A:K?.E1C.E,S7Z:K="-" D:S11="HG,GR,SG,MK" SC S:$L(K) S0=0 S FP=S4,S9=0 W @F,@F1 G S7D:K=""&('S0) I K="" K ST S S1=S4 G S7H
S7C G S7D:'$D(ST(K)) S S3=ST(K) G S7M
S7D K ST S S6=K S:K=" " S6=""
S7E S S5=$E(S6,1,28),S1=S4 S:S6="" (S2,S3,S5)=0 S:S6'="" (S2,S3,S5)=S5_" " G S7M:$D(@(S8)) S (S2,S3)=$N(@(S8)) G S7K:S2=-1 S S2=$N(^(S2))
S7F I $E(S2,1,$L(S6))'=S6&'S0&($E(S3,1,$L(S6))=S6) G S7M
S7G S S2=S5
S7H S S2=$N(@(S8)) G S7K:($E(S2,1,$L(S6))]S6)&'S0&(S1=S4) G S7L:S2=-1 I $E(S2,1,$L(S6))'=S6 S S0=0 G S7A
S7I S FP=S1,S9=S9+1,ST(S9)=S2 W @F,$C(13),?2,S9,". ",?6 I NIV'="HG,GR,SG,MK" W:S2="  " $P($T(T13),U,2) W:S2'="  " S2 G S7J
S7II S PR=+^(S2) W $P(@S10,D,1),?34,$P(^(0),D,2)
S7J S S1=S1+100 G S7H:S1<(2300+F60) S S0=1 G S7A
S7K X ^cTXT(0,"N",156) R K
S7L S (S2,S0)=0 G S7A
S7M S R=S3
S7Z K S0,S1,S2,S3,S4,S5,S6,S7,S8,S9,S10,S11,SA,ST Q
 ;
Z X ^cZ
ZZ ; 01.06.88 - 14 u 02