- DIQGQ ;SFISC/DCL-DATA RETRIEVAL ;03:48 PM 26 Mar 2001 [ 12/09/2003 4:34 PM ]
- ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;RECURSIVELY CALLED FROM BELOW
- DDENTRY N DIQGQE S DIQGQE=0
- I $G(U)'="^" N U S U="^"
- I '$G(DA) N X S X(1)="RECORD" G 202
- ;K DIERR,^TMP("DIERR",$J)
- ;N DIERR
- N DIQGCP,DIQGDD S DIQGPARM=$G(DIQGPARM),DIQGIPAR=$G(DIQGIPAR),DIQGDD=DIQGPARM["D",DIQGCP=$S(DIQGDD:"D",1:"") S:DIQGPARM["Z" DIQGCP=DIQGCP_"Z" S:DIQGPARM["F" DIQGCP=DIQGCP_"F"
- N DIQGFE,DIQGFEN S DIQGFE=DIQGPARM["R"
- N DIQGFET S DIQGFET=DIQGPARM["T"
- I '$D(DIQGR) N X S X(1)="FILE" G 202
- N DIQGI1 S DIQGI1=+DIQGIPAR=0
- I DIQGI1,'DIQGR N X S X(1)="FILE" G 202
- D:$G(DA)["," IEN(DA,.DA)
- I DIQGI1,'DIQGDD,$$N9^DIQGU(DIQGR,.DA) D BLD^DIALOG(602) G OUT
- I '$D(DR) N X S X(1)="FIELD" G 202
- I DIQGI1,$G(DIQGTA)']"" N X S X(1)="TARGET ARRAY" G 202
- I DIQGI1,("("[$G(DIQGTA)&(")"'[$G(DIQGTA))) N X S X(1)="TARGET ARRAY" G 202
- S:DIQGR DIQGR=$S(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA)) I DIQGR="" N X S X(1)="FILE AND IEN COMBINATION" G 202
- N DIQGMDD,DIQGE,DIQGI,DIQGXXE,DIQGXXI,DIQGSI,DIQGXAF,DIQGXPRI,DIQGXPRE,DIQGXPRN,DIQGXPRF,DIQGXDD,DIQGXDDN,DIQGXPRA,DIQGXTA,DIQGXDA,DIQGXPRS,DIQGPRSE S DIQGPRSE=1
- S DIQGSI=$$CREF(DIQGR),DIQGXAF=0,DIQGXPRI=DIQGPARM["I",DIQGXPRE=DIQGPARM["E",DIQGXPRN=DIQGPARM["N",DIQGXPRF=DIQGPARM["F",DIQGXPRS=DIQGPARM["S" S:DIQGXPRS DIQGXPRE=1,DIQGXPRI=1 S DIQGXPRA=DIQGXPRE!DIQGXPRI
- I '$D(@DIQGSI@(DA)),DIQGPARM'["A" D BLD^DIALOG(601) G OUT ;Entry may have existed in the past
- S:$D(@DIQGSI@(0)) DIQGXDDN=+$P(^(0),"^",2),DIQGXDD="^DD("_DIQGXDDN_")" I '$D(DIQGXDD) N X S X("FILE")=DIQGR D BLD^DIALOG(401,.X) G OUT
- S:'DIQGXDDN DIQGXDDN=+$P(DIQGR,"(",2)
- I $D(DIQGTA)=1,DIQGTA]"",DIQGTA'>0 S DIQGXAF=1,DIQGXTA=DIQGTA S DIQGXTA=$$CREF(DIQGXTA)
- N DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDT S DIQGXDC=0
- AUDIT I DIQGIPAR'["R" N DIQGAUDR,DIQGAUDD S DIQGAUDD=+$P(DIQGPARM,"A",2) I DIQGAUDD D GET^DIAUTL(DIQGXDDN,DA_",",DIQGAUDD,"DIQGAUDR") ;is there and AUDIT TRAIL??
- F DIQGXDI=1:1 S DIQGXDF=$P(DR,";",DIQGXDI),DIQGXDN=$P(DIQGXDF,":") Q:DIQGXDF="" D I $L(DIQGXDF,":")>1 S DIQGXDT=$P(DIQGXDF,":",2) F S DIQGXDN=$O(@DIQGXDD@(+DIQGXDN)) Q:DIQGXDN'>0!(DIQGXDN>DIQGXDT) S DIQGXDC=$P(^(DIQGXDN,0),"^",2) D ;
- .I DIQGXDC,$P(^DD(+DIQGXDC,.01,0),"^",2)'["W" S:DR="**" DIQGXDN=DIQGXDN_"*" Q:$L(DIQGXDN,"*")'=2
- .I DIQGXDN'?.N,$L(DIQGXDN,"*")=2,$P(DIQGXDN,"*")]"",$D(@DIQGXDD@("B",$P(DIQGXDN,"*"))) S DIQGXDN=$O(^($P(DIQGXDN,"*"),""))_"*"
- .I $L(DIQGXDN,"*")=2,+DIQGXDN>0 S DIQGMDD=+$P($G(@DIQGXDD@(+DIQGXDN,0)),"^",2) I DIQGMDD,$P(^DD(DIQGMDD,.01,0),"^",2)'["W" D Q
- ..N DIQGMDA,DIQGMGR
- ..D F S DIQGMDA=$O(@DIQGMGR@(DIQGMDA)) Q:DIQGMDA'>0 D EN($S('DIQGDD:DIQGMDD,1:$$OREF(DIQGMGR)),.DIQGMDA,"**",DIQGPARM,.DIQGTA,"",''DIQGDD_"R")
- ...N I F I=1:1 Q:'$D(DA(I)) S DIQGMDA(I+1)=DA(I)
- ...S DIQGMDA(1)=DA,DIQGMGR=$S('DIQGDD:$$ROOT^DIQGU(DIQGMDD,.DIQGMDA,1),1:DIQGR_DA_","_$$Q($P($P(@DIQGXDD@(+DIQGXDN,0),"^",4),";"))_")"),DIQGMDA=0
- ...Q
- .I DIQGXDN="*"!(DIQGXDN="**") S DIQGXDN=0,DIQGXDF=":999999999" Q
- .S DIQGXDA=$$DA(.DA),DIQGFEN=$S((DIQGFE&(DIQGXDN))!(DIQGFET):$P(@DIQGXDD@(DIQGXDN,0),"^"),1:DIQGXDN) S:DIQGFET DIQGFEN=DIQGXDN_" "_DIQGFEN
- .I DIQGDD N DIQGXDDN S DIQGXDDN="DD"
- INTERNAL .I DIQGXPRI D Q:DIQGI="$WP$" G:$G(DIERR) ERR
- ..I $G(DIQGAUDR(DIQGXDDN,DIQGXDA)) S DIQGI="" G XXI
- ..I $D(DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN)) S DIQGI=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN)) G XXI
- ..S DIQGI=$$GET^DIQG(DIQGR,.DA,DIQGXDN,"I"_DIQGCP,$S('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
- XXI ..S DIQGXXI='DIQGXPRN!(DIQGXPRN&(DIQGI]""))
- ..Q
- EXTERNAL .I DIQGXPRE!'DIQGXPRA D Q:DIQGE="$WP$"
- ..I $G(DIQGAUDR(DIQGXDDN,DIQGXDA)) S DIQGE="" G XXE
- ..I $D(DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN)) S DIQGE=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN),"E") G XXE
- ..S DIQGE=$$GET^DIQG(DIQGR,.DA,DIQGXDN,DIQGCP,$S('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
- XXE ..S DIQGXXE='DIQGXPRN!(DIQGXPRN&(DIQGE]""))
- ..Q
- ERR .I $G(DIERR) S $P(DIQGQERR,U)=$P($G(DIQGQERR),U)+DIERR,$P(DIQGQERR,U,2)=$P($G(DIQGQERR),U,2)+$P(DIERR,U,2) K DIERR S DIQGQE=DIQGQE+1 Q
- .S:DIQGXPRS DIQGPRSE=DIQGI'=DIQGE
- .I DIQGXAF,DIQGXPRA D Q
- ..G:DIQGXPRF XPRF1
- ..I DIQGXPRI,DIQGXXI S @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"I")=DIQGI
- ..I DIQGXPRE,DIQGXXE,DIQGPRSE S @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"E")=DIQGE
- ..Q
- XPRF1 ..I DIQGXPRI,DIQGXXI S @DIQGXTA@(DIQGFEN,"I")=DIQGI
- ..I DIQGXPRE,DIQGXXE,DIQGPRSE S @DIQGXTA@(DIQGFEN,"E")=DIQGE
- ..Q
- .I DIQGXAF D Q
- ..I DIQGXPRF,DIQGXXE S @DIQGXTA@(DIQGFEN)=DIQGE Q
- ..S:DIQGXXE @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN)=DIQGE
- ..Q
- .Q
- Q
- ;
- CREF(X) N L,X1,X2,X3 S X1=$P(X,"("),X2=$P(X,"(",2,99),L=$L(X2),X3=$TR($E(X2,L),",)"),X2=$E(X2,1,(L-1))_X3 Q X1_$S(X2]"":"("_X2_")",1:"")
- OREF(X) N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2)) Q:X2="" X1 Q X1_X2_","
- OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
- DA(DA) N X,Y S X="",Y=$G(DA)_"," F S X=$O(DA(X)) Q:X="" S Y=Y_DA(X)_","
- Q Y
- IEN(IEN,DA) S DA=$P(IEN,",") N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I)
- Q
- Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
- DD(X) Q:'$D(^DD(X)) "" Q "^DD("_X_","
- 202 D BLD^DIALOG(202,.X)
- OUT Q
- DIQGQ ;SFISC/DCL-DATA RETRIEVAL ;03:48 PM 26 Mar 2001 [ 12/09/2003 4:34 PM ]
- +1 ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
- +2 ;Per VHA Directive 10-93-142, this routine should not be modified.
- EN(DIQGR,DA,DR,DIQGPARM,DIQGTA,DIQGERRA,DIQGIPAR) ;RECURSIVELY CALLED FROM BELOW
- DDENTRY NEW DIQGQE
- SET DIQGQE=0
- +1 IF $GET(U)'="^"
- NEW U
- SET U="^"
- +2 IF '$GET(DA)
- NEW X
- SET X(1)="RECORD"
- GOTO 202
- +3 ;K DIERR,^TMP("DIERR",$J)
- +4 ;N DIERR
- +5 NEW DIQGCP,DIQGDD
- SET DIQGPARM=$GET(DIQGPARM)
- SET DIQGIPAR=$GET(DIQGIPAR)
- SET DIQGDD=DIQGPARM["D"
- SET DIQGCP=$SELECT(DIQGDD:"D",1:"")
- IF DIQGPARM["Z"
- SET DIQGCP=DIQGCP_"Z"
- IF DIQGPARM["F"
- SET DIQGCP=DIQGCP_"F"
- +6 NEW DIQGFE,DIQGFEN
- SET DIQGFE=DIQGPARM["R"
- +7 NEW DIQGFET
- SET DIQGFET=DIQGPARM["T"
- +8 IF '$DATA(DIQGR)
- NEW X
- SET X(1)="FILE"
- GOTO 202
- +9 NEW DIQGI1
- SET DIQGI1=+DIQGIPAR=0
- +10 IF DIQGI1
- IF 'DIQGR
- NEW X
- SET X(1)="FILE"
- GOTO 202
- +11 IF $GET(DA)[","
- DO IEN(DA,.DA)
- +12 IF DIQGI1
- IF 'DIQGDD
- IF $$N9^DIQGU(DIQGR,.DA)
- DO BLD^DIALOG(602)
- GOTO OUT
- +13 IF '$DATA(DR)
- NEW X
- SET X(1)="FIELD"
- GOTO 202
- +14 IF DIQGI1
- IF $GET(DIQGTA)']""
- NEW X
- SET X(1)="TARGET ARRAY"
- GOTO 202
- +15 IF DIQGI1
- IF ("("[$GET(DIQGTA)&(")"'[$GET(DIQGTA)))
- NEW X
- SET X(1)="TARGET ARRAY"
- GOTO 202
- +16 IF DIQGR
- SET DIQGR=$SELECT(DIQGDD:$$DD(DIQGR),1:$$ROOT^DIQGU(DIQGR,.DA))
- IF DIQGR=""
- NEW X
- SET X(1)="FILE AND IEN COMBINATION"
- GOTO 202
- +17 NEW DIQGMDD,DIQGE,DIQGI,DIQGXXE,DIQGXXI,DIQGSI,DIQGXAF,DIQGXPRI,DIQGXPRE,DIQGXPRN,DIQGXPRF,DIQGXDD,DIQGXDDN,DIQGXPRA,DIQGXTA,DIQGXDA,DIQGXPRS,DIQGPRSE
- SET DIQGPRSE=1
- +18 SET DIQGSI=$$CREF(DIQGR)
- SET DIQGXAF=0
- SET DIQGXPRI=DIQGPARM["I"
- SET DIQGXPRE=DIQGPARM["E"
- SET DIQGXPRN=DIQGPARM["N"
- SET DIQGXPRF=DIQGPARM["F"
- SET DIQGXPRS=DIQGPARM["S"
- IF DIQGXPRS
- SET DIQGXPRE=1
- SET DIQGXPRI=1
- SET DIQGXPRA=DIQGXPRE!DIQGXPRI
- +19 ;Entry may have existed in the past
- IF '$DATA(@DIQGSI@(DA))
- IF DIQGPARM'["A"
- DO BLD^DIALOG(601)
- GOTO OUT
- +20 IF $DATA(@DIQGSI@(0))
- SET DIQGXDDN=+$PIECE(^(0),"^",2)
- SET DIQGXDD="^DD("_DIQGXDDN_")"
- IF '$DATA(DIQGXDD)
- NEW X
- SET X("FILE")=DIQGR
- DO BLD^DIALOG(401,.X)
- GOTO OUT
- +21 IF 'DIQGXDDN
- SET DIQGXDDN=+$PIECE(DIQGR,"(",2)
- +22 IF $DATA(DIQGTA)=1
- IF DIQGTA]""
- IF DIQGTA'>0
- SET DIQGXAF=1
- SET DIQGXTA=DIQGTA
- SET DIQGXTA=$$CREF(DIQGXTA)
- +23 NEW DIQGXDC,DIQGXDF,DIQGXDI,DIQGXDN,DIQGXDT
- SET DIQGXDC=0
- AUDIT ;is there and AUDIT TRAIL??
- IF DIQGIPAR'["R"
- NEW DIQGAUDR,DIQGAUDD
- SET DIQGAUDD=+$PIECE(DIQGPARM,"A",2)
- IF DIQGAUDD
- DO GET^DIAUTL(DIQGXDDN,DA_",",DIQGAUDD,"DIQGAUDR")
- +1 ;
- FOR DIQGXDI=1:1
- SET DIQGXDF=$PIECE(DR,";",DIQGXDI)
- SET DIQGXDN=$PIECE(DIQGXDF,":")
- IF DIQGXDF=""
- QUIT
- Begin DoDot:1
- +2 IF DIQGXDC
- IF $PIECE(^DD(+DIQGXDC,.01,0),"^",2)'["W"
- IF DR="**"
- SET DIQGXDN=DIQGXDN_"*"
- IF $LENGTH(DIQGXDN,"*")'=2
- QUIT
- +3 IF DIQGXDN'?.N
- IF $LENGTH(DIQGXDN,"*")=2
- IF $PIECE(DIQGXDN,"*")]""
- IF $DATA(@DIQGXDD@("B",$PIECE(DIQGXDN,"*")))
- SET DIQGXDN=$ORDER(^($PIECE(DIQGXDN,"*"),""))_"*"
- +4 IF $LENGTH(DIQGXDN,"*")=2
- IF +DIQGXDN>0
- SET DIQGMDD=+$PIECE($GET(@DIQGXDD@(+DIQGXDN,0)),"^",2)
- IF DIQGMDD
- IF $PIECE(^DD(DIQGMDD,.01,0),"^",2)'["W"
- Begin DoDot:2
- +5 NEW DIQGMDA,DIQGMGR
- +6 Begin DoDot:3
- +7 NEW I
- FOR I=1:1
- IF '$DATA(DA(I))
- QUIT
- SET DIQGMDA(I+1)=DA(I)
- +8 SET DIQGMDA(1)=DA
- SET DIQGMGR=$SELECT('DIQGDD:$$ROOT^DIQGU(DIQGMDD,.DIQGMDA,1),1:DIQGR_DA_","_$$Q($PIECE($PIECE(@DIQGXDD@(+DIQGXDN,0),"^",4),";"))_")")
- SET DIQGMDA=0
- +9 QUIT
- End DoDot:3
- FOR
- SET DIQGMDA=$ORDER(@DIQGMGR@(DIQGMDA))
- IF DIQGMDA'>0
- QUIT
- DO EN($SELECT('DIQGDD:DIQGMDD,1:$$OREF(DIQGMGR)),.DIQGMDA,"**",DIQGPARM,.DIQGTA,"",''DIQGDD_"R")
- End DoDot:2
- QUIT
- +10 IF DIQGXDN="*"!(DIQGXDN="**")
- SET DIQGXDN=0
- SET DIQGXDF=":999999999"
- QUIT
- +11 SET DIQGXDA=$$DA(.DA)
- SET DIQGFEN=$SELECT((DIQGFE&(DIQGXDN))!(DIQGFET):$PIECE(@DIQGXDD@(DIQGXDN,0),"^"),1:DIQGXDN)
- IF DIQGFET
- SET DIQGFEN=DIQGXDN_" "_DIQGFEN
- +12 IF DIQGDD
- NEW DIQGXDDN
- SET DIQGXDDN="DD"
- INTERNAL IF DIQGXPRI
- Begin DoDot:2
- +1 IF $GET(DIQGAUDR(DIQGXDDN,DIQGXDA))
- SET DIQGI=""
- GOTO XXI
- +2 IF $DATA(DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN))
- SET DIQGI=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN))
- GOTO XXI
- +3 SET DIQGI=$$GET^DIQG(DIQGR,.DA,DIQGXDN,"I"_DIQGCP,$SELECT('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
- XXI SET DIQGXXI='DIQGXPRN!(DIQGXPRN&(DIQGI]""))
- +1 QUIT
- End DoDot:2
- IF DIQGI="$WP$"
- QUIT
- IF $GET(DIERR)
- GOTO ERR
- EXTERNAL IF DIQGXPRE!'DIQGXPRA
- Begin DoDot:2
- +1 IF $GET(DIQGAUDR(DIQGXDDN,DIQGXDA))
- SET DIQGE=""
- GOTO XXE
- +2 IF $DATA(DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN))
- SET DIQGE=$$DIA^DIAUTL(DIQGAUDD,DIQGAUDR,DIQGAUDR(DIQGXDDN,DIQGXDA,DIQGXDN),"E")
- GOTO XXE
- +3 SET DIQGE=$$GET^DIQG(DIQGR,.DA,DIQGXDN,DIQGCP,$SELECT('DIQGXPRF:$$OREF(DIQGXTA)_$$Q(DIQGXDDN)_","_$$Q(DIQGXDA)_","_$$Q(DIQGFEN)_")",1:$$OREF(DIQGXTA)_$$Q(DIQGFEN)_")"),"","1A")
- XXE SET DIQGXXE='DIQGXPRN!(DIQGXPRN&(DIQGE]""))
- +1 QUIT
- End DoDot:2
- IF DIQGE="$WP$"
- QUIT
- ERR IF $GET(DIERR)
- SET $PIECE(DIQGQERR,U)=$PIECE($GET(DIQGQERR),U)+DIERR
- SET $PIECE(DIQGQERR,U,2)=$PIECE($GET(DIQGQERR),U,2)+$PIECE(DIERR,U,2)
- KILL DIERR
- SET DIQGQE=DIQGQE+1
- QUIT
- +1 IF DIQGXPRS
- SET DIQGPRSE=DIQGI'=DIQGE
- +2 IF DIQGXAF
- IF DIQGXPRA
- Begin DoDot:2
- +3 IF DIQGXPRF
- GOTO XPRF1
- +4 IF DIQGXPRI
- IF DIQGXXI
- SET @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"I")=DIQGI
- +5 IF DIQGXPRE
- IF DIQGXXE
- IF DIQGPRSE
- SET @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN,"E")=DIQGE
- +6 QUIT
- XPRF1 IF DIQGXPRI
- IF DIQGXXI
- SET @DIQGXTA@(DIQGFEN,"I")=DIQGI
- +1 IF DIQGXPRE
- IF DIQGXXE
- IF DIQGPRSE
- SET @DIQGXTA@(DIQGFEN,"E")=DIQGE
- +2 QUIT
- End DoDot:2
- QUIT
- +3 IF DIQGXAF
- Begin DoDot:2
- +4 IF DIQGXPRF
- IF DIQGXXE
- SET @DIQGXTA@(DIQGFEN)=DIQGE
- QUIT
- +5 IF DIQGXXE
- SET @DIQGXTA@(DIQGXDDN,DIQGXDA,DIQGFEN)=DIQGE
- +6 QUIT
- End DoDot:2
- QUIT
- +7 QUIT
- End DoDot:1
- IF $LENGTH(DIQGXDF,":")>1
- SET DIQGXDT=$PIECE(DIQGXDF,":",2)
- FOR
- SET DIQGXDN=$ORDER(@DIQGXDD@(+DIQGXDN))
- IF DIQGXDN'>0!(DIQGXDN>DIQGXDT)
- QUIT
- SET DIQGXDC=$PIECE(^(DIQGXDN,0),"^",2)
- Begin DoDot:1
- End DoDot:1
- +8 QUIT
- +9 ;
- CREF(X) NEW L,X1,X2,X3
- SET X1=$PIECE(X,"(")
- SET X2=$PIECE(X,"(",2,99)
- SET L=$LENGTH(X2)
- SET X3=$TRANSLATE($EXTRACT(X2,L),",)")
- SET X2=$EXTRACT(X2,1,(L-1))_X3
- QUIT X1_$SELECT(X2]"":"("_X2_")",1:"")
- OREF(X) NEW X1,X2
- SET X1=$PIECE(X,"(")_"("
- SET X2=$$OR2($PIECE(X,"(",2))
- IF X2=""
- QUIT X1
- QUIT X1_X2_","
- OR2(%) IF %=")"!(%=",")
- QUIT ""
- IF $LENGTH(%)=1
- QUIT %
- IF "),"[$EXTRACT(%,$LENGTH(%))
- SET %=$EXTRACT(%,1,$LENGTH(%)-1)
- QUIT %
- DA(DA) NEW X,Y
- SET X=""
- SET Y=$GET(DA)_","
- FOR
- SET X=$ORDER(DA(X))
- IF X=""
- QUIT
- SET Y=Y_DA(X)_","
- +1 QUIT Y
- IEN(IEN,DA) SET DA=$PIECE(IEN,",")
- NEW I
- FOR I=2:1
- IF $PIECE(IEN,",",I)=""
- QUIT
- SET DA(I-1)=$PIECE(IEN,",",I)
- +1 QUIT
- Q(%Z) SET %Z(%Z)=""
- SET %Z=$QUERY(%Z(""))
- QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
- DD(X) IF '$DATA(^DD(X))
- QUIT ""
- QUIT "^DD("_X_","
- 202 DO BLD^DIALOG(202,.X)
- OUT QUIT
