DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-31 9:51 AM
;;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.
;
;.
;
PRIOR ;from DICOMP -- PRIOR.. Functions get archived values
N DIC,DICOMPSP,DICOMPXE,DICOPS
S X=$E(X,6,99),DICOMPSP=$E("D",X="DATE"),DICOMPXE="D "_X_"^DIAUTL(",W=$F(I,")",M) S:X="USER"&$D(^VA(200)) DICO("PT")=200,DICOMPSP="p200" I 'W!'$D(DICMX)!'$D(J(0)) K Y Q
S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999)
S DIC="^DD("_J(DLV)_",",DIC(0)="",DIC("S")="I '$P(^(0),U,2),$P(^(0),U,2)'[""C""" D DICS^DICOMPY,^DIC K DIC I Y<0 K Y Q ;Find Field that is the argument of PRIOR function
S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")"
S DICOPS="><[]=",DIMW="m"
G INSERT
;
BACKPNT ;from DICOMPV -- Backwards Pointer
N DICOPS,D
S DICOPS="><[]="
G COLON
;
MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered
N DICOXR,DICOMPXE,DICOPS S DICOPS="><][="
I DICOMPSP S X=$P(^DD(+DICOMPSP,.01,0),U,2) G WP:X["W" D S DLV=DLV+1,I(DLV)=""""_$P($P(Y(0),U,4),";")_"""",J(DLV)=+DICOMPSP D X G FOR
.I T<DLV S DLV0=DLV0+100,%=DLV0-(T\100*100) F DLV=DLV0:1 S I(DLV)=I(DLV-%),J(DLV)=J(DLV-%),DG(DLV-%,DLV0-%)=DLV#100 I DLV-%=T S K(K+1,1)=DLV0,(T,DG(DLV0))=DLV Q
S Y=+$P(DICOMPSP,"p",2),DIMW="m"_$E("w",DICOMPSP["w"),DICOMPXE=$P(Y(0),U,5,99)
I Y S (%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D X^DICOMPV(Y,.01)
INSERT N DICOMX S D=DICOMPXE,DICOMX=DICMX D CONTAINS Q:'$D(Y) I DICOMX=DICMX D
.I DICOMPSP["D" S DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX
.I DICOMPSP["p" S DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX
N F,Z,I S Z=""
S F=$F(DICMX,"X DICMX") I F D
.S Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") "
.S DICMX=$E(DICMX,1,F-6)_"DICOMPM"_$E(DICMX,F,999)
D DIMP(DICMX) S Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")"
D DIMP(D),DICOXR S Z=Z_X
D DIMP(Z) S X=X_" S X=X" Q
;
WP S DIMW="m"_$E("w",X'["L"),DICOPS="["
M S X="S X=^(0)"
FOR N DICOR,DICOT ;These lines build the code for a typical Computed Multiple
S DICOMPXE=X,DICOT=Y(0) D CONTAINS Q:'$D(Y)
S Y=T#100+1,D=$P($P(DICOT,U,4),";") I +D'=D S D=""""_D_""""
S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y
S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR
I W=")",$D(DPS(DPS,"INTERNAL")) S D="S D=$G(DIWF) N DIWF S DIWF=D_""XL"" "_D ;**DI*22*152
S %=+$P(DICOT,U,2)
I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01))
E I '$D(^DD(%,.01,1,1,0))
E I $P(^(0),U,3)]""
I S D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien
E D DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE) S D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)" ;We will go thru the multiple using the B X-ref
D DIMP($$I(Y)_D)
I DICOPS'?1P S K(K+1,2)=1 ;If it is just a multiple, it can't be followed by an operator (see BINOP^DICOMP)
S (T,DG(DLV0))=DG(DLV0)+1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T
S X=X_":D"_(Y-1)_">0"
DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR)
Q
;
CONTAINS N DICON
S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q
I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q
.S DICOXR=$$DGI^DICOMP
.D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X
.S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1
.S DBOOL=1,DIMW=""
COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q
N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y
I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W
S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple!
;
R(DICORM) N DICOLEFT,DICOX S DICOLEFT="",DICOX=0 F %=1:1 S W=$E(DICORM,%) Q:W="" S:W="(" DICOX=DICOX+1 I W=")" S DICOX=DICOX-1 I DICOX<0 S DICOLEFT=$E(DICORM,%,999),DICORM=$E(DICORM,1,%-1)
S DICOX=$G(X) D RCR(DICORM)
S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q
;
RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression.
N D
S:+W=W W=""""_W_"""" S D="ZXM"_$$DIMC_" S"_DICOMP D ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric.
.N X,DICOMP,DLV,DICMXSV,K
.S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX
DQI .S %=$G(DQI,"Y(") N DQI S DQI=%_$$DIMC_","
.D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point
.I '$D(X) K Y Q
.K W M W=X
.I Y["m" K DICMXSV
.I $D(DICMXSV) S DICMX=DICMXSV
I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE
Q
;
DIMP(D) ;
N DIM
S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01)
S X(DIM)=D,X=" X "_$$DA_DIM_")" Q
;
DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA)
;
DIMC() N DIM
S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1
Q DIM
;
X ;
S X="S X=$P(^(0),U)"_$S(X["D"&'$D(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:""),DIMW="m" Q
;
I(LEV) N S
S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q ""
Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" "
;
REF(T) ;
N L,D,X,V
F L=T\100*100:1:T S D=I(L) S X=$G(X)_D_$E(",",$D(X))_$S(L<DLV0:"I("_L_",0)",1:"D"_(L#100))_","
Q $E(X,1,$L(X)-1)
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMPZ 5582 printed Sep 23, 2025@20:22:38 Page 2
DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-31 9:51 AM
+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 ;.
+8 ;
PRIOR ;from DICOMP -- PRIOR.. Functions get archived values
+1 NEW DIC,DICOMPSP,DICOMPXE,DICOPS
+2 SET X=$EXTRACT(X,6,99)
SET DICOMPSP=$EXTRACT("D",X="DATE")
SET DICOMPXE="D "_X_"^DIAUTL("
SET W=$FIND(I,")",M)
if X="USER"&$DATA(^VA(200))
SET DICO("PT")=200
SET DICOMPSP="p200"
IF 'W!'$DATA(DICMX)!'$DATA(J(0))
KILL Y
QUIT
+3 SET X=$EXTRACT(I,M+1,W-2)
SET M=W
SET W=$EXTRACT(I,M)
if X?1"#"1.NP
SET X=$EXTRACT(X,2,999)
+4 ;Find Field that is the argument of PRIOR function
SET DIC="^DD("_J(DLV)_","
SET DIC(0)=""
SET DIC("S")="I '$P(^(0),U,2),$P(^(0),U,2)'[""C"""
DO DICS^DICOMPY
DO ^DIC
KILL DIC
IF Y<0
KILL Y
QUIT
+5 SET DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")"
+6 SET DICOPS="><[]="
SET DIMW="m"
+7 GOTO INSERT
+8 ;
BACKPNT ;from DICOMPV -- Backwards Pointer
+1 NEW DICOPS,D
+2 SET DICOPS="><[]="
+3 GOTO COLON
+4 ;
MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered
+1 NEW DICOXR,DICOMPXE,DICOPS
SET DICOPS="><][="
+2 IF DICOMPSP
SET X=$PIECE(^DD(+DICOMPSP,.01,0),U,2)
if X["W"
GOTO WP
Begin DoDot:1
+3 IF T<DLV
SET DLV0=DLV0+100
SET %=DLV0-(T\100*100)
FOR DLV=DLV0:1
SET I(DLV)=I(DLV-%)
SET J(DLV)=J(DLV-%)
SET DG(DLV-%,DLV0-%)=DLV#100
IF DLV-%=T
SET K(K+1,1)=DLV0
SET (T,DG(DLV0))=DLV
QUIT
End DoDot:1
SET DLV=DLV+1
SET I(DLV)=""""_$PIECE($PIECE(Y(0),U,4),";")_""""
SET J(DLV)=+DICOMPSP
DO X
GOTO FOR
+4 SET Y=+$PIECE(DICOMPSP,"p",2)
SET DIMW="m"_$EXTRACT("w",DICOMPSP["w")
SET DICOMPXE=$PIECE(Y(0),U,5,99)
+5 IF Y
SET (%,DLV,DLV0)=DLV0+100
SET I(%)=^DIC(Y,0,"GL")
SET J(%)=Y
DO X^DICOMPV(Y,.01)
INSERT NEW DICOMX
SET D=DICOMPXE
SET DICOMX=DICMX
DO CONTAINS
if '$DATA(Y)
QUIT
IF DICOMX=DICMX
Begin DoDot:1
+1 IF DICOMPSP["D"
SET DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX
+2 IF DICOMPSP["p"
SET DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX
End DoDot:1
+3 NEW F,Z,I
SET Z=""
+4 SET F=$FIND(DICMX,"X DICMX")
IF F
Begin DoDot:1
+5 SET Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") "
+6 SET DICMX=$EXTRACT(DICMX,1,F-6)_"DICOMPM"_$EXTRACT(DICMX,F,999)
End DoDot:1
+7 DO DIMP(DICMX)
SET Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")"
+8 DO DIMP(D)
DO DICOXR
SET Z=Z_X
+9 DO DIMP(Z)
SET X=X_" S X=X"
QUIT
+10 ;
WP SET DIMW="m"_$EXTRACT("w",X'["L")
SET DICOPS="["
M SET X="S X=^(0)"
FOR ;These lines build the code for a typical Computed Multiple
NEW DICOR,DICOT
+1 SET DICOMPXE=X
SET DICOT=Y(0)
DO CONTAINS
if '$DATA(Y)
QUIT
+2 SET Y=T#100+1
SET D=$PIECE($PIECE(DICOT,U,4),";")
IF +D'=D
SET D=""""_D_""""
+3 SET DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y
+4 SET DICOR=$$REF(T)_","_D_","
SET D="F D=0:0 S (D,D"_Y_")=$O("_DICOR
+5 ;**DI*22*152
IF W=")"
IF $DATA(DPS(DPS,"INTERNAL"))
SET D="S D=$G(DIWF) N DIWF S DIWF=D_""XL"" "_D
+6 SET %=+$PIECE(DICOT,U,2)
+7 IF $PIECE($GET(^DD(%,.01,0)),U,2)["W"!'$DATA(^DD(%,0,"IX","B",%,.01))
+8 IF '$TEST
IF '$DATA(^DD(%,.01,1,1,0))
+9 IF '$TEST
IF $PIECE(^(0),U,3)]""
+10 ;We will go thru the muliple by ien
IF $TEST
SET D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE
+11 ;We will go thru the multiple using the B X-ref
IF '$TEST
DO DIMP(D_"""B"",DICOB,D)) Q:D'>0 I $D("_DICOR_DICOMPXE)
SET D="N DICOB S DICOB="""" F S DICOB=$O("_DICOR_"""B"",DICOB)) Q:DICOB="""" "_X_" Q:'$D(D)"
+12 DO DIMP($$I(Y)_D)
+13 ;If it is just a multiple, it can't be followed by an operator (see BINOP^DICOMP)
IF DICOPS'?1P
SET K(K+1,2)=1
+14 SET (T,DG(DLV0))=DG(DLV0)+1
SET K(K+2,1)=DLV0
SET DG(DLV0,T)=Y
SET M(Y,DLV0+Y)=T
+15 SET X=X_":D"_(Y-1)_">0"
DICOXR SET X=X_" S X="_$SELECT(DIMW["m"!'$DATA(DICOXR):"""""",1:DICOXR)
+1 QUIT
+2 ;
CONTAINS NEW DICON
+1 SET DICON=W="'"
SET %=$EXTRACT(I,M+DICON)
IF %=""!(W=")")
SET Y=0
QUIT
+2 IF DICOPS[%
SET DICOPS=%
DO R($EXTRACT(I,M+DICON+1,999))
if '$DATA(Y)
QUIT
Begin DoDot:1
+3 SET DICOXR=$$DGI^DICOMP
+4 DO DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D")
SET DICMX=X
+5 SET K(K+1)=" S "_DICOXR_"="_DICON
SET K=K+1
+6 SET DBOOL=1
SET DIMW=""
End DoDot:1
QUIT
COLON IF W'=":"
if W=""
QUIT
SET DICOMPX("X")="X"
SET I="X"_$EXTRACT(I,M,999)
SET M=0
IF DICOPS="["
KILL Y
QUIT
+1 NEW DQI
DO R($EXTRACT(I,M+1,999))
if '$DATA(Y)
QUIT
IF '$DATA(DICO("RCR"))
SET DICO("RCR")=Y
+2 IF Y#100=0
SET W=$GET(J(+Y))
IF W
SET DICO("PT")=W
+3 ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple!
SET DICMX=X_" "_$GET(DICMX)
QUIT
+4 ;
R(DICORM) NEW DICOLEFT,DICOX
SET DICOLEFT=""
SET DICOX=0
FOR %=1:1
SET W=$EXTRACT(DICORM,%)
if W=""
QUIT
if W="("
SET DICOX=DICOX+1
IF W=")"
SET DICOX=DICOX-1
IF DICOX<0
SET DICOLEFT=$EXTRACT(DICORM,%,999)
SET DICORM=$EXTRACT(DICORM,1,%-1)
+1 SET DICOX=$GET(X)
DO RCR(DICORM)
+2 SET W=""
SET M=0
SET I=DICOLEFT
if '$DATA(Y)
SET I=DICORM
SET X=DICOX
QUIT
+3 ;
RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression.
+1 NEW D
+2 ;Don't allow MUMPS. Remember where to start more nodes in X array. Allow simple numeric.
if +W=W
SET W=""""_W_""""
SET D="ZXM"_$$DIMC_" S"_DICOMP
Begin DoDot:1
+3 NEW X,DICOMP,DLV,DICMXSV,K
+4 SET X=W
SET DICOMP=D
IF $DATA(DICMX)
SET DICMXSV=DICMX
DQI SET %=$GET(DQI,"Y(")
NEW DQI
SET DQI=%_$$DIMC_","
+1 ;Here is the recursion! I & J, the context, will be preserved by this entry point
DO EN1^DICOMP
+2 IF '$DATA(X)
KILL Y
QUIT
+3 KILL W
MERGE W=X
+4 IF Y["m"
KILL DICMXSV
+5 IF $DATA(DICMXSV)
SET DICMX=DICMXSV
End DoDot:1
+6 ;Remember if it's a DATE
IF $DATA(Y)
MERGE X=W
DO DIMP(X)
if Y["D"
DO DATE^DICOMP0
+7 QUIT
+8 ;
DIMP(D) ;
+1 NEW DIM
+2 SET DIM=$$DIMC
SET DIM=DIM+$SELECT(DIM<9.8:.1,1:.01)
+3 SET X(DIM)=D
SET X=" X "_$$DA_DIM_")"
QUIT
+4 ;
DA() QUIT $SELECT(DA:"^DD("_A_","_DA_",",1:DA)
+1 ;
DIMC() NEW DIM
+1 SET DIM=$ORDER(X(99),-1)
IF 'DIM
SET DIM=+$PIECE(DICOMP,"M",2)
IF 'DIM
SET DIM=9.1
+2 QUIT DIM
+3 ;
X ;
+1 SET X="S X=$P(^(0),U)"_$SELECT(X["D"&'$DATA(DPS($$NEST^DICOMP,"INTERNAL")):",Y=X X ^DD(""DD"") S X=Y",X["P":" S:$D(^"_$PIECE(^(0),U,3)_"+X,0)) X=$P(^(0),U)",X["S":",Y=$F(^DD("_+D_",.01,0),X_$C(58)) S:Y X=$P($E(^(0),Y,999),$C(59),1)",1:"")
SET DIMW="m"
QUIT
+2 ;
I(LEV) NEW S
+1 SET S=DLV0+LEV
IF DICOMP'["I"!'$DATA(I(S))
QUIT ""
+2 QUIT "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" "
+3 ;
REF(T) ;
+1 NEW L,D,X,V
+2 FOR L=T\100*100:1:T
SET D=I(L)
SET X=$GET(X)_D_$EXTRACT(",",$DATA(X))_$SELECT(L<DLV0:"I("_L_",0)",1:"D"_(L#100))_","
+3 QUIT $EXTRACT(X,1,$LENGTH(X)-1)
