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