DICATTDM ;SFISC/GFT - SUBSCRIPT AND PIECE-POSITION FOR STORAGE OF SINGLE-VALUED DATA IN SCREENMAN ;23JUN2017
;;22.2;VA FileMan;**2,13,20**;Jan 05, 2016;Build 2
;;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.
;;GFT;**42,118,1014,1044,1062**
;
;
SUBDEF ;EXECUTABLE DEFAULT for FIELD 16 (SUBSCRIPT)
S Y=$O(^DD(DICATTA,"GL",""),-1) ;find the highest subscript now used for storage of this File's data
I $$CHKSUB(Y,1) Q
NXT I Y S Y=Y+1 Q ;get a new subscript
F Y=+$O(^DD(DICATTA,"GL","A"),-1):1 Q:'$D(^(Y))
Q
;
PIECDEF ;
I $E($G(DICATT2N))="K" S Y="E1,245" Q
S Y=$$G(16) I Y]"" S Y=$$P(Y)
Q
;
P(Y) ;given SUBSCRIPT Y, return PIECE prompt
N P,X,%
S X=0,%=1,P=0
PC S X=$O(^DD(DICATTA,"GL",Y,X)) I X'="" S P=$P(X,",",2),%=$S(%>P:%,1:P+1) G PC
I P!$$ESTORE^DICATT1($G(DICATT2N)) S %="E"_%_","_($G(DICATTLN)+%-1)
E S %=$O(^(99999),-1)+1
Q %
;
SUBHELP ;
S Y=$E($G(DICATT2N))="K" D UNED^DDSUTL(17,"DICATTM",3,Y)
N X,Y,T
S X(1)="Enter name of MUMPS Global subscript where this Field's data will be stored."
S X(2)="Already assigned:"
S Y="",T=3
F S Y=$O(^DD(DICATTA,"GL",Y)) Q:Y="" S X(T)=$G(X(T))_$J(Y,9) I $L(X(T))>66 S T=T+1
D HLP^DDSUTL(.X)
Q
;
CHKSUB(X,DISHORT) ;used as INPUT TRANSFORM for Fields 16 (SUBSCRIPT) & 76 (MUL SUBSCRIPT) X is the subscript name. DISHORT says 'don't go beyond 250'
N M
S M=$$GET^DDSVALF(20.5,"DICATT",1,"","") ;'Is this field Multiple?'
I $D(^DD(DICATTA,"GL",X)),M Q "Another Field is already stored at '"_X_"'"
I $D(^(X,0)) Q "A multiple field is already stored at '"_X_"'"
I $O(^(0)),$$ESTORE^DICATT1($G(DICATT2N)) Q "Can't store this kind of data in this subscript"
I X<0 Q "Negative subscripts are not allowed" ;p20
I '$G(DICATTLN) Q 1 ;if we do not have a current length for the field, we are OK
S M=$S($G(DISHORT):250,1:$G(^DD("STRING_LIMIT"),255)-5) I $$MAX(DICATTLN,X)>M Q "Too much to store at the '"_X_"' subscript"
Q 1
;
MAX(L,Y) ;given L=length of new data, Y=subscript name
N T,A,DP,N,W
S A=DICATTA,DP=DICATTF
D MAX^DICATT1 Q T ;returns maximum length of subscript's data
;
CHKPIEC(P) ;
N N,S
S S=$$G(16) I S="" Q S ;must have subscript
I P?1"E"1.N1","1.N S N=$P(P,",",2)-$E(P,2,9)+1 G USED:N'<$G(DICATTLN) Q "Can't be less than "_DICATTLN
I P>0,P<100,P?.N,+P=P N Y D PIECDEF G USED:Y'?1"E".E Q "Must be stored by EXTRACT position"
Q ""
USED I $D(^DD(DICATTA,"GL",S,P)) Q "Already used for '"_$P(^DD(DICATTA,$O(^(P,0)),0),U)_"'"
I P["E",$O(^(0)) Q "Can't store by $EXTRACT in the same subscript with $PIECES"
Q 1
;
PIECHELP ;
N X,G,Y,P,T
S G=$$G(16) Q:G=""
S X(1)="Enter a number from 1 to 99",T=" an $EXTRACT range such as ""E1,4""."
I $$ESTORE^DICATT1($G(DICATT2N)) S X(1)="Enter"_T
E I '$D(^DD(DICATTA,"GL",G)) S X(1)=X(1)_" or "_T Q
S X(1)=X(1)_".",X(2)="Currently assigned: ",Y="",T=2
F S Y=$O(^DD(DICATTA,"GL",G,Y)) Q:Y="" S P=$O(^(Y,0)) I $D(^DD(DICATTA,P,0)) S X(T)=$G(X(T))_$J(Y,8) I $L(X(T))>66 S T=T+1
D HLP^DDSUTL(.X)
Q
;
POST ;POST-ACTION of Page 3
N %
S %=$$CHKPIEC($$G(17)) I '% S DDSBR=% K % S %(1)=DDSBR,DDSBR=16 D H(.%)
Q
;
H(%) S %($O(%(""),-1)+1)="$$EOP"
D HLP^DDSUTL(.%)
Q
;
G(I) Q $$GET^DDSVALF(I,"DICATTM",3,"","")
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDICATTDM 3448 printed Sep 23, 2025@20:21:56 Page 2
DICATTDM ;SFISC/GFT - SUBSCRIPT AND PIECE-POSITION FOR STORAGE OF SINGLE-VALUED DATA IN SCREENMAN ;23JUN2017
+1 ;;22.2;VA FileMan;**2,13,20**;Jan 05, 2016;Build 2
+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 ;;GFT;**42,118,1014,1044,1062**
+7 ;
+8 ;
SUBDEF ;EXECUTABLE DEFAULT for FIELD 16 (SUBSCRIPT)
+1 ;find the highest subscript now used for storage of this File's data
SET Y=$ORDER(^DD(DICATTA,"GL",""),-1)
+2 IF $$CHKSUB(Y,1)
QUIT
NXT ;get a new subscript
IF Y
SET Y=Y+1
QUIT
+1 FOR Y=+$ORDER(^DD(DICATTA,"GL","A"),-1):1
if '$DATA(^(Y))
QUIT
+2 QUIT
+3 ;
PIECDEF ;
+1 IF $EXTRACT($GET(DICATT2N))="K"
SET Y="E1,245"
QUIT
+2 SET Y=$$G(16)
IF Y]""
SET Y=$$P(Y)
+3 QUIT
+4 ;
P(Y) ;given SUBSCRIPT Y, return PIECE prompt
+1 NEW P,X,%
+2 SET X=0
SET %=1
SET P=0
PC SET X=$ORDER(^DD(DICATTA,"GL",Y,X))
IF X'=""
SET P=$PIECE(X,",",2)
SET %=$SELECT(%>P:%,1:P+1)
GOTO PC
+1 IF P!$$ESTORE^DICATT1($GET(DICATT2N))
SET %="E"_%_","_($GET(DICATTLN)+%-1)
+2 IF '$TEST
SET %=$ORDER(^(99999),-1)+1
+3 QUIT %
+4 ;
SUBHELP ;
+1 SET Y=$EXTRACT($GET(DICATT2N))="K"
DO UNED^DDSUTL(17,"DICATTM",3,Y)
+2 NEW X,Y,T
+3 SET X(1)="Enter name of MUMPS Global subscript where this Field's data will be stored."
+4 SET X(2)="Already assigned:"
+5 SET Y=""
SET T=3
+6 FOR
SET Y=$ORDER(^DD(DICATTA,"GL",Y))
if Y=""
QUIT
SET X(T)=$GET(X(T))_$JUSTIFY(Y,9)
IF $LENGTH(X(T))>66
SET T=T+1
+7 DO HLP^DDSUTL(.X)
+8 QUIT
+9 ;
CHKSUB(X,DISHORT) ;used as INPUT TRANSFORM for Fields 16 (SUBSCRIPT) & 76 (MUL SUBSCRIPT) X is the subscript name. DISHORT says 'don't go beyond 250'
+1 NEW M
+2 ;'Is this field Multiple?'
SET M=$$GET^DDSVALF(20.5,"DICATT",1,"","")
+3 IF $DATA(^DD(DICATTA,"GL",X))
IF M
QUIT "Another Field is already stored at '"_X_"'"
+4 IF $DATA(^(X,0))
QUIT "A multiple field is already stored at '"_X_"'"
+5 IF $ORDER(^(0))
IF $$ESTORE^DICATT1($GET(DICATT2N))
QUIT "Can't store this kind of data in this subscript"
+6 ;p20
IF X<0
QUIT "Negative subscripts are not allowed"
+7 ;if we do not have a current length for the field, we are OK
IF '$GET(DICATTLN)
QUIT 1
+8 SET M=$SELECT($GET(DISHORT):250,1:$GET(^DD("STRING_LIMIT"),255)-5)
IF $$MAX(DICATTLN,X)>M
QUIT "Too much to store at the '"_X_"' subscript"
+9 QUIT 1
+10 ;
MAX(L,Y) ;given L=length of new data, Y=subscript name
+1 NEW T,A,DP,N,W
+2 SET A=DICATTA
SET DP=DICATTF
+3 ;returns maximum length of subscript's data
DO MAX^DICATT1
QUIT T
+4 ;
CHKPIEC(P) ;
+1 NEW N,S
+2 ;must have subscript
SET S=$$G(16)
IF S=""
QUIT S
+3 IF P?1"E"1.N1","1.N
SET N=$PIECE(P,",",2)-$EXTRACT(P,2,9)+1
if N'<$GET(DICATTLN)
GOTO USED
QUIT "Can't be less than "_DICATTLN
+4 IF P>0
IF P<100
IF P?.N
IF +P=P
NEW Y
DO PIECDEF
if Y'?1"E".E
GOTO USED
QUIT "Must be stored by EXTRACT position"
+5 QUIT ""
USED IF $DATA(^DD(DICATTA,"GL",S,P))
QUIT "Already used for '"_$PIECE(^DD(DICATTA,$ORDER(^(P,0)),0),U)_"'"
+1 IF P["E"
IF $ORDER(^(0))
QUIT "Can't store by $EXTRACT in the same subscript with $PIECES"
+2 QUIT 1
+3 ;
PIECHELP ;
+1 NEW X,G,Y,P,T
+2 SET G=$$G(16)
if G=""
QUIT
+3 SET X(1)="Enter a number from 1 to 99"
SET T=" an $EXTRACT range such as ""E1,4""."
+4 IF $$ESTORE^DICATT1($GET(DICATT2N))
SET X(1)="Enter"_T
+5 IF '$TEST
IF '$DATA(^DD(DICATTA,"GL",G))
SET X(1)=X(1)_" or "_T
QUIT
+6 SET X(1)=X(1)_"."
SET X(2)="Currently assigned: "
SET Y=""
SET T=2
+7 FOR
SET Y=$ORDER(^DD(DICATTA,"GL",G,Y))
if Y=""
QUIT
SET P=$ORDER(^(Y,0))
IF $DATA(^DD(DICATTA,P,0))
SET X(T)=$GET(X(T))_$JUSTIFY(Y,8)
IF $LENGTH(X(T))>66
SET T=T+1
+8 DO HLP^DDSUTL(.X)
+9 QUIT
+10 ;
POST ;POST-ACTION of Page 3
+1 NEW %
+2 SET %=$$CHKPIEC($$G(17))
IF '%
SET DDSBR=%
KILL %
SET %(1)=DDSBR
SET DDSBR=16
DO H(.%)
+3 QUIT
+4 ;
H(%) SET %($ORDER(%(""),-1)+1)="$$EOP"
+1 DO HLP^DDSUTL(.%)
+2 QUIT
+3 ;
G(I) QUIT $$GET^DDSVALF(I,"DICATTM",3,"","")
