CIAURPC ;MSC/IND/DKM - RPC Encapsulations for CIAU routines ;04-May-2006 08:19;DKM
;;1.2;CIA UTILITIES;;Mar 20, 2007
;;Copyright 2000-2006, Medsphere Systems Corporation
;=================================================================
; RPC: CIAUDIC
DIC(CIADATA,CIABM,CIACMD,CIAARG) ;
S CIADATA(0)=$$ENTRY^CIAUDIC(CIABM,CIACMD)
Q
; RPC: CIAUSTX
MSYNTAX(CIADATA,CIACODE,CIAOPT) ;
S CIADATA=$$ENTRY^CIAUSTX(CIACODE,.CIAOPT)
Q
; RPC: Return a group of entries from a file
; CIAFN = File #
; CIAFROM = Starting entry (default is null)
; CIADIR = Direction (default = 1)
; CIASCN = Screening logic (optional)
; CIAMAX = Maximum entries (default = 20)
; CIAXRF = Cross reference (default = B)
FILGET(CIADATA,CIAFN,CIAFROM,CIADIR,CIASCN,CIAMAX,CIAXRF) ;
N CIAIEN,CIAGBL,CIATOT,Y
S CIAFROM=$G(CIAFROM),CIADIR=$S($G(CIADIR)<0:-1,1:1),CIAMAX=$G(CIAMAX,20),CIAXRF=$G(CIAXRF,"B"),CIASCN=$G(CIASCN),CIAGBL=$$ROOT^DILFD(CIAFN,,1),CIATOT=0
Q:'$L(CIAGBL)
F Q:CIATOT'<CIAMAX S CIAFROM=$O(@CIAGBL@(CIAXRF,CIAFROM),CIADIR),CIAIEN=0 Q:'$L(CIAFROM) D
.F S CIAIEN=$O(@CIAGBL@(CIAXRF,CIAFROM,CIAIEN)) Q:'CIAIEN D
..Q:'$D(@CIAGBL@(CIAIEN,0))
..I $L(CIASCN) S Y=CIAIEN X CIASCN E Q
..S CIATOT=CIATOT+1,@CIADATA@(CIATOT)=CIAIEN_U_CIAFROM
Q
; RPC: Show all or selected entries for a file
; CIAGBL = File # or closed global reference
; CIAIEN = Optional list of IENs to retrieve (default=ALL)
; May be passed as single IEN or array with IENs as subscripts
FILENT(CIADATA,CIAGBL,CIAIEN) ;
N CIAG,CIAX
S:CIAGBL=+CIAGBL CIAGBL=$$ROOT^DILFD(CIAGBL,,1)
S CIADATA=$$TMPGBL
Q:'$L(CIAGBL)
S:$G(CIAIEN) CIAIEN(+CIAIEN)=""
S CIAG=$S($D(CIAIEN):"CIAIEN",1:CIAGBL),CIAIEN=0
F S CIAIEN=$O(@CIAG@(CIAIEN)) Q:'CIAIEN D
.S CIAX=$P($G(@CIAGBL@(CIAIEN,0)),U)
.S:$L(CIAX) @CIADATA@(CIAIEN)=CIAIEN_U_CIAX
Q
; RPC: Show IEN of next/previous entry in a file
FILNXT(CIADATA,CIAGBL,CIAIEN) ;
N CIAD
S:CIAGBL=+CIAGBL CIAGBL=$$ROOT^DILFD(CIAGBL,,1)
I CIAIEN<0 S CIAIEN=-CIAIEN,CIAD=-1
E S CIAD=1
S CIADATA=+$O(@CIAGBL@(CIAIEN),CIAD)
Q
; RPC: Convert date input to FM format
STRTODAT(DATA,VAL,FMT) ;
N %DT,X,Y
I VAL'["@",VAL[" " S VAL=$TR(VAL," ","@")
I VAL["@",$TR($P(VAL,"@",2),":0")="" S $P(VAL,"@",2)="00:00:01"
S %DT=$G(FMT,"TS"),X=VAL
D ^%DT
S DATA=$S(Y>0:Y,1:"")
Q
; Return reference to temp global
TMPGBL(X) ;EP
K ^TMP("CIAURPC"_$G(X),$J) Q $NA(^($J))
; 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
CIAURPC ;MSC/IND/DKM - RPC Encapsulations for CIAU routines ;04-May-2006 08:19;DKM
+1 ;;1.2;CIA UTILITIES;;Mar 20, 2007
+2 ;;Copyright 2000-2006, Medsphere Systems Corporation
+3 ;=================================================================
+4 ; RPC: CIAUDIC
DIC(CIADATA,CIABM,CIACMD,CIAARG) ;
+1 SET CIADATA(0)=$$ENTRY^CIAUDIC(CIABM,CIACMD)
+2 QUIT
+3 ; RPC: CIAUSTX
MSYNTAX(CIADATA,CIACODE,CIAOPT) ;
+1 SET CIADATA=$$ENTRY^CIAUSTX(CIACODE,.CIAOPT)
+2 QUIT
+3 ; RPC: Return a group of entries from a file
+4 ; CIAFN = File #
+5 ; CIAFROM = Starting entry (default is null)
+6 ; CIADIR = Direction (default = 1)
+7 ; CIASCN = Screening logic (optional)
+8 ; CIAMAX = Maximum entries (default = 20)
+9 ; CIAXRF = Cross reference (default = B)
FILGET(CIADATA,CIAFN,CIAFROM,CIADIR,CIASCN,CIAMAX,CIAXRF) ;
+1 NEW CIAIEN,CIAGBL,CIATOT,Y
+2 SET CIAFROM=$GET(CIAFROM)
SET CIADIR=$SELECT($GET(CIADIR)<0:-1,1:1)
SET CIAMAX=$GET(CIAMAX,20)
SET CIAXRF=$GET(CIAXRF,"B")
SET CIASCN=$GET(CIASCN)
SET CIAGBL=$$ROOT^DILFD(CIAFN,,1)
SET CIATOT=0
+3 IF '$LENGTH(CIAGBL)
QUIT
+4 FOR
IF CIATOT'<CIAMAX
QUIT
SET CIAFROM=$ORDER(@CIAGBL@(CIAXRF,CIAFROM),CIADIR)
SET CIAIEN=0
IF '$LENGTH(CIAFROM)
QUIT
Begin DoDot:1
+5 FOR
SET CIAIEN=$ORDER(@CIAGBL@(CIAXRF,CIAFROM,CIAIEN))
IF 'CIAIEN
QUIT
Begin DoDot:2
+6 IF '$DATA(@CIAGBL@(CIAIEN,0))
QUIT
+7 IF $LENGTH(CIASCN)
SET Y=CIAIEN
XECUTE CIASCN
IF '$TEST
QUIT
+8 SET CIATOT=CIATOT+1
SET @CIADATA@(CIATOT)=CIAIEN_U_CIAFROM
End DoDot:2
End DoDot:1
+9 QUIT
+10 ; RPC: Show all or selected entries for a file
+11 ; CIAGBL = File # or closed global reference
+12 ; CIAIEN = Optional list of IENs to retrieve (default=ALL)
+13 ; May be passed as single IEN or array with IENs as subscripts
FILENT(CIADATA,CIAGBL,CIAIEN) ;
+1 NEW CIAG,CIAX
+2 IF CIAGBL=+CIAGBL
SET CIAGBL=$$ROOT^DILFD(CIAGBL,,1)
+3 SET CIADATA=$$TMPGBL
+4 IF '$LENGTH(CIAGBL)
QUIT
+5 IF $GET(CIAIEN)
SET CIAIEN(+CIAIEN)=""
+6 SET CIAG=$SELECT($DATA(CIAIEN):"CIAIEN",1:CIAGBL)
SET CIAIEN=0
+7 FOR
SET CIAIEN=$ORDER(@CIAG@(CIAIEN))
IF 'CIAIEN
QUIT
Begin DoDot:1
+8 SET CIAX=$PIECE($GET(@CIAGBL@(CIAIEN,0)),U)
+9 IF $LENGTH(CIAX)
SET @CIADATA@(CIAIEN)=CIAIEN_U_CIAX
End DoDot:1
+10 QUIT
+11 ; RPC: Show IEN of next/previous entry in a file
FILNXT(CIADATA,CIAGBL,CIAIEN) ;
+1 NEW CIAD
+2 IF CIAGBL=+CIAGBL
SET CIAGBL=$$ROOT^DILFD(CIAGBL,,1)
+3 IF CIAIEN<0
SET CIAIEN=-CIAIEN
SET CIAD=-1
+4 IF '$TEST
SET CIAD=1
+5 SET CIADATA=+$ORDER(@CIAGBL@(CIAIEN),CIAD)
+6 QUIT
+7 ; RPC: Convert date input to FM format
STRTODAT(DATA,VAL,FMT) ;
+1 NEW %DT,X,Y
+2 IF VAL'["@"
IF VAL[" "
SET VAL=$TRANSLATE(VAL," ","@")
+3 IF VAL["@"
IF $TRANSLATE($PIECE(VAL,"@",2),":0")=""
SET $PIECE(VAL,"@",2)="00:00:01"
+4 SET %DT=$GET(FMT,"TS")
SET X=VAL
+5 DO ^%DT
+6 SET DATA=$SELECT(Y>0:Y,1:"")
+7 QUIT
+8 ; Return reference to temp global
TMPGBL(X) ;EP
+1 KILL ^TMP("CIAURPC"_$GET(X),$JOB)
QUIT $NAME(^($JOB))
+2 ; 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
