cI39L ;Conversie ISO-landcodes ;%I39L ; [ 03/27/00  1:48 PM ]
 ;
T1 ;Dit programma converteert de landcode in volgende bestanden:;
T2 ;a) $P(^_Q_BA(39),D,3);
T3 ;b) adressen (KL, LE, VT, NA, NP, CP, ...) + openingspatronen;
T4 ;c) factuur- en leveringsadressen;
T5 ;d) postnummers (PN);
T8 ;Q-waarde(s) <;
T9 ;Start <N>;
 ;
 ; init + uitleg
1 S Q=$G(Q) D ^cA604,MASTER^cQ5:'$D(boot) S QU=$G(QU,"DAM")
11 w !!,$P($T(+1),U,2),!!
13 f i=1:1 s j=$p($t(@("T"_i)),U,2) q:j=""  w j,!
 ;
 ; vraagstelling
2 s qq=$g(^cLOG("Q"),Q) i $d(boot) s qq=$g(^cLOG(boot,"Q"),qq)
21 i $p(qq,D)="SYS" s qq=$p(qq,D,2,999)
23 i qq[D s qq=$tr(qq,D," ")
25 w !,$p($t(T8),U,2),qq,">" r k g YZ:k="-"!(k="^") i $l(k) s qq=k g 25
27 w !,$p($t(T9),U,2) r k g 25:"-^"[k&$l(k) s k=$tr(k,"JjYy1","11110") g 27:k'=1
 ;
3 ; aflopen Q-waardes
31 s Q=$p(qq," "),qq=$p(qq," ",2,999) i Q'?1.3U g 31:$l(qq),Y
33 w !,Q,?5,$g(@("^"_Q_"BA(99,1)"),"?"),?40
35 s ba39=$g(@("^"_Q_"BA(39)")) i $p(ba39,D,3)="" s $p(ba39,D,3)="B"
37 w " BA" s l=$p(ba39,D,3) d S1 i $l(j) s $p(@("^"_Q_"BA(39)"),D,3)=$p(^(0),D)
 ;
 ; adressen
4 f g="KL","LE","VT","NA","NP","CP","MA","MB","VOS.ADR","KL.LVA" d
 . i '$d(^DMS(Q,g)) q
 . w " ",g s UQC=$p(^(g),D),USC=$p(^(g),D,2)
 . s UQA=$p($g(^(g,0)),D,3),USA=$p($g(^(0)),D,4) i USA="" s USA=g
 . i UQA="" f  s UQA=$o(^DMA(UQA)) q:UQA=""  i $d(^(UQA,USA)) q
 . i '$d(^DMC(UQC,USC)) w $C(7),"?" q
 . s UREF=^(USC,"DATA","REF")
 . s UI1=0 f  s UI1=$o(@UREF) q:UI1=""  i $d(^(UI1,0)) d     ; data
 .. s b=^(0),l=$p(b,D,8) w $e(UI1) l @UREF
 .. i l="" s l=$p(ba39,D,3)
 .. i $l(l) d S1 i $l(j) d
 ... i $l(UQA),$l(USA) d W^cAN220(USA,UQA,UI1,108,j) q
 ... s $p(@UREF@(0),D,8)=j
 .. i g="LE" s b=@UREF@(1),l=$p(b,D,15) i $l(l) D S1 i $l(j) d
 ... i $l(UQA),$l(USA) d W^cAN220(USA,UQA,UI1,215,j) q
 ... s $p(@UREF@(1),D,15)=j
 .. w $C(8)," ",$C(8) l
 . s p=0 f  s p=$o(@("^"_Q_"BA")@("%A",1,g,p)) q:p=""  i $d(^(p,0)) d
 .. s b=^(0),l=$p(b,D,8) i l="?" q
 .. i l="" s l=$p(ba39,D,3)
 .. i $l(l) d S1 i $l(j) s $p(@("^"_Q_"BA")@("%A",1,g,p,0),D,8)=j
 .. i g="LE" s b=@("^"_Q_"BA")@("%A",1,g,p,1),l=$p(b,D,15) i $l(l),l'="?" D S1 i $l(j) s $p(@("^"_Q_"BA")@("%A",1,g,p,1),D,15)=j
 ;
 ; factuur- en leveringsadressen
5 f ugl="OD","UL","TO","TOL" w " ",ugl d
 . s kc=0 f  s kc=$o(@("^"_Q_ugl)@(kc)) q:kc=""  d
 .. s us=0 f  s us=$o(@("^"_Q_ugl)@(kc,us)) q:us=""  d
 ... i ugl="TOL",us="P" q
 ... s ur=0 f  s ur=$o(@("^"_Q_ugl)@(kc,us,ur)) q:ur=""  d
 .... l @("^"_Q_ugl)@(kc,us,ur)
 .... i $d(^(ur,2)) s l=$p(^(2),D,8) i $l(l) d S1 i $l(j) s $p(@("^"_Q_ugl)@(kc,us,ur,2),D,8)=j
 .... i $d(^(3)) s l=$p(^(3),D,8) i $l(l) d S1 i $l(j) s $p(@("^"_Q_ugl)@(kc,us,ur,3),D,8)=j
 ;
 ; einde Q-waarde
6 g 31
 ;
 ; postnummers
Y s g="PN" w !,g
 s UQC=0,USC=g,UQA=0,USA=g
 i '$d(^DMC(UQC,USC)) w $C(7),"?" g YZ
 s UREF=^(USC,"DATA","REF")
 s UI1=0 f  s UI1=$o(@UREF) q:UI1=""  i $d(^(UI1,0)) d
 . s b=^(0),l=$p(b,D,8) w "." l @UREF
 . i $l(l) d S1 i $l(j) s $p(@UREF@(0),D,8)=j
 . w $C(8)," ",$C(8) l
 ;
YZ w ! Q
 ;
S1 s j="",sw=0
 i 'sw,l="A" s l="AT",sw=1
 i 'sw,l="AUS" s l="AU",sw=1
 i 'sw,l="AB" s l="AL",sw=1
 i 'sw,l="AK" s l="AG",sw=1
 i 'sw,l="AN" s l="AO",sw=1
 i 'sw,l="AND" s l="AD",sw=1
 i 'sw,l="AS" s l="SA",sw=1
 i 'sw,l="B" s l="BE",sw=1
 i 'sw,l="BA" s l="BM",sw=1
 i 'sw,l="BC" s l="BJ",sw=1
 i 'sw,l="BDI" s l="BI",sw=1
 i 'sw,l="BDS" s l="BB",sw=1
 i 'sw,l="BH" s l="HN",sw=1
 i 'sw,l="BI" s l="GW",sw=1
 i 'sw,l="BM" s l="MM",sw=1
 i 'sw,l="BRN" s l="BH",sw=1
 i 'sw,l="BRU" s l="BN",sw=1
 i 'sw,l="BUR" s l="MM",sw=1
 i 'sw,l="BV"!(l="BX") s l="BO",sw=1
 i 'sw,l="BP" s l="BW",sw=1
 i 'sw,l="CDN" s l="CA",sw=1
 i 'sw,l="CL" s l="LK",sw=1
 i 'sw,l="CP" s l="KY",sw=1
 i 'sw,l="D" s l="DE",sw=1
 i 'sw,l="DH" s l="QA",sw=1
 i 'sw,l="DOM" s l="DO",sw=1
 i 'sw,l="E" s l="ES",sw=1
 i 'sw,l="EAK" s l="KE",sw=1
 i 'sw,l="EAU" s l="UG",sw=1
 i 'sw,l="EG" s l="GQ",sw=1
 i 'sw,l="EI" s l="IE",sw=1
 i 'sw,l="EM" s l="AE",sw=1
 i 'sw,l="ET" s l="EG",sw=1
 i 'sw,l="F" s l="FR",sw=1
 i 'sw,l="FG" s l="GF",sw=1
 i 'sw,l="FIN" s l="FI",sw=1
 i 'sw,l="FJI" s l="FJ",sw=1
 i 'sw,l="FL" s l="LI",sw=1
 i 'sw,l="FP" s l="PF",sw=1
 i 'sw,l="FR" s l="FP",sw=1
 i 'sw,l="GA" s l="GD",sw=1
 i 'sw,l="GBG" s l="GG",sw=1
 i 'sw,l="GBJ" s l="JE",sw=1
 i 'sw,l="GBM" s l="IM",sw=1
 i 'sw,l="GBZ" s l="GI",sw=1
 i 'sw,l="GC" s l="ES",sw=1
 i 'sw,l="GCA" s l="GT",sw=1
 i 'sw,l="GL" s l="GP",sw=1
 i 'sw,l="GD" s l="GL",sw=1
 i 'sw,l="GE" s l="GN",sw=1
 i 'sw,l="GM" s l="GU",sw=1
 i 'sw,l="GO" s l="GA",sw=1
 i 'sw,l="GUY" s l="GY",sw=1
 i 'sw,l="H" s l="HU",sw=1
 i 'sw,l="HKJ" s l="JO",sw=1
 i 'sw,l="HL" s l="SH",sw=1
 i 'sw,l="HM"!(l="HR")!(l="HW") s l="US",sw=1
 i 'sw,l="HO" s l="HN",sw=1
 i 'sw,l="I" s l="IT",sw=1
 i 'sw,l="IK" s l="IQ",sw=1
 i 'sw,l="IND" s l="IN",sw=1
 i 'sw,l="J" s l="JP",sw=1
 i 'sw,l="JA" s l="JM",sw=1
 i 'sw,l="K" s l="KH",sw=1
 i 'sw,l="KC" s l="KN",sw=1
 i 'sw,l="KD" s l="TD",sw=1
 i 'sw,l="KN" s l="CM",sw=1
 i 'sw,l="KO" s l="KM",sw=1
 i 'sw,l="KWT" s l="KW",sw=1
 i 'sw,l="L" s l="LU",sw=1
 i 'sw,l="LA" s l="AI",sw=1
 i 'sw,l="LI" s l="LR",sw=1
 i 'sw,l="LO" s l="LS",sw=1
 i 'sw,l="LS" s l="LA",sw=1
 i 'sw,l="M" s l="MT",sw=1
 i 'sw,l="MAL" s l="MY",sw=1
 i 'sw,l="MB" s l="OM",sw=1
 i 'sw,l="MEX" s l="MX",sw=1
 i 'sw,l="MF" s l="MV",sw=1
 i 'sw,l="MH" s l="MN",sw=1
 i 'sw,l="MK" s l="MS",sw=1
 i 'sw,l="MN" s l="MP",sw=1
 i 'sw,l="MO" s l="MZ",sw=1
 i 'sw,l="MQ" s l="MR",sw=1
 i 'sw,l="MR" s l="MQ",sw=1
 i 'sw,l="MS" s l="MU",sw=1
 i 'sw,l="N" s l="NO",sw=1
 i 'sw,l="NA" s l="AN",sw=1
 i 'sw,l="NH" s l="VU",sw=1
 i 'sw,l="NIC" s l="NI",sw=1
 i 'sw,l="NM" s l="NC",sw=1
 i 'sw,l="NV" s l="NF",sw=1
 i 'sw,l="OE" s l="UG",sw=1
 i 'sw,l="OM" s l="MO",sw=1
 i 'sw,l="P" s l="PT",sw=1
 i 'sw,l="PAC" s l="PZ",sw=1
 i 'sw,l="PD" s l="PR",sw=1
 i 'sw,l="PNG" s l="PG",sw=1
 i 'sw,l="QN" s l="PM",sw=1
 i 'sw,l="RA" s l="AR",sw=1
 i 'sw,l="RB" s l="BW",sw=1
 i 'sw,l="RC" s l="CN",sw=1
 i 'sw,l="RCA" s l="CF",sw=1
 i 'sw,l="RCB" s l="CG",sw=1
 i 'sw,l="RCH" s l="CL",sw=1
 i 'sw,l="RG" s l="CK",sw=1
 i 'sw,l="RH" s l="HT",sw=1
 i 'sw,l="RI" s l="ID",sw=1
 i 'sw,l="RL" s l="LB",sw=1
 i 'sw,l="RM" s l="MG",sw=1
 i 'sw,l="RMM" s l="ML",sw=1
 i 'sw,l="RN" s l="NE",sw=1
 i 'sw,l="ROK" s l="KR",sw=1
 i 'sw,l="ROU" s l="UY",sw=1
 i 'sw,l="RP" s l="PH",sw=1
 i 'sw,l="RSM" s l="SM",sw=1
 i 'sw,l="RWA" s l="RW",sw=1
 i 'sw,l="S" s l="SE",sw=1
 i 'sw,l="SD" s l="SZ",sw=1
 i 'sw,l="SGP" s l="SG",sw=1
 i 'sw,l="SJ" s l="SA",sw=1
 i 'sw,l="SLO" s l="SI",sw=1
 i 'sw,l="SM" s l="SO",sw=1
 i 'sw,l="SME" s l="SR",sw=1
 i 'sw,l="SQ" s l="SK",sw=1
 i 'sw,l="SR" s l="SV",sw=1
 i 'sw,l="SU" s l="RU",sw=1
 i 'sw,l="SYR" s l="SY",sw=1
 i 'sw,l="SZ" s l="SC",sw=1
 i 'sw,l="T" s l="TH",sw=1
 i 'sw,l="TI" s l="TP",sw=1
 i 'sw,l="TK" s l="PN",sw=1
 i 'sw,l="TQ" s l="TC",sw=1
 i 'sw,l="TS" s l="TO",sw=1
 i 'sw,l="USA" s l="US",sw=1
 i 'sw,l="UU" s l="BI",sw=1
 i 'sw,l="VB" s l="VG",sw=1
 i 'sw,l="VT" s l="VN",sw=1
 i 'sw,l="WAG" s l="GM",sw=1
 i 'sw,l="WAL" s l="SL",sw=1
 i 'sw,l="WAN" s l="NG",sw=1
 i 'sw,l="WI" s l="IN",sw=1
 i 'sw,l="WK" s l="NA",sw=1
 i 'sw,l="WL" s l="LC",sw=1
 i 'sw,l="WV" s l="VC",sw=1
 i 'sw,l="YEZ" s l="YE",sw=1
 i 'sw,l="YV" s l="VE",sw=1
 i 'sw,l="ZRE" s l="CD",sw=1
 i 'sw,l="ZV" s l="NR",sw=1
S1A s j=$o(^ISO(0,"ISO.LAND",j)) i j="" g S1Z
S1B i $p(^(j,0),D)'=l G S1A
S1Z q
 ;
ZZ ; 10.04.00 - 11 u 03 * V7.3