Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDSTQ1

MAGDSTQ1.m

Go to the documentation of this file. 
  1. MAGDSTQ1 ;WOIFO/PMK - Study Tracker - Query/Retrieve user ; Feb 15, 2022@10:52:44
  1.  ;;3.0;IMAGING;**231,305**;Mar 19, 2002;Build 3
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  ; 
  1.  ; Notice: This routine is on both VistA and the DICOM Gateway
  1.  ;
  1.  ;
  1.  Q
  1.  ;
  1. PNAME ; get patient name attribute
  1.  N HELP,PROMPT,X
  1.  S PATLKUPMODE=$$GETMODE()
  1.  I PATLKUPMODE="VISTA" D  ; routine for VistA
  1.  . D PATIENTQ^MAGDSTQ7
  1.  . Q
  1.  E  D
  1.  . S PROMPT="Enter the Patient Name"
  1.  . S HELP(1)="Enter the Patient Name in ""LAST^FIRST^MIDDLE"" format"
  1.  . S HELP(2)="You can enter a partial match and use ""*"" as a wild-card"
  1.  . S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  . D CHKNAME(ATTRIB)
  1.  . Q
  1.  Q
  1.  ;
  1. CHKNAME(ATTRIB) ; convert comma(s) to caret(s) & remove leading spaces
  1.  I $D(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB)) S ^(ATTRIB)=$TR(^(ATTRIB),",","^")
  1.  ; remove any spaces before delimiters
  1.  F  Q:$G(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB))'[" ^"  D
  1.  . S ^(ATTRIB)=$P(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB)," ^",1)_"^"_$P(^(ATTRIB)," ^",2,999)
  1.  . Q
  1.  ; remove any spaces after delimiters
  1.  F  Q:$G(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB))'["^ "  D
  1.  . S ^(ATTRIB)=$P(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB),"^ ",1)_"^"_$P(^(ATTRIB),"^ ",2,999)
  1.  . Q
  1.  I $D(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB)) S ^(ATTRIB)=$TR(^(ATTRIB),",","^")
  1.  Q
  1.  ;
  1. PID ; get patient id attribute
  1.  N HELP,PROMPT,X
  1.  S PATLKUPMODE=$$GETMODE()
  1.  I PATLKUPMODE="VISTA" D  ; routine for VistA
  1.  . D PATIENTQ^MAGDSTQ7
  1.  . Q
  1.  E  D
  1.  . S PROMPT="Enter the Patient ID"
  1.  . S HELP(1)="Enter the Patient ID (Social Security Number)"
  1.  . S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  . Q
  1.  Q
  1.  ;
  1. GETMODE() ; get the patient lookup CLIENT for manual Q/R client
  1.  N HELP,X
  1.  S PATLKUPMODE=$G(^TMP("MAG",$J,"Q/R PARAM","PATIENT LOOKUP MODE"),"<undef>")
  1.  I PATLKUPMODE="<undef>" D
  1.  . I '$$VISTA^MAGDSTQ,'$D(^TMP("MAG",$J,"DICOM RPC USER")) S PATLKUPMODE="MANUAL" Q  ; On gateway w/o RPCs
  1.  . I $$YESNO^MAGDSTQ("Use VistA Patient identification information for PACS Query/Retrieve?","y",.X,.HELP)<0 Q:""
  1.  . S PATLKUPMODE=$S(X="YES":"VISTA",1:"MANUAL")
  1.  . S ^TMP("MAG",$J,"Q/R PARAM","PATIENT LOOKUP MODE")=PATLKUPMODE
  1.  . I PATLKUPMODE="VISTA" D
  1.  . . D ASKDASH^MAGDSTQ0
  1.  . . Q
  1.  . Q
  1.  Q PATLKUPMODE
  1.  ;
  1. SEX ; get the patient's sex
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the sex of the patient"
  1.  S HELP(1)="Enter M for male, F for female, or O for other."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHECKSEX(.X)")
  1.  Q
  1.  ;
  1. CHECKSEX(X) ;
  1.  N RETURN,Y
  1.  S RETURN=-1
  1.  S X=$E(X) ; allow only a single uppercase letter
  1.  X ^%ZOSF("UPPERCASE") S X=Y
  1.  I "MFO"[X S RETURN=0
  1.  Q RETURN
  1.  ;
  1. ACNUMB ; enter the accession number
  1.  N ANPREFIX,HELP,PROMPT,X
  1.  S PROMPT="Enter the Accession Number"
  1.  S ANPREFIX=$G(^TMP("MAG",$J,"Q/R PARAM","ACCESSION NUMBER PREFIX"),"<undef>")
  1.  I ANPREFIX'="<undef>",ANPREFIX'="" S PROMPT=PROMPT_" ("_ANPREFIX_")"
  1.  S HELP(1)="For Radiology, the Accession Number is the Date-Case Number or Site-Date-Case Number."
  1.  S HELP(2)="For CPRS Requests, it is ""GMRC-"" followed by the request number, or"
  1.  S HELP(3)="Site-GMR-Request Number, where Site is the station number."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  I "@^"'[X S X=$$ANPREFIX
  1.  Q
  1.  ;
  1. ANPREFIX() ; add the site-specific accession number prefix
  1.  N ANPREFIX,RETURN
  1.  I $L(X,"-")=3 S RETURN=0 ; <station name> - MMDDYY - <case number>
  1.  E  D
  1.  . S ANPREFIX=$G(^TMP("MAG",$J,"Q/R PARAM","ACCESSION NUMBER PREFIX"),"<undef>")
  1.  . I ANPREFIX="<undef>" D
  1.  . . I $$VISTA^MAGDSTQ D  ; VistA code - call API
  1.  . . . S ANPREFIX=$$ANPREFIX^MAGDSTAB
  1.  . . . Q
  1.  . . E  D  ; DICOM Gateway code - call RPC
  1.  . . . N RPCERR
  1.  . . . I '$D(^TMP("MAG",$J,"DICOM RPC USER")) D  Q  ; no RPC
  1.  . . . . S ANPREFIX=""
  1.  . . . . Q
  1.  . . . S RPCERR=$$CALLRPC^MAGM2VCU("MAG DICOM GET ACN PREFIX","M",.ANPREFIX)
  1.  . . . I RPCERR<0 D  S OUTPUT(0)=-1 Q
  1.  . . . . D ERRORMSG^MAGDSTQ0(1,"Error in MAG DICOM GET ACN PREFIX rpc",.ANPREFIX)
  1.  . . . . Q
  1.  . . . Q
  1.  . . S ANPREFIX=$$GETANPFX(ANPREFIX) ; allow the accession number prefix to be changed
  1.  . . S ^TMP("MAG",$J,"Q/R PARAM","ACCESSION NUMBER PREFIX")=ANPREFIX
  1.  . . Q
  1.  . S RETURN=1
  1.  . I $D(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB)) S ^(ATTRIB)=ANPREFIX_^(ATTRIB)
  1.  . Q
  1.  Q RETURN
  1.  ;
  1. GETANPFX(DEFAULT) ; get the accession number prefix
  1.  N ANPREFIX,OK
  1.  S OK=0 F  D  Q:OK
  1.  . W !!,"Enter the Accession Number Prefix: "
  1.  . I $L(DEFAULT) W DEFAULT,"// "
  1.  . R ANPREFIX:DTIME E  S OK=-1 Q
  1.  . I ANPREFIX="",$L(DEFAULT) S ANPREFIX=DEFAULT W ANPREFIX
  1.  . I ANPREFIX="" W " -- use ""@"" to remove it" Q
  1.  . I ANPREFIX["^" S OK=-1 Q
  1.  . I ANPREFIX="@" S ANPREFIX=""
  1.  . I ANPREFIX?0.4(1U,1N,1"-") S OK=1
  1.  . E  W "  ???",!,"Please enter ""@"" or 1-4 characters (numeric, uppercase characters, hyphen)"
  1.  . Q
  1.  Q ANPREFIX
  1.  ;
  1. REFDOC ;
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Referring Physician's name"
  1.  S HELP(1)="Enter the Referring Physician's name in ""LAST^FIRST^MI"" format"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  D CHKNAME(ATTRIB)
  1.  Q
  1.  ;
  1. STUDYID ; enter the study id
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Study Identifier"
  1.  S HELP(1)="The Study Identifier is generated by the modality."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  Q
  1.  ;
  1. SERIESNO ; enter the series number
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Series Number"
  1.  S HELP(1)="The Study Number is generated by the modality."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  Q
  1.  ;
  1. REQPROID ; enter the requested procedure id
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Requested Procedure ID"
  1.  S HELP(1)="The Requested Procedure ID is generated by VistA."
  1.  S HELP(2)="For Radiology, it is Case Number."
  1.  S HELP(3)="For CPRS requests, it is the consult or procedure number."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  Q
  1.  ;
  1. SPSTEPID ; enter the scheduled procedure step id
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Scheduled Procedure Step ID"
  1.  S HELP(1)="The studies generated by VistA, it is the Accession Number."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP)
  1.  Q
  1.  ;
  1. STUDYUID ; enter the study instance uid
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Study Instance UID"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHECKUID(.X)")
  1.  Q
  1.  ;
  1. SERIEUID ; enter the series instance uid
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Series Instance UID"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHECKUID(.X)")
  1.  Q
  1.  ;
  1. SOPUID ; enter the SOP instance uid
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the SOP Instance UID"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHECKUID(.X)")
  1.  Q
  1.  ;
  1. CHECKUID(X) ; check the format of the uid
  1.  N RETURN
  1.  S RETURN=-1
  1.  I X?.(1N.N1".")1N.N S RETURN=0
  1.  Q RETURN
  1.  ;
  1. MODALITY ; select the modality
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Enter the Modality Code"
  1.  S HELP(1)="Please enter the DICOM modality value"
  1.  S HELP(2)="Examples: CR, CT, DX, MR, NM, RF, US, XA"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHECKMOD(.X)")
  1.  Q
  1.  ;
  1. CHECKMOD(X) ; check the validity of the entered modality value
  1.  N DICTIEN,MODALIEN,RETURN,Y
  1.  X ^%ZOSF("UPPERCASE") S X=Y
  1.  I X="" S RETURN=0
  1.  E  I $$VISTA^MAGDSTQ D
  1.  . S RETURN=0 ; can't check on VistA
  1.  . Q
  1.  E  D
  1.  . S DICTIEN=$O(^MAGDICOM(2006.51,"B","0008,0060",""))
  1.  . I 'DICTIEN D
  1.  . . W !!,"Please run the menu option to Reinitialize All the DICOM Master Files",!
  1.  . . S RETURN=-1
  1.  . . Q
  1.  . E  S MODALIEN=$O(^MAGDICOM(2006.51,DICTIEN,1,"B",X,"")) I 'MODALIEN D
  1.  . . W !,"*** Warning: Modality """,X,""" is not defined in DICOM."
  1.  . . S RETURN=-1
  1.  . . Q
  1.  . E  D
  1.  . . W " -- ",$P($P(^MAGDICOM(2006.51,DICTIEN,1,MODALIEN,0),"^",2),"=",1)
  1.  . . R Y:5
  1.  . . S RETURN=0
  1.  . . Q
  1.  . Q
  1.  Q RETURN
  1.  ;
  1. BIRTHDAT ; birth date, may be a range
  1.  D GETDATE("B")
  1.  Q
  1.  ;
  1. STDYDATE ; study date, may be a range
  1.  D GETDATE("S")
  1.  Q
  1.  ;
  1. GETDATE(TYPE) ; get the date
  1.  N HELP,PROMPT,X
  1.  S PROMPT=$S(TYPE="B":"Birth",1:"Study")_" Date (yyyymmdd or yyyymmdd-yyyymmdd)"
  1.  S HELP(1)="The "_$S(TYPE="B":"birth",1:"study")_" date can be entered in several formats:"
  1.  S HELP(2)="   1)  yyyymmdd  (selects only one date)"
  1.  S HELP(3)="   2)  yyyymmdd- (selects that date and subsequent ones)"
  1.  S HELP(4)="   3) -yyyymmdd  (selects that date and prior ones)"
  1.  S HELP(5)="   4)  yyyymmdd-yyyymmdd (selects an inclusive range of dates)"
  1.  S HELP(6)="   5)  FileMan ""T..."" dates are accepted and converted to yyyymmdd"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHKDATE(.X)")
  1.  Q
  1.  ;
  1. CHKDATE(X) ; check the date
  1.  I (X?1"T".E)!(X="NOW") D
  1.  . N %DT
  1.  . S %DT="TS" D ^%DT
  1.  . S X=Y\1,$E(X)=$E(X)+17
  1.  . Q
  1.  Q $S(X="":0,X?8N:0,X?8N1"-":0,X?1"-"8N:0,X?8N1"-"8N:0,1:-1)
  1.  ;
  1. STDYTIME ; study time, may be a range
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Study Time (hhmmss or hhmmss-hhmmss)"
  1.  S HELP(1)="The study time can be entered in several formats:"
  1.  S HELP(2)="   1)  hhmmss  (selects only one time - not too useful!)"
  1.  S HELP(3)="   2)  hhmmss- (selects that time and subsequent ones)"
  1.  S HELP(4)="   3) -hhmmss  (selects that time and prior ones)"
  1.  S HELP(5)="   4)  hhmmss-hhmmss (selects an inclusive range of times)"
  1.  S HELP(6)="Note: all times are 24-hour"
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHKTIME(.X)")
  1.  Q
  1.  ;
  1. CHKTIME(X) ; check the study time
  1.  Q $S(X="":0,X?6N:0,X?6N1"-":0,X?1"-"6N:0,X?6N1"-"6N:0,1:-1)
  1.  ;
  1. QRROOT ; get query/retrieve root
  1.  N HELP,PROMPT,X
  1.  S PROMPT="Query/Retrieve Root (Patient or Study)"
  1.  S HELP(1)="The Query/Retrieve Root determines the DICOM information model for the query."
  1.  S HELP(2)=""
  1.  S HELP(3)="The Patient Root has four levels: Patient, Study, Series, and Image."
  1.  S HELP(4)=""
  1.  S HELP(5)="The Study Root Information Model has three levels: Study, Series, and Image,"
  1.  S HELP(6)="with the Patient Level information included in the Study Level."
  1.  S HELP(7)=""
  1.  S HELP(8)="If you are only looking for a single study and know the accession number, the"
  1.  S HELP(9)="STUDY Root will allow you search by accession number and find it quickest."
  1.  S HELP(10)=""
  1.  S HELP(11)="If you are looking for all the studies for a patient, use the PATIENT Root."
  1.  S X=$$GETKEY(ATTRIB,PROMPT,.HELP,"$$CHKQRR(.X)")
  1.  Q
  1.  ;
  1. CHKQRR(X) ; check the query/retrieve root
  1.  N ERROR,Y,Z S ERROR=1
  1.  X ^%ZOSF("UPPERCASE") S X=Y
  1.  I $E(X)="P" S X="PATIENT",ERROR=0
  1.  E  I $E(X)="S" D
  1.  . S X="STUDY",ERROR=0
  1.  . I $G(^TMP("MAG",$J,"Q/R PARAM","QUERY LEVEL"))="PATIENT" D
  1.  . . W !,"Patient Level queries are not supported for Study Root -- changing to STUDY"
  1.  . . R Z:5
  1.  . . S ^TMP("MAG",$J,"Q/R PARAM","QUERY LEVEL")="STUDY"
  1.  . . Q
  1.  . Q
  1.  Q ERROR
  1.  ;
  1. GETKEY(ATTRIB,PROMPT,HELP,CHECK) ; get the value for the key
  1.  N DONE,DEFAULT,I,X
  1.  S DEFAULT=$G(^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB))
  1.  S DONE="" F  D  Q:DONE
  1.  . W !!,PROMPT,":  " I DEFAULT'="" W DEFAULT,"// "
  1.  . R X:DTIME I X="" S X=DEFAULT W X
  1.  . I X["?" D
  1.  . . W ! S I=0 F  S I=$O(HELP(I)) Q:'I  W !,HELP(I)
  1.  . . I DEFAULT'="" W !!,"(Enter ""@"" to delete the """,DEFAULT,""" value)"
  1.  . . Q
  1.  . E  S DONE=1 I X'="^" D  ; a caret will terminate the program
  1.  . . I X="@" D
  1.  . . . K ^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB) W " -- deleted"
  1.  . . . I ATTRIB?1"PATIENT".E K ^TMP("MAG",$J,"Q/R PARAM","PATIENT LOOKUP MODE") ; reset VistA/Manual Mode
  1.  . . . Q
  1.  . . E  D
  1.  . . . I $D(CHECK),@CHECK D  W "Illegal Value" S DONE=0
  1.  . . . . I $X>60 W !
  1.  . . . . E  W "  "
  1.  . . . . Q
  1.  . . . E  S ^TMP("MAG",$J,"Q/R QUERY",QRSTACK,ATTRIB)=X
  1.  . . . Q
  1.  . . Q
  1.  . Q
  1.  Q X