XWBBRK ;ISC-SF/EG - DHCP BROKER PROTOYPE ;07/08/2004 11:08
;;1.1;RPC BROKER;**2,4,10,16,26,35**;Mar 28, 1997
PRSP(P) ;Parse Protocol
;M Extrinsic Function
;
;Inputs
;P Protocol string with the form
; Protocol := Protocol Header^Message where
; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
; LLL := length of protocol header (3 numeric)
; WKID := Workstation ID (ALPHA)
; WINH := Window handle (ALPHA)
; PRCH := Process handle (ALPHA)
; WISH := Window server handle (ALPHA)
; MESG := Unparsed message
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N ERR,C,M,R,X,U
S U="U",R=0,C=";",ERR=0,M=512 ;Maximum buffer input
IF $E(P,1,5)="{XWB}" S P=$E(P,6,$L(P)) ;drop out prefix
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S XWB(R,"LENG")=+$E(P,1,3)
. S X=$E(P,4,XWB(R,"LENG")+3)
. S XWB(R,"MESG")=$E(P,XWB(R,"LENG")+4,M)
. S XWB(R,"WKID")=$P(X,C)
. S XWB(R,"WINH")=$P(X,C,2)
. S XWB(R,"PRCH")=$P(X,C,3)
. S XWB(R,"WISH")=$P(X,C,4)
Q ERR
;
PRSM(P) ;Parse message
;M Extrinsic Function
;
;Inputs
;P Message string with the form
; Message := Header^Content
; Header := LLL;FLAG
; LLL := length of entire message (3 numeric)
; FLAG := 1 indicates variables follow
; Content := Contains API call information
;Outputs
;ERR 0 for success, "-1^Text" if error
N C,ERR,M,R,X,U
S U="^",R=1,C=";",ERR=0,M=512 ;Max buffer
IF '+$G(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S XWB(R,"LENG")=+$E(P,1,5)
. S XWB(R,"FLAG")=$E(P,6,6)
. S XWB(R,"TEXT")=$E(P,7,M)
Q ERR
;
PRSA(P) ;Parse API information, get calling info
;M Extrinsic Function
;Inputs
;P Content := API Name^Param string
; API := .01 field of API file
; Param := Parameter information
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N C,DR,ERR,M,R,T,X,U
S U="^",R=2,C=";",ERR=0,M=512 ;Max buffer
IF '+$L(P) S ERR="-1^Required input reference is NULL"
IF +ERR=0 D
. S XWB(R,"CAPI")=$P(P,U)
. S XWB(R,"PARM")=$E(P,$F(P,U),M)
. S T=$O(^XWB(8994,"B",XWB(R,"CAPI"),0))
. I '+T S ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' doesn't exist on the server." Q ;P10 - dpc
. S T(0)=$G(^XWB(8994,T,0))
. I $P(T(0),U,6)=1!($P(T(0),U,6)=2) S ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' cannot be run at this time." Q ;P10. Check INACTIVE field. - dpc.
. S XWB(R,"NAME")=$P(T(0),"^")
. S XWB(R,"RTAG")=$P(T(0),"^",2)
. S XWB(R,"RNAM")=$P(T(0),"^",3)
. S XWBPTYPE=$P(T(0),"^",4)
. S XWBWRAP=+$P(T(0),"^",8)
Q ERR
;
PRSB(P) ;Parse Parameter information
;M Extrinsic Function
;Inputs
;P Param := M parameter list
; Param := LLL,Name,Value
; LLL := length of variable name and value
; Name := name of M variable
; Value := a string
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R
S R=3,MAXP=+$E(P,1,5)
S P1=$E(P,6,MAXP+5) ;only param string
S ERR=0,F=3,M=512
IF '+$D(P) S ERR="-1^Required input reference is NULL"
S FL=+$G(XWB(1,"FLAG"))
S I=0
IF '+ERR D
. ;IF 'FL S P1=$E(P,F+1,MAXP) Q
. IF 'FL,+MAXP=0 S P1="",ERR=1 Q
. F D Q:P1=""
. . Q:P1=""
. . S L=+$E(P1,1,3)-1
. . S P3=+$E(P1,4,4)
. . S P1=$E(P1,5,MAXP)
. . S XWB(R,"P",I)=$S(P3'=1:$E(P1,1,L),1:$$GETV($E(P1,1,L)))
. . IF FL=1,P3=2 D ;XWB*1.1*2
. . . S A=$$OARY^XWBBRK2,XWBARY=A
. . . S XWB(R,"P",I)=$$CREF^XWBBRK2(A,XWB(R,"P",I))
. . S P1=$E(P1,L+1,MAXP)
. . S K=I,I=I+1
. IF 'FL Q
. S P3=P
. S L=+$E(P3,1,5)
. S P1=$E(P3,F+3,L+F)
. ;IF FL=1 S P1=$$CREF^XWBBRK2(A,P1) ;convert array ref to namespace ref
. S P2=$E(P3,L+F+3,M)
. ;instantiate array
. ;S DM=0
. F D Q:+L=0
. . ;Sumtimes the array is null, so there isn't data for first read.
. . S L=+$$BREAD^XWBRW(3,15,1) Q:L=0 S P3=$$BREAD^XWBRW(L)
. . S L=+$$BREAD^XWBRW(3) IF L'=0 S P4=$$BREAD^XWBRW(L)
. . IF L=0 Q
. . IF P3=0,P4="" S L=0 Q ; P4=0 changed to P4="" JLI 021114
. . IF FL=1 D LINST(A,P3,P4)
. . IF FL=2 D GINST
IF ERR Q P1
S P1=""
D Q P1
. F I=0:1:K D
. . IF FL,$E(XWB(R,"P",I),1,5)=".XWBS" D Q ;XWB*1.1*2
. . . S P1=P1_"."_$E(XWB(R,"P",I),2,$L(XWB(R,"P",I)))
. . . IF I'=K S P1=P1_","
. . S P1=P1_"XWB("_R_",""P"","_I_")"
. . IF I'=K S P1=P1_","
IF '+ERR Q P1
Q ERR
;
CALLP(XWBP,P,DEBUG) ;make API call using Protocol string
;ERR will be 0 or "-1^text"
N ERR,S
S ERR=0
IF '$D(DEBUG) S DEBUG=0
;IF 'DEBUG D:$D(XRTL) T0^%ZOSV ;start RTL
S ERR=$$PRSP(P)
IF '+ERR S ERR=$$PRSM(XWB(0,"MESG"))
IF '+ERR S ERR=$$PRSA(XWB(1,"TEXT")) I $G(XWB(2,"CAPI"))="XUS SET SHARED" S XWBSHARE=1 Q
I +ERR S XWBSEC=$P(ERR,U,2) ;P10 -- dpc
IF '+ERR S S=$$PRSB(XWB(2,"PARM"))
;Check OK
I '+ERR D CHKPRMIT^XWBSEC(XWB(2,"CAPI")) ;checks if RPC allowed to run
S:$L($G(XWBSEC)) ERR="-1^"_XWBSEC
;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
IF '+ERR,(+S=0)!(+S>0) D
. ;Logging
. I $G(XWBDEBUG)>1 D LOG^XWBDLOG("RPC: "_XWB(2,"CAPI"))
. D CAPI^XWBBRK2(.XWBP,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
E D CLRBUF ;p10
IF 'DEBUG K XWB
IF $D(XWBARY) K @XWBARY,XWBARY
Q
;
LINST(A,X,XWBY) ;instantiate local array
IF XWBY=$C(1) S XWBY=""
S X=A_"("_X_")"
S @X=XWBY
Q
GINST ;instantiate global
N DONE,N,T,T1
S (DONE,I)=0
;find piece with global ref - recover $C(44)
S REF=$TR(REF,$C(23),$C(44))
F D Q:DONE
. S N=$NA(^TMP("XWB",$J,$P($H,",",2)))
. S XWB("FRM")=REF
. S XWB("TO")=N
. IF '$D(@N) S DONE=1 Q
;loop through all and instantiate
S DONE=0
F D Q:DONE
. S T=$E(@REF@(I),4,M)
. IF T="" S DONE=1 Q
. S @N@("XWB")="" ;set naked indicator
. S @T
. S I=I+1
K @N@("XWB")
Q
;
GETV(V) ;get value of V - reference parameter
N X
S X=V
IF $E(X,1,2)="$$" Q ""
IF $C(34,36)[$E(V) X "S V="_$$VCHK(V)
E S V=@V
Q V
;
VCHK(S) ;Parse string for first argument
N C,I,P
F I=1:1 S C=$E(S,I) D VCHKP:C="(",VCHKQ:C=$C(34) Q:" ,"[C
Q $E(S,1,I-1)
VCHKP S P=1 ;Find closing paren
F I=I+1:1 S C=$E(S,I) Q:P=0!(C="") I "()"""[C D VCHKQ:C=$C(34) S P=P+$S("("[C:1,")"[C:-1,1:0)
Q
VCHKQ ;Find closing quote
F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))
Q
CLRBUF ;p10 Empties Input buffer
N %
F R %#1:XWBTIME(1) Q:%=""
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBBRK 6517 printed Dec 13, 2024@02:37:07 Page 2
XWBBRK ;ISC-SF/EG - DHCP BROKER PROTOYPE ;07/08/2004 11:08
+1 ;;1.1;RPC BROKER;**2,4,10,16,26,35**;Mar 28, 1997
PRSP(P) ;Parse Protocol
+1 ;M Extrinsic Function
+2 ;
+3 ;Inputs
+4 ;P Protocol string with the form
+5 ; Protocol := Protocol Header^Message where
+6 ; Protocol Header := LLLWKID;WINH;PRCH;WISH;MESG
+7 ; LLL := length of protocol header (3 numeric)
+8 ; WKID := Workstation ID (ALPHA)
+9 ; WINH := Window handle (ALPHA)
+10 ; PRCH := Process handle (ALPHA)
+11 ; WISH := Window server handle (ALPHA)
+12 ; MESG := Unparsed message
+13 ;Outputs
+14 ;ERR 0 for success, "-1^Text" if error
+15 ;
+16 NEW ERR,C,M,R,X,U
+17 ;Maximum buffer input
SET U="U"
SET R=0
SET C=";"
SET ERR=0
SET M=512
+18 ;drop out prefix
IF $EXTRACT(P,1,5)="{XWB}"
SET P=$EXTRACT(P,6,$LENGTH(P))
+19 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+20 IF +ERR=0
Begin DoDot:1
+21 SET XWB(R,"LENG")=+$EXTRACT(P,1,3)
+22 SET X=$EXTRACT(P,4,XWB(R,"LENG")+3)
+23 SET XWB(R,"MESG")=$EXTRACT(P,XWB(R,"LENG")+4,M)
+24 SET XWB(R,"WKID")=$PIECE(X,C)
+25 SET XWB(R,"WINH")=$PIECE(X,C,2)
+26 SET XWB(R,"PRCH")=$PIECE(X,C,3)
+27 SET XWB(R,"WISH")=$PIECE(X,C,4)
End DoDot:1
+28 QUIT ERR
+29 ;
PRSM(P) ;Parse message
+1 ;M Extrinsic Function
+2 ;
+3 ;Inputs
+4 ;P Message string with the form
+5 ; Message := Header^Content
+6 ; Header := LLL;FLAG
+7 ; LLL := length of entire message (3 numeric)
+8 ; FLAG := 1 indicates variables follow
+9 ; Content := Contains API call information
+10 ;Outputs
+11 ;ERR 0 for success, "-1^Text" if error
+12 NEW C,ERR,M,R,X,U
+13 ;Max buffer
SET U="^"
SET R=1
SET C=";"
SET ERR=0
SET M=512
+14 IF '+$GET(P)
SET ERR="-1^Required input reference is NULL"
+15 IF +ERR=0
Begin DoDot:1
+16 SET XWB(R,"LENG")=+$EXTRACT(P,1,5)
+17 SET XWB(R,"FLAG")=$EXTRACT(P,6,6)
+18 SET XWB(R,"TEXT")=$EXTRACT(P,7,M)
End DoDot:1
+19 QUIT ERR
+20 ;
PRSA(P) ;Parse API information, get calling info
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;P Content := API Name^Param string
+4 ; API := .01 field of API file
+5 ; Param := Parameter information
+6 ;Outputs
+7 ;ERR 0 for success, "-1^Text" if error
+8 ;
+9 NEW C,DR,ERR,M,R,T,X,U
+10 ;Max buffer
SET U="^"
SET R=2
SET C=";"
SET ERR=0
SET M=512
+11 IF '+$LENGTH(P)
SET ERR="-1^Required input reference is NULL"
+12 IF +ERR=0
Begin DoDot:1
+13 SET XWB(R,"CAPI")=$PIECE(P,U)
+14 SET XWB(R,"PARM")=$EXTRACT(P,$FIND(P,U),M)
+15 SET T=$ORDER(^XWB(8994,"B",XWB(R,"CAPI"),0))
+16 ;P10 - dpc
IF '+T
SET ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' doesn't exist on the server."
QUIT
+17 SET T(0)=$GET(^XWB(8994,T,0))
+18 ;P10. Check INACTIVE field. - dpc.
IF $PIECE(T(0),U,6)=1!($PIECE(T(0),U,6)=2)
SET ERR="-1^Remote Procedure '"_XWB(R,"CAPI")_"' cannot be run at this time."
QUIT
+19 SET XWB(R,"NAME")=$PIECE(T(0),"^")
+20 SET XWB(R,"RTAG")=$PIECE(T(0),"^",2)
+21 SET XWB(R,"RNAM")=$PIECE(T(0),"^",3)
+22 SET XWBPTYPE=$PIECE(T(0),"^",4)
+23 SET XWBWRAP=+$PIECE(T(0),"^",8)
End DoDot:1
+24 QUIT ERR
+25 ;
PRSB(P) ;Parse Parameter information
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;P Param := M parameter list
+4 ; Param := LLL,Name,Value
+5 ; LLL := length of variable name and value
+6 ; Name := name of M variable
+7 ; Value := a string
+8 ;Outputs
+9 ;ERR 0 for success, "-1^Text" if error
+10 ;
+11 NEW A,ERR,F,FL,I,K,L,M,P1,P2,P3,P4,P5,MAXP,R
+12 SET R=3
SET MAXP=+$EXTRACT(P,1,5)
+13 ;only param string
SET P1=$EXTRACT(P,6,MAXP+5)
+14 SET ERR=0
SET F=3
SET M=512
+15 IF '+$DATA(P)
SET ERR="-1^Required input reference is NULL"
+16 SET FL=+$GET(XWB(1,"FLAG"))
+17 SET I=0
+18 IF '+ERR
Begin DoDot:1
+19 ;IF 'FL S P1=$E(P,F+1,MAXP) Q
+20 IF 'FL
IF +MAXP=0
SET P1=""
SET ERR=1
QUIT
+21 FOR
Begin DoDot:2
+22 if P1=""
QUIT
+23 SET L=+$EXTRACT(P1,1,3)-1
+24 SET P3=+$EXTRACT(P1,4,4)
+25 SET P1=$EXTRACT(P1,5,MAXP)
+26 SET XWB(R,"P",I)=$SELECT(P3'=1:$EXTRACT(P1,1,L),1:$$GETV($EXTRACT(P1,1,L)))
+27 ;XWB*1.1*2
IF FL=1
IF P3=2
Begin DoDot:3
+28 SET A=$$OARY^XWBBRK2
SET XWBARY=A
+29 SET XWB(R,"P",I)=$$CREF^XWBBRK2(A,XWB(R,"P",I))
End DoDot:3
+30 SET P1=$EXTRACT(P1,L+1,MAXP)
+31 SET K=I
SET I=I+1
End DoDot:2
if P1=""
QUIT
+32 IF 'FL
QUIT
+33 SET P3=P
+34 SET L=+$EXTRACT(P3,1,5)
+35 SET P1=$EXTRACT(P3,F+3,L+F)
+36 ;IF FL=1 S P1=$$CREF^XWBBRK2(A,P1) ;convert array ref to namespace ref
+37 SET P2=$EXTRACT(P3,L+F+3,M)
+38 ;instantiate array
+39 ;S DM=0
+40 FOR
Begin DoDot:2
+41 ;Sumtimes the array is null, so there isn't data for first read.
+42 SET L=+$$BREAD^XWBRW(3,15,1)
if L=0
QUIT
SET P3=$$BREAD^XWBRW(L)
+43 SET L=+$$BREAD^XWBRW(3)
IF L'=0
SET P4=$$BREAD^XWBRW(L)
+44 IF L=0
QUIT
+45 ; P4=0 changed to P4="" JLI 021114
IF P3=0
IF P4=""
SET L=0
QUIT
+46 IF FL=1
DO LINST(A,P3,P4)
+47 IF FL=2
DO GINST
End DoDot:2
if +L=0
QUIT
End DoDot:1
+48 IF ERR
QUIT P1
+49 SET P1=""
+50 Begin DoDot:1
+51 FOR I=0:1:K
Begin DoDot:2
+52 ;XWB*1.1*2
IF FL
IF $EXTRACT(XWB(R,"P",I),1,5)=".XWBS"
Begin DoDot:3
+53 SET P1=P1_"."_$EXTRACT(XWB(R,"P",I),2,$LENGTH(XWB(R,"P",I)))
+54 IF I'=K
SET P1=P1_","
End DoDot:3
QUIT
+55 SET P1=P1_"XWB("_R_",""P"","_I_")"
+56 IF I'=K
SET P1=P1_","
End DoDot:2
End DoDot:1
QUIT P1
+57 IF '+ERR
QUIT P1
+58 QUIT ERR
+59 ;
CALLP(XWBP,P,DEBUG) ;make API call using Protocol string
+1 ;ERR will be 0 or "-1^text"
+2 NEW ERR,S
+3 SET ERR=0
+4 IF '$DATA(DEBUG)
SET DEBUG=0
+5 ;IF 'DEBUG D:$D(XRTL) T0^%ZOSV ;start RTL
+6 SET ERR=$$PRSP(P)
+7 IF '+ERR
SET ERR=$$PRSM(XWB(0,"MESG"))
+8 IF '+ERR
SET ERR=$$PRSA(XWB(1,"TEXT"))
IF $GET(XWB(2,"CAPI"))="XUS SET SHARED"
SET XWBSHARE=1
QUIT
+9 ;P10 -- dpc
IF +ERR
SET XWBSEC=$PIECE(ERR,U,2)
+10 IF '+ERR
SET S=$$PRSB(XWB(2,"PARM"))
+11 ;Check OK
+12 ;checks if RPC allowed to run
IF '+ERR
DO CHKPRMIT^XWBSEC(XWB(2,"CAPI"))
+13 if $LENGTH($GET(XWBSEC))
SET ERR="-1^"_XWBSEC
+14 ;IF 'DEBUG S:$D(XRT0) XRTN="RPC BROKER READ/PARSE" D:$D(XRT0) T1^%ZOSV ;stop RTL
+15 IF '+ERR
IF (+S=0)!(+S>0)
Begin DoDot:1
+16 ;Logging
+17 IF $GET(XWBDEBUG)>1
DO LOG^XWBDLOG("RPC: "_XWB(2,"CAPI"))
+18 DO CAPI^XWBBRK2(.XWBP,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
End DoDot:1
+19 ;p10
IF '$TEST
DO CLRBUF
+20 IF 'DEBUG
KILL XWB
+21 IF $DATA(XWBARY)
KILL @XWBARY,XWBARY
+22 QUIT
+23 ;
LINST(A,X,XWBY) ;instantiate local array
+1 IF XWBY=$CHAR(1)
SET XWBY=""
+2 SET X=A_"("_X_")"
+3 SET @X=XWBY
+4 QUIT
GINST ;instantiate global
+1 NEW DONE,N,T,T1
+2 SET (DONE,I)=0
+3 ;find piece with global ref - recover $C(44)
+4 SET REF=$TRANSLATE(REF,$CHAR(23),$CHAR(44))
+5 FOR
Begin DoDot:1
+6 SET N=$NAME(^TMP("XWB",$JOB,$PIECE($HOROLOG,",",2)))
+7 SET XWB("FRM")=REF
+8 SET XWB("TO")=N
+9 IF '$DATA(@N)
SET DONE=1
QUIT
End DoDot:1
if DONE
QUIT
+10 ;loop through all and instantiate
+11 SET DONE=0
+12 FOR
Begin DoDot:1
+13 SET T=$EXTRACT(@REF@(I),4,M)
+14 IF T=""
SET DONE=1
QUIT
+15 ;set naked indicator
SET @N@("XWB")=""
+16 SET @T
+17 SET I=I+1
End DoDot:1
if DONE
QUIT
+18 KILL @N@("XWB")
+19 QUIT
+20 ;
GETV(V) ;get value of V - reference parameter
+1 NEW X
+2 SET X=V
+3 IF $EXTRACT(X,1,2)="$$"
QUIT ""
+4 IF $CHAR(34,36)[$EXTRACT(V)
XECUTE "S V="_$$VCHK(V)
+5 IF '$TEST
SET V=@V
+6 QUIT V
+7 ;
VCHK(S) ;Parse string for first argument
+1 NEW C,I,P
+2 FOR I=1:1
SET C=$EXTRACT(S,I)
if C="("
DO VCHKP
if C=$CHAR(34)
DO VCHKQ
if " ,"[C
QUIT
+3 QUIT $EXTRACT(S,1,I-1)
VCHKP ;Find closing paren
SET P=1
+1 FOR I=I+1:1
SET C=$EXTRACT(S,I)
if P=0!(C="")
QUIT
IF "()"""[C
if C=$CHAR(34)
DO VCHKQ
SET P=P+$SELECT("("[C:1,")"[C:-1,1:0)
+2 QUIT
VCHKQ ;Find closing quote
+1 FOR I=I+1:1
SET C=$EXTRACT(S,I)
if C=""!(C=$CHAR(34))
QUIT
+2 QUIT
CLRBUF ;p10 Empties Input buffer
+1 NEW %
+2 FOR
READ %#1:XWBTIME(1)
if %=""
QUIT
+3 QUIT
