- DICATTD4 ;GFT/GFT - FREE TEXT FIELDS;8JAN2013
- ;;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.
- ;
- ;
- PRE4 ;PATTERN MATCH -- EXECUTABLE DEFAULT of Field 70
- N I,Z,X,L,YY
- S DICATT5P=" X",YY=0,I=0,L=1,Y="",Z=$P(DICATT5,")!'(",2,99) Q:Z=""
- L S I=I+1,X=$E(Z,I) G L:X'?.P Q:X="" I X="""" S YY='YY G L
- G L:YY I X="(" S L=L+1
- G L:X'=")" S L=L-1 G L:L
- S Y=$E(Z,1,I-1),DICATT5P=$E(Z,I+1,999) Q ;Y is default pattern-match
- ;
- POST4 ;check FREE TEXT
- N L,A1,A2 S L=$$G(69) Q:L="" ;get MAXIMUM LENGTH
- D:'$D(DICATT5P) PRE4 ;DICATT5P may be UNDEFINED
- E S A1=$P($P(DICATT4,";",2),"E",2) I A1 S A2=$P(A1,",",2) I A2,A2-A1+1<L S DDSERROR=1,DDSBR="69^DICATT4^2.4" D HLP^DDSUTL(" DATA IS STORED AS $E"_A1) Q
- I DICATT2["X" D S L=L_"X" G FJ ;EDIT LENGTH, EVEN IF NOTHING ELSE
- .S DICATTMN=$$GET^DDSVALF(98,"DICATT",1),Y="MAXIMUM LENGTH: " I DICATTMN=""!$P(DICATTMN,Y,2) S DICATTMN=Y_L D PUT^DDSVALF(98,"DICATT",1,DICATTMN)
- S Y=$$G(68) Q:Y=""
- I L<Y S DDSERROR=1,DDSBR="68^DICATT4^2.4" D HLP^DDSUTL("'MINIMUM' & 'MAXIMUM' ARE IN WRONG ORDER") Q
- S X=$S(L=Y:L,1:Y_"-"_L),DICATTMN="Answer must be "_X_" character"_$E("s",X'=1)_" in length."
- S X=$$G(70) I X]"" S X="!'("_X_")"
- S DICATT5N="K:$L(X)>"_L_"!($L(X)<"_Y_")"_X_DICATT5P
- D CHNG^DICATTD
- FJ S DICATTLN=+L,DICATT2N="FJ"_L,DICATT3N=""
- Q
- ;
- G(I) N X Q $$GET^DDSVALF(I,"DICATT4",2.4)
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTD4 1619 printed Apr 23, 2025@19:00 Page 2
- DICATTD4 ;GFT/GFT - FREE TEXT FIELDS;8JAN2013
- +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 ;
- PRE4 ;PATTERN MATCH -- EXECUTABLE DEFAULT of Field 70
- +1 NEW I,Z,X,L,YY
- +2 SET DICATT5P=" X"
- SET YY=0
- SET I=0
- SET L=1
- SET Y=""
- SET Z=$PIECE(DICATT5,")!'(",2,99)
- if Z=""
- QUIT
- L SET I=I+1
- SET X=$EXTRACT(Z,I)
- if X'?.P
- GOTO L
- if X=""
- QUIT
- IF X=""""
- SET YY='YY
- GOTO L
- +1 if YY
- GOTO L
- IF X="("
- SET L=L+1
- +2 if X'=")"
- GOTO L
- SET L=L-1
- if L
- GOTO L
- +3 ;Y is default pattern-match
- SET Y=$EXTRACT(Z,1,I-1)
- SET DICATT5P=$EXTRACT(Z,I+1,999)
- QUIT
- +4 ;
- POST4 ;check FREE TEXT
- +1 ;get MAXIMUM LENGTH
- NEW L,A1,A2
- SET L=$$G(69)
- if L=""
- QUIT
- +2 ;DICATT5P may be UNDEFINED
- if '$DATA(DICATT5P)
- DO PRE4
- E SET A1=$PIECE($PIECE(DICATT4,";",2),"E",2)
- IF A1
- SET A2=$PIECE(A1,",",2)
- IF A2
- IF A2-A1+1<L
- SET DDSERROR=1
- SET DDSBR="69^DICATT4^2.4"
- DO HLP^DDSUTL(" DATA IS STORED AS $E"_A1)
- QUIT
- +1 ;EDIT LENGTH, EVEN IF NOTHING ELSE
- IF DICATT2["X"
- Begin DoDot:1
- +2 SET DICATTMN=$$GET^DDSVALF(98,"DICATT",1)
- SET Y="MAXIMUM LENGTH: "
- IF DICATTMN=""!$PIECE(DICATTMN,Y,2)
- SET DICATTMN=Y_L
- DO PUT^DDSVALF(98,"DICATT",1,DICATTMN)
- End DoDot:1
- SET L=L_"X"
- GOTO FJ
- +3 SET Y=$$G(68)
- if Y=""
- QUIT
- +4 IF L<Y
- SET DDSERROR=1
- SET DDSBR="68^DICATT4^2.4"
- DO HLP^DDSUTL("'MINIMUM' & 'MAXIMUM' ARE IN WRONG ORDER")
- QUIT
- +5 SET X=$SELECT(L=Y:L,1:Y_"-"_L)
- SET DICATTMN="Answer must be "_X_" character"_$EXTRACT("s",X'=1)_" in length."
- +6 SET X=$$G(70)
- IF X]""
- SET X="!'("_X_")"
- +7 SET DICATT5N="K:$L(X)>"_L_"!($L(X)<"_Y_")"_X_DICATT5P
- +8 DO CHNG^DICATTD
- FJ SET DICATTLN=+L
- SET DICATT2N="FJ"_L
- SET DICATT3N=""
- +1 QUIT
- +2 ;
- G(I) NEW X
- QUIT $$GET^DDSVALF(I,"DICATT4",2.4)
