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