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