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

DIKCFORM.m

Go to the documentation of this file. 
  1. DIKCFORM ;SFISC/MKO-ENTRY POINTS FOR THE 'DIKC EDIT' FORM ;2:57 PM  25 Apr 2002 [ 12/09/2003  4:10 PM ]
  1.  ;;22.0;VA FileMan;**20,68,108,1002**;Mar 30, 1999
  1.  ;Per VHA Directive 10-93-142, this routine should not be modified.
  1.  ;
  1.  ;==========================
  1.  ; [DIKC EDIT] entry points
  1.  ;==========================
  1.  ;
  1. TYPEVAL ;Validation on Type (#.2)
  1.  Q:DDSOLD=""
  1.  I X'="MU"!($G(DUZ(0))'="@") D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"You can only change the Type of cross reference to MUMPS, and only if you're a programmer.")
  1.  ;
  1.  I X="MU",$P($G(^DD(+$$FNO^DILIBF($$GET^DDSVAL(.11,DA,.01)),0,"DI")),U)="Y" D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Cannot create MUMPS cross references on archived files.")
  1.  Q
  1. TYPECHG ;Post action on change for Type (#.2)
  1.  N NAME,USE
  1.  S USE=$$GET^DDSVAL(.11,DA,.42) Q:USE]""
  1.  S NAME=$$GET^DDSVAL(.11,DA,.02)
  1.  I NAME]"",$E(NAME)'="A" D PUT^DDSVAL(.11,DA,.42,"LS","","I")
  1.  Q
  1.  ;
  1. NAMEVAL ;Validation for Name (#.02)
  1.  Q:$P(^DD("IX",DA,0),U,2)=X
  1.  I X="" D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Index Name is a required field.")
  1.  ;
  1.  N F01,TYPE
  1.  ;
  1.  S F01=$$GET^DDSVAL(.11,DA,.01)
  1.  I $D(^DD("IX","BB",F01,X)) D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' Index already exists.")
  1.  ;
  1.  I $D(^DD(F01,0,"IX",X)) D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"A"_$E("n","AEIOUaeiou"[$E(X))_" '"_X_"' cross-reference already exists.")
  1.  ;
  1.  I $E(X)="A",$D(^DD("KEY","AU",DA)) D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Uniqueness Index Name cannot start with 'A'.")
  1.  Q
  1.  ;
  1. NAMECHG ;Post action on change for Name (#.02)
  1.  N SORT1,SORT2,USE
  1.  S USE=$$GET^DDSVAL(.11,DA,.42)
  1.  S SORT1=$E(DDSOLD)="A",SORT2=$E(X)="A"
  1.  D:SORT1'=SORT2!(USE="") PUT^DDSVAL(.11,DA,.42,$S(SORT2:"S",1:"LS"),"","I")
  1.  D BLDLOG^DIKCFORM(DA)
  1.  Q
  1.  ;
  1. USEVAL ;Validation for Use (#.42)
  1.  N NAME,TYPE
  1.  S NAME=$$GET^DDSVAL(.11,DA,.02)
  1.  S TYPE=$$GET^DDSVAL(.11,DA,.2)
  1.  I NAME=""!(TYPE="") D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Please enter a NAME and TYPE for this Index.")
  1.  ;
  1.  I X="S" D:$E(NAME)'="A"
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Indexes used for Sorting Only must start with 'A'.")
  1.  E  I X="LS" D:$E(NAME)="A"
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Indexes used for Lookup & Sorting cannot start with 'A'.")
  1.  E  I TYPE="R" D
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Only MUMPS Indexes can be Action-type Indexes.")
  1.  E  I $E(NAME)'="A" D
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Action-type Indexes must start with 'A'.")
  1.  Q
  1.  ;
  1. VALLOG ;Called from data validation of logic fields
  1.  I $G(DUZ(0))'="@" D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"Only programmers are allowed to edit index logic.")
  1.  ;
  1.  I $$GET^DDSVAL(DIE,.DA,.2,"","I")'="MU" D  Q
  1.  . S DDSERROR=1
  1.  . D HLP^DDSUTL($C(7)_"You can modify the logic of only 'MUMPS' indexes.")
  1.  Q
  1.  ;
  1. BLDLOG(DIXR) ;Build the logic of the cross reference
  1.  ;Called from post actions of fields on form [DIKC EDIT]
  1.  N TYPE
  1.  S TYPE=$$GET^DDSVAL(.11,DIXR,.2)
  1.  I TYPE="MU" D UPDEXEC(DIXR) Q
  1.  ;
  1.  N FILE,NAME,RTYPE,RFILE
  1.  S FILE=$$GET^DDSVAL(.11,DIXR,.01)
  1.  S NAME=$$GET^DDSVAL(.11,DIXR,.02)
  1.  S RTYPE=$$GET^DDSVAL(.11,DIXR,.5)
  1.  S RFILE=$$GET^DDSVAL(.11,DIXR,.51)
  1.  ;
  1.  N LDIF,LEV,ROOT,WKILL
  1.  I FILE'=RFILE Q:RTYPE'="W"  S LDIF=$$FLEVDIFF^DIKCU(FILE,RFILE)
  1.  E  S LDIF=0
  1.  S ROOT=$$FROOTDA^DIKCU(FILE,LDIF_"O",.LEV)_""""_NAME_""""
  1.  S WKILL="K "_ROOT_")"
  1.  ;
  1.  N CNT,CRV,FCNT,MAXL,ORD,SBSC,VAL
  1.  S CRV(1)=DIXR
  1.  S CRV=0 F  S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV  D:$G(^(CRV,0))'?."^"
  1.  . S ORD=$$GET^DDSVAL(.114,.CRV,.01) Q:'ORD
  1.  . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1
  1.  . S CNT=$G(CNT)+1
  1.  . S SBSC=$$GET^DDSVAL(.114,.CRV,.5) Q:'SBSC
  1.  . S MAXL=$$GET^DDSVAL(.114,.CRV,6)
  1.  . S SBSC(SBSC)=ORD_U_MAXL
  1.  ;
  1.  S SBSC=0 F  S SBSC=$O(SBSC(SBSC)) Q:'SBSC  D
  1.  . S ORD=$P(SBSC(SBSC),U),MAXL=$P(SBSC(SBSC),U,2)
  1.  . I $G(CNT)=1 S VAL=$S(MAXL:"$E(X,1,"_MAXL_")",1:"X")
  1.  . E  S VAL=$S(MAXL:"$E(X("_ORD_"),1,"_MAXL_")",1:"X("_ORD_")")
  1.  . S ROOT=ROOT_","_VAL
  1.  ;
  1.  N L
  1.  F L=LDIF:-1:1 S ROOT=ROOT_",DA("_L_")"
  1.  S ROOT=ROOT_",DA)"
  1.  ;
  1.  N SET,KILL
  1.  I '$O(SBSC(0)) S (SET,KILL)="Q",WKILL=""
  1.  E  S SET="S "_ROOT_"=""""",KILL="K "_ROOT
  1.  D PUT^DDSVAL(.11,DIXR,1.1,SET)
  1.  D PUT^DDSVAL(.11,DIXR,2.1,KILL)
  1.  D PUT^DDSVAL(.11,DIXR,2.5,WKILL)
  1.  D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I")
  1.  Q
  1.  ;
  1. CRVTYPE ;Post-Action on change for Cross-Reference Value -> Type of Value
  1.  N DIKCIENS
  1.  S DIKCIENS=DA_","_DA(1)_","
  1.  ;
  1.  I X="F" D
  1.  . D REQ^DDSUTL("FILE",1,2.1,1,DIKCIENS)
  1.  . D REQ^DDSUTL("FIELD",1,2.1,1,DIKCIENS)
  1.  . D REQ^DDSUTL("COMPUTED CODE",1,2.2,0,DIKCIENS)
  1.  . D PUT^DDSVAL(DIE,.DA,4,"")
  1.  . D PUT^DDSVAL(DIE,.DA,4.5,"")
  1.  E  D
  1.  . D REQ^DDSUTL("FILE",1,2.1,0,DIKCIENS)
  1.  . D REQ^DDSUTL("FIELD",1,2.1,0,DIKCIENS)
  1.  . D REQ^DDSUTL("COMPUTED CODE",1,2.2,1,DIKCIENS)
  1.  . D PUT^DDSVAL(DIE,.DA,2,"")
  1.  . D PUT^DDSVAL(DIE,.DA,3,"")
  1.  ;
  1.  D UPDEXEC(DA(1))
  1.  Q
  1.  ;
  1. UPDEXEC(DIXR) ;Update Execution based on number of field-type xref values
  1.  N CRV,FCNT
  1.  S CRV(1)=DIXR,CRV=0
  1.  F  S CRV=$O(^DD("IX",DIXR,11.1,CRV)) Q:'CRV  D
  1.  . Q:'$$GET^DDSVAL(.114,.CRV,.01)
  1.  . S:$$GET^DDSVAL(.114,.CRV,1)="F" FCNT=$G(FCNT)+1
  1.  D PUT^DDSVAL(.11,DIXR,.4,$S($G(FCNT)>1:"R",1:"F"),"","I")
  1.  Q
  1.  ;
  1. BKPRE21 ;Pre-Action for block 'DIKC EDIT FIELD CRV'
  1.  N X
  1.  S X=$$GET^DDSVAL(DIE,.DA,5) D TRANS
  1.  Q
  1.  ;
  1. TRANS ;Post-Action on Change for Transform for Storage
  1.  N DIKCIENS
  1.  S DIKCIENS=DA_","_DA(1)_","
  1.  I X]"" D
  1.  . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,0,DIKCIENS)
  1.  E  D
  1.  . D PUT^DDSVAL(DIE,.DA,5.5,"")
  1.  . D UNED^DDSUTL("TRANSFORM FOR DISPLAY",1,2.1,1,DIKCIENS)
  1.  Q
  1.  ;
  1. VALFILE ;Data Validation for File
  1.  Q:X=""  Q:X=DDSOLD
  1.  N LDIF,RFILE
  1.  S RFILE=$$GET^DDSVAL(.11,DA,.51)
  1.  ;
  1.  I X'=RFILE D
  1.  . S LDIF=$$FLEVDIFF^DIKCU(X,RFILE)
  1.  . I LDIF="" D  Q
  1.  .. D HLP^DDSUTL($C(7)_"File must be a parent (ancestor) of Root File.")
  1.  .. S DDSERROR=1
  1.  . D:DDSOLD=RFILE PUT^DDSVAL(.11,DA,.5,"W","","I")
  1.  E  D:DDSOLD'=RFILE PUT^DDSVAL(.11,DA,.5,"I","","I")
  1.  Q
  1.  ;
  1. FORMDV ;Form-Level Data Validation
  1.  ;Check that Subscript Numbers are unique and consecutive from 1.
  1.  N DIKCDA,DIKCI,DIKCLIST,DIKCSS,DIKCSQ
  1.  ;
  1.  ;Build list DIKCLIST(ss#,ien) while checking for duplicates.
  1.  ;Also check that a file# is assigned for Field-type CRVs and that
  1.  ;they it is equal to root file.
  1.  S DIKCDA(1)=DA
  1.  S DIKCDA=0 F  S DIKCDA=$O(^DD("IX",DA,11.1,DIKCDA)) Q:'DIKCDA  D
  1.  . I $$GET^DDSVAL(.114,.DIKCDA,1)="F" D
  1.  .. N DIKCFIL,DIKCMSG,DIKCRF
  1.  .. S DIKCFIL=$$GET^DDSVAL(.114,.DIKCDA,2)
  1.  .. I DIKCFIL="" D
  1.  ... D:'$D(DDSERROR) MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES")
  1.  ... S DDSERROR=1
  1.  ... S DIKCMSG(1)="FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is missing."
  1.  ... S DIKCMSG(2)="  To correct the problem, press <RET> at the Order # on Page 2."
  1.  ... S DIKCMSG(3)="  In the resulting pop-up page, FILE will be filled in automatically."
  1.  ... S DIKCMSG(4)="  Try saving again."
  1.  ... D MSG^DDSUTL(.DIKCMSG)
  1.  .. E  S DIKCRF=$$GET^DDSVAL(.11,DA,.51) I DIKCFIL'=DIKCRF D
  1.  ... D:'$D(DDSERROR) MSG
  1.  ... S DDSERROR=1
  1.  ... D MSG^DDSUTL("FILE for Order #"_$$GET^DDSVAL(.114,.DIKCDA,.01)_" is not equal to the Root File: "_DIKCRF_".")
  1.  . S DIKCSS=$$GET^DDSVAL(.114,.DIKCDA,.5) Q:'DIKCSS
  1.  . I $D(DIKCLIST(DIKCSS)) D
  1.  .. D:'$D(DDSERROR) MSG
  1.  .. S DDSERROR=1
  1.  .. D MSG^DDSUTL("The subscript number "_DIKCSS_" is used more than once.")
  1.  . E  S DIKCLIST(DIKCSS,DIKCDA)=""
  1.  ;
  1.  ;If no duplicates, check that subscript numbers are consecutive from 1
  1.  I '$D(DDSERROR) D
  1.  . S DIKCSS=0
  1.  . F DIKCI=1:1 S DIKCSS=$O(DIKCLIST(DIKCSS)) Q:'DIKCSS!$G(DDSERROR)  D:DIKCSS'=DIKCI
  1.  .. S DDSERROR=1
  1.  .. D MSG
  1.  .. D MSG^DDSUTL("Subscript numbers must be consecutive numbers starting with 1.")
  1.  Q
  1.  ;
  1. MSG ;Print message
  1.  D MSG^DDSUTL($C(7)_"UNABLE TO SAVE CHANGES")
  1.  Q
  1.  ;
  1. POSTSV ;Post Save
  1.  ;Clean-up global (get rid of null nodes)
  1.  ;Kill DIKCREB, the flag that indicates that a crv was deleted, but
  1.  ;the logic wasn't yet saved.
  1.  N CRV,ND
  1.  S CRV=0 F  S CRV=$O(^DD("IX",DA,11.1,CRV)) Q:'CRV  D
  1.  . F ND=1.5,2,3 I $D(^DD("IX",DA,11.1,CRV,ND))#2,^(ND)="" K ^(ND)
  1.  K DIKCREB
  1.  Q