VBECRPC ; HOIFO/BNT - VBECS Remote Procedure Utilities;Mar 23,2005
;;2.0;VBEC;;Jun 05, 2015;Build 4
;
; Note: This routine supports data exchange with an FDA registered
; medical device. As such, it may not be changed in any way without
; prior written approval from the medical device manufacturer.
;
; Integration Agreements:
; Reference to $$GET1^DIQ supported by IA #2052
; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
;
QUIT
;
STRIPL(VBDATA) ;STRIP TRAILING SPACES
F Q:$E(VBDATA,$L(VBDATA))'=" " S VBDATA=$E(VBDATA,1,$L(VBDATA)-1)
Q VBDATA
STRIPL3(VBDATA) ;STRIP LAST 3 CHARACTERS
S VBDATA=$E(VBDATA,1,$L(VBDATA)-3)
Q VBDATA
BEGROOT(X) ; Add beginning root element
D ADD("<"_X_">")
Q
;
ENDROOT(X) ; Add end root element
D ADD("</"_X_">")
Q
;
ADD(STR) ; Add XML to result global
S VBECCNT=VBECCNT+1
S @RESULTS@(VBECCNT)=STR
Q
;
ERROR(STR) ; Return ERROR
;
D BEGROOT("Error")
D ADD("<Text>"_$$CHARCHK^XOBVLIB(STR)_"</Text>")
D ENDROOT("Error")
Q
;
BADRPC(RPC,RTN,OPTION) ; Send back information on bad RPC call
;
;
S @RESULTS@(0)="-1^Error calling RPC: "_RPC_" at "_OPTION_U_RTN
Q
;
BLDERMSG(VBECPRMS,VBRSLT,VBMT) ; build error message(s) into VBMT global
;
N VBX ; temporary variable for holding text
N VBNM ; indirect name of request/results array/global
N VBNM2 ; copy of VBNM for different FOR loop
N VBORIG ; copy of VBNM with trailing parenthesis removed
N VBDATA ; data value from request/results node
N VBLBL ; label value comprised of $NA_VBDATA
N VBSUB ; subscript value for array node
N VBOUT ; full concatenated value of node to display
N VBLCV ; loop control variable for FOR loop
N VBDONE ; flag to signify 'done' with loop
N VBBLANK ; blank line of blank spaces
N VBMAXDAT ; maximum allowable length of array node data value
N VBMAXLBL ; maximum discovered length of array node label value
N VBSPACES ; calulated gap to format display to show data at column
;
S VBX="Following are the request and results array(s)"
I $D(@VBMT@("!INITIAL IEN"))#2=1 D
. S VBX=VBX_" for IEN # "_$P(@VBMT@("!INITIAL IEN"),U,2)
. S @VBMT@("#FOLLOWS MSG")=VBX
S VBBLANK=" "
;
F VBNM="VBECPRMS",$NA(@VBRSLT) D
. S VBNM2=VBNM,VBORIG=$P(VBNM,")")
. S VBMAXLBL=1
. F S VBNM2=$Q(@VBNM2) Q:VBNM2="" Q:$NA(@VBNM2)'[VBORIG D
. . S:VBORIG="VBECPRMS" VBLBL=$P($NA(@VBNM2),"(",2)
. . S:VBORIG=$P($NA(@VBRSLT),")") VBLBL=$P($NA(@VBNM2),")")
. . I VBORIG["VBECPRMS" D
. . . S VBLBL=$P(VBLBL,")")
. . I VBORIG'["VBECPRMS" D
. . . S VBLBL=$P(VBLBL,"(",2)
. . . S VBLBL=$P(VBLBL,$J)_$E(VBLBL,$F(VBLBL,$J)+1,$L(VBLBL))
. . . S VBLBL=$TR(VBLBL,"""","'"),VBLBL="'"_$P(VBLBL,"XML_",2)
. . S VBMAXLBL=$S($L(VBLBL)>VBMAXLBL:$L(VBLBL),1:VBMAXLBL)
. S VBMAXLBL=$S(VBMAXLBL>30:30,1:VBMAXLBL+3)
. S VBMAXDAT=80-VBMAXLBL-2
. S VBORIG=$P(VBNM,")")
. F S VBNM=$Q(@VBNM) Q:VBNM="" Q:$NA(@VBNM)'[VBORIG D
. . S VBLCV=0
. . S VBSUB=$NA(@VBNM),VBSUB=$TR(VBSUB,"""","")
. . S:VBORIG="VBECPRMS" VBLBL=$P($NA(@VBNM),"(",2)
. . S:VBORIG=$P($NA(@VBRSLT),")") VBLBL=$P($NA(@VBNM),")")
. . I VBORIG["VBECPRMS" D
. . . S VBLBL=$P(VBLBL,")")
. . I VBORIG'["VBECPRMS" D
. . . S VBLBL=$P(VBLBL,"(",2)
. . . S VBLBL=$P(VBLBL,$J)_$E(VBLBL,$F(VBLBL,$J)+1,$L(VBLBL))
. . . S VBLBL=$TR(VBLBL,"""","'"),VBLBL="'"_$P(VBLBL,"XML_",2)
. . S VBSPACES="",$P(VBSPACES," ",VBMAXLBL-$L(VBLBL))=""
. . S VBSPACES=VBSPACES
. . S VBDATA=$G(@VBNM)
. . K VBDONE
. . F VBLCV=0:1:25 D Q:$D(VBDONE)
. . . S VBSUB=$P(VBSUB,"||")
. . . S VBSUB=VBSUB_"||"_VBLCV
. . . S VBDATA(VBLCV)=" "_$E(VBDATA,1,VBMAXDAT)
. . . S VBDATA=$E(VBDATA,VBMAXDAT+1,$L(VBDATA))
. . . S:$L(VBDATA)'>0 VBDONE=1
. . . I VBLCV<1 D Q
. . . . I $L(VBLBL)'>VBMAXLBL D Q
. . . . . S $P(VBSPACES," ",$L(VBLBL)-VBMAXLBL)=""
. . . . . S VBLBL=VBLBL_VBSPACES
. . . . . S VBOUT=VBLBL_VBDATA(VBLCV)
. . . . . S @VBMT@(VBSUB)=VBOUT
. . . . I $L(VBLBL)>VBMAXLBL D
. . . . . S @VBMT@(VBSUB)=VBLBL
. . . . . S VBSUB=VBSUB_"||"_VBLCV
. . . . . S VBLBL=$E(VBBLANK,1,VBMAXLBL-1)
. . . . . S VBOUT=VBLBL_VBDATA(VBLCV)
. . . . . S VBSUB=$P(VBSUB,"||")
. . . . . S VBLCV=VBLCV+1
. . . . . S VBSUB=VBSUB_"||"_VBLCV
. . . . . S @VBMT@(VBSUB)=VBOUT
. . . I VBLCV>0 D
. . . . S VBLBL=$E(VBBLANK,1,VBMAXLBL-1)
. . . . S VBOUT=VBLBL_VBDATA(VBLCV)
. . . . S @VBMT@(VBSUB)=VBOUT
K VBDATA
Q
SENDMSG(VBMT,SENDER,RECEIVER,SUBJECT) ; Function - send message to mail group
;
; Input:
; VBMT - Array with error information for message text
; SENDER - Name of sender (routine tag and name)
; RECEIVER - Mail group or individual
; SUBJECT - Text for message subject
;
N VBT ; node in array during $Q
N VBLN ; message parameters
N VBGROUP ; name of mail group to which message will be sent
N VBCNT ; line count of VBLN array
N VBUSERNM ; IEN of user's entry in NEW PERSON file
N VBUSER ; name of user running this program
N XMDUZ ; sender
N XMSUB ; message subject
N XMTEXT ; message text array
N XMY ; recipient array
N XMZ ; returned message number
;
I '$D(VBMT) Q
I '$D(SENDER) S SENDER="VBECS VistALink M Client"
I '$D(RECEIVER) S RECEIVER="G.VBECS INTERFACE ADMIN"
I '$D(SUBJECT) S SUBJECT="VBECS VistaLink Error"
;
S VBCNT=1
S VBT=$NA(@VBMT)
;
S VBUSERNM=$$GET1^DIQ(200,DUZ,.01)
;
S VBLN(VBCNT)="* * * VBECS VistALink Error Notification * * *"
S VBCNT=VBCNT+1,VBLN(VBCNT)=" ",VBCNT=VBCNT+1
S VBLN(VBCNT)=" Generated by: "_VBUSERNM
S VBCNT=VBCNT+1,VBLN(VBCNT)=" "
F S VBT=$Q(@VBT) Q:VBT="" Q:$NA(@VBT)'[$J D
. S VBCNT=VBCNT+1
. S:VBT["DILIST" VBLN(VBCNT)=$G(@VBT)
. S:VBT'["DILIST" VBLN(VBCNT)=$P($G(@VBT),U)
. S VBLN(VBCNT)=$TR(VBLN(VBCNT),"""","'")
;
S XMDUZ=SENDER
S XMSUB=SUBJECT
S XMTEXT="VBLN("
; reactivate the following ling after testing:
S XMY(RECEIVER)=""
;S XMY(VBUSERNM)=""
D ^XMD
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HVBECRPC 6079 printed Jan 18, 2025@03:45:33 Page 2
VBECRPC ; HOIFO/BNT - VBECS Remote Procedure Utilities;Mar 23,2005
+1 ;;2.0;VBEC;;Jun 05, 2015;Build 4
+2 ;
+3 ; Note: This routine supports data exchange with an FDA registered
+4 ; medical device. As such, it may not be changed in any way without
+5 ; prior written approval from the medical device manufacturer.
+6 ;
+7 ; Integration Agreements:
+8 ; Reference to $$GET1^DIQ supported by IA #2052
+9 ; Reference to $$CHARCHK^XOBVLIB supported by IA #4090
+10 ;
+11 QUIT
+12 ;
STRIPL(VBDATA) ;STRIP TRAILING SPACES
+1 FOR
if $EXTRACT(VBDATA,$LENGTH(VBDATA))'=" "
QUIT
SET VBDATA=$EXTRACT(VBDATA,1,$LENGTH(VBDATA)-1)
+2 QUIT VBDATA
STRIPL3(VBDATA) ;STRIP LAST 3 CHARACTERS
+1 SET VBDATA=$EXTRACT(VBDATA,1,$LENGTH(VBDATA)-3)
+2 QUIT VBDATA
BEGROOT(X) ; Add beginning root element
+1 DO ADD("<"_X_">")
+2 QUIT
+3 ;
ENDROOT(X) ; Add end root element
+1 DO ADD("</"_X_">")
+2 QUIT
+3 ;
ADD(STR) ; Add XML to result global
+1 SET VBECCNT=VBECCNT+1
+2 SET @RESULTS@(VBECCNT)=STR
+3 QUIT
+4 ;
ERROR(STR) ; Return ERROR
+1 ;
+2 DO BEGROOT("Error")
+3 DO ADD("<Text>"_$$CHARCHK^XOBVLIB(STR)_"</Text>")
+4 DO ENDROOT("Error")
+5 QUIT
+6 ;
BADRPC(RPC,RTN,OPTION) ; Send back information on bad RPC call
+1 ;
+2 ;
+3 SET @RESULTS@(0)="-1^Error calling RPC: "_RPC_" at "_OPTION_U_RTN
+4 QUIT
+5 ;
BLDERMSG(VBECPRMS,VBRSLT,VBMT) ; build error message(s) into VBMT global
+1 ;
+2 ; temporary variable for holding text
NEW VBX
+3 ; indirect name of request/results array/global
NEW VBNM
+4 ; copy of VBNM for different FOR loop
NEW VBNM2
+5 ; copy of VBNM with trailing parenthesis removed
NEW VBORIG
+6 ; data value from request/results node
NEW VBDATA
+7 ; label value comprised of $NA_VBDATA
NEW VBLBL
+8 ; subscript value for array node
NEW VBSUB
+9 ; full concatenated value of node to display
NEW VBOUT
+10 ; loop control variable for FOR loop
NEW VBLCV
+11 ; flag to signify 'done' with loop
NEW VBDONE
+12 ; blank line of blank spaces
NEW VBBLANK
+13 ; maximum allowable length of array node data value
NEW VBMAXDAT
+14 ; maximum discovered length of array node label value
NEW VBMAXLBL
+15 ; calulated gap to format display to show data at column
NEW VBSPACES
+16 ;
+17 SET VBX="Following are the request and results array(s)"
+18 IF $DATA(@VBMT@("!INITIAL IEN"))#2=1
Begin DoDot:1
+19 SET VBX=VBX_" for IEN # "_$PIECE(@VBMT@("!INITIAL IEN"),U,2)
+20 SET @VBMT@("#FOLLOWS MSG")=VBX
End DoDot:1
+21 SET VBBLANK=" "
+22 ;
+23 FOR VBNM="VBECPRMS",$NAME(@VBRSLT)
Begin DoDot:1
+24 SET VBNM2=VBNM
SET VBORIG=$PIECE(VBNM,")")
+25 SET VBMAXLBL=1
+26 FOR
SET VBNM2=$QUERY(@VBNM2)
if VBNM2=""
QUIT
if $NAME(@VBNM2)'[VBORIG
QUIT
Begin DoDot:2
+27 if VBORIG="VBECPRMS"
SET VBLBL=$PIECE($NAME(@VBNM2),"(",2)
+28 if VBORIG=$PIECE($NAME(@VBRSLT),")")
SET VBLBL=$PIECE($NAME(@VBNM2),")")
+29 IF VBORIG["VBECPRMS"
Begin DoDot:3
+30 SET VBLBL=$PIECE(VBLBL,")")
End DoDot:3
+31 IF VBORIG'["VBECPRMS"
Begin DoDot:3
+32 SET VBLBL=$PIECE(VBLBL,"(",2)
+33 SET VBLBL=$PIECE(VBLBL,$JOB)_$EXTRACT(VBLBL,$FIND(VBLBL,$JOB)+1,$LENGTH(VBLBL))
+34 SET VBLBL=$TRANSLATE(VBLBL,"""","'")
SET VBLBL="'"_$PIECE(VBLBL,"XML_",2)
End DoDot:3
+35 SET VBMAXLBL=$SELECT($LENGTH(VBLBL)>VBMAXLBL:$LENGTH(VBLBL),1:VBMAXLBL)
End DoDot:2
+36 SET VBMAXLBL=$SELECT(VBMAXLBL>30:30,1:VBMAXLBL+3)
+37 SET VBMAXDAT=80-VBMAXLBL-2
+38 SET VBORIG=$PIECE(VBNM,")")
+39 FOR
SET VBNM=$QUERY(@VBNM)
if VBNM=""
QUIT
if $NAME(@VBNM)'[VBORIG
QUIT
Begin DoDot:2
+40 SET VBLCV=0
+41 SET VBSUB=$NAME(@VBNM)
SET VBSUB=$TRANSLATE(VBSUB,"""","")
+42 if VBORIG="VBECPRMS"
SET VBLBL=$PIECE($NAME(@VBNM),"(",2)
+43 if VBORIG=$PIECE($NAME(@VBRSLT),")")
SET VBLBL=$PIECE($NAME(@VBNM),")")
+44 IF VBORIG["VBECPRMS"
Begin DoDot:3
+45 SET VBLBL=$PIECE(VBLBL,")")
End DoDot:3
+46 IF VBORIG'["VBECPRMS"
Begin DoDot:3
+47 SET VBLBL=$PIECE(VBLBL,"(",2)
+48 SET VBLBL=$PIECE(VBLBL,$JOB)_$EXTRACT(VBLBL,$FIND(VBLBL,$JOB)+1,$LENGTH(VBLBL))
+49 SET VBLBL=$TRANSLATE(VBLBL,"""","'")
SET VBLBL="'"_$PIECE(VBLBL,"XML_",2)
End DoDot:3
+50 SET VBSPACES=""
SET $PIECE(VBSPACES," ",VBMAXLBL-$LENGTH(VBLBL))=""
+51 SET VBSPACES=VBSPACES
+52 SET VBDATA=$GET(@VBNM)
+53 KILL VBDONE
+54 FOR VBLCV=0:1:25
Begin DoDot:3
+55 SET VBSUB=$PIECE(VBSUB,"||")
+56 SET VBSUB=VBSUB_"||"_VBLCV
+57 SET VBDATA(VBLCV)=" "_$EXTRACT(VBDATA,1,VBMAXDAT)
+58 SET VBDATA=$EXTRACT(VBDATA,VBMAXDAT+1,$LENGTH(VBDATA))
+59 if $LENGTH(VBDATA)'>0
SET VBDONE=1
+60 IF VBLCV<1
Begin DoDot:4
+61 IF $LENGTH(VBLBL)'>VBMAXLBL
Begin DoDot:5
+62 SET $PIECE(VBSPACES," ",$LENGTH(VBLBL)-VBMAXLBL)=""
+63 SET VBLBL=VBLBL_VBSPACES
+64 SET VBOUT=VBLBL_VBDATA(VBLCV)
+65 SET @VBMT@(VBSUB)=VBOUT
End DoDot:5
QUIT
+66 IF $LENGTH(VBLBL)>VBMAXLBL
Begin DoDot:5
+67 SET @VBMT@(VBSUB)=VBLBL
+68 SET VBSUB=VBSUB_"||"_VBLCV
+69 SET VBLBL=$EXTRACT(VBBLANK,1,VBMAXLBL-1)
+70 SET VBOUT=VBLBL_VBDATA(VBLCV)
+71 SET VBSUB=$PIECE(VBSUB,"||")
+72 SET VBLCV=VBLCV+1
+73 SET VBSUB=VBSUB_"||"_VBLCV
+74 SET @VBMT@(VBSUB)=VBOUT
End DoDot:5
End DoDot:4
QUIT
+75 IF VBLCV>0
Begin DoDot:4
+76 SET VBLBL=$EXTRACT(VBBLANK,1,VBMAXLBL-1)
+77 SET VBOUT=VBLBL_VBDATA(VBLCV)
+78 SET @VBMT@(VBSUB)=VBOUT
End DoDot:4
End DoDot:3
if $DATA(VBDONE)
QUIT
End DoDot:2
End DoDot:1
+79 KILL VBDATA
+80 QUIT
SENDMSG(VBMT,SENDER,RECEIVER,SUBJECT) ; Function - send message to mail group
+1 ;
+2 ; Input:
+3 ; VBMT - Array with error information for message text
+4 ; SENDER - Name of sender (routine tag and name)
+5 ; RECEIVER - Mail group or individual
+6 ; SUBJECT - Text for message subject
+7 ;
+8 ; node in array during $Q
NEW VBT
+9 ; message parameters
NEW VBLN
+10 ; name of mail group to which message will be sent
NEW VBGROUP
+11 ; line count of VBLN array
NEW VBCNT
+12 ; IEN of user's entry in NEW PERSON file
NEW VBUSERNM
+13 ; name of user running this program
NEW VBUSER
+14 ; sender
NEW XMDUZ
+15 ; message subject
NEW XMSUB
+16 ; message text array
NEW XMTEXT
+17 ; recipient array
NEW XMY
+18 ; returned message number
NEW XMZ
+19 ;
+20 IF '$DATA(VBMT)
QUIT
+21 IF '$DATA(SENDER)
SET SENDER="VBECS VistALink M Client"
+22 IF '$DATA(RECEIVER)
SET RECEIVER="G.VBECS INTERFACE ADMIN"
+23 IF '$DATA(SUBJECT)
SET SUBJECT="VBECS VistaLink Error"
+24 ;
+25 SET VBCNT=1
+26 SET VBT=$NAME(@VBMT)
+27 ;
+28 SET VBUSERNM=$$GET1^DIQ(200,DUZ,.01)
+29 ;
+30 SET VBLN(VBCNT)="* * * VBECS VistALink Error Notification * * *"
+31 SET VBCNT=VBCNT+1
SET VBLN(VBCNT)=" "
SET VBCNT=VBCNT+1
+32 SET VBLN(VBCNT)=" Generated by: "_VBUSERNM
+33 SET VBCNT=VBCNT+1
SET VBLN(VBCNT)=" "
+34 FOR
SET VBT=$QUERY(@VBT)
if VBT=""
QUIT
if $NAME(@VBT)'[$JOB
QUIT
Begin DoDot:1
+35 SET VBCNT=VBCNT+1
+36 if VBT["DILIST"
SET VBLN(VBCNT)=$GET(@VBT)
+37 if VBT'["DILIST"
SET VBLN(VBCNT)=$PIECE($GET(@VBT),U)
+38 SET VBLN(VBCNT)=$TRANSLATE(VBLN(VBCNT),"""","'")
End DoDot:1
+39 ;
+40 SET XMDUZ=SENDER
+41 SET XMSUB=SUBJECT
+42 SET XMTEXT="VBLN("
+43 ; reactivate the following ling after testing:
+44 SET XMY(RECEIVER)=""
+45 ;S XMY(VBUSERNM)=""
+46 DO ^XMD
+47 QUIT
