Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DICATTDM

DICATTDM.m

Go to the documentation of this file.
  1. 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
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;;Submitted to OSEHRA 5 January 2015 by the VISTA Expertise Network.
  1. ;;Based on Medsphere Systems Corporation's MSC FileMan 1051.
  1. ;;Licensed under the terms of the Apache License, Version 2.0.
  1. ;;GFT;**42,118,1014,1044,1062**
  1. ;
  1. ;
  1. SUBDEF ;EXECUTABLE DEFAULT for FIELD 16 (SUBSCRIPT)
  1. S Y=$O(^DD(DICATTA,"GL",""),-1) ;find the highest subscript now used for storage of this File's data
  1. I $$CHKSUB(Y,1) Q
  1. NXT I Y S Y=Y+1 Q ;get a new subscript
  1. F Y=+$O(^DD(DICATTA,"GL","A"),-1):1 Q:'$D(^(Y))
  1. Q
  1. ;
  1. PIECDEF ;
  1. I $E($G(DICATT2N))="K" S Y="E1,245" Q
  1. S Y=$$G(16) I Y]"" S Y=$$P(Y)
  1. Q
  1. ;
  1. P(Y) ;given SUBSCRIPT Y, return PIECE prompt
  1. N P,X,%
  1. S X=0,%=1,P=0
  1. PC S X=$O(^DD(DICATTA,"GL",Y,X)) I X'="" S P=$P(X,",",2),%=$S(%>P:%,1:P+1) G PC
  1. I P!$$ESTORE^DICATT1($G(DICATT2N)) S %="E"_%_","_($G(DICATTLN)+%-1)
  1. E S %=$O(^(99999),-1)+1
  1. Q %
  1. ;
  1. SUBHELP ;
  1. S Y=$E($G(DICATT2N))="K" D UNED^DDSUTL(17,"DICATTM",3,Y)
  1. N X,Y,T
  1. S X(1)="Enter name of MUMPS Global subscript where this Field's data will be stored."
  1. S X(2)="Already assigned:"
  1. S Y="",T=3
  1. 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
  1. D HLP^DDSUTL(.X)
  1. Q
  1. ;
  1. 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. N M
  1. S M=$$GET^DDSVALF(20.5,"DICATT",1,"","") ;'Is this field Multiple?'
  1. I $D(^DD(DICATTA,"GL",X)),M Q "Another Field is already stored at '"_X_"'"
  1. I $D(^(X,0)) Q "A multiple field is already stored at '"_X_"'"
  1. I $O(^(0)),$$ESTORE^DICATT1($G(DICATT2N)) Q "Can't store this kind of data in this subscript"
  1. I X<0 Q "Negative subscripts are not allowed" ;p20
  1. I '$G(DICATTLN) Q 1 ;if we do not have a current length for the field, we are OK
  1. 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"
  1. Q 1
  1. ;
  1. MAX(L,Y) ;given L=length of new data, Y=subscript name
  1. N T,A,DP,N,W
  1. S A=DICATTA,DP=DICATTF
  1. D MAX^DICATT1 Q T ;returns maximum length of subscript's data
  1. ;
  1. CHKPIEC(P) ;
  1. N N,S
  1. S S=$$G(16) I S="" Q S ;must have subscript
  1. 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
  1. 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"
  1. Q ""
  1. USED I $D(^DD(DICATTA,"GL",S,P)) Q "Already used for '"_$P(^DD(DICATTA,$O(^(P,0)),0),U)_"'"
  1. I P["E",$O(^(0)) Q "Can't store by $EXTRACT in the same subscript with $PIECES"
  1. Q 1
  1. ;
  1. PIECHELP ;
  1. N X,G,Y,P,T
  1. S G=$$G(16) Q:G=""
  1. S X(1)="Enter a number from 1 to 99",T=" an $EXTRACT range such as ""E1,4""."
  1. I $$ESTORE^DICATT1($G(DICATT2N)) S X(1)="Enter"_T
  1. E I '$D(^DD(DICATTA,"GL",G)) S X(1)=X(1)_" or "_T Q
  1. S X(1)=X(1)_".",X(2)="Currently assigned: ",Y="",T=2
  1. 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
  1. D HLP^DDSUTL(.X)
  1. Q
  1. ;
  1. POST ;POST-ACTION of Page 3
  1. N %
  1. S %=$$CHKPIEC($$G(17)) I '% S DDSBR=% K % S %(1)=DDSBR,DDSBR=16 D H(.%)
  1. Q
  1. ;
  1. H(%) S %($O(%(""),-1)+1)="$$EOP"
  1. D HLP^DDSUTL(.%)
  1. Q
  1. ;
  1. G(I) Q $$GET^DDSVALF(I,"DICATTM",3,"","")