DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;1:50 PM 16 Jul 1999 [ 04/02/2003 8:25 AM ]
;;22.0;VA FileMan;**1001**;APR 1, 2003
;;22.0;VA FileMan;**8,11**;Mar 30, 1999
;Per VHA Directive 10-93-142, this routine should not be modified.
UNED ;Change was made to uneditable field
D MSG^DDSMSG("No editing allowed.",1)
I $P($G(DDSO(0)),U,3)=2 N DDP S DDP=0
S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD S:$D(DDSU("X"))#2 ^("X")=DDSU("X")
Q
;
SV ;Save
S DDACT="N"
I $G(DDSDN)=1,DDO D ERR3^DDS3 Q
I DDSSC'>1,'$G(DDSSEL),'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q
N DDSEM
S DDSEM(1)="You cannot save changes at this level."
S DDSEM(2)="To close the current page, press <PF1>C."
D MSG^DDSMSG(.DDSEM,1)
Q
;
EXT ;Process external form
I '$P($G(DDSU("DD")),U,2),$P($G(DDSU("DD")),U,2)["P" D PT
I $P($G(DDSO(0)),U,3)=2,$E($P($G(DDSO(20)),U))="P" D PTFO
;
S:DDSOLD=Y DIR0N=1
S DDSX=X,DDSY=Y
I Y]"",$P($G(DDSU("DD")),U,2)["O",$G(^DD(DDP,DDSFLD,2))'?."^" K Y(0) X ^(2) S Y(0)=Y
;
S DDSEXT=$G(Y(0,0),$G(Y(0),Y)),X=DDSY
;
I $D(DDSO(14)) K DDSERROR X DDSO(14) I $D(DDSERROR)#2 D Q
. K DDSERROR,DDSY S DIR0("L")=DDSEXT,DDSCHKQ=1
;
I DDSY="",DDSFLD'=.01 D Q:'$D(DDSY)
. N DDSREQ,DDSKEY
. S DDSREQ=$P($G(DDSU("A")),U)
. S:DDSREQ="" DDSREQ=$P($G(DDSO(4)),U)
. S:DDSREQ="" DDSREQ=$P($G(DDSU("DD")),U,2)["R"
. S DDSKEY=$D(^DD("KEY","F",DDP,DDSFLD))>0
. I 'DDSREQ,'DDSKEY Q
. K DDSY
. S DDSCHKQ=1,DIR0("L")=DDSEXT
. D MSG^DDSMSG("This is a required "_$S(DDSKEY:"key ",1:"")_"field.",1)
;
S DY=$P(DIR0,U),DX=$P(DIR0,U,2)
I DDSEXT'=DDSX D
. X IOXY
. S DDSX=$E(DDSEXT,1,$P(DIR0,U,3))
. I '$P(DIR0,U,6) S DDSX=DDSX_$J("",$P(DIR0,U,3)-$L(DDSEXT))
. E S DDSX=$J("",$P(DIR0,U,3)-$L(DDSEXT))_DDSX
. W $P(DDGLVID,DDGLDEL)_DDSX_$P(DDGLVID,DDGLDEL,10)
;
I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY)
. N DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
. D LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NA(@DDSREFT@("F"))_"_","DDSFXR")
. S:$D(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2 DDSVSV=^("D") S ^("D")=DDSY
. S DDSUNIQ=1,DDSUI=0
. F S DDSUI=$O(DDSFXR(DDP,DDSUI)) Q:'DDSUI D Q:'DDSUNIQ
.. S DIIENS=DDSDA
.. D SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
.. S DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
. I 'DDSUNIQ D
.. K DDSY
.. S DDSCHKQ=1,DIR0("L")=DDSEXT
.. D MSG^DDSMSG("Another entry already exists with this key value.",1)
.. K @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D") S:$D(DDSVSV)#2 ^("D")=DDSVSV
;
D:$G(DDSDA)!'$D(DDSREP)
. S:$D(Y(0)) @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
. S @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY I DDSY="",$D(DDSU("X")) S ^("X")=""
K DDSY
Q
;
PT ;Modify Y for pointer type fields
I $P(Y,U,3)=1 D
. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,^("ADD",^("ADD"))=+Y_","_U_$P(DDSU("DD"),U,3)
S Y=$P(Y,U)
Q
;
PTFO ;Modify Y for pointer type form only fields
I $P(Y,U,3)=1 D
. N R,I S R=""
. F I=1:1 Q:$D(DA(I))[0 S R=R_DA(I)_","
. S ^("ADD")=$G(@DDSREFT@("ADD"))+1,@DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$S($P(DDSO(20),U,3):^DIC(+$P(DDSO(20),U,3),0,"GL"),1:U_$P($P(DDSO(20),U,3),":"))
S Y=$S(Y=-1:"",1:$P(Y,U))
Q
DDS02 ;SFISC/MKO-OVERFLOW FROM ^DDS01 ;1:50 PM 16 Jul 1999 [ 04/02/2003 8:25 AM ]
+1 ;;22.0;VA FileMan;**1001**;APR 1, 2003
+2 ;;22.0;VA FileMan;**8,11**;Mar 30, 1999
+3 ;Per VHA Directive 10-93-142, this routine should not be modified.
UNED ;Change was made to uneditable field
+1 DO MSG^DDSMSG("No editing allowed.",1)
+2 IF $PIECE($GET(DDSO(0)),U,3)=2
NEW DDP
SET DDP=0
+3 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSOLD
IF $DATA(DDSU("X"))#2
SET ^("X")=DDSU("X")
+4 QUIT
+5 ;
SV ;Save
+1 SET DDACT="N"
+2 IF $GET(DDSDN)=1
IF DDO
DO ERR3^DDS3
QUIT
+3 IF DDSSC'>1
IF '$GET(DDSSEL)
IF '$PIECE(DDSSC(DDSSC),U,4)
DO S^DDS3
QUIT
+4 NEW DDSEM
+5 SET DDSEM(1)="You cannot save changes at this level."
+6 SET DDSEM(2)="To close the current page, press <PF1>C."
+7 DO MSG^DDSMSG(.DDSEM,1)
+8 QUIT
+9 ;
EXT ;Process external form
+1 IF '$PIECE($GET(DDSU("DD")),U,2)
IF $PIECE($GET(DDSU("DD")),U,2)["P"
DO PT
+2 IF $PIECE($GET(DDSO(0)),U,3)=2
IF $EXTRACT($PIECE($GET(DDSO(20)),U))="P"
DO PTFO
+3 ;
+4 IF DDSOLD=Y
SET DIR0N=1
+5 SET DDSX=X
SET DDSY=Y
+6 IF Y]""
IF $PIECE($GET(DDSU("DD")),U,2)["O"
IF $GET(^DD(DDP,DDSFLD,2))'?."^"
KILL Y(0)
XECUTE ^(2)
SET Y(0)=Y
+7 ;
+8 SET DDSEXT=$GET(Y(0,0),$GET(Y(0),Y))
SET X=DDSY
+9 ;
+10 IF $DATA(DDSO(14))
KILL DDSERROR
XECUTE DDSO(14)
IF $DATA(DDSERROR)#2
Begin DoDot:1
+11 KILL DDSERROR,DDSY
SET DIR0("L")=DDSEXT
SET DDSCHKQ=1
End DoDot:1
QUIT
+12 ;
+13 IF DDSY=""
IF DDSFLD'=.01
Begin DoDot:1
+14 NEW DDSREQ,DDSKEY
+15 SET DDSREQ=$PIECE($GET(DDSU("A")),U)
+16 IF DDSREQ=""
SET DDSREQ=$PIECE($GET(DDSO(4)),U)
+17 IF DDSREQ=""
SET DDSREQ=$PIECE($GET(DDSU("DD")),U,2)["R"
+18 SET DDSKEY=$DATA(^DD("KEY","F",DDP,DDSFLD))>0
+19 IF 'DDSREQ
IF 'DDSKEY
QUIT
+20 KILL DDSY
+21 SET DDSCHKQ=1
SET DIR0("L")=DDSEXT
+22 DO MSG^DDSMSG("This is a required "_$SELECT(DDSKEY:"key ",1:"")_"field.",1)
End DoDot:1
IF '$DATA(DDSY)
QUIT
+23 ;
+24 SET DY=$PIECE(DIR0,U)
SET DX=$PIECE(DIR0,U,2)
+25 IF DDSEXT'=DDSX
Begin DoDot:1
+26 XECUTE IOXY
+27 SET DDSX=$EXTRACT(DDSEXT,1,$PIECE(DIR0,U,3))
+28 IF '$PIECE(DIR0,U,6)
SET DDSX=DDSX_$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))
+29 IF '$TEST
SET DDSX=$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))_DDSX
+30 WRITE $PIECE(DDGLVID,DDGLDEL)_DDSX_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
+31 ;
+32 IF $GET(DDSU("K"))
IF DDSY]""!(DDSFLD'=.01)
Begin DoDot:1
+33 NEW DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
+34 DO LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NAME(@DDSREFT@("F"))_"_","DDSFXR")
+35 IF $DATA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2
SET DDSVSV=^("D")
SET ^("D")=DDSY
+36 SET DDSUNIQ=1
SET DDSUI=0
+37 FOR
SET DDSUI=$ORDER(DDSFXR(DDP,DDSUI))
IF 'DDSUI
QUIT
Begin DoDot:2
+38 SET DIIENS=DDSDA
+39 DO SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
+40 SET DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
End DoDot:2
IF 'DDSUNIQ
QUIT
+41 IF 'DDSUNIQ
Begin DoDot:2
+42 KILL DDSY
+43 SET DDSCHKQ=1
SET DIR0("L")=DDSEXT
+44 DO MSG^DDSMSG("Another entry already exists with this key value.",1)
+45 KILL @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")
IF $DATA(DDSVSV)#2
SET ^("D")=DDSVSV
End DoDot:2
End DoDot:1
IF '$DATA(DDSY)
QUIT
+46 ;
+47 IF $GET(DDSDA)!'$DATA(DDSREP)
Begin DoDot:1
+48 IF $DATA(Y(0))
SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
+49 SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY
IF DDSY=""
IF $DATA(DDSU("X"))
SET ^("X")=""
End DoDot:1
+50 KILL DDSY
+51 QUIT
+52 ;
PT ;Modify Y for pointer type fields
+1 IF $PIECE(Y,U,3)=1
Begin DoDot:1
+2 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
SET ^("ADD",^("ADD"))=+Y_","_U_$PIECE(DDSU("DD"),U,3)
End DoDot:1
+3 SET Y=$PIECE(Y,U)
+4 QUIT
+5 ;
PTFO ;Modify Y for pointer type form only fields
+1 IF $PIECE(Y,U,3)=1
Begin DoDot:1
+2 NEW R,I
SET R=""
+3 FOR I=1:1
IF $DATA(DA(I))[0
QUIT
SET R=R_DA(I)_","
+4 SET ^("ADD")=$GET(@DDSREFT@("ADD"))+1
SET @DDSREFT@("ADD",@DDSREFT@("ADD"))=+Y_","_R_$SELECT($PIECE(DDSO(20),U,3):^DIC(+$PIECE(DDSO(20),U,3),0,"GL"),1:U_$PIECE($PIECE(DDSO(20),U,3),":"))
End DoDot:1
+5 SET Y=$SELECT(Y=-1:"",1:$PIECE(Y,U))
+6 QUIT
