MAGUERR1 ;WOIFO/SG - ERROR HANDLING UTILITIES ; 3/9/09 12:53pm
;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
;; Per VHA Directive 2004-038, this routine should not be modified.
;; +---------------------------------------------------------------+
;; | Property of the US Government. |
;; | No permission to copy or redistribute this software is given. |
;; | Use of unreleased versions of this software requires the user |
;; | to execute a written test agreement with the VistA Imaging |
;; | Development Office of the Department of Veterans Affairs, |
;; | telephone (301) 734-0100. |
;; | |
;; | The Food and Drug Administration classifies this software as |
;; | a medical device. As such, it may not be changed in any way. |
;; | Modifications to this software may result in an adulterated |
;; | medical device under 21CFR820, the use of which is considered |
;; | to be a violation of US Federal Statutes. |
;; +---------------------------------------------------------------+
;;
Q
;
;***** PRINTS THE DUMP OF THE ERROR STORAGE
DUMP() ;
Q:$D(^TMP("MAG-ERRROR-STORAGE",$J))<10
N EPTR,I,NODE,TMP
S NODE=$NA(^TMP("MAG-ERRROR-STORAGE",$J))
;=== Print the header
D DUMPL("Code Message Text",1)
D DUMPL(" Additional info")
;=== Print the errors
S EPTR=""
F S EPTR=$O(@NODE@(EPTR)) Q:EPTR="" D
. ;--- Print the error descriptor
. S TMP=@NODE@(EPTR,0)
. D DUMPL($J(+TMP,4)_" "_$P(TMP,U,2),1)
. S TMP=$P(TMP,U,3)
. D:TMP'="" DUMPL(" Location: "_TMP)
. ;--- Print the optional text
. S I=""
. F S I=$O(@NODE@(EPTR,1,I)) Q:I="" D
. . D DUMPL(" "_@NODE@(EPTR,1,I))
. . Q
. Q
;===
Q
;
DUMPL(MSG,SKIP) ;
I '$D(XPDNM) W:$G(SKIP) ! W MSG,! Q
I $G(SKIP) D BMES^XPDUTL(MSG) Q
D MES^XPDUTL(MSG)
Q
;
;##### RETURNS A LIST OF ERROR CODES FROM THE ERROR STORAGE
;
; [ENCLOSE] Enclose the list in commas.
;
; Return Values
; =============
; "" No errors
; ... List of error codes (in reverse chronological
; order) separated by commas.
;
ERRLST(ENCLOSE) ;
N I,LST
S I=" ",LST=""
F S I=$O(^TMP("MAG-ERRROR-STORAGE",$J,I),-1) Q:I'>0 D
. S LST=LST_","_$P(^TMP("MAG-ERRROR-STORAGE",$J,I,0),U)
. Q
Q $S(LST="":"",$G(ENCLOSE):LST_",",1:$P(LST,",",2,9999))
;
;##### RETURNS DESCRIPTOR OF THE FIRST ERROR FROM THE ERROR STORAGE
;
; [.INFO] Reference to a local array where additional text
; associated with the error message is returned to
; (first level nodes; no 0-nodes). If there is no
; such text, this parameter will be undefined after
; the call.
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; "" Error storage is empty or it has not been
; enabled (see the CLEAR^MAGUERR)
;
FIRSTERR(INFO) ;
N I K INFO
S I=$O(^TMP("MAG-ERRROR-STORAGE",$J,0)) Q:I'>0 ""
M INFO=^TMP("MAG-ERRROR-STORAGE",$J,I,1)
Q $G(^TMP("MAG-ERRROR-STORAGE",$J,I,0))
;
;##### RETURNS DESCRIPTOR OF THE LAST ERROR FROM THE ERROR STORAGE
;
; [.INFO] Reference to a local array where additional text
; associated with the error message is returned to
; (first level nodes; no 0-nodes). If there is no
; such text, this parameter will be undefined after
; the call.
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; "" Error storage is empty or it has not been
; enabled (see the CLEAR^MAGUERR)
;
LASTERR(INFO) ;
N I K INFO
S I=$O(^TMP("MAG-ERRROR-STORAGE",$J," "),-1) Q:I'>0 ""
M INFO=^TMP("MAG-ERRROR-STORAGE",$J,I,1)
Q $G(^TMP("MAG-ERRROR-STORAGE",$J,I,0))
;
;##### RETURNS ERRORS FROM A REMOTE PROCEDURE
;
; .RESULTS Reference to the first parameter (RPC result) of the
; entry point that implements the remote procedure.
;
; If the type of the remote procedure result is GLOBAL
; ARRAY or GLOBAL INSTANCE and the RESULTS stores a
; valid name of a node in the ^TMP global, then errors
; are returned "under" this node.
;
; Otherwise, the RPC result type is changed to ARRAY
; and errors are returned in the RESULTS array.
;
; [ERR] Error descriptor of the main problem (from the RPC's
; point of view ;-). Only the 2nd piece is used: the
; message is returned as the 2nd piece of the result
; descriptor (for compatibility with the old code).
; By default, a generic message is used.
;
; Return Values
; =============
;
; @MAG8RES@(0) Result descriptor
; ^01: 0
; ^02: Message (2nd piece of the ERR)
;
; @MAG8RES@(i) Error descriptor (see the $$ERROR^MAGUERR)
; ^01: Error code
; ^02: Message
; ^03: Error location
; ^04: Message type
;
; @MAG8RES@(j) Line of the additional info
; ^01: ""
; ^02: Text
;
; The MAG8RES value is either the value of the RESULTS parameter
; (global node) or the parameter's name ("RESULTS").
;
; Error descriptors are returned in reverse chronological order
; (most recent first).
;
; Notes
; =====
;
; In order to use this functionality, the error storage must be
; enabled and initialized in the beginning of the code that
; implements the remote procedure (see the CLEAR^MAGUERR). See the
; MAGGA0* routines for usage examples.
;
RPCERRS(RESULTS,ERR) ;
N CNT,EPTR,I,MAGLOBAL,MAG8RES,TMP
;=== Re-initialize the result array
D:$G(RESULTS)?1"^TMP("1.E1")"
. N $ESTACK,$ETRAP
. S $ETRAP="S (MAG8RES,$ECODE)="""""
. ;--- Check if the node name is valid
. S MAG8RES=$NA(@RESULTS)
. Q
I $G(MAG8RES)="" D S MAG8RES="RESULTS"
. ;--- Change type of the RPC result
. S TMP=$$RTRNFMT^XWBLIB("ARRAY",1)
. Q
;--- Clear the buffer
K @MAG8RES
;
;=== Format the result descriptor (backward compatible)
S TMP=$$TRIM^XLFSTR($P($G(ERR),U,2))
S @MAG8RES@(0)="0"_U_$S(TMP'="":TMP,1:"RPC encountered error(s).")
Q:$D(^TMP("MAG-ERRROR-STORAGE",$J))<10
;
;=== Get errors from the temporary storage
S EPTR="",CNT=0
F S EPTR=$O(^TMP("MAG-ERRROR-STORAGE",$J,EPTR),-1) Q:EPTR="" D
. S TMP=$G(^TMP("MAG-ERRROR-STORAGE",$J,EPTR,0)) Q:'TMP
. S CNT=CNT+1,@MAG8RES@(CNT)=TMP
. S I=0
. F S I=$O(^TMP("MAG-ERRROR-STORAGE",$J,EPTR,1,I)) Q:I'>0 D
. . S CNT=CNT+1
. . S $P(@MAG8RES@(CNT),U,2)=^TMP("MAG-ERRROR-STORAGE",$J,EPTR,1,I)
. . Q
. Q
;
;=== Cleanup
D CLEAR^MAGUERR(0) ; Error storage
K ^TMP("DILIST",$J) ; Default FileMan buffer
Q
;
;+++++ DEFAULT RUN-TIME ERROR HANDLER
;
; MAGZZRCV Name of a variable that the error descriptor
; (-20) is assigned to.
;
RTEHNDLR(MAGZZRCV) ;
N MAGZZERR,MAGZZRC
;--- Record the error
S MAGZZERR=$$EC^%ZOSV D ^%ZTER S $ECODE=""
S MAGZZRC=$$ERROR^MAGUERR(-20,,MAGZZERR)
;--- Unwind the stack and assign/return the error descriptor
S $ETRAP="S:$ESTACK'>0 $ECODE="""""
S:MAGZZRCV'="" $ETRAP=$ETRAP_","_MAGZZRCV_"="_$$DDQ^MAGUTL05(MAGZZRC)
S $ETRAP=$ETRAP_" Q:$QUIT "_$$DDQ^MAGUTL05(MAGZZRC)_" Q"
S $ECODE=",U1,"
Q:$QUIT MAGZZRC Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGUERR1 7751 printed Apr 09, 2024@21:05:07 Page 2
MAGUERR1 ;WOIFO/SG - ERROR HANDLING UTILITIES ; 3/9/09 12:53pm
+1 ;;3.0;IMAGING;**93**;Dec 02, 2009;Build 163
+2 ;; Per VHA Directive 2004-038, this routine should not be modified.
+3 ;; +---------------------------------------------------------------+
+4 ;; | Property of the US Government. |
+5 ;; | No permission to copy or redistribute this software is given. |
+6 ;; | Use of unreleased versions of this software requires the user |
+7 ;; | to execute a written test agreement with the VistA Imaging |
+8 ;; | Development Office of the Department of Veterans Affairs, |
+9 ;; | telephone (301) 734-0100. |
+10 ;; | |
+11 ;; | The Food and Drug Administration classifies this software as |
+12 ;; | a medical device. As such, it may not be changed in any way. |
+13 ;; | Modifications to this software may result in an adulterated |
+14 ;; | medical device under 21CFR820, the use of which is considered |
+15 ;; | to be a violation of US Federal Statutes. |
+16 ;; +---------------------------------------------------------------+
+17 ;;
+18 QUIT
+19 ;
+20 ;***** PRINTS THE DUMP OF THE ERROR STORAGE
DUMP() ;
+1 if $DATA(^TMP("MAG-ERRROR-STORAGE",$JOB))<10
QUIT
+2 NEW EPTR,I,NODE,TMP
+3 SET NODE=$NAME(^TMP("MAG-ERRROR-STORAGE",$JOB))
+4 ;=== Print the header
+5 DO DUMPL("Code Message Text",1)
+6 DO DUMPL(" Additional info")
+7 ;=== Print the errors
+8 SET EPTR=""
+9 FOR
SET EPTR=$ORDER(@NODE@(EPTR))
if EPTR=""
QUIT
Begin DoDot:1
+10 ;--- Print the error descriptor
+11 SET TMP=@NODE@(EPTR,0)
+12 DO DUMPL($JUSTIFY(+TMP,4)_" "_$PIECE(TMP,U,2),1)
+13 SET TMP=$PIECE(TMP,U,3)
+14 if TMP'=""
DO DUMPL(" Location: "_TMP)
+15 ;--- Print the optional text
+16 SET I=""
+17 FOR
SET I=$ORDER(@NODE@(EPTR,1,I))
if I=""
QUIT
Begin DoDot:2
+18 DO DUMPL(" "_@NODE@(EPTR,1,I))
+19 QUIT
End DoDot:2
+20 QUIT
End DoDot:1
+21 ;===
+22 QUIT
+23 ;
DUMPL(MSG,SKIP) ;
+1 IF '$DATA(XPDNM)
if $GET(SKIP)
WRITE !
WRITE MSG,!
QUIT
+2 IF $GET(SKIP)
DO BMES^XPDUTL(MSG)
QUIT
+3 DO MES^XPDUTL(MSG)
+4 QUIT
+5 ;
+6 ;##### RETURNS A LIST OF ERROR CODES FROM THE ERROR STORAGE
+7 ;
+8 ; [ENCLOSE] Enclose the list in commas.
+9 ;
+10 ; Return Values
+11 ; =============
+12 ; "" No errors
+13 ; ... List of error codes (in reverse chronological
+14 ; order) separated by commas.
+15 ;
ERRLST(ENCLOSE) ;
+1 NEW I,LST
+2 SET I=" "
SET LST=""
+3 FOR
SET I=$ORDER(^TMP("MAG-ERRROR-STORAGE",$JOB,I),-1)
if I'>0
QUIT
Begin DoDot:1
+4 SET LST=LST_","_$PIECE(^TMP("MAG-ERRROR-STORAGE",$JOB,I,0),U)
+5 QUIT
End DoDot:1
+6 QUIT $SELECT(LST="":"",$GET(ENCLOSE):LST_",",1:$PIECE(LST,",",2,9999))
+7 ;
+8 ;##### RETURNS DESCRIPTOR OF THE FIRST ERROR FROM THE ERROR STORAGE
+9 ;
+10 ; [.INFO] Reference to a local array where additional text
+11 ; associated with the error message is returned to
+12 ; (first level nodes; no 0-nodes). If there is no
+13 ; such text, this parameter will be undefined after
+14 ; the call.
+15 ;
+16 ; Return Values
+17 ; =============
+18 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+19 ; "" Error storage is empty or it has not been
+20 ; enabled (see the CLEAR^MAGUERR)
+21 ;
FIRSTERR(INFO) ;
+1 NEW I
KILL INFO
+2 SET I=$ORDER(^TMP("MAG-ERRROR-STORAGE",$JOB,0))
if I'>0
QUIT ""
+3 MERGE INFO=^TMP("MAG-ERRROR-STORAGE",$JOB,I,1)
+4 QUIT $GET(^TMP("MAG-ERRROR-STORAGE",$JOB,I,0))
+5 ;
+6 ;##### RETURNS DESCRIPTOR OF THE LAST ERROR FROM THE ERROR STORAGE
+7 ;
+8 ; [.INFO] Reference to a local array where additional text
+9 ; associated with the error message is returned to
+10 ; (first level nodes; no 0-nodes). If there is no
+11 ; such text, this parameter will be undefined after
+12 ; the call.
+13 ;
+14 ; Return Values
+15 ; =============
+16 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+17 ; "" Error storage is empty or it has not been
+18 ; enabled (see the CLEAR^MAGUERR)
+19 ;
LASTERR(INFO) ;
+1 NEW I
KILL INFO
+2 SET I=$ORDER(^TMP("MAG-ERRROR-STORAGE",$JOB," "),-1)
if I'>0
QUIT ""
+3 MERGE INFO=^TMP("MAG-ERRROR-STORAGE",$JOB,I,1)
+4 QUIT $GET(^TMP("MAG-ERRROR-STORAGE",$JOB,I,0))
+5 ;
+6 ;##### RETURNS ERRORS FROM A REMOTE PROCEDURE
+7 ;
+8 ; .RESULTS Reference to the first parameter (RPC result) of the
+9 ; entry point that implements the remote procedure.
+10 ;
+11 ; If the type of the remote procedure result is GLOBAL
+12 ; ARRAY or GLOBAL INSTANCE and the RESULTS stores a
+13 ; valid name of a node in the ^TMP global, then errors
+14 ; are returned "under" this node.
+15 ;
+16 ; Otherwise, the RPC result type is changed to ARRAY
+17 ; and errors are returned in the RESULTS array.
+18 ;
+19 ; [ERR] Error descriptor of the main problem (from the RPC's
+20 ; point of view ;-). Only the 2nd piece is used: the
+21 ; message is returned as the 2nd piece of the result
+22 ; descriptor (for compatibility with the old code).
+23 ; By default, a generic message is used.
+24 ;
+25 ; Return Values
+26 ; =============
+27 ;
+28 ; @MAG8RES@(0) Result descriptor
+29 ; ^01: 0
+30 ; ^02: Message (2nd piece of the ERR)
+31 ;
+32 ; @MAG8RES@(i) Error descriptor (see the $$ERROR^MAGUERR)
+33 ; ^01: Error code
+34 ; ^02: Message
+35 ; ^03: Error location
+36 ; ^04: Message type
+37 ;
+38 ; @MAG8RES@(j) Line of the additional info
+39 ; ^01: ""
+40 ; ^02: Text
+41 ;
+42 ; The MAG8RES value is either the value of the RESULTS parameter
+43 ; (global node) or the parameter's name ("RESULTS").
+44 ;
+45 ; Error descriptors are returned in reverse chronological order
+46 ; (most recent first).
+47 ;
+48 ; Notes
+49 ; =====
+50 ;
+51 ; In order to use this functionality, the error storage must be
+52 ; enabled and initialized in the beginning of the code that
+53 ; implements the remote procedure (see the CLEAR^MAGUERR). See the
+54 ; MAGGA0* routines for usage examples.
+55 ;
RPCERRS(RESULTS,ERR) ;
+1 NEW CNT,EPTR,I,MAGLOBAL,MAG8RES,TMP
+2 ;=== Re-initialize the result array
+3 if $GET(RESULTS)?1"^TMP("1.E1")"
Begin DoDot:1
+4 NEW $ESTACK,$ETRAP
+5 SET $ETRAP="S (MAG8RES,$ECODE)="""""
+6 ;--- Check if the node name is valid
+7 SET MAG8RES=$NAME(@RESULTS)
+8 QUIT
End DoDot:1
+9 IF $GET(MAG8RES)=""
Begin DoDot:1
+10 ;--- Change type of the RPC result
+11 SET TMP=$$RTRNFMT^XWBLIB("ARRAY",1)
+12 QUIT
End DoDot:1
SET MAG8RES="RESULTS"
+13 ;--- Clear the buffer
+14 KILL @MAG8RES
+15 ;
+16 ;=== Format the result descriptor (backward compatible)
+17 SET TMP=$$TRIM^XLFSTR($PIECE($GET(ERR),U,2))
+18 SET @MAG8RES@(0)="0"_U_$SELECT(TMP'="":TMP,1:"RPC encountered error(s).")
+19 if $DATA(^TMP("MAG-ERRROR-STORAGE",$JOB))<10
QUIT
+20 ;
+21 ;=== Get errors from the temporary storage
+22 SET EPTR=""
SET CNT=0
+23 FOR
SET EPTR=$ORDER(^TMP("MAG-ERRROR-STORAGE",$JOB,EPTR),-1)
if EPTR=""
QUIT
Begin DoDot:1
+24 SET TMP=$GET(^TMP("MAG-ERRROR-STORAGE",$JOB,EPTR,0))
if 'TMP
QUIT
+25 SET CNT=CNT+1
SET @MAG8RES@(CNT)=TMP
+26 SET I=0
+27 FOR
SET I=$ORDER(^TMP("MAG-ERRROR-STORAGE",$JOB,EPTR,1,I))
if I'>0
QUIT
Begin DoDot:2
+28 SET CNT=CNT+1
+29 SET $PIECE(@MAG8RES@(CNT),U,2)=^TMP("MAG-ERRROR-STORAGE",$JOB,EPTR,1,I)
+30 QUIT
End DoDot:2
+31 QUIT
End DoDot:1
+32 ;
+33 ;=== Cleanup
+34 ; Error storage
DO CLEAR^MAGUERR(0)
+35 ; Default FileMan buffer
KILL ^TMP("DILIST",$JOB)
+36 QUIT
+37 ;
+38 ;+++++ DEFAULT RUN-TIME ERROR HANDLER
+39 ;
+40 ; MAGZZRCV Name of a variable that the error descriptor
+41 ; (-20) is assigned to.
+42 ;
RTEHNDLR(MAGZZRCV) ;
+1 NEW MAGZZERR,MAGZZRC
+2 ;--- Record the error
+3 SET MAGZZERR=$$EC^%ZOSV
DO ^%ZTER
SET $ECODE=""
+4 SET MAGZZRC=$$ERROR^MAGUERR(-20,,MAGZZERR)
+5 ;--- Unwind the stack and assign/return the error descriptor
+6 SET $ETRAP="S:$ESTACK'>0 $ECODE="""""
+7 if MAGZZRCV'=""
SET $ETRAP=$ETRAP_","_MAGZZRCV_"="_$$DDQ^MAGUTL05(MAGZZRC)
+8 SET $ETRAP=$ETRAP_" Q:$QUIT "_$$DDQ^MAGUTL05(MAGZZRC)_" Q"
+9 SET $ECODE=",U1,"
+10 if $QUIT
QUIT MAGZZRC
QUIT
