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 Dec 13, 2024@01:59:55 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
