- 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 Jan 18, 2025@03:53:40 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