- 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 Jan 18, 2025@03:47:31 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)