SDECRPC ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
;
Q
;
;=================================================================
;
; Register/unregister RPCs within a given namespace to a context
REGNMSP(NMSP,CTX,DEL) ;EP
N RPC,IEN,LEN
S LEN=$L(NMSP),CTX=+$$GETOPT(CTX)
I $G(DEL) D
.S IEN=0
.F S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D
..I $E($G(^XWB(8994,IEN,0)),1,LEN)=NMSP,$$REGRPC(IEN,CTX,1)
E D
.Q:LEN<2
.S RPC=NMSP
.F D:$L(RPC) S RPC=$O(^XWB(8994,"B",RPC)) Q:NMSP'=$E(RPC,1,LEN)
..F IEN=0:0 S IEN=$O(^XWB(8994,"B",RPC,IEN)) Q:'IEN I $$REGRPC(IEN,.CTX)
Q
; Register/unregister an RPC to/from a context
; RPC = IEN or name of RPC
; CTX = IEN or name of context
; DEL = If nonzero, the RPC is unregistered (defaults to 0)
; Returns -1 if already registered; 0 if failed; 1 if succeeded
REGRPC(RPC,CTX,DEL) ;EP
S RPC=+$$GETRPC(RPC)
Q $S(RPC<1:0,1:$$REGMULT(19.05,"RPC",RPC,.CTX,.DEL))
; Add/remove a context to/from the ITEM multiple of another context.
REGCTX(SRC,DST,DEL) ;EP
S SRC=+$$GETOPT(SRC)
Q $S('SRC:0,1:$$REGMULT(19.01,10,SRC,.DST,.DEL))
; Add/delete an entry to/from a specified OPTION multiple.
; SFN = Subfile #
; NOD = Subnode for multiple
; ITM = Item IEN to add
; CTX = Option to add to
; DEL = Delete flag (optional)
REGMULT(SFN,NOD,ITM,CTX,DEL) ;
N FDA,IEN
S CTX=+$$GETOPT(CTX)
S DEL=+$G(DEL)
S IEN=+$O(^DIC(19,CTX,NOD,"B",ITM,0))
Q:'IEN=DEL -1
K ^TMP("DIERR",$J)
I DEL S FDA(SFN,IEN_","_CTX_",",.01)="@"
E S FDA(SFN,"+1,"_CTX_",",.01)=ITM
D UPDATE^DIE("","FDA")
S FDA='$D(^TMP("DIERR",$J)) K ^($J)
Q FDA
; Register a protocol to an extended action protocol
; Input: P-Parent protocol
; C-Child protocol
REGPROT(P,C,ERR) ;EP
N IENARY,PIEN,AIEN,FDA
D
.I '$L(P)!('$L(C)) S ERR="Missing input parameter" Q
.S IENARY(1)=$$FIND1^DIC(101,"","",P)
.S AIEN=$$FIND1^DIC(101,"","",C)
.I 'IENARY(1)!'AIEN S ERR="Unknown protocol name" Q
.S FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
.D UPDATE^DIE("S","FDA","IENARY","ERR")
Q:$Q $G(ERR)=""
Q
; Remove nonexistent RPCs from context
CLNRPC(CTX) ;EP
N IEN
S CTX=+$$GETOPT(CTX)
F IEN=0:0 S IEN=$O(^DIC(19,CTX,"RPC","B",IEN)) Q:'IEN D:'$D(^XWB(8994,IEN)) REGRPC(IEN,CTX,1)
Q
; Return IEN of option
GETOPT(X) ;EP
N Y
Q:X=+X X
S Y=$$FIND1^DIC(19,"","X",X)
W:'Y "Cannot find option "_X,!!
Q Y
; Return IEN of RPC
GETRPC(X) ;EP
N Y
Q:X=+X X
S Y=$$FIND1^DIC(8994,"","X",X)
W:'Y "Cannot find RPC "_X,!!
Q Y
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDECRPC 2580 printed Dec 13, 2024@02:52:32 Page 2
SDECRPC ;ALB/SAT - VISTA SCHEDULING RPCS ;JAN 15, 2016
+1 ;;5.3;Scheduling;**627**;Aug 13, 1993;Build 249
+2 ;
+3 QUIT
+4 ;
+5 ;=================================================================
+6 ;
+7 ; Register/unregister RPCs within a given namespace to a context
REGNMSP(NMSP,CTX,DEL) ;EP
+1 NEW RPC,IEN,LEN
+2 SET LEN=$LENGTH(NMSP)
SET CTX=+$$GETOPT(CTX)
+3 IF $GET(DEL)
Begin DoDot:1
+4 SET IEN=0
+5 FOR
SET IEN=$ORDER(^DIC(19,CTX,"RPC","B",IEN))
if 'IEN
QUIT
Begin DoDot:2
+6 IF $EXTRACT($GET(^XWB(8994,IEN,0)),1,LEN)=NMSP
IF $$REGRPC(IEN,CTX,1)
End DoDot:2
End DoDot:1
+7 IF '$TEST
Begin DoDot:1
+8 if LEN<2
QUIT
+9 SET RPC=NMSP
+10 FOR
if $LENGTH(RPC)
Begin DoDot:2
+11 FOR IEN=0:0
SET IEN=$ORDER(^XWB(8994,"B",RPC,IEN))
if 'IEN
QUIT
IF $$REGRPC(IEN,.CTX)
End DoDot:2
SET RPC=$ORDER(^XWB(8994,"B",RPC))
if NMSP'=$EXTRACT(RPC,1,LEN)
QUIT
End DoDot:1
+12 QUIT
+13 ; Register/unregister an RPC to/from a context
+14 ; RPC = IEN or name of RPC
+15 ; CTX = IEN or name of context
+16 ; DEL = If nonzero, the RPC is unregistered (defaults to 0)
+17 ; Returns -1 if already registered; 0 if failed; 1 if succeeded
REGRPC(RPC,CTX,DEL) ;EP
+1 SET RPC=+$$GETRPC(RPC)
+2 QUIT $SELECT(RPC<1:0,1:$$REGMULT(19.05,"RPC",RPC,.CTX,.DEL))
+3 ; Add/remove a context to/from the ITEM multiple of another context.
REGCTX(SRC,DST,DEL) ;EP
+1 SET SRC=+$$GETOPT(SRC)
+2 QUIT $SELECT('SRC:0,1:$$REGMULT(19.01,10,SRC,.DST,.DEL))
+3 ; Add/delete an entry to/from a specified OPTION multiple.
+4 ; SFN = Subfile #
+5 ; NOD = Subnode for multiple
+6 ; ITM = Item IEN to add
+7 ; CTX = Option to add to
+8 ; DEL = Delete flag (optional)
REGMULT(SFN,NOD,ITM,CTX,DEL) ;
+1 NEW FDA,IEN
+2 SET CTX=+$$GETOPT(CTX)
+3 SET DEL=+$GET(DEL)
+4 SET IEN=+$ORDER(^DIC(19,CTX,NOD,"B",ITM,0))
+5 if 'IEN=DEL
QUIT -1
+6 KILL ^TMP("DIERR",$JOB)
+7 IF DEL
SET FDA(SFN,IEN_","_CTX_",",.01)="@"
+8 IF '$TEST
SET FDA(SFN,"+1,"_CTX_",",.01)=ITM
+9 DO UPDATE^DIE("","FDA")
+10 SET FDA='$DATA(^TMP("DIERR",$JOB))
KILL ^($JOB)
+11 QUIT FDA
+12 ; Register a protocol to an extended action protocol
+13 ; Input: P-Parent protocol
+14 ; C-Child protocol
REGPROT(P,C,ERR) ;EP
+1 NEW IENARY,PIEN,AIEN,FDA
+2 Begin DoDot:1
+3 IF '$LENGTH(P)!('$LENGTH(C))
SET ERR="Missing input parameter"
QUIT
+4 SET IENARY(1)=$$FIND1^DIC(101,"","",P)
+5 SET AIEN=$$FIND1^DIC(101,"","",C)
+6 IF 'IENARY(1)!'AIEN
SET ERR="Unknown protocol name"
QUIT
+7 SET FDA(101.01,"?+2,"_IENARY(1)_",",.01)=AIEN
+8 DO UPDATE^DIE("S","FDA","IENARY","ERR")
End DoDot:1
+9 if $QUIT
QUIT $GET(ERR)=""
+10 QUIT
+11 ; Remove nonexistent RPCs from context
CLNRPC(CTX) ;EP
+1 NEW IEN
+2 SET CTX=+$$GETOPT(CTX)
+3 FOR IEN=0:0
SET IEN=$ORDER(^DIC(19,CTX,"RPC","B",IEN))
if 'IEN
QUIT
if '$DATA(^XWB(8994,IEN))
DO REGRPC(IEN,CTX,1)
+4 QUIT
+5 ; Return IEN of option
GETOPT(X) ;EP
+1 NEW Y
+2 if X=+X
QUIT X
+3 SET Y=$$FIND1^DIC(19,"","X",X)
+4 if 'Y
WRITE "Cannot find option "_X,!!
+5 QUIT Y
+6 ; Return IEN of RPC
GETRPC(X) ;EP
+1 NEW Y
+2 if X=+X
QUIT X
+3 SET Y=$$FIND1^DIC(8994,"","X",X)
+4 if 'Y
WRITE "Cannot find RPC "_X,!!
+5 QUIT Y