Routine: XWBPRS

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

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

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

 ;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

 ;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

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)

VCHKQ ;Find closing quote

 F I=I+1:1 S C=$E(S,I) Q:C=""!(C=$C(34))

CLRBUF ;Empties Input buffer

N %

 F  R *%:2 Q:'$T!(%=4)  ;!(%=-1)

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

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"))

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

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

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

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  Feb 19, 2025@00:03:44                                                                                                                                                                                                      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       ;

XWBPRS.m