- 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 Jan 18, 2025@03:02:57 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