- MAGDGMRC ;WOIFO/PMK,EdM,MLH,DAC - Read a DICOM image file ; Nov 08, 2019@10:50:30
- ;;3.0;IMAGING;**10,51,50,85,118,138,239**;Mar 19, 2002;Build 18;May 19, 2019
- ;; 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. |
- ;; +---------------------------------------------------------------+
- ;;
- ; This is the set of GMRC APIs that are use by the VistA Imaging
- ; DICOM Gateway
- ;
- ANYREQ(DFN) ; check if any GMRC requests are present for the patient
- N ADFN ; ---- array of DFNs to look up
- N WRK ; ----- work array for our results
- N IX ; ------ results lookup index
- N FHIT ; ---- flag - any results for the pt?
- ;
- ; ask for requests for the patient
- S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
- S ADFN(1)=DFN
- D FIND^DIC(123,,"@;.02I","QX",.ADFN,,"F",,,WRK,WRK)
- ;
- ; check returns to see if any are actually for this patient (see note
- ; on SEARCH below)
- S IX=0
- F S IX=$O(@WRK@("DILIST","ID",IX)) Q:'IX D Q:$G(FHIT)
- . I $G(@WRK@("DILIST","ID",IX,.02))=DFN S FHIT=1
- . Q
- K @WRK
- Q +$G(FHIT)
- ;
- TIULAST(GMRCIEN) ; find the ien of the most recent TIU note for this request
- N TIUIEN
- N WRK ; root of work global
- S TIUIEN=0
- I GMRCIEN D ; look for the most recent TIU note for this request
- . ; set up the array to look through
- . S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
- . D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- . ; traverse the array
- . N TIUPTR
- . S TIUPTR=" " ; setup for reverse $o from space (" ")
- . F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR),-1) Q:'TIUPTR D Q:TIUIEN
- . . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- . . I $P(TIUIEN,";",2)'="TIU(8925," S TIUIEN=0 ; not a TIU document
- . . Q
- . Q
- K @WRK
- Q +TIUIEN
- ;
- TIUALL(GMRCIEN,RESULT) ; find all IENs for the TIU notes for this request
- N MAGIEN,TIUIEN,TIUPTR,TIUXIEN,Y
- N WRK ; root of work global
- K RESULT
- ; set up the array to look through
- S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
- D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- ; traverse the array
- S (RESULT,TIUPTR)=0
- F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D
- . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- . I $P(TIUIEN,";",2)'="TIU(8925," Q ; not a TIU document
- . S TIUIEN=+TIUIEN ; strip off variable pointer stuff
- . S TIUXIEN=""
- . F S TIUXIEN=$O(^TIU(8925.91,"B",TIUIEN,TIUXIEN)) Q:'TIUXIEN D
- . . S Y=$G(^TIU(8925.91,TIUXIEN,0)) Q:'Y
- . . S MAGIEN=$P(Y,"^",2)
- . . S RESULT=RESULT+1
- . . S RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^"_MAGIEN
- . . Q
- . ; new database structure
- . S TIUXIEN=""
- . ; P239 DAC - Changed/(fixed) next three global references to ^MAGV instead of ^MAG
- . F S TIUXIEN=$O(^MAGV(2005.61,"B",TIUIEN,TIUXIEN)) Q:'TIUXIEN D
- . . S Y=$G(^MAGV(2005.61,TIUXIEN,0)) Q:$P(Y,"^",3)'="TIU"
- . . S MAGIEN=""
- . . F S MAGIEN=$O(^MAGV(2005.62,"C",TIUXIEN,MAGIEN)) Q:'MAGIEN D
- . . . S RESULT=RESULT+1
- . . . S RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^N"_MAGIEN
- . . . Q
- . . Q
- . Q
- K @WRK
- Q
- ;
- FWDFROM(GMRCIEN) ; for a forwarded request, determine the FORWARD FROM service
- N FWDFROM,I
- N WRK ; root of work global
- ; set up the array to look through
- S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
- D LIST^DIC(123.02,","_GMRCIEN_",",".01I;6I",,,,,,,,WRK,WRK)
- ; traverse the array
- S FWDFROM=0
- I GMRCIEN D
- . S I=$O(@WRK@("DILIST","ID"," "),-1)
- . I I D ; get the FORWARDED FROM service
- . . S FWDFROM=$G(@WRK@("DILIST","ID",I,6))
- . . Q
- . Q
- K @WRK
- Q +FWDFROM
- ;
- UNSIGNED(GMRCIEN) ; check if there are any unsigned TIU notes for the request
- N TIUPTR,NRESULTS,TIUSTAT,UNSIGNED,X
- N WRK ; root of work global
- ; set up the array to look through
- S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
- D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- S UNSIGNED=0,TIUPTR=""
- ; traverse the array, check all associated results, bail if any unsigned
- F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D Q:UNSIGNED
- . S X=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- . ; if TIU note, check if unsigned
- . I X?.N1";TIU(8925," D ; check status of TIU note for completion
- . . ; status in ^TIU(8925.6) - use first 5 "UNs" per Margy McClenanhan
- . . S TIUSTAT=$$GET1^DIQ(8925,+X,.05,"I")
- . . I TIUSTAT,TIUSTAT<6 S UNSIGNED=1 ; got one!
- . . Q
- . Q
- K @WRK
- Q UNSIGNED
- --- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDGMRC 5197 printed Feb 18, 2025@23:26:22 Page 2
- MAGDGMRC ;WOIFO/PMK,EdM,MLH,DAC - Read a DICOM image file ; Nov 08, 2019@10:50:30
- +1 ;;3.0;IMAGING;**10,51,50,85,118,138,239**;Mar 19, 2002;Build 18;May 19, 2019
- +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 ; This is the set of GMRC APIs that are use by the VistA Imaging
- +18 ; DICOM Gateway
- +19 ;
- ANYREQ(DFN) ; check if any GMRC requests are present for the patient
- +1 ; ---- array of DFNs to look up
- NEW ADFN
- +2 ; ----- work array for our results
- NEW WRK
- +3 ; ------ results lookup index
- NEW IX
- +4 ; ---- flag - any results for the pt?
- NEW FHIT
- +5 ;
- +6 ; ask for requests for the patient
- +7 SET WRK=$NAME(^TMP("MAG",$JOB,$TEXT(+0)))
- KILL @WRK
- +8 SET ADFN(1)=DFN
- +9 DO FIND^DIC(123,,"@;.02I","QX",.ADFN,,"F",,,WRK,WRK)
- +10 ;
- +11 ; check returns to see if any are actually for this patient (see note
- +12 ; on SEARCH below)
- +13 SET IX=0
- +14 FOR
- SET IX=$ORDER(@WRK@("DILIST","ID",IX))
- if 'IX
- QUIT
- Begin DoDot:1
- +15 IF $GET(@WRK@("DILIST","ID",IX,.02))=DFN
- SET FHIT=1
- +16 QUIT
- End DoDot:1
- if $GET(FHIT)
- QUIT
- +17 KILL @WRK
- +18 QUIT +$GET(FHIT)
- +19 ;
- TIULAST(GMRCIEN) ; find the ien of the most recent TIU note for this request
- +1 NEW TIUIEN
- +2 ; root of work global
- NEW WRK
- +3 SET TIUIEN=0
- +4 ; look for the most recent TIU note for this request
- IF GMRCIEN
- Begin DoDot:1
- +5 ; set up the array to look through
- +6 SET WRK=$NAME(^TMP("MAG",$JOB,$TEXT(+0)))
- KILL @WRK
- +7 DO LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- +8 ; traverse the array
- +9 NEW TIUPTR
- +10 ; setup for reverse $o from space (" ")
- SET TIUPTR=" "
- +11 FOR
- SET TIUPTR=$ORDER(@WRK@("DILIST","ID",TIUPTR),-1)
- if 'TIUPTR
- QUIT
- Begin DoDot:2
- +12 SET TIUIEN=$PIECE($GET(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- +13 ; not a TIU document
- IF $PIECE(TIUIEN,";",2)'="TIU(8925,"
- SET TIUIEN=0
- +14 QUIT
- End DoDot:2
- if TIUIEN
- QUIT
- +15 QUIT
- End DoDot:1
- +16 KILL @WRK
- +17 QUIT +TIUIEN
- +18 ;
- TIUALL(GMRCIEN,RESULT) ; find all IENs for the TIU notes for this request
- +1 NEW MAGIEN,TIUIEN,TIUPTR,TIUXIEN,Y
- +2 ; root of work global
- NEW WRK
- +3 KILL RESULT
- +4 ; set up the array to look through
- +5 SET WRK=$NAME(^TMP("MAG",$JOB,$TEXT(+0)))
- KILL @WRK
- +6 DO LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- +7 ; traverse the array
- +8 SET (RESULT,TIUPTR)=0
- +9 FOR
- SET TIUPTR=$ORDER(@WRK@("DILIST","ID",TIUPTR))
- if 'TIUPTR
- QUIT
- Begin DoDot:1
- +10 SET TIUIEN=$PIECE($GET(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- +11 ; not a TIU document
- IF $PIECE(TIUIEN,";",2)'="TIU(8925,"
- QUIT
- +12 ; strip off variable pointer stuff
- SET TIUIEN=+TIUIEN
- +13 SET TIUXIEN=""
- +14 FOR
- SET TIUXIEN=$ORDER(^TIU(8925.91,"B",TIUIEN,TIUXIEN))
- if 'TIUXIEN
- QUIT
- Begin DoDot:2
- +15 SET Y=$GET(^TIU(8925.91,TIUXIEN,0))
- if 'Y
- QUIT
- +16 SET MAGIEN=$PIECE(Y,"^",2)
- +17 SET RESULT=RESULT+1
- +18 SET RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^"_MAGIEN
- +19 QUIT
- End DoDot:2
- +20 ; new database structure
- +21 SET TIUXIEN=""
- +22 ; P239 DAC - Changed/(fixed) next three global references to ^MAGV instead of ^MAG
- +23 FOR
- SET TIUXIEN=$ORDER(^MAGV(2005.61,"B",TIUIEN,TIUXIEN))
- if 'TIUXIEN
- QUIT
- Begin DoDot:2
- +24 SET Y=$GET(^MAGV(2005.61,TIUXIEN,0))
- if $PIECE(Y,"^",3)'="TIU"
- QUIT
- +25 SET MAGIEN=""
- +26 FOR
- SET MAGIEN=$ORDER(^MAGV(2005.62,"C",TIUXIEN,MAGIEN))
- if 'MAGIEN
- QUIT
- Begin DoDot:3
- +27 SET RESULT=RESULT+1
- +28 SET RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^N"_MAGIEN
- +29 QUIT
- End DoDot:3
- +30 QUIT
- End DoDot:2
- +31 QUIT
- End DoDot:1
- +32 KILL @WRK
- +33 QUIT
- +34 ;
- FWDFROM(GMRCIEN) ; for a forwarded request, determine the FORWARD FROM service
- +1 NEW FWDFROM,I
- +2 ; root of work global
- NEW WRK
- +3 ; set up the array to look through
- +4 SET WRK=$NAME(^TMP("MAG",$JOB,$TEXT(+0)))
- KILL @WRK
- +5 DO LIST^DIC(123.02,","_GMRCIEN_",",".01I;6I",,,,,,,,WRK,WRK)
- +6 ; traverse the array
- +7 SET FWDFROM=0
- +8 IF GMRCIEN
- Begin DoDot:1
- +9 SET I=$ORDER(@WRK@("DILIST","ID"," "),-1)
- +10 ; get the FORWARDED FROM service
- IF I
- Begin DoDot:2
- +11 SET FWDFROM=$GET(@WRK@("DILIST","ID",I,6))
- +12 QUIT
- End DoDot:2
- +13 QUIT
- End DoDot:1
- +14 KILL @WRK
- +15 QUIT +FWDFROM
- +16 ;
- UNSIGNED(GMRCIEN) ; check if there are any unsigned TIU notes for the request
- +1 NEW TIUPTR,NRESULTS,TIUSTAT,UNSIGNED,X
- +2 ; root of work global
- NEW WRK
- +3 ; set up the array to look through
- +4 SET WRK=$NAME(^TMP("MAG",$JOB,$TEXT(+0)))
- KILL @WRK
- +5 DO LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
- +6 SET UNSIGNED=0
- SET TIUPTR=""
- +7 ; traverse the array, check all associated results, bail if any unsigned
- +8 FOR
- SET TIUPTR=$ORDER(@WRK@("DILIST","ID",TIUPTR))
- if 'TIUPTR
- QUIT
- Begin DoDot:1
- +9 SET X=$PIECE($GET(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
- +10 ; if TIU note, check if unsigned
- +11 ; check status of TIU note for completion
- IF X?.N1";TIU(8925,"
- Begin DoDot:2
- +12 ; status in ^TIU(8925.6) - use first 5 "UNs" per Margy McClenanhan
- +13 SET TIUSTAT=$$GET1^DIQ(8925,+X,.05,"I")
- +14 ; got one!
- IF TIUSTAT
- IF TIUSTAT<6
- SET UNSIGNED=1
- +15 QUIT
- End DoDot:2
- +16 QUIT
- End DoDot:1
- if UNSIGNED
- QUIT
- +17 KILL @WRK
- +18 QUIT UNSIGNED