source: WorldVistAEHR/trunk/r/VA_FILEMAN-ARJT-DI-DD-DM-DT-%DT-%RCR/DICOMP1.m@ 619

DICOMP1 ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;19JUNE2007
        ;;22.0;VA FileMan;**6,44,76,152**;Mar 30, 1999;Build 10
        ;Per VHA Directive 2004-038, this routine should not be modified.
        F  Q:'$D(DPS(DPS,"ST"))  D DPS^DICOMPW S K=K+1,K(K)=X
        G 0:DPS
INIT    S T=99,DLV0=0,X="",K=1 D ST ;ST will build code to get top=level values
NN      I $D(K(K,1)) S DLV0=K(K,1) K K(K,1) D ST ;'1' flags a change in levels
        I $D(K(K,9)) F %=1:1:K K DATE(%)
        G S:$D(K(K))[0,K1:K(K)=""
        I " "[$E(K(K)) D
        .Q:X=""
        .I K(K)?1" S ".E D  Q
AS      ..D EX I $L(K(K))+$L(X)>160 D M Q
        ..S K(K)=$E(K(K),4,999),X=X_","
        .D EX:W,M:$L(X)+$L(K(K))>180
        E  I 'W D M:$L(X)+$L(K(K))>165 S X=X_" S X=",W=6
        D:K(K)?1P
P       .I "\/"[K(K),$G(K(K+1))'?.NP S K=K+1,K(K)=",X=$S("_K(K)_":X"_K(K-1)_K(K)_",1:""*******"")"
        .I $L(X)>150,$F(DPUNC,K(K))>3 D M,SX
        G A:'$D(DATE(K))
DATE    I $G(K(K-1))="_",X?.E1"_" S X=$E(X,1,$L(X)-1) D EXTRASB S Y=$$DGI^DICOMP,X=X_" S "_Y_"=X,X="_K(K)_" S Y=X X ^DD(""DD"") S X="_Y_"_Y",K(K)="" G A
        S Y=1 I $G(K(K-1))="+" S X=X_"0,X2=X,X1="_K(K) G DTC
2       G A:$D(K(K+2))[0
        K DATE(K)
        I $D(DATE(K+2))[0,$F("+-",K(K+1))>1 S X=X_K(K)_",X1=X,X2="_K(K+1)_K(K+2),DATE(K+2)=1
        E  G A:K(K+1)'="-" K DATE(K+2) S X=X_K(K)_",X1=X,X2="_K(K+2),Y=0
        S K=K+2
DTC     S K=K+1,X=X_",X="""" D"_$P(":X2 ^ C",U,Y+1)_"^%DTC:X1" G S:'$D(K(K)) D SX G NN:'Y S K=K-1,K(K)="" G 2
        ;
A       S W='$D(K(K,2)),X=X_K(K)
K1      S K=K+1 G NN:$D(K(K))#2
S       S I="" F  S I=$O(M(I)),W=0 Q:I=""  D M:$L(X)>235 S K=$O(M(I,"")),X=X_" S D"_I_"="_$S(DA:DQI_(K+80),1:"I("_K_",0")_")"
        S I=-1 D SS S:X?.E1" S X=X" X=$E(X,1,$L(X)-6) I X'?1"S X="1N.NP!(DICOMP["Z") G Q
0       ;NO GOT!  Come here when parsing fails
        K X,DIM,DATE I DUZ(0)="@",DICOMP'["X" D
        .Q:DICO'[" "
        .S DIM=1 I $L(DICO," ")=2 F Y="OPEN","CLOSE","BREAK","USE" D  I '$D(DIM) Q
        ..I $E(Y)=$P(DICO," ")!(Y=$P(DICO," ")) K DIM
        .I $D(DIM) S X=DICO D ^DIM
        S DICOMP="",DLV=DICO(1)
Q       I DICOMP'["S" S K=DICO(1) F  S K=$O(I(K)) Q:K=""  K I(K),J(K)
        I $D(X) S:$D(DICO("DIERR")) X="N DIERR "_X I $G(DICOMPQI) S X="N Y "_X
Y       K Y I $D(DICO("RCR")) S Y=DICO("RCR")
        E  S Y=DLV_$E("W",$D(DPS("W")))_$S($G(DBOOL)=1:"B",$D(DATE)>9:"D",1:"")_$E("X",$D(DIM))_$E("L",$D(DICO(2)))
        S Y=Y_DIMW
        I $D(DICO("PT")) S Y=Y_"p"_DICO("PT")
        K K,DLV,DICOMP,DICMX Q
        ;
ST      S W=0,DG="" F  S DG=$O(DG(DLV0,DG)),Y=$P(DG,U,2) Q:DG=""  D
        .I Y]"" S:+Y'=Y Y=""""_Y_"""" S I=DQI_DG(DLV0,DG)_")=$S($D(^(" D:T-DG!(DG<DLV0)  S I=I_Y_")):^("_Y_"),1:"""")" G VP
        ..N T,QI,%
X       ..S I=$P(I,U),%=DG\100*100
        ..F T=0:1:DG#100 S QI=I(%) S I=I_QI_$E(",",1,T)_$S(DICOMP["T"&(DG<DICO(0)):"I("_%_",0)",1:"D"_T)_",",%=%+1
        ..K DG(DLV0,DG)
        ..;do not change above code to use "$G" until you change E2+4^DIP0 !
C       .F  S %=$O(DG(DLV0,DG,0)) Q:'%  D  K DG(DLV0,DG,%) ;for Computed Fields
        ..S I=" X ""N I,Y ""_$P(^DD("_J(DG)_","_%_",0),U,5,99)"
        ..I DICOMP["T",DG<DICO(0) D
        ...N W,SV S SV=X,X="N D0 S D0=I("_DG_",0)"_I D EXTRASB S I=X,X=SV
        ..S I=I_" S "_DQI_DG(DLV0,DG,%)_")=X"
        ..D EX:W,M:$L(X)+$L(I)>180 S X=X_I
        .Q:$D(DG(DLV0,DG))[0
        .S I=DG(DLV0,DG) I I?.N S I=$S(DA:DQI_(DLV0+I+80),1:"I("_(DLV0+I)_",0")_")=$G(D"_I_")"
        .E  S I=DQI_+DG_")="_I
        .K DG(DLV0,DG) G OV:DG?.N1A
VP      .I $G(DICV)["V" S I=I_"_$C(59)_"""_$E(I(0),2,99)_""""
OV      .I $L(I)+$L(X)>180 D M
        .S:'W X=X_" S " S X=X_I_",",W=2
        D EX S W=0 Q
        ;
M       D SS,EX
EXTRASB D DIMP^DICOMPZ(X) S W=0 Q
        ;
SS      Q:$A(X)-32  S X=$E(X,2,999) G SS
        ;
EX      S X=$E(X,1,$L(X)-W+1) Q
        ;
SX      S X=X_" S X=X",W=1
        Q