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

MAGDSTA8.m

Go to the documentation of this file.
  1. MAGDSTA8 ;WOIFO/PMK - Q/R Retrieve of DICOM images from PACS to VistA ; Feb 15, 2022@10:50:15
  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. ; Supported IA #2056 reference $$GET1^DIQ function call
  1. ; Controlled IA #4171 to read REQUEST SERVICES file (#123.5)
  1. ; Controlled IA #7095 to read GMRC PROCEDURE file (#123.3)
  1. ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
  1. ;
  1. Q
  1. ;
  1. LEGACY(GROUPIEN,SERIESCOUNT,IMAGECOUNT) ; get all the UIDs for the imaging group
  1. N I,IMAGEIEN,VISTASTUDYUID,SERIESUID,SOPUID,X,Y,Z
  1. S (SERIESCOUNT,IMAGECOUNT)=0 ; want series/image counts for this group ien
  1. S X=$G(^MAG(2005,GROUPIEN,"PACS"))
  1. S VISTASTUDYUID=$P(X,"^",1)
  1. I VISTASTUDYUID="" Q ; invoked for a group without a study uid
  1. ; there may be multiple study instance uids
  1. I '$D(^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID)) D
  1. . ; increment study uid count for PACS lookup, if needed
  1. . S ^(0)=($G(^TMP("MAG",$J,"UIDS","VISTA",0))+1)_" ; legacy study count"
  1. . Q
  1. S I=0 ; skip zero-node of group multiple
  1. F S I=$O(^MAG(2005,GROUPIEN,1,I)) Q:'I D
  1. . S Y=$G(^MAG(2005,GROUPIEN,1,I,0))
  1. . S IMAGEIEN=$P(Y,"^",1)
  1. . S Z=$G(^MAG(2005,IMAGEIEN,"PACS")),SERIESUID=$G(^("SERIESUID"))
  1. . S SOPUID=$P(Z,"^",1)
  1. . ; require both series instance uid and sop instance uid
  1. . Q:SERIESUID="" Q:SOPUID="" ; can't do PACS lookup
  1. . D SERIES(VISTASTUDYUID,SERIESUID,.SERIESCOUNT)
  1. . D IMAGE(VISTASTUDYUID,SERIESUID,SOPUID,.IMAGECOUNT)
  1. . Q
  1. Q
  1. ;
  1. NEWSOPDB(ACNUMB,SERIESCOUNT,IMAGECOUNT) ; look for UIDs in the P34 database for the new SOP Classes
  1. ; Rules:
  1. ; 1) the Attribute On File field is not checked at all.
  1. ; 2) for the Procedure Reference file (#2005.61), there has to be a pointer to the Patient
  1. ; Reference file (#2005.6) and the patient id type in file #2005.6 needs to be "DFN".
  1. ; 3) for the Image Study file (#2005.62), the study must be "accessible" and AOF
  1. ; 4) for the Image Series file (#2006.63), the series must be "accessible" and AOF
  1. ; 5) for the SOP Instance file ("2006.64), the SOP instance must be "accessible" and AOF
  1. ;
  1. ; Rules 1, 2, and 3 are from the logic in ADD1STD^MAGDQR74
  1. ; Rules 4 and 5 are from the logic in STYSERKT^MAGVD010
  1. ;
  1. N PROCIX,SERIESDATA0,SERIESIX,SERIESUID,STUDYDATA0,STUDYIX
  1. N SOPDATA0,SOPIX,SOPUID,VISTASTUDYUID
  1. ;
  1. S (SERIESCOUNT,IMAGECOUNT)=0 ; want series/image counts for this accession number
  1. I $G(ACNUMB)="" Q ; invoked without an accession number
  1. ;
  1. S PROCIX="" ; procedure level indexed by accession number
  1. F S PROCIX=$O(^MAGV(2005.61,"B",ACNUMB,PROCIX)) Q:'PROCIX D
  1. . I $$PROBLEM61(PROCIX) Q ; patient not available - quit
  1. . ;
  1. . S STUDYIX="" ; study level
  1. . F S STUDYIX=$O(^MAGV(2005.62,"C",PROCIX,STUDYIX)) Q:'STUDYIX D
  1. . . I $$PROBLEM62(STUDYIX) Q ; study not available - quit
  1. . . S STUDYDATA0=$G(^MAGV(2005.62,STUDYIX,0))
  1. . . S VISTASTUDYUID=$P(STUDYDATA0,"^",1)
  1. . . S ^(0)=($G(^TMP("MAG",$J,"UIDS","VISTA",0))+1)_" ; new sop class db study count" ; increment study count
  1. . . ;
  1. . . S SERIESIX="" ; series level
  1. . . F S SERIESIX=$O(^MAGV(2005.63,"C",STUDYIX,SERIESIX)) Q:'SERIESIX D
  1. . . . I $$PROBLEM63(SERIESIX) Q ; if the series is not available, don't count it - quit
  1. . . . S SERIESDATA0=$G(^MAGV(2005.63,SERIESIX,0))
  1. . . . S SERIESUID=$P(SERIESDATA0,"^",1)
  1. . . . D SERIES(VISTASTUDYUID,SERIESUID,.SERIESCOUNT)
  1. . . . ;
  1. . . . S SOPIX="" ; sop instance level
  1. . . . F S SOPIX=$O(^MAGV(2005.64,"C",SERIESIX,SOPIX)) Q:'SOPIX D
  1. . . . . I $$PROBLEM64(SOPIX) Q ; if the sop instance is not available, don't count it - quit
  1. . . . . S SOPDATA0=^MAGV(2005.64,SOPIX,0)
  1. . . . . S SOPUID=$P(SOPDATA0,"^",1)
  1. . . . . ;
  1. . . . . S IMAGEIX="" ; image instance level
  1. . . . . F S IMAGEIX=$O(^MAGV(2005.65,"C",SOPIX,IMAGEIX)) Q:'IMAGEIX D
  1. . . . . . I $$PROBLEM65(IMAGEIX) Q ; if the original image is not available, don't count it - quit
  1. . . . . . D IMAGE(VISTASTUDYUID,SERIESUID,SOPUID,.IMAGECOUNT)
  1. . . . . . Q
  1. . . . . Q
  1. . . . Q
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. PROBLEM61(PROCIX) ; check both file 2005.6 and 2005.61
  1. N ARTIFACTONFILE,DFN,PATREFDATA,PATREFIX,PROCREFDATA0,PROCREFDATA6,RETURN,STATUS,STUDYIX
  1. S RETURN=1 D
  1. . ; check IMAGING PROCEDURE REFERNCE file
  1. . S PROCREFDATA0=$G(^MAGV(2005.61,PROCIX,0))
  1. . S STATUS=$P(PROCREFDATA0,"^",5) I STATUS'="A" Q ; imaging procedure not accessible
  1. . S ARTIFACTONFILE=$P(PROCREFDATA0,"^",6) I 'ARTIFACTONFILE Q ; artifact not on file
  1. . S PROCREFDATA6=$G(^MAGV(2005.61,PROCIX,6))
  1. . S PATREFIX=$P(PROCREFDATA6,"^",1) I 'PATREFIX Q ; No Patient Reference
  1. . ;
  1. . ; check IMAGING PATIENT REFERENCE file
  1. . S PATREFDATA=$G(^MAGV(2005.6,PATREFIX,0))
  1. . S DFN=$P(PATREFDATA,"^",1) I DFN="" Q ; no DFN
  1. . I $P(PATREFDATA,"^",3)'="D" Q ; Quit if Patient ID Type is not DFN
  1. . S ARTIFACTONFILE=$P(PATREFDATA,"^",4) I 'ARTIFACTONFILE Q ; artifact not on file
  1. . S STATUS=$P(PATREFDATA,"^",5) I STATUS'="A" Q ; patient not accessible
  1. . ;
  1. . ; check that there is at least one good study
  1. . S STUDYIX="" ; study level
  1. . F S STUDYIX=$O(^MAGV(2005.62,"C",PROCIX,STUDYIX)) Q:'STUDYIX D
  1. . . I $$PROBLEM62^MAGDSTA8(STUDYIX) Q ; study not available - quit
  1. . . S RETURN=0
  1. . . Q
  1. . Q
  1. Q RETURN ; 0=OK, no problem, 1=fails, not available
  1. ;
  1. PROBLEM62(STUDYIX) ; check file 2005.62
  1. N ARTIFACTONFILE,RETURN,STATUS,STUDYDATA5,STUDYDATA6
  1. S RETURN=1 D
  1. . ; check IMAGE STUDY file
  1. . S STUDYDATA5=$G(^MAGV(2005.62,STUDYIX,5))
  1. . S STATUS=$P(STUDYDATA5,"^",2) I STATUS'="A" Q ; study not accessible
  1. . S STUDYDATA6=$G(^MAGV(2005.62,STUDYIX,6))
  1. . S ARTIFACTONFILE=$P(STUDYDATA6,"^",2) I 'ARTIFACTONFILE Q ; artifact not on file
  1. . S RETURN=0
  1. . Q
  1. Q RETURN ; 0=OK, no problem, 1=fails, not available
  1. ;
  1. PROBLEM63(SERIESIX) ; check file 2005.63
  1. N ARTIFACTONFILE,RETURN,SERIESDATA6,SERIESDATA9,STATUS
  1. S RETURN=1 D
  1. . ; check IMAGE SERIES file
  1. . S SERIESDATA6=$G(^MAGV(2005.63,SERIESIX,6))
  1. . S ARTIFACTONFILE=$P(SERIESDATA6,"^",2) I 'ARTIFACTONFILE Q ; artifact not on file
  1. . S SERIESDATA9=$G(^MAGV(2005.63,SERIESIX,9))
  1. . S STATUS=$P(SERIESDATA9,"^",1) I STATUS'="A" Q ; series not accessible
  1. . S RETURN=0
  1. . Q
  1. Q RETURN ; 0=OK, no problem, 1=fails, not available
  1. ;
  1. PROBLEM64(SOPIX) ; check file 2005.64
  1. N ARTIFACTONFILE,RETURN,SOPDATA6,SOPDATA11,STATUS
  1. S RETURN=1 D
  1. . ; check IMAGE SOP INSTANCE file
  1. . S SOPDATA6=$G(^MAGV(2005.64,SOPIX,6))
  1. . S ARTIFACTONFILE=$P(SOPDATA6,"^",2) I 'ARTIFACTONFILE Q ; artifact not on file
  1. . S SOPDATA11=$G(^MAGV(2005.64,SOPIX,11))
  1. . S STATUS=$P(SOPDATA11,"^",1) I STATUS'="A" Q ; SOP instance not accessible
  1. . S RETURN=0
  1. . Q
  1. Q RETURN ; 0=OK, no problem, 1=fails, not available
  1. ;
  1. PROBLEM65(IMAGEIX) ; check file 2005.65
  1. N ARTIFACTIX,DELETED,IMAGEDATA0,IMAGEDATA1,IMAGEDATA4,ORIGINAL,RETURN,STATUS
  1. S RETURN=1 D
  1. . ; check IMAGE INSTANCE file
  1. . S IMAGEDATA0=$G(^MAGV(2005.65,IMAGEIX,0))
  1. . S ARTIFACTIX=$P(IMAGEDATA0,"^",2) I 'ARTIFACTIX="" Q ; no artifact reference
  1. . S IMAGEDATA1=$G(^MAGV(2005.65,IMAGEIX,1))
  1. . S ORIGINAL=$P(IMAGEDATA1,"^",2) I 'ORIGINAL Q ; only want original DICOM object
  1. . S STATUS=$P(IMAGEDATA1,"^",5) I STATUS'="A" Q ; image not accessible
  1. . S IMAGEDATA4=$G(^MAGV(2005.65,IMAGEIX,4))
  1. . S DELETED=$P(IMAGEDATA4,"^",1,3) I DELETED'="",DELETED'="^^" Q ; deleted image
  1. . S RETURN=0
  1. . Q
  1. Q RETURN ; 0=OK, no problem, 1=fails, not available
  1. ;
  1. SERIES(VISTASTUDYUID,SERIESUID,SERIESCOUNT) ; increment series counters
  1. I '$D(^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID,SERIESUID)) D
  1. . S ^(0)=($G(^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID,0))+1)_" ; series count" ; increment series count
  1. . ; don't count a series uid if it was under a previous study uid
  1. . I '$D(^TMP("MAG",$J,"UIDS","VISTA SERIES UID",SERIESUID)) D ; new series uid, count it
  1. . . S SERIESCOUNT=SERIESCOUNT+1 ; count of series instance uids, for all study uids
  1. . . Q
  1. . Q
  1. S ^TMP("MAG",$J,"UIDS","VISTA SERIES UID",SERIESUID,"STUDY UID",VISTASTUDYUID)=""
  1. Q
  1. ;
  1. IMAGE(VISTASTUDYUID,SERIESUID,SOPUID,IMAGECOUNNT) ; increment image counters
  1. I '$D(^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID,SERIESUID,SOPUID)) D
  1. . ; increment image count and save image in ^TMP
  1. . S ^(0)=($G(^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID,SERIESUID,0))+1)_" ; image count" ; increment image count
  1. . S IMAGECOUNT=IMAGECOUNT+1 ; count of sop instance uids, for all study & series uids
  1. . S ^TMP("MAG",$J,"UIDS","VISTA",VISTASTUDYUID,SERIESUID,SOPUID)=""
  1. . Q
  1. Q
  1. ;
  1. ;
  1. SERVICES(CONSULTSERVICES,GETQRSCP) ; get services to query
  1. N ALPHA,DONE,I,IBEGIN,IEND,INCRMENT,ISCREEN,KEEPSCREEN
  1. N LIST,NPICK,NSCREENS,PROCNAME,QUIT,SERVICE,SERVICENAME,RETURN,X
  1. S GETQRSCP=$G(GETQRSCP,"NO")
  1. I GETQRSCP'="NO",GETQRSCP'="YES" D Q -1
  1. . W !,"SERVICES^",$T(+0)," invoked with unrecognized GETQRSCP parameter: """,GETQRSCP,"""",!
  1. . Q
  1. K CONSULTSERVICES
  1. S SERVICE="" ; alpha sort services
  1. F I=1:1 S SERVICE=$O(^MAG(2006.5831,"B",SERVICE)) Q:'SERVICE D
  1. . S SERVICENAME=$$GET1^DIQ(123.5,SERVICE,.01,"E")
  1. . S ALPHA(SERVICENAME)=SERVICE
  1. . Q
  1. S SERVICENAME="" ; put sorted services into LIST
  1. F I=1:1 S SERVICENAME=$O(ALPHA(SERVICENAME)) Q:SERVICENAME="" D
  1. . S SERVICE=ALPHA(SERVICENAME)
  1. . S LIST(I)=SERVICENAME_"^"_SERVICE
  1. . I $D(^TMP("MAG",$J,"BATCH Q/R","CONSULT SERVICES",SERVICE)) S PICK(I)=1
  1. . Q
  1. ;
  1. S N=I-1,(QUIT,RETURN)=0
  1. ;
  1. I $D(PICK) D Q:QUIT -1 W !
  1. . W !!,"CPRS Consult/Procedure Service(s) from Previous Run"
  1. . W !,"---------------------------------------------------"
  1. . S INCREMENT=IOSL-5
  1. . S NSCREENS=((N-1)\INCREMENT)+1
  1. . F ISCREEN=1:1:NSCREENS D
  1. . . S IBEGIN=1+((ISCREEN-1)*INCREMENT)
  1. . . S IEND=INCREMENT*ISCREEN
  1. . . S IEND=$S(IEND>N:N,1:IEND)
  1. . . W @IOF,"CPRS Consult/Procedure Service(s) from Previous Run"
  1. . . W !,"---------------------------------------------------"
  1. . . F I=IBEGIN:1:IEND D
  1. . . . W !?5
  1. . . . D SERVICE3
  1. . . . Q
  1. . . I ISCREEN<NSCREENS D CONTINUE^MAGDSTQ
  1. . . Q
  1. . I $$YESNO^MAGDSTQ("Do you wish to change this?","n",.X)<0 S QUIT=1 Q
  1. . I X="YES" D SERVICE1
  1. . Q
  1. E D
  1. . D SERVICE1
  1. . Q
  1. ;
  1. I RETURN'<0 D ; build list of selected services, by ien
  1. . D SERVICE4(.CONSULTSERVICES,GETQRSCP,.LIST,.PICK)
  1. . Q
  1. I '$D(CONSULTSERVICES) D
  1. . W !!,"*** No consult/procedure service was selected ***"
  1. . D CONTINUE^MAGDSTQ
  1. . S RETURN=-2
  1. . Q
  1. Q RETURN
  1. ;
  1. SERVICE1 ; present selection screen(s)
  1. S INCREMENT=IOSL-7,DONE=0
  1. S NSCREENS=((N-1)\INCREMENT)+1
  1. F ISCREEN=1:1:NSCREENS D Q:DONE
  1. . S IBEGIN=1+((ISCREEN-1)*INCREMENT)
  1. . S IEND=INCREMENT*ISCREEN
  1. . S IEND=$S(IEND>N:N,1:IEND)
  1. . D SERVICE2
  1. . Q
  1. I 'DONE G SERVICE1 ; go back to first screen and repeat
  1. Q
  1. ;
  1. SERVICE2 ; select the service from a screen full
  1. S KEEPSCREEN=0
  1. W @IOF,"Select CPRS Consult/Procedure Service(s) with DICOM Imaging Capabilities"
  1. W !,"------------------------------------------------------------------------",!
  1. ; instructions
  1. W "There are ",N," services. Enter a number to select or deselect each service,"
  1. W !,"enter ""A"" for all, and enter ""D"" when done with the selection.",!
  1. F I=IBEGIN:1:IEND D Q:DONE
  1. . W !,$J(I,3),") "
  1. . D SERVICE3
  1. . Q
  1. ;
  1. ; process user selection(s)
  1. W !!,"Please enter ",IBEGIN,"-",IEND," to select/deselect a service (and ""D"" when done): "
  1. R X:DTIME E S X="^"
  1. I "?"[$E(X) S X="?" ; <null> or "?..." becomes "?"
  1. I "^"[$E(X) S RETURN=-1,DONE=1 Q
  1. I "Dd"[$E(X) S DONE=1 Q
  1. I "Aa"[$E(X) D Q
  1. . F I=1:1:N S PICK(I)=1
  1. . Q
  1. I X?1N.N,X>0,X'<IBEGIN,X'>IEND D
  1. . I $G(PICK(X)) S PICK(X)=0 ; deselect PICK(I)
  1. . E S PICK(X)=1 ; select PICK(I)
  1. . S KEEPSCREEN=1
  1. . Q
  1. E D
  1. . I X'="?" W " ???" R X:DTIME S KEEPSCREEN=1
  1. . Q
  1. ;
  1. I KEEPSCREEN=1 G SERVICE2 ; keep the same screen, don't go to next one
  1. Q
  1. ;
  1. SERVICE3 ; output one service
  1. W $S($G(PICK(I)):"-->",1:" "),$P(LIST(I),"^",1)
  1. Q
  1. ;
  1. SERVICE4(CONSULTSERVICES,GETQRSCP,LIST,PICK) ; build list of selected services, by ien
  1. N I,IEN,MAGIEN0,N,PROCEDURE,QRPROVIDER,SERVICE,SVCNAME
  1. S N=$O(LIST(""),-1)
  1. F I=1:1:N I $G(PICK(I)) D
  1. . S SVCNAME=$P(LIST(I),"^",1),SERVICE=$P(LIST(I),"^",2)
  1. . S CONSULTSERVICES(SERVICE)=SVCNAME
  1. . I GETQRSCP="NO" Q ; ignore Q/R Provider
  1. . ; check each service for QUERY/RETRIEVE PROVIDER value
  1. . S IEN="" F S IEN=$O(^MAG(2006.5831,"B",SERVICE,IEN)) Q:'IEN D
  1. . . S MAGIEN0=$G(^MAG(2006.5831,IEN,0))
  1. . . S PROCEDURE=+$P(MAGIEN0,"^",2) ; null becomes 0
  1. . . ; check for a special Q/R provider
  1. . . S QRPROVIDER=$P(MAGIEN0,"^",8)
  1. . . I QRPROVIDER'="" D
  1. . . . S PROCNAME=$S(PROCEDURE:$$GET1^DIQ(123.3,PROCEDURE,.01,"E"),1:"CONSULT")
  1. . . . S CONSULTSERVICES(SERVICE,PROCEDURE)=PROCNAME_"^"_QRPROVIDER
  1. . . . Q
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. QRSCP() ; get the q/r scp for the consult
  1. N MAG5831,QRSCP,TOSERVICE,X
  1. ;
  1. S QRSCP=^TMP("MAG",$J,"BATCH Q/R","PACS Q/R RETRIEVE SCP")
  1. ;
  1. ; does the consult modality worklist have a designated q/r scp?
  1. I IMAGINGSERVICE="CONSULTS" D
  1. . S TOSERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
  1. . S MAG5831=$$MWLFIND^MAGDHOW1(TOSERVICE,GMRCIEN)
  1. . I MAG5831 D ; get designated q/r scp for the worklist
  1. . . S X=$$GET1^DIQ(2006.5831,MAG5831,8,"E")
  1. . . I X'="" S QRSCP=X W !?20,"<<< Q/R SCP: ",QRSCP," >>>"
  1. . . Q
  1. . Q
  1. ;
  1. Q QRSCP