- 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 Jan 18, 2025@03:54:39 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 ;