XWBPRS ;ISF/STAFF - VISTA BROKER MSG PARSER ;08/11/15 09:49
;;1.1;RPC BROKER;**35,43,46,57,64,67**;Mar 28, 1997;Build 5
;Per VA Directive 6402, this routine should not be modified.
;
;XWB holds info from the message used by the RPC
CALLP(XWBP,XWBDEBUG) ;make API call using Protocol string
N ERR,S,XWBARY K XWB
S ERR=0
S ERR=$$PRSP("[XWB]") ;Read the rest of the protocol header
I '+ERR S ERR=$$PRSM ;Read and parse message
I $G(XWB(2,"RPC"))="XUS SET SHARED" S XWBSHARE=1 Q
I '+ERR S ERR=$$RPC ;Check the RPC
I +ERR S XWBSEC=$P(ERR,U,2) ;P10 -- dpc
I '+ERR D CHKPRMIT^XWBSEC($G(XWB(2,"RPC"))) ;checks if RPC allowed to run
S:$L($G(XWBSEC)) ERR="-1^"_XWBSEC
I '+ERR D
. D CAPI(.XWBP,XWB("PARAM"))
E I ($G(XWBTCMD)'="#BYE#") D LOG^XWBTCPM("Bad Msg"_ERR),CLRBUF
I 'XWBDEBUG K XWB
I $D(XWBARY) K @XWBARY,XWBARY
Q
;
PRSP(P) ;ef, Parse Protocol
;M Extrinsic Function
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N ERR,C,M,R,X
S R=0,C=";",ERR=0
S P=$$BREAD^XWBRW(4)
IF $L(P)'=4 S ERR="-1^Short Header info"
IF +ERR=0 D
. S XWB(R,"VER")=+$E(P,1)
. S XWB(R,"TYPE")=+$E(P,2)
. S (XWBENVL,XWB(R,"LENV"))=+$E(P,3)
. S (XWBPRT,XWB(R,"RT"))=+$E(P,4)
I XWBENVL<1 S (XWBENVL,XWB(R,"LENV"))=3
Q ERR
;
PRSM() ;ef, Parse message
;M Extrinsic Function
;See document on msg format
;Outputs
;ERR 0 for success, "-1^Text" if error
N C,EX1,ERR,R,X,CNK
S R=1,C=";",CNK=0,EX1=0 ;Max buffer
S ERR="-1^Invalid Chunk"
F S CNK=$$BREAD^XWBRW(1) Q:("12345"'[CNK) D Q:EX1
. S EX1=(CNK=5),@("ERR=$$PRS"_CNK)
Q ERR
;
PRS1() ;Parse the HEADER chunk
N %,L,R
S R=1
S XWB(R,"VER")=$$SREAD
S XWB(R,"RETURN")=$$SREAD
Q 0
;
PRS2() ;Parse the RPC chunk
N L,R
S R=2
S (XWBAPVER,XWB(R,"VER"))=$$SREAD ;RPC version
S XWB(R,"RPC")=$$SREAD
I $G(XWBDEBUG)>1 D LOG^XWBTCPM("RPC: "_XWB(R,"RPC"))
Q 0
PRS3() ;Parse the Security chunk
N L,R
S R=3
Q 0
PRS4() ;Parse the Command chunk
N R
S R=4,XWBTCMD=$$SREAD,XWB(R,"CMD")=XWBTCMD
I $G(XWBDEBUG)>1 D LOG^XWBTCPM("CMD: "_XWBTCMD)
Q ("TCPConnect^#BYE#"[XWBTCMD)
;
PRS5() ;Parse Data Parameter chunk
;M Extrinsic Function
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N CONT,DONE,ERR,F,FL,IX,K,L,MAXP,P1,P2,P3,P4,P5,R,TY,VA
S R=5,ERR=0,F=3,IX=0,DONE=0,CONT="f",XWB("PARAM")=""
F S:CONT="f" TY=$$BREAD^XWBRW(1) D Q:DONE S CONT=$$BREAD^XWBRW(1) S:CONT'="t" IX=IX+1
. K VA,P1
. IF TY=$C(4) S DONE=1 Q ;EOT
. IF TY=0 D Q ;literal
. . D LREAD("VA")
. . S XWB(R,"P",IX)=VA(1) D PARAM($NA(XWB(R,"P",IX)))
. . Q
. IF TY=1 D Q ;reference
. . D LREAD("VA")
. . S XWB(R,"P",IX)=$$GETV(VA(1)) D PARAM($NA(XWB(R,"P",IX)))
. . Q
. IF TY=2 D Q ;list
. . I CONT'="t" D
. . . S XWBARY=$$OARY,XWB(R,"P",IX)="."_XWBARY
. . . D PARAM(XWB(R,"P",IX))
. . D LREAD("P1") Q:P1(1)="" D LREAD("VA")
. . D LINST(XWBARY,P1(1),VA(1))
. . Q
. IF TY=3 D Q ;global
. . I CONT'="t" D
. . . S XWBARY=$NA(^TMP("XWBA",$J,IX)),XWB(R,"P",IX)=XWBARY
. . . K @XWBARY S @XWBARY=""
. . . D PARAM(XWBARY)
. . D LREAD("P1") Q:P1(1)="" D LREAD("VA")
. . D GINST(XWBARY,P1(1),VA(1))
. . Q
. IF TY=4 D Q ;empty - ,,
. . S XWB(R,"XWB",IX)=""
. . Q
. IF TY=5 D Q
. . ;stream still to be done
. Q ;End of loop
Q ERR
PARAM(NA) ;Add a new parameter to the list
N A
S A=$G(XWB("PARAM")) S:'$L(NA) NA="""""" ;Empty
S A=A_$S($L(A):",",1:"")_$S(TY=3:"$NA(",1:"")_NA_$S(TY=3:")",1:"")
S XWB("PARAM")=A
Q
;
RPC() ;Check the rpc information.
;M Extrinsic Function
;Outputs
;ERR 0 for success, "-1^Text" if error
;
N C,DR,ERR,M,R,RPC,T,X
S R=2,C=";",ERR=0,M=512 ;Max buffer
S RPC=$G(XWB(R,"RPC")) I '$L(RPC) Q "-1^No RPC sent"
S T=$O(^XWB(8994,"B",RPC,0))
I '+T Q "-1^Remote Procedure '"_RPC_"' doesn't exist on the server."
S T(0)=$G(^XWB(8994,T,0))
I $P(T(0),U,6)=1!($P(T(0),U,6)=2) Q "-1^Remote Procedure '"_RPC_"' cannot be run at this time."
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
;
SREAD() ;Read a S_PACK
N L,V7
S L=$$BREAD^XWBRW(1),L=$A(L)
S V7=$$BREAD^XWBRW(L)
Q V7
;
LREAD(ROOT) ;Read a L_PACK
N L,V7,I ;p45 Remove limit on length of string.
S I=1,@ROOT@(I)=""
S L=$$BREAD^XWBRW(XWBENVL),L=+L
I L>0 S V7=$$BREAD^XWBRW(L),@ROOT@(I)=V7,I=I+1
Q
;
;X can be something like '"TEXT",1,0'.
LINST(A,X,XWBY) ;instantiate local array
IF XWBY=$C(1) S XWBY=""
S X=A_"("_X_")"
S @X=XWBY
Q
;
;S can be something like '"TEXT",1,0'.
GINST(R,S,V) ;instantiate global
N N
I V=$C(1) S V=""
S N=$P(R,")")_","_S_")"
S @N=V
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 ;Empties Input buffer
N %
F R *%:2 Q:'$T!(%=4) ;!(%=-1)
Q
ZZZ(X) ;Convert
N I,J
F S I=$F(X,"$C(") Q:'I S J=$F(X,")",I),X=$E(X,1,I-4)_$C($E(X,I,J-2))_$E(X,J,999)
Q X
;
CAPI(XWBY,PAR) ;make API call
N XWBCALL,T,DX,DY
; ZEXCEPT: XWBFGTIM - created here, will be killed in STRTCVR2 or ONECOVER
; ZEXCEPT: XWBCSRPC - created here, will be killed in ONECOVER
; JLI 110606 next line checks for start call to Coversheet Timing
I XWB(2,"RTAG")="START",XWB(2,"RNAM")="ORWCV" I +$G(^KMPTMP("KMPD-CPRS")) S XWBFGTIM=$H D STRTCVR1 I 1
E I $G(XWBCOVER),$D(^TMP("XWBFGP",$J,"TODO",XWB(2,"RPC"))) S XWBFGTIM=$H,XWBCSRPC=XWB(2,"RPC")
S XWBCALL=XWB(2,"RTAG")_"^"_XWB(2,"RNAM")_"(.XWBY"_$S($L(PAR):","_PAR,1:"")_")",XWBCALL2=""
K PAR
O XWBNULL U XWBNULL ;p43 Make sure its open
;
I $G(XWBDEBUG)>2 D LOG^XWBDLOG("Call: "_$E(XWBCALL,1,247))
;start RUM for RPC
;P67-change "CAPI" to "RPC"
I $G(XWB(2,"RPC"))]"" D LOGRSRC^%ZOSV(XWB(2,"RPC"),2,1)
;
D @XWBCALL S XWBCALL2=XWBCALL ;Save call for debug
;
I $G(XWBCOVER),XWB(2,"RTAG")="START",XWB(2,"RNAM")="ORWCV" D STRTCVR2(XWBY) I 1
E I $D(XWBCOVER),$D(XWBCSRPC) D ONECOVER ; JLI 110606
;
;restart RUM for handler
D LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
;
U XWBTDEV
Q
;
OARY() ;create storage array
N A,DONE,I
S I=1+$G(XWB("ARRAY")),XWB("ARRAY")=I
S A="XWBS"_I
K @A ;temp fix for single array
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)
;
STRTCVR1 ; JLI 110606
; SET UP DATA FOR OBTAINING FOREGROUND PROCESSING TIMES FOR COVERSHEET LOADS
; REQUESTED FOR TIMING ON COMMODITY SERVERS, ETC.
N DFN,IP,HWND,NODE
; ZEXCEPT: XWBCOVER - created here, will be killed when foreground processing is complete
S XWBCOVER=1
K ^TMP("XWBFGP",$J)
S DFN=XWB(5,"P",0),IP=XWB(5,"P",1),HWND=XWB(5,"P",2)
S NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
S ^TMP("XWBFGP",$J,"NODE")=NODE ; SO WE CAN GET IT EASILY EACH PASS
S ^KMPTMP("KMPDT","ORWCV-FT",NODE)=XWBFGTIM_"^^"_$G(DUZ)_"^"_$G(IO("CLNM"))
Q
;
STRTCVR2(RETRNVAL) ; JLI 110606 - setup after coming back from initial start for coversheets
N XWBFGDIF,I
; the return value contains ids for coversheets to be handled in the foreground separated by commas
F I=1:1 S XWBCSID=$P(RETRNVAL,";",I) Q:XWBCSID="" D SETCSID(XWBCSID)
K XWBFGTIM
Q
;
SETCSID(XWBCSID) ; Obtain and setup selected coversheet ids for foreground processing
N I,RPC
; The coversheet ID value (XWBCSID) will be used for a look-up on the "AC" cross-reference of file 101.24.
; It is possible to have multiple entries with the same ID value, so checking that the 8th piece of the zero node of the value is a "C" will be required.
F I=0:0 S I=$O(^ORD(101.24,"AC",XWBCSID,I)) Q:I'>0 I $P(^ORD(101.24,I,0),U,8)="C" S RPC=$P(^(0),U,13),RPC=$P(^XWB(8994,RPC,0),U),^TMP("XWBFGP",$J,"TODO",RPC)=I Q
I $D(^TMP("XWBFGP",$J,"TODO","ORQQPX REMINDERS LIST")) D
.N XWBCSIEN S XWBCSIEN=^TMP("XWBFGP",$J,"TODO","ORQQPX REMINDERS LIST")
.S ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDERS APPLICABLE")=XWBCSIEN
.S ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDERS UNEVALUATED")=XWBCSIEN
.S ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDER CATEGORIES")=XWBCSIEN
.Q
Q
ONECOVER ; called after data is returned to client
I "^ORQQPXRM REMINDERS APPLICABLE^ORQQPXRM REMINDERS UNEVALUATED^ORQQPXRM REMINDER CATEGORIES^"[U_XWBCSRPC_U K ^TMP("XWBFGP",$J,"TODO","ORQQPX REMINDERS LIST")
I XWBCSRPC="ORQQPX REMINDERS LIST" D
.K ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDERS APPLICABLE")
.K ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDERS UNEVALUATED")
.K ^TMP("XWBFGP",$J,"TODO","ORQQPXRM REMINDER CATEGORIES")
.Q
;
K ^TMP("XWBFGP",$J,"TODO",XWBCSRPC),XWBCSRPC,XWBFGTIM
I '$D(^TMP("XWBFGP",$J,"TODO")) D ENDCOVER
Q
;
ENDCOVER ; no more cover sheets to process, so set final values, clean up
N I,NODE,X
S NODE=^TMP("XWBFGP",$J,"NODE")
S $P(^KMPTMP("KMPDT","ORWCV-FT",NODE),U,2)=$H
K XWBCOVER,^TMP("XWBFGP",$J)
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HXWBPRS 9406 printed Oct 16, 2024@18:37:57 Page 2
XWBPRS ;ISF/STAFF - VISTA BROKER MSG PARSER ;08/11/15 09:49
+1 ;;1.1;RPC BROKER;**35,43,46,57,64,67**;Mar 28, 1997;Build 5
+2 ;Per VA Directive 6402, this routine should not be modified.
+3 ;
+4 ;XWB holds info from the message used by the RPC
CALLP(XWBP,XWBDEBUG) ;make API call using Protocol string
+1 NEW ERR,S,XWBARY
KILL XWB
+2 SET ERR=0
+3 ;Read the rest of the protocol header
SET ERR=$$PRSP("[XWB]")
+4 ;Read and parse message
IF '+ERR
SET ERR=$$PRSM
+5 IF $GET(XWB(2,"RPC"))="XUS SET SHARED"
SET XWBSHARE=1
QUIT
+6 ;Check the RPC
IF '+ERR
SET ERR=$$RPC
+7 ;P10 -- dpc
IF +ERR
SET XWBSEC=$PIECE(ERR,U,2)
+8 ;checks if RPC allowed to run
IF '+ERR
DO CHKPRMIT^XWBSEC($GET(XWB(2,"RPC")))
+9 if $LENGTH($GET(XWBSEC))
SET ERR="-1^"_XWBSEC
+10 IF '+ERR
Begin DoDot:1
+11 DO CAPI(.XWBP,XWB("PARAM"))
End DoDot:1
+12 IF '$TEST
IF ($GET(XWBTCMD)'="#BYE#")
DO LOG^XWBTCPM("Bad Msg"_ERR)
DO CLRBUF
+13 IF 'XWBDEBUG
KILL XWB
+14 IF $DATA(XWBARY)
KILL @XWBARY,XWBARY
+15 QUIT
+16 ;
PRSP(P) ;ef, Parse Protocol
+1 ;M Extrinsic Function
+2 ;Outputs
+3 ;ERR 0 for success, "-1^Text" if error
+4 ;
+5 NEW ERR,C,M,R,X
+6 SET R=0
SET C=";"
SET ERR=0
+7 SET P=$$BREAD^XWBRW(4)
+8 IF $LENGTH(P)'=4
SET ERR="-1^Short Header info"
+9 IF +ERR=0
Begin DoDot:1
+10 SET XWB(R,"VER")=+$EXTRACT(P,1)
+11 SET XWB(R,"TYPE")=+$EXTRACT(P,2)
+12 SET (XWBENVL,XWB(R,"LENV"))=+$EXTRACT(P,3)
+13 SET (XWBPRT,XWB(R,"RT"))=+$EXTRACT(P,4)
End DoDot:1
+14 IF XWBENVL<1
SET (XWBENVL,XWB(R,"LENV"))=3
+15 QUIT ERR
+16 ;
PRSM() ;ef, Parse message
+1 ;M Extrinsic Function
+2 ;See document on msg format
+3 ;Outputs
+4 ;ERR 0 for success, "-1^Text" if error
+5 NEW C,EX1,ERR,R,X,CNK
+6 ;Max buffer
SET R=1
SET C=";"
SET CNK=0
SET EX1=0
+7 SET ERR="-1^Invalid Chunk"
+8 FOR
SET CNK=$$BREAD^XWBRW(1)
if ("12345"'[CNK)
QUIT
Begin DoDot:1
+9 SET EX1=(CNK=5)
SET @("ERR=$$PRS"_CNK)
End DoDot:1
if EX1
QUIT
+10 QUIT ERR
+11 ;
PRS1() ;Parse the HEADER chunk
+1 NEW %,L,R
+2 SET R=1
+3 SET XWB(R,"VER")=$$SREAD
+4 SET XWB(R,"RETURN")=$$SREAD
+5 QUIT 0
+6 ;
PRS2() ;Parse the RPC chunk
+1 NEW L,R
+2 SET R=2
+3 ;RPC version
SET (XWBAPVER,XWB(R,"VER"))=$$SREAD
+4 SET XWB(R,"RPC")=$$SREAD
+5 IF $GET(XWBDEBUG)>1
DO LOG^XWBTCPM("RPC: "_XWB(R,"RPC"))
+6 QUIT 0
PRS3() ;Parse the Security chunk
+1 NEW L,R
+2 SET R=3
+3 QUIT 0
PRS4() ;Parse the Command chunk
+1 NEW R
+2 SET R=4
SET XWBTCMD=$$SREAD
SET XWB(R,"CMD")=XWBTCMD
+3 IF $GET(XWBDEBUG)>1
DO LOG^XWBTCPM("CMD: "_XWBTCMD)
+4 QUIT ("TCPConnect^#BYE#"[XWBTCMD)
+5 ;
PRS5() ;Parse Data Parameter chunk
+1 ;M Extrinsic Function
+2 ;Outputs
+3 ;ERR 0 for success, "-1^Text" if error
+4 ;
+5 NEW CONT,DONE,ERR,F,FL,IX,K,L,MAXP,P1,P2,P3,P4,P5,R,TY,VA
+6 SET R=5
SET ERR=0
SET F=3
SET IX=0
SET DONE=0
SET CONT="f"
SET XWB("PARAM")=""
+7 FOR
if CONT="f"
SET TY=$$BREAD^XWBRW(1)
Begin DoDot:1
+8 KILL VA,P1
+9 ;EOT
IF TY=$CHAR(4)
SET DONE=1
QUIT
+10 ;literal
IF TY=0
Begin DoDot:2
+11 DO LREAD("VA")
+12 SET XWB(R,"P",IX)=VA(1)
DO PARAM($NAME(XWB(R,"P",IX)))
+13 QUIT
End DoDot:2
QUIT
+14 ;reference
IF TY=1
Begin DoDot:2
+15 DO LREAD("VA")
+16 SET XWB(R,"P",IX)=$$GETV(VA(1))
DO PARAM($NAME(XWB(R,"P",IX)))
+17 QUIT
End DoDot:2
QUIT
+18 ;list
IF TY=2
Begin DoDot:2
+19 IF CONT'="t"
Begin DoDot:3
+20 SET XWBARY=$$OARY
SET XWB(R,"P",IX)="."_XWBARY
+21 DO PARAM(XWB(R,"P",IX))
End DoDot:3
+22 DO LREAD("P1")
if P1(1)=""
QUIT
DO LREAD("VA")
+23 DO LINST(XWBARY,P1(1),VA(1))
+24 QUIT
End DoDot:2
QUIT
+25 ;global
IF TY=3
Begin DoDot:2
+26 IF CONT'="t"
Begin DoDot:3
+27 SET XWBARY=$NAME(^TMP("XWBA",$JOB,IX))
SET XWB(R,"P",IX)=XWBARY
+28 KILL @XWBARY
SET @XWBARY=""
+29 DO PARAM(XWBARY)
End DoDot:3
+30 DO LREAD("P1")
if P1(1)=""
QUIT
DO LREAD("VA")
+31 DO GINST(XWBARY,P1(1),VA(1))
+32 QUIT
End DoDot:2
QUIT
+33 ;empty - ,,
IF TY=4
Begin DoDot:2
+34 SET XWB(R,"XWB",IX)=""
+35 QUIT
End DoDot:2
QUIT
+36 IF TY=5
Begin DoDot:2
+37 ;stream still to be done
End DoDot:2
QUIT
+38 ;End of loop
QUIT
End DoDot:1
if DONE
QUIT
SET CONT=$$BREAD^XWBRW(1)
if CONT'="t"
SET IX=IX+1
+39 QUIT ERR
PARAM(NA) ;Add a new parameter to the list
+1 NEW A
+2 ;Empty
SET A=$GET(XWB("PARAM"))
if '$LENGTH(NA)
SET NA=""""""
+3 SET A=A_$SELECT($LENGTH(A):",",1:"")_$SELECT(TY=3:"$NA(",1:"")_NA_$SELECT(TY=3:")",1:"")
+4 SET XWB("PARAM")=A
+5 QUIT
+6 ;
RPC() ;Check the rpc information.
+1 ;M Extrinsic Function
+2 ;Outputs
+3 ;ERR 0 for success, "-1^Text" if error
+4 ;
+5 NEW C,DR,ERR,M,R,RPC,T,X
+6 ;Max buffer
SET R=2
SET C=";"
SET ERR=0
SET M=512
+7 SET RPC=$GET(XWB(R,"RPC"))
IF '$LENGTH(RPC)
QUIT "-1^No RPC sent"
+8 SET T=$ORDER(^XWB(8994,"B",RPC,0))
+9 IF '+T
QUIT "-1^Remote Procedure '"_RPC_"' doesn't exist on the server."
+10 SET T(0)=$GET(^XWB(8994,T,0))
+11 IF $PIECE(T(0),U,6)=1!($PIECE(T(0),U,6)=2)
QUIT "-1^Remote Procedure '"_RPC_"' cannot be run at this time."
+12 SET XWB(R,"RTAG")=$PIECE(T(0),"^",2)
+13 SET XWB(R,"RNAM")=$PIECE(T(0),"^",3)
+14 SET XWBPTYPE=$PIECE(T(0),"^",4)
+15 SET XWBWRAP=+$PIECE(T(0),"^",8)
+16 QUIT ERR
+17 ;
SREAD() ;Read a S_PACK
+1 NEW L,V7
+2 SET L=$$BREAD^XWBRW(1)
SET L=$ASCII(L)
+3 SET V7=$$BREAD^XWBRW(L)
+4 QUIT V7
+5 ;
LREAD(ROOT) ;Read a L_PACK
+1 ;p45 Remove limit on length of string.
NEW L,V7,I
+2 SET I=1
SET @ROOT@(I)=""
+3 SET L=$$BREAD^XWBRW(XWBENVL)
SET L=+L
+4 IF L>0
SET V7=$$BREAD^XWBRW(L)
SET @ROOT@(I)=V7
SET I=I+1
+5 QUIT
+6 ;
+7 ;X can be something like '"TEXT",1,0'.
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
+5 ;
+6 ;S can be something like '"TEXT",1,0'.
GINST(R,S,V) ;instantiate global
+1 NEW N
+2 IF V=$CHAR(1)
SET V=""
+3 SET N=$PIECE(R,")")_","_S_")"
+4 SET @N=V
+5 QUIT
+6 ;
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 ;Empties Input buffer
+1 NEW %
+2 ;!(%=-1)
FOR
READ *%:2
if '$TEST!(%=4)
QUIT
+3 QUIT
ZZZ(X) ;Convert
+1 NEW I,J
+2 FOR
SET I=$FIND(X,"$C(")
if 'I
QUIT
SET J=$FIND(X,")",I)
SET X=$EXTRACT(X,1,I-4)_$CHAR($EXTRACT(X,I,J-2))_$EXTRACT(X,J,999)
+3 QUIT X
+4 ;
CAPI(XWBY,PAR) ;make API call
+1 NEW XWBCALL,T,DX,DY
+2 ; ZEXCEPT: XWBFGTIM - created here, will be killed in STRTCVR2 or ONECOVER
+3 ; ZEXCEPT: XWBCSRPC - created here, will be killed in ONECOVER
+4 ; JLI 110606 next line checks for start call to Coversheet Timing
+5 IF XWB(2,"RTAG")="START"
IF XWB(2,"RNAM")="ORWCV"
IF +$GET(^KMPTMP("KMPD-CPRS"))
SET XWBFGTIM=$HOROLOG
DO STRTCVR1
IF 1
+6 IF '$TEST
IF $GET(XWBCOVER)
IF $DATA(^TMP("XWBFGP",$JOB,"TODO",XWB(2,"RPC")))
SET XWBFGTIM=$HOROLOG
SET XWBCSRPC=XWB(2,"RPC")
+7 SET XWBCALL=XWB(2,"RTAG")_"^"_XWB(2,"RNAM")_"(.XWBY"_$SELECT($LENGTH(PAR):","_PAR,1:"")_")"
SET XWBCALL2=""
+8 KILL PAR
+9 ;p43 Make sure its open
OPEN XWBNULL
USE XWBNULL
+10 ;
+11 IF $GET(XWBDEBUG)>2
DO LOG^XWBDLOG("Call: "_$EXTRACT(XWBCALL,1,247))
+12 ;start RUM for RPC
+13 ;P67-change "CAPI" to "RPC"
+14 IF $GET(XWB(2,"RPC"))]""
DO LOGRSRC^%ZOSV(XWB(2,"RPC"),2,1)
+15 ;
+16 ;Save call for debug
DO @XWBCALL
SET XWBCALL2=XWBCALL
+17 ;
+18 IF $GET(XWBCOVER)
IF XWB(2,"RTAG")="START"
IF XWB(2,"RNAM")="ORWCV"
DO STRTCVR2(XWBY)
IF 1
+19 ; JLI 110606
IF '$TEST
IF $DATA(XWBCOVER)
IF $DATA(XWBCSRPC)
DO ONECOVER
+20 ;
+21 ;restart RUM for handler
+22 DO LOGRSRC^%ZOSV("$BROKER HANDLER$",2,1)
+23 ;
+24 USE XWBTDEV
+25 QUIT
+26 ;
OARY() ;create storage array
+1 NEW A,DONE,I
+2 SET I=1+$GET(XWB("ARRAY"))
SET XWB("ARRAY")=I
+3 SET A="XWBS"_I
+4 ;temp fix for single array
KILL @A
+5 ;set naked
SET @A=""
+6 QUIT A
+7 ;
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 ;
STRTCVR1 ; JLI 110606
+1 ; SET UP DATA FOR OBTAINING FOREGROUND PROCESSING TIMES FOR COVERSHEET LOADS
+2 ; REQUESTED FOR TIMING ON COMMODITY SERVERS, ETC.
+3 NEW DFN,IP,HWND,NODE
+4 ; ZEXCEPT: XWBCOVER - created here, will be killed when foreground processing is complete
+5 SET XWBCOVER=1
+6 KILL ^TMP("XWBFGP",$JOB)
+7 SET DFN=XWB(5,"P",0)
SET IP=XWB(5,"P",1)
SET HWND=XWB(5,"P",2)
+8 SET NODE="ORWCV "_IP_"-"_HWND_"-"_DFN
+9 ; SO WE CAN GET IT EASILY EACH PASS
SET ^TMP("XWBFGP",$JOB,"NODE")=NODE
+10 SET ^KMPTMP("KMPDT","ORWCV-FT",NODE)=XWBFGTIM_"^^"_$GET(DUZ)_"^"_$GET(IO("CLNM"))
+11 QUIT
+12 ;
STRTCVR2(RETRNVAL) ; JLI 110606 - setup after coming back from initial start for coversheets
+1 NEW XWBFGDIF,I
+2 ; the return value contains ids for coversheets to be handled in the foreground separated by commas
+3 FOR I=1:1
SET XWBCSID=$PIECE(RETRNVAL,";",I)
if XWBCSID=""
QUIT
DO SETCSID(XWBCSID)
+4 KILL XWBFGTIM
+5 QUIT
+6 ;
SETCSID(XWBCSID) ; Obtain and setup selected coversheet ids for foreground processing
+1 NEW I,RPC
+2 ; The coversheet ID value (XWBCSID) will be used for a look-up on the "AC" cross-reference of file 101.24.
+3 ; It is possible to have multiple entries with the same ID value, so checking that the 8th piece of the zero node of the value is a "C" will be required.
+4 FOR I=0:0
SET I=$ORDER(^ORD(101.24,"AC",XWBCSID,I))
if I'>0
QUIT
IF $PIECE(^ORD(101.24,I,0),U,8)="C"
SET RPC=$PIECE(^(0),U,13)
SET RPC=$PIECE(^XWB(8994,RPC,0),U)
SET ^TMP("XWBFGP",$JOB,"TODO",RPC)=I
QUIT
+5 IF $DATA(^TMP("XWBFGP",$JOB,"TODO","ORQQPX REMINDERS LIST"))
Begin DoDot:1
+6 NEW XWBCSIEN
SET XWBCSIEN=^TMP("XWBFGP",$JOB,"TODO","ORQQPX REMINDERS LIST")
+7 SET ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDERS APPLICABLE")=XWBCSIEN
+8 SET ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDERS UNEVALUATED")=XWBCSIEN
+9 SET ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDER CATEGORIES")=XWBCSIEN
+10 QUIT
End DoDot:1
+11 QUIT
ONECOVER ; called after data is returned to client
+1 IF "^ORQQPXRM REMINDERS APPLICABLE^ORQQPXRM REMINDERS UNEVALUATED^ORQQPXRM REMINDER CATEGORIES^"[U_XWBCSRPC_U
KILL ^TMP("XWBFGP",$JOB,"TODO","ORQQPX REMINDERS LIST")
+2 IF XWBCSRPC="ORQQPX REMINDERS LIST"
Begin DoDot:1
+3 KILL ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDERS APPLICABLE")
+4 KILL ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDERS UNEVALUATED")
+5 KILL ^TMP("XWBFGP",$JOB,"TODO","ORQQPXRM REMINDER CATEGORIES")
+6 QUIT
End DoDot:1
+7 ;
+8 KILL ^TMP("XWBFGP",$JOB,"TODO",XWBCSRPC),XWBCSRPC,XWBFGTIM
+9 IF '$DATA(^TMP("XWBFGP",$JOB,"TODO"))
DO ENDCOVER
+10 QUIT
+11 ;
ENDCOVER ; no more cover sheets to process, so set final values, clean up
+1 NEW I,NODE,X
+2 SET NODE=^TMP("XWBFGP",$JOB,"NODE")
+3 SET $PIECE(^KMPTMP("KMPDT","ORWCV-FT",NODE),U,2)=$HOROLOG
+4 KILL XWBCOVER,^TMP("XWBFGP",$JOB)
+5 ;
