cABVBP2	; functies voor opzetten ^DDP ; cABVBP2  ; Compiled December 8, 2011 12:06:16
	;
T1	;Doorgegeven sleutel is leeg;
T2	;U heeft geen licentie voor dit bestand : ;
T3	;Definitie DMA niet in orde voor : ;
T4	;Fout bij het verwijderen van DDP;
T5	;Fout bij het aanmaken van DDP;
T6	;Geen data voor doorgegeven sleutel : ;
T7	;Fout bij het aanmaken van ;
	;
T1F	;Doorgegeven sleutel is leeg;
T2F	;Vous n'avez pas de license pour ce fichier : ;
T3F	;Definitie DMA niet in orde;
T4F	;Fout bij het verwijderen van DDP;
T5F	;Fout bij het aanmaken van DDP;
T6F	;Geen data voor doorgegeven sleutel : ;
	;
T1E	;Doorgegeven sleutel is leeg;
T2E	;You have no license for this file : ;
T3E	;Definitie DMA niet in orde;
T4E	;Fout bij het verwijderen van DDP;
T5E	;Fout bij het aanmaken van DDP;
T6E	;Geen data voor doorgegeven sleutel : ;
	;
YZ	Q
	;
BUILD(UI1C,AFW)	; opbouwen aan de hand van UI1 van DDC
	; UI1C = UI1 van DDC (Niet deze van de afwijking)
	; AFW    = code afwijking (bv FOR, TBK)  : komt te vervallen
	S $ZT="TRAP^cAN000"
	N OK,DMSC,DMSP,UQC,USC,SW3,UI1,R,B,i,UI1P,TAB,K,SK
	I '$L($G(UI1C)) S OK="0\"_$P($T(@("T1"_QT)),U,2) G BUILDZ
	S DMSC="DC",DMSP="DP",AFW=$G(AFW)
BUILDA	D DMS^cAN000("UQC","USC",DMSC) I '$L(UQC)!'$L(USC) S OK="0\"_$P($T(@("T2"_QT)),U,2)_DMSC G BUILDZ
	S SW3=$$SW3(DMSC) I 'SW3 S OK="0\"_$P($T(@("T3"_QT)),U,2)_DMSC G BUILDZ
	S UI1=UI1C
	; ku 25.10
	; I $L($G(AFW)) D  ; UI1 van de afwijking ophalen
	; . S R=$$UI1OP^cAFA1(DMSC,"M2","1\1",UI1C,AFW)
	; . I $L(R) S UI1=R
	S R=$$UI1OP^cAFA1(DMSC,133,"1\1",UI1C)  ; is er een copy van het origineel ?
	I $L(R) S UI1=R
	S B(1)=$$SIGN^cAFA1(DMSC,UI1,0) I '$L(B(1)) S OK="0\"_$P($T(@("T6"_QT)),U,2)_DMSC_" : "_UI1 G BUILDZ
	F i=2:1:SW3 S B(i)=$G(^(i-1))
	; 
	; ophalen Searchkeys + wegschrijven
	D SEARCHK^cAFVBI01(.SK,$P(B(2),D,6),$P(B(2),D,7))
	; GM 27.04.07 Indien er iets (spatie,ongeldig,...) was ingegeven in de klassedefinitie als zoeksleutel,
	;             maar SEARCHK komt met blanco terug dan wordt de zoeksleutel op " " gezet
	F i=1,2 S $P(B(2),D,5+i)=$S($L($P(B(2),D,5+1))&'$L(SK(i)):" ",1:$TR(SK(i),D,"#"))
	;
BUILDB	S UI1P=UI1C ; UI1 voor DDP : steeds van originele klasse
	K TAB
	M TAB=B
	S $P(TAB(1),D,28,29)=D
	S $P(TAB(1),D,33)=UI1   ; invullen gebruikt item
	I $L($$SIGN^cAFA1(DMSP,UI1P,0)) D X^cAN220(DMSP,"",UI1P) I K="-" S OK="0\"_$P($T(@("T4"_QT)),U,2) G BUILDZ    ; verwijderen DDP
	D P^cAN220(DMSP,"",UI1P,"TAB","") I K="-" S OK="0\"_$P($T(@("T5"_QT)),U,2) G BUILDZ    ; openen DDP
	; opzetten definitie per taal + indien afwijking zit def. per taal ook bij de afwijking
	S OK=$$BTAAL(DMSC_".TAAL",UI1,DMSP_".TAAL",UI1P) I 'OK G BUILDZ
	; opzetten properties : vertrekken van originele UI1C
	S OK=$$BCHLD(1,DMSC_".PROP",UI1C,DMSP_".PROP",AFW,.SK) I 'OK G BUILDZ
	; opzetten indexen
	S OK=$$BCHLD(2,DMSC_".IND",UI1C,DMSP_".IND",AFW) I 'OK G BUILDZ
	; opzetten methodes
	S OK=$$BCHLD(3,DMSC_".METH",UI1C,DMSP_".METH",AFW) I 'OK G BUILDZ
	; opzetten applicaties
	S OK=$$BCHLD(4,DMSC_".APPL",UI1C,DMSP_".APPL",AFW) I 'OK G BUILDZ
	; opzetten queries
	;S OK=$$BCHLD(99,DMSC_".QUER",UI1C,DMSP_".QUER",AFW) I 'OK G BUILDZ
	S OK=1
BUILDZ	Q OK
	;
BTAAL(DMSCT,UI1C,DMSPT,UI1P,SKTEL,SWKEY,SWREF)	; opzetten def. per taal
	; DMSC  = DC of DC.PROP
	; UI1C = UI1 van DDC (kan ook van de afwijking zijn)
	; DMSP  = DP of DP.PROP
	; UI1P = UI1 van DDP
	; SKTEL = Teller van Searchkey (zoeksleutel)
	; SWKEY = 1 : key-item
	; SWREF = 1 : referentie nr andere klasse
	;
	; Opgelet : DP.TAAL dient reeds verwijderd te zijn
	;           (wordt normaal verwijderd bij verwijderen van klasse/property in DDP)
	; 
	S $ZT="TRAP^cAN000"
	N UQC,USC,SW3,UREF,TKI1,TKB,TK,UI1,TAB,K,OK,i
	D DMS^cAN000("UQC","USC",DMSCT,1) I '$L(UQC)!'$L(USC) S OK="0\"_$P($T(@("T2"_QT)),U,2)_DMSCT G BTAALZ
	S UREF=^DMC(UQC,USC,"DATA","REF")
	S SW3=$$SW3(DMSCT) I 'SW3 S OK="0\"_$P($T(@("T3"_QT)),U,2)_DMSCT G BTAALZ
	S TKI1=""
BTAALA	S TKI1=$O(^DTEXT(0,"TEXT.9000",TKI1)) G BTAALY:TKI1=""  ; aflopen taalcodes
	S TKB=^(TKI1,0)
	I $P(TKB,D,30) G BTAALA  ; BG of verwijderd
	S TK=TKI1 ;$P(TKB,D)
	S UI1=UI1C_" "_TK
	S TAB(1)=$G(@UREF@(0)) F i=2:1:SW3 S TAB(i)=$G(^(i-1))
	S $P(TAB(1),D,1,2)=UI1P_D_TK
	S $P(TAB(1),D,28,29)=D
	S $P(TAB(1),D,33)=UI1
	I $G(SWKEY)!$G(SWREF) D  ; indien key : Id bij externe naam toevoegen
	. S K=$P(TAB(2),D) I '$L(K) Q
	. I $$UC^cAFA1($E(K,$L(K)-1,$L(K)))'="ID" S $P(TAB(2),D)=$P(TAB(2),D)_"Id"
BTAALB	I '$G(SKTEL) G BTAALC           ; geen zoeksleutel doorgegeven
	I $G(SKTEL) F i=1,2,3,31,32 S $P(TAB(2),D,i)=""   ; uitblanken externe property en DMA
	I $G(SKTEL)=1 G BTAALC
	; zoeksleutel 2
	I '$P($G(SKTEL),D,2) G BTAALC   ; niet meertalig
	; indien searchkey 2 : samenstellen taal (meestal Omschrijving)
	F i=11,21,12,13,22 S $P(TAB(2),D,i)=$S($L($P(TAB(2),D,i+5)):$P(TAB(2),D,i+5),1:$$OMSCH($P(TAB(2),D,i)))
BTAALC	I '$G(SWKEY),DMSPT[".PROP." S $P(TAB(2),D,12)=$$TOOLTIP($P(TAB(2),D,11),$P(TAB(2),D,12),TK)
	D P^cAN220(DMSPT,"",UI1P_" "_TK,"TAB","") I K="-" S OK="0\"_$P($T(@("T7"_QT)),U,2)_DMSPT_" : "_UI1P_" "_TK G BTAALZ
	G BTAALA
BTAALY	S OK=1
BTAALZ	Q OK
	;
TOOLTIP(TIT,TOOL,TK)	; opzetten tooltip
	S $ZT="TRAP^cAN000"
	N R,I,R1
	S D="\"
	S R=$S($L($G(TOOL)):TOOL,1:TIT)
	I $L($G(TOOL)) G TOOLTIPZ
	I '$L(R) G TOOLTIPZ
	I $G(TK)'="E" G TOOLTIPZ
	I R?1"Description "1.A,"\Dutch\French\German\English\"[(D_$P(R," ",2)_D) G TOOLTIPZ
	S I=""
	F i=1:1:$L(R) I $E(R,i)?1U D
	. S R1=$E(R,i-1)  ; vorig karakter ophalen
	. I R1'?1" " Q    ; geen spatie
	. S R2=$E(R,i+1)  ; volgend karakter ophalen
	. I $E(R2)'?1L Q  ; geen kleine letter
	. S $E(R,i)=$$LC^cAFA1($E(R,i))
TOOLTIPZ	Q R
	;
OMSCH(R)	; taal uit de omschrijving halen
	I R'?.E1P.E G OMSCHZ
	I $E(R,$L(R))?1P G OMSCHZ:$E(R,1,$L(R)-1)'?.E1P.E S R=$E(R,1,$L(R)-1)
	F  Q:$E(R,$L(R))?1P!'$L(R)  S R=$E(R,1,$L(R)-1)
	I $E(R,$L(R))=" " S R=$E(R,1,$L(R)-1)
OMSCHZ	Q R
	;
BCHLD(SRT,DMSCP,UI1C,DMSPP,AFW,SK)	; opzetten properties, indexen, methodes, applicaties, queries
	; SRT = 1 = properties
	;       2 = indexen
	;       3 = methodes
	;       4 = queries
	; DMSC  = DC
	; UI1C = UI1 van DDC (nooit van de afwijking)
	; DMSP  = DP
	; AFW    = code afwijking (bv FOR, TBK)
	; SK   = SK(1) = B-index(en) searchkey 1, SK(2) = B-index(en) searchkey 2
	;
	; Opgelet : DP.PROP dient reeds verwijderd te zijn
	;           (wordt normaal verwijderd bij verwijderen van klasse/property in DDP)
	; 
	S $ZT="TRAP^cAN000"
	N UQC,USC,UREF,IREF,SW3,I1,OK,UI1,UI1CP,R,B,i,TAB,UI1P,K,TKB,TK,TFORK,UI1ID,TEL
	D DMS^cAN000("UQC","USC",DMSCP,1) I '$L(UQC)!'$L(USC) S OK="0\"_$P($T(@("T2"_QT)),U,2)_DMSCP G BCHLDZ
	S IREF=^DMC(UQC,USC,"DATA","INDEX"),UREF=^("REF")
	S SW3=$$SW3(DMSCP) I 'SW3 S OK="0\"_$P($T(@("T3"_QT)),U,2)_DMSCP G BCHLDZ
	S I1=UI1C_" ",(I1,UI1CD)=$$DI^cAN000(UI1C,""),AFW=$G(AFW),OK=1,UI1ID=""
BCHLDA	S I1=$O(@IREF@(101,I1)) G BCHLDC:$E(I1,1,$L(UI1CD))'=UI1CD
	S (UI1,UI1CP)=$P(^(I1),D)
	I $L($P(@UREF@(0),D,33)) G BCHLDA  ; indien origineel ingevuld niet meenemen
	; ku 25.10
	; I $L(AFW) D  ; UI1 van de afwijking ophalen
	; . S R=$$UI1OP^cAFA1(DMSCP,"M2","1\1",UI1CP,AFW)
	; . I $L(R) S UI1=R
	; S R=$$UI1OP^cAFA1(DMSCP,133,"1\1",UI1CP)  ; is er een copy van het origineel ?
	; I $L(R) S UI1=R
	; S B(1)=@UREF@(0) F i=2:1:SW3 S B(i)=$G(^(i-1))
	; ku 25.10
	; I $L($P(B(1),D,32)),$P(B(1),D,32)'=AFW G BCHLDA
	; ophalen data
BCHLDB	K B S OK=$$GDCHLD(SRT,DMSCP,UI1CP,.B,UREF,SW3) I 'OK G BCHLDC
	S UI1=$P(OK,D,2)
	; GM 04.05.07 - Buiten gebruik ook opzetten in einddefinitie
	;I $P(B(1),D,30) G BCHLDA  ; BG of verwijderd
	I $P(B(1),D,30)=2 G BCHLDA  ; Verwijderd
	; properties : eventueel ophalen node 1 uit datadic
	; I SRT=1,$L($P(B(1),D,5)) S OK=$$GDPROP(DMSCP,UI1,.B,SW3,$G(AFW)) I 'OK G BCHLDZ
	; I SRT=1,$P(B(1),D,7) S $P(B(2),D,12,13)=D   ; indien subscript ingevuld geen klas- of grid referentie
	S UI1P=UI1CP   ; UI1 voor DDP : steeds van originele property
	K TAB
	; indien Id, intern nummer bijhouden
	I SRT=1,$P(B(1),D,7),$E($P(B(1),D,3),$L($P(B(1),D,3))-1,$L($P(B(1),D,3)))="Id" S UI1ID=UI1P,SK(1,"T")=UI1P
	; data voor searchkey bijhouden
	I SRT=1,$L($P(B(1),D,10)) F TEL=1,2 D
	. I '$D(SK(TEL,"D")),$P(B(1),D,10)=$P(SK(TEL),D) M SK(TEL,"D")=B S SK(TEL,"P")=UI1P
	. F i=1:1:$L(SK(TEL),D) I $P(SK(TEL),D,i)=$P(B(1),D,10),'$L($P($G(SK(TEL,"I")),D,i)) S $P(SK(TEL,"I"),D,i)=$P(B(1),D,3)
	M TAB=B
	S $P(TAB(1),D,28,29)=D
	S $P(TAB(1),D,33)=UI1   ; invullen gebruikt item
	D P^cAN220(DMSPP,"",UI1P,"TAB","") I K="-" S OK="0\"_$P($T(@("T7"_QT)),U,2)_DMSPP_" : "_UI1P G BCHLDZ
	; property : opzetten definitie per taal + indien afwijking zit def. per taal ook bij de afwijking
	I SRT=1 D  I 'OK G BCHLDZ
	. ; indien geen link naar DD of overschrijf DD staat op : bij DC.PROP.TAAL ophalen
	. ; anders uit DD.TAAL
	. S OK=$$BTAAL($S('$L($P(B(1),D,5))!$P(B(1),D,11):DMSCP,1:"DD")_".TAAL",$S('$L($P(B(1),D,5))!$P(B(1),D,11):UI1,1:$P(B(1),D,5)),DMSPP_".TAAL",UI1P,,$G(SK(1,"T"))=UI1P,$L($P(B(2),D,12)))
	; applicatie : opzetten definitie per taal + indien afwijking zit def. per taal ook bij de afwijking
	I SRT=4 D  I 'OK G BCHLDZ
	. ; indien geen link naar DD of overschrijf DD staat op : bij DC.PROP.TAAL ophalen
	. ; anders uit DD.TAAL
	. S OK=$$BTAAL(DMSCP_".TAAL",UI1,DMSPP_".TAAL",UI1P)
	G BCHLDA
BCHLDC	; aanpassen titel foreign key
	I SRT'=1 G BCHLDZ            ; enkel voor properties
	D SEARCHK(1) I 'OK G BCHLDZ  ; opzetten zoeksleutel 1
	D SEARCHK(2) I 'OK G BCHLDZ  ; opzetten zoeksleutel 2
	; GM 01.02.06 DV270 - FK wordt niet meer in ^DDP samengesteld, gaat nu via $$OMS^cABVBA01
	;D DMS^cAN000("UQC","USC",DMSPP_".TAAL",1) I '$L(UQC)!'$L(USC) S OK="0\"_$P($T(@("T2"_QT)),U,2)_DMSCT G BCHLDZ
	;S UREF=^DMC(UQC,USC,"DATA","REF")
	;I '$G(UI1ID) G BCHLDE  ; geen Id gevonden
	; bepalen titel foreignkey van het Id
	;S TKI1=""
BCHLDD	;F  S TKI1=$O(^DKODE(0,"CODE.9010",TKI1)) Q:TKI1=""  D
	;. S TKB=^(TKI1,0)
	;. I $P(TKB,D,30) Q  ; BG of verwijderd
	;. S TK=$P(TKB,D)
	;. S UI1=UI1ID_" "_TK
	;. S K=$P($G(@UREF@(1)),D,13) I '$L(K) S K=$P($G(^(1)),D,11)
	;. I TK'="E",$L(K),$$LC^cAFA1($E(K,2,$L(K)))=$E(K,2,$L(K)) S K=$$LC^cAFA1(K)
	;. S TFORK(TK)=K
BCHLDE	;S UI1=UI1C_" "
BCHLDF	;S UI1=$O(@UREF) I $P(UI1," ")'=UI1C G BCHLDZ
	; titel foreign key reeds ingevuld en er is geen referentie ingevuld
	;I $L($P(@UREF@(1),D,13)),'$L($$SIG^cAFA1(DMSPP,$P(^(0),D),212)) G BCHLDF
	;S TK=$P(@UREF@(0),D,2)
	;S K=$P(^(1),D,11)
	;I $$SIG^cAFA1(DMSPP,$P(^(0),D),113)=1,'$L($P(@UREF@(1),D,13)) S $P(@UREF@(1),D,13)=K G BCHLDF  ; zoeksl. 1
	;I $P(UI1," ",2)'=$P(UI1ID," ",2),$L(K) S K=K_$S($L($G(TFORK(TK))):" "_TFORK(TK),1:"")
	;S $P(@UREF@(1),D,13)=K
	;G BCHLDF
BCHLDZ	Q OK
	;
GDCHLD(SRT,DMSCP,UI1CP,B,UREF,SW3)	; ophalen data
	; DMSCP = DMS van property
	; UI1CP = UI1 van de property
	N UQC,USC,OK,UI1,i
	S $ZT="TRAP^cAN000"
	S OK=1_D_UI1CP
GDCHLDA	I $L($G(UREF)) G GDCHLDB
	D DMS^cAN000("UQC","USC",DMSCP,1) I '$L(UQC)!'$L(USC) S OK="0\"_$P($T(@("T2"_QT)),U,2)_DMSCP G GDCHLDZ
	S UREF=^DMC(UQC,USC,"DATA","REF")
GDCHLDB	I '$G(SW3) S SW3=$$SW3(DMSCP) I 'SW3 S OK="0\"_$P($T(@("T3"_QT)),U,2)_DMSCP G GDCHLDZ
	S UI1=UI1CP
	S R=$$UI1OP^cAFA1(DMSCP,133,"\1",UI1CP)  ; is er een copy van het origineel ?
	I $L(R) S UI1=R
	S OK=1_D_UI1_D_R
	S B(1)=@UREF@(0) F i=2:1:SW3 S B(i)=$G(^(i-1))
	S $P(B(1),D,2)=$P(UI1CP," ",2)
	; properties : eventueel ophalen node 1 uit datadic
GDCHLDC	I SRT'=1 G GDCHLDZ
	I $L($P(B(1),D,5)) S i=$$GDPROP(DMSCP,UI1,.B,SW3,$G(AFW)) I 'i S OK=i G GDCHLDZ
	;GM 25.04.07 - Klas- en grid referentie toch behouden voor ID
	;I $P(B(1),D,7) S $P(B(2),D,12,13)=D   ; indien subscript ingevuld geen klas- of grid referentie
GDCHLDZ	Q OK
	;
GDPROP(DMSCP,UI1,B,SW3,AFW)	; ophalen data node 1 van de property
	; DMSCP = DMS van propert
	; UI1 = UI1 van de property
	; B = tabel B : opgelet : wordt doorgegeven als referentie : .B
	; SW3 = hoeveel nodes
	; 
	;  !!!! opgelet : als hier iets aangepast wordt ivm ophalen node1
	;       moet dit ook in NODE1^cABVBK10 aangepast worden !!!!
	;   	        
	; 
	S $zt="TRAP^cAN000"
	N OK,i,R,BD,TREFW
	S OK=1
	I '$G(SW3) S SW3=$$SW3(DMSCP) I 'SW3 S OK="0\"_$P($T(@("T3"_QT)),U,2)_DMSCP G GDPROPZ
	I '$D(B(1)) S B(1)=$$SIGN^cAFA1(DMSCP,UI1,0) F i=2:1:SW3 S B(i)=$G(^(i-1))
	I '$L($P(B(1),D,5)) G GDPROPZ   ; geen link met datadic
	I $P(B(1),D,11) G GDPROPZ      ; bij ingave van property wijkte data af van datadic
	; ku 25.10
	; I $L($G(AFW)) D  ; UI1 van de afwijking ophalen
	; . S R=$$UI1OP^cAFA1("DD","M2","1\1",$P(B(1),D,5),AFW)
	; . I $L(R) S $P(B(1),D,5)=R
	; ophalen gegevens uit datadic
	S R=$$UI1OP^cAFA1("DD",133,"1\1",$P(B(1),D,5))  ; is er een copy van het origineel ?
	I $L(R) S $P(B(1),D,5)=R
	S BD(2)=$$SIGN^cAFA1("DD",$P(B(1),D,5),1),TREFW=$P($G(^(0)),D)
	I '$L(BD(2)) S OK="0\"_$P($T(@("T6"_QT)),U,2)_"DD :"_$P(B(1),D,5) G GDPROPZ
	I '$L($TR($G(B(4)),"\0")) S B(2)=BD(2) G GDPROPY
	; er kan per veld ingesteld zijn om over te nemen van datadic :
	;    0 of "" = overnemen van datadic
	;    1 = ophalen bij property zelf
	F i=1:1:$L(B(4),D) I '$P(B(4),D,i) S $P(B(2),D,i)=$P(BD(2),D,i)
GDPROPY	S $P(B(1),D,12)=$$DP^cABVBD1(TREFW,$$SIG^cAFA1("DD",$P(B(1),D),101))  ; ophalen en wegschrijven trefwoord DDD
GDPROPZ	Q OK
	;
SEARCHK(TEL)	
	I TEL=1,'$D(SK(TEL,"T")) G SEARCHKZ   ; geen ID
	I '$D(SK(TEL,"P")) G SEARCHKZ         ; geen property gevonden
	K TAB
	M TAB=SK(TEL,"D")  ; ophalen data
	S $P(TAB(1),D,3)=$TR(SK(TEL,"I"),D,"#")
	S $P(TAB(1),D,28,29)=D
	S $P(TAB(1),D,33)=SK(TEL,"P")   ; invullen gebruikt item
	I $L($P(TAB(1),D,12)) S $P(TAB(1),D,12)="z"_TEL_$P(TAB(1),D,12)
	S $P(TAB(1),D,13)=TEL           ; nummer zoeksleutel
	S $P(TAB(1),D,4)="Zoeksleutel "_TEL
	S $P(TAB(1),D,2)=100+TEL  ; invullen volgnr
	S UI1P=$P(TAB(1),D)_" "_$P(TAB(1),D,2)
	D P^cAN220(DMSPP,"",UI1P,"TAB","") I K="-" S OK="0\"_$P($T(@("T7"_QT)),U,2)_DMSPP_" : "_UI1P G SEARCHKZ
	; opzetten taalafhankelijke gegevens
	I TEL=2 G SEARCHKC
SEARCHKA	S OK=$$BTAAL(DMSPP_".TAAL",SK(1,"T"),DMSPP_".TAAL",UI1P,TEL)  ; 'kopieer' taalgeg. ID naar taalgegens Searchkey 1
	G SEARCHKZ
SEARCHKC	S OK=$$BTAAL(DMSPP_".TAAL",SK(2,"P"),DMSPP_".TAAL",UI1P,TEL_$S($L(SK(TEL),D)>1:D_1,1:""))
SEARCHKZ	Q 
 	;
SW3(DMS)	; ophalen SW3
	S $ZT="TRAP^cAN000"
	N SW3,I,J,U7,UQA,USA,ZR,UQCC,USCC
	S SW3=0
	D DMS^cAN000("UQCC","USCC",DMS,1) I '$L(UQCC)!'$L(USCC) G SW3Z
	I $ZR'["DMS" G SW3Z
	S UQD=$QS($ZR,1)  ; ophalen subscript 1
	S USA=$G(^DMS(UQD,DMS,"DMA","O")),UQA=$P(USA,D),USA=$P(USA,D,2)
	S I=0 F  S I=$O(^DMA(UQA,USA,I)) Q:I=""  S J="" D
	. F  S J=$O(^DMA(UQA,USA,I,J)) Q:J=""  S U7=$G(^(J,16)) I U7\100>SW3 S SW3=U7\100
SW3Z	Q SW3
	;
ZZ	; 29.08.07 - 10 u 22 * V8.09