| 1 | DICOMP ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;29APR2003
|
|---|
| 2 | ;;22.0;VA FileMan;**6,76,114,118**
|
|---|
| 3 | ;Per VHA Directive 10-93-142, this routine should not be modified.
|
|---|
| 4 | S DICOMP=$G(DICOMP) N DLV,K S K=0 F DLV=0:1 G A:'$D(J(DLV+1))
|
|---|
| 5 | EN1 ;
|
|---|
| 6 | 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)
|
|---|
| 7 | EN ;
|
|---|
| 8 | S DLV=+DICOMP
|
|---|
| 9 | 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!
|
|---|
| 10 | I DICOMP'["?",'$D(DIQUIET) N DIQUIET S DIQUIET=1
|
|---|
| 11 | 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
|
|---|
| 12 | I '$D(DQI) N DQI S DQI="Y(",DICOMPQI=1
|
|---|
| 13 | S I=DLV F S I=$O(J(I)),DICO(1)=DLV Q:I="" K:DLV I(I),J(I)
|
|---|
| 14 | S DPUNC=",'+-():[]!&\/*_=<>",DLV0=DLV\100*100,I=X,DIMW="" K X
|
|---|
| 15 | 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(%)=%
|
|---|
| 16 | TOOEASY G 0:" "[I!(+I=I)!(I'?.ANP)!(I?."?")!($E(I,$L(I))=":")
|
|---|
| 17 | 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"))
|
|---|
| 18 | G E:$L(X)>30,FUNC:W="(",N:X?1"$"1U
|
|---|
| 19 | 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
|
|---|
| 20 | 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
|
|---|
| 21 | N ;
|
|---|
| 22 | I X]"" S K=K+1,K(K)=X
|
|---|
| 23 | S I=$E(I,M,999),M=0 G G:$F(DPUNC,W)<2
|
|---|
| 24 | 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
|
|---|
| 25 | S X=W,W="",M=2 G N:X=""
|
|---|
| 26 | G DPS:X=")",C:",:"[X,0:"+-'"[X&'$L($E(I,M,999)) I X="(" D ST G N
|
|---|
| 27 | S DBOOL="><]['=!&"[X,Y="[]!&/\_><*="
|
|---|
| 28 | NOT I X="'" S %=$E(I,2) I "_"""[% G 0
|
|---|
| 29 | G N:Y'[X
|
|---|
| 30 | BINOP I ")"'[$E(I_W,M),$G(K(K))]"",'$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
|
|---|
| 31 | CONCAT .I $D(DATE(K)) K DATE(K) S X=" S Y=X X ^DD(""DD"") S X=Y_"
|
|---|
| 32 | 0 G 0^DICOMP1
|
|---|
| 33 | ;
|
|---|
| 34 | I 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
|
|---|
| 35 | MR F M=M+1:1 S W=$E(I,M) Q:DPUNC[W
|
|---|
| 36 | S X=$E(I,1,M-1) Q
|
|---|
| 37 | ;
|
|---|
| 38 | C I $D(DPS($$NEST,"SETDATA")) D G Q^DICOMP1:'$D(X)
|
|---|
| 39 | .N DIFILE,DIAC S DIAC="WR",DIFILE=J(DLV0) D ^DIAC
|
|---|
| 40 | .I $P($G(^DD(J(DLV0),0,"DI")),U,2)["Y"!(J(DLV0)=200&($P($G(^DIC(200,0)),U)="NEW PERSON"))!'DIAC W:DICOMP["?" " "_$$EZBLD^DIALOG(405,J(DLV0)) K X Q
|
|---|
| 41 | .S %Y=+$P(DICOMPX,U,2),%=$P($G(^DD(+DICOMPX,%Y,0)),U,2),DIAC=$G(^(9)) I %["C"!%!(%="")!(DIAC]""&(DUZ(0)'="@")&($TR(DIAC,DUZ(0))=DIAC)) N XD S XD("FILE")=J(DLV0),XD("FIELD")=%Y W:DICOMP["?" " "_$$EZBLD^DIALOG(710,.XD) K X Q
|
|---|
| 42 | .S DICF="" F %=DLV0:1:DLV S DICF="_D"_(%#100)_"_"","""_DICF
|
|---|
| 43 | .S DPS($$NEST)=" N DIFDA S DIFDA("_J(DLV0)_","_$E(DICF,2,999)_","_%Y_")=X D FILE^DIE("""",""DIFDA"") S X="""""
|
|---|
| 44 | S DICF=X D DG S K(K+1,2)=0
|
|---|
| 45 | I $O(DPS($$NEST,"$"))["$" S DPS($$NEST)=DPS($$NEST)_Y_DICF G N
|
|---|
| 46 | 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
|
|---|
| 47 | ;
|
|---|
| 48 | DPS I $D(DPS(DPS,"ST")) D DPS^DICOMPW S:X]"" K=K+1,K(K)=X G DPS
|
|---|
| 49 | I DPS D DPS^DICOMPW G N:'$D(W(DPS+1))
|
|---|
| 50 | G 0
|
|---|
| 51 | ;
|
|---|
| 52 | FUNC S Y=$O(^DD("FUNC","B",X,0)) S:Y="" Y=-1 I '$D(^DD("FUNC",Y,0)),X'?1N.N2A,X'?1"$"1U G V
|
|---|
| 53 | I Y=90!(Y=91)!(Y=92) D PRIOR^DICOMPZ G N:$D(Y),0
|
|---|
| 54 | S DICF=X,DBOOL=$G(DBOOL,0) D ST I $D(^DD("FUNC",Y,1)) D 1 G B
|
|---|
| 55 | I DICF'?1"$"1U.U D ^DICOMPY S W="" G DPS:DPS,0
|
|---|
| 56 | S DPS(DPS,DICF)=DPS(DPS),DPS(DPS)=" S X="_DICF_W
|
|---|
| 57 | B S M=M+1,W="" G 0:$E(I,M)=")",N
|
|---|
| 58 | ;
|
|---|
| 59 | 2 ;
|
|---|
| 60 | D ST
|
|---|
| 61 | 1 S DPS(DPS,DICF)="",DPS(DPS)=" "_^(1)_DPS(DPS)_" S X=X" I $D(^(2)) S %=$P(^(2),U) I %]"" S DPS(DPS,%)=""
|
|---|
| 62 | I DPS=1,$G(^(10))]"" S DPS(^(10))=""
|
|---|
| 63 | S %=$G(^(3),0) D:%'?.N
|
|---|
| 64 | .S %=1 F %Y=M+1:1 S Y=$E(I,%Y) Q:")"[Y S:Y="," %=%+1
|
|---|
| 65 | .S DPS(DPS)=" K X"_%_DPS(DPS)
|
|---|
| 66 | S:%>1 W(DPS)=% Q
|
|---|
| 67 | ;
|
|---|
| 68 | ST ;
|
|---|
| 69 | N Y
|
|---|
| 70 | S DPS=DPS+1,%="",Y=K I $D(DBOOL) S DPS(DPS,"BOOL")=DBOOL K DBOOL
|
|---|
| 71 | S I 'Y S X="",DPS(DPS)=$P(" S X="_%_"X",U,%]"") Q
|
|---|
| 72 | I K(Y)="" S Y=Y-1 G S
|
|---|
| 73 | 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
|
|---|
| 74 | 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
|
|---|
| 75 | S:$D(DATE(K)) DPS(DPS,"DATE")=1
|
|---|
| 76 | S K(K+1,2)=0 Q
|
|---|
| 77 | ;
|
|---|
| 78 | NEST() N I
|
|---|
| 79 | F I=DPS:-1 Q:'$D(DPS(I,"ST"))
|
|---|
| 80 | Q I
|
|---|
| 81 | ;
|
|---|
| 82 | DG S Y=$$DGI,X=" S "_Y_"=$G(X)"
|
|---|
| 83 | Q
|
|---|
| 84 | DGI() S DG(DLV0)=$G(DG(DLV0))+1 Q DQI_DG(DLV0)_")"
|
|---|
| 85 | ;
|
|---|
| 86 | EXPR(FILE,DICOMP,I,SUBS) ;I=input expression; DICOMP=flags
|
|---|
| 87 | S X=$G(DUZ),DICOMP=$G(DICOMP)
|
|---|
| 88 | N DUZ,J,DICOMPX,DICOMPW,DQI,DA,DICMX S DUZ=X,DUZ(0)="@" ;pretend he's programmer
|
|---|
| 89 | K X S X=I
|
|---|
| 90 | I DICOMP["m" S DICMX="X DICMX" ;Flag 'm' = allow returning multiple values
|
|---|
| 91 | S DICOMPW="",DA="X("
|
|---|
| 92 | S DICOMPX="",DICOMP=$TR(DICOMP,"F")_"X" ;(Why strip out "F"?) We don't allow MUMPS
|
|---|
| 93 | M DICOMPX=SUBS ;list of terms to substitute
|
|---|
| 94 | D IJ^DIUTL(FILE) S FILE=$O(I(""),-1) I FILE S DICOMP=FILE_DICOMP ;FILE may be down a level or 2
|
|---|
| 95 | K SUBS,FILE
|
|---|
| 96 | D DICOMP
|
|---|
| 97 | I '$D(X) Q
|
|---|
| 98 | S X("USED")=$G(DICOMPX)
|
|---|
| 99 | Q
|
|---|
