MAGGA01 ;WOIFO/SG - REMOTE PROCEDURES FOR REASONS ; 5/13/09 10:12am
;;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
;
;+++++ APPENDS THE REASONS TO THE RESULT ARRAY
;
; RESULTS Closed reference to the RPC result buffer.
;
; .MAGBUF Reference to a local array with records of the
; MAG REASON file (#2005.88) loaded by the LIST^DIC.
;
; FLAGS Flags that control execution.
;
; Return Values
; =============
; <0 Error descriptor (see the $$ERROR^MAGUERR)
; 0 Success
;
; Notes
; =====
;
; This is an internal entry point. Do not call it from outside of
; this routine.
;
APNDRSNS(RESULTS,MAGBUF,FLAGS) ;
N I,IENS,IMB,IRES,MAGTXT,RC
S RC=0,IRES=+$O(@RESULTS@(" "),-1)
;---
S IMB=0
F S IMB=$O(MAGBUF("DILIST",IMB)) Q:IMB'>0 D Q:RC<0
. S IRES=IRES+1,@RESULTS@(IRES)=MAGBUF("DILIST",IMB,0)
. ;--- Check if full details are requested
. Q:FLAGS'["F"
. ;--- Load the description
. K MAGTXT S IENS=$P(MAGBUF("DILIST",IMB,0),U)_","
. D GETS^DIQ(2005.88,IENS,"1",,"MAGTXT","MAGMSG")
. I $G(DIERR) S RC=$$DBS^MAGUERR("MAGMSG",2005.88,IENS) Q
. ;--- Append the description to the result array
. S I=0
. F S I=$O(MAGTXT(2005.88,IENS,1,I)) Q:I'>0 D
. . S IRES=IRES+1,@RESULTS@(IRES)="D"_U_MAGTXT(2005.88,IENS,1,I)
. . Q
. Q
;---
Q $S(RC<0:RC,1:0)
;
;***** RETURNS THE REASON PROPERTIES
; RPC: MAGG REASON GET PROPERTIES
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; RSNID Identifier of the reason: Internal Entry Number of
; the record in the MAG REASON file (#2005.88) or the
; reason code (see the FLAGS parameter).
;
; [FLAGS] Flags that control execution (can be combined):
;
; C By default, value of the RSNID parameter is
; treated as the reason IEN. If this flag is
; provided, then the reason code should be passed
; as the value of the RSNID.
;
; F Include full details (description text).
; By default, only the summary data is returned.
;
; Return Values
; =============
;
; Zero value of the first '^'-piece of the RESULTS(0) indicates
; that an error occurred during the execution of the procedure.
; In this case, the RESULTS array is formatted as described in the
; comments to the RPCERRS^MAGUERR1 procedure.
;
; Otherwise, the RESULTS(0) contains '1^OK' and the reason summary
; and description are returned in the subsequent elements of the
; RESULTS array as follows:
;
; RESULTS(1) Reason summary
; ^01: IEN of the reason in file #2005.88
; ^02: Text of the reason
; ^03: Types of the reason (combination of
; "C", "D", "P", and/or "S")
; ^04: Date of inactivation (FileMan)
; ^05: Unique code of the reason
;
; RESULTS(1+i) Line of the description of the reason
; ^01: "D"
; ^02: Text line
;
; The description text is returned only if the
; value of the FLAGS parameter contains "F" and
; the DESCRIPTION field (1) of the MAG REASON
; file (#2005.88) is not empty.
;
GET(RESULTS,RSNID,FLAGS) ;RPC [MAGG REASON GET PROPERTIES]
N RC K RESULTS
S RESULTS(0)="1^Ok",RC=0
D CLEAR^MAGUERR(1)
;
D
. N DESCR,I,REASON
. S REASON=$$GETRSN^MAGUTL10(RSNID,$G(FLAGS),.DESCR)
. I REASON<0 S RC=REASON Q
. ;
. ;--- Append the summary to the result array
. S IRES=1,RESULTS(IRES)=REASON
. Q:FLAGS'["F"
. ;
. ;--- Append the description to the result array
. S I=0
. F S I=$O(DESCR(I)) Q:I'>0 D
. . S IRES=IRES+1,RESULTS(IRES)="D"_U_DESCR(I)
. . Q
. Q
;
;=== Error handling and cleanup
D:RC<0 RPCERRS^MAGUERR1(.RESULTS,RC)
Q
;
;***** RETURNS THE LIST OF REASONS
; RPC: MAGG REASON LIST
;
; .RESULTS Reference to a local variable where the results
; are returned to.
;
; MAGTYPE Type(s) of returned reasons (can be combined):
;
; C Reasons for copying images
; D Reasons for deleting images
; P Reasons for printing images
; S Reasons for changing image status
;
; [FLAGS] Flags that control execution (can be combined):
;
; F Include full details (description text, etc.)
; I Include inactivated reasons
;
; By default ($G(FLAGS)=""), only the summary data
; for currently active reasons is returned.
;
; [PART] The partial match restriction (case sensitive).
; For example, a PART value of "ZZ" would restrict
; the list to those entries starting with the
; letters "ZZ".
;
; By default ($G(PART)=""), no text restrictions are
; applied.
;
; Return Values
; =============
;
; Zero value of the first '^'-piece of the @RESULTS@(0) indicates
; that an error occurred during the execution of the procedure.
; In this case, the @RESULTS array is formatted as described in the
; comments to the RPCERRS^MAGUERR1 procedure.
;
; Otherwise, the @RESULTS@(0) contains '1^OK' and the list of reasons
; is returned in the subsequent elements of the @RESULTS array as
; follows:
;
; @RESULTS@(i) Reason summary
; ^01: IEN of the reason in file #2005.88
; ^02: Text of the reason
; ^03: Types of the reason (combination of
; "C", "D", "P", and/or "S")
; ^04: Date of inactivation (FileMan).
; This piece is always empty if the
; value of the FLAGS parameter does not
; contain "I". Otherwise, a date in
; internal FileMan format is returned
; here for inactivated reasons.
; ^05: Unique code of the reason
;
; @RESULTS@(i+j) Line of the description of the reason
; ^01: "D"
; ^02: Text line
;
; The description text is returned only if the
; value of the FLAGS parameter contains "F" and
; the DESCRIPTION field (1) of the MAG REASON
; file (#2005.88) is not empty.
;
; The reasons are sorted alphabetically (case sensitive).
;
; Notes
; =====
;
; The ^TMP($J,"MAGGA01") global node is used by this procedure.
;
LSTRSNS(RESULTS,MAGTYPE,FLAGS,PART) ;RPC [MAGG REASON LIST]
N RC
D CLEAR^MAGUERR(1)
S DT=$$DT^XLFDT ; Ensure the current date value
S RC=0
;
;=== Initialize the result array
K RESULTS S RESULTS=$NA(^TMP("MAGGA01",$J))
K @RESULTS S @RESULTS@(0)="1^Ok"
;
D
. N FLDS,MAGBUF,MAGMSG,SCR
. ;=== Validate parameters
. S FLAGS=$G(FLAGS),PART=$G(PART)
. ;--- Type is not defined
. I $G(MAGTYPE)="" S RC=$$ERROR^MAGUERR(-8,,"MAGTYPE") Q
. ;--- Invalid type code(s)
. I $TR(MAGTYPE,"CDPS")'="" S RC=$$IPVE^MAGUERR("MAGTYPE") Q
. ;--- Invalid flag(s)
. I $TR(FLAGS,"FI")'="" S RC=$$IPVE^MAGUERR("FLAGS") Q
. ;
. ;=== Prepare the search parameters
. S FLDS="@;.01;.02I;.03I;.04"
. S SCR="N MAG0 S MAG0=$G(^(0)) I $TR(MAGTYPE,$P(MAG0,U,2))'=MAGTYPE"
. S:FLAGS'["I" SCR=SCR_",($P(MAG0,U,3)'>0)!($P(MAG0,U,3)>DT)"
. ;
. ;=== Search for reasons
. D LIST^DIC(2005.88,,FLDS,"P",,,PART,"B",SCR,,"MAGBUF","MAGMSG")
. I $G(DIERR) S RC=$$DBS^MAGUERR("MAGMSG",2005.88) Q
. Q:$G(MAGBUF("DILIST",0))'>0 ; Nothing has been found
. ;
. ;--- Append the reasons to the result array
. S RC=$$APNDRSNS(RESULTS,.MAGBUF,FLAGS)
. Q
;
;=== Error handling and cleanup
D:RC<0 RPCERRS^MAGUERR1(.RESULTS,RC)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGGA01 9383 printed Apr 09, 2024@21:11:40 Page 2
MAGGA01 ;WOIFO/SG - REMOTE PROCEDURES FOR REASONS ; 5/13/09 10:12am
+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 ;+++++ APPENDS THE REASONS TO THE RESULT ARRAY
+21 ;
+22 ; RESULTS Closed reference to the RPC result buffer.
+23 ;
+24 ; .MAGBUF Reference to a local array with records of the
+25 ; MAG REASON file (#2005.88) loaded by the LIST^DIC.
+26 ;
+27 ; FLAGS Flags that control execution.
+28 ;
+29 ; Return Values
+30 ; =============
+31 ; <0 Error descriptor (see the $$ERROR^MAGUERR)
+32 ; 0 Success
+33 ;
+34 ; Notes
+35 ; =====
+36 ;
+37 ; This is an internal entry point. Do not call it from outside of
+38 ; this routine.
+39 ;
APNDRSNS(RESULTS,MAGBUF,FLAGS) ;
+1 NEW I,IENS,IMB,IRES,MAGTXT,RC
+2 SET RC=0
SET IRES=+$ORDER(@RESULTS@(" "),-1)
+3 ;---
+4 SET IMB=0
+5 FOR
SET IMB=$ORDER(MAGBUF("DILIST",IMB))
if IMB'>0
QUIT
Begin DoDot:1
+6 SET IRES=IRES+1
SET @RESULTS@(IRES)=MAGBUF("DILIST",IMB,0)
+7 ;--- Check if full details are requested
+8 if FLAGS'["F"
QUIT
+9 ;--- Load the description
+10 KILL MAGTXT
SET IENS=$PIECE(MAGBUF("DILIST",IMB,0),U)_","
+11 DO GETS^DIQ(2005.88,IENS,"1",,"MAGTXT","MAGMSG")
+12 IF $GET(DIERR)
SET RC=$$DBS^MAGUERR("MAGMSG",2005.88,IENS)
QUIT
+13 ;--- Append the description to the result array
+14 SET I=0
+15 FOR
SET I=$ORDER(MAGTXT(2005.88,IENS,1,I))
if I'>0
QUIT
Begin DoDot:2
+16 SET IRES=IRES+1
SET @RESULTS@(IRES)="D"_U_MAGTXT(2005.88,IENS,1,I)
+17 QUIT
End DoDot:2
+18 QUIT
End DoDot:1
if RC<0
QUIT
+19 ;---
+20 QUIT $SELECT(RC<0:RC,1:0)
+21 ;
+22 ;***** RETURNS THE REASON PROPERTIES
+23 ; RPC: MAGG REASON GET PROPERTIES
+24 ;
+25 ; .RESULTS Reference to a local variable where the results
+26 ; are returned to.
+27 ;
+28 ; RSNID Identifier of the reason: Internal Entry Number of
+29 ; the record in the MAG REASON file (#2005.88) or the
+30 ; reason code (see the FLAGS parameter).
+31 ;
+32 ; [FLAGS] Flags that control execution (can be combined):
+33 ;
+34 ; C By default, value of the RSNID parameter is
+35 ; treated as the reason IEN. If this flag is
+36 ; provided, then the reason code should be passed
+37 ; as the value of the RSNID.
+38 ;
+39 ; F Include full details (description text).
+40 ; By default, only the summary data is returned.
+41 ;
+42 ; Return Values
+43 ; =============
+44 ;
+45 ; Zero value of the first '^'-piece of the RESULTS(0) indicates
+46 ; that an error occurred during the execution of the procedure.
+47 ; In this case, the RESULTS array is formatted as described in the
+48 ; comments to the RPCERRS^MAGUERR1 procedure.
+49 ;
+50 ; Otherwise, the RESULTS(0) contains '1^OK' and the reason summary
+51 ; and description are returned in the subsequent elements of the
+52 ; RESULTS array as follows:
+53 ;
+54 ; RESULTS(1) Reason summary
+55 ; ^01: IEN of the reason in file #2005.88
+56 ; ^02: Text of the reason
+57 ; ^03: Types of the reason (combination of
+58 ; "C", "D", "P", and/or "S")
+59 ; ^04: Date of inactivation (FileMan)
+60 ; ^05: Unique code of the reason
+61 ;
+62 ; RESULTS(1+i) Line of the description of the reason
+63 ; ^01: "D"
+64 ; ^02: Text line
+65 ;
+66 ; The description text is returned only if the
+67 ; value of the FLAGS parameter contains "F" and
+68 ; the DESCRIPTION field (1) of the MAG REASON
+69 ; file (#2005.88) is not empty.
+70 ;
GET(RESULTS,RSNID,FLAGS) ;RPC [MAGG REASON GET PROPERTIES]
+1 NEW RC
KILL RESULTS
+2 SET RESULTS(0)="1^Ok"
SET RC=0
+3 DO CLEAR^MAGUERR(1)
+4 ;
+5 Begin DoDot:1
+6 NEW DESCR,I,REASON
+7 SET REASON=$$GETRSN^MAGUTL10(RSNID,$GET(FLAGS),.DESCR)
+8 IF REASON<0
SET RC=REASON
QUIT
+9 ;
+10 ;--- Append the summary to the result array
+11 SET IRES=1
SET RESULTS(IRES)=REASON
+12 if FLAGS'["F"
QUIT
+13 ;
+14 ;--- Append the description to the result array
+15 SET I=0
+16 FOR
SET I=$ORDER(DESCR(I))
if I'>0
QUIT
Begin DoDot:2
+17 SET IRES=IRES+1
SET RESULTS(IRES)="D"_U_DESCR(I)
+18 QUIT
End DoDot:2
+19 QUIT
End DoDot:1
+20 ;
+21 ;=== Error handling and cleanup
+22 if RC<0
DO RPCERRS^MAGUERR1(.RESULTS,RC)
+23 QUIT
+24 ;
+25 ;***** RETURNS THE LIST OF REASONS
+26 ; RPC: MAGG REASON LIST
+27 ;
+28 ; .RESULTS Reference to a local variable where the results
+29 ; are returned to.
+30 ;
+31 ; MAGTYPE Type(s) of returned reasons (can be combined):
+32 ;
+33 ; C Reasons for copying images
+34 ; D Reasons for deleting images
+35 ; P Reasons for printing images
+36 ; S Reasons for changing image status
+37 ;
+38 ; [FLAGS] Flags that control execution (can be combined):
+39 ;
+40 ; F Include full details (description text, etc.)
+41 ; I Include inactivated reasons
+42 ;
+43 ; By default ($G(FLAGS)=""), only the summary data
+44 ; for currently active reasons is returned.
+45 ;
+46 ; [PART] The partial match restriction (case sensitive).
+47 ; For example, a PART value of "ZZ" would restrict
+48 ; the list to those entries starting with the
+49 ; letters "ZZ".
+50 ;
+51 ; By default ($G(PART)=""), no text restrictions are
+52 ; applied.
+53 ;
+54 ; Return Values
+55 ; =============
+56 ;
+57 ; Zero value of the first '^'-piece of the @RESULTS@(0) indicates
+58 ; that an error occurred during the execution of the procedure.
+59 ; In this case, the @RESULTS array is formatted as described in the
+60 ; comments to the RPCERRS^MAGUERR1 procedure.
+61 ;
+62 ; Otherwise, the @RESULTS@(0) contains '1^OK' and the list of reasons
+63 ; is returned in the subsequent elements of the @RESULTS array as
+64 ; follows:
+65 ;
+66 ; @RESULTS@(i) Reason summary
+67 ; ^01: IEN of the reason in file #2005.88
+68 ; ^02: Text of the reason
+69 ; ^03: Types of the reason (combination of
+70 ; "C", "D", "P", and/or "S")
+71 ; ^04: Date of inactivation (FileMan).
+72 ; This piece is always empty if the
+73 ; value of the FLAGS parameter does not
+74 ; contain "I". Otherwise, a date in
+75 ; internal FileMan format is returned
+76 ; here for inactivated reasons.
+77 ; ^05: Unique code of the reason
+78 ;
+79 ; @RESULTS@(i+j) Line of the description of the reason
+80 ; ^01: "D"
+81 ; ^02: Text line
+82 ;
+83 ; The description text is returned only if the
+84 ; value of the FLAGS parameter contains "F" and
+85 ; the DESCRIPTION field (1) of the MAG REASON
+86 ; file (#2005.88) is not empty.
+87 ;
+88 ; The reasons are sorted alphabetically (case sensitive).
+89 ;
+90 ; Notes
+91 ; =====
+92 ;
+93 ; The ^TMP($J,"MAGGA01") global node is used by this procedure.
+94 ;
LSTRSNS(RESULTS,MAGTYPE,FLAGS,PART) ;RPC [MAGG REASON LIST]
+1 NEW RC
+2 DO CLEAR^MAGUERR(1)
+3 ; Ensure the current date value
SET DT=$$DT^XLFDT
+4 SET RC=0
+5 ;
+6 ;=== Initialize the result array
+7 KILL RESULTS
SET RESULTS=$NAME(^TMP("MAGGA01",$JOB))
+8 KILL @RESULTS
SET @RESULTS@(0)="1^Ok"
+9 ;
+10 Begin DoDot:1
+11 NEW FLDS,MAGBUF,MAGMSG,SCR
+12 ;=== Validate parameters
+13 SET FLAGS=$GET(FLAGS)
SET PART=$GET(PART)
+14 ;--- Type is not defined
+15 IF $GET(MAGTYPE)=""
SET RC=$$ERROR^MAGUERR(-8,,"MAGTYPE")
QUIT
+16 ;--- Invalid type code(s)
+17 IF $TRANSLATE(MAGTYPE,"CDPS")'=""
SET RC=$$IPVE^MAGUERR("MAGTYPE")
QUIT
+18 ;--- Invalid flag(s)
+19 IF $TRANSLATE(FLAGS,"FI")'=""
SET RC=$$IPVE^MAGUERR("FLAGS")
QUIT
+20 ;
+21 ;=== Prepare the search parameters
+22 SET FLDS="@;.01;.02I;.03I;.04"
+23 SET SCR="N MAG0 S MAG0=$G(^(0)) I $TR(MAGTYPE,$P(MAG0,U,2))'=MAGTYPE"
+24 if FLAGS'["I"
SET SCR=SCR_",($P(MAG0,U,3)'>0)!($P(MAG0,U,3)>DT)"
+25 ;
+26 ;=== Search for reasons
+27 DO LIST^DIC(2005.88,,FLDS,"P",,,PART,"B",SCR,,"MAGBUF","MAGMSG")
+28 IF $GET(DIERR)
SET RC=$$DBS^MAGUERR("MAGMSG",2005.88)
QUIT
+29 ; Nothing has been found
if $GET(MAGBUF("DILIST",0))'>0
QUIT
+30 ;
+31 ;--- Append the reasons to the result array
+32 SET RC=$$APNDRSNS(RESULTS,.MAGBUF,FLAGS)
+33 QUIT
End DoDot:1
+34 ;
+35 ;=== Error handling and cleanup
+36 if RC<0
DO RPCERRS^MAGUERR1(.RESULTS,RC)
+37 QUIT
