DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;5:52 AM 20 Dec 2001 [ 12/09/2003 4:25 PM ]
;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
G @N
;
3 S Z="",L=1,P=0,Y="INTERNALLY-STORED CODE: "
P S P=P+1,C=$P($P(O,U,3),S,P) W !,Y W:C]"" $P(C,":",1)_"// " R T:DTIME G T:'$T
I T_C]"" G P:T="@" S:T="" T=$P(C,":",1) S X=T,L=$S($L(X)>L:$L(X),1:L) D C I $D(X) W " WILL STAND FOR: " W:C]"" $P(C,":",2),"// " R X:DTIME G:'$T T S:X="" X=$P(C,":",2) D C I $D(X) G TOO:$L(Z)+$L(T)+$L(X)+$L(F)>235 S Z=Z_T_":"_X_S G P:X]"",T
G T:Z=""!'$D(X) S (DIZ,Z)="S^"_Z I DUZ(0)="@" S DE="^"_F D S^DICATT5 K DE G CHECK^DICATT:$D(DTOUT)!(X=U)
S C="Q" G H
;
C I X["?",P=1 K X W !,"For Example: Internal Code 'M' could stand for 'MALE'",! Q
I X[":"!(X[U)!(X[S)!(X[Q)!(X["=") K X W $C(7),!,"SORRY, ';' ':' '^' '""' AND '=' AREN'T ALLOWED IN SETS!",! Q
I X'?.ANP W !,$C(7),"Cannot use CONTROL CHARACTERS!" K X
Q
;
TOO W $C(7),!,"TOO MUCH!! -- SHOULD BE 'POINTER', NOT 'SET'"
T W ! G NO^DICATT2:'$D(X) S DTOUT=1 G CHECK^DICATT
;
4 K DG,DE,M S DL=1,L=1,DP=-1,DQ(1)="MINIMUM LENGTH^NR^^1^K:X\1'=X!(X<1) X",DQ(2)="MAXIMUM LENGTH^RN^^2^K:X\1'=X!(X>250)!(DG(1)>X) X"
S T="",P=" X",DQ(3)="(OPTIONAL) PATTERN MATCH (IN 'X')^^^3^S X=""I ""_X D ^DIM S:$D(X) X=$E(X,3,999) I $D(X) K:X?.NAC X",DQ(3,3)="EXAMPLE: ""X?1A.A"" OR ""X'?.P"""
G DIED:'O,DG:C'?.E1"K:$L".E1" X"
S T=$P(C,"K:$L",1),DE(2)=+$P(C,"$L(X)>",2),DE(1)=+$P(C,"$L(X)<",2)
S Y=0,I=0,Z=$P(C,")!'(",2,99) I Z="" K:'DE(2) DE(2) G DG
L S I=I+1,X=$E(Z,I) G L:X'?.P,DG:X="" I X=Q S Y='Y G L
G L:Y I X="(" S L=L+1
G L:X'=")" S L=L-1 G L:L
S DE(3)=$E(Z,1,I-1),P=$E(Z,I+1,999)
DG S:$D(^DD(A,DA,3)) M=^(3) F L=1,2,3 S:$D(DE(L)) DG(L)=DE(L)
DIED K Y S DM=0 D DQ^DIED K DQ,DM G CHECK^DICATT:$D(DTOUT)!($D(Y))
S Y=DG(1),L=DG(2),X=$S(L=Y:L,1:Y_"-"_L) I L<Y W $C(7),"??" G 4
S Z="Answer must be "_X_" character"_$E("s",X'=1)_" in length." I $S($D(M):M'[Z,1:1) S M=Z
S X=$S('$D(DG(3)):"",DG(3)="":"",1:"!'("_DG(3)_")")
S C=T_"K:$L(X)>"_L_"!($L(X)<"_Y_")"_X_P
Z S (DIZ,Z)="F^"
H G ^DICATT1
DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;5:52 AM 20 Dec 2001 [ 12/09/2003 4:25 PM ]
+1 ;;22.0;VA FileMan;**76,1002**;Mar 30, 1999
+2 ;Per VHA Directive 10-93-142, this routine should not be modified.
+3 GOTO @N
+4 ;
3 SET Z=""
SET L=1
SET P=0
SET Y="INTERNALLY-STORED CODE: "
P SET P=P+1
SET C=$PIECE($PIECE(O,U,3),S,P)
WRITE !,Y
IF C]""
WRITE $PIECE(C,":",1)_"// "
READ T:DTIME
IF '$TEST
GOTO T
+1 IF T_C]""
IF T="@"
GOTO P
IF T=""
SET T=$PIECE(C,":",1)
SET X=T
SET L=$SELECT($LENGTH(X)>L:$LENGTH(X),1:L)
DO C
IF $DATA(X)
WRITE " WILL STAND FOR: "
IF C]""
WRITE $PIECE(C,":",2),"// "
READ X:DTIME
IF '$TEST
GOTO T
IF X=""
SET X=$PIECE(C,":",2)
DO C
IF $DATA(X)
IF $LENGTH(Z)+$LENGTH(T)+$LENGTH(X)+$LENGTH(F)>235
GOTO TOO
SET Z=Z_T_":"_X_S
IF X]""
GOTO P
GOTO T
+2 IF Z=""!'$DATA(X)
GOTO T
SET (DIZ,Z)="S^"_Z
IF DUZ(0)="@"
SET DE="^"_F
DO S^DICATT5
KILL DE
IF $DATA(DTOUT)!(X=U)
GOTO CHECK^DICATT
+3 SET C="Q"
GOTO H
+4 ;
C IF X["?"
IF P=1
KILL X
WRITE !,"For Example: Internal Code 'M' could stand for 'MALE'",!
QUIT
+1 IF X[":"!(X[U)!(X[S)!(X[Q)!(X["=")
KILL X
WRITE $CHAR(7),!,"SORRY, ';' ':' '^' '""' AND '=' AREN'T ALLOWED IN SETS!",!
QUIT
+2 IF X'?.ANP
WRITE !,$CHAR(7),"Cannot use CONTROL CHARACTERS!"
KILL X
+3 QUIT
+4 ;
TOO WRITE $CHAR(7),!,"TOO MUCH!! -- SHOULD BE 'POINTER', NOT 'SET'"
T WRITE !
IF '$DATA(X)
GOTO NO^DICATT2
SET DTOUT=1
GOTO CHECK^DICATT
+1 ;
4 KILL DG,DE,M
SET DL=1
SET L=1
SET DP=-1
SET DQ(1)="MINIMUM LENGTH^NR^^1^K:X\1'=X!(X<1) X"
SET DQ(2)="MAXIMUM LENGTH^RN^^2^K:X\1'=X!(X>250)!(DG(1)>X) X"
+1 SET T=""
SET P=" X"
SET DQ(3)="(OPTIONAL) PATTERN MATCH (IN 'X')^^^3^S X=""I ""_X D ^DIM S:$D(X) X=$E(X,3,999) I $D(X) K:X?.NAC X"
SET DQ(3,3)="EXAMPLE: ""X?1A.A"" OR ""X'?.P"""
+2 IF 'O
GOTO DIED
IF C'?.E1"K:$L".E1" X"
GOTO DG
+3 SET T=$PIECE(C,"K:$L",1)
SET DE(2)=+$PIECE(C,"$L(X)>",2)
SET DE(1)=+$PIECE(C,"$L(X)<",2)
+4 SET Y=0
SET I=0
SET Z=$PIECE(C,")!'(",2,99)
IF Z=""
IF 'DE(2)
KILL DE(2)
GOTO DG
L SET I=I+1
SET X=$EXTRACT(Z,I)
IF X'?.P
GOTO L
IF X=""
GOTO DG
IF X=Q
SET Y='Y
GOTO L
+1 IF Y
GOTO L
IF X="("
SET L=L+1
+2 IF X'=")"
GOTO L
SET L=L-1
IF L
GOTO L
+3 SET DE(3)=$EXTRACT(Z,1,I-1)
SET P=$EXTRACT(Z,I+1,999)
DG IF $DATA(^DD(A,DA,3))
SET M=^(3)
FOR L=1,2,3
IF $DATA(DE(L))
SET DG(L)=DE(L)
DIED KILL Y
SET DM=0
DO DQ^DIED
KILL DQ,DM
IF $DATA(DTOUT)!($DATA(Y))
GOTO CHECK^DICATT
+1 SET Y=DG(1)
SET L=DG(2)
SET X=$SELECT(L=Y:L,1:Y_"-"_L)
IF L<Y
WRITE $CHAR(7),"??"
GOTO 4
+2 SET Z="Answer must be "_X_" character"_$EXTRACT("s",X'=1)_" in length."
IF $SELECT($DATA(M):M'[Z,1:1)
SET M=Z
+3 SET X=$SELECT('$DATA(DG(3)):"",DG(3)="":"",1:"!'("_DG(3)_")")
+4 SET C=T_"K:$L">L(X)>"_L">L_"!($L">L(X)<"_Y_")"_X_P
Z SET (DIZ,Z)="F^"
H GOTO ^DICATT1
