DICOMPU ;GFT/GFT - META-DATA-DICTIONARY LOOKUP;24JAN2013
;;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.
;
EN(Y,J,DICOMP,DICMX) ; Main Entry Point
;Y=expression; DICOMP=parameter string; J array by reference, as set up by IJ^DIUTL, or just FILE NUMBER; DICMX defined means multiples allowed
N DATE,D,DD,DIS,DISTART,DICN,FIL,FIELD,F,FLD,DSPI,FILE,DIC,%,X,ASKED
I $D(J)=1 S D=J K J S J(0)=D
K DUOUT
S DISTART=Y K Y I $L(DISTART)>31!($D(J)<9)!($L(DISTART)<3) Q "" ;1 or 2 characters isn't enough
I '$D(DICOMP) S DICOMP="?"
D DRW^DICOMPX ;Sets up DIC("S") (see tags PTQ+2 and ACCESS+2)
S D="" F S D=$O(J(D)) Q:D="" S FILE(J(D))="" ;builds list of Files we know to start with
;Here we go, looping thru ^DDD
S DIS=DISTART
X F DICN=0:0 S DICN=$O(^DDD("C",DIS,DICN)) Q:'DICN S DIC=$G(^DDD(DICN,0)),X=$P(DIC,U,2),FIL=$P(DIC,U,3),FIELD=$P(DIC,U,4),F=$$LOOK G QX:$D(DUOUT) I F]"" S:$P(DIC,U,5) FIELD=FIELD_"="""_X_"""" G GOT
;That 5th piece would be a VALUE, like "ILLINOIS"
I $L(DISTART)>2 S DIS=$O(^DDD("C",DIS)) I DIS]"",$P(DIS,DISTART)="" G X
;Couldn't find simple field name. Let's see if it's "FILE FIELD"
S X=DISTART
F DSPI=1:1:$L(X," ")-1 S FIL=$P(X," ",1,DSPI) I FIL]"",$L(FIL)<32 S FIL=$O(^DIC("B",FIL,0)) I FIL S FIELD=$P(X," ",DSPI+1,999) I FIELD]"",$L(FIELD)<32 S FIELD=$O(^DD(FIL,"B",FIELD,0)),F=$$LOOK Q:$D(DUOUT) G GOT:F]""
QX K ^TMP("DICOMPU",$J) Q ""
;
;
LOOK() N TRY K ^TMP("DICOMPU",$J)
;In ^TMP("DICOMPU",$J,"F") we will store failure to go FORWARD
;In ^TMP("DICOMPU",$J,"B") we will store failure to go BACKWARD
I 'FIL!'FIELD Q ""
Q $$FIELD(FIL,FIELD)
;Following subroutine is called RECURSIVELY
FIELD(F,DD) ;Can we TRANSlate File F, Field DD to the context of FILE?
I '$D(^DD(F,DD,0)) Q ""
I '$D(DICMX),$P(^(0),U,2) Q "" ;Can we go to a multiple field?
I $D(TRY(F)) Q ""
I '$$ACCESS(F,DD) Q "" ; Not if they don"t have access to that File & Field
S TRY(F)="" N T M T=TRY N TRY M TRY=T K T ;Inherit everything tried
MULTIPL ;First, can we get to the context by going up from a MULTIPLE
N OUT,B,T,TRANS,L,D,I
I $D(DICMX) S T=F,TRANS="" K D D I $D(D) S TRANS=$$TOOLONG(D,TRANS) D SAVE G OUT:$G(OUT)
.F Q:'$D(^DD(T,0,"UP")) S D=T,TRANS=$O(^DD(T,0,"NM",0))_":"_TRANS,T=^DD(T,0,"UP"),D=$O(^DD(T,"SB",D,0))
.I TRANS=""!$D(TRY(T)) K D Q
.I $D(FILE(T)) S D="",OUT=1 Q
.S D=$$FIELD(T,D) I D="" K D
FORWARD ;Next, can we go FROM our context TO the found File F?
D D SAVE G OUT:$G(OUT)
.N Y,KEEP,UP,FI,FLD ;Can we go from our context to File F?
.S FI=1.9,KEEP=""
PTQ .S TRANS=KEEP,FI=$O(^DD(F,0,"PT",FI)) I 'FI Q ;Can we get to this F FILE from another?
.G PTQ:$D(TRY(FI))!$D(^TMP("DICOMPU",$J,"F",F,FI)) I FI[".",$D(^DD(FI,0,"UP")) G PTQ:'$D(DICMX)
.S FLD=0
F .S FLD=+$O(^DD(F,0,"PT",FI,FLD)) I 'FLD G PTQ ;go thru all the Pointers to File F in File FI, and take those that...
.S %=$P($G(^DD(FI,FLD,0)),U,2) I %'["P" G F ;...are regular pointers (not VARIABLE-POINTER)...
.I +$P(%,"P",2)=FI G F ;not to itself
.S TRANS=$P(^(0),U)_":" I $D(FILE(FI)) S OUT=1 Q
.S T=$$FIELD(FI,FLD) I T="" S ^TMP("DICOMPU",$J,"F",F,FI)="" G PTQ
.S KEEP=$$TOOLONG(T,TRANS) G F
BACK ;Finally, is there a Pointer FROM the found file TO our context?
;if file's .01 field is a DINUM pointer, maybe we can get to it by Backwards-pointer syntax -- "FILE NAME:"
I $P($G(^DD(F,.01,0)),U,2)["P",$P(^(0),U,5,99)["DINUM=X" S T=+$P($P(^(0),U,2),"P",2) I T-F,$D(FILE(T)),$G(^DIC(F,0))[U S TRANS=$P(^(0),U)_":" D SAVE G OUT
I $D(DICMX) F T=0:0 S T=$O(FILE(T)) Q:'T!$G(OUT) D
.N R,D,B,L,I ;Does File F eventually point to File T?
.F D=1.9:0 S D=$O(^DD(T,0,"PT",D)) Q:'D D:'$D(TRY(D))&'$D(^TMP("DICOMPU",$J,"B",F,D,T)) Q:$G(OUT)
..S B=$$TOP(D) I B>0,B-T F L=0:0 S L=$O(^DD(T,0,"PT",D,L)) Q:'L I $P($G(^DD(D,L,0)),U,2)["P" F I=0:0 S I=$O(^DD(D,L,1,I)) Q:'I I +$G(^(I,0))=B,$P(^(0),U,3,9)="" D D SAVE Q:$G(OUT)
...S TRANS=$O(^DD(B,0,"NM",0))_":" I TRANS=":" S TRANS="" Q
...I B=F S OUT=1 Q ;if we are at File F, we have succeeded
...N FILE K TRY(F) S TRY(D)="",FILE(B)="",FILE=$$RECURSE ;Otherwise, we CHANGE THE CONTEXT
...I FILE]"" S TRANS=$$TOOLONG(TRANS,FILE) Q
...S TRANS="",^TMP("DICOMPU",$J,"B",F,D,T)=""
OUT S OUT="",T=0 ;Of our possible paths, let's choose the SHORTEST
I '$D(DUOUT) F %=1:1 Q:'$D(OUT(%)) S L=$L(OUT(%),":") D
.I OUT]"" Q:T'>L I ":"_OUT(%)[":*" Q ;We don't like * fields
.S OUT=OUT(%),T=L
Q OUT
;
RECURSE() G MULTIPL
;
;
TOP(B) ;
UP I '$D(^DD(B,0)) Q -999
I $D(^(0,"UP")) S B=^("UP") G UP
Q B
;
ACCESS(A,B) I DUZ(0)="@" Q 1
N Y S Y=$$TOP(A) I '$D(^DIC(Y,0)) Q 0
X DIC("S") E Q 0
I '$D(^DD(A,B,8)) Q 1
Q $TR(DUZ(0),^(8))'=DUZ(0)
;
TOOLONG(A,B) I $L(A)+$L(B)+$L(FIELD)>($G(^DD("STRING_LIMIT"),255)-5) Q ""
Q A_B
;
SAVE I TRANS]"" D ASK I TRANS]"" D Q
.;I TRANS'[":" K OUT S OUT=1 Q
.S OUT($O(OUT(""),-1)+1)=TRANS
S OUT=$G(DUOUT) Q
;
ASK I $D(DUOUT) S TRANS="" Q ;TRANS is the return value
I DICOMP'["?"!'DD!$G(DSPI) Q ;if Field Number is zero, or input was in form of 'FILE FIELD', don't ASK
I $D(ASKED(FIL,FIELD)) S:'ASKED(FIL,FIELD) TRANS="" Q
N DIASK
W !?7 S DIASK(1)=DISTART,DIASK(3)=$P(DIC,U,2),%=$P(DIC,U),DIASK(2)=$P(%,"_",1,$L(%,"_")-1)
D BLD^DIALOG(8201,.DIASK),MSG^DIALOG("WM")
S %=1 D YN^DICN I %<0 S DUOUT=1
S ASKED(FIL,FIELD)=%=1 S:%-1 TRANS="" Q
;
GOT K ^TMP("DICOMPU",$J) Q F_"#"_FIELD ;we've GOT the expression.
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMPU 5685 printed Apr 09, 2024@21:47:50 Page 2
DICOMPU ;GFT/GFT - META-DATA-DICTIONARY LOOKUP;24JAN2013
+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 ;
EN(Y,J,DICOMP,DICMX) ; Main Entry Point
+1 ;Y=expression; DICOMP=parameter string; J array by reference, as set up by IJ^DIUTL, or just FILE NUMBER; DICMX defined means multiples allowed
+2 NEW DATE,D,DD,DIS,DISTART,DICN,FIL,FIELD,F,FLD,DSPI,FILE,DIC,%,X,ASKED
+3 IF $DATA(J)=1
SET D=J
KILL J
SET J(0)=D
+4 KILL DUOUT
+5 ;1 or 2 characters isn't enough
SET DISTART=Y
KILL Y
IF $LENGTH(DISTART)>31!($DATA(J)<9)!($LENGTH(DISTART)<3)
QUIT ""
+6 IF '$DATA(DICOMP)
SET DICOMP="?"
+7 ;Sets up DIC("S") (see tags PTQ+2 and ACCESS+2)
DO DRW^DICOMPX
+8 ;builds list of Files we know to start with
SET D=""
FOR
SET D=$ORDER(J(D))
if D=""
QUIT
SET FILE(J(D))=""
+9 ;Here we go, looping thru ^DDD
+10 SET DIS=DISTART
X FOR DICN=0:0
SET DICN=$ORDER(^DDD("C",DIS,DICN))
if 'DICN
QUIT
SET DIC=$GET(^DDD(DICN,0))
SET X=$PIECE(DIC,U,2)
SET FIL=$PIECE(DIC,U,3)
SET FIELD=$PIECE(DIC,U,4)
SET F=$$LOOK
if $DATA(DUOUT)
GOTO QX
IF F]""
if $PIECE(DIC,U,5)
SET FIELD=FIELD_"="""_X_""""
GOTO GOT
+1 ;That 5th piece would be a VALUE, like "ILLINOIS"
+2 IF $LENGTH(DISTART)>2
SET DIS=$ORDER(^DDD("C",DIS))
IF DIS]""
IF $PIECE(DIS,DISTART)=""
GOTO X
+3 ;Couldn't find simple field name. Let's see if it's "FILE FIELD"
+4 SET X=DISTART
+5 FOR DSPI=1:1:$LENGTH(X," ")-1
SET FIL=$PIECE(X," ",1,DSPI)
IF FIL]""
IF $LENGTH(FIL)<32
SET FIL=$ORDER(^DIC("B",FIL,0))
IF FIL
SET FIELD=$PIECE(X," ",DSPI+1,999)
IF FIELD]""
IF $LENGTH(FIELD)<32
SET FIELD=$ORDER(^DD(FIL,"B",FIELD,0))
SET F=$$LOOK
if $DATA(DUOUT)
QUIT
if F]""
GOTO GOT
QX KILL ^TMP("DICOMPU",$JOB)
QUIT ""
+1 ;
+2 ;
LOOK() NEW TRY
KILL ^TMP("DICOMPU",$JOB)
+1 ;In ^TMP("DICOMPU",$J,"F") we will store failure to go FORWARD
+2 ;In ^TMP("DICOMPU",$J,"B") we will store failure to go BACKWARD
+3 IF 'FIL!'FIELD
QUIT ""
+4 QUIT $$FIELD(FIL,FIELD)
+5 ;Following subroutine is called RECURSIVELY
FIELD(F,DD) ;Can we TRANSlate File F, Field DD to the context of FILE?
+1 IF '$DATA(^DD(F,DD,0))
QUIT ""
+2 ;Can we go to a multiple field?
IF '$DATA(DICMX)
IF $PIECE(^(0),U,2)
QUIT ""
+3 IF $DATA(TRY(F))
QUIT ""
+4 ; Not if they don"t have access to that File & Field
IF '$$ACCESS(F,DD)
QUIT ""
+5 ;Inherit everything tried
SET TRY(F)=""
NEW T
MERGE T=TRY
NEW TRY
MERGE TRY=T
KILL T
MULTIPL ;First, can we get to the context by going up from a MULTIPLE
+1 NEW OUT,B,T,TRANS,L,D,I
+2 IF $DATA(DICMX)
SET T=F
SET TRANS=""
KILL D
Begin DoDot:1
+3 FOR
if '$DATA(^DD(T,0,"UP"))
QUIT
SET D=T
SET TRANS=$ORDER(^DD(T,0,"NM",0))_":"_TRANS
SET T=^DD(T,0,"UP")
SET D=$ORDER(^DD(T,"SB",D,0))
+4 IF TRANS=""!$DATA(TRY(T))
KILL D
QUIT
+5 IF $DATA(FILE(T))
SET D=""
SET OUT=1
QUIT
+6 SET D=$$FIELD(T,D)
IF D=""
KILL D
End DoDot:1
IF $DATA(D)
SET TRANS=$$TOOLONG(D,TRANS)
DO SAVE
if $GET(OUT)
GOTO OUT
FORWARD ;Next, can we go FROM our context TO the found File F?
+1 Begin DoDot:1
+2 ;Can we go from our context to File F?
NEW Y,KEEP,UP,FI,FLD
+3 SET FI=1.9
SET KEEP=""
PTQ ;Can we get to this F FILE from another?
SET TRANS=KEEP
SET FI=$ORDER(^DD(F,0,"PT",FI))
IF 'FI
QUIT
+1 if $DATA(TRY(FI))!$DATA(^TMP("DICOMPU",$JOB,"F",F,FI))
GOTO PTQ
IF FI["."
IF $DATA(^DD(FI,0,"UP"))
if '$DATA(DICMX)
GOTO PTQ
+2 SET FLD=0
F ;go thru all the Pointers to File F in File FI, and take those that...
SET FLD=+$ORDER(^DD(F,0,"PT",FI,FLD))
IF 'FLD
GOTO PTQ
+1 ;...are regular pointers (not VARIABLE-POINTER)...
SET %=$PIECE($GET(^DD(FI,FLD,0)),U,2)
IF %'["P"
GOTO F
+2 ;not to itself
IF +$PIECE(%,"P",2)=FI
GOTO F
+3 SET TRANS=$PIECE(^(0),U)_":"
IF $DATA(FILE(FI))
SET OUT=1
QUIT
+4 SET T=$$FIELD(FI,FLD)
IF T=""
SET ^TMP("DICOMPU",$JOB,"F",F,FI)=""
GOTO PTQ
+5 SET KEEP=$$TOOLONG(T,TRANS)
GOTO F
End DoDot:1
DO SAVE
if $GET(OUT)
GOTO OUT
BACK ;Finally, is there a Pointer FROM the found file TO our context?
+1 ;if file's .01 field is a DINUM pointer, maybe we can get to it by Backwards-pointer syntax -- "FILE NAME:"
+2 IF $PIECE($GET(^DD(F,.01,0)),U,2)["P"
IF $PIECE(^(0),U,5,99)["DINUM=X"
SET T=+$PIECE($PIECE(^(0),U,2),"P",2)
IF T-F
IF $DATA(FILE(T))
IF $GET(^DIC(F,0))[U
SET TRANS=$PIECE(^(0),U)_":"
DO SAVE
GOTO OUT
+3 IF $DATA(DICMX)
FOR T=0:0
SET T=$ORDER(FILE(T))
if 'T!$GET(OUT)
QUIT
Begin DoDot:1
+4 ;Does File F eventually point to File T?
NEW R,D,B,L,I
+5 FOR D=1.9:0
SET D=$ORDER(^DD(T,0,"PT",D))
if 'D
QUIT
if '$DATA(TRY(D))&'$DATA(^TMP("DICOMPU",$JOB,"B",F,D,T))
Begin DoDot:2
+6 SET B=$$TOP(D)
IF B>0
IF B-T
FOR L=0:0
SET L=$ORDER(^DD(T,0,"PT",D,L))
if 'L
QUIT
IF $PIECE($GET(^DD(D,L,0)),U,2)["P"
FOR I=0:0
SET I=$ORDER(^DD(D,L,1,I))
if 'I
QUIT
IF +$GET(^(I,0))=B
IF $PIECE(^(0),U,3,9)=""
Begin DoDot:3
+7 SET TRANS=$ORDER(^DD(B,0,"NM",0))_":"
IF TRANS=":"
SET TRANS=""
QUIT
+8 ;if we are at File F, we have succeeded
IF B=F
SET OUT=1
QUIT
+9 ;Otherwise, we CHANGE THE CONTEXT
NEW FILE
KILL TRY(F)
SET TRY(D)=""
SET FILE(B)=""
SET FILE=$$RECURSE
+10 IF FILE]""
SET TRANS=$$TOOLONG(TRANS,FILE)
QUIT
+11 SET TRANS=""
SET ^TMP("DICOMPU",$JOB,"B",F,D,T)=""
End DoDot:3
DO SAVE
if $GET(OUT)
QUIT
End DoDot:2
if $GET(OUT)
QUIT
End DoDot:1
OUT ;Of our possible paths, let's choose the SHORTEST
SET OUT=""
SET T=0
+1 IF '$DATA(DUOUT)
FOR %=1:1
if '$DATA(OUT(%))
QUIT
SET L=$LENGTH(OUT(%),":")
Begin DoDot:1
+2 ;We don't like * fields
IF OUT]""
if T'>L
QUIT
IF ":"_OUT(%)[":*"
QUIT
+3 SET OUT=OUT(%)
SET T=L
End DoDot:1
+4 QUIT OUT
+5 ;
RECURSE() GOTO MULTIPL
+1 ;
+2 ;
TOP(B) ;
UP IF '$DATA(^DD(B,0))
QUIT -999
+1 IF $DATA(^(0,"UP"))
SET B=^("UP")
GOTO UP
+2 QUIT B
+3 ;
ACCESS(A,B) IF DUZ(0)="@"
QUIT 1
+1 NEW Y
SET Y=$$TOP(A)
IF '$DATA(^DIC(Y,0))
QUIT 0
+2 XECUTE DIC("S")
IF '$TEST
QUIT 0
+3 IF '$DATA(^DD(A,B,8))
QUIT 1
+4 QUIT $TRANSLATE(DUZ(0),^(8))'=DUZ(0)
+5 ;
TOOLONG(A,B) IF $LENGTH(A)+$LENGTH(B)+$LENGTH(FIELD)>($GET(^DD("STRING_LIMIT"),255)-5)
QUIT ""
+1 QUIT A_B
+2 ;
SAVE IF TRANS]""
DO ASK
IF TRANS]""
Begin DoDot:1
+1 ;I TRANS'[":" K OUT S OUT=1 Q
+2 SET OUT($ORDER(OUT(""),-1)+1)=TRANS
End DoDot:1
QUIT
+3 SET OUT=$GET(DUOUT)
QUIT
+4 ;
ASK ;TRANS is the return value
IF $DATA(DUOUT)
SET TRANS=""
QUIT
+1 ;if Field Number is zero, or input was in form of 'FILE FIELD', don't ASK
IF DICOMP'["?"!'DD!$GET(DSPI)
QUIT
+2 IF $DATA(ASKED(FIL,FIELD))
if 'ASKED(FIL,FIELD)
SET TRANS=""
QUIT
+3 NEW DIASK
+4 WRITE !?7
SET DIASK(1)=DISTART
SET DIASK(3)=$PIECE(DIC,U,2)
SET %=$PIECE(DIC,U)
SET DIASK(2)=$PIECE(%,"_",1,$LENGTH(%,"_")-1)
+5 DO BLD^DIALOG(8201,.DIASK)
DO MSG^DIALOG("WM")
+6 SET %=1
DO YN^DICN
IF %<0
SET DUOUT=1
+7 SET ASKED(FIL,FIELD)=%=1
if %-1
SET TRANS=""
QUIT
+8 ;
GOT ;we've GOT the expression.
KILL ^TMP("DICOMPU",$JOB)
QUIT F_"#"_FIELD
