XWBBRK2 ;ISC-SF/EG - DHCP BROKER PROTOYPE -
;;1.1;RPC BROKER;**5,67**;Mar 28, 1997;Build 5
;Per VA Directive 6402, this routine should not be modified.
;
CAPI(XWBY,TAG,NAM,PAR) ;make API call
N R,T,DX,DY
IF XWB(1,"FLAG")=2 D
. S PAR=$P(PAR,XWB("FRM"))_XWB("TO")_$P(PAR,XWB("FRM"),2)
S R=$S(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.XWBY)",1:TAG_"^"_NAM_"(.XWBY,"_PAR_")")
D:$D(XRTL) T0^%ZOSV ;start RTL
U XWBNULL
;
;start RUM for RPC
;P67-change "CAPI" to "RPC"
I $G(XWB(2,"RPC"))]"" D LOGRSRC^%ZOSV(XWB(2,"RPC"),2,1)
;
D @R
;
;restart RUM for handler
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
;
S:$D(XRT0) XRTN=XWB(2,"NAME") D:$D(XRT0) T1^%ZOSV ;stop RTL
;once call is completed, write buffer should be empty, make it so!
U XWBNULL S DX=0,DY=0 X ^%ZOSF("XY")
U XWBTDEV
Q
;
BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
N S,L
S S=""
S S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
S L=$L(S)
S S=$E("000"_L,$L(L)+1,$L(L)+3)_S
Q S
;
BARY(A,R,V) ;add array elements+values to storage array
IF A'["XWBS" Q "-1^ARRAY NAME MUST BE XWBS"
S @A@(R)=V
Q 0
;
BLDB(P) ;Build formatted string
N L
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDA(N,P) ;Build API string
;M Extrinsic Function
;Inputs
;N API name
;P Comma delimited parameter string
;Outputs
;String API string if successful, "-1^Text" if error
;
N I,F,L,T,U,T1,T2
IF '+$D(N) Q "-1^Required input reference is NULL"
S U="^"
S (F,T,Y)=0
IF '$D(P) S P=""
IF P'="" D
. S L=$L(P)-$L($TR(P,$C(44)))+1
. IF L=0 S L=1
. F I=1:1:L D Q:T
. . S T1=$P(P,",",I)
. . S T2=$E(T1,1,1)="."
. . IF T1=+T1 Q
. . IF $E(T1,1,1)="^" S F=2,T=1 Q
. . ;IF $E(T1,1,5)="$NA(^" S F=2,T=1 Q
. . IF T2&($E(T1,2,$L(T1))?.ANP) S F=1,T=1 Q
;IF P?.ANP1"."1A.ANP S F=1
S P=$$BLDB(P)
S L=$L(P)+$L(P)-3
S P=F_N_U_P
S L=$L(P)
Q $E("000"_L,$L(L)+1,$L(L)+3)_P
;
BLDS(R) ;Build a parameter string from an array
N L,T,Y
S Y=""
F D Q:R=""
. S R=$Q(@R)
. IF R="" Q
. S L=$L(R)+$L(@R)+1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S Y=Y_$E("000"_L,$L(L)+1,$L(L)+3)_R_"="_T
Q Y_"000"
;
BLDU(R) ;Build a parameter string from a scalar
N DONE,L,N,N1,P1
IF R=+R Q R
S N=$F(R,$C(34))
IF N=0 Q $C(34)_R_$C(34)
S P1=$E(R,1,N-2)
S (L,DONE)=0
F D Q:DONE
. S N1=$F(R,$C(34),N)
. IF N1=0 S L=$L(R)+2,N1=L
. S P1=P1_$C(34,34)_$E(R,N,N1-2)
. IF N1=L S DONE=1,P1=$C(34)_P1_$C(34) Q
. S N=N1
Q $TR(P1,$C(44),$C(23))
;
BLDG(R) ;build a parameter string from a global reference
N I,L,L1,M,T,T1,T2,Y
K ^TMP("XWB",$J)
IF '$D(R) Q "-1^Reference does not exist"
S Y=$NA(^TMP("XWB",$J,$P($H,",",2)))
S I=0
S M=512
S T1=$P(R,")")
S L1=$L($P(R,"("))
F D Q:R=""
. S R=$Q(@R)
. S T2=$F(R,"(")
. IF R=""!(R'[T1) Q
. S L=$L(R)+$L(@R)-L1
. S T=@R
. S T=$TR(T,$C(44),$C(23))
. S @Y@(I)=$E("000"_L,$L(L)+1,$L(L)+3)_"^("_$E(R,T2,M)_"="_$$BLDU(T)
. S I=I+1
S @Y@(I)="000"
S Y=$TR(Y,$C(44),$C(23))
Q Y
;
OARY() ;create storage array
N A,DONE,I
S (DONE,I)=0
F I=1:1 D Q:DONE
. S A="XWBS"_I
. K @A ;temp fix for single array
. IF '$D(@A) S DONE=1
;S Y("XWBS")=A
S @A="" ;set naked
Q A
;
CREF(R,P) ;Convert array contained in P to reference A
N I,X,DONE,F1,S
S DONE=0
S S=""
F I=1:1 D Q:DONE
. IF $P(P,",",I)="" S DONE=1 Q
. S X(I)=$P(P,",",I)
. IF X(I)?1"."1A.E D
. . S F1=$F(X(I),".")
. . S X(I)="."_R
. S S=S_X(I)_","
Q $E(S,1,$L(S)-1)
;
GETP(P) ;returns various parameters out of the Protocol string
N M,T,XWB
S M=512
S T=$$PRSP^XWBBRK(P)
IF '+T D
. S T=$$PRSM^XWBBRK(XWB(0,"MESG"))
. IF '+T S T=XWB(0,"WKID")_";"_XWB(0,"WINH")_";"_XWB(0,"PRCH")_";"_XWB(0,"WISH")_";"_$P(XWB(1,"TEXT"),"^")
Q T
;
CALLM(X,P,DEBUG) ;make call using Message string
N ERR,S
S X="",ERR=0
S ERR=$$PRSM^XWBBRK(P)
IF '+ERR S ERR=$$PRSA^XWBBRK(XWB(1,"TEXT"))
IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
IF 'DEBUG K XWB
K @(X("XWBS")),X("XWBS")
Q
;
CALLA(X,P,DEBUG) ;make call using API string
N ERR,S
S X="",ERR=0
S ERR=$$PRSA^XWBBRK(P)
IF '+ERR S S=$$PRSB^XWBBRK(XWB(2,"PARM"))
IF (+S=0)!(+S>0) D
. D CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
IF 'DEBUG K XWB
K @(X("XWBS")),X("XWBS")
Q
;
TRANSPRT() ;Determine the Transport Method
;DDP is local :=0
;TCP/IP is remote :=1
;Serial/RS-232 is remote :=2
Q 1
;Q 0 ;Do DDP for Now
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBBRK2 4495 printed Dec 13, 2024@02:37:08 Page 2
XWBBRK2 ;ISC-SF/EG - DHCP BROKER PROTOYPE -
+1 ;;1.1;RPC BROKER;**5,67**;Mar 28, 1997;Build 5
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
CAPI(XWBY,TAG,NAM,PAR) ;make API call
+1 NEW R,T,DX,DY
+2 IF XWB(1,"FLAG")=2
Begin DoDot:1
+3 SET PAR=$PIECE(PAR,XWB("FRM"))_XWB("TO")_$PIECE(PAR,XWB("FRM"),2)
End DoDot:1
+4 SET R=$SELECT(PAR'=+PAR&(PAR=""):TAG_"^"_NAM_"(.XWBY)",1:TAG_"^"_NAM_"(.XWBY,"_PAR_")")
+5 ;start RTL
if $DATA(XRTL)
DO T0^%ZOSV
+6 USE XWBNULL
+7 ;
+8 ;start RUM for RPC
+9 ;P67-change "CAPI" to "RPC"
+10 IF $GET(XWB(2,"RPC"))]""
DO LOGRSRC^%ZOSV(XWB(2,"RPC"),2,1)
+11 ;
+12 DO @R
+13 ;
+14 ;restart RUM for handler
+15 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+16 ;
+17 ;stop RTL
if $DATA(XRT0)
SET XRTN=XWB(2,"NAME")
if $DATA(XRT0)
DO T1^%ZOSV
+18 ;once call is completed, write buffer should be empty, make it so!
+19 USE XWBNULL
SET DX=0
SET DY=0
XECUTE ^%ZOSF("XY")
+20 USE XWBTDEV
+21 QUIT
+22 ;
BHDR(WKID,WINH,PRCH,WISH) ;Build a protocol header
+1 NEW S,L
+2 SET S=""
+3 SET S=WKID_";"_WINH_";"_PRCH_";"_WISH_";"
+4 SET L=$LENGTH(S)
+5 SET S=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_S
+6 QUIT S
+7 ;
BARY(A,R,V) ;add array elements+values to storage array
+1 IF A'["XWBS"
QUIT "-1^ARRAY NAME MUST BE XWBS"
+2 SET @A@(R)=V
+3 QUIT 0
+4 ;
BLDB(P) ;Build formatted string
+1 NEW L
+2 SET L=$LENGTH(P)
+3 QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P
+4 ;
BLDA(N,P) ;Build API string
+1 ;M Extrinsic Function
+2 ;Inputs
+3 ;N API name
+4 ;P Comma delimited parameter string
+5 ;Outputs
+6 ;String API string if successful, "-1^Text" if error
+7 ;
+8 NEW I,F,L,T,U,T1,T2
+9 IF '+$DATA(N)
QUIT "-1^Required input reference is NULL"
+10 SET U="^"
+11 SET (F,T,Y)=0
+12 IF '$DATA(P)
SET P=""
+13 IF P'=""
Begin DoDot:1
+14 SET L=$LENGTH(P)-$LENGTH($TRANSLATE(P,$CHAR(44)))+1
+15 IF L=0
SET L=1
+16 FOR I=1:1:L
Begin DoDot:2
+17 SET T1=$PIECE(P,",",I)
+18 SET T2=$EXTRACT(T1,1,1)="."
+19 IF T1=+T1
QUIT
+20 IF $EXTRACT(T1,1,1)="^"
SET F=2
SET T=1
QUIT
+21 ;IF $E(T1,1,5)="$NA(^" S F=2,T=1 Q
+22 IF T2&($EXTRACT(T1,2,$LENGTH(T1))?.ANP)
SET F=1
SET T=1
QUIT
End DoDot:2
if T
QUIT
End DoDot:1
+23 ;IF P?.ANP1"."1A.ANP S F=1
+24 SET P=$$BLDB(P)
+25 SET L=$LENGTH(P)+$LENGTH(P)-3
+26 SET P=F_N_U_P
+27 SET L=$LENGTH(P)
+28 QUIT $EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_P
+29 ;
BLDS(R) ;Build a parameter string from an array
+1 NEW L,T,Y
+2 SET Y=""
+3 FOR
Begin DoDot:1
+4 SET R=$QUERY(@R)
+5 IF R=""
QUIT
+6 SET L=$LENGTH(R)+$LENGTH(@R)+1
+7 SET T=@R
+8 SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))
+9 SET Y=Y_$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_R_"="_T
End DoDot:1
if R=""
QUIT
+10 QUIT Y_"000"
+11 ;
BLDU(R) ;Build a parameter string from a scalar
+1 NEW DONE,L,N,N1,P1
+2 IF R=+R
QUIT R
+3 SET N=$FIND(R,$CHAR(34))
+4 IF N=0
QUIT $CHAR(34)_R_$CHAR(34)
+5 SET P1=$EXTRACT(R,1,N-2)
+6 SET (L,DONE)=0
+7 FOR
Begin DoDot:1
+8 SET N1=$FIND(R,$CHAR(34),N)
+9 IF N1=0
SET L=$LENGTH(R)+2
SET N1=L
+10 SET P1=P1_$CHAR(34,34)_$EXTRACT(R,N,N1-2)
+11 IF N1=L
SET DONE=1
SET P1=$CHAR(34)_P1_$CHAR(34)
QUIT
+12 SET N=N1
End DoDot:1
if DONE
QUIT
+13 QUIT $TRANSLATE(P1,$CHAR(44),$CHAR(23))
+14 ;
BLDG(R) ;build a parameter string from a global reference
+1 NEW I,L,L1,M,T,T1,T2,Y
+2 KILL ^TMP("XWB",$JOB)
+3 IF '$DATA(R)
QUIT "-1^Reference does not exist"
+4 SET Y=$NAME(^TMP("XWB",$JOB,$PIECE($HOROLOG,",",2)))
+5 SET I=0
+6 SET M=512
+7 SET T1=$PIECE(R,")")
+8 SET L1=$LENGTH($PIECE(R,"("))
+9 FOR
Begin DoDot:1
+10 SET R=$QUERY(@R)
+11 SET T2=$FIND(R,"(")
+12 IF R=""!(R'[T1)
QUIT
+13 SET L=$LENGTH(R)+$LENGTH(@R)-L1
+14 SET T=@R
+15 SET T=$TRANSLATE(T,$CHAR(44),$CHAR(23))
+16 SET @Y@(I)=$EXTRACT("000"_L,$LENGTH(L)+1,$LENGTH(L)+3)_"^("_$EXTRACT(R,T2,M)_"="_$$BLDU(T)
+17 SET I=I+1
End DoDot:1
if R=""
QUIT
+18 SET @Y@(I)="000"
+19 SET Y=$TRANSLATE(Y,$CHAR(44),$CHAR(23))
+20 QUIT Y
+21 ;
OARY() ;create storage array
+1 NEW A,DONE,I
+2 SET (DONE,I)=0
+3 FOR I=1:1
Begin DoDot:1
+4 SET A="XWBS"_I
+5 ;temp fix for single array
KILL @A
+6 IF '$DATA(@A)
SET DONE=1
End DoDot:1
if DONE
QUIT
+7 ;S Y("XWBS")=A
+8 ;set naked
SET @A=""
+9 QUIT A
+10 ;
CREF(R,P) ;Convert array contained in P to reference A
+1 NEW I,X,DONE,F1,S
+2 SET DONE=0
+3 SET S=""
+4 FOR I=1:1
Begin DoDot:1
+5 IF $PIECE(P,",",I)=""
SET DONE=1
QUIT
+6 SET X(I)=$PIECE(P,",",I)
+7 IF X(I)?1"."1A.E
Begin DoDot:2
+8 SET F1=$FIND(X(I),".")
+9 SET X(I)="."_R
End DoDot:2
+10 SET S=S_X(I)_","
End DoDot:1
if DONE
QUIT
+11 QUIT $EXTRACT(S,1,$LENGTH(S)-1)
+12 ;
GETP(P) ;returns various parameters out of the Protocol string
+1 NEW M,T,XWB
+2 SET M=512
+3 SET T=$$PRSP^XWBBRK(P)
+4 IF '+T
Begin DoDot:1
+5 SET T=$$PRSM^XWBBRK(XWB(0,"MESG"))
+6 IF '+T
SET T=XWB(0,"WKID")_";"_XWB(0,"WINH")_";"_XWB(0,"PRCH")_";"_XWB(0,"WISH")_";"_$PIECE(XWB(1,"TEXT"),"^")
End DoDot:1
+7 QUIT T
+8 ;
CALLM(X,P,DEBUG) ;make call using Message string
+1 NEW ERR,S
+2 SET X=""
SET ERR=0
+3 SET ERR=$$PRSM^XWBBRK(P)
+4 IF '+ERR
SET ERR=$$PRSA^XWBBRK(XWB(1,"TEXT"))
+5 IF '+ERR
SET S=$$PRSB^XWBBRK(XWB(2,"PARM"))
+6 IF (+S=0)!(+S>0)
Begin DoDot:1
+7 DO CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
End DoDot:1
+8 IF 'DEBUG
KILL XWB
+9 KILL @(X("XWBS")),X("XWBS")
+10 QUIT
+11 ;
CALLA(X,P,DEBUG) ;make call using API string
+1 NEW ERR,S
+2 SET X=""
SET ERR=0
+3 SET ERR=$$PRSA^XWBBRK(P)
+4 IF '+ERR
SET S=$$PRSB^XWBBRK(XWB(2,"PARM"))
+5 IF (+S=0)!(+S>0)
Begin DoDot:1
+6 DO CAPI(.X,XWB(2,"RTAG"),XWB(2,"RNAM"),S)
End DoDot:1
+7 IF 'DEBUG
KILL XWB
+8 KILL @(X("XWBS")),X("XWBS")
+9 QUIT
+10 ;
TRANSPRT() ;Determine the Transport Method
+1 ;DDP is local :=0
+2 ;TCP/IP is remote :=1
+3 ;Serial/RS-232 is remote :=2
+4 QUIT 1
+5 ;Q 0 ;Do DDP for Now
