- DICATT5 ;SFISC/XAK-POINTERS ;12:04 PM 25 Jan 2000 [ 04/02/2003 8:25 AM ]
- ;;22.0;VA FileMan;**1001**;APR 1, 2003
- ;;22.0;VA FileMan;**26**;Mar 30, 1999
- ;Per VHA Directive 10-93-142, this routine should not be modified.
- 7 K DIC S Y="",%=$P(O,U,3),DIC(0)="EFQIZ"
- S:$P(O,U,2)["P"&$L(%) Y=$S($D(@("^"_%_"0)")):$P(^(0),U),1:"")
- W !,"POINT TO WHICH FILE: " W:Y]"" Y_"// " R X:DTIME S:'$T DTOUT=1 G CHECK^DICATT:X=U!'$T I Y]"",X="" S X=Y,DIC(0)=DIC(0)_"O"
- S DIC=1,DIC("S")="I Y'=1.1 S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
- D ^DIC K DIC,DIFILE,DIAC G:Y<0 7:X["?",T S X=^(0,"GL"),DE=Y G 77
- T K DIC G CHECK^DICATT:$D(DTOUT),NO^DICATT2
- 77 S DIFILE=+Y,DIAC="LAYGO" D ^DIAC S %=0 S:'DIAC!($P($G(^DD(DIFILE,0,"DI")),U,2)["Y") %=2 K DIFILE,DIAC
- P I % W !,$C(7) D A W !,"WILL NOT " D B
- E S %=1+$S($P(O,U,2)["'":1,$P(O,U,2)']"":1,1:0) W !,"SHOULD " D A W ! D B,YN^DICN G T:%<1
- S Z="P"_+DE_$E("'",%=2)_X,C="Q",L=9,E=X G H:DUZ(0)'="@" D S G T:X=U,H
- S ;
- S D=$S($D(^DD(A,DA,12.1)):^(12.1),1:""),%=2-(D]""),P=$S($D(^(12)):^(12),1:""),I=$S($D(^(12.2)):^(12.2),1:"")
- W !,"SHOULD '"_$P(DE,U,2)_"' ENTRIES BE SCREENED" D YN^DICN S:%<0 X=U Q:X=U I '% W !?5,"Answer YES if there is a condition which should prohibit",!?5,"selection of some entries." G S
- I %=2 K ^(12.1),^(12),^(12.2) Q
- G M ;W !,"ENTER A TRUTH-VALUED EXPRESSION WHICH MUST BE TRUE OF ANY ENTRY POINTED TO:",!?4 I I]"" W I_"// " W:$X>35 !?4
- R X:DTIME S:'$T DTOUT=1 G T:X=U!'$T S:X="" X=I I X="" G M:DUZ(0)="@",S
- K DG,K S ^(12.2)=X,K=100,DQI="Y(",DG(K)=K,K(1,1)=K,(DLV,DLV0)=K,J(K)=+DE,I(K)=E,K=0 D EN^DICOMP
- G S:'$D(X) I $D(X)>1!(X[" ^DIC") W $C(7),!,"TOO COMPLICATED!" G S
- S I=0 I 'DBOOL W $C(7),!?8,"WARNING-- THIS DOESN'T LOOK LIKE A TRUTH-VALUED EXPRESSION"
- D0 S I=$F(X,E_"D0",I) I I S X=$E(X,1,I-3)_"Y"_$E(X,I,999) G D0
- Q S I=$F(X,"""",I) I I S X=$E(X,1,I-1)_""""_$E(X,I,999),I=I+1 G Q
- S (D,X)="S DIC(""S"")="""_X_" I X""" G E:DUZ(0)'="@"
- M W !,"MUMPS CODE THAT WILL SET 'DIC(""S"")': " W:D]"" D S Y=D D:D]"" RW^DIR2 G S:X="@" I D']"" R X:DTIME S:'$T DTOUT=1 Q:X=U!'$T
- I X="" S X=D G S:X=""
- I X?."?" D HELP^DICATT4 G M
- D ^DIM:'$T I '$D(X) S X="" G S
- I X'["DIC(""S"")" W $C(7),!,?8,"WARNING - Screen Does Not Contain DIC(""S"")"
- E W !,"EXPLANATION OF SCREEN: " W:P]"" P_"// " R %:DTIME S:'$T %=U,DTOUT=1 S:%="" %=P G S:%=U I %?.P W !?5,$C(7),"An explanation must be entered." G E
- I $D(^DD(A,DA,12.1)) S:X'=^(12.1) M(1)=0
- S ^DD(A,DA,12)=%,^(12.1)=X,Z="*"_Z S:Z?1"*P".E C=X_" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X" Q
- H S DIZ=Z G ^DICATT1
- ;
- A W "'ADDING A NEW "_$P(DE,U,2)_" FILE ENTRY' (""LAYGO"")" Q
- B W "BE ALLOWED WHEN ANSWERING THE "_F_"' QUESTION" Q
- Q
- DICATT5 ;SFISC/XAK-POINTERS ;12:04 PM 25 Jan 2000 [ 04/02/2003 8:25 AM ]
- +1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
- +2 ;;22.0;VA FileMan;**26**;Mar 30, 1999
- +3 ;Per VHA Directive 10-93-142, this routine should not be modified.
- 7 KILL DIC
- SET Y=""
- SET %=$PIECE(O,U,3)
- SET DIC(0)="EFQIZ"
- +1 IF $PIECE(O,U,2)["P"&$LENGTH(%)
- SET Y=$SELECT($DATA(@("^"_%_"0)")):$PIECE(^(0),U),1:"")
- +2 WRITE !,"POINT TO WHICH FILE: "
- IF Y]""
- WRITE Y_"// "
- READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- IF X=U!'$TEST
- GOTO CHECK^DICATT
- IF Y]""
- IF X=""
- SET X=Y
- SET DIC(0)=DIC(0)_"O"
- +3 SET DIC=1
- SET DIC("S")="I Y'=1.1 S DIFILE=+Y,DIAC=""RD"" D ^DIAC I %"
- +4 DO ^DIC
- KILL DIC,DIFILE,DIAC
- IF Y<0
- IF X["?"
- GOTO 7
- GOTO T
- SET X=^(0,"GL")
- SET DE=Y
- GOTO 77
- T KILL DIC
- IF $DATA(DTOUT)
- GOTO CHECK^DICATT
- GOTO NO^DICATT2
- 77 SET DIFILE=+Y
- SET DIAC="LAYGO"
- DO ^DIAC
- SET %=0
- IF 'DIAC!($PIECE($GET(^DD(DIFILE,0,"DI")),U,2)["Y")
- SET %=2
- KILL DIFILE,DIAC
- P IF %
- WRITE !,$CHAR(7)
- DO A
- WRITE !,"WILL NOT "
- DO B
- +1 IF '$TEST
- SET %=1+$SELECT($PIECE(O,U,2)["'":1,$PIECE(O,U,2)']"":1,1:0)
- WRITE !,"SHOULD "
- DO A
- WRITE !
- DO B
- DO YN^DICN
- IF %<1
- GOTO T
- +2 SET Z="P"_+DE_$EXTRACT("'",%=2)_X
- SET C="Q"
- SET L=9
- SET E=X
- IF DUZ(0)'="@"
- GOTO H
- DO S
- IF X=U
- GOTO T
- GOTO H
- S ;
- +1 SET D=$SELECT($DATA(^DD(A,DA,12.1)):^(12.1),1:"")
- SET %=2-(D]"")
- SET P=$SELECT($DATA(^(12)):^(12),1:"")
- SET I=$SELECT($DATA(^(12.2)):^(12.2),1:"")
- +2 WRITE !,"SHOULD '"_$PIECE(DE,U,2)_"' ENTRIES BE SCREENED"
- DO YN^DICN
- IF %<0
- SET X=U
- IF X=U
- QUIT
- IF '%
- WRITE !?5,"Answer YES if there is a condition which should prohibit",!?5,"selection of some entries."
- GOTO S
- +3 IF %=2
- KILL ^(12.1),^(12),^(12.2)
- QUIT
- +4 ;W !,"ENTER A TRUTH-VALUED EXPRESSION WHICH MUST BE TRUE OF ANY ENTRY POINTED TO:",!?4 I I]"" W I_"// " W:$X>35 !?4
- GOTO M
- +5 READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- IF X=U!'$TEST
- GOTO T
- IF X=""
- SET X=I
- IF X=""
- IF DUZ(0)="@"
- GOTO M
- GOTO S
- +6 KILL DG,K
- SET ^(12.2)=X
- SET K=100
- SET DQI="Y("
- SET DG(K)=K
- SET K(1,1)=K
- SET (DLV,DLV0)=K
- SET J(K)=+DE
- SET I(K)=E
- SET K=0
- DO EN^DICOMP
- +7 IF '$DATA(X)
- GOTO S
- IF $DATA(X)>1!(X[" ^DIC")
- WRITE $CHAR(7),!,"TOO COMPLICATED!"
- GOTO S
- +8 SET I=0
- IF 'DBOOL
- WRITE $CHAR(7),!?8,"WARNING-- THIS DOESN'T LOOK LIKE A TRUTH-VALUED EXPRESSION"
- D0 SET I=$FIND(X,E_"D0",I)
- IF I
- SET X=$EXTRACT(X,1,I-3)_"Y"_$EXTRACT(X,I,999)
- GOTO D0
- Q SET I=$FIND(X,"""",I)
- IF I
- SET X=$EXTRACT(X,1,I-1)_""""_$EXTRACT(X,I,999)
- SET I=I+1
- GOTO Q
- +1 SET (D,X)="S DIC(""S"")="""_X_" I X"""
- IF DUZ(0)'="@"
- GOTO E
- M WRITE !,"MUMPS CODE THAT WILL SET 'DIC(""S"")': "
- IF D]""
- WRITE D
- SET Y=D
- IF D]""
- DO RW^DIR2
- IF X="@"
- GOTO S
- IF D']""
- READ X:DTIME
- IF '$TEST
- SET DTOUT=1
- IF X=U!'$TEST
- QUIT
- +1 IF X=""
- SET X=D
- IF X=""
- GOTO S
- +2 IF X?."?"
- DO HELP^DICATT4
- GOTO M
- +3 IF '$TEST
- DO ^DIM
- IF '$DATA(X)
- SET X=""
- GOTO S
- +4 IF X'["DIC(""S"")"
- WRITE $CHAR(7),!,?8,"WARNING - Screen Does Not Contain DIC(""S"")"
- E WRITE !,"EXPLANATION OF SCREEN: "
- IF P]""
- WRITE P_"// "
- READ %:DTIME
- IF '$TEST
- SET %=U
- SET DTOUT=1
- IF %=""
- SET %=P
- IF %=U
- GOTO S
- IF %?.P
- WRITE !?5,$CHAR(7),"An explanation must be entered."
- GOTO E
- +1 IF $DATA(^DD(A,DA,12.1))
- IF X'=^(12.1)
- SET M(1)=0
- +2 SET ^DD(A,DA,12)=%
- SET ^(12.1)=X
- SET Z="*"_Z
- IF Z?1"*P".E
- SET C=X_" D ^DIC K DIC S DIC=DIE,X=+Y K:Y<0 X"
- QUIT
- H SET DIZ=Z
- GOTO ^DICATT1
- +1 ;
- A WRITE "'ADDING A NEW "_$PIECE(DE,U,2)_" FILE ENTRY' (""LAYGO"")"
- QUIT
- B WRITE "BE ALLOWED WHEN ANSWERING THE "_F_"' QUESTION"
- QUIT
- +1 QUIT
