Return to DICOMPZ.m CVS log

Up to [Coherent Logic Development] / freem_fileman / USER

Restructure repository

    1: DICOMPZ	;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;5/17/93  12:33 PM
    2: 	;;21.0;VA FileMan;;Dec 28, 1994
    3: 	;Per VHA Directive 10-93-142, this routine should not be modified.
    4: 	;
    5: ARG	;
    6: 	S DPS(DPS,DICF)="",DPS(DPS)=" "_^(1)_DPS(DPS)_" S X=X" I $D(^(2)) S %=$P(^(2),U,1) I %]"" S DPS(DPS,%)=""
    7: 	I DPS=1,$D(^(10)),^(10)]"" S DPS(^(10))=""
    8: 	S %=$S($D(^(3)):^(3),1:0) G W:%?.N
    9: 	S %=1 F %Y=M+1:1 S Y=$E(I,%Y) Q:")"[Y  S:Y="," %=%+1
   10: 	S DPS(DPS)=" K X"_%_DPS(DPS)
   11: W	S:%>1 W(DPS)=% Q
   12: 	;
   13: MUL	;
   14: 	I $E(I,M,M+1)="'["!(W["[") G CNTNS
   15: 	I D S X=$P(^DD(+D,.01,0),U,2) G WP:X["W" D X G FOR
   16: 	S %=D,DIMW="m"_$E("w",%["w"),(DICN,D)=$P(Y(0),U,5,99) F Y=0:0 S Y=$F(D,"X DICMX",Y) Q:Y'>0  S D=$E(D,1,Y-8)_DICMX_$E(D,Y,999),Y=$L(DICMX)-7+Y
   17: 	I DICMX'="X DICMX",D=DICN S D=DICMX D DIM S D="S DICMX="_DA_DIM_") "_DICN
   18: 	I %["p" S Y=+$P(%,"p",2),(%,DLV,DLV0)=DLV0+100,I(%)=^DIC(Y,0,"GL"),J(%)=Y D DICOMPX^DICOMPV
   19: DIM	S DIM=DIM+.1,X(DIM)=D,X=" X "_$S(DA:"^DD("_A_","_DA_",",1:DA)_DIM_")" Q
   20: 	;
   21: X	;
   22: 	S X="S X=$P(^(0),U,1)"_$S(X["D":",Y=X D D^DIQ S X=Y",X["P":" S:$D(^"_$P(^(0),U,3)_"+X,0)) X=$P(^(0),U,1)",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
   23: 	;
   24: WP	S DIMW="m"_$E("w",X'["L")
   25: M	S X="S X=^(0)"
   26: FOR	S Y=T#100+1,D=$P($P(Y(0),U,4),";",1),X="D)) Q:D'>0  I $D(^(D,0))#2 "_X_" "_DICMX_" Q:'$D(D)  S D=D"_Y S:+D'=D D=Q_D_Q
   27: 	F T=T:-1:T\100*100 S X=$S(T<DLV0:"I("_T_",0)",1:"D"_(T#100))_","_D_","_X,D=I(T)
   28: 	S D="F D=0:0 S (D,D"_Y_")=$O("_D_X
   29: 	I DICOMP["I" S X=I(DLV0) D QQ^DICOMPX:X["""" S D="S I("_DLV0_")="""_X_""",J("_DLV0_")="_J(DLV0)_" "_D
   30: 	D DIM S X=X_":D"_(Y-1)_">0 S X="""""
   31: 	Q
   32: 	;
   33: CNTNS	K DICF S:$D(DICMX) DICF=DICMX S DPS=DPS+1,DPS(DPS)=DG(DLV0)+1,DG(DLV0)=DPS(DPS)+1,DD=W="'",DICMX="I X["_DQI_DPS(DPS)_") S "_DQI_(DPS(DPS)+1)_")="_'DD_" K D"
   34: 	D M K DICMX S:$D(DICF) DICMX=DICF
   35: 	S DIMW="",I=$E(I,M+DD+1,999),DPS(DPS)=" S "_DQI_DPS(DPS)_")=X,"_DQI_(DPS(DPS)+1)_")="_DD_X_" S X="_DQI_(DPS(DPS)+1)_")" K Y D I^DICOMP,^DICOMP0:X]""
   36: 	I $D(Y) S K=K+1,K(K)=X,X=DPS(DPS),DBOOL=1
   37: 	S DPS=DPS-1
   38: 	Q
   39: SD	;
   40: 	I +DICOMPX=200,$P(^DIC(200,0),U)="NEW PERSON" W:DICOMP["?" !?5,"CANNOT SET DATA INTO THE NEW PERSON FILE" K X Q
   41: 	I +DICOMPX=3,$P(^DIC(3,0),U)="USER" W:DICOMP["?" !?5,"CANNOT SET DATA INTO THE USER FILE" K X Q
   42: 	I $P($G(^DD(+DICOMPX,0,"DI")),U,2)["Y" W:DICOMP["?" !?5,"CANNOT SET DATA INTO A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE" K X Q
   43: 	S %=$P($P(DICO,",",$L(DICO,",")),")") I $A(%)=34,"^@"[$E(%,2) W:DICOMP["?" !?5,"CANNOT SET "_%_" INTO A FIELD" K X Q
   44: 	S DICF=I(DLV0)
   45: 	I $P(^DD(+DICOMPX,+$P(DICOMPX,U,2),0),U,2)["C" W:DICOMP["?" !?5,"CANNOT SET DATA INTO A COMPUTED FIELD" K X Q
   46: 	I $P($P(^(0),U,4),";",2),%[U W:DICOMP["?" !?5,"CANNOT SET A VALUE WHICH CONTAINS AN '^' INTO A FIELD" K X Q
   47: 	S DICF(1)=0 F %=DLV0:0 S %=$O(I(%)) Q:%'>0  S DICF=DICF_"D"_(%#10-1)_","_$E(Q,I(%)[Q)_I(%)_$E(Q,I(%)[Q)_",",DICF(1)=DICF(1)+1
   48: 	S %=" S DA=D"_DICF(1),Y=0
   49: 	I DICF(1)>0 F DICF(1)=DICF(1)-1:-1:0 S Y=Y+1,%=%_",DA("_Y_")=D"_DICF(1)
   50: 	S DICF(1)=%_",DIH="_+DICOMPX_",DIG="_+$P(DICOMPX,U,2)_",DIC="_Q_DICF_Q
   51: 	Q