DIQGQ ;SFISC/DCL-DATA RETRIEVAL ; Jun 08, 2023@08:54:56
;;22.2;VA FileMan;**28**;Jan 05, 2016;Build 2
;;Per VA Directive 6402, this routine should not be modified.
;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
;;Licensed under the terms of the Apache License, Version 2.0.
;
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) ;p28
;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 ERROUT ;p28
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 an 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 DIQGXDN?.N,'$D(@DIQGXDD@(DIQGXDN,0)) D BLD^DIALOG(200,.X) G ERROUT ;check that field exists ;p28
DOWN .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:'$D(DOERR) G ERR
..N DIQGMDA,DIQGMGR
..D I DIQGMGR="" N X S X(1)="IENS" D 202 Q ;we don't want a syntax error on $O(@DIQGMGR@(DIQGMDA)) below!
...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
..F S DIQGMDA=$O(@DIQGMGR@(DIQGMDA)) Q:DIQGMDA'>0 D EN($S('DIQGDD:DIQGMDD,1:$$OREF(DIQGMGR)),.DIQGMDA,"**",DIQGPARM,.DIQGTA,"",''DIQGDD_"R") ;recursion
.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)
ERROUT 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 ;p28
OUT Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQGQ 6090 printed Dec 13, 2024@02:53:40 Page 2
DIQGQ ;SFISC/DCL-DATA RETRIEVAL ; Jun 08, 2023@08:54:56
+1 ;;22.2;VA FileMan;**28**;Jan 05, 2016;Build 2
+2 ;;Per VA Directive 6402, this routine should not be modified.
+3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
+4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
+5 ;;Licensed under the terms of the Apache License, Version 2.0.
+6 ;
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 ;p28
KILL DIERR,^TMP("DIERR",$JOB)
+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 ;p28
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 ERROUT
+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 an 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 ;check that field exists ;p28
IF DIQGXDN?.N
IF '$DATA(@DIQGXDD@(DIQGXDN,0))
DO BLD^DIALOG(200,.X)
GOTO ERROUT
DOWN 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
+1 NEW DIQGMDA,DIQGMGR
+2 ;we don't want a syntax error on $O(@DIQGMGR@(DIQGMDA)) below!
Begin DoDot:3
+3 NEW I
FOR I=1:1
if '$DATA(DA(I))
QUIT
SET DIQGMDA(I+1)=DA(I)
+4 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
End DoDot:3
IF DIQGMGR=""
NEW X
SET X(1)="IENS"
DO 202
QUIT
+5 ;recursion
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
if '$DATA(DOERR)
QUIT
GOTO ERR
+6 IF DIQGXDN="*"!(DIQGXDN="**")
SET DIQGXDN=0
SET DIQGXDF=":999999999"
QUIT
+7 SET DIQGXDA=$$DA(.DA)
SET DIQGFEN=$SELECT((DIQGFE&(DIQGXDN))!(DIQGFET):$PIECE(@DIQGXDD@(DIQGXDN,0),"^"),1:DIQGXDN)
if DIQGFET
SET DIQGFEN=DIQGXDN_" "_DIQGFEN
+8 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)
ERROUT ;p28
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
OUT QUIT
