- DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-26 9:30 AM
- ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- ;;Per VA Directive 6402, this routine should not be modified.
- ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- ;;Licensed under the terms of the Apache License, Version 2.0.
- ;
- M ;From DICOMP
- S DICOMPXM=M
- F D F Q:$D(X) D Q:'$D(X) ;Try as long a file name as possible
- .I M<$L(I) F M=M+1:1 S W=$E(I,M) I DPUNC[W S X=$E(I,1,M-1) Q
- S:'$D(X) M=DICOMPXM K DICOMPXM
- Q
- ;
- F 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=$$CONVQQ^DILIBF(I(D)),J(DLV)=Y D S DLV0=DLV0+100 F DLV=D:1:DLV D SN
- REF .F Y=D+1:1:DLV S V=Y#100-1,DICN=$$CONVQQ^DILIBF(I(Y)),X=X_$S(T<DLV0:"I("_(T\100*100+V)_",0)",1:"D"_V)_","_DICN_","
- Q Q
- ;
- R I X]"",$P(X,DG)="",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 S X=$$CONVQQ^DILIBF(^(0,"GL")) G Y
- K X Q
- ;
- 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
- ;
- ;
- OKFILE(Y,DICOMP) ;Called from DICATT6 Block, DICATT3, DICOMP0 to see if we can jump to FILE Y
- I DICOMP'["W",DICOMP'["?" Q 1 ;DICOMP either does or doesn't contain "W" and "?"
- 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 ;from DINUM^DICOMPV, DICOMP0
- S X=" S D0="_X_" S:'D0!'$D("_%Y_"+D0,0)) D0=-1 S D0=D0"
- 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
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMPX 2626 printed Feb 19, 2025@00:12:45 Page 2
- DICOMPX ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-26 9:30 AM
- +1 ;;22.2;VA FileMan;;Jan 05, 2016;Build 42
- +2 ;;Per VA Directive 6402, this routine should not be modified.
- +3 ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
- +4 ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
- +5 ;;Licensed under the terms of the Apache License, Version 2.0.
- +6 ;
- M ;From DICOMP
- +1 SET DICOMPXM=M
- +2 ;Try as long a file name as possible
- FOR
- DO F
- if $DATA(X)
- QUIT
- Begin DoDot:1
- +3 IF M<$LENGTH(I)
- FOR M=M+1:1
- SET W=$EXTRACT(I,M)
- IF DPUNC[W
- SET X=$EXTRACT(I,1,M-1)
- QUIT
- End DoDot:1
- if '$DATA(X)
- QUIT
- +4 if '$DATA(X)
- SET M=DICOMPXM
- KILL DICOMPXM
- +5 QUIT
- +6 ;
- F IF '$DATA(J(0))
- KILL X
- QUIT
- +1 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=$$CONVQQ^DILIBF(I(D))
- SET J(DLV)=Y
- Begin DoDot:1
- REF FOR Y=D+1:1:DLV
- SET V=Y#100-1
- SET DICN=$$CONVQQ^DILIBF(I(Y))
- SET X=X_$SELECT(T<DLV0:"I("_(T\100*100+V)_",0)",1:"D"_V)_","_DICN_","
- End DoDot:1
- SET DLV0=DLV0+100
- FOR DLV=D:1:DLV
- DO SN
- Q QUIT
- +1 ;
- R IF X]""
- IF $PIECE(X,DG)=""
- 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
- SET X=$$CONVQQ^DILIBF(^(0,"GL"))
- GOTO Y
- +1 KILL X
- QUIT
- +2 ;
- 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 ;
- +3 ;
- OKFILE(Y,DICOMP) ;Called from DICATT6 Block, DICATT3, DICOMP0 to see if we can jump to FILE Y
- +1 ;DICOMP either does or doesn't contain "W" and "?"
- IF DICOMP'["W"
- IF DICOMP'["?"
- QUIT 1
- +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 ;from DINUM^DICOMPV, DICOMP0
- +1 SET X=" S D0="_X_" S:'D0!'$D("_%Y_"+D0,0)) D0=-1 S D0=D0"
- +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