- DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-27 12:56 PM
- ;;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.
- ;
- S DICOMP=$G(DICOMP) N DLV,K S K=0 F DLV=0:1 G A:'$D(J(DLV+1))
- EN1 ;
- S K=0 F S DLV=K,K=$O(I(K)) G A:K="",A:$D(J(K))[0!($D(I(K\100*100))[0)
- EN ;
- S DLV=+DICOMP
- A N DICO,DPUNC,DLV0,DIM,DIMW,DG,DBOOL,DICV,V,T,DICN,DICF,DIC,DATE,DPS,M,W,DICOMPQI,D,%,%Y,DS,DZ,%DT ;Don't NEW the variable A!
- I DICOMP'["?",'$D(DIQUIET) N DIQUIET S DIQUIET=1
- K K K S K=0 I DLV F I=0:100 Q:I>DLV S K=K+1,K(K)="",K(K,1)=I
- I '$D(DQI) N DQI S DQI="Y(",DICOMPQI=1
- S I=DLV F S I=$O(J(I)),DICO(1)=DLV Q:I="" K:DLV I(I),J(I)
- S DPUNC=",'+-():[]!&\/*_=<>",DLV0=DLV\100*100,I=X,DIMW="" K X
- S DIC(0)="ZFO",(M,DPS)=0,DICO=I,DICO(1)=DLV,DICO(0)=DLV\100*100 F %=0:100 Q:'$D(J(%)) S DG(%)=%
- TOOEASY G 0:" "[I!(+I=I)!(I'?.ANP)!(I?."?")!($E(I,$L(I))=":")
- G D I I X?.NP G:X="" N:I]"",^DICOMP1 I +X=X,X<1700!'$D(DATE(K-1))!'$G(DBOOL) G N:W'=":",N:$D(DPS($$NEST,"$S"))
- G E:$L(X)>30,FUNC:W="(",N:X?1"$"1U
- V I $D(DICOMPX(X))#2 D DATE^DICOMP0:$D(DICOMPX(X,"DATE")) S T=X,X=DICOMPX(X) G N:'$D(DICOMPX(T,U)) S T=DICOMPX(T,U),DICN=$P(T,U,2),T=+T,Y(0)=^DD(T,DICN,0),D=$P(Y(0),U,2) D S^DICOMP0 G N
- E K Y D ^DICOMP0 G N:+X=X,N:$D(Y),0:$D(DICO("BACK"))-10 S X=DICO,DLV=DICO(1),DICO("BACK")=1 S:$G(DICOMPX)]"" DICOMPX="" G K
- N ;
- I X]"" S K=K+1,K(K)=X
- S I=$E(I,M,999),M=0 G G:$F(DPUNC,W)<2
- I W=":",'$D(DPS($$NEST,"$S")) S I=$E(I,2,999) D I,M^DICOMPX,M^DICOMPW:$D(X) S W="" G N:$D(X),0
- S X=W,W="",M=2 G N:X=""
- G DPS:X=")",C:",:"[X,0:"+-'"[X&'$L($E(I,M,999)) I X="(" D ST G N
- S DBOOL="><]['=!&"[X,Y="[]!&/\_><*="
- NOT I X="'" S %=$E(I,2) I "_"""[% G 0
- G N:Y'[X
- BINOP I ")"'[$E(I_W,M),$G(K(K))]"" I '$D(K(K,2)),'$F($TR(DPUNC,")'"),K(K)),$F(Y,W)<2 D:X="_" G N:K(K)'="'" S K(K)="'"_X,X="" G N:DBOOL
- CONCAT .I $D(DATE(K)) K DATE(K) S K=K+1,K(K)=" S Y=X X ^DD(""DD"") S X=Y"
- 0 G 0^DICOMP1
- ;
- I ;parse off the next element, as delimited by PUNCtuation
- I $A(I,M+1)=34 S M=$F(I,"""",M+2)-1 G I:M>0 S W=0,M=999,X=U Q
- MR F M=M+1:1 S W=$E(I,M) Q:DPUNC[W
- S X=$E(I,1,M-1) Q
- ;
- C ;we've encountered a comman or colon(:)
- I $D(DPS($$NEST,"SETDATA")) G 0
- S DICF=X D DG S K(K+1,2)=0
- I $O(DPS($$NEST,"$"))["$" S DPS($$NEST)=DPS($$NEST)_Y_DICF G N
- G 0:'$D(W($$NEST)) S (W,W($$NEST))=W($$NEST)-1 K:W<2 W($$NEST) S DPS($$NEST)=" S X"_W_"="_Y_DPS($$NEST) G N
- ;
- DPS G 0:'DPS ;WE HAVE ENCOUNTERED A ")", SO WE MUST BOUNCE UP A LEVEL. BUT IF THERE IS NO HIGHER LEVEL, IT IS AN ERROR
- I $D(DPS(DPS,"ST")) D DPS^DICOMPW S:X]"" K=K+1,K(K)=X G DPS
- I $D(DPS(DPS,"BETWEEN")) S DPS(DPS,"BOOL")=1
- DUP I $D(DPS(DPS,"DUPLICATED")) D G 0:'DPS
- .I $G(Y(0))'[U S DPS=0 Q
- .S Y=$O(^DD(J(DLV),"B",$P(Y(0),U),0)) I 'Y S DPS=0 Q
- .F T=0:0 S T=$O(^DD(J(DLV),Y,1,T)) Q:'T I +$G(^(T,0))=J(DLV0),$P(^(0),U,3,99)="" S Y=$P(^(0),U,2) I Y?1U.AN Q ;find a regular cross_refs
- .I 'T F T=0:0 S T=$O(^DD("IX","F",J(DLV),Y,T)) Q:'T I $P($G(^DD("IX",T,0)),U,4)="R",$P(^(0),U,6)="F",$P(^(0),U,9)=J(0) S Y=$P(^(0),U,2) Q ;or find a regular INDEX
- .I 'T S DPS=0 Q
- .D DIMP^DICOMPZ("N Z S Z=X,X="""" I $L(Z) S Z=$O("_I(DLV0)_""""_Y_""",Z,0)) I Z,Z-D0!$O(^(D0)) S X=1") S DPS(DPS)=X_" S X=X",DPS(DPS,"BOOL")=1
- D DPS^DICOMPW G N:'$D(W(DPS+1)),0
- ;
- FUNC ;We have encountered a "("
- S Y=+$O(^DD("FUNC","B",X,0)) I '$D(^DD("FUNC",Y,0)),X'?1N.N2A,X'?1"$"1U G V
- I Y=90!(Y=91)!(Y=92) D PRIOR^DICOMPZ G N:$D(Y),0
- S DICF=X,DBOOL=$G(DBOOL,0) D ST
- I DICF="DUPLICATED"!(DICF="YEAR")!(DICF="MONTH")!(DICF="DATE") S DPS(DPS,"INTERNAL")="" D 1 K Y G B ;SOME FUNCTIONS REQUIRE THEIR ARGUMENTS TO BE IN INTERNAL FORM
- I "Q"'[$G(^DD("FUNC",Y,1)) D 1 G B
- I DICF'?1"$"1U.U D ^DICOMPY S W="" G DPS:DPS,0
- S DPS(DPS,DICF)=DPS(DPS),DPS(DPS)=" S X="_DICF_W
- B S M=M+1,W="" G 0:$E(I,M)=")",N
- ;
- 2 ;
- D ST
- 1 ;NAKED REFERENCES IN LINE BELOW IS TO 'MUMPS CODE' IN THE FUNCTION FILE
- S DPS(DPS,DICF)="",DPS(DPS)=" "_$G(^(1))_DPS(DPS)_" S X=X"
- DV S %=$P($G(^(2)),U) I %]"" S DPS(DPS,%)="" ;'D:YES;X:NO;O:OPTIONAL' IN THE FUNCTION FILE, so there can be a DPS(DPS,"D")
- I DPS=1,$G(^(10))]"" S DPS(^(10))=""
- S %=$G(^(3),0) D:%'?.N
- .S %=1 F %Y=M+1:1 S Y=$E(I,%Y) Q:")"[Y S:Y="," %=%+1
- .S DPS(DPS)=" K X"_%_DPS(DPS)
- S:%>1 W(DPS)=% Q
- ;
- ST ;push down the stack
- N Y
- S DPS=DPS+1,%="",Y=K I $D(DBOOL) S DPS(DPS,"BOOL")=DBOOL K DBOOL
- S I 'Y S X="",DPS(DPS)=$P(" S X="_%_"X",U,%]"") Q
- I K(Y)="" S Y=Y-1 G S
- I "'"[K(Y)!(K(Y)="+"),$S(Y=1:1,1:K(Y-1)?1P!(K(Y-1)="")) S %=K(Y)_%,K=K-1,Y=Y-1 G S
- D DG S DPS(DPS)=""
- I K(K)?1P!(K(K)?2P) S DPS(DPS)=" S Y="_%_"X,X="_Y_",X=X",DPS(DPS,U)=K(K)_"Y",K=K-1
- I $D(DATE(K)) S DPS(DPS,"DATE")=1 ;REMEMBER THAT WHEN WE GOT TO THIS POINT IN THE EVALUATION, WE HAD DATE VALUE
- S K(K+1,2)=0 Q
- ;
- NEST() N I
- F I=DPS:-1 Q:'$D(DPS(I,"ST"))
- Q I
- ;
- DG S Y=$$DGI,X=" S "_Y_"=$G(X)"
- Q
- DGI() S DG(DLV0)=$G(DG(DLV0))+1 Q DQI_DG(DLV0)_")"
- ;
- ;
- EXPR(FILE,DICOMP,I,SUBS) ;I=input expression; DICOMP=flags
- S X=$G(DUZ),X(2)=$G(DUZ(2)),DICOMP=$G(DICOMP)
- N DUZ,J,DICOMPX,DICOMPW,DQI,DA,DICMX S DUZ=X,DUZ(0)="@",DUZ(2)=X(2) ;pretend he's programmer
- K X S X=I
- I DICOMP["m" S DICMX="X DICMX" ;Flag 'm' = allow returning multiple values
- S DICOMPW="",DA="X("
- S DICOMPX="",DICOMP=$TR(DICOMP,"F")_"X" ;(Why strip out "F"?) We don't allow MUMPS
- M DICOMPX=SUBS ;list of terms to substitute
- D IJ^DIUTL(FILE) S FILE=$O(I(""),-1) I FILE S DICOMP=FILE_DICOMP ;FILE may be down a level or 2
- K SUBS,FILE
- D DICOMP
- I '$D(X) Q
- S X("USED")=$G(DICOMPX)
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMP 5739 printed Jan 18, 2025@03:47:23 Page 2
- DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-27 12:56 PM
- +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 ;
- +7 SET DICOMP=$GET(DICOMP)
- NEW DLV,K
- SET K=0
- FOR DLV=0:1
- if '$DATA(J(DLV+1))
- GOTO A
- EN1 ;
- +1 SET K=0
- FOR
- SET DLV=K
- SET K=$ORDER(I(K))
- if K=""
- GOTO A
- if $DATA(J(K))[0!($DATA(I(K\100*100))[0)
- GOTO A
- EN ;
- +1 SET DLV=+DICOMP
- A ;Don't NEW the variable A!
- NEW DICO,DPUNC,DLV0,DIM,DIMW,DG,DBOOL,DICV,V,T,DICN,DICF,DIC,DATE,DPS,M,W,DICOMPQI,D,%,%Y,DS,DZ,%DT
- +1 IF DICOMP'["?"
- IF '$DATA(DIQUIET)
- NEW DIQUIET
- SET DIQUIET=1
- K KILL K
- SET K=0
- IF DLV
- FOR I=0:100
- if I>DLV
- QUIT
- SET K=K+1
- SET K(K)=""
- SET K(K,1)=I
- +1 IF '$DATA(DQI)
- NEW DQI
- SET DQI="Y("
- SET DICOMPQI=1
- +2 SET I=DLV
- FOR
- SET I=$ORDER(J(I))
- SET DICO(1)=DLV
- if I=""
- QUIT
- if DLV
- KILL I(I),J(I)
- +3 SET DPUNC=",'+-():[]!&\/*_=<>"
- SET DLV0=DLV\100*100
- SET I=X
- SET DIMW=""
- KILL X
- +4 SET DIC(0)="ZFO"
- SET (M,DPS)=0
- SET DICO=I
- SET DICO(1)=DLV
- SET DICO(0)=DLV\100*100
- FOR %=0:100
- if '$DATA(J(%))
- QUIT
- SET DG(%)=%
- TOOEASY if " "[I!(+I=I)!(I'?.ANP)!(I?."?")!($EXTRACT(I,$LENGTH(I))=":")
- GOTO 0
- G DO I
- IF X?.NP
- if X=""
- if I]""
- GOTO N
- GOTO ^DICOMP1
- IF +X=X
- IF X<1700!'$DATA(DATE(K-1))!'$GET(DBOOL)
- if W'=":"
- GOTO N
- if $DATA(DPS($$NEST,"$S"))
- GOTO N
- +1 if $LENGTH(X)>30
- GOTO E
- if W="("
- GOTO FUNC
- if X?1"$"1U
- GOTO N
- V IF $DATA(DICOMPX(X))#2
- if $DATA(DICOMPX(X,"DATE"))
- DO DATE^DICOMP0
- SET T=X
- SET X=DICOMPX(X)
- if '$DATA(DICOMPX(T,U))
- GOTO N
- SET T=DICOMPX(T,U)
- SET DICN=$PIECE(T,U,2)
- SET T=+T
- SET Y(0)=^DD(T,DICN,0)
- SET D=$PIECE(Y(0),U,2)
- DO S^DICOMP0
- GOTO N
- E KILL Y
- DO ^DICOMP0
- if +X=X
- GOTO N
- if $DATA(Y)
- GOTO N
- if $DATA(DICO("BACK"))-10
- GOTO 0
- SET X=DICO
- SET DLV=DICO(1)
- SET DICO("BACK")=1
- if $GET(DICOMPX)]""
- SET DICOMPX=""
- GOTO K
- N ;
- +1 IF X]""
- SET K=K+1
- SET K(K)=X
- +2 SET I=$EXTRACT(I,M,999)
- SET M=0
- if $FIND(DPUNC,W)<2
- GOTO G
- +3 IF W=":"
- IF '$DATA(DPS($$NEST,"$S"))
- SET I=$EXTRACT(I,2,999)
- DO I
- DO M^DICOMPX
- if $DATA(X)
- DO M^DICOMPW
- SET W=""
- if $DATA(X)
- GOTO N
- GOTO 0
- +4 SET X=W
- SET W=""
- SET M=2
- if X=""
- GOTO N
- +5 if X=")"
- GOTO DPS
- if ",:"[X
- GOTO C
- if "+-'"[X&'$LENGTH($EXTRACT(I,M,999))
- GOTO 0
- IF X="("
- DO ST
- GOTO N
- +6 SET DBOOL="><]['=!&"[X
- SET Y="[]!&/\_><*="
- NOT IF X="'"
- SET %=$EXTRACT(I,2)
- IF "_"""[%
- GOTO 0
- +1 if Y'[X
- GOTO N
- BINOP IF ")"'[$EXTRACT(I_W,M)
- IF $GET(K(K))]""
- IF '$DATA(K(K,2))
- IF '$FIND($TRANSLATE(DPUNC,")'"),K(K))
- IF $FIND(Y,W)<2
- if X="_"
- Begin DoDot:1
- CONCAT IF $DATA(DATE(K))
- KILL DATE(K)
- SET K=K+1
- SET K(K)=" S Y=X X ^DD(""DD"") S X=Y"
- End DoDot:1
- if K(K)'="'"
- GOTO N
- SET K(K)="'"_X
- SET X=""
- if DBOOL
- GOTO N
- 0 GOTO 0^DICOMP1
- +1 ;
- I ;parse off the next element, as delimited by PUNCtuation
- +1 IF $ASCII(I,M+1)=34
- SET M=$FIND(I,"""",M+2)-1
- if M>0
- GOTO I
- SET W=0
- SET M=999
- SET X=U
- QUIT
- MR FOR M=M+1:1
- SET W=$EXTRACT(I,M)
- if DPUNC[W
- QUIT
- +1 SET X=$EXTRACT(I,1,M-1)
- QUIT
- +2 ;
- C ;we've encountered a comman or colon(:)
- +1 IF $DATA(DPS($$NEST,"SETDATA"))
- GOTO 0
- +2 SET DICF=X
- DO DG
- SET K(K+1,2)=0
- +3 IF $ORDER(DPS($$NEST,"$"))["$"
- SET DPS($$NEST)=DPS($$NEST)_Y_DICF
- GOTO N
- +4 if '$DATA(W($$NEST))
- GOTO 0
- SET (W,W($$NEST))=W($$NEST)-1
- if W<2
- KILL W($$NEST)
- SET DPS($$NEST)=" S X"_W_"="_Y_DPS($$NEST)
- GOTO N
- +5 ;
- DPS ;WE HAVE ENCOUNTERED A ")", SO WE MUST BOUNCE UP A LEVEL. BUT IF THERE IS NO HIGHER LEVEL, IT IS AN ERROR
- if 'DPS
- GOTO 0
- +1 IF $DATA(DPS(DPS,"ST"))
- DO DPS^DICOMPW
- if X]""
- SET K=K+1
- SET K(K)=X
- GOTO DPS
- +2 IF $DATA(DPS(DPS,"BETWEEN"))
- SET DPS(DPS,"BOOL")=1
- DUP IF $DATA(DPS(DPS,"DUPLICATED"))
- Begin DoDot:1
- +1 IF $GET(Y(0))'[U
- SET DPS=0
- QUIT
- +2 SET Y=$ORDER(^DD(J(DLV),"B",$PIECE(Y(0),U),0))
- IF 'Y
- SET DPS=0
- QUIT
- +3 ;find a regular cross_refs
- FOR T=0:0
- SET T=$ORDER(^DD(J(DLV),Y,1,T))
- if 'T
- QUIT
- IF +$GET(^(T,0))=J(DLV0)
- IF $PIECE(^(0),U,3,99)=""
- SET Y=$PIECE(^(0),U,2)
- IF Y?1U.AN
- QUIT
- +4 ;or find a regular INDEX
- IF 'T
- FOR T=0:0
- SET T=$ORDER(^DD("IX","F",J(DLV),Y,T))
- if 'T
- QUIT
- IF $PIECE($GET(^DD("IX",T,0)),U,4)="R"
- IF $PIECE(^(0),U,6)="F"
- IF $PIECE(^(0),U,9)=J(0)
- SET Y=$PIECE(^(0),U,2)
- QUIT
- +5 IF 'T
- SET DPS=0
- QUIT
- +6 DO DIMP^DICOMPZ("N Z S Z=X,X="""" I $L(Z) S Z=$O("_I(DLV0)_""""_Y_""",Z,0)) I Z,Z-D0!$O(^(D0)) S X=1")
- SET DPS(DPS)=X_" S X=X"
- SET DPS(DPS,"BOOL")=1
- End DoDot:1
- if 'DPS
- GOTO 0
- +7 DO DPS^DICOMPW
- if '$DATA(W(DPS+1))
- GOTO N
- GOTO 0
- +8 ;
- FUNC ;We have encountered a "("
- +1 SET Y=+$ORDER(^DD("FUNC","B",X,0))
- IF '$DATA(^DD("FUNC",Y,0))
- IF X'?1N.N2A
- IF X'?1"$"1U
- GOTO V
- +2 IF Y=90!(Y=91)!(Y=92)
- DO PRIOR^DICOMPZ
- if $DATA(Y)
- GOTO N
- GOTO 0
- +3 SET DICF=X
- SET DBOOL=$GET(DBOOL,0)
- DO ST
- +4 ;SOME FUNCTIONS REQUIRE THEIR ARGUMENTS TO BE IN INTERNAL FORM
- IF DICF="DUPLICATED"!(DICF="YEAR")!(DICF="MONTH")!(DICF="DATE")
- SET DPS(DPS,"INTERNAL")=""
- DO 1
- KILL Y
- GOTO B
- +5 IF "Q"'[$GET(^DD("FUNC",Y,1))
- DO 1
- GOTO B
- +6 IF DICF'?1"$"1U.U
- DO ^DICOMPY
- SET W=""
- if DPS
- GOTO DPS
- GOTO 0
- +7 SET DPS(DPS,DICF)=DPS(DPS)
- SET DPS(DPS)=" S X="_DICF_W
- B SET M=M+1
- SET W=""
- if $EXTRACT(I,M)=")"
- GOTO 0
- GOTO N
- +1 ;
- 2 ;
- +1 DO ST
- 1 ;NAKED REFERENCES IN LINE BELOW IS TO 'MUMPS CODE' IN THE FUNCTION FILE
- +1 SET DPS(DPS,DICF)=""
- SET DPS(DPS)=" "_$GET(^(1))_DPS(DPS)_" S X=X"
- DV ;'D:YES;X:NO;O:OPTIONAL' IN THE FUNCTION FILE, so there can be a DPS(DPS,"D")
- SET %=$PIECE($GET(^(2)),U)
- IF %]""
- SET DPS(DPS,%)=""
- +1 IF DPS=1
- IF $GET(^(10))]""
- SET DPS(^(10))=""
- +2 SET %=$GET(^(3),0)
- if %'?.N
- Begin DoDot:1
- +3 SET %=1
- FOR %Y=M+1:1
- SET Y=$EXTRACT(I,%Y)
- if ")"[Y
- QUIT
- if Y=","
- SET %=%+1
- +4 SET DPS(DPS)=" K X"_%_DPS(DPS)
- End DoDot:1
- +5 if %>1
- SET W(DPS)=%
- QUIT
- +6 ;
- ST ;push down the stack
- +1 NEW Y
- +2 SET DPS=DPS+1
- SET %=""
- SET Y=K
- IF $DATA(DBOOL)
- SET DPS(DPS,"BOOL")=DBOOL
- KILL DBOOL
- S IF 'Y
- SET X=""
- SET DPS(DPS)=$PIECE(" S X="_%_"X",U,%]"")
- QUIT
- +1 IF K(Y)=""
- SET Y=Y-1
- GOTO S
- +2 IF "'"[K(Y)!(K(Y)="+")
- IF $SELECT(Y=1:1,1:K(Y-1)?1P!(K(Y-1)=""))
- SET %=K(Y)_%
- SET K=K-1
- SET Y=Y-1
- GOTO S
- +3 DO DG
- SET DPS(DPS)=""
- +4 IF K(K)?1P!(K(K)?2P)
- SET DPS(DPS)=" S Y="_%_"X,X="_Y_",X=X"
- SET DPS(DPS,U)=K(K)_"Y"
- SET K=K-1
- +5 ;REMEMBER THAT WHEN WE GOT TO THIS POINT IN THE EVALUATION, WE HAD DATE VALUE
- IF $DATA(DATE(K))
- SET DPS(DPS,"DATE")=1
- +6 SET K(K+1,2)=0
- QUIT
- +7 ;
- NEST() NEW I
- +1 FOR I=DPS:-1
- if '$DATA(DPS(I,"ST"))
- QUIT
- +2 QUIT I
- +3 ;
- DG SET Y=$$DGI
- SET X=" S "_Y_"=$G(X)"
- +1 QUIT
- DGI() SET DG(DLV0)=$GET(DG(DLV0))+1
- QUIT DQI_DG(DLV0)_")"
- +1 ;
- +2 ;
- EXPR(FILE,DICOMP,I,SUBS) ;I=input expression; DICOMP=flags
- +1 SET X=$GET(DUZ)
- SET X(2)=$GET(DUZ(2))
- SET DICOMP=$GET(DICOMP)
- +2 ;pretend he's programmer
- NEW DUZ,J,DICOMPX,DICOMPW,DQI,DA,DICMX
- SET DUZ=X
- SET DUZ(0)="@"
- SET DUZ(2)=X(2)
- +3 KILL X
- SET X=I
- +4 ;Flag 'm' = allow returning multiple values
- IF DICOMP["m"
- SET DICMX="X DICMX"
- +5 SET DICOMPW=""
- SET DA="X("
- +6 ;(Why strip out "F"?) We don't allow MUMPS
- SET DICOMPX=""
- SET DICOMP=$TRANSLATE(DICOMP,"F")_"X"
- +7 ;list of terms to substitute
- MERGE DICOMPX=SUBS
- +8 ;FILE may be down a level or 2
- DO IJ^DIUTL(FILE)
- SET FILE=$ORDER(I(""),-1)
- IF FILE
- SET DICOMP=FILE_DICOMP
- +9 KILL SUBS,FILE
- +10 DO DICOMP
- +11 IF '$DATA(X)
- QUIT
- +12 SET X("USED")=$GET(DICOMPX)
- +13 QUIT