- 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 Feb 19, 2025@00:10:56 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