DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;24APR2013
;;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
;
FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback
N DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N
D PARSE(.DDR) S DDRVAL=$G(DDR("VALUE"))
S A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR")
S A=$S($G(DIERR):"",1:A)
S N=0 D SET(A)
I $G(DIERR) D ERROR Q
I $G(DDROPT)["R" S IEN=$S($G(DDRIENS)]"":A_DDRIENS,1:A_",") D RECALL^DILFD(DDRFILE,IEN,DUZ)
Q
;
GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback
N DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR
N DDRXREF,DDRSCRN,N
D PARSE(.DDR)
D GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR")
S N=0
I '$D(DDROPT) D 1,2 Q
I $G(DDROPT)["U" D 11,21
I $G(DDROPT)["?" D HLP
Q
1 I $D(DDRRSLT),'$G(DIERR) D SET("[Data]") F DDRFILE=0:0 S DDRFILE=$O(DDRRSLT(DDRFILE)) Q:'DDRFILE S DDRIENS="" F S DDRIENS=$O(DDRRSLT(DDRFILE,DDRIENS)) Q:DDRIENS="" D
. N DDRFIELD,X,J
. S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D
. . ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components.
. . S X=DDRFILE_"^"_$E(DDRIENS,1,$L(DDRIENS)-1)_"^"_DDRFIELD_"^"
. . ; -- below call to $$GET1 is too slow...working w/FM team for speed
. . ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D
. . ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <<Replaced by more generic check below.
. . I $P($G(^DD(+$P($G(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W" D
. . . D SET(X_"[WORD PROCESSING]")
. . . S J=0 F S J=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J)) Q:'J D
. . . . D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
. . . D SET("$$END$$")
. . E D
. . . D SET(X_$G(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))_"^"_$G(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")))
Q
11 N HD,I,E,B,J,K
D SET("[BEGIN_diDATA]")
S HD=DDRFILE_U_$E(DDRIENS,1,$L(DDRIENS)-1)
S I=DDRFLAGS["I",E=DDRFLAGS["E",B=(I&E)
S DDRFIELD=0 F S DDRFIELD=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD)) Q:'DDRFIELD D
. I $P($G(^DD(+$P($G(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W" D Q
. . S (K,J)=0 F S K=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,K)) Q:'K S J=J+1
. . D SET(HD_U_DDRFIELD_U_"W"_U_J)
. . S J=0 F S J=$O(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J)) Q:'J D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
. . Q
. S FLG=$S(B:"B",I:"I",1:"E")
. D SET(HD_U_DDRFIELD_U_FLG)
. I B D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")),SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I")) Q
. I E D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")) Q
. I I D SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I")) Q
D SET("[END_diDATA]")
Q
2 IF $D(DDRERR) D SET("[ERROR]")
Q
21 I $D(DIERR) D ERROR
Q
SET(X) ;
S N=N+1
S DDRDATA(N)=X
Q
HLP ;
N FLD,FLG,Z,%
S FLD=0,FLG="?"
D SET("[BEGIN_diHELP]")
F Z=1:1 S FLD=+$P(DDRFLDS,";",Z) Q:'FLD D HELP(DDRFILE,DDRIENS,FLD,FLG)
D SET("[END_diHELP]")
Q
;
GETHLPC(DDRDATA,DDR) ; DDR GET DD HELP rpc callback
N DDRFILE,DDRFIELD,DDRFLGS,N
S DDRFILE=$G(DDR("FILE"))
S DDRFIELD=$G(DDR("FIELD"))
S DDRFLGS=$G(DDR("FLAGS"))
S N=0
D SET("[BEGIN_diHELP]")
D HELP(DDRFILE,"",DDRFIELD,DDRFLGS)
D SET("[END_diHELP]")
Q
;
HELP(FILE,IENS,FIELD,FLGS) ;
N DDRHLP,HD,A
D HELP^DIE(FILE,IENS,FIELD,FLGS,"DDRHLP")
Q:'$D(DDRHLP("DIHELP"))
S HD=FILE_U_FIELD_U_"?"_U_DDRHLP("DIHELP") D SET(HD)
S A=0 F S A=$O(DDRHLP("DIHELP",A)) Q:'A D SET(DDRHLP("DIHELP",A))
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
PARSE(DDR) ;
S DDRFILE=$G(DDR("FILE"))
S DDRIENS=$G(DDR("IENS"))
S DDRFLDS=$G(DDR("FIELDS"))
S DDRFLAGS=$G(DDR("FLAGS"))
S DDRXREF=$G(DDR("XREF"))
S DDRSCRN=$G(DDR("SCREEN"))
S:$D(DDR("OPTIONS")) DDROPT=DDR("OPTIONS")
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDR2 4852 printed Apr 09, 2024@21:54:59 Page 2
DDR2 ;ALB/MJK-FileMan Delphi Components' RPCs ;24APR2013
+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 ;
FIND1C(DDRDATA,DDR) ; DDR FIND1 rpc callback
+1 NEW DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,DDRERR,A,IEN,N
+2 DO PARSE(.DDR)
SET DDRVAL=$GET(DDR("VALUE"))
+3 SET A=$$FIND1^DIC(DDRFILE,DDRIENS,DDRFLAGS,DDRVAL,DDRXREF,DDRSCRN,"DDRERR")
+4 SET A=$SELECT($GET(DIERR):"",1:A)
+5 SET N=0
DO SET(A)
+6 IF $GET(DIERR)
DO ERROR
QUIT
+7 IF $GET(DDROPT)["R"
SET IEN=$SELECT($GET(DDRIENS)]"":A_DDRIENS,1:A_",")
DO RECALL^DILFD(DDRFILE,IEN,DUZ)
+8 QUIT
+9 ;
GETSC(DDRDATA,DDR) ; DDR GETS ENTRY DATA rpc callback
+1 NEW DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,DDROPT,DDRRSLT,DDRERR
+2 NEW DDRXREF,DDRSCRN,N
+3 DO PARSE(.DDR)
+4 DO GETS^DIQ(DDRFILE,DDRIENS,DDRFLDS,DDRFLAGS,"DDRRSLT","DDRERR")
+5 SET N=0
+6 IF '$DATA(DDROPT)
DO 1
DO 2
QUIT
+7 IF $GET(DDROPT)["U"
DO 11
DO 21
+8 IF $GET(DDROPT)["?"
DO HLP
+9 QUIT
1 IF $DATA(DDRRSLT)
IF '$GET(DIERR)
DO SET("[Data]")
FOR DDRFILE=0:0
SET DDRFILE=$ORDER(DDRRSLT(DDRFILE))
if 'DDRFILE
QUIT
SET DDRIENS=""
FOR
SET DDRIENS=$ORDER(DDRRSLT(DDRFILE,DDRIENS))
if DDRIENS=""
QUIT
Begin DoDot:1
+1 NEW DDRFIELD,X,J
+2 SET DDRFIELD=0
FOR
SET DDRFIELD=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD))
if 'DDRFIELD
QUIT
Begin DoDot:2
+3 ;Do not remove stripping of ',' from IENS in line below if this code should work with T11 (21.1T1) of FM components.
+4 SET X=DDRFILE_"^"_$EXTRACT(DDRIENS,1,$LENGTH(DDRIENS)-1)_"^"_DDRFIELD_"^"
+5 ; -- below call to $$GET1 is too slow...working w/FM team for speed
+6 ;IF $$GET1^DID(DDRFILE,DDRFIELD,"","TYPE")="WORD-PROCESSING" D
+7 ;IF $P($G(^DD(DDRFILE,DDRFIELD,0)),U,4)[";0" D <<Replaced by more generic check below.
+8 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W"
Begin DoDot:3
+9 DO SET(X_"[WORD PROCESSING]")
+10 SET J=0
FOR
SET J=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
if 'J
QUIT
Begin DoDot:4
+11 DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
End DoDot:4
+12 DO SET("$$END$$")
End DoDot:3
+13 IF '$TEST
Begin DoDot:3
+14 DO SET(X_$GET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))_"^"_$GET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E")))
End DoDot:3
End DoDot:2
End DoDot:1
+15 QUIT
11 NEW HD,I,E,B,J,K
+1 DO SET("[BEGIN_diDATA]")
+2 SET HD=DDRFILE_U_$EXTRACT(DDRIENS,1,$LENGTH(DDRIENS)-1)
+3 SET I=DDRFLAGS["I"
SET E=DDRFLAGS["E"
SET B=(I&E)
+4 SET DDRFIELD=0
FOR
SET DDRFIELD=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD))
if 'DDRFIELD
QUIT
Begin DoDot:1
+5 IF $PIECE($GET(^DD(+$PIECE($GET(^DD(DDRFILE,DDRFIELD,0)),U,2),.01,0)),U,2)["W"
Begin DoDot:2
+6 SET (K,J)=0
FOR
SET K=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,K))
if 'K
QUIT
SET J=J+1
+7 DO SET(HD_U_DDRFIELD_U_"W"_U_J)
+8 SET J=0
FOR
SET J=$ORDER(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
if 'J
QUIT
DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,J))
+9 QUIT
End DoDot:2
QUIT
+10 SET FLG=$SELECT(B:"B",I:"I",1:"E")
+11 DO SET(HD_U_DDRFIELD_U_FLG)
+12 IF B
DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E"))
DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))
QUIT
+13 IF E
DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"E"))
QUIT
+14 IF I
DO SET(DDRRSLT(DDRFILE,DDRIENS,DDRFIELD,"I"))
QUIT
End DoDot:1
+15 DO SET("[END_diDATA]")
+16 QUIT
2 IF $DATA(DDRERR)
DO SET("[ERROR]")
+1 QUIT
21 IF $DATA(DIERR)
DO ERROR
+1 QUIT
SET(X) ;
+1 SET N=N+1
+2 SET DDRDATA(N)=X
+3 QUIT
HLP ;
+1 NEW FLD,FLG,Z,%
+2 SET FLD=0
SET FLG="?"
+3 DO SET("[BEGIN_diHELP]")
+4 FOR Z=1:1
SET FLD=+$PIECE(DDRFLDS,";",Z)
if 'FLD
QUIT
DO HELP(DDRFILE,DDRIENS,FLD,FLG)
+5 DO SET("[END_diHELP]")
+6 QUIT
+7 ;
GETHLPC(DDRDATA,DDR) ; DDR GET DD HELP rpc callback
+1 NEW DDRFILE,DDRFIELD,DDRFLGS,N
+2 SET DDRFILE=$GET(DDR("FILE"))
+3 SET DDRFIELD=$GET(DDR("FIELD"))
+4 SET DDRFLGS=$GET(DDR("FLAGS"))
+5 SET N=0
+6 DO SET("[BEGIN_diHELP]")
+7 DO HELP(DDRFILE,"",DDRFIELD,DDRFLGS)
+8 DO SET("[END_diHELP]")
+9 QUIT
+10 ;
HELP(FILE,IENS,FIELD,FLGS) ;
+1 NEW DDRHLP,HD,A
+2 DO HELP^DIE(FILE,IENS,FIELD,FLGS,"DDRHLP")
+3 if '$DATA(DDRHLP("DIHELP"))
QUIT
+4 SET HD=FILE_U_FIELD_U_"?"_U_DDRHLP("DIHELP")
DO SET(HD)
+5 SET A=0
FOR
SET A=$ORDER(DDRHLP("DIHELP",A))
if 'A
QUIT
DO SET(DDRHLP("DIHELP",A))
+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
PARSE(DDR) ;
+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 DDRXREF=$GET(DDR("XREF"))
+6 SET DDRSCRN=$GET(DDR("SCREEN"))
+7 if $DATA(DDR("OPTIONS"))
SET DDROPT=DDR("OPTIONS")
+8 QUIT
