DICATT5 ;SFISC/XAK-POINTERS ;12:04 PM 25 Jan 2000
;;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.
;
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT5 2794 printed Nov 22, 2024@17:55:29 Page 2
DICATT5 ;SFISC/XAK-POINTERS ;12:04 PM 25 Jan 2000
+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 ;
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
