DDS02 ;SFISC/MKO - OVERFLOW FROM ^DDS01 ;24JUL2015
;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
;;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.
REFRESH(DDSPG) ;Refreshes the setup for page
N B,D,I,DIE,DDSDA,DDP
F B=0:0 S B=$O(@DDSREFT@(DDSPG,B)) Q:'B D
.I '$D(DDSDA) S DDSDA=^(B),DIE=^(B,DDSDA,"GL"),DDP=$P(@DDSREFS@(DDSPG,B),U,3) ;GET THE ORIGINAL PAGE DATA
.S D="" F S D=$O(@DDSREFT@(DDSPG,B,D)) Q:D="" I +$G(^(D))=1 S $P(^(D),U)=0 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE!
.S I="" F S I=$O(@DDSREFT@("F0",I)) Q:I="" F S D=$O(@DDSREFT@("F0",I,D)) Q:D="" I $P(D,",",2)=B,$G(^(D,"F"))=3 K @DDSREFT@("F0",I,D) ;KILL OLD FORM-ONLY VALUE
I $D(D) D EN^DDS1(DDSPG)
Q
;
;
;
SV ;Save
S DDACT="N"
I $G(DDSDN)=1,DDO D ERR3^DDS3 Q
I DDSSC'>1,'$P(DDSSC(DDSSC),U,4) D S^DDS3 Q ;INCLUDED '$G(DDSSEL)
D MSG^DDSMSG($$EZBLD^DIALOG(3093),1) ;**CANNOT SAVE
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"!($P($G(DDSU("DD")),U,2)["t") X $$OUTPUT^DIETLIBF(DDP,DDSFLD) S Y(0)=Y ;OUTPUT TRANSFORM
;
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($$EZBLD^DIALOG($S(DDSKEY:3092.2,1:3092.1)),1) ;'REQUIRED KEY FIELD'
;
S DY=$P(DIR0,U),DX=$P(DIR0,U,2)
REPNT I DDSEXT'=DDSX!$G(DDSREPNT) D K DDSREPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT
. 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)
;
CHECKEY I $G(DDSU("K")),DDSY]""!(DDSFLD'=.01) D Q:'$D(DDSY) ;CHECK KEY
. 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($$EZBLD^DIALOG(3094),1) ;"Another Entry already exists with this KEY value."
.. 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")="" ;CHANGE THE DATA!
K DDSY
Q
;
DEC(FILE,FIELD,DEC) ;NOT USED (??)
S DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$E(DEC,5,999)_")"
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
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDS02 3847 printed Oct 16, 2024@18:43:34 Page 2
DDS02 ;SFISC/MKO - OVERFLOW FROM ^DDS01 ;24JUL2015
+1 ;;22.2;VA FileMan;**2**;Jan 05, 2016;Build 139
+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.
REFRESH(DDSPG) ;Refreshes the setup for page
+1 NEW B,D,I,DIE,DDSDA,DDP
+2 FOR B=0:0
SET B=$ORDER(@DDSREFT@(DDSPG,B))
if 'B
QUIT
Begin DoDot:1
+3 ;GET THE ORIGINAL PAGE DATA
IF '$DATA(DDSDA)
SET DDSDA=^(B)
SET DIE=^(B,DDSDA,"GL")
SET DDP=$PIECE(@DDSREFS@(DDSPG,B),U,3)
+4 ;REMEMBER TO RELOAD BLOCKS ON THIS PAGE!
SET D=""
FOR
SET D=$ORDER(@DDSREFT@(DDSPG,B,D))
if D=""
QUIT
IF +$GET(^(D))=1
SET $PIECE(^(D),U)=0
+5 ;KILL OLD FORM-ONLY VALUE
SET I=""
FOR
SET I=$ORDER(@DDSREFT@("F0",I))
if I=""
QUIT
FOR
SET D=$ORDER(@DDSREFT@("F0",I,D))
if D=""
QUIT
IF $PIECE(D,",",2)=B
IF $GET(^(D,"F"))=3
KILL @DDSREFT@("F0",I,D)
End DoDot:1
+6 IF $DATA(D)
DO EN^DDS1(DDSPG)
+7 QUIT
+8 ;
+9 ;
+10 ;
SV ;Save
+1 SET DDACT="N"
+2 IF $GET(DDSDN)=1
IF DDO
DO ERR3^DDS3
QUIT
+3 ;INCLUDED '$G(DDSSEL)
IF DDSSC'>1
IF '$PIECE(DDSSC(DDSSC),U,4)
DO S^DDS3
QUIT
+4 ;**CANNOT SAVE
DO MSG^DDSMSG($$EZBLD^DIALOG(3093),1)
+5 QUIT
+6 ;
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 ;OUTPUT TRANSFORM
IF Y]""
IF $PIECE($GET(DDSU("DD")),U,2)["O"!($PIECE($GET(DDSU("DD")),U,2)["t")
XECUTE $$OUTPUT^DIETLIBF(DDP,DDSFLD)
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 ;'REQUIRED KEY FIELD'
DO MSG^DDSMSG($$EZBLD^DIALOG($SELECT(DDSKEY:3092.2,1:3092.1)),1)
End DoDot:1
if '$DATA(DDSY)
QUIT
+23 ;
+24 SET DY=$PIECE(DIR0,U)
SET DX=$PIECE(DIR0,U,2)
REPNT ;WRITE OUT NEW VALUE, IF IT DIFFERS FROM WHAT WAS INPUT
IF DDSEXT'=DDSX!$GET(DDSREPNT)
Begin DoDot:1
+1 XECUTE IOXY
+2 SET DDSX=$EXTRACT(DDSEXT,1,$PIECE(DIR0,U,3))
+3 IF '$PIECE(DIR0,U,6)
SET DDSX=DDSX_$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))
+4 IF '$TEST
SET DDSX=$JUSTIFY("",$PIECE(DIR0,U,3)-$LENGTH(DDSEXT))_DDSX
+5 WRITE $PIECE(DDGLVID,DDGLDEL)_DDSX_$PIECE(DDGLVID,DDGLDEL,10)
End DoDot:1
KILL DDSREPNT
+6 ;
CHECKEY ;CHECK KEY
IF $GET(DDSU("K"))
IF DDSY]""!(DDSFLD'=.01)
Begin DoDot:1
+1 NEW DDSFXR,DDSUI,DDSUNIQ,DDSVSV,DIIENS
+2 DO LOADXREF^DIKC1(DDP,"","",DDSU("K"),$NAME(@DDSREFT@("F"))_"_","DDSFXR")
+3 if $DATA(@DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D"))#2
SET DDSVSV=^("D")
SET ^("D")=DDSY
+4 SET DDSUNIQ=1
SET DDSUI=0
+5 FOR
SET DDSUI=$ORDER(DDSFXR(DDP,DDSUI))
if 'DDSUI
QUIT
Begin DoDot:2
+6 SET DIIENS=DDSDA
+7 DO SETXARR^DIKC(DDP,DDSUI,"DDSFXR","","D")
+8 SET DDSUNIQ=$$UNIQUE^DIKK2(DDP,DDSUI,.X,.DA,"DDSFXR")
End DoDot:2
if 'DDSUNIQ
QUIT
+9 IF 'DDSUNIQ
Begin DoDot:2
+10 KILL DDSY
+11 SET DDSCHKQ=1
SET DIR0("L")=DDSEXT
+12 ;"Another Entry already exists with this KEY value."
DO MSG^DDSMSG($$EZBLD^DIALOG(3094),1)
+13 KILL @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")
if $DATA(DDSVSV)#2
SET ^("D")=DDSVSV
End DoDot:2
End DoDot:1
if '$DATA(DDSY)
QUIT
+14 ;
+15 if $GET(DDSDA)!'$DATA(DDSREP)
Begin DoDot:1
+16 if $DATA(Y(0))
SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"X")=DDSEXT
+17 ;CHANGE THE DATA!
SET @DDSREFT@("F"_DDP,DDSDA,DDSFLD,"D")=DDSY
IF DDSY=""
IF $DATA(DDSU("X"))
SET ^("X")=""
End DoDot:1
+18 KILL DDSY
+19 QUIT
+20 ;
DEC(FILE,FIELD,DEC) ;NOT USED (??)
+1 SET DEC="S X=$G(@DDSREFT@(""F"_FILE_""",DIIENS,"_FIELD_",""D""),"_$EXTRACT(DEC,5,999)_")"
+2 QUIT
+3 ;
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
