MAGVIM05 ;WOIFO/MAT,JL,DAC,PMK,BT - Utilities for RPC calls for DICOM file processing ;15 March 2023 9:56 AM
;;3.0;IMAGING;**118,138,164,166,194,278,357**;Mar 19, 2002;Build 29
;; Per VA Directive 6402, 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
;
;+++++ Wrap call to code underlying RPC: RAMAG EXAM COMPLETE & re-format output
;
; RPC: MAGV RAD STAT COMPLETE Private IA #5072
;
; Inputs:
; =======
;
; RETURN ...... variable to hold the results
; RADPT ....... IEN of the RAD/NUC MED PATIENT file (#70)
; RAEXAM1 ..... EXAM DATE (#.01) of the REGISTERED EXAMS sub-file (#70.02)
; RAEXAM2 ..... IEN of the EXAMINATIONS sub-file (#70.03)
; MAGVUSR ..... DUZ of the Importer 2 application user.
; MAGVUSRDV ... DUZ(2) of the Importer 2 user.
; RAIMGTYP .... TYPE OF IMAGING (#2) of the REGISTERED EXAMS sub-file (#70.02)
; [RASTDRPT] ... IEN of an entry in the STANDARD REPORTS file (#74.1)
; [RADXPRIM] .. Primary Diagnostic Code --> RAMISC Param PRIMDXCODE
; IEN(s) of entries in the DIAGNOSTIC CODES file(#78.3)
; [RADXSCND] ... In the RPC (defined as OTHDIAG). Contains List of
; ... (1) One or more IENs of entries in the DIAGNOSTIC CODES file (#78.3).
; ... (These will be the exam's Secondary Diagnostic Codes via the RAMISC parameter 'SECDXCODE')
; ... (2) Report Text and Impression Text
; ... (Either entered manually or populated using 'GET Report from SR' in the Importer app)
;
; Outputs:
; ========
;
; Notes:
; ======
;
; The parameters mirror those of the underlying call.
;
XMCOMPLT(RETURN,RADPT,RAEXAM1,RAEXAM2,MAGVUSR,MAGVUSRDV,RAIMGTYP,RASTDRPT,RADXPRIM,RADXSCND) ;
;
;--- Initialize
K RETURN
N MSG,RARESULT,SEPSTAT,SEPOUTP D ZRUSEPIN
;
N RAMAN ; Use Manually entered Report and Impression Text
N RARPTXT S RARPTXT="" ; Manually entered Report Text (List - multiple lines of text)
N RAIMPRS S RAIMPRS="" ; Manually entered Impression Text (List - multiple lines of text)
N RASCND
;
;--- Validate incoming parameters.
N MAGERR,PARAM S MAGERR=0
D
. F PARAM="RADPT","RAEXAM1","RAEXAM2","MAGVUSR","MAGVUSRDV","RAIMGTYP" D Q:MAGERR
. . S:@PARAM="" MAGERR=1
. . Q
. Q
;
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_"Required parameter "_PARAM_" missing or invalid."
. Q
;
;--- Format incoming RAD Exam Identifiers.
S RAEXAM=RADPT_U_RAEXAM1_U_RAEXAM2
;
;--- Set IMAGING SITE PARAMETERS file (#2006.1) IEN from DUZ(2).
N MAGSITEP
D
. S MAGVUSRDV=$G(MAGVUSRDV,$G(DUZ(2))),MAGSITEP=$O(^MAG(2006.1,"B",MAGVUSRDV,"")) ;P164
. I MAGSITEP="" D ;P164 - if it is not Site IEN, try Station Number
. . ;--- Get IEN of INSTITUTION file (#4) from STATION NUMBER (Supported IA# 2171)
. . N IENINST S IENINST=$$IEN^XUAF4(MAGVUSRDV)
. . S MAGSITEP=$O(^MAG(2006.1,"B",IENINST,"")) Q:+MAGSITEP ;found the site
. . S MAGERR=1,MSG="Unable to resolve Imaging Site Parameters entry. {DUZ(2)="_MAGVUSRDV_"} "
. Q
;
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_MSG
. Q
;
;--- Compile Report Text, and Impression if passed in.
;--- must do it this way, HDIG RPC broker doesn't work with multiple LIST input parameters
D:$G(RADXSCND(0))'=""
. ;
. N RCT S RCT=0
. N ICT S ICT=0
. N SCT S SCT=0
. N CT S CT=""
. F S CT=$O(RADXSCND(CT)) Q:CT="" D
. . I $E(RADXSCND(CT),1,3)="|R|" S RAMAN=1,RCT=RCT+1,RARPTXT(RCT)=$P(RADXSCND(CT),"|R|",2),RARPTXT=RARPTXT_RARPTXT(RCT) Q
. . I $E(RADXSCND(CT),1,3)="|I|" S RAMAN=1,ICT=ICT+1,RAIMPRS(ICT)=$P(RADXSCND(CT),"|I|",2),RAIMPRS=RAIMPRS_RAIMPRS(ICT) Q
. . S RASCND(SCT)=RADXSCND(CT),SCT=SCT+1
. . Q
. K RADXSCND M RADXSCND=RASCND
. Q
;
;--- Set additional RAD Order/Exam parameters.
S MAGERR=$$MAKELIST("C",RAIMGTYP,.RAMSC,MAGVUSR,MAGSITEP)
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_$P(MAGERR,U,2)
. Q
;
;--- Set flag to insert Primary DX code if passed in.
D:$G(RADXPRIM)'="" OUTPUT("PRIMDXCODE^^"_RADXPRIM,.RAMSC)
;
;--- Set flag to insert Secondary DX code(s) if passed in.
D:$G(RADXSCND(0))'=""
. ;
. N CT S CT=""
. F S CT=$O(RADXSCND(CT)) Q:CT="" D OUTPUT("SECDXCODE"_U_(CT+1)_U_RADXSCND(CT),.RAMSC)
. Q
;
;--- Set flag to suppress HL7 message to dictation systems.
D OUTPUT("FLAGS^^FS",.RAMSC)
;--- Call code underlying RPC: RAMAG EXAM COMPLETE (Private IA #5072)
D COMPLETE^RAMAGRP1(.RARESULT,RAEXAM,.RAMSC)
I $G(RARESULT(1))="-11^2" D ; add the OUTSIDE STUDY and try the RPC again
. N INFO
. D ADDROOM(.INFO,RAEXAM)
. K RARESULT
. I INFO(1)<0 M RARESULT=INFO Q
. D COMPLETE^RAMAGRP1(.RARESULT,RAEXAM,.RAMSC)
. Q
;
;--- Re-format error output or return 0.
I RARESULT(0)<0 D
. ;
. S RETURN(0)=-1_SEPSTAT_$O(RARESULT("A"),-1)_" error lines returned."
. N X S X=0
. F S X=$O(RARESULT(X)) Q:X="" D
. . S RETURN(X)=$P(RARESULT(X),U,1)_SEPSTAT_$P(RARESULT(X),U,2,999)
. . Q
E D
. S RETURN(0)=0_SEPSTAT_RARESULT(0)
. N X S X=0
. F S X=$O(RARESULT(X)) Q:X="" D
. . S RETURN(X)=$TR(RARESULT(X),U,SEPOUTP)
. . Q
. ;--- Call RA* code to trigger alerts for DX codes.
. D ALERT^MAGVIMRA(RADPT,RAEXAM1,RAEXAM2,1)
. Q
Q
;+++++ Wrap call to code underlying RPC: RAMAG EXAMINED & re-format output
;
; RPC: MAGV RAD STAT EXAMINED Private IA #5071
;
; Inputs:
; =======
;
; See input parameter descriptions above tag XMCOMPLT (above).
;
XMEXAMIN(RETURN,RADFN,RAEXAM1,RAEXAM2,MAGVUSR,MAGVUSRDV,RAIMGTYP) ;
;
;--- Initialize.
K RETURN
N MSG,RARESULT,SEPSTAT,SEPOUTP D ZRUSEPIN
;--- Validate incoming parameters.
N MAGERR,PARAM S MAGERR=0
D
. F PARAM="RADFN","RAEXAM1","RAEXAM2","MAGVUSR","MAGVUSRDV","RAIMGTYP" D Q:MAGERR
. . S:@PARAM="" MAGERR=1
. . Q
. Q
;
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_"Required parameter "_PARAM_" missing or invalid."
. Q
;
;--- Format incoming RAD Exam Identifiers
N RAEXAM S RAEXAM=RADFN_U_RAEXAM1_U_RAEXAM2
;
;--- Set IMAGING SITE PARAMETERS file (#2006.1) IEN from DUZ(2).
N MAGSITEP
D
. S MAGVUSRDV=$G(MAGVUSRDV,$G(DUZ(2))),MAGSITEP=$O(^MAG(2006.1,"B",MAGVUSRDV,"")) ;DAC P166
. I MAGSITEP="" D ;DAC P166 - if it is not Site IEN, try Station Number
. . ;--- Get IEN of INSTITUTION file (#4) from STATION NUMBER (Supported IA# 2171)
. . N IENINST S IENINST=$$IEN^XUAF4(MAGVUSRDV)
. . I IENINST'="" S MAGSITEP=$O(^MAG(2006.1,"B",IENINST,"")) Q:+MAGSITEP ;found the site
. . S MAGERR=1,MSG="Unable to resolve Imaging Site Parameters entry. {DUZ(2)="_MAGVUSRDV_"} "
. Q
;
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_MSG
. Q
;
;
;--- Set required parameters
S MAGERR=$$MAKELIST("E",RAIMGTYP,.RAMSC,MAGVUSR,MAGSITEP)
I MAGERR D Q
. S RETURN(0)="-1"_SEPSTAT_$P(MAGERR,U,2)
. Q
;
;--- Set flag to suppress HL7 message to dictation systems.
D OUTPUT("FLAGS^^FS",.RAMSC)
;--- Call code underlying RPC: RAMAG EXAMINED (Private IA #5071).
D EXAMINED^RAMAGRP2(.RARESULT,RAEXAM,.RAMSC)
I $G(RARESULT(1))="-11^2" D ; add the OUTSIDE STUDY and try the RPC again
. N INFO
. D ADDROOM(.INFO,RAEXAM)
. K RARESULT
. I INFO(1)<0 M RARESULT=INFO Q
. D EXAMINED^RAMAGRP2(.RARESULT,RAEXAM,.RAMSC)
. Q
;
;--- Re-format error output or return 0.
I RARESULT(0)<0 D
. ;
. S RETURN(0)=-1_SEPSTAT_$O(RARESULT("A"),-1)_" error lines returned."
. N X S X=0
. F S X=$O(RARESULT(X)) Q:X="" D
. . S RETURN(X)=$P(RARESULT(X),U,1)_SEPSTAT_$P(RARESULT(X),U,2,999)
. . Q
E D
. S RETURN(0)=0_SEPSTAT_RARESULT(0)
. N X S X=0
. F S X=$O(RARESULT(X)) Q:X="" D
. . S RETURN(X)=$TR(RARESULT(X),U,SEPOUTP)
. . Q
. Q
Q
;+++++ Wrap calls to RPC: RAMAG EXAM ORDER & re-format output.
;
; RPC: MAGV RAD EXAM ORDER Private IA #5068
;
; Inputs:
; =======
;
; RETURN
; DFN
; RAMLC
; RADPROC
; STUDYDAT
; RACAT
; REQLOC
; REQPHYS
; REASON
; MISC
;
; Notes:
; ======
;
; The parameters are the same as those of the underlying call.
;
XMORDER(RETURN,DFN,RAMLC,RADPROC,STUDYDAT,RACAT,REQLOC,REQPHYS,REASON,MISC) ;
;
K RETURN
N SEPSTAT,SEPOUTP,I,FMDAY,MAXORDER,RAOIEN,REVERSEDAY,PROC1 D ZRUSEPIN
;
; maximum number of same procedures for same date for patient - P194 PMK/DAC 8/14/2018
S MAXORDER=$P($G(^MAG(2006.1,1,"IMPORTER")),U,6)
I MAXORDER="" S MAXORDER=10
;
S FMDAY=$$HL7TFM^XLFDT($G(STUDYDAT))
I FMDAY'>0 D Q
. S RETURN(0)=-1_SEPSTAT_"1 error line returned."
. S RETURN(1)=-1001_SEPSTAT_"Illegal or non-existent STUDYDAT="""_$G(STUDYDAT)_""""
. Q
S REVERSEDAY=9999999.9999-(FMDAY\1) ; strip the time and reverse the date
S PROC1=$P(RADPROC,U,1) ; P278 DAC - RADPROC may contain optional modifiers - Set PROC1 to the procedure IEN without modifiers
;
S RAOIEN=0
; P278 DAC - Use PROC1 (procedure) instead of RADPROC (procudure + optional modifiers)
F I=1:1:MAXORDER S RAOIEN=$O(^RAO(75.1,"AP",DFN,PROC1,REVERSEDAY,RAOIEN)) Q:'RAOIEN
I RAOIEN D Q
. S RETURN(0)=-1_SEPSTAT_"1 error line returned."
. S RETURN(1)=-1000_SEPSTAT_"Order already on file with IEN="_RAOIEN
. Q
;
;--- Private IA #5068.
D ORDER^RAMAGRP1(.ORDINFO,DFN,RAMLC,RADPROC,STUDYDAT,RACAT,REQLOC,REQPHYS,REASON,.MISC)
;
;--- Re-format error output or return new IEN in RAD/NUC MED ORDERS File (#75.1)
I ORDINFO(0)<0 D K ORDINFO
. ;
. S RETURN(0)=-1_SEPSTAT_$O(ORDINFO("A"),-1)_" error lines returned."
. N X S X=0 F S X=$O(ORDINFO(X)) Q:X="" D
. . ;
. . S RETURN(X)=$P(ORDINFO(X),U,1)_SEPSTAT_$P(ORDINFO(X),U,2,999)
. . Q
. Q
E S RETURN(0)=ORDINFO(0)
K ORDINFO
Q
;
;+++++ Wrap calls to RPC: RAMAG EXAM REGISTER & re-format output.
;
; RPC: MAGV RAD EXAM REGISTER Private IA #5069.
;
; Inputs:
; =======
;
; RETURN
; RAOIFN
; EXMDTE
; RAMSC
;
; Notes:
; ======
;
; The parameters are the same as those of the underlying call.
;
XMREGSTR(RETURN,RAOIFN,EXMDTE,RAMSC) ;
;
K RETURN
N SEPSTAT,SEPOUTP,IMAGLOC D ZRUSEPIN
N DIV S DIV=$$GETDIV()
;
; Check if imaging location is present - if not find outside imaging location for procedure and division
N RODATA S RODATA=$G(^RAO(75.1,RAOIFN,0))
D:$P(RODATA,U,20)=""
. N LOCINFO,PROCIEN,RAMLC S PROCIEN=$P(RODATA,U,2)
. D IMAGELOC(.RAMLC,PROCIEN,DIV)
. S:$P(RAMLC,SEPSTAT)<0 RETURN(0)=RAMLC
. Q:$G(RETURN(0))
. S RAMLC=$P(RAMLC,SEPSTAT,2)
. ; call the RPC to update the radiology imaging location in the radiology order file (#75.1).
. D IMAGELOC^MAGDRPCB(.LOCINFO,RAOIFN,RAMLC)
. I $G(LOCINFO)<0 S RETURN(0)=LOCINFO ;"-1"_SEPSTAT_"Error in rpc MAG DICOM SET IMAGING LOCATION"
. Q
;
;Get imaging location IEN (#79.1)
K RAMLC,PROCIEN
S PROCIEN=$P(RODATA,U,2)
D IMAGELOC(.RAMLC,PROCIEN,DIV)
S:$P(RAMLC,SEPSTAT)<0 RETURN(0)=RAMLC
Q:$G(RETURN(0))
S RAMLC=$P(RAMLC,SEPSTAT,2)
;Get corresponding hospital location IEN (#44)
S IMAGLOC=$$GET1^DIQ(79.1,.RAMLC,.01,"I")
K RAMSC
S RAMSC(1)="PRINCLIN^^"_$G(IMAGLOC)
S RAMSC(2)="FLAGS^^D"
;
Q:$G(RETURN(0))
;--- Private IA #5069.
D REGISTER^RAMAGRP1(.RARESULT,RAOIFN,EXMDTE,.RAMSC)
;
I RARESULT(0)<0 D
. ;
. S RETURN(0)=-1_SEPSTAT_$O(RARESULT("A"),-1)_" error lines returned."
. N X S X=0 F S X=$O(RARESULT(X)) Q:X="" D
. . ;
. . S RETURN(X)=$P(RARESULT(X),U,1)_SEPSTAT_$P(RARESULT(X),U,2,999)
. . Q
E D
. S RETURN(0)=0_SEPSTAT_RARESULT(0)
. N X S X=0 F S X=$O(RARESULT(X)) Q:X="" D
. . ;
. . S RETURN(X)=$TR(RARESULT(X),U,SEPOUTP)
. . Q
. Q
Q
;+++ Routine Utility: Initialize Separators
ZRUSEPIN ;
S SEPOUTP=$$OUTSEP^MAGVIM01
S SEPSTAT=$$STATSEP^MAGVIM01
Q
;+++ Use Alternate Division if it's available otherwise use site#
GETDIV() ;
N DIV
S DIV=$$GET^XPAR("SYS","MAG ALTERNATE DIVISION",,"I") ; IA# 2263
I DIV="" Q DUZ(2)
Q DIV
;
MAKELIST(RACTION,RAIMGTYP,RAMSC,MAGVUSR,MAGSITEP) ; output required fields
; Load required flags
N INFO
D EXMSTREQ^RAMAGRP2(.INFO,RACTION,RAIMGTYP)
I INFO(0)<0 Q INFO(1)
;
N TODAYHL7
S TODAYHL7=$$NOW^XLFDT()\1,$E(TODAYHL7)=$E(TODAYHL7)+17
;
N REQ,RADPVAL
;REQ001 - technologist
S REQ(1)="TECH^1^"_MAGVUSR
;
;REQ002 - resident or staff
;REQ003 - detailed procedure - taken care of already
;
;REQ004 - film entry
S RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD FILM SIZE","I")
S REQ(4)="FILMSIZE^1^"_RADPVAL_U_"0"
;
;REQ005 - diagnostic code default, if not supplied by user.
D:$G(RADXPRIM)=""
. S RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD PRIMARY DIAGNOSTIC CODE","I")
. S REQ(5)="PRIMDXCODE^^"_RADPVAL
. Q
;
;REQ006 - camera / equipment / room
S RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD PRIMARY CAMERA/EQUIP/RM","I")
S REQ(6)="PRIMCAM^^"_RADPVAL
;
;REQ007 - reserved
;REQ008 - reserved
;REQ009 - reserved
;REQ010 - reserved
;
;REQ011 - report entered
S REQ(11)="RPTDTE^^"_TODAYHL7
I $G(RAMAN)=1 D MANRPRT(.RARPTXT,"R",1) ;--- Add manually entered REPORT text to the RAMSC array.
I $G(RAMAN)'=1 D
. I $G(RASTDRPT)="" S REQ(11,1)="REPORT^1^Electronically generated report for outside study."
. I $G(RASTDRPT)'="" D STNDRPRT(RASTDRPT,"R",1) ; Add the REPORT text of a selected STANDARD REPORT to the RAMSC array.
. Q
;
;--- Report can't be blank
N NOREPORT S NOREPORT=0
I '$D(RARPTXT),$G(RASTDRPT)="" S NOREPORT=1
I '$D(RARPTXT),$G(RASTDRPT)'="",'$D(^RA(74.1,RASTDRPT,"R")) S NOREPORT=1
I $D(RARPTXT),$G(RARPTXT)="",$G(RASTDRPT)="" S NOREPORT=1
I NOREPORT,$G(REQ(11,1))="" S REQ(11,1)="REPORT^1^No report text"
;
;REQ012 - verified report
S REQ(12)="VERDTE^^"_TODAYHL7
S REQ(12,1)="RPTSTATUS^^EF"
;
;REQ013 - procedure modifiers required - previously done
;
;REQ014 - cpt modifiers
S RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD CPT MODIFIERS","I")
S:RADPVAL REQ(14)="CPTMODS^1^"_RADPVAL
;
;REQ015 - reserved
;
;REQ016 - impression
I $G(RAMAN)=1 D MANRPRT(.RAIMPRS,"I",1) ;--- Add manually entered impression text to the RAMSC array.
I $G(RAMAN)'=1 D
. I $G(RASTDRPT)="" S REQ(16)="IMPRESSION^1^Electronically generated report for outside study."
. I $G(RASTDRPT)'="" D STNDRPRT(RASTDRPT,"I",1) ; Add the IMPRESSION text of a selected STANDARD REPORT to the RAMSC array.
. Q
;
;--- Impression can't be blank
N NOIMPR S NOIMPR=0
I '$D(RAIMPRS),$G(RASTDRPT)="" S NOIMPR=1
I '$D(RAIMPRS),$G(RASTDRPT)'="",'$D(^RA(74.1,RASTDRPT,"I")) S NOIMPR=1
I $D(RAIMPRS),$G(RAIMPRS)="",$G(RASTDRPT)="" S NOIMPR=1
I NOIMPR,$G(REQ(16))="" S REQ(16)="IMPRESSION^1^No impression text"
;
N INDEX
F INDEX=1:1:16 I $P(INFO(0),"^",INDEX) D
. D:$D(REQ(INDEX)) OUTPUT(REQ(INDEX),.RAMSC)
. D:$D(REQ(INDEX,1)) OUTPUT(REQ(INDEX,1),.RAMSC)
. Q
;
Q 0
;
;+++++ Add selected STANDARD REPORT text to the Miscellaneous Parameters array.
;
STNDRPRT(RASTDRPT,SSCR,INDEX1) ;
;
N PREFIX S PREFIX=$S(SSCR="R":"REPORT",SSCR="I":"IMPRESSION")
;
N CT
S CT=0 F S CT=$O(^RA(74.1,RASTDRPT,SSCR,CT)) Q:CT="" D
. N RPTXT
. S RPTXT=PREFIX_U_(CT+INDEX1)_U_$G(^RA(74.1,RASTDRPT,SSCR,CT,0)) D OUTPUT(RPTXT,.RAMSC)
. Q
Q
;
;+++++ Add manually entered REPORT/IMPRESSION text to the Miscellaneous Parameters array.
;
MANRPRT(TXTLST,SSCR,INDEX1) ;
;
N PREFIX S PREFIX=$S(SSCR="R":"REPORT",SSCR="I":"IMPRESSION")
N CT S CT=""
F S CT=$O(TXTLST(CT)) Q:CT="" D
. N RPTXT
. S RPTXT=PREFIX_U_(CT+INDEX1)_U_TXTLST(CT) D OUTPUT(RPTXT,.RAMSC)
. Q
Q
;
OUTPUT(TEXT,ARRAY) ;
N I
S I=$O(ARRAY(""),-1)+1
S ARRAY(I)=TEXT
Q
;
; MAGV OUTSIDE IMAGE LOCATION
;
; Inputs:
; =======
;
; PROCIEN -- IEN of procedure in RAD/NUC MED PROCEDURES (file #71)
; DIVISION - IEN of division in INSTITUTION (file #4)
;
; Output:
; ========
;
; <0 Error message
; 0 IEN of the Outside Image Location in the IMAGE LOCATIONS (file #79.1)
;
IMAGELOC(RESULT,PROCIEN,DIVISION) ;
; return the outside imaging location for a given radiology procedure and division
N IEN,IMAGETYPE,SEPSTAT,SEPOUTP D ZRUSEPIN
K RESULT
S PROCIEN=$G(PROCIEN)
I (PROCIEN'>0)!(PROCIEN'=+PROCIEN) D Q
. S RESULT="-1"_SEPSTAT_"Invalid or missing Radiology Procedure pointer: """_PROCIEN_"""."
. Q
;
S DIVISION=$G(DIVISION)
I (DIVISION'>0)!(DIVISION'=+DIVISION) D Q
. S RESULT="-2"_SEPSTAT_"Invalid or missing Division pointer:"""_DIVISION_"""."
. Q
;
S IMAGETYPE=$$GET1^DIQ(71,PROCIEN,12,"I")
I 'IMAGETYPE D Q
. S RESULT="-3"_SEPSTAT_"Image Type could not be determined for Radiology Procedure pointer: """_PROCIEN_"""."
. Q
;
I $$GET1^DIQ(4,DIVISION,.01)="" D Q
. S RESULT="-4"_SEPSTAT_"Invalid Division (Institution) pointer:"""_DIVISION_"""."
. Q
S IEN=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,""))
I IEN="" D Q
. S RESULT="-5"_SEPSTAT_"Outside Imaging Location could not be determined for Division: "_DIVISION_" & Procedure: """_PROCIEN_"""."
. Q
S RESULT=0_SEPSTAT_$$GET1^DIQ(2006.5759,IEN,.01,"I")
Q
ADDROOM(INFO,RAEXAM) ; add the OUTSIDE STUDY camera equipment room to the IMAGING LOCATION
;S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM ADD CAMERA EQUIP RM","M",.INFO,RAEXAM)
D ADDROOM^MAGDRPCB(.INFO,RAEXAM)
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVIM05 18061 printed Dec 13, 2024@02:09:52 Page 2
MAGVIM05 ;WOIFO/MAT,JL,DAC,PMK,BT - Utilities for RPC calls for DICOM file processing ;15 March 2023 9:56 AM
+1 ;;3.0;IMAGING;**118,138,164,166,194,278,357**;Mar 19, 2002;Build 29
+2 ;; Per VA Directive 6402, 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 ;; | The Food and Drug Administration classifies this software as |
+11 ;; | a medical device. As such, it may not be changed in any way. |
+12 ;; | Modifications to this software may result in an adulterated |
+13 ;; | medical device under 21CFR820, the use of which is considered |
+14 ;; | to be a violation of US Federal Statutes. |
+15 ;; +---------------------------------------------------------------+
+16 ;;
+17 ;
+18 QUIT
+19 ;
+20 ;+++++ Wrap call to code underlying RPC: RAMAG EXAM COMPLETE & re-format output
+21 ;
+22 ; RPC: MAGV RAD STAT COMPLETE Private IA #5072
+23 ;
+24 ; Inputs:
+25 ; =======
+26 ;
+27 ; RETURN ...... variable to hold the results
+28 ; RADPT ....... IEN of the RAD/NUC MED PATIENT file (#70)
+29 ; RAEXAM1 ..... EXAM DATE (#.01) of the REGISTERED EXAMS sub-file (#70.02)
+30 ; RAEXAM2 ..... IEN of the EXAMINATIONS sub-file (#70.03)
+31 ; MAGVUSR ..... DUZ of the Importer 2 application user.
+32 ; MAGVUSRDV ... DUZ(2) of the Importer 2 user.
+33 ; RAIMGTYP .... TYPE OF IMAGING (#2) of the REGISTERED EXAMS sub-file (#70.02)
+34 ; [RASTDRPT] ... IEN of an entry in the STANDARD REPORTS file (#74.1)
+35 ; [RADXPRIM] .. Primary Diagnostic Code --> RAMISC Param PRIMDXCODE
+36 ; IEN(s) of entries in the DIAGNOSTIC CODES file(#78.3)
+37 ; [RADXSCND] ... In the RPC (defined as OTHDIAG). Contains List of
+38 ; ... (1) One or more IENs of entries in the DIAGNOSTIC CODES file (#78.3).
+39 ; ... (These will be the exam's Secondary Diagnostic Codes via the RAMISC parameter 'SECDXCODE')
+40 ; ... (2) Report Text and Impression Text
+41 ; ... (Either entered manually or populated using 'GET Report from SR' in the Importer app)
+42 ;
+43 ; Outputs:
+44 ; ========
+45 ;
+46 ; Notes:
+47 ; ======
+48 ;
+49 ; The parameters mirror those of the underlying call.
+50 ;
XMCOMPLT(RETURN,RADPT,RAEXAM1,RAEXAM2,MAGVUSR,MAGVUSRDV,RAIMGTYP,RASTDRPT,RADXPRIM,RADXSCND) ;
+1 ;
+2 ;--- Initialize
+3 KILL RETURN
+4 NEW MSG,RARESULT,SEPSTAT,SEPOUTP
DO ZRUSEPIN
+5 ;
+6 ; Use Manually entered Report and Impression Text
NEW RAMAN
+7 ; Manually entered Report Text (List - multiple lines of text)
NEW RARPTXT
SET RARPTXT=""
+8 ; Manually entered Impression Text (List - multiple lines of text)
NEW RAIMPRS
SET RAIMPRS=""
+9 NEW RASCND
+10 ;
+11 ;--- Validate incoming parameters.
+12 NEW MAGERR,PARAM
SET MAGERR=0
+13 Begin DoDot:1
+14 FOR PARAM="RADPT","RAEXAM1","RAEXAM2","MAGVUSR","MAGVUSRDV","RAIMGTYP"
Begin DoDot:2
+15 if @PARAM=""
SET MAGERR=1
+16 QUIT
End DoDot:2
if MAGERR
QUIT
+17 QUIT
End DoDot:1
+18 ;
+19 IF MAGERR
Begin DoDot:1
+20 SET RETURN(0)="-1"_SEPSTAT_"Required parameter "_PARAM_" missing or invalid."
+21 QUIT
End DoDot:1
QUIT
+22 ;
+23 ;--- Format incoming RAD Exam Identifiers.
+24 SET RAEXAM=RADPT_U_RAEXAM1_U_RAEXAM2
+25 ;
+26 ;--- Set IMAGING SITE PARAMETERS file (#2006.1) IEN from DUZ(2).
+27 NEW MAGSITEP
+28 Begin DoDot:1
+29 ;P164
SET MAGVUSRDV=$GET(MAGVUSRDV,$GET(DUZ(2)))
SET MAGSITEP=$ORDER(^MAG(2006.1,"B",MAGVUSRDV,""))
+30 ;P164 - if it is not Site IEN, try Station Number
IF MAGSITEP=""
Begin DoDot:2
+31 ;--- Get IEN of INSTITUTION file (#4) from STATION NUMBER (Supported IA# 2171)
+32 NEW IENINST
SET IENINST=$$IEN^XUAF4(MAGVUSRDV)
+33 ;found the site
SET MAGSITEP=$ORDER(^MAG(2006.1,"B",IENINST,""))
if +MAGSITEP
QUIT
+34 SET MAGERR=1
SET MSG="Unable to resolve Imaging Site Parameters entry. {DUZ(2)="_MAGVUSRDV_"} "
End DoDot:2
+35 QUIT
End DoDot:1
+36 ;
+37 IF MAGERR
Begin DoDot:1
+38 SET RETURN(0)="-1"_SEPSTAT_MSG
+39 QUIT
End DoDot:1
QUIT
+40 ;
+41 ;--- Compile Report Text, and Impression if passed in.
+42 ;--- must do it this way, HDIG RPC broker doesn't work with multiple LIST input parameters
+43 if $GET(RADXSCND(0))'=""
Begin DoDot:1
+44 ;
+45 NEW RCT
SET RCT=0
+46 NEW ICT
SET ICT=0
+47 NEW SCT
SET SCT=0
+48 NEW CT
SET CT=""
+49 FOR
SET CT=$ORDER(RADXSCND(CT))
if CT=""
QUIT
Begin DoDot:2
+50 IF $EXTRACT(RADXSCND(CT),1,3)="|R|"
SET RAMAN=1
SET RCT=RCT+1
SET RARPTXT(RCT)=$PIECE(RADXSCND(CT),"|R|",2)
SET RARPTXT=RARPTXT_RARPTXT(RCT)
QUIT
+51 IF $EXTRACT(RADXSCND(CT),1,3)="|I|"
SET RAMAN=1
SET ICT=ICT+1
SET RAIMPRS(ICT)=$PIECE(RADXSCND(CT),"|I|",2)
SET RAIMPRS=RAIMPRS_RAIMPRS(ICT)
QUIT
+52 SET RASCND(SCT)=RADXSCND(CT)
SET SCT=SCT+1
+53 QUIT
End DoDot:2
+54 KILL RADXSCND
MERGE RADXSCND=RASCND
+55 QUIT
End DoDot:1
+56 ;
+57 ;--- Set additional RAD Order/Exam parameters.
+58 SET MAGERR=$$MAKELIST("C",RAIMGTYP,.RAMSC,MAGVUSR,MAGSITEP)
+59 IF MAGERR
Begin DoDot:1
+60 SET RETURN(0)="-1"_SEPSTAT_$PIECE(MAGERR,U,2)
+61 QUIT
End DoDot:1
QUIT
+62 ;
+63 ;--- Set flag to insert Primary DX code if passed in.
+64 if $GET(RADXPRIM)'=""
DO OUTPUT("PRIMDXCODE^^"_RADXPRIM,.RAMSC)
+65 ;
+66 ;--- Set flag to insert Secondary DX code(s) if passed in.
+67 if $GET(RADXSCND(0))'=""
Begin DoDot:1
+68 ;
+69 NEW CT
SET CT=""
+70 FOR
SET CT=$ORDER(RADXSCND(CT))
if CT=""
QUIT
DO OUTPUT("SECDXCODE"_U_(CT+1)_U_RADXSCND(CT),.RAMSC)
+71 QUIT
End DoDot:1
+72 ;
+73 ;--- Set flag to suppress HL7 message to dictation systems.
+74 DO OUTPUT("FLAGS^^FS",.RAMSC)
+75 ;--- Call code underlying RPC: RAMAG EXAM COMPLETE (Private IA #5072)
+76 DO COMPLETE^RAMAGRP1(.RARESULT,RAEXAM,.RAMSC)
+77 ; add the OUTSIDE STUDY and try the RPC again
IF $GET(RARESULT(1))="-11^2"
Begin DoDot:1
+78 NEW INFO
+79 DO ADDROOM(.INFO,RAEXAM)
+80 KILL RARESULT
+81 IF INFO(1)<0
MERGE RARESULT=INFO
QUIT
+82 DO COMPLETE^RAMAGRP1(.RARESULT,RAEXAM,.RAMSC)
+83 QUIT
End DoDot:1
+84 ;
+85 ;--- Re-format error output or return 0.
+86 IF RARESULT(0)<0
Begin DoDot:1
+87 ;
+88 SET RETURN(0)=-1_SEPSTAT_$ORDER(RARESULT("A"),-1)_" error lines returned."
+89 NEW X
SET X=0
+90 FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+91 SET RETURN(X)=$PIECE(RARESULT(X),U,1)_SEPSTAT_$PIECE(RARESULT(X),U,2,999)
+92 QUIT
End DoDot:2
End DoDot:1
+93 IF '$TEST
Begin DoDot:1
+94 SET RETURN(0)=0_SEPSTAT_RARESULT(0)
+95 NEW X
SET X=0
+96 FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+97 SET RETURN(X)=$TRANSLATE(RARESULT(X),U,SEPOUTP)
+98 QUIT
End DoDot:2
+99 ;--- Call RA* code to trigger alerts for DX codes.
+100 DO ALERT^MAGVIMRA(RADPT,RAEXAM1,RAEXAM2,1)
+101 QUIT
End DoDot:1
+102 QUIT
+103 ;+++++ Wrap call to code underlying RPC: RAMAG EXAMINED & re-format output
+104 ;
+105 ; RPC: MAGV RAD STAT EXAMINED Private IA #5071
+106 ;
+107 ; Inputs:
+108 ; =======
+109 ;
+110 ; See input parameter descriptions above tag XMCOMPLT (above).
+111 ;
XMEXAMIN(RETURN,RADFN,RAEXAM1,RAEXAM2,MAGVUSR,MAGVUSRDV,RAIMGTYP) ;
+1 ;
+2 ;--- Initialize.
+3 KILL RETURN
+4 NEW MSG,RARESULT,SEPSTAT,SEPOUTP
DO ZRUSEPIN
+5 ;--- Validate incoming parameters.
+6 NEW MAGERR,PARAM
SET MAGERR=0
+7 Begin DoDot:1
+8 FOR PARAM="RADFN","RAEXAM1","RAEXAM2","MAGVUSR","MAGVUSRDV","RAIMGTYP"
Begin DoDot:2
+9 if @PARAM=""
SET MAGERR=1
+10 QUIT
End DoDot:2
if MAGERR
QUIT
+11 QUIT
End DoDot:1
+12 ;
+13 IF MAGERR
Begin DoDot:1
+14 SET RETURN(0)="-1"_SEPSTAT_"Required parameter "_PARAM_" missing or invalid."
+15 QUIT
End DoDot:1
QUIT
+16 ;
+17 ;--- Format incoming RAD Exam Identifiers
+18 NEW RAEXAM
SET RAEXAM=RADFN_U_RAEXAM1_U_RAEXAM2
+19 ;
+20 ;--- Set IMAGING SITE PARAMETERS file (#2006.1) IEN from DUZ(2).
+21 NEW MAGSITEP
+22 Begin DoDot:1
+23 ;DAC P166
SET MAGVUSRDV=$GET(MAGVUSRDV,$GET(DUZ(2)))
SET MAGSITEP=$ORDER(^MAG(2006.1,"B",MAGVUSRDV,""))
+24 ;DAC P166 - if it is not Site IEN, try Station Number
IF MAGSITEP=""
Begin DoDot:2
+25 ;--- Get IEN of INSTITUTION file (#4) from STATION NUMBER (Supported IA# 2171)
+26 NEW IENINST
SET IENINST=$$IEN^XUAF4(MAGVUSRDV)
+27 ;found the site
IF IENINST'=""
SET MAGSITEP=$ORDER(^MAG(2006.1,"B",IENINST,""))
if +MAGSITEP
QUIT
+28 SET MAGERR=1
SET MSG="Unable to resolve Imaging Site Parameters entry. {DUZ(2)="_MAGVUSRDV_"} "
End DoDot:2
+29 QUIT
End DoDot:1
+30 ;
+31 IF MAGERR
Begin DoDot:1
+32 SET RETURN(0)="-1"_SEPSTAT_MSG
+33 QUIT
End DoDot:1
QUIT
+34 ;
+35 ;
+36 ;--- Set required parameters
+37 SET MAGERR=$$MAKELIST("E",RAIMGTYP,.RAMSC,MAGVUSR,MAGSITEP)
+38 IF MAGERR
Begin DoDot:1
+39 SET RETURN(0)="-1"_SEPSTAT_$PIECE(MAGERR,U,2)
+40 QUIT
End DoDot:1
QUIT
+41 ;
+42 ;--- Set flag to suppress HL7 message to dictation systems.
+43 DO OUTPUT("FLAGS^^FS",.RAMSC)
+44 ;--- Call code underlying RPC: RAMAG EXAMINED (Private IA #5071).
+45 DO EXAMINED^RAMAGRP2(.RARESULT,RAEXAM,.RAMSC)
+46 ; add the OUTSIDE STUDY and try the RPC again
IF $GET(RARESULT(1))="-11^2"
Begin DoDot:1
+47 NEW INFO
+48 DO ADDROOM(.INFO,RAEXAM)
+49 KILL RARESULT
+50 IF INFO(1)<0
MERGE RARESULT=INFO
QUIT
+51 DO EXAMINED^RAMAGRP2(.RARESULT,RAEXAM,.RAMSC)
+52 QUIT
End DoDot:1
+53 ;
+54 ;--- Re-format error output or return 0.
+55 IF RARESULT(0)<0
Begin DoDot:1
+56 ;
+57 SET RETURN(0)=-1_SEPSTAT_$ORDER(RARESULT("A"),-1)_" error lines returned."
+58 NEW X
SET X=0
+59 FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+60 SET RETURN(X)=$PIECE(RARESULT(X),U,1)_SEPSTAT_$PIECE(RARESULT(X),U,2,999)
+61 QUIT
End DoDot:2
End DoDot:1
+62 IF '$TEST
Begin DoDot:1
+63 SET RETURN(0)=0_SEPSTAT_RARESULT(0)
+64 NEW X
SET X=0
+65 FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+66 SET RETURN(X)=$TRANSLATE(RARESULT(X),U,SEPOUTP)
+67 QUIT
End DoDot:2
+68 QUIT
End DoDot:1
+69 QUIT
+70 ;+++++ Wrap calls to RPC: RAMAG EXAM ORDER & re-format output.
+71 ;
+72 ; RPC: MAGV RAD EXAM ORDER Private IA #5068
+73 ;
+74 ; Inputs:
+75 ; =======
+76 ;
+77 ; RETURN
+78 ; DFN
+79 ; RAMLC
+80 ; RADPROC
+81 ; STUDYDAT
+82 ; RACAT
+83 ; REQLOC
+84 ; REQPHYS
+85 ; REASON
+86 ; MISC
+87 ;
+88 ; Notes:
+89 ; ======
+90 ;
+91 ; The parameters are the same as those of the underlying call.
+92 ;
XMORDER(RETURN,DFN,RAMLC,RADPROC,STUDYDAT,RACAT,REQLOC,REQPHYS,REASON,MISC) ;
+1 ;
+2 KILL RETURN
+3 NEW SEPSTAT,SEPOUTP,I,FMDAY,MAXORDER,RAOIEN,REVERSEDAY,PROC1
DO ZRUSEPIN
+4 ;
+5 ; maximum number of same procedures for same date for patient - P194 PMK/DAC 8/14/2018
+6 SET MAXORDER=$PIECE($GET(^MAG(2006.1,1,"IMPORTER")),U,6)
+7 IF MAXORDER=""
SET MAXORDER=10
+8 ;
+9 SET FMDAY=$$HL7TFM^XLFDT($GET(STUDYDAT))
+10 IF FMDAY'>0
Begin DoDot:1
+11 SET RETURN(0)=-1_SEPSTAT_"1 error line returned."
+12 SET RETURN(1)=-1001_SEPSTAT_"Illegal or non-existent STUDYDAT="""_$GET(STUDYDAT)_""""
+13 QUIT
End DoDot:1
QUIT
+14 ; strip the time and reverse the date
SET REVERSEDAY=9999999.9999-(FMDAY\1)
+15 ; P278 DAC - RADPROC may contain optional modifiers - Set PROC1 to the procedure IEN without modifiers
SET PROC1=$PIECE(RADPROC,U,1)
+16 ;
+17 SET RAOIEN=0
+18 ; P278 DAC - Use PROC1 (procedure) instead of RADPROC (procudure + optional modifiers)
+19 FOR I=1:1:MAXORDER
SET RAOIEN=$ORDER(^RAO(75.1,"AP",DFN,PROC1,REVERSEDAY,RAOIEN))
if 'RAOIEN
QUIT
+20 IF RAOIEN
Begin DoDot:1
+21 SET RETURN(0)=-1_SEPSTAT_"1 error line returned."
+22 SET RETURN(1)=-1000_SEPSTAT_"Order already on file with IEN="_RAOIEN
+23 QUIT
End DoDot:1
QUIT
+24 ;
+25 ;--- Private IA #5068.
+26 DO ORDER^RAMAGRP1(.ORDINFO,DFN,RAMLC,RADPROC,STUDYDAT,RACAT,REQLOC,REQPHYS,REASON,.MISC)
+27 ;
+28 ;--- Re-format error output or return new IEN in RAD/NUC MED ORDERS File (#75.1)
+29 IF ORDINFO(0)<0
Begin DoDot:1
+30 ;
+31 SET RETURN(0)=-1_SEPSTAT_$ORDER(ORDINFO("A"),-1)_" error lines returned."
+32 NEW X
SET X=0
FOR
SET X=$ORDER(ORDINFO(X))
if X=""
QUIT
Begin DoDot:2
+33 ;
+34 SET RETURN(X)=$PIECE(ORDINFO(X),U,1)_SEPSTAT_$PIECE(ORDINFO(X),U,2,999)
+35 QUIT
End DoDot:2
+36 QUIT
End DoDot:1
KILL ORDINFO
+37 IF '$TEST
SET RETURN(0)=ORDINFO(0)
+38 KILL ORDINFO
+39 QUIT
+40 ;
+41 ;+++++ Wrap calls to RPC: RAMAG EXAM REGISTER & re-format output.
+42 ;
+43 ; RPC: MAGV RAD EXAM REGISTER Private IA #5069.
+44 ;
+45 ; Inputs:
+46 ; =======
+47 ;
+48 ; RETURN
+49 ; RAOIFN
+50 ; EXMDTE
+51 ; RAMSC
+52 ;
+53 ; Notes:
+54 ; ======
+55 ;
+56 ; The parameters are the same as those of the underlying call.
+57 ;
XMREGSTR(RETURN,RAOIFN,EXMDTE,RAMSC) ;
+1 ;
+2 KILL RETURN
+3 NEW SEPSTAT,SEPOUTP,IMAGLOC
DO ZRUSEPIN
+4 NEW DIV
SET DIV=$$GETDIV()
+5 ;
+6 ; Check if imaging location is present - if not find outside imaging location for procedure and division
+7 NEW RODATA
SET RODATA=$GET(^RAO(75.1,RAOIFN,0))
+8 if $PIECE(RODATA,U,20)=""
Begin DoDot:1
+9 NEW LOCINFO,PROCIEN,RAMLC
SET PROCIEN=$PIECE(RODATA,U,2)
+10 DO IMAGELOC(.RAMLC,PROCIEN,DIV)
+11 if $PIECE(RAMLC,SEPSTAT)<0
SET RETURN(0)=RAMLC
+12 if $GET(RETURN(0))
QUIT
+13 SET RAMLC=$PIECE(RAMLC,SEPSTAT,2)
+14 ; call the RPC to update the radiology imaging location in the radiology order file (#75.1).
+15 DO IMAGELOC^MAGDRPCB(.LOCINFO,RAOIFN,RAMLC)
+16 ;"-1"_SEPSTAT_"Error in rpc MAG DICOM SET IMAGING LOCATION"
IF $GET(LOCINFO)<0
SET RETURN(0)=LOCINFO
+17 QUIT
End DoDot:1
+18 ;
+19 ;Get imaging location IEN (#79.1)
+20 KILL RAMLC,PROCIEN
+21 SET PROCIEN=$PIECE(RODATA,U,2)
+22 DO IMAGELOC(.RAMLC,PROCIEN,DIV)
+23 if $PIECE(RAMLC,SEPSTAT)<0
SET RETURN(0)=RAMLC
+24 if $GET(RETURN(0))
QUIT
+25 SET RAMLC=$PIECE(RAMLC,SEPSTAT,2)
+26 ;Get corresponding hospital location IEN (#44)
+27 SET IMAGLOC=$$GET1^DIQ(79.1,.RAMLC,.01,"I")
+28 KILL RAMSC
+29 SET RAMSC(1)="PRINCLIN^^"_$GET(IMAGLOC)
+30 SET RAMSC(2)="FLAGS^^D"
+31 ;
+32 if $GET(RETURN(0))
QUIT
+33 ;--- Private IA #5069.
+34 DO REGISTER^RAMAGRP1(.RARESULT,RAOIFN,EXMDTE,.RAMSC)
+35 ;
+36 IF RARESULT(0)<0
Begin DoDot:1
+37 ;
+38 SET RETURN(0)=-1_SEPSTAT_$ORDER(RARESULT("A"),-1)_" error lines returned."
+39 NEW X
SET X=0
FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+40 ;
+41 SET RETURN(X)=$PIECE(RARESULT(X),U,1)_SEPSTAT_$PIECE(RARESULT(X),U,2,999)
+42 QUIT
End DoDot:2
End DoDot:1
+43 IF '$TEST
Begin DoDot:1
+44 SET RETURN(0)=0_SEPSTAT_RARESULT(0)
+45 NEW X
SET X=0
FOR
SET X=$ORDER(RARESULT(X))
if X=""
QUIT
Begin DoDot:2
+46 ;
+47 SET RETURN(X)=$TRANSLATE(RARESULT(X),U,SEPOUTP)
+48 QUIT
End DoDot:2
+49 QUIT
End DoDot:1
+50 QUIT
+51 ;+++ Routine Utility: Initialize Separators
ZRUSEPIN ;
+1 SET SEPOUTP=$$OUTSEP^MAGVIM01
+2 SET SEPSTAT=$$STATSEP^MAGVIM01
+3 QUIT
+4 ;+++ Use Alternate Division if it's available otherwise use site#
GETDIV() ;
+1 NEW DIV
+2 ; IA# 2263
SET DIV=$$GET^XPAR("SYS","MAG ALTERNATE DIVISION",,"I")
+3 IF DIV=""
QUIT DUZ(2)
+4 QUIT DIV
+5 ;
MAKELIST(RACTION,RAIMGTYP,RAMSC,MAGVUSR,MAGSITEP) ; output required fields
+1 ; Load required flags
+2 NEW INFO
+3 DO EXMSTREQ^RAMAGRP2(.INFO,RACTION,RAIMGTYP)
+4 IF INFO(0)<0
QUIT INFO(1)
+5 ;
+6 NEW TODAYHL7
+7 SET TODAYHL7=$$NOW^XLFDT()\1
SET $EXTRACT(TODAYHL7)=$EXTRACT(TODAYHL7)+17
+8 ;
+9 NEW REQ,RADPVAL
+10 ;REQ001 - technologist
+11 SET REQ(1)="TECH^1^"_MAGVUSR
+12 ;
+13 ;REQ002 - resident or staff
+14 ;REQ003 - detailed procedure - taken care of already
+15 ;
+16 ;REQ004 - film entry
+17 SET RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD FILM SIZE","I")
+18 SET REQ(4)="FILMSIZE^1^"_RADPVAL_U_"0"
+19 ;
+20 ;REQ005 - diagnostic code default, if not supplied by user.
+21 if $GET(RADXPRIM)=""
Begin DoDot:1
+22 SET RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD PRIMARY DIAGNOSTIC CODE","I")
+23 SET REQ(5)="PRIMDXCODE^^"_RADPVAL
+24 QUIT
End DoDot:1
+25 ;
+26 ;REQ006 - camera / equipment / room
+27 SET RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD PRIMARY CAMERA/EQUIP/RM","I")
+28 SET REQ(6)="PRIMCAM^^"_RADPVAL
+29 ;
+30 ;REQ007 - reserved
+31 ;REQ008 - reserved
+32 ;REQ009 - reserved
+33 ;REQ010 - reserved
+34 ;
+35 ;REQ011 - report entered
+36 SET REQ(11)="RPTDTE^^"_TODAYHL7
+37 ;--- Add manually entered REPORT text to the RAMSC array.
IF $GET(RAMAN)=1
DO MANRPRT(.RARPTXT,"R",1)
+38 IF $GET(RAMAN)'=1
Begin DoDot:1
+39 IF $GET(RASTDRPT)=""
SET REQ(11,1)="REPORT^1^Electronically generated report for outside study."
+40 ; Add the REPORT text of a selected STANDARD REPORT to the RAMSC array.
IF $GET(RASTDRPT)'=""
DO STNDRPRT(RASTDRPT,"R",1)
+41 QUIT
End DoDot:1
+42 ;
+43 ;--- Report can't be blank
+44 NEW NOREPORT
SET NOREPORT=0
+45 IF '$DATA(RARPTXT)
IF $GET(RASTDRPT)=""
SET NOREPORT=1
+46 IF '$DATA(RARPTXT)
IF $GET(RASTDRPT)'=""
IF '$DATA(^RA(74.1,RASTDRPT,"R"))
SET NOREPORT=1
+47 IF $DATA(RARPTXT)
IF $GET(RARPTXT)=""
IF $GET(RASTDRPT)=""
SET NOREPORT=1
+48 IF NOREPORT
IF $GET(REQ(11,1))=""
SET REQ(11,1)="REPORT^1^No report text"
+49 ;
+50 ;REQ012 - verified report
+51 SET REQ(12)="VERDTE^^"_TODAYHL7
+52 SET REQ(12,1)="RPTSTATUS^^EF"
+53 ;
+54 ;REQ013 - procedure modifiers required - previously done
+55 ;
+56 ;REQ014 - cpt modifiers
+57 SET RADPVAL=$$GET1^DIQ(2006.1,MAGSITEP,"RAD CPT MODIFIERS","I")
+58 if RADPVAL
SET REQ(14)="CPTMODS^1^"_RADPVAL
+59 ;
+60 ;REQ015 - reserved
+61 ;
+62 ;REQ016 - impression
+63 ;--- Add manually entered impression text to the RAMSC array.
IF $GET(RAMAN)=1
DO MANRPRT(.RAIMPRS,"I",1)
+64 IF $GET(RAMAN)'=1
Begin DoDot:1
+65 IF $GET(RASTDRPT)=""
SET REQ(16)="IMPRESSION^1^Electronically generated report for outside study."
+66 ; Add the IMPRESSION text of a selected STANDARD REPORT to the RAMSC array.
IF $GET(RASTDRPT)'=""
DO STNDRPRT(RASTDRPT,"I",1)
+67 QUIT
End DoDot:1
+68 ;
+69 ;--- Impression can't be blank
+70 NEW NOIMPR
SET NOIMPR=0
+71 IF '$DATA(RAIMPRS)
IF $GET(RASTDRPT)=""
SET NOIMPR=1
+72 IF '$DATA(RAIMPRS)
IF $GET(RASTDRPT)'=""
IF '$DATA(^RA(74.1,RASTDRPT,"I"))
SET NOIMPR=1
+73 IF $DATA(RAIMPRS)
IF $GET(RAIMPRS)=""
IF $GET(RASTDRPT)=""
SET NOIMPR=1
+74 IF NOIMPR
IF $GET(REQ(16))=""
SET REQ(16)="IMPRESSION^1^No impression text"
+75 ;
+76 NEW INDEX
+77 FOR INDEX=1:1:16
IF $PIECE(INFO(0),"^",INDEX)
Begin DoDot:1
+78 if $DATA(REQ(INDEX))
DO OUTPUT(REQ(INDEX),.RAMSC)
+79 if $DATA(REQ(INDEX,1))
DO OUTPUT(REQ(INDEX,1),.RAMSC)
+80 QUIT
End DoDot:1
+81 ;
+82 QUIT 0
+83 ;
+84 ;+++++ Add selected STANDARD REPORT text to the Miscellaneous Parameters array.
+85 ;
STNDRPRT(RASTDRPT,SSCR,INDEX1) ;
+1 ;
+2 NEW PREFIX
SET PREFIX=$SELECT(SSCR="R":"REPORT",SSCR="I":"IMPRESSION")
+3 ;
+4 NEW CT
+5 SET CT=0
FOR
SET CT=$ORDER(^RA(74.1,RASTDRPT,SSCR,CT))
if CT=""
QUIT
Begin DoDot:1
+6 NEW RPTXT
+7 SET RPTXT=PREFIX_U_(CT+INDEX1)_U_$GET(^RA(74.1,RASTDRPT,SSCR,CT,0))
DO OUTPUT(RPTXT,.RAMSC)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
+11 ;+++++ Add manually entered REPORT/IMPRESSION text to the Miscellaneous Parameters array.
+12 ;
MANRPRT(TXTLST,SSCR,INDEX1) ;
+1 ;
+2 NEW PREFIX
SET PREFIX=$SELECT(SSCR="R":"REPORT",SSCR="I":"IMPRESSION")
+3 NEW CT
SET CT=""
+4 FOR
SET CT=$ORDER(TXTLST(CT))
if CT=""
QUIT
Begin DoDot:1
+5 NEW RPTXT
+6 SET RPTXT=PREFIX_U_(CT+INDEX1)_U_TXTLST(CT)
DO OUTPUT(RPTXT,.RAMSC)
+7 QUIT
End DoDot:1
+8 QUIT
+9 ;
OUTPUT(TEXT,ARRAY) ;
+1 NEW I
+2 SET I=$ORDER(ARRAY(""),-1)+1
+3 SET ARRAY(I)=TEXT
+4 QUIT
+5 ;
+6 ; MAGV OUTSIDE IMAGE LOCATION
+7 ;
+8 ; Inputs:
+9 ; =======
+10 ;
+11 ; PROCIEN -- IEN of procedure in RAD/NUC MED PROCEDURES (file #71)
+12 ; DIVISION - IEN of division in INSTITUTION (file #4)
+13 ;
+14 ; Output:
+15 ; ========
+16 ;
+17 ; <0 Error message
+18 ; 0 IEN of the Outside Image Location in the IMAGE LOCATIONS (file #79.1)
+19 ;
IMAGELOC(RESULT,PROCIEN,DIVISION) ;
+1 ; return the outside imaging location for a given radiology procedure and division
+2 NEW IEN,IMAGETYPE,SEPSTAT,SEPOUTP
DO ZRUSEPIN
+3 KILL RESULT
+4 SET PROCIEN=$GET(PROCIEN)
+5 IF (PROCIEN'>0)!(PROCIEN'=+PROCIEN)
Begin DoDot:1
+6 SET RESULT="-1"_SEPSTAT_"Invalid or missing Radiology Procedure pointer: """_PROCIEN_"""."
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 SET DIVISION=$GET(DIVISION)
+10 IF (DIVISION'>0)!(DIVISION'=+DIVISION)
Begin DoDot:1
+11 SET RESULT="-2"_SEPSTAT_"Invalid or missing Division pointer:"""_DIVISION_"""."
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 SET IMAGETYPE=$$GET1^DIQ(71,PROCIEN,12,"I")
+15 IF 'IMAGETYPE
Begin DoDot:1
+16 SET RESULT="-3"_SEPSTAT_"Image Type could not be determined for Radiology Procedure pointer: """_PROCIEN_"""."
+17 QUIT
End DoDot:1
QUIT
+18 ;
+19 IF $$GET1^DIQ(4,DIVISION,.01)=""
Begin DoDot:1
+20 SET RESULT="-4"_SEPSTAT_"Invalid Division (Institution) pointer:"""_DIVISION_"""."
+21 QUIT
End DoDot:1
QUIT
+22 SET IEN=$ORDER(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,""))
+23 IF IEN=""
Begin DoDot:1
+24 SET RESULT="-5"_SEPSTAT_"Outside Imaging Location could not be determined for Division: "_DIVISION_" & Procedure: """_PROCIEN_"""."
+25 QUIT
End DoDot:1
QUIT
+26 SET RESULT=0_SEPSTAT_$$GET1^DIQ(2006.5759,IEN,.01,"I")
+27 QUIT
ADDROOM(INFO,RAEXAM) ; add the OUTSIDE STUDY camera equipment room to the IMAGING LOCATION
+1 ;S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM ADD CAMERA EQUIP RM","M",.INFO,RAEXAM)
+2 DO ADDROOM^MAGDRPCB(.INFO,RAEXAM)
+3 QUIT
+4 ;
