DICATTD3 ;GFT/GFT - Set of Codes ;09:06 AM 21 Jan 1999
;;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.
;
Y(ORDER,CM) ;
S Y=$P($P(DICATT3,";",ORDER),":",CM) Q
C ;
N C
F C=":",";","=","""" I X[C D HLP^DDSUTL("SORRY -- '"_C_"' NOT ALLOWED IN SET VALUES!") K X Q
Q
;
POST3 ;
N I,X,F
K DDSBR,DDSERROR
S F=$$GET^DDSVALF(1,"DICATT",1,"I","") ;we need FIELD LABEL to check total length of "0" node
S DICATTLN=1,DICATT3N=""
F X=35:2:59 S I=$$G(X) D I $D(DDSERROR) G ERROR
.I I="" Q:$$G(X+1)="" S DDSERROR=1,DDSBR=X D H("THERE MUST BE A CODE FOR '"_$$G(X+1)_"'!") Q
.I $D(F(I)) S DDSERROR=1,DDSBR=X D H("CAN'T HAVE TWO IDENTICAL CODES!") Q
.S X(X)=I,F(I)=""
.I $L(I)>DICATTLN S DICATTLN=$L(I)
.S I=$$G(X+1) I I="" S DDSERROR=1,DDSBR=X+1 D H("'"_X(X)_"' MUST MEAN SOMETHING!") Q
.I $L(DICATT3N)+$L(X(X))+$L(I)+$L(F)>235 S DDSERROR=1,DDSBR=X D H("TOO MUCH!! TO STORE THAT MUCH, BUILD A NEW FILE AND USE A POINTER!") Q
.S DICATT3N=DICATT3N_X(X)_":"_I_";"
S DICATT2N="S",DICATT5N="Q"
S DICATTMN=$$GET^DDSVALF(98,"DICATT",1,"I","") ;says we have a change
BRANCH I '$D(DICATTSC),DUZ(0)="@" S DICATTSC=3,DDSBR="65^DICATT SCREEN^6" Q
D SCREEN
Q
;
G(I) N X Q $$GET^DDSVALF(I,"DICATT3",2.3,"I","")
;
H(I) N X S X(1)=I,X(2)="$$EOP"
D HLP^DDSUTL(.X)
Q
;
ERROR S DDSBR=DDSBR_"^DICATT3^2.3" Q
;
SCREEN ;
I DUZ(0)'="@" Q
I $$S(66)]"" S DICATT5N(12.1)=$$S(66),DICATT5N(12)=$$S(67),DICATT2N="*"_DICATT2N
Q
;
S(I) Q $$GET^DDSVALF(I,"DICATT SCREEN",6,"I","")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTD3 1766 printed Apr 09, 2024@21:51:30 Page 2
DICATTD3 ;GFT/GFT - Set of Codes ;09:06 AM 21 Jan 1999
+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 ;
Y(ORDER,CM) ;
+1 SET Y=$PIECE($PIECE(DICATT3,";",ORDER),":",CM)
QUIT
C ;
+1 NEW C
+2 FOR C=":",";","=",""""
IF X[C
DO HLP^DDSUTL("SORRY -- '"_C_"' NOT ALLOWED IN SET VALUES!")
KILL X
QUIT
+3 QUIT
+4 ;
POST3 ;
+1 NEW I,X,F
+2 KILL DDSBR,DDSERROR
+3 ;we need FIELD LABEL to check total length of "0" node
SET F=$$GET^DDSVALF(1,"DICATT",1,"I","")
+4 SET DICATTLN=1
SET DICATT3N=""
+5 FOR X=35:2:59
SET I=$$G(X)
Begin DoDot:1
+6 IF I=""
if $$G(X+1)=""
QUIT
SET DDSERROR=1
SET DDSBR=X
DO H("THERE MUST BE A CODE FOR '"_$$G(X+1)_"'!")
QUIT
+7 IF $DATA(F(I))
SET DDSERROR=1
SET DDSBR=X
DO H("CAN'T HAVE TWO IDENTICAL CODES!")
QUIT
+8 SET X(X)=I
SET F(I)=""
+9 IF $LENGTH(I)>DICATTLN
SET DICATTLN=$LENGTH(I)
+10 SET I=$$G(X+1)
IF I=""
SET DDSERROR=1
SET DDSBR=X+1
DO H("'"_X(X)_"' MUST MEAN SOMETHING!")
QUIT
+11 IF $LENGTH(DICATT3N)+$LENGTH(X(X))+$LENGTH(I)+$LENGTH(F)>235
SET DDSERROR=1
SET DDSBR=X
DO H("TOO MUCH!! TO STORE THAT MUCH, BUILD A NEW FILE AND USE A POINTER!")
QUIT
+12 SET DICATT3N=DICATT3N_X(X)_":"_I_";"
End DoDot:1
IF $DATA(DDSERROR)
GOTO ERROR
+13 SET DICATT2N="S"
SET DICATT5N="Q"
+14 ;says we have a change
SET DICATTMN=$$GET^DDSVALF(98,"DICATT",1,"I","")
BRANCH IF '$DATA(DICATTSC)
IF DUZ(0)="@"
SET DICATTSC=3
SET DDSBR="65^DICATT SCREEN^6"
QUIT
+1 DO SCREEN
+2 QUIT
+3 ;
G(I) NEW X
QUIT $$GET^DDSVALF(I,"DICATT3",2.3,"I","")
+1 ;
H(I) NEW X
SET X(1)=I
SET X(2)="$$EOP"
+1 DO HLP^DDSUTL(.X)
+2 QUIT
+3 ;
ERROR SET DDSBR=DDSBR_"^DICATT3^2.3"
QUIT
+1 ;
SCREEN ;
+1 IF DUZ(0)'="@"
QUIT
+2 IF $$S(66)]""
SET DICATT5N(12.1)=$$S(66)
SET DICATT5N(12)=$$S(67)
SET DICATT2N="*"_DICATT2N
+3 QUIT
+4 ;
S(I) QUIT $$GET^DDSVALF(I,"DICATT SCREEN",6,"I","")
