- Timestamp:
- Dec 4, 2009, 12:11:15 AM (14 years ago)
- File:
-
- 1 edited
Legend:
- Unmodified
- Added
- Removed
-
WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMPZ.m
r613 r623 1 DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;9APR2007 2 ;;22.0;VA FileMan;**6,76,114,152**;Mar 30, 1999;Build 10 3 ;Per VHA Directive 2004-038, this routine should not be modified. 4 ; 5 PRIOR ;from DICOMP -- PRIOR.. Functions get archived values 6 N DIC,DICOMPSP,DICOMPXE,DICOPS 7 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 8 S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999) 9 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 10 S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")" 11 S DICOPS="><[]=",DIMW="m" 12 G INSERT 13 ; 14 BACKPNT ;from DICOMPV -- Backwards Pointer 15 N DICOPS,D 16 S DICOPS="><[]=" 17 G COLON 18 ; 19 MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered 20 N DICOXR,DICOMPXE,DICOPS S DICOPS="><][=" 21 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 22 .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 23 S Y=+$P(DICOMPSP,"p",2),DIMW="m"_$E("w",DICOMPSP["w"),DICOMPXE=$P(Y(0),U,5,99) 24 I Y S (%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D X^DICOMPV(Y,.01) 25 INSERT N DICOMX S D=DICOMPXE,DICOMX=DICMX D CONTAINS Q:'$D(Y) I DICOMX=DICMX D 26 .I DICOMPSP["D" S DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX 27 .I DICOMPSP["p" S DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX 28 N F,Z,I S Z="" 29 S F=$F(DICMX,"X DICMX") I F D 30 .S Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") " 31 .S DICMX=$E(DICMX,1,F-6)_"DICOMPM"_$E(DICMX,F,999) 32 D DIMP(DICMX) S Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")" 33 D DIMP(D),DICOXR S Z=Z_X 34 D DIMP(Z) S X=X_" S X=X" Q 35 ; 36 WP S DIMW="m"_$E("w",X'["L"),DICOPS="[" 37 M S X="S X=^(0)" 38 FOR N DICOR,DICOT 39 S DICOMPXE=X,DICOT=Y(0) D CONTAINS Q:'$D(Y) 40 S Y=T#100+1,D=$P($P(DICOT,U,4),";") I +D'=D S D=""""_D_"""" 41 S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y 42 S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR 43 I W=")",$D(DPS(DPS,"INTERNAL")) S D="S D=$G(DIWF) N DIWF S DIWF=D_""XL"" "_D ;**DI*22*152 44 S %=+$P(DICOT,U,2) 45 I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01)) 46 E I '$D(^DD(%,.01,1,1,0)) 47 E I $P(^(0),U,3)]"" 48 I S D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien 49 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 50 D DIMP($$I(Y)_D) 51 S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T 52 S X=X_":D"_(Y-1)_">0" 53 DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) 54 Q 55 ; 56 CONTAINS N DICON 57 S DICON=W="'",%=$E(I,M+DICON) I %=""!(W=")") S Y=0 Q 58 I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q 59 .S DICOXR=$$DGI^DICOMP 60 .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X 61 .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 62 .S DBOOL=1,DIMW="" 63 COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q 64 N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y 65 I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W 66 S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! 67 ; 68 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) 69 S DICOX=$G(X) D RCR(DICORM) 70 S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q 71 ; 72 RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. 73 N D 74 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. 75 .N X,DICOMP,DLV,DICMXSV,K 76 .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX 77 DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," 78 .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point 79 .I '$D(X) K Y Q 80 .K W M W=X 81 .I Y["m" K DICMXSV 82 .I $D(DICMXSV) S DICMX=DICMXSV 83 I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE 84 Q 85 ; 86 DIMP(D) ; 87 N DIM 88 S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) 89 S X(DIM)=D,X=" X "_$$DA_DIM_")" Q 90 ; 91 DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) 92 ; 93 DIMC() N DIM 94 S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 95 Q DIM 96 ; 97 X ; 98 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 99 ; 100 I(LEV) N S 101 S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" 102 Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " 103 ; 104 REF(T) ; 105 N L,D,X,V 106 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))_"," 107 Q $E(X,1,$L(X)-1) 1 DICOMPZ ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;05:07 PM 16 Jan 2003 2 ;;22.0;VA FileMan;**6,76,114**;Mar 30, 1999 3 ;Per VHA Directive 10-93-142, this routine should not be modified. 4 ; 5 PRIOR ;from DICOMP -- PRIOR.. Functions get archived values 6 N DIC,DICOMPSP,DICOMPXE,DICOPS 7 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 8 S X=$E(I,M+1,W-2),M=W,W=$E(I,M) S:X?1"#"1.NP X=$E(X,2,999) 9 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 10 S DICOMPXE=DICOMPXE_+J(DLV)_","_+Y_")" 11 S DICOPS="><[]=",DIMW="m" 12 G INSERT 13 ; 14 BACKPNT ;from DICOMPV -- Backwards Pointer 15 N DICOPS,D 16 S DICOPS="><[]=" 17 G COLON 18 ; 19 MUL(DICOMPSP) ;DICOMPSP is the SPECIFIER of the Field we have encountered 20 N DICOXR,DICOMPXE,DICOPS S DICOPS="><][=" 21 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 22 .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 23 S Y=+$P(DICOMPSP,"p",2),DIMW="m"_$E("w",DICOMPSP["w"),DICOMPXE=$P(Y(0),U,5,99) 24 I Y S (%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D X^DICOMPV(Y,.01) 25 INSERT N DICOMX S D=DICOMPXE,DICOMX=DICMX D CONTAINS Q:'$D(Y) I DICOMX=DICMX D 26 .I DICOMPSP["D" S DICMX="S Y=X X ^DD(""DD"") S X=Y "_DICMX 27 .I DICOMPSP["p" S DICMX="S X=$$CP^DIQ1("""_DICOMPSP_""",X) "_DICMX 28 N F,Z,I S Z="" 29 S F=$F(DICMX,"X DICMX") I F D 30 .S Z="N DICOMPM S DICOMPM=$G(DICMX,""Q"") " 31 .S DICMX=$E(DICMX,1,F-6)_"DICOMPM"_$E(DICMX,F,999) 32 D DIMP(DICMX) S Z=Z_"N DICMX S DICMX="_$$DA_$$DIMC_")" 33 D DIMP(D),DICOXR S Z=Z_X 34 D DIMP(Z) S X=X_" S X=X" Q 35 ; 36 WP S DIMW="m"_$E("w",X'["L"),DICOPS="[" 37 M S X="S X=^(0)" 38 FOR N DICOR,DICOT 39 S DICOMPXE=X,DICOT=Y(0) D CONTAINS Q:'$D(Y) 40 S Y=T#100+1,D=$P($P(DICOT,U,4),";") I +D'=D S D=""""_D_"""" 41 S DICOMPXE="D,0))#2 "_DICOMPXE_" "_DICMX_" Q:'$D(D) S D=D"_Y 42 S DICOR=$$REF(T)_","_D_",",D="F D=0:0 S (D,D"_Y_")=$O("_DICOR 43 S %=+$P(DICOT,U,2) 44 I $P($G(^DD(%,.01,0)),U,2)["W"!'$D(^DD(%,0,"IX","B",%,.01)) 45 E I '$D(^DD(%,.01,1,1,0)) 46 E I $P(^(0),U,3)]"" 47 I S D=D_"D)) Q:D'>0 I $D(^("_DICOMPXE ;We will go thru the muliple by ien 48 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 49 D DIMP($$I(Y)_D) 50 S (T,DG(DLV0))=DG(DLV0)+1,K(K+1,2)=1,K(K+2,1)=DLV0,DG(DLV0,T)=Y,M(Y,DLV0+Y)=T 51 S X=X_":D"_(Y-1)_">0" 52 DICOXR S X=X_" S X="_$S(DIMW["m"!'$D(DICOXR):"""""",1:DICOXR) 53 Q 54 ; 55 CONTAINS N DICON 56 S DICON=W="'",%=$E(I,M+DICON) I %="" S Y=0 Q 57 I DICOPS[% S DICOPS=% D R($E(I,M+DICON+1,999)) Q:'$D(Y) D Q 58 .S DICOXR=$$DGI^DICOMP 59 .D DIMP("S Y=X "_X_" I Y"_DICOPS_"X S "_DICOXR_"="_'DICON_" K D") S DICMX=X 60 .S K(K+1)=" S "_DICOXR_"="_DICON,K=K+1 61 .S DBOOL=1,DIMW="" 62 COLON I W'=":" Q:W="" S DICOMPX("X")="X",I="X"_$E(I,M,999),M=0 I DICOPS="[" K Y Q 63 N DQI D R($E(I,M+1,999)) Q:'$D(Y) I '$D(DICO("RCR")) S DICO("RCR")=Y 64 I Y#100=0 S W=$G(J(+Y)) I W S DICO("PT")=W 65 S DICMX=X_" "_$G(DICMX) Q ;The 'X" code that we got back from RCR becomes what we eXecute for every multiple! 66 ; 67 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) 68 S DICOX=$G(X) D RCR(DICORM) 69 S W="",M=0,I=DICOLEFT S:'$D(Y) I=DICORM,X=DICOX Q 70 ; 71 RCR(W) ;Tricky and important! What we get from this recursion will be inserted into the larger expression. 72 N D 73 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. 74 .N X,DICOMP,DLV,DICMXSV,K 75 .S X=W,DICOMP=D I $D(DICMX) S DICMXSV=DICMX 76 DQI .I $D(DQI) S %=DQI N DQI S DQI=%_$$DIMC_"," 77 .D EN1^DICOMP ;Here is the recursion! I & J, the context, will be preserved by this entry point 78 .I '$D(X) K Y Q 79 .K W M W=X 80 .I Y["m" K DICMXSV 81 .I $D(DICMXSV) S DICMX=DICMXSV 82 I $D(Y) M X=W D DIMP(X),DATE^DICOMP0:Y["D" ;Remember if it's a DATE 83 Q 84 ; 85 DIMP(D) ; 86 N DIM 87 S DIM=$$DIMC,DIM=DIM+$S(DIM<9.8:.1,1:.01) 88 S X(DIM)=D,X=" X "_$$DA_DIM_")" Q 89 ; 90 DA() Q $S(DA:"^DD("_A_","_DA_",",1:DA) 91 ; 92 DIMC() N DIM 93 S DIM=$O(X(99),-1) I 'DIM S DIM=+$P(DICOMP,"M",2) I 'DIM S DIM=9.1 94 Q DIM 95 ; 96 X ; 97 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 98 ; 99 I(LEV) N S 100 S S=DLV0+LEV I DICOMP'["I"!'$D(I(S)) Q "" 101 Q "S I("_S_")="""_$$CONVQQ^DILIBF(I(S))_""",J("_S_")="_J(S)_" " 102 ; 103 REF(T) ; 104 N L,D,X,V 105 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))_"," 106 Q $E(X,1,$L(X)-1)
Note:
See TracChangeset
for help on using the changeset viewer.
