DIQGU ;SFISC/DCL-DATA RETRIEVAL INTERNAL FUNCTIONS ;8FEB2011
;;22.2;VA FileMan;;Jan 05, 2016;Build 42
;;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.
;
DT(H) Q $$HTFM^DILIBF(H,1)
;
ROOT(DIC,DA,CP,ERR) ;
ENROOT S ERR=$G(ERR)=1
N DIQGUFN,DIQGUIEN
S DIQGUFN=$G(DIC),DIQGUIEN=$G(DA)
I DIC="" D:ERR BLD^DIALOG(200) Q ""
N RQ
S RQ=$G(CP)'["Q"
S CP=$G(CP)'[1
G:$L($G(DA),",,")>1 ERR
D:$G(DA)["," DAIEN(DA,.DA)
I $G(^DIC(DIC,0,"GL"))]"" N DIQGUX S DIQGUX=^("GL") D:ERR Q:CP DIQGUX Q $$CREF(DIQGUX)
.Q:$G(DIQGUIEN)'[","
.N X S X=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN)
.Q:X
.S (CP,DIQGUX)=""
.Q
N A,A2
I $D(DA)>9,$G(^DIC(+$$UP(DIC,.A),0,"GL"))]"" S DIC=^("GL"),A=$P($O(A("")),"-",2) I A>0,$D(DA(A))=1,'$O(DA(A)) D Q:CP DIC Q $$CREF(DIC)
.S A="" F S A=$O(A(A)) Q:A'<0 D
..I RQ S A2=$P(A(A),"^",2),DIC=DIC_DA($P(A,"-",2))_","_$$Q(A2)_"," Q
..S A2=$P(A(A),"^",2),DIC=DIC_DA($P(A,"-",2))_","""_A2_"""," Q
ERR Q:'ERR ""
S DIQGUIEN=$$IENS^DILF(.DA)
S A=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN) Q:'A ""
D BLD^DIALOG(200) Q ""
;
N9(FN,DA) Q:$G(DA)="" 0 N N9 S N9=$$ROOT($$UP(FN),"",1) Q:N9="" 0 Q:$D(@N9@($$DA(.DA),-9)) 1 Q 0
;
DA(Y) Q:$D(Y)=1 Y Q Y($O(Y(""),-1))
;
UP(Y,A) N D,N,X
S A(0)=Y F D=0:-1 Q:'$D(^DD(+A(D),0,"UP")) D Q:D=666
.S X=^("UP"),N=$G(^DD($P(X,"^"),+$O(^DD($P(X,"^"),"SB",+A(D),"")),0)) I N="" S D=666 Q ;"UP" NODE MAY BE BOGUS!
.S A(D-1)=$P(X,"^")_"^"_$P($P(N,"^",4),";")
I D=666 Q Y
Q $P(A($O(A(""))),"^")
;
CREF(X) ;
ENCREF 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) ;
ENOREF N X1,X2 S X1=$P(X,"(")_"(",X2=$$OR2($P(X,"(",2,999)) Q:X2="" X1 Q X1_X2_","
;
OR2(%) Q:%=")"!(%=",") "" Q:$L(%)=1 % S:"),"[$E(%,$L(%)) %=$E(%,1,$L(%)-1) Q %
;
RCP(%DIQGRCP) Q $$CREF($$R^DIQGU0(%DIQGRCP))
;
Q(%Z) S %Z(%Z)="",%Z=$Q(%Z("")) Q $E(%Z,4,$L(%Z)-1)
;
DY(Y) X ^DD("DD") Q Y ;*CCO/NI DATE FORMAT
;
DAIEN(IEN,DA) ;
K DA
S DA=$P(IEN,",")
N I F I=2:1 Q:$P(IEN,",",I)="" S DA(I-1)=$P(IEN,",",I)
Q
;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIOUTPUT) ;SEA/TOAD
G XTRNLX^DIDU
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDIQGU 2372 printed Dec 13, 2024@02:53:41 Page 2
DIQGU ;SFISC/DCL-DATA RETRIEVAL INTERNAL FUNCTIONS ;8FEB2011
+1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
+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 ;
DT(H) QUIT $$HTFM^DILIBF(H,1)
+1 ;
ROOT(DIC,DA,CP,ERR) ;
ENROOT SET ERR=$GET(ERR)=1
+1 NEW DIQGUFN,DIQGUIEN
+2 SET DIQGUFN=$GET(DIC)
SET DIQGUIEN=$GET(DA)
+3 IF DIC=""
if ERR
DO BLD^DIALOG(200)
QUIT ""
+4 NEW RQ
+5 SET RQ=$GET(CP)'["Q"
+6 SET CP=$GET(CP)'[1
+7 if $LENGTH($GET(DA),",,")>1
GOTO ERR
+8 if $GET(DA)[","
DO DAIEN(DA,.DA)
+9 IF $GET(^DIC(DIC,0,"GL"))]""
NEW DIQGUX
SET DIQGUX=^("GL")
if ERR
Begin DoDot:1
+10 if $GET(DIQGUIEN)'[","
QUIT
+11 NEW X
SET X=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN)
+12 if X
QUIT
+13 SET (CP,DIQGUX)=""
+14 QUIT
End DoDot:1
if CP
QUIT DIQGUX
QUIT $$CREF(DIQGUX)
+15 NEW A,A2
+16 IF $DATA(DA)>9
IF $GET(^DIC(+$$UP(DIC,.A),0,"GL"))]""
SET DIC=^("GL")
SET A=$PIECE($ORDER(A("")),"-",2)
IF A>0
IF $DATA(DA(A))=1
IF '$ORDER(DA(A))
Begin DoDot:1
+17 SET A=""
FOR
SET A=$ORDER(A(A))
if A'<0
QUIT
Begin DoDot:2
+18 IF RQ
SET A2=$PIECE(A(A),"^",2)
SET DIC=DIC_DA($PIECE(A,"-",2))_","_$$Q(A2)_","
QUIT
+19 SET A2=$PIECE(A(A),"^",2)
SET DIC=DIC_DA($PIECE(A,"-",2))_","""_A2_""","
QUIT
End DoDot:2
End DoDot:1
if CP
QUIT DIC
QUIT $$CREF(DIC)
ERR if 'ERR
QUIT ""
+1 SET DIQGUIEN=$$IENS^DILF(.DA)
+2 SET A=$$IENCHK^DIT3(DIQGUFN,DIQGUIEN)
if 'A
QUIT ""
+3 DO BLD^DIALOG(200)
QUIT ""
+4 ;
N9(FN,DA) if $GET(DA)=""
QUIT 0
NEW N9
SET N9=$$ROOT($$UP(FN),"",1)
if N9=""
QUIT 0
if $DATA(@N9@($$DA(.DA),-9))
QUIT 1
QUIT 0
+1 ;
DA(Y) if $DATA(Y)=1
QUIT Y
QUIT Y($ORDER(Y(""),-1))
+1 ;
UP(Y,A) NEW D,N,X
+1 SET A(0)=Y
FOR D=0:-1
if '$DATA(^DD(+A(D),0,"UP"))
QUIT
Begin DoDot:1
+2 ;"UP" NODE MAY BE BOGUS!
SET X=^("UP")
SET N=$GET(^DD($PIECE(X,"^"),+$ORDER(^DD($PIECE(X,"^"),"SB",+A(D),"")),0))
IF N=""
SET D=666
QUIT
+3 SET A(D-1)=$PIECE(X,"^")_"^"_$PIECE($PIECE(N,"^",4),";")
End DoDot:1
if D=666
QUIT
+4 IF D=666
QUIT Y
+5 QUIT $PIECE(A($ORDER(A(""))),"^")
+6 ;
CREF(X) ;
ENCREF 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) ;
ENOREF NEW X1,X2
SET X1=$PIECE(X,"(")_"("
SET X2=$$OR2($PIECE(X,"(",2,999))
if X2=""
QUIT X1
QUIT X1_X2_","
+1 ;
OR2(%) if %=")"!(%=",")
QUIT ""
if $LENGTH(%)=1
QUIT %
if "),"[$EXTRACT(%,$LENGTH(%))
SET %=$EXTRACT(%,1,$LENGTH(%)-1)
QUIT %
+1 ;
RCP(%DIQGRCP) QUIT $$CREF($$R^DIQGU0(%DIQGRCP))
+1 ;
Q(%Z) SET %Z(%Z)=""
SET %Z=$QUERY(%Z(""))
QUIT $EXTRACT(%Z,4,$LENGTH(%Z)-1)
+1 ;
DY(Y) ;*CCO/NI DATE FORMAT
XECUTE ^DD("DD")
QUIT Y
+1 ;
DAIEN(IEN,DA) ;
+1 KILL DA
+2 SET DA=$PIECE(IEN,",")
+3 NEW I
FOR I=2:1
if $PIECE(IEN,",",I)=""
QUIT
SET DA(I-1)=$PIECE(IEN,",",I)
+4 QUIT
+5 ;
EXTERNAL(DIFILE,DIFIELD,DIFLAGS,DINTERNL,DIOUTPUT) ;SEA/TOAD
+1 GOTO XTRNLX^DIDU
+2 ;
