DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;2013-03-22 1:46 PM
;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
;;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
FINDC(DDRDATA,DDR) ; -- broker callback to get list data
N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT
; -- parse array to parameters
D PARSE(.DDR)
S DDROUT=""
D FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
I $G(DDRFLAGS)["P" D
. Q:'$D(^TMP("DILIST",$J))
. N COUNT S COUNT=$G(^TMP("DILIST",$J,0)) Q:'COUNT D 1 ;added $G() ;p24
. I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP")
. K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(COUNT+1)="[END_diDATA]"
. Q
I $G(DDRFLAGS)'["P" D
. Q:'$D(^TMP("DILIST",$J))
. N COUNT S COUNT=$G(^TMP("DILIST",$J,0)) Q:'COUNT ;added $G() ;p24
. D 1,UNPACKED
. Q
D 3,4
Q
FINDI(DDRDATA,DDR) ; -- improved broker callback to find data,it can handle compound index
N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT
; -- parse array to parameters
D PARSE(.DDR)
IF DDRVAL[U DO
.N I,DDRTMP
.S DDRTMP=DDRVAL
.K DDRVAL
.F I=1:1:$L(DDRTMP,U) S DDRVAL(I)=$P(DDRTMP,U,I)
S DDROUT=""
D FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,.DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
I $G(DDRFLAGS)["P" D
. Q:'$D(^TMP("DILIST",$J))
. N COUNT S COUNT=$G(^TMP("DILIST",$J,0)) Q:'COUNT D 1 ;added $G() ;p24
. I XWBAPVER>1 S ^(.3)="[MAP]",^TMP("DILIST",$J,.4)=^TMP("DILIST",$J,0,"MAP")
. K ^TMP("DILIST",$J,0) S ^(.5)="[BEGIN_diDATA]",^(COUNT+1)="[END_diDATA]"
. Q
I $G(DDRFLAGS)'["P" D
. Q:'$D(^TMP("DILIST",$J))
. N COUNT S COUNT=$G(^TMP("DILIST",$J,0)) Q:'COUNT ;added $G() ;p24
. D 1,UNPACKED
. Q
D 3,4
Q
1 Q:'$P(COUNT,U,3)
S ^TMP("DILIST",$J,.1)="[Misc]",^(.2)="MORE"
Q
3 I $D(DIERR) D ERROR
Q
4 S DDRDATA=$NA(^TMP("DILIST",$J))
Q
PARSE(DDR) ; -- array parsing
S DDRFILE=$G(DDR("FILE"))
S DDRIENS=$G(DDR("IENS"))
S DDRFLDS=$G(DDR("FIELDS"))
S DDRFLAGS=$G(DDR("FLAGS"))
S DDRMAX=$G(DDR("MAX"),"*")
S DDRVAL=$G(DDR("VALUE"))
S DDRXREF=$G(DDR("XREF"))
S DDRSCRN=$G(DDR("SCREEN"))
S DDRID=$G(DDR("ID"))
S DDRROOT=$G(DDR("ROOT"))
S DDROPT=$G(DDR("OPTIONS"))
Q
ERROR ;
N I S I=1
D Z("[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 Z(HD)
. S B=0 F S B=$O(PARAM(B)) Q:'B S %=PARAM(B) D Z(%)
. S B=0 F S B=$O(TEXT(B)) Q:'B S %=TEXT(B) D Z(%)
. Q
D Z("[END_diERRORS]")
Q
Z(%) ;
S ^TMP("DILIST",$J,"ZERR",I)=%,I=I+1
Q
UNPACKED ;
K ^TMP("DILIST",$J,0)
S ^TMP("DILIST",$J,.5)="[BEGIN_diDATA]" K ^TMP("DILIST",$J,1)
S ^TMP("DILIST",$J,2,.1)="BEGIN_IENs",^(COUNT+1)="END_IENs"
I DDRFLDS]"",$D(^TMP("DILIST",$J,"ID")) D
. N Z,FLD,FLDCNT S Z=0,FLD="",FLDCNT=0
. F S Z=$O(^TMP("DILIST",$J,"ID",1,Z)) Q:'Z S FLD=FLD_Z_";",FLDCNT=FLDCNT+1
. Q:'FLDCNT
. S ^TMP("DILIST",$J,"ID",0)="BEGIN_IDVALUES",^(.1)=FLD_U_FLDCNT,^(COUNT+1)="END_IDVALUES"
E D
. N Z S Z=0 F S Z=$O(^TMP("DILIST",$J,"ID",Z)) Q:'Z K ^TMP("DILIST",$J,"ID",Z)
I $G(DDROPT)["WID",$D(^TMP("DILIST",$J,"ID","WRITE")) D
. N Z,N,I,IEN,WIDCNT S (N,I)=0
. M Z=^TMP("DILIST",$J,"ID","WRITE") K ^TMP("DILIST",$J,"ID","WRITE")
. S ^TMP("DILIST",$J,"ID","WID",0)="BEGIN_WIDVALUES",N=N+1
. F S I=$O(Z(I)) Q:'I S IEN=$G(^TMP("DILIST",$J,2,I)) D
. . N J S (J,WIDCNT)=0 F S J=$O(Z(I,J)) Q:'J S WIDCNT=WIDCNT+1
. . S ^TMP("DILIST",$J,"ID","WID",N)="WID"_U_IEN_U_WIDCNT,N=N+1
. . N J S J=0 F J=1:1:WIDCNT S ^TMP("DILIST",$J,"ID","WID",N)=Z(I,J),N=N+1
. S ^TMP("DILIST",$J,"ID","WID",N)="END_WIDVALUES"
I $G(DDROPT)'["WID" K ^TMP("DILIST",$J,"ID","WRITE")
S ^TMP("DILIST",$J,"IDZ")="[END_diDATA]"
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDR0 4638 printed Nov 22, 2024@17:52:48 Page 2
DDR0 ;SF/DCM-FileMan Delphi Components' RPCs ;2013-03-22 1:46 PM
+1 ;;22.2;VA FileMan;**24**;Jan 05, 2016;Build 3
+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
FINDC(DDRDATA,DDR) ; -- broker callback to get list data
+1 NEW DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT
+2 ; -- parse array to parameters
+3 DO PARSE(.DDR)
+4 SET DDROUT=""
+5 DO FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
+6 IF $GET(DDRFLAGS)["P"
Begin DoDot:1
+7 if '$DATA(^TMP("DILIST",$JOB))
QUIT
+8 ;added $G() ;p24
NEW COUNT
SET COUNT=$GET(^TMP("DILIST",$JOB,0))
if 'COUNT
QUIT
DO 1
+9 IF XWBAPVER>1
SET ^(.3)="[MAP]"
SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
+10 KILL ^TMP("DILIST",$JOB,0)
SET ^(.5)="[BEGIN_diDATA]"
SET ^(COUNT+1)="[END_diDATA]"
+11 QUIT
End DoDot:1
+12 IF $GET(DDRFLAGS)'["P"
Begin DoDot:1
+13 if '$DATA(^TMP("DILIST",$JOB))
QUIT
+14 ;added $G() ;p24
NEW COUNT
SET COUNT=$GET(^TMP("DILIST",$JOB,0))
if 'COUNT
QUIT
+15 DO 1
DO UNPACKED
+16 QUIT
End DoDot:1
+17 DO 3
DO 4
+18 QUIT
FINDI(DDRDATA,DDR) ; -- improved broker callback to find data,it can handle compound index
+1 NEW DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDRROOT,DDRERR,DDRRSLT,DDROPT,DDROUT
+2 ; -- parse array to parameters
+3 DO PARSE(.DDR)
+4 IF DDRVAL[U
Begin DoDot:1
+5 NEW I,DDRTMP
+6 SET DDRTMP=DDRVAL
+7 KILL DDRVAL
+8 FOR I=1:1:$LENGTH(DDRTMP,U)
SET DDRVAL(I)=$PIECE(DDRTMP,U,I)
End DoDot:1
+9 SET DDROUT=""
+10 DO FIND^DIC(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,.DDRVAL,DDRMAX,DDRXREF,DDRSCRN,DDRID,DDROUT,"DDRERR")
+11 IF $GET(DDRFLAGS)["P"
Begin DoDot:1
+12 if '$DATA(^TMP("DILIST",$JOB))
QUIT
+13 ;added $G() ;p24
NEW COUNT
SET COUNT=$GET(^TMP("DILIST",$JOB,0))
if 'COUNT
QUIT
DO 1
+14 IF XWBAPVER>1
SET ^(.3)="[MAP]"
SET ^TMP("DILIST",$JOB,.4)=^TMP("DILIST",$JOB,0,"MAP")
+15 KILL ^TMP("DILIST",$JOB,0)
SET ^(.5)="[BEGIN_diDATA]"
SET ^(COUNT+1)="[END_diDATA]"
+16 QUIT
End DoDot:1
+17 IF $GET(DDRFLAGS)'["P"
Begin DoDot:1
+18 if '$DATA(^TMP("DILIST",$JOB))
QUIT
+19 ;added $G() ;p24
NEW COUNT
SET COUNT=$GET(^TMP("DILIST",$JOB,0))
if 'COUNT
QUIT
+20 DO 1
DO UNPACKED
+21 QUIT
End DoDot:1
+22 DO 3
DO 4
+23 QUIT
1 if '$PIECE(COUNT,U,3)
QUIT
+1 SET ^TMP("DILIST",$JOB,.1)="[Misc]"
SET ^(.2)="MORE"
+2 QUIT
3 IF $DATA(DIERR)
DO ERROR
+1 QUIT
4 SET DDRDATA=$NAME(^TMP("DILIST",$JOB))
+1 QUIT
PARSE(DDR) ; -- array parsing
+1 SET DDRFILE=$GET(DDR("FILE"))
+2 SET DDRIENS=$GET(DDR("IENS"))
+3 SET DDRFLDS=$GET(DDR("FIELDS"))
+4 SET DDRFLAGS=$GET(DDR("FLAGS"))
+5 SET DDRMAX=$GET(DDR("MAX"),"*")
+6 SET DDRVAL=$GET(DDR("VALUE"))
+7 SET DDRXREF=$GET(DDR("XREF"))
+8 SET DDRSCRN=$GET(DDR("SCREEN"))
+9 SET DDRID=$GET(DDR("ID"))
+10 SET DDRROOT=$GET(DDR("ROOT"))
+11 SET DDROPT=$GET(DDR("OPTIONS"))
+12 QUIT
ERROR ;
+1 NEW I
SET I=1
+2 DO Z("[BEGIN_diERRORS]")
+3 NEW A
SET A=0
FOR
SET A=$ORDER(DDRERR("DIERR",A))
if 'A
QUIT
Begin DoDot:1
+4 NEW HD,PARAM,B,C,TEXT,TXTCNT,D,FILE,FIELD,IENS
+5 SET HD=DDRERR("DIERR",A)
+6 IF $DATA(DDRERR("DIERR",A,"PARAM",0))
Begin DoDot:2
+7 SET (B,D)=0
FOR C=1:1
SET B=$ORDER(DDRERR("DIERR",A,"PARAM",B))
if B=""
QUIT
Begin DoDot:3
+8 IF B="FILE"
SET FILE=DDRERR("DIERR",A,"PARAM","FILE")
+9 IF B="FIELD"
SET FIELD=DDRERR("DIERR",A,"PARAM","FIELD")
+10 IF B="IENS"
SET IENS=DDRERR("DIERR",A,"PARAM","IENS")
+11 SET D=D+1
SET PARAM(D)=B_U_DDRERR("DIERR",A,"PARAM",B)
End DoDot:3
End DoDot:2
+12 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
+13 SET HD=HD_U_TXTCNT_U_$GET(FILE)_U_$GET(IENS)_U_$GET(FIELD)_U_$GET(D)
DO Z(HD)
+14 SET B=0
FOR
SET B=$ORDER(PARAM(B))
if 'B
QUIT
SET %=PARAM(B)
DO Z(%)
+15 SET B=0
FOR
SET B=$ORDER(TEXT(B))
if 'B
QUIT
SET %=TEXT(B)
DO Z(%)
+16 QUIT
End DoDot:1
+17 DO Z("[END_diERRORS]")
+18 QUIT
Z(%) ;
+1 SET ^TMP("DILIST",$JOB,"ZERR",I)=%
SET I=I+1
+2 QUIT
UNPACKED ;
+1 KILL ^TMP("DILIST",$JOB,0)
+2 SET ^TMP("DILIST",$JOB,.5)="[BEGIN_diDATA]"
KILL ^TMP("DILIST",$JOB,1)
+3 SET ^TMP("DILIST",$JOB,2,.1)="BEGIN_IENs"
SET ^(COUNT+1)="END_IENs"
+4 IF DDRFLDS]""
IF $DATA(^TMP("DILIST",$JOB,"ID"))
Begin DoDot:1
+5 NEW Z,FLD,FLDCNT
SET Z=0
SET FLD=""
SET FLDCNT=0
+6 FOR
SET Z=$ORDER(^TMP("DILIST",$JOB,"ID",1,Z))
if 'Z
QUIT
SET FLD=FLD_Z_";"
SET FLDCNT=FLDCNT+1
+7 if 'FLDCNT
QUIT
+8 SET ^TMP("DILIST",$JOB,"ID",0)="BEGIN_IDVALUES"
SET ^(.1)=FLD_U_FLDCNT
SET ^(COUNT+1)="END_IDVALUES"
End DoDot:1
+9 IF '$TEST
Begin DoDot:1
+10 NEW Z
SET Z=0
FOR
SET Z=$ORDER(^TMP("DILIST",$JOB,"ID",Z))
if 'Z
QUIT
KILL ^TMP("DILIST",$JOB,"ID",Z)
End DoDot:1
+11 IF $GET(DDROPT)["WID"
IF $DATA(^TMP("DILIST",$JOB,"ID","WRITE"))
Begin DoDot:1
+12 NEW Z,N,I,IEN,WIDCNT
SET (N,I)=0
+13 MERGE Z=^TMP("DILIST",$JOB,"ID","WRITE")
KILL ^TMP("DILIST",$JOB,"ID","WRITE")
+14 SET ^TMP("DILIST",$JOB,"ID","WID",0)="BEGIN_WIDVALUES"
SET N=N+1
+15 FOR
SET I=$ORDER(Z(I))
if 'I
QUIT
SET IEN=$GET(^TMP("DILIST",$JOB,2,I))
Begin DoDot:2
+16 NEW J
SET (J,WIDCNT)=0
FOR
SET J=$ORDER(Z(I,J))
if 'J
QUIT
SET WIDCNT=WIDCNT+1
+17 SET ^TMP("DILIST",$JOB,"ID","WID",N)="WID"_U_IEN_U_WIDCNT
SET N=N+1
+18 NEW J
SET J=0
FOR J=1:1:WIDCNT
SET ^TMP("DILIST",$JOB,"ID","WID",N)=Z(I,J)
SET N=N+1
End DoDot:2
+19 SET ^TMP("DILIST",$JOB,"ID","WID",N)="END_WIDVALUES"
End DoDot:1
+20 IF $GET(DDROPT)'["WID"
KILL ^TMP("DILIST",$JOB,"ID","WRITE")
+21 SET ^TMP("DILIST",$JOB,"IDZ")="[END_diDATA]"
+22 QUIT
