DDR3 ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;2013-03-22 1:47 PM
;;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.
;
Q
;
FILEC(DDRDATA,DDRMODE,DDRROOT,DDRFLAGS,DDRIENS) ; DDR FILER rpc callback
N DDRRTN,DDRFDA,DDRERR,N,I
D FDASET(.DDRROOT,.DDRFDA)
; -- set up placeholder DINUM's if any
; -- NOTE: Can't use until multiple arrays can be passed by broker
I $D(DDRROOT("IENs")) M DDRIENS=DDRROOT("IENs")
SET DDRFLAGS=$SELECT($DATA(DDRFLAGS):DDRFLAGS,1:"")
SET I="" FOR SET I=$ORDER(DDRIENS(I)) QUIT:I="" SET DDRRTN(+I)=+DDRIENS(I)
IF DDRMODE="ADD" DO
. DO UPDATE^DIE(DDRFLAGS,"DDRFDA","DDRRTN","DDRERR")
ELSE DO
. DO FILE^DIE(DDRFLAGS,"DDRFDA","DDRERR")
S N=0
D SET("[Data]")
; -- send back info on entry #'s for placeholders
S I=0 F S I=$O(DDRRTN(I)) Q:'I D SET("+"_I_","_U_DDRRTN(I))
IF $D(DDRERR) D ERROR
Q
;
FDASET(DDRROOT,DDRFDA) ;
N DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
S I=0
F S I=$O(DDRROOT(I)) Q:'I S X=DDRROOT(I) D
. S DDRFILE=$P(X,U)
. S DDRFIELD=$P(X,U,2)
. S DDRIEN=$P(X,U,3)
. S DDRVAL=$P(X,U,4,99)
. D FDA^DILF(DDRFILE,DDRIEN_$S($E(DDRIEN,$L(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
Q
;
VALC(DDRDATA,DDR) ; DDR VALIDATOR rpc callback
N DDRFILE,DDRIENS,DDRFIELD,DDRVAL,DDRRSLT,DDRERR,DDRFLAGS,N
S DDRFLAGS="EH"
S DDRFILE=$G(DDR("FILE"))
S DDRIENS=$G(DDR("IENS"))
S DDRFIELD=$G(DDR("FIELD"))
S DDRVAL=$G(DDR("VALUE"))
D VAL^DIE(DDRFILE,DDRIENS,DDRFIELD,DDRFLAGS,DDRVAL,.DDRRSLT,"","DDRERR")
S N=0
D SET("[FILLER]")
D SET("[Data]")
D SET($G(DDRRSLT,U))
D SET($G(DDRRSLT(0)))
IF $D(DDRERR) D ERROR,HELP
Q
SET(X) ;
S N=N+1
S DDRDATA(N)=X
Q
HELP ;
Q:'$D(DDRERR("DIHELP"))
D SET("[BEGIN_diHELP]")
S HD=DDRFILE_U_DDRFIELD_U_"?"_U_DDRERR("DIHELP") D SET(HD)
N A S A=0 F S A=$O(DDRERR("DIHELP",A)) Q:'A D SET(DDRERR("DIHELP",A))
D SET("[END_diHELP]")
Q
ERROR ;
D SET("[BEGIN_diERRORS]")
N A S A=0 F S A=$O(DDRERR("DIERR",A)) Q:'A D
. N HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
. S HD=DDRERR("DIERR",A)
. I $D(DDRERR("DIERR",A,"PARAM",0)) D
. . S (B,D)=0 F C=1:1 S B=$O(DDRERR("DIERR",A,"PARAM",B)) Q:B="" D
. . . I B="FILE" S FILE=DDRERR("DIERR",A,"PARAM","FILE")
. . . I B="FIELD" S FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
. . . I B="IENS" S IENS=DDRERR("DIERR",A,"PARAM","IENS")
. . . S D=D+1,PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
. S C=0 F S C=$O(DDRERR("DIERR",A,"TEXT",C)) Q:'C S TEXT(C)=DDRERR("DIERR",A,"TEXT",C),TXTCNT=C
. S HD=HD_U_TXTCNT_U_$G(FILE)_U_$G(IENS)_U_$G(FIELD)_U_$G(D) D SET(HD)
. S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D SET(%)
. S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D SET(%)
. Q
D SET("[END_diERRORS]")
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDR3 3006 printed Nov 22, 2024@17:52:51 Page 2
DDR3 ;ALB/MJK,SF/DCM-FileMan Delphi Components' RPCs ;2013-03-22 1:47 PM
+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 QUIT
+8 ;
FILEC(DDRDATA,DDRMODE,DDRROOT,DDRFLAGS,DDRIENS) ; DDR FILER rpc callback
+1 NEW DDRRTN,DDRFDA,DDRERR,N,I
+2 DO FDASET(.DDRROOT,.DDRFDA)
+3 ; -- set up placeholder DINUM's if any
+4 ; -- NOTE: Can't use until multiple arrays can be passed by broker
+5 IF $DATA(DDRROOT("IENs"))
MERGE DDRIENS=DDRROOT("IENs")
+6 SET DDRFLAGS=$SELECT($DATA(DDRFLAGS):DDRFLAGS,1:"")
+7 SET I=""
FOR
SET I=$ORDER(DDRIENS(I))
if I=""
QUIT
SET DDRRTN(+I)=+DDRIENS(I)
+8 IF DDRMODE="ADD"
Begin DoDot:1
+9 DO UPDATE^DIE(DDRFLAGS,"DDRFDA","DDRRTN","DDRERR")
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 DO FILE^DIE(DDRFLAGS,"DDRFDA","DDRERR")
End DoDot:1
+12 SET N=0
+13 DO SET("[Data]")
+14 ; -- send back info on entry #'s for placeholders
+15 SET I=0
FOR
SET I=$ORDER(DDRRTN(I))
if 'I
QUIT
DO SET("+"_I_","_U_DDRRTN(I))
+16 IF $DATA(DDRERR)
DO ERROR
+17 QUIT
+18 ;
FDASET(DDRROOT,DDRFDA) ;
+1 NEW DDRFILE,DDRIEN,DDRFIELD,DDRVAL,DDRERR,I
+2 SET I=0
+3 FOR
SET I=$ORDER(DDRROOT(I))
if 'I
QUIT
SET X=DDRROOT(I)
Begin DoDot:1
+4 SET DDRFILE=$PIECE(X,U)
+5 SET DDRFIELD=$PIECE(X,U,2)
+6 SET DDRIEN=$PIECE(X,U,3)
+7 SET DDRVAL=$PIECE(X,U,4,99)
+8 DO FDA^DILF(DDRFILE,DDRIEN_$SELECT($EXTRACT(DDRIEN,$LENGTH(DDRIEN))'=",":",",1:""),DDRFIELD,"",DDRVAL,"DDRFDA","DDRERR")
End DoDot:1
+9 QUIT
+10 ;
VALC(DDRDATA,DDR) ; DDR VALIDATOR rpc callback
+1 NEW DDRFILE,DDRIENS,DDRFIELD,DDRVAL,DDRRSLT,DDRERR,DDRFLAGS,N
+2 SET DDRFLAGS="EH"
+3 SET DDRFILE=$GET(DDR("FILE"))
+4 SET DDRIENS=$GET(DDR("IENS"))
+5 SET DDRFIELD=$GET(DDR("FIELD"))
+6 SET DDRVAL=$GET(DDR("VALUE"))
+7 DO VAL^DIE(DDRFILE,DDRIENS,DDRFIELD,DDRFLAGS,DDRVAL,.DDRRSLT,"","DDRERR")
+8 SET N=0
+9 DO SET("[FILLER]")
+10 DO SET("[Data]")
+11 DO SET($GET(DDRRSLT,U))
+12 DO SET($GET(DDRRSLT(0)))
+13 IF $DATA(DDRERR)
DO ERROR
DO HELP
+14 QUIT
SET(X) ;
+1 SET N=N+1
+2 SET DDRDATA(N)=X
+3 QUIT
HELP ;
+1 if '$DATA(DDRERR("DIHELP"))
QUIT
+2 DO SET("[BEGIN_diHELP]")
+3 SET HD=DDRFILE_U_DDRFIELD_U_"?"_U_DDRERR("DIHELP")
DO SET(HD)
+4 NEW A
SET A=0
FOR
SET A=$ORDER(DDRERR("DIHELP",A))
if 'A
QUIT
DO SET(DDRERR("DIHELP",A))
+5 DO SET("[END_diHELP]")
+6 QUIT
ERROR ;
+1 DO SET("[BEGIN_diERRORS]")
+2 NEW A
SET A=0
FOR
SET A=$ORDER(DDRERR("DIERR",A))
if 'A
QUIT
Begin DoDot:1
+3 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
+4 SET HD=DDRERR("DIERR",A)
+5 IF $DATA(DDRERR("DIERR",A,"PARAM",0))
Begin DoDot:2
+6 SET (B,D)=0
FOR C=1:1
SET B=$ORDER(DDRERR("DIERR",A,"PARAM",B))
if B=""
QUIT
Begin DoDot:3
+7 IF B="FILE"
SET FILE=DDRERR("DIERR",A,"PARAM","FILE")
+8 IF B="FIELD"
SET FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
+9 IF B="IENS"
SET IENS=DDRERR("DIERR",A,"PARAM","IENS")
+10 SET D=D+1
SET PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
End DoDot:3
End DoDot:2
+11 SET C=0
FOR
SET C=$ORDER(DDRERR("DIERR",A,"TEXT",C))
if 'C
QUIT
SET TEXT(C)=DDRERR("DIERR",A,"TEXT",C)
SET TXTCNT=C
+12 SET HD=HD_U_TXTCNT_U_$GET(FILE)_U_$GET(IENS)_U_$GET(FIELD)_U_$GET(D)
DO SET(HD)
+13 SET B=0
FOR
SET B=$ORDER(PARAM(B))
if 'B
QUIT
SET %=PARAM(B)
DO SET(%)
+14 SET B=0
FOR
SET B=$ORDER(TEXT(B))
if 'B
QUIT
SET %=TEXT(B)
DO SET(%)
+15 QUIT
End DoDot:1
+16 DO SET("[END_diERRORS]")
+17 QUIT
+18 ;
