- DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-27 2: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.
- ;
- COLON N DICOMPW K DP,Y S DICOMPW=DICOMP ;COME HERE WHEN INPUT ENDS IN COLON
- I $D(DIC)#2,$P(X,":",2)="" S X=$P(X,":"),DIC(0)="FIZO",DIC("S")="N A S A=$P(^(0),U,2) I A[""P""!(A[""p""),'A" N DICR,DO,DIY D ^DIC K DIC S X=X_":" D:Y>0 ARC I Y>0 S X="INTERNAL(#"_+Y_")",DP=+$P($P(Y(0),U,2),"P",2)_U_$P(Y(0),U,3)
- I I $P(Y(0),U,2)["p" S X=$P(Y(0),U,5,99),DP=+$P($P(Y(0),U,2),"p",2),DP=DP_$G(^DIC(DP,0,"GL")),Y=0 G JUMP:$P(Y(0),U,2)'["m" S DICOMPW=DICOMP+100 D IJ S Y=D_"m" Q ;computed pointer, possibly multiple
- I $G(Y)'>0 S X=$E(X,1,$L(X)-1),DICOMPX="",DICOMPX(0)="D("
- S DICOMP=DICOMP_"S"
- D EN^DICOMP G Q:'$D(X)
- I '$D(DP) K:Y'>DICOMPW X S %=I(+Y),DP=J(+Y)_$S(%[U:%,1:U_$P(%,"""",1)_$P(%,"""",2)) G Q
- JUMP S:$D(DIFG) DIFG=2 S DICOMP=DICOMPW D DRW^DICOMPX G Q:'$D(^DIC(+DP,0)) S D=Y,Y=+DP X DIC("S") S Y=D I '$T K X,DIC("S") G Q
- IJ F D=DICOMPW\100*100:1 S X="S I("_D_",0)=D"_(D#100)_" "_X I +DICOMPW=D S X=X_" S D(0)=+X",D=Y\100+1*100,I(D)=U_$P(DP,U,2),J(D)=+DP,Y=D_U_Y Q
- Q S:$D(DIFG)&$D(X) DIFG("DICOMP")=DICOMPX K DICOMP,DICOMPX,DICOMPW Q
- ;
- ;
- M ;
- S (D,DS)=0,DZ="""",Y=J(DLV) I DICOMP["W" D ASKE,ASK:'D I D<0 K X Q
- S:DS DZ="E"""
- I D S DZ=$E("W",$D(DICO(3)))_"L"_DZ_$S(DLV=DLV0:"",1:",DIC(""P"")="""_$P(^DD(J(DLV-1),$O(^DD(J(DLV-1),"SB",J(DLV),0)),0),U,2)_"""") I D=2 S DZ=DZ_",X=""""""""_X_"""""""""
- S (%,%Y)=DLV#100,DZ="N DIC S DIC=X N X S X=DIC,"_$P("Y=-1,",U,%>0)_"DIC="""_X_""",DIC(0)=""MF"_DZ_" D ^DIC"_$P(":D"_(%-1)_">0",U,%>0),X=" S (D,D"_%_$S($D(DICOMPX(0)):","_DICOMPX(0)_%_")",1:"")_")=+Y"
- I D F %=%:-1:1 S X=X_",DA("_%_")=DIU("_%_")",DZ=DZ_",DIU("_%_")=$S($D(DA("_%_")):DA("_%_"),1:0),DA("_%_")=D"_(%Y-%)
- S %=X D DIMP^DICOMPZ(DZ) S X=X_%
- I W=":" S M=M+1 Q
- S I="#.01"_$E(I,M,999),M=0 Q
- ;
- ASKE ;
- S (D,DS)=0,%=1 I DICOMP["?",DICOMP["E" W !,$$EZBLD^DIALOG(8203,$$FILENAME^DIALOGZ(Y)) D YN^DICN S:%=1 DS=1 ;**CCO/NI 'WILL USER SELECT?'
- S:%<0 D=% Q:% D DICOMPW^DIQQQ G ASKE
- ;
- ASK ;
- G NO:DICOMP'["?",ASK1:DUZ(0)="@"
- S DIFILE=Y,DIAC="LAYGO" D ^DIAC K DIAC,DIFILE G:'% NO
- ASK1 W !,$$EZBLD^DIALOG(8204,$$FILENAME^DIALOGZ(Y)) ;**CCO/NI WANT TO PERMIT ADDING...?
- S %=2-(DICOMP["L"),D=0 D YN^DICN W ! I %<1 S D=-1 Q
- ASK2 Q:%=2 S D=1 Q:DZ W $$EZBLD^DIALOG(8205) ;**CCO/NI WELL, WANT TO *FORCCE* ADING...?
- S %=2-(DICOMP["L2") D YN^DICN I %<1 S D=-1 Q
- S D=3-%,DICO(2)=1 Q:%=1!'DS
- ASK3 W !,$$EZBLD^DIALOG(8206,$$FILENAME^DIALOGZ(Y)) D YN^DICN I %<1 S D=-1 Q ;**CCO/NI WANT AN 'ADDING NEW?' MESSAGE?
- Q:%=1 S DICO(3)=% Q
- NO S D=0 Q
- ;
- DPS ;COME HERE FROM DICOMP, DICOMP0, DICOMP1 TO POP THE STACK
- S X=DPS(DPS),%=$O(DPS(DPS,"$")) S:$D(DPS(DPS,"BOOL")) DBOOL=DPS(DPS,"BOOL") I %["$" S X=X_"X)"_DPS(DPS,%) D
- .N % S %=X N X S X=% F Q:$E(X)'=" " S X=$E(X,2,999)
- .D ^DIM I '$D(X) S W(DPS)="BAD '$' SYNTAX!"
- I $D(DPS(DPS,"DATE")) S DATE(K+1)=1 ;THE FUNCTION WAS DATE-VALUED, SO WE HAVE A DATE-VALUED EXPRESSION UP TO NOW
- S %=$D(DATE(K)) I $D(DPS(DPS,U)) S K=K+2,K(K-1)=X,K(K)=$E(DPS(DPS,U)),X=$E(DPS(DPS,U),2,99)
- I %&$D(DPS(DPS,"O"))!$D(DPS(DPS,"D")) S DATE(K+1)=1 ;!$D(DPS(DPS,"DATE")); "O" = DATE-VALUED IF INPUT WAS DATE-VALUED. "D" = ALWAYS DATE-VALUED.
- E I '$D(DPS(DPS,"ST")) S K(K+1,9)=0
- K DPS(DPS) S DPS=DPS-1
- Q
- ;
- ARC ;
- Q:DICOMP'["W"
- RES N N S N=+$P($P(Y(0),U,2),"P",2) I $P($G(^DD(N,0,"DI")),U,2)["Y" W !,$C(7),$$EZBLD^DIALOG(405,N) S Y=-1 ;**CCO/NI 'CANNOT EDIT RESTRICTED FILE'
- Q
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICOMPW 3747 printed Feb 19, 2025@00:12:44 Page 2
- DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR ;2014-12-27 2: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 ;
- COLON ;COME HERE WHEN INPUT ENDS IN COLON
- NEW DICOMPW
- KILL DP,Y
- SET DICOMPW=DICOMP
- +1 IF $DATA(DIC)#2
- IF $PIECE(X,":",2)=""
- SET X=$PIECE(X,":")
- SET DIC(0)="FIZO"
- SET DIC("S")="N A S A=$P(^(0),U,2) I A[""P""!(A[""p""),'A"
- NEW DICR,DO,DIY
- DO ^DIC
- KILL DIC
- SET X=X_":"
- if Y>0
- DO ARC
- IF Y>0
- SET X="INTERNAL(#"_+Y_")"
- SET DP=+$PIECE($PIECE(Y(0),U,2),"P",2)_U_$PIECE(Y(0),U,3)
- +2 ;computed pointer, possibly multiple
- IF $TEST
- IF $PIECE(Y(0),U,2)["p"
- SET X=$PIECE(Y(0),U,5,99)
- SET DP=+$PIECE($PIECE(Y(0),U,2),"p",2)
- SET DP=DP_$GET(^DIC(DP,0,"GL"))
- SET Y=0
- if $PIECE(Y(0),U,2)'["m"
- GOTO JUMP
- SET DICOMPW=DICOMP+100
- DO IJ
- SET Y=D_"m"
- QUIT
- +3 IF $GET(Y)'>0
- SET X=$EXTRACT(X,1,$LENGTH(X)-1)
- SET DICOMPX=""
- SET DICOMPX(0)="D("
- +4 SET DICOMP=DICOMP_"S"
- +5 DO EN^DICOMP
- if '$DATA(X)
- GOTO Q
- +6 IF '$DATA(DP)
- if Y'>DICOMPW
- KILL X
- SET %=I(+Y)
- SET DP=J(+Y)_$SELECT(%[U:%,1:U_$PIECE(%,"""",1)_$PIECE(%,"""",2))
- GOTO Q
- JUMP if $DATA(DIFG)
- SET DIFG=2
- SET DICOMP=DICOMPW
- DO DRW^DICOMPX
- if '$DATA(^DIC(+DP,0))
- GOTO Q
- SET D=Y
- SET Y=+DP
- XECUTE DIC("S")
- SET Y=D
- IF '$TEST
- KILL X,DIC("S")
- GOTO Q
- IJ FOR D=DICOMPW\100*100:1
- SET X="S I("_D_",0)=D"_(D#100)_" "_X
- IF +DICOMPW=D
- SET X=X_" S D(0)=+X"
- SET D=Y\100+1*100
- SET I(D)=U_$PIECE(DP,U,2)
- SET J(D)=+DP
- SET Y=D_U_Y
- QUIT
- Q if $DATA(DIFG)&$DATA(X)
- SET DIFG("DICOMP")=DICOMPX
- KILL DICOMP,DICOMPX,DICOMPW
- QUIT
- +1 ;
- +2 ;
- M ;
- +1 SET (D,DS)=0
- SET DZ=""""
- SET Y=J(DLV)
- IF DICOMP["W"
- DO ASKE
- if 'D
- DO ASK
- IF D<0
- KILL X
- QUIT
- +2 if DS
- SET DZ="E"""
- +3 IF D
- SET DZ=$EXTRACT("W",$DATA(DICO(3)))_"L"_DZ_$SELECT(DLV=DLV0:"",1:",DIC(""P"")="""_$PIECE(^DD(J(DLV-1),$ORDER(^DD(J(DLV-1),"SB",J(DLV),0)),0),U,2)_"""")
- IF D=2
- SET DZ=DZ_",X=""""""""_X_"""""""""
- +4 SET (%,%Y)=DLV#100
- SET DZ="N DIC S DIC=X N X S X=DIC,"_$PIECE("Y=-1,",U,%>0)_"DIC="""_X_""",DIC(0)=""MF"_DZ_" D ^DIC"_$PIECE(":D"_(%-1)_">0",U,%>0)
- SET X=" S (D,D"_%_$SELECT($DATA(DICOMPX(0)):","_DICOMPX(0)_%_")",1:"")_")=+Y"
- +5 IF D
- FOR %=%:-1:1
- SET X=X_",DA("_%_")=DIU("_%_")"
- SET DZ=DZ_",DIU("_%_")=$S($D(DA("_%_")):DA("_%_"),1:0),DA("_%_")=D"_(%Y-%)
- +6 SET %=X
- DO DIMP^DICOMPZ(DZ)
- SET X=X_%
- +7 IF W=":"
- SET M=M+1
- QUIT
- +8 SET I="#.01"_$EXTRACT(I,M,999)
- SET M=0
- QUIT
- +9 ;
- ASKE ;
- +1 ;**CCO/NI 'WILL USER SELECT?'
- SET (D,DS)=0
- SET %=1
- IF DICOMP["?"
- IF DICOMP["E"
- WRITE !,$$EZBLD^DIALOG(8203,$$FILENAME^DIALOGZ(Y))
- DO YN^DICN
- if %=1
- SET DS=1
- +2 if %<0
- SET D=%
- if %
- QUIT
- DO DICOMPW^DIQQQ
- GOTO ASKE
- +3 ;
- ASK ;
- +1 if DICOMP'["?"
- GOTO NO
- if DUZ(0)="@"
- GOTO ASK1
- +2 SET DIFILE=Y
- SET DIAC="LAYGO"
- DO ^DIAC
- KILL DIAC,DIFILE
- if '%
- GOTO NO
- ASK1 ;**CCO/NI WANT TO PERMIT ADDING...?
- WRITE !,$$EZBLD^DIALOG(8204,$$FILENAME^DIALOGZ(Y))
- +1 SET %=2-(DICOMP["L")
- SET D=0
- DO YN^DICN
- WRITE !
- IF %<1
- SET D=-1
- QUIT
- ASK2 ;**CCO/NI WELL, WANT TO *FORCCE* ADING...?
- if %=2
- QUIT
- SET D=1
- if DZ
- QUIT
- WRITE $$EZBLD^DIALOG(8205)
- +1 SET %=2-(DICOMP["L2")
- DO YN^DICN
- IF %<1
- SET D=-1
- QUIT
- +2 SET D=3-%
- SET DICO(2)=1
- if %=1!'DS
- QUIT
- ASK3 ;**CCO/NI WANT AN 'ADDING NEW?' MESSAGE?
- WRITE !,$$EZBLD^DIALOG(8206,$$FILENAME^DIALOGZ(Y))
- DO YN^DICN
- IF %<1
- SET D=-1
- QUIT
- +1 if %=1
- QUIT
- SET DICO(3)=%
- QUIT
- NO SET D=0
- QUIT
- +1 ;
- DPS ;COME HERE FROM DICOMP, DICOMP0, DICOMP1 TO POP THE STACK
- +1 SET X=DPS(DPS)
- SET %=$ORDER(DPS(DPS,"$"))
- if $DATA(DPS(DPS,"BOOL"))
- SET DBOOL=DPS(DPS,"BOOL")
- IF %["$"
- SET X=X_"X)"_DPS(DPS,%)
- Begin DoDot:1
- +2 NEW %
- SET %=X
- NEW X
- SET X=%
- FOR
- if $EXTRACT(X)'=" "
- QUIT
- SET X=$EXTRACT(X,2,999)
- +3 DO ^DIM
- IF '$DATA(X)
- SET W(DPS)="BAD '$' SYNTAX!"
- End DoDot:1
- +4 ;THE FUNCTION WAS DATE-VALUED, SO WE HAVE A DATE-VALUED EXPRESSION UP TO NOW
- IF $DATA(DPS(DPS,"DATE"))
- SET DATE(K+1)=1
- +5 SET %=$DATA(DATE(K))
- IF $DATA(DPS(DPS,U))
- SET K=K+2
- SET K(K-1)=X
- SET K(K)=$EXTRACT(DPS(DPS,U))
- SET X=$EXTRACT(DPS(DPS,U),2,99)
- +6 ;!$D(DPS(DPS,"DATE")); "O" = DATE-VALUED IF INPUT WAS DATE-VALUED. "D" = ALWAYS DATE-VALUED.
- IF %&$DATA(DPS(DPS,"O"))!$DATA(DPS(DPS,"D"))
- SET DATE(K+1)=1
- +7 IF '$TEST
- IF '$DATA(DPS(DPS,"ST"))
- SET K(K+1,9)=0
- +8 KILL DPS(DPS)
- SET DPS=DPS-1
- +9 QUIT
- +10 ;
- ARC ;
- +1 if DICOMP'["W"
- QUIT
- RES ;**CCO/NI 'CANNOT EDIT RESTRICTED FILE'
- NEW N
- SET N=+$PIECE($PIECE(Y(0),U,2),"P",2)
- IF $PIECE($GET(^DD(N,0,"DI")),U,2)["Y"
- WRITE !,$CHAR(7),$$EZBLD^DIALOG(405,N)
- SET Y=-1
- +1 QUIT