- 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 Feb 19, 2025@00:12:04 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,"","")