- DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;2013-01-16 11:41 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.
- ;
- 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 L=$G(^DD("STRING_LIMIT"),255)-5,P=$P($P($P(^DD(A,DA,0),U,4),";",2),"E",2) I P S M=$P(P,",",2) I M S L=M-P+1
- S DL=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>"_L_")!(DG(1)>X) X"
- S T="",L=1,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)="FJ"_L_U
- H G ^DICATT1
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATT6 2397 printed Mar 13, 2025@21:50:19 Page 2
- DICATT6 ;SFISC/XAK-SETS,FREE TEXT ;2013-01-16 11:41 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 ;
- +7 GOTO @N
- +8 ;
- 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 L=$GET(^DD("STRING_LIMIT"),255)-5
- SET P=$PIECE($PIECE($PIECE(^DD(A,DA,0),U,4),";",2),"E",2)
- IF P
- SET M=$PIECE(P,",",2)
- IF M
- SET L=M-P+1
- +1 SET DL=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>"_L_")!(DG(1)>X) X"
- +2 SET T=""
- SET L=1
- 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"""
- +3 if 'O
- GOTO DIED
- if C'?.E1"K:$L".E1" X"
- GOTO DG
- +4 SET T=$PIECE(C,"K:$L",1)
- SET DE(2)=+$PIECE(C,"$L(X)>",2)
- SET DE(1)=+$PIECE(C,"$L(X)<",2)
- +5 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(X)>"_L_"!($L(X)<"_Y_")"_X_P
- Z SET (DIZ,Z)="FJ"_L_U
- H GOTO ^DICATT1
