- 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
