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

MAGDGMRC.m

Go to the documentation of this file.
  1. 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
  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. ; This is the set of GMRC APIs that are use by the VistA Imaging
  1. ; DICOM Gateway
  1. ;
  1. ANYREQ(DFN) ; check if any GMRC requests are present for the patient
  1. N ADFN ; ---- array of DFNs to look up
  1. N WRK ; ----- work array for our results
  1. N IX ; ------ results lookup index
  1. N FHIT ; ---- flag - any results for the pt?
  1. ;
  1. ; ask for requests for the patient
  1. S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
  1. S ADFN(1)=DFN
  1. D FIND^DIC(123,,"@;.02I","QX",.ADFN,,"F",,,WRK,WRK)
  1. ;
  1. ; check returns to see if any are actually for this patient (see note
  1. ; on SEARCH below)
  1. S IX=0
  1. F S IX=$O(@WRK@("DILIST","ID",IX)) Q:'IX D Q:$G(FHIT)
  1. . I $G(@WRK@("DILIST","ID",IX,.02))=DFN S FHIT=1
  1. . Q
  1. K @WRK
  1. Q +$G(FHIT)
  1. ;
  1. TIULAST(GMRCIEN) ; find the ien of the most recent TIU note for this request
  1. N TIUIEN
  1. N WRK ; root of work global
  1. S TIUIEN=0
  1. I GMRCIEN D ; look for the most recent TIU note for this request
  1. . ; set up the array to look through
  1. . S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
  1. . D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
  1. . ; traverse the array
  1. . N TIUPTR
  1. . S TIUPTR=" " ; setup for reverse $o from space (" ")
  1. . F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR),-1) Q:'TIUPTR D Q:TIUIEN
  1. . . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
  1. . . I $P(TIUIEN,";",2)'="TIU(8925," S TIUIEN=0 ; not a TIU document
  1. . . Q
  1. . Q
  1. K @WRK
  1. Q +TIUIEN
  1. ;
  1. TIUALL(GMRCIEN,RESULT) ; find all IENs for the TIU notes for this request
  1. N MAGIEN,TIUIEN,TIUPTR,TIUXIEN,Y
  1. N WRK ; root of work global
  1. K RESULT
  1. ; set up the array to look through
  1. S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
  1. D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
  1. ; traverse the array
  1. S (RESULT,TIUPTR)=0
  1. F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D
  1. . S TIUIEN=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
  1. . I $P(TIUIEN,";",2)'="TIU(8925," Q ; not a TIU document
  1. . S TIUIEN=+TIUIEN ; strip off variable pointer stuff
  1. . S TIUXIEN=""
  1. . F S TIUXIEN=$O(^TIU(8925.91,"B",TIUIEN,TIUXIEN)) Q:'TIUXIEN D
  1. . . S Y=$G(^TIU(8925.91,TIUXIEN,0)) Q:'Y
  1. . . S MAGIEN=$P(Y,"^",2)
  1. . . S RESULT=RESULT+1
  1. . . S RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^"_MAGIEN
  1. . . Q
  1. . ; new database structure
  1. . S TIUXIEN=""
  1. . ; P239 DAC - Changed/(fixed) next three global references to ^MAGV instead of ^MAG
  1. . F S TIUXIEN=$O(^MAGV(2005.61,"B",TIUIEN,TIUXIEN)) Q:'TIUXIEN D
  1. . . S Y=$G(^MAGV(2005.61,TIUXIEN,0)) Q:$P(Y,"^",3)'="TIU"
  1. . . S MAGIEN=""
  1. . . F S MAGIEN=$O(^MAGV(2005.62,"C",TIUXIEN,MAGIEN)) Q:'MAGIEN D
  1. . . . S RESULT=RESULT+1
  1. . . . S RESULT(RESULT)=TIUIEN_"^"_$$GMRCACN^MAGDFCNV(GMRCIEN)_"^N"_MAGIEN
  1. . . . Q
  1. . . Q
  1. . Q
  1. K @WRK
  1. Q
  1. ;
  1. FWDFROM(GMRCIEN) ; for a forwarded request, determine the FORWARD FROM service
  1. N FWDFROM,I
  1. N WRK ; root of work global
  1. ; set up the array to look through
  1. S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
  1. D LIST^DIC(123.02,","_GMRCIEN_",",".01I;6I",,,,,,,,WRK,WRK)
  1. ; traverse the array
  1. S FWDFROM=0
  1. I GMRCIEN D
  1. . S I=$O(@WRK@("DILIST","ID"," "),-1)
  1. . I I D ; get the FORWARDED FROM service
  1. . . S FWDFROM=$G(@WRK@("DILIST","ID",I,6))
  1. . . Q
  1. . Q
  1. K @WRK
  1. Q +FWDFROM
  1. ;
  1. UNSIGNED(GMRCIEN) ; check if there are any unsigned TIU notes for the request
  1. N TIUPTR,NRESULTS,TIUSTAT,UNSIGNED,X
  1. N WRK ; root of work global
  1. ; set up the array to look through
  1. S WRK=$NA(^TMP("MAG",$J,$T(+0))) K @WRK
  1. D LIST^DIC(123.03,","_GMRCIEN_",",".01I",,,,,,,,WRK,WRK)
  1. S UNSIGNED=0,TIUPTR=""
  1. ; traverse the array, check all associated results, bail if any unsigned
  1. F S TIUPTR=$O(@WRK@("DILIST","ID",TIUPTR)) Q:'TIUPTR D Q:UNSIGNED
  1. . S X=$P($G(@WRK@("DILIST","ID",TIUPTR,.01)),"^",1)
  1. . ; if TIU note, check if unsigned
  1. . I X?.N1";TIU(8925," D ; check status of TIU note for completion
  1. . . ; status in ^TIU(8925.6) - use first 5 "UNs" per Margy McClenanhan
  1. . . S TIUSTAT=$$GET1^DIQ(8925,+X,.05,"I")
  1. . . I TIUSTAT,TIUSTAT<6 S UNSIGNED=1 ; got one!
  1. . . Q
  1. . Q
  1. K @WRK
  1. Q UNSIGNED