DDR1 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/18/97 16:15
;;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
;
DIKC(DDROK,DDR) ; -- broker callback to kill a file entry via ^DIK
N DIK,DA,FILE,IENS,FDA
S FILE=$G(DDR("FILE"))
S IENS=$G(DDR("IENS"))
I $$FNO^DILIBF(FILE)=FILE,$L(IENS,",")=2 D Q
. S DIK=$G(^DIC(FILE,0,"GL")),DA=+IENS D ^DIK S DDROK=1
S FDA(FILE,IENS,.01)="@"
D FILE^DIE("","FDA")
S DDROK='$G(DIERR)
Q
;
LOCKC(DDROK,DDR) ; -- broker callback to lock/unlock a node
N DDRNODE
S DDRNODE=$G(DDR("NODE"))
IF DDRNODE]"" D
. IF $G(DDR("LOCKMODE")) D
. . L @("+"_DDRNODE_":"_$G(DDR("TIMEOUT"),5))
. . S DDROK=$T
. ELSE D
. . L @("-"_DDRNODE)
. . S DDROK=1
ELSE D
. S DDROK=0
Q
;
FILENOC(DDRFLNO,DDRNAME) ; -- broker callback to get File #
;
S DDRFLNO=+$O(^DIC("B",DDRNAME,""))
Q
;
NODEC(DDRNODE,DDRROOT) ; -- broker callback to get global node value
;
;S DDRNODE=$G(@DDRROOT)
IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D
. S DDRNODE="{{"_$D(@DDRROOT)_"}}"
IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D
. S DDRNODE=$G(@DDRROOT)
Q
;
GLCNT(DDROK,DDR) ; -- extrinsic call to invoke broker to return number of
; global nodes found at cross reference
N DDRNODE,DDRTEAM,DDRXREF
;
S DDRNODE=$G(DDR("ROOT"))
S DDRXREF=$G(DDR("XREF"))
S DDRVAL=$G(DDR("VALUE"))
;
S:DDRXREF="" DDRXREF="B"
S I="",X=0
F S I=$O(@DDRNODE@(DDRXREF,DDRVAL,I)) Q:I="" D
. S X=X+1
S DDROK=$G(X)
Q
;
IFNODE(DDRNODE,DDRROOT) ; -- extrinsic call to check if node exists.
; passes in full node reference
N X
;
IF $D(@DDRROOT)=0!($D(@DDRROOT)=10) D
. S DDRNODE="{{"_$D(@DDRROOT)_"}}"
IF $D(@DDRROOT)=1!($D(@DDRROOT)=11) D
. S DDRNODE=$G(@DDRROOT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HDDR1 2000 printed Apr 09, 2024@21:55:05 Page 2
DDR1 ;ALB/MJK-FileMan Delphi Components' RPCs ;4/18/97 16:15
+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 ;
DIKC(DDROK,DDR) ; -- broker callback to kill a file entry via ^DIK
+1 NEW DIK,DA,FILE,IENS,FDA
+2 SET FILE=$GET(DDR("FILE"))
+3 SET IENS=$GET(DDR("IENS"))
+4 IF $$FNO^DILIBF(FILE)=FILE
IF $LENGTH(IENS,",")=2
Begin DoDot:1
+5 SET DIK=$GET(^DIC(FILE,0,"GL"))
SET DA=+IENS
DO ^DIK
SET DDROK=1
End DoDot:1
QUIT
+6 SET FDA(FILE,IENS,.01)="@"
+7 DO FILE^DIE("","FDA")
+8 SET DDROK='$GET(DIERR)
+9 QUIT
+10 ;
LOCKC(DDROK,DDR) ; -- broker callback to lock/unlock a node
+1 NEW DDRNODE
+2 SET DDRNODE=$GET(DDR("NODE"))
+3 IF DDRNODE]""
Begin DoDot:1
+4 IF $GET(DDR("LOCKMODE"))
Begin DoDot:2
+5 LOCK @("+"_DDRNODE_":"_$GET(DDR("TIMEOUT"),5))
+6 SET DDROK=$TEST
End DoDot:2
+7 IF '$TEST
Begin DoDot:2
+8 LOCK @("-"_DDRNODE)
+9 SET DDROK=1
End DoDot:2
End DoDot:1
+10 IF '$TEST
Begin DoDot:1
+11 SET DDROK=0
End DoDot:1
+12 QUIT
+13 ;
FILENOC(DDRFLNO,DDRNAME) ; -- broker callback to get File #
+1 ;
+2 SET DDRFLNO=+$ORDER(^DIC("B",DDRNAME,""))
+3 QUIT
+4 ;
NODEC(DDRNODE,DDRROOT) ; -- broker callback to get global node value
+1 ;
+2 ;S DDRNODE=$G(@DDRROOT)
+3 IF $DATA(@DDRROOT)=0!($DATA(@DDRROOT)=10)
Begin DoDot:1
+4 SET DDRNODE="{{"_$DATA(@DDRROOT)_"}}"
End DoDot:1
+5 IF $DATA(@DDRROOT)=1!($DATA(@DDRROOT)=11)
Begin DoDot:1
+6 SET DDRNODE=$GET(@DDRROOT)
End DoDot:1
+7 QUIT
+8 ;
GLCNT(DDROK,DDR) ; -- extrinsic call to invoke broker to return number of
+1 ; global nodes found at cross reference
+2 NEW DDRNODE,DDRTEAM,DDRXREF
+3 ;
+4 SET DDRNODE=$GET(DDR("ROOT"))
+5 SET DDRXREF=$GET(DDR("XREF"))
+6 SET DDRVAL=$GET(DDR("VALUE"))
+7 ;
+8 if DDRXREF=""
SET DDRXREF="B"
+9 SET I=""
SET X=0
+10 FOR
SET I=$ORDER(@DDRNODE@(DDRXREF,DDRVAL,I))
if I=""
QUIT
Begin DoDot:1
+11 SET X=X+1
End DoDot:1
+12 SET DDROK=$GET(X)
+13 QUIT
+14 ;
IFNODE(DDRNODE,DDRROOT) ; -- extrinsic call to check if node exists.
+1 ; passes in full node reference
+2 NEW X
+3 ;
+4 IF $DATA(@DDRROOT)=0!($DATA(@DDRROOT)=10)
Begin DoDot:1
+5 SET DDRNODE="{{"_$DATA(@DDRROOT)_"}}"
End DoDot:1
+6 IF $DATA(@DDRROOT)=1!($DATA(@DDRROOT)=11)
Begin DoDot:1
+7 SET DDRNODE=$GET(@DDRROOT)
End DoDot:1
+8 QUIT
