MAGDRPCB ;WOIFO/PMK/MLS/SG - Imaging RPCs for Importer ; 16 Jan 2013 4:41 PM
;;3.0;IMAGING;**53,118,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
;; 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
;
FILM(RESULTS,FILM) ; RPC = MAG DICOM GET RAD FILM
D LOOKUP(.RESULTS,$G(FILM),78.4,"B",".01") ; ICR 5360
Q
;
DXCODE(RESULTS,DXCODE) ; RPC = MAG DICOM GET RAD DIAGNOSTIC CODE
D LOOKUP(.RESULTS,$G(DXCODE),78.3,"B",".01") ; ICR 4112
Q
;
CAMERA(RESULTS,CAMERA) ; RPC = MAG DICOM GET RAD CAMERA
D LOOKUP(.RESULTS,$G(CAMERA),78.6,"B",".01;2") ; ICR 5359
Q
;
CPTMOD(RESULTS,CPTMOD,MAGDT) ; RPC = MAG DICOM GET RAD CPT MOD
; CPTMOD = partial CPT modifier match
N I,SCR
S:$G(MAGDT)'>0 MAGDT=$$DT^XLFDT
S SCR="S D=$$MOD^ICPTMOD(Y,""I"",MAGDT) I D'<0,$P(D,U,7)"
D LOOKUP(.RESULTS,$G(CPTMOD),81.3,"C","",SCR) ; ICR 3026
F I=1:1:$G(RESULTS(1)) D
. S $P(RESULTS(I+1),"^",2)=$P($$MOD^ICPTMOD(RESULTS(I+1),"I"),"^",3)
. Q
Q
;
LOOKUP(RESULTS,SRCHVAL,FILE,XREF,FIELDS,SCREEN,MAX) ; search file
N CNT,I,MAGTMP,MAGMSG,MAXNR,X
S MAXNR=100
I $G(MAX)="1" S MAXNR="" ; Remove 100 record maximum constraint if MAX = 1
S SRCHVAL=$$UP^XLFSTR($TR(SRCHVAL,"*?"))
S SRCHVAL=$E(SRCHVAL,1,30) ; limit of 30 characters for B or C cross reference
S MAGTMP=$NA(^TMP($T(+0),$J))
K @MAGTMP,RESULTS
;
;--- Perform the search
D LIST^DIC(FILE,,"@;"_FIELDS,"P",MAXNR,,SRCHVAL,XREF,$G(SCREEN),,MAGTMP,"MAGMSG")
S X=$G(@MAGTMP@("DILIST",0))
I X'>0 S RESULTS(1)="-1^No records match the input." Q
I $P(X,U,3) D Q
. S RESULTS(1)="-2,More than "_MAXNR_" matches; please specify"
. S RESULTS(1)=RESULTS(1)_" more characters in the name."
. Q
;
;--- Copy the records to the result array
S (RESULTS(1),I)=0
F S I=$O(@MAGTMP@("DILIST",I)) Q:'I D
. S RESULTS(1)=RESULTS(1)+1
. S RESULTS(RESULTS(1)+1)=@MAGTMP@("DILIST",I,0)
. Q
;
;--- Cleanup
K @MAGTMP
Q
;
;***** RETURNS LIST OF USERS WITH PROVIDED RADIOLOGY CLASSIFICATION
; RPC: MAG DICOM GET RAD PERSON
;
; .RESULTS Reference to a local variable where results
; are returned to.
;
; MAGRADCLASS Radiology classification codes (can be combined):
;
; C Clerk R Resident
; S Staff T Technologist
;
; [NAME] Partial name match.
;
RADLST(RESULTS,MAGRADCLASS,NAME) ;
N I,MAGMSG,MAGTMP,MAXNR,X
S MAXNR=100 ; Maximum number of records to return
S DT=$$DT^XLFDT ; Make sure that the actual date is there
S MAGTMP=$NA(^TMP($T(+0),$J))
K @MAGTMP,RESULTS
;
;--- Validate parameters
I $G(MAGRADCLASS)="" D Q
. S RESULTS(1)="-1^No RAD/NUC classification provided."
. Q
S NAME=$$UP^XLFSTR($TR($G(NAME),"*?"))
S NAME=$E(NAME,1,30) ; limit of 30 characters for B cross reference
;
;--- Search for users
S X="I $$SCRUSR^"_$T(+0)_"(Y)" ; Screening code
D LIST^DIC(200,,"@;.01","P",MAXNR,,NAME,"B",X,,MAGTMP,"MAGMSG") ; ICR # 10060
S X=$G(@MAGTMP@("DILIST",0))
I X'>0 S RESULTS(1)="-1^No provider matching input." Q
I $P(X,U,3) D Q
. S RESULTS(1)="-2,More than "_MAXNR_" matches; please specify"
. S RESULTS(1)=RESULTS(1)_" more characters in the name."
. Q
;
;--- Copy the records to the result array
S (RESULTS(1),I)=0
F S I=$O(@MAGTMP@("DILIST",I)) Q:'I D
. S RESULTS(1)=RESULTS(1)+1
. S RESULTS(RESULTS(1)+1)=@MAGTMP@("DILIST",I,0)
. Q
;
;--- Cleanup
K @MAGTMP
Q
;
;***** SCREENING LOGIC FOR SEARCH FOR RADIOLOGY USERS
;
; IEN IEN in the NEW PERSON file (#200)
;
; Input variables:
; MAGRADCLASS
;
; Return Values:
; 0 Skip the record
; 1 Get the record
;
SCRUSR(IEN) ;
N IEN1,MAGMSG,OK,TERMDT
;--- Check the termination date
S TERMDT=$$GET1^DIQ(200,IEN_",",9.2,"I",,"MAGMSG") ; ICR # 10060
I TERMDT>0 Q:TERMDT'>DT 0
;--- Check the radiology classification
S (IEN1,OK)=0
F S IEN1=$O(^VA(200,IEN,"RAC",IEN1)) Q:'IEN1 D Q:OK
. S:MAGRADCLASS[$P(^VA(200,IEN,"RAC",IEN1,0),U) OK=1
. Q
Q OK
;
GETLOC(RESULTS,LOCATION) ; RPC = MAG DICOM GET HOSP LOCATION
N I,INACTIVE,LIST,REACTIVE,TYPE
D LOOKUP(.LIST,$G(LOCATION),44,"B",".01;2I;2505I;2506I",,1) ; ICR 10040
K RESULTS
;--- Copy the records to the result array
S (RESULTS(1),I)=0
F I=2:1:LIST(1)+1 D
. S TYPE=$P(LIST(I),"^",3)
. ;
. ; allow C=Clinic, M=Module, W=Ward, Z=Other Location
. ; allow N=Non-clinic stop, OR=Operating Room
. ; ignore F=File area and I=Imaging
. ;
. I "^C^M^W^Z^N^OR^"'[("^"_TYPE_"^") Q
. ;
. ; check inactivate date and reactivate date
. S INACTIVE=$P(LIST(I),"^",4),REACTIVE=$P(LIST(I),"^",5)
. I INACTIVE,DT>INACTIVE Q:'REACTIVE Q:INACTIVE>REACTIVE Q:DT<REACTIVE
. ;
. S RESULTS(1)=RESULTS(1)+1
. S RESULTS(I)=$P(LIST(I),"^",1,2)
. Q
Q
;
USERNAME(RESULT) ; RPC = MAG DICOM GET USERNAME
S RESULT=$$GET1^DIQ(200,DUZ,.01) ; ICR # 10060
Q
;
ORDERS(ARRAY,DFN) ; RPC = MAG DICOM GET RAD ORDERS
; look up radiology orders
N ACNUMB,CASENUMB,DIERR,EXAMDATA,EXAMDATE,ERROR,FIELDS,I,IENS,IMAGLOCN,INACTDAT
N ORDER,MAGEXAM,MAGMSG,MAGTMPEXAM,MAGTMPMOD,MODCOUNT,MODDATA
N MODIEN,MODIFIER,MSG,PROCIEN,RACNI,RADFN,RADTI,RAOIEN,RC,STATUS,STUDYDAT,TODAY,X,Z
K ARRAY
S DFN=$G(DFN),TODAY=$$DT^XLFDT()
I (DFN'>0)!(DFN'=+DFN) D Q
. S ARRAY(1)="-1,Invalid or missing patient identifier: """_DFN_"""."
. Q
;
; Make sure that the patient is registered in the RAD/NUC MED PATIENT file (#70)
;
S RC=$$RAPTREG^RAMAGU04(DFN) I RC<0 D Q ; ICR 5519
. S ARRAY(1)="-2,Patient with DFN #"_DFN_" is not defined in the RAD/NUC MED PATIENT file (#70)."
. S ARRAY(2)=RC
. Q
;
; Use MUMPS global reads to get data from ^RAO because of possible bad data
; that would cause Fileman to throw an error and not return any results.
;
S (ARRAY(1),ERROR,RAOIEN)=0
F S RAOIEN=$O(^RAO(75.1,"B",DFN,RAOIEN)) Q:ERROR Q:RAOIEN="" D ; ICR 3074
. S STATUS=$$GET1^DIQ(75.1,RAOIEN,5) ; request status
. I "^^COMPLETE^DISCONTINUED^UNRELEASED^"[("^"_STATUS_"^") Q ; quit if status is null too
. S Z=$G(^RAO(75.1,RAOIEN,0))
. K ORDER S $P(ORDER,"^",11)="" ; initialize ORDER string
. S $P(ORDER,"^",1)=RAOIEN ; file 75.1 IEN
. S PROCIEN=$P(Z,"^",2) ; procedure
. Q:PROCIEN="" Q:'$D(^RAMIS(71,PROCIEN,0)) ; null or bad PROCIEN
. S INACTDAT=$P($G(^RAMIS(71,PROCIEN,"I")),U)
. I INACTDAT,INACTDAT<TODAY Q ; ignore inactive procedures
. S $P(ORDER,"^",2)=PROCIEN ; procedure
. ; piece 3 of ORDER is modifier(s)
. S $P(ORDER,"^",4)=STATUS ; request status
. S $P(ORDER,"^",5)=$P(Z,"^",16) ; request entered date
. S $P(ORDER,"^",6)=$$GET1^DIQ(75.1,RAOIEN,1.1) ; reason for study
. I $D(^RADPT("AO",RAOIEN)) D
. . S RADFN=$O(^RADPT("AO",RAOIEN,"")) ; ICR 1172
. . S RADTI=$O(^RADPT("AO",RAOIEN,RADFN,""))
. . S RACNI=$O(^RADPT("AO",RAOIEN,RADFN,RADTI,""))
. . S $P(ORDER,"^",7)=RADTI
. . S $P(ORDER,"^",8)=RACNI
. . S MAGTMPEXAM=$NA(^TMP($T(+0),$J,"EXAM"))
. . S IENS=RACNI_","_RADTI_","_RADFN_","
. . S EXAMDATA=$NA(@MAGTMPEXAM@(70.03,IENS))
. . I $T(ACCFIND^RAAPI)'="" S FIELDS=".01;31;" ; requires RA*5.0*47
. . E S FIELDS=".01;" ; no accession number field (#31)
. . K @MAGTMPEXAM,MAGMSG
. . D GETS^DIQ(70.03,IENS,FIELDS,"EI",MAGTMPEXAM,"MAGMSG") ; ICR 1172
. . I $D(MAGMSG) D ORDERERR(.ARRAY,.MAGMSG,-3) S ERROR=-3 Q ; fatal FileMan error
. . S EXAMDATE=$$GET1^DIQ(70.02,(RADTI_","_RADFN),.01,"I") ; ICR 1172
. . S ACNUMB=$G(@EXAMDATA@(31,"E"))
. . I ACNUMB="" D
. . . S CASENUMB=@EXAMDATA@(.01,"E")
. . . S ACNUMB=$E(EXAMDATE,4,7)_$E(EXAMDATE,2,3)_"-"_CASENUMB
. . . Q
. . S $P(ORDER,"^",9)=ACNUMB,$P(ORDER,"^",10)=EXAMDATE
. . S IMAGLOCN=$$GET1^DIQ(70.02,(RADTI_","_RADFN),4) ; ICR 1172
. . S $P(ORDER,"^",11)=IMAGLOCN
. . Q
. ;
. I ERROR Q ; FileMan error encountered in exam lookup
. ;
. ; get procedure modifier(s)
. S MAGTMPMOD=$NA(^TMP($T(+0),$J,"MODIFIER")),MODDATA=$NA(@MAGTMPMOD@("DILIST"))
. K @MAGTMPMOD,MAGMSG
. D LIST^DIC(75.1125,","_RAOIEN_",","@;.01;.01I;IX","",,,,,,,MAGTMPMOD,"MAGMSG") ; ICR 3074
. I $D(MAGMSG) D ORDERERR(.ARRAY,.MAGMSG,-4) Q ; fatal FileMan error
. S MODCOUNT=+@MODDATA@(0)
. S MODIFIER=""
. F I=1:1:MODCOUNT D
. . S:$L(MODIFIER) MODIFIER=MODIFIER_"~"
. . S MODIEN=@MODDATA@(2,I)
. . S MODIFIER=MODIFIER_@MODDATA@("ID",MODIEN,.01,"E")_"|"_^("I")
. . Q
. S $P(ORDER,"^",3)=MODIFIER
. ;
. S ARRAY(1)=ARRAY(1)+1,ARRAY(ARRAY(1)+1)=ORDER
. Q
K:$D(MAGTMPEXAM) @MAGTMPEXAM K:$D(MAGTMPMOD) @MAGTMPMOD ; cleanup
Q
;
ORDERERR(ARRAY,MSG,ERRNUMB) ; handle FilMan errors in ORDER subroutine
N I,NODE
K ARRAY
S I=1,NODE="MSG"
F S NODE=$Q(@NODE) Q:NODE="" D
. S I=I+1,ARRAY(I)=NODE
. I $D(@NODE) S ARRAY(I)=ARRAY(I)_"="_@NODE
. Q
S ARRAY(1)="-100,Fatal FileMan error #"_ERRNUMB
Q
;
IMAGELOC(RESULT,RAOIEN,RAMLC) ; RPC = MAG DICOM SET IMAGING LOCATION
N DIERR,MAGFDA,MAGMSG
;
K RESULT
S RAOIEN=$G(RAOIEN)
I (RAOIEN'>0)!(RAOIEN'=+RAOIEN) D Q
. S RESULT="-1,Invalid or missing Radiology Order pointer: """_RAOIEN_"""."
. Q
;
S RAMLC=$G(RAMLC)
I (RAMLC'>0)!(RAMLC'=+RAMLC) D Q
. S RESULT="-2,Invalid or missing Radiology Image Location identifier: """_RAMLC_"""."
. Q
;
I $$GET1^DIQ(75.1,RAOIEN,.01)="" D Q ; ICR 3074
. S RESULT="-3,Missing Radiology Order for pointer: """_RAOIEN_"""."
. Q
;
I $$GET1^DIQ(79.1,RAMLC,.01)="" D Q ; ICR 5357
. S RESULT="-4,Missing Radiology Image Location for pointer: """_RAMLC_"""."
. Q
;
I $$GET1^DIQ(75.1,RAOIEN,20)="" D Q ; ICR 3074
. S MAGFDA(75.1,RAOIEN_",",20)=RAMLC ; IMAGING LOCATION
. D FILE^DIE("","MAGFDA","MAGMSG") ; ICR 3074
. I $D(MAGMSG) S RESULT="-5,Error setting Radiology Image Location" Q
. S RESULT="1,Radiology Image Location set for pointer: """_RAOIEN_"""."
. Q
E D
. S RESULT="2,Radiology Image Location already set for pointer: """_RAOIEN_""", operation ignored."
. Q
Q
;
ADDROOM(RETURN,RAEXAM) ; RPC = MAG DICOM ADD CAMERA EQUIP RM
N HIT,I,IENS,LOCNAME,OUTSIDESTUDY,MAGFDA,MAGMSG,RADIMGLOC,ROOMS
K RETURN
;
I $L($G(RAEXAM),"^")<2 S RETURN(0)="-1,Invalid or missing Radiology Exam pointer: """_RAEXAM_"""." Q
;
; get the Radiology IMAGING LOCATION
S IENS=$P(RAEXAM,"^",2)_","_$P(RAEXAM,"^",1)_","
S RADIMGLOC=$$GET1^DIQ(70.02,IENS,4,"I") ; ICR 1172
I 'RADIMGLOC S RETURN(0)="-2,Invalid or missing Radiology IMAGING LOCATION for Exam pointer: """_RAEXAM_"""." Q
S LOCNAME=$$GET1^DIQ(79.1,RADIMGLOC,.01)
;
; check if the IMAGING LOCATION has the OUTSIDE STUDY Camera/Equipment/Room
S OUTSIDESTUDY="OUTSIDE STUDY" ; designated name
D LIST^DIC(79.12,","_RADIMGLOC_",","@;.01","",,,,,,,"ROOMS","MAGMSG")
I $D(MAGMSG) D ORDERERR(.RETURN,.MAGMSG,-3) Q ; fatal FileMan error
S HIT=0 F I=1:1:ROOMS("DILIST",0) D Q:HIT
. I ROOMS("DILIST","ID",I,".01")=OUTSIDESTUDY S HIT=1
. Q
I HIT S RETURN(0)="2,"_OUTSIDESTUDY_" is already defined for """_LOCNAME_"""." Q
;
; add the OUTSIDE STUDY Camera/Equipment/Room to the IMAGING LOCATION
S MAGFDA(79.12,"+1,"_RADIMGLOC_",",.01)=OUTSIDESTUDY
D UPDATE^DIE("E","MAGFDA","MAGIENS","MAGMSG") ; ICR 5357
I $D(MAGMSG) D ORDERERR(.RETURN,.MAGMSG,-4) Q ; fatal FileMan error
S RETURN(0)="1,"_OUTSIDESTUDY_" has been added for """_LOCNAME_"""."
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRPCB 12263 printed Dec 13, 2024@02:01:30 Page 2
MAGDRPCB ;WOIFO/PMK/MLS/SG - Imaging RPCs for Importer ; 16 Jan 2013 4:41 PM
+1 ;;3.0;IMAGING;**53,118,138**;Mar 19, 2002;Build 5380;Sep 03, 2013
+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 ;; | 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 QUIT
+18 ;
FILM(RESULTS,FILM) ; RPC = MAG DICOM GET RAD FILM
+1 ; ICR 5360
DO LOOKUP(.RESULTS,$GET(FILM),78.4,"B",".01")
+2 QUIT
+3 ;
DXCODE(RESULTS,DXCODE) ; RPC = MAG DICOM GET RAD DIAGNOSTIC CODE
+1 ; ICR 4112
DO LOOKUP(.RESULTS,$GET(DXCODE),78.3,"B",".01")
+2 QUIT
+3 ;
CAMERA(RESULTS,CAMERA) ; RPC = MAG DICOM GET RAD CAMERA
+1 ; ICR 5359
DO LOOKUP(.RESULTS,$GET(CAMERA),78.6,"B",".01;2")
+2 QUIT
+3 ;
CPTMOD(RESULTS,CPTMOD,MAGDT) ; RPC = MAG DICOM GET RAD CPT MOD
+1 ; CPTMOD = partial CPT modifier match
+2 NEW I,SCR
+3 if $GET(MAGDT)'>0
SET MAGDT=$$DT^XLFDT
+4 SET SCR="S D=$$MOD^ICPTMOD(Y,""I"",MAGDT) I D'<0,$P(D,U,7)"
+5 ; ICR 3026
DO LOOKUP(.RESULTS,$GET(CPTMOD),81.3,"C","",SCR)
+6 FOR I=1:1:$GET(RESULTS(1))
Begin DoDot:1
+7 SET $PIECE(RESULTS(I+1),"^",2)=$PIECE($$MOD^ICPTMOD(RESULTS(I+1),"I"),"^",3)
+8 QUIT
End DoDot:1
+9 QUIT
+10 ;
LOOKUP(RESULTS,SRCHVAL,FILE,XREF,FIELDS,SCREEN,MAX) ; search file
+1 NEW CNT,I,MAGTMP,MAGMSG,MAXNR,X
+2 SET MAXNR=100
+3 ; Remove 100 record maximum constraint if MAX = 1
IF $GET(MAX)="1"
SET MAXNR=""
+4 SET SRCHVAL=$$UP^XLFSTR($TRANSLATE(SRCHVAL,"*?"))
+5 ; limit of 30 characters for B or C cross reference
SET SRCHVAL=$EXTRACT(SRCHVAL,1,30)
+6 SET MAGTMP=$NAME(^TMP($TEXT(+0),$JOB))
+7 KILL @MAGTMP,RESULTS
+8 ;
+9 ;--- Perform the search
+10 DO LIST^DIC(FILE,,"@;"_FIELDS,"P",MAXNR,,SRCHVAL,XREF,$GET(SCREEN),,MAGTMP,"MAGMSG")
+11 SET X=$GET(@MAGTMP@("DILIST",0))
+12 IF X'>0
SET RESULTS(1)="-1^No records match the input."
QUIT
+13 IF $PIECE(X,U,3)
Begin DoDot:1
+14 SET RESULTS(1)="-2,More than "_MAXNR_" matches; please specify"
+15 SET RESULTS(1)=RESULTS(1)_" more characters in the name."
+16 QUIT
End DoDot:1
QUIT
+17 ;
+18 ;--- Copy the records to the result array
+19 SET (RESULTS(1),I)=0
+20 FOR
SET I=$ORDER(@MAGTMP@("DILIST",I))
if 'I
QUIT
Begin DoDot:1
+21 SET RESULTS(1)=RESULTS(1)+1
+22 SET RESULTS(RESULTS(1)+1)=@MAGTMP@("DILIST",I,0)
+23 QUIT
End DoDot:1
+24 ;
+25 ;--- Cleanup
+26 KILL @MAGTMP
+27 QUIT
+28 ;
+29 ;***** RETURNS LIST OF USERS WITH PROVIDED RADIOLOGY CLASSIFICATION
+30 ; RPC: MAG DICOM GET RAD PERSON
+31 ;
+32 ; .RESULTS Reference to a local variable where results
+33 ; are returned to.
+34 ;
+35 ; MAGRADCLASS Radiology classification codes (can be combined):
+36 ;
+37 ; C Clerk R Resident
+38 ; S Staff T Technologist
+39 ;
+40 ; [NAME] Partial name match.
+41 ;
RADLST(RESULTS,MAGRADCLASS,NAME) ;
+1 NEW I,MAGMSG,MAGTMP,MAXNR,X
+2 ; Maximum number of records to return
SET MAXNR=100
+3 ; Make sure that the actual date is there
SET DT=$$DT^XLFDT
+4 SET MAGTMP=$NAME(^TMP($TEXT(+0),$JOB))
+5 KILL @MAGTMP,RESULTS
+6 ;
+7 ;--- Validate parameters
+8 IF $GET(MAGRADCLASS)=""
Begin DoDot:1
+9 SET RESULTS(1)="-1^No RAD/NUC classification provided."
+10 QUIT
End DoDot:1
QUIT
+11 SET NAME=$$UP^XLFSTR($TRANSLATE($GET(NAME),"*?"))
+12 ; limit of 30 characters for B cross reference
SET NAME=$EXTRACT(NAME,1,30)
+13 ;
+14 ;--- Search for users
+15 ; Screening code
SET X="I $$SCRUSR^"_$TEXT(+0)_"(Y)"
+16 ; ICR # 10060
DO LIST^DIC(200,,"@;.01","P",MAXNR,,NAME,"B",X,,MAGTMP,"MAGMSG")
+17 SET X=$GET(@MAGTMP@("DILIST",0))
+18 IF X'>0
SET RESULTS(1)="-1^No provider matching input."
QUIT
+19 IF $PIECE(X,U,3)
Begin DoDot:1
+20 SET RESULTS(1)="-2,More than "_MAXNR_" matches; please specify"
+21 SET RESULTS(1)=RESULTS(1)_" more characters in the name."
+22 QUIT
End DoDot:1
QUIT
+23 ;
+24 ;--- Copy the records to the result array
+25 SET (RESULTS(1),I)=0
+26 FOR
SET I=$ORDER(@MAGTMP@("DILIST",I))
if 'I
QUIT
Begin DoDot:1
+27 SET RESULTS(1)=RESULTS(1)+1
+28 SET RESULTS(RESULTS(1)+1)=@MAGTMP@("DILIST",I,0)
+29 QUIT
End DoDot:1
+30 ;
+31 ;--- Cleanup
+32 KILL @MAGTMP
+33 QUIT
+34 ;
+35 ;***** SCREENING LOGIC FOR SEARCH FOR RADIOLOGY USERS
+36 ;
+37 ; IEN IEN in the NEW PERSON file (#200)
+38 ;
+39 ; Input variables:
+40 ; MAGRADCLASS
+41 ;
+42 ; Return Values:
+43 ; 0 Skip the record
+44 ; 1 Get the record
+45 ;
SCRUSR(IEN) ;
+1 NEW IEN1,MAGMSG,OK,TERMDT
+2 ;--- Check the termination date
+3 ; ICR # 10060
SET TERMDT=$$GET1^DIQ(200,IEN_",",9.2,"I",,"MAGMSG")
+4 IF TERMDT>0
if TERMDT'>DT
QUIT 0
+5 ;--- Check the radiology classification
+6 SET (IEN1,OK)=0
+7 FOR
SET IEN1=$ORDER(^VA(200,IEN,"RAC",IEN1))
if 'IEN1
QUIT
Begin DoDot:1
+8 if MAGRADCLASS[$PIECE(^VA(200,IEN,"RAC",IEN1,0),U)
SET OK=1
+9 QUIT
End DoDot:1
if OK
QUIT
+10 QUIT OK
+11 ;
GETLOC(RESULTS,LOCATION) ; RPC = MAG DICOM GET HOSP LOCATION
+1 NEW I,INACTIVE,LIST,REACTIVE,TYPE
+2 ; ICR 10040
DO LOOKUP(.LIST,$GET(LOCATION),44,"B",".01;2I;2505I;2506I",,1)
+3 KILL RESULTS
+4 ;--- Copy the records to the result array
+5 SET (RESULTS(1),I)=0
+6 FOR I=2:1:LIST(1)+1
Begin DoDot:1
+7 SET TYPE=$PIECE(LIST(I),"^",3)
+8 ;
+9 ; allow C=Clinic, M=Module, W=Ward, Z=Other Location
+10 ; allow N=Non-clinic stop, OR=Operating Room
+11 ; ignore F=File area and I=Imaging
+12 ;
+13 IF "^C^M^W^Z^N^OR^"'[("^"_TYPE_"^")
QUIT
+14 ;
+15 ; check inactivate date and reactivate date
+16 SET INACTIVE=$PIECE(LIST(I),"^",4)
SET REACTIVE=$PIECE(LIST(I),"^",5)
+17 IF INACTIVE
IF DT>INACTIVE
if 'REACTIVE
QUIT
if INACTIVE>REACTIVE
QUIT
if DT<REACTIVE
QUIT
+18 ;
+19 SET RESULTS(1)=RESULTS(1)+1
+20 SET RESULTS(I)=$PIECE(LIST(I),"^",1,2)
+21 QUIT
End DoDot:1
+22 QUIT
+23 ;
USERNAME(RESULT) ; RPC = MAG DICOM GET USERNAME
+1 ; ICR # 10060
SET RESULT=$$GET1^DIQ(200,DUZ,.01)
+2 QUIT
+3 ;
ORDERS(ARRAY,DFN) ; RPC = MAG DICOM GET RAD ORDERS
+1 ; look up radiology orders
+2 NEW ACNUMB,CASENUMB,DIERR,EXAMDATA,EXAMDATE,ERROR,FIELDS,I,IENS,IMAGLOCN,INACTDAT
+3 NEW ORDER,MAGEXAM,MAGMSG,MAGTMPEXAM,MAGTMPMOD,MODCOUNT,MODDATA
+4 NEW MODIEN,MODIFIER,MSG,PROCIEN,RACNI,RADFN,RADTI,RAOIEN,RC,STATUS,STUDYDAT,TODAY,X,Z
+5 KILL ARRAY
+6 SET DFN=$GET(DFN)
SET TODAY=$$DT^XLFDT()
+7 IF (DFN'>0)!(DFN'=+DFN)
Begin DoDot:1
+8 SET ARRAY(1)="-1,Invalid or missing patient identifier: """_DFN_"""."
+9 QUIT
End DoDot:1
QUIT
+10 ;
+11 ; Make sure that the patient is registered in the RAD/NUC MED PATIENT file (#70)
+12 ;
+13 ; ICR 5519
SET RC=$$RAPTREG^RAMAGU04(DFN)
IF RC<0
Begin DoDot:1
+14 SET ARRAY(1)="-2,Patient with DFN #"_DFN_" is not defined in the RAD/NUC MED PATIENT file (#70)."
+15 SET ARRAY(2)=RC
+16 QUIT
End DoDot:1
QUIT
+17 ;
+18 ; Use MUMPS global reads to get data from ^RAO because of possible bad data
+19 ; that would cause Fileman to throw an error and not return any results.
+20 ;
+21 SET (ARRAY(1),ERROR,RAOIEN)=0
+22 ; ICR 3074
FOR
SET RAOIEN=$ORDER(^RAO(75.1,"B",DFN,RAOIEN))
if ERROR
QUIT
if RAOIEN=""
QUIT
Begin DoDot:1
+23 ; request status
SET STATUS=$$GET1^DIQ(75.1,RAOIEN,5)
+24 ; quit if status is null too
IF "^^COMPLETE^DISCONTINUED^UNRELEASED^"[("^"_STATUS_"^")
QUIT
+25 SET Z=$GET(^RAO(75.1,RAOIEN,0))
+26 ; initialize ORDER string
KILL ORDER
SET $PIECE(ORDER,"^",11)=""
+27 ; file 75.1 IEN
SET $PIECE(ORDER,"^",1)=RAOIEN
+28 ; procedure
SET PROCIEN=$PIECE(Z,"^",2)
+29 ; null or bad PROCIEN
if PROCIEN=""
QUIT
if '$DATA(^RAMIS(71,PROCIEN,0))
QUIT
+30 SET INACTDAT=$PIECE($GET(^RAMIS(71,PROCIEN,"I")),U)
+31 ; ignore inactive procedures
IF INACTDAT
IF INACTDAT<TODAY
QUIT
+32 ; procedure
SET $PIECE(ORDER,"^",2)=PROCIEN
+33 ; piece 3 of ORDER is modifier(s)
+34 ; request status
SET $PIECE(ORDER,"^",4)=STATUS
+35 ; request entered date
SET $PIECE(ORDER,"^",5)=$PIECE(Z,"^",16)
+36 ; reason for study
SET $PIECE(ORDER,"^",6)=$$GET1^DIQ(75.1,RAOIEN,1.1)
+37 IF $DATA(^RADPT("AO",RAOIEN))
Begin DoDot:2
+38 ; ICR 1172
SET RADFN=$ORDER(^RADPT("AO",RAOIEN,""))
+39 SET RADTI=$ORDER(^RADPT("AO",RAOIEN,RADFN,""))
+40 SET RACNI=$ORDER(^RADPT("AO",RAOIEN,RADFN,RADTI,""))
+41 SET $PIECE(ORDER,"^",7)=RADTI
+42 SET $PIECE(ORDER,"^",8)=RACNI
+43 SET MAGTMPEXAM=$NAME(^TMP($TEXT(+0),$JOB,"EXAM"))
+44 SET IENS=RACNI_","_RADTI_","_RADFN_","
+45 SET EXAMDATA=$NAME(@MAGTMPEXAM@(70.03,IENS))
+46 ; requires RA*5.0*47
IF $TEXT(ACCFIND^RAAPI)'=""
SET FIELDS=".01;31;"
+47 ; no accession number field (#31)
IF '$TEST
SET FIELDS=".01;"
+48 KILL @MAGTMPEXAM,MAGMSG
+49 ; ICR 1172
DO GETS^DIQ(70.03,IENS,FIELDS,"EI",MAGTMPEXAM,"MAGMSG")
+50 ; fatal FileMan error
IF $DATA(MAGMSG)
DO ORDERERR(.ARRAY,.MAGMSG,-3)
SET ERROR=-3
QUIT
+51 ; ICR 1172
SET EXAMDATE=$$GET1^DIQ(70.02,(RADTI_","_RADFN),.01,"I")
+52 SET ACNUMB=$GET(@EXAMDATA@(31,"E"))
+53 IF ACNUMB=""
Begin DoDot:3
+54 SET CASENUMB=@EXAMDATA@(.01,"E")
+55 SET ACNUMB=$EXTRACT(EXAMDATE,4,7)_$EXTRACT(EXAMDATE,2,3)_"-"_CASENUMB
+56 QUIT
End DoDot:3
+57 SET $PIECE(ORDER,"^",9)=ACNUMB
SET $PIECE(ORDER,"^",10)=EXAMDATE
+58 ; ICR 1172
SET IMAGLOCN=$$GET1^DIQ(70.02,(RADTI_","_RADFN),4)
+59 SET $PIECE(ORDER,"^",11)=IMAGLOCN
+60 QUIT
End DoDot:2
+61 ;
+62 ; FileMan error encountered in exam lookup
IF ERROR
QUIT
+63 ;
+64 ; get procedure modifier(s)
+65 SET MAGTMPMOD=$NAME(^TMP($TEXT(+0),$JOB,"MODIFIER"))
SET MODDATA=$NAME(@MAGTMPMOD@("DILIST"))
+66 KILL @MAGTMPMOD,MAGMSG
+67 ; ICR 3074
DO LIST^DIC(75.1125,","_RAOIEN_",","@;.01;.01I;IX","",,,,,,,MAGTMPMOD,"MAGMSG")
+68 ; fatal FileMan error
IF $DATA(MAGMSG)
DO ORDERERR(.ARRAY,.MAGMSG,-4)
QUIT
+69 SET MODCOUNT=+@MODDATA@(0)
+70 SET MODIFIER=""
+71 FOR I=1:1:MODCOUNT
Begin DoDot:2
+72 if $LENGTH(MODIFIER)
SET MODIFIER=MODIFIER_"~"
+73 SET MODIEN=@MODDATA@(2,I)
+74 SET MODIFIER=MODIFIER_@MODDATA@("ID",MODIEN,.01,"E")_"|"_^("I")
+75 QUIT
End DoDot:2
+76 SET $PIECE(ORDER,"^",3)=MODIFIER
+77 ;
+78 SET ARRAY(1)=ARRAY(1)+1
SET ARRAY(ARRAY(1)+1)=ORDER
+79 QUIT
End DoDot:1
+80 ; cleanup
if $DATA(MAGTMPEXAM)
KILL @MAGTMPEXAM
if $DATA(MAGTMPMOD)
KILL @MAGTMPMOD
+81 QUIT
+82 ;
ORDERERR(ARRAY,MSG,ERRNUMB) ; handle FilMan errors in ORDER subroutine
+1 NEW I,NODE
+2 KILL ARRAY
+3 SET I=1
SET NODE="MSG"
+4 FOR
SET NODE=$QUERY(@NODE)
if NODE=""
QUIT
Begin DoDot:1
+5 SET I=I+1
SET ARRAY(I)=NODE
+6 IF $DATA(@NODE)
SET ARRAY(I)=ARRAY(I)_"="_@NODE
+7 QUIT
End DoDot:1
+8 SET ARRAY(1)="-100,Fatal FileMan error #"_ERRNUMB
+9 QUIT
+10 ;
IMAGELOC(RESULT,RAOIEN,RAMLC) ; RPC = MAG DICOM SET IMAGING LOCATION
+1 NEW DIERR,MAGFDA,MAGMSG
+2 ;
+3 KILL RESULT
+4 SET RAOIEN=$GET(RAOIEN)
+5 IF (RAOIEN'>0)!(RAOIEN'=+RAOIEN)
Begin DoDot:1
+6 SET RESULT="-1,Invalid or missing Radiology Order pointer: """_RAOIEN_"""."
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 SET RAMLC=$GET(RAMLC)
+10 IF (RAMLC'>0)!(RAMLC'=+RAMLC)
Begin DoDot:1
+11 SET RESULT="-2,Invalid or missing Radiology Image Location identifier: """_RAMLC_"""."
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 ; ICR 3074
IF $$GET1^DIQ(75.1,RAOIEN,.01)=""
Begin DoDot:1
+15 SET RESULT="-3,Missing Radiology Order for pointer: """_RAOIEN_"""."
+16 QUIT
End DoDot:1
QUIT
+17 ;
+18 ; ICR 5357
IF $$GET1^DIQ(79.1,RAMLC,.01)=""
Begin DoDot:1
+19 SET RESULT="-4,Missing Radiology Image Location for pointer: """_RAMLC_"""."
+20 QUIT
End DoDot:1
QUIT
+21 ;
+22 ; ICR 3074
IF $$GET1^DIQ(75.1,RAOIEN,20)=""
Begin DoDot:1
+23 ; IMAGING LOCATION
SET MAGFDA(75.1,RAOIEN_",",20)=RAMLC
+24 ; ICR 3074
DO FILE^DIE("","MAGFDA","MAGMSG")
+25 IF $DATA(MAGMSG)
SET RESULT="-5,Error setting Radiology Image Location"
QUIT
+26 SET RESULT="1,Radiology Image Location set for pointer: """_RAOIEN_"""."
+27 QUIT
End DoDot:1
QUIT
+28 IF '$TEST
Begin DoDot:1
+29 SET RESULT="2,Radiology Image Location already set for pointer: """_RAOIEN_""", operation ignored."
+30 QUIT
End DoDot:1
+31 QUIT
+32 ;
ADDROOM(RETURN,RAEXAM) ; RPC = MAG DICOM ADD CAMERA EQUIP RM
+1 NEW HIT,I,IENS,LOCNAME,OUTSIDESTUDY,MAGFDA,MAGMSG,RADIMGLOC,ROOMS
+2 KILL RETURN
+3 ;
+4 IF $LENGTH($GET(RAEXAM),"^")<2
SET RETURN(0)="-1,Invalid or missing Radiology Exam pointer: """_RAEXAM_"""."
QUIT
+5 ;
+6 ; get the Radiology IMAGING LOCATION
+7 SET IENS=$PIECE(RAEXAM,"^",2)_","_$PIECE(RAEXAM,"^",1)_","
+8 ; ICR 1172
SET RADIMGLOC=$$GET1^DIQ(70.02,IENS,4,"I")
+9 IF 'RADIMGLOC
SET RETURN(0)="-2,Invalid or missing Radiology IMAGING LOCATION for Exam pointer: """_RAEXAM_"""."
QUIT
+10 SET LOCNAME=$$GET1^DIQ(79.1,RADIMGLOC,.01)
+11 ;
+12 ; check if the IMAGING LOCATION has the OUTSIDE STUDY Camera/Equipment/Room
+13 ; designated name
SET OUTSIDESTUDY="OUTSIDE STUDY"
+14 DO LIST^DIC(79.12,","_RADIMGLOC_",","@;.01","",,,,,,,"ROOMS","MAGMSG")
+15 ; fatal FileMan error
IF $DATA(MAGMSG)
DO ORDERERR(.RETURN,.MAGMSG,-3)
QUIT
+16 SET HIT=0
FOR I=1:1:ROOMS("DILIST",0)
Begin DoDot:1
+17 IF ROOMS("DILIST","ID",I,".01")=OUTSIDESTUDY
SET HIT=1
+18 QUIT
End DoDot:1
if HIT
QUIT
+19 IF HIT
SET RETURN(0)="2,"_OUTSIDESTUDY_" is already defined for """_LOCNAME_"""."
QUIT
+20 ;
+21 ; add the OUTSIDE STUDY Camera/Equipment/Room to the IMAGING LOCATION
+22 SET MAGFDA(79.12,"+1,"_RADIMGLOC_",",.01)=OUTSIDESTUDY
+23 ; ICR 5357
DO UPDATE^DIE("E","MAGFDA","MAGIENS","MAGMSG")
+24 ; fatal FileMan error
IF $DATA(MAGMSG)
DO ORDERERR(.RETURN,.MAGMSG,-4)
QUIT
+25 SET RETURN(0)="1,"_OUTSIDESTUDY_" has been added for """_LOCNAME_"""."
+26 QUIT
