DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;10:29 AM 22 Nov 2002 [ 12/09/2003 4:30 PM ]
;;22.0;VA FileMan;**6,76,114,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
M ;
I '$D(J(0)) K X Q
S DIC("S")="I $P(^(0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""W"""
MM S DICN=X,T=DLV S:X?1"#".NP X=$E(X,2,99)
TRY S DIC="^DD("_J(T)_",",DG=$O(^DD(J(T),0,"NM",0))_" " D DICS^DICOMPY,^DIC G R:Y<0
F D=M:1:$L(I)+1 Q:$F(X,$E(I,1,D))-1-D S W=$E(I,D+1)
I DICOMP["?",$P(Y,U,2)'=DICN W !?3,"By '"_DICN_"', do you mean the '"_$P(Y,U,2)_"' Subfield" S %=1 D YN^DICN I %-1 G R:%+1 K X Q
S M=D,Y=+$P(Y(0),U,2),X=$P($P(Y(0),U,4),";") I +X'=X S X=""""_X_""""
S (DLV,D)=DLV0+100 F %=T\100*100:1 Q:%>T S J(DLV)=J(%),I(DLV)=I(%),DLV=DLV+1
S I(DLV)=X,X=I(D),J(DLV)=Y D QQ,REF S DLV0=DLV0+100 F DLV=D:1:DLV D SN
Q
;
REF F Y=D+1:1:DLV S V=Y#100-1,DICN=I(Y) S:DICN["""" DICN=""""_DICN_"""" S X=X_$S(T<DLV0:"I("_(T\100*100+V)_",0)",1:"D"_V)_","_DICN_","
Q Q
;
R I X]"",$P(X,DG,1)="",X=DICN S X=$P(X,DG,2,9) G TRY
S T=T-1 I T'<0 G TRY:$D(J(T)) F T=T-99:1 G TRY:'$D(J(T+1))
FILEQ S X=DICN,DIC=1 D DRW,^DIC I Y<0 K X Q
S X=^(0,"GL") D QQ
Y ;
S DLV0=DLV0+100,I(DLV0)=^DIC(+Y,0,"GL"),J(DLV0)=+Y F DLV=DLV+100:-1:DLV0 D SN
Q
;
SN D SV(DLV0-100) S DG(DLV0)=DLV Q
;
SV(%X) ;also called from DICOMPY
S (T,DG(%X))=DG(%X)+1,%=DLV#100,K(K+2,1)=DLV0,DG(%X,T)=%,M(%,%X+%)=T Q
;
QQ F %=0:0 S %=$F(X,"""",%) G Q:%<1 S X=$E(X,1,%-1)_$E(X,%-1,999),%=%+1
;
OKFILE(Y,DICOMP) ;Called from DIR
;DICOMP either does or doesn't contain "W"
N D,DIC,DIAC,DIFILE,%
D DRW I $D(^DIC(Y,0)) X DIC("S")
Q $T
;
DRW ;also called from DICOMPV, and DICOMPW to filter FILE names
S D=$S(DICOMP["W":"""WR""",1:"""RD""")
S DIC("S")="S DIAC="_D_",DIFILE=+Y D ^DIAC I %"
Q
;
P ;
S X=" S D0="_X_" S:'D0!'$D("_%Y_"+D0,0)) D0=-1"
I $D(DICOMPX(0)) S X=X_" S "_DICOMPX(0)_"0)=D0",DICOMPX(0,DICN)=""
D ST
I W=":" D
.S M=M+1,W="",%=$E(I,M,999) I %,+%=$P(%,")") S I=$E(I,1,M-1)_"#"_%
E S I="#.01"_$E(I,M,999),M=1,W=""
S DLV0=DLV0+100,I(DLV0)=%Y,J(DLV0)=DICN F DLV=DLV+100:-1:DLV0 D SN
Q
;
ST N X D ST^DICOMP S DPS(DPS,"ST")=1,K=K+1,K(K)=X
Q
DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;10:29 AM 22 Nov 2002 [ 12/09/2003 4:30 PM ]
+1 ;;22.0;VA FileMan;**6,76,114,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
M ;
+1 IF '$DATA(J(0))
KILL X
QUIT
+2 SET DIC("S")="I $P(^(0),U,2),$P(^DD(+$P(^(0),U,2),.01,0),U,2)'[""W"""
MM SET DICN=X
SET T=DLV
IF X?1"#".NP
SET X=$EXTRACT(X,2,99)
TRY SET DIC="^DD("_J(T)_","
SET DG=$ORDER(^DD(J(T),0,"NM",0))_" "
DO DICS^DICOMPY
DO ^DIC
IF Y<0
GOTO R
+1 FOR D=M:1:$LENGTH(I)+1
IF $FIND(X,$EXTRACT(I,1,D))-1-D
QUIT
SET W=$EXTRACT(I,D+1)
+2 IF DICOMP["?"
IF $PIECE(Y,U,2)'=DICN
WRITE !?3,"By '"_DICN_"', do you mean the '"_$PIECE(Y,U,2)_"' Subfield"
SET %=1
DO YN^DICN
IF %-1
IF %+1
GOTO R
KILL X
QUIT
+3 SET M=D
SET Y=+$PIECE(Y(0),U,2)
SET X=$PIECE($PIECE(Y(0),U,4),";")
IF +X'=X
SET X=""""_X_""""
+4 SET (DLV,D)=DLV0+100
FOR %=T\100*100:1
IF %>T
QUIT
SET J(DLV)=J(%)
SET I(DLV)=I(%)
SET DLV=DLV+1
+5 SET I(DLV)=X
SET X=I(D)
SET J(DLV)=Y
DO QQ
DO REF
SET DLV0=DLV0+100
FOR DLV=D:1:DLV
DO SN
+6 QUIT
+7 ;
REF FOR Y=D+1:1:DLV
SET V=Y#100-1
SET DICN=I(Y)
IF DICN[""""
SET DICN=""""_DICN_""""
SET X=X_$SELECT(T<DLV0:"I("_(T\100*100+V)_",0)",1:"D"_V)_","_DICN_","
Q QUIT
+1 ;
R IF X]""
IF $PIECE(X,DG,1)=""
IF X=DICN
SET X=$PIECE(X,DG,2,9)
GOTO TRY
+1 SET T=T-1
IF T'<0
IF $DATA(J(T))
GOTO TRY
FOR T=T-99:1
IF '$DATA(J(T+1))
GOTO TRY
FILEQ SET X=DICN
SET DIC=1
DO DRW
DO ^DIC
IF Y<0
KILL X
QUIT
+1 SET X=^(0,"GL")
DO QQ
Y ;
+1 SET DLV0=DLV0+100
SET I(DLV0)=^DIC(+Y,0,"GL")
SET J(DLV0)=+Y
FOR DLV=DLV+100:-1:DLV0
DO SN
+2 QUIT
+3 ;
SN DO SV(DLV0-100)
SET DG(DLV0)=DLV
QUIT
+1 ;
SV(%X) ;also called from DICOMPY
+1 SET (T,DG(%X))=DG(%X)+1
SET %=DLV#100
SET K(K+2,1)=DLV0
SET DG(%X,T)=%
SET M(%,%X+%)=T
QUIT
+2 ;
QQ FOR %=0:0
SET %=$FIND(X,"""",%)
IF %<1
GOTO Q
SET X=$EXTRACT(X,1,%-1)_$EXTRACT(X,%-1,999)
SET %=%+1
+1 ;
OKFILE(Y,DICOMP) ;Called from DIR
+1 ;DICOMP either does or doesn't contain "W"
+2 NEW D,DIC,DIAC,DIFILE,%
+3 DO DRW
IF $DATA(^DIC(Y,0))
XECUTE DIC("S")
+4 QUIT $TEST
+5 ;
DRW ;also called from DICOMPV, and DICOMPW to filter FILE names
+1 SET D=$SELECT(DICOMP["W":"""WR""",1:"""RD""")
+2 SET DIC("S")="S DIAC="_D_",DIFILE=+Y D ^DIAC I %"
+3 QUIT
+4 ;
P ;
+1 SET X=" S D0="_X_" S:'D0!'$D("_%Y_"+D0,0)) D0=-1"
+2 IF $DATA(DICOMPX(0))
SET X=X_" S "_DICOMPX(0)_"0)=D0"
SET DICOMPX(0,DICN)=""
+3 DO ST
+4 IF W=":"
Begin DoDot:1
+5 SET M=M+1
SET W=""
SET %=$EXTRACT(I,M,999)
IF %
IF +%=$PIECE(%,")")
SET I=$EXTRACT(I,1,M-1)_"#"_%
End DoDot:1
+6 IF '$TEST
SET I="#.01"_$EXTRACT(I,M,999)
SET M=1
SET W=""
+7 SET DLV0=DLV0+100
SET I(DLV0)=%Y
SET J(DLV0)=DICN
FOR DLV=DLV+100:-1:DLV0
DO SN
+8 QUIT
+9 ;
ST NEW X
DO ST^DICOMP
SET DPS(DPS,"ST")=1
SET K=K+1
SET K(K)=X
+1 QUIT
