- 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 Feb 19, 2025@00:12:42 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