- DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR 1/7/2004;8FEB2012
- ;;22.0;VA FileMan;**6,76,169**;Mar 30, 1999;Build 28
- ;Per VHA Directive 2004-038, this routine should not be modified.
- 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 !,"WILL TERMINAL USER BE ALLOWED TO SELECT PROPER ENTRY IN '"_$O(^DD(Y,0,"NM",0))_"' FILE" D YN^DICN S:%=1 DS=1
- 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 !,"DO YOU WANT TO PERMIT ADDING A NEW '"_$O(^DD(Y,0,"NM",0))_"' ENTRY"
- S %=2-(DICOMP["L"),D=0 D YN^DICN W ! I %<1 S D=-1 Q
- Q:%=2 S D=1 Q:DZ W "WELL THEN, DO YOU WANT TO **FORCE** ADDING A NEW ENTRY EVERY TIME"
- S %=2-(DICOMP["L2") D YN^DICN I %<1 S D=-1 Q
- S D=3-%,DICO(2)=1 Q:%=1!'DS
- W !,"DO YOU WANT AN 'ADDING A NEW "_$O(^DD(Y,0,"NM",0))_"' MESSAGE" D YN^DICN I %<1 S D=-1 Q
- Q:%=1 S DICO(3)=% Q
- NO S D=0 Q
- ;
- DPS ;
- 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
- 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"))!$D(DPS(DPS,"DATE")) S DATE(K+1)=1
- E I '$D(DPS(DPS,"ST")) S K(K+1,9)=0
- K DPS(DPS) S DPS=DPS-1
- Q
- ARC ;
- Q:DICOMP'["W"
- I $P($G(^DD(+$P($P(Y(0),U,2),"P",2),0,"DI")),U,2)["Y" W !,$C(7),"SORRY, CAN'T EDIT A RESTRICTED"_$S($P($G(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!" S Y=-1
- Q
- DICOMPW ;SFISC/GFT-EVALUATE COMPUTED FLD EXPR 1/7/2004;8FEB2012
- +1 ;;22.0;VA FileMan;**6,76,169**;Mar 30, 1999;Build 28
- +2 ;Per VHA Directive 2004-038, this routine should not be modified.
- 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 SET (D,DS)=0
- SET %=1
- IF DICOMP["?"
- IF DICOMP["E"
- WRITE !,"WILL TERMINAL USER BE ALLOWED TO SELECT PROPER ENTRY IN '"_$ORDER(^DD(Y,0,"NM",0))_"' FILE"
- 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 WRITE !,"DO YOU WANT TO PERMIT ADDING A NEW '"_$ORDER(^DD(Y,0,"NM",0))_"' ENTRY"
- +1 SET %=2-(DICOMP["L")
- SET D=0
- DO YN^DICN
- WRITE !
- IF %<1
- SET D=-1
- QUIT
- +2 IF %=2
- QUIT
- SET D=1
- IF DZ
- QUIT
- WRITE "WELL THEN, DO YOU WANT TO **FORCE** ADDING A NEW ENTRY EVERY TIME"
- +3 SET %=2-(DICOMP["L2")
- DO YN^DICN
- IF %<1
- SET D=-1
- QUIT
- +4 SET D=3-%
- SET DICO(2)=1
- IF %=1!'DS
- QUIT
- +5 WRITE !,"DO YOU WANT AN 'ADDING A NEW "_$ORDER(^DD(Y,0,"NM",0))_"' MESSAGE"
- DO YN^DICN
- IF %<1
- SET D=-1
- QUIT
- +6 IF %=1
- QUIT
- SET DICO(3)=%
- QUIT
- NO SET D=0
- QUIT
- +1 ;
- DPS ;
- +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 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 IF %&$DATA(DPS(DPS,"O"))!$DATA(DPS(DPS,"D"))!$DATA(DPS(DPS,"DATE"))
- 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
- ARC ;
- +1 IF DICOMP'["W"
- QUIT
- +2 IF $PIECE($GET(^DD(+$PIECE($PIECE(Y(0),U,2),"P",2),0,"DI")),U,2)["Y"
- WRITE !,$CHAR(7),"SORRY, CAN'T EDIT A RESTRICTED"_$SELECT($PIECE($GET(^("DI")),U)["Y":" (ARCHIVE)",1:"")_" FILE!"
- SET Y=-1
- +3 QUIT
