MAGD350J ;WOIFO/EDM/PMK - Imaging RPCs ; Jul 26, 2024@10:41:12
;;3.0;IMAGING;**350**;Mar 19, 2002;Build 4
;; 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 #4110 to read REQUEST/CONSULTATION file (#123)
; Controlled IA #3268 to read TIU DOCUMENT file (#8925)
;
; Copied from MAGDRPC2 and then modified to support TIER-2 lookups
;
Q
;
IMAGE(OUT,D0) ; RPC = MAG DICOM P350 GET BASIC IMAGE
N I,MSG,TARGET,V,VE,VI,X
K OUT S I=1
I '$G(D0) S OUT(1)="-1,Invalid IEN ("_$G(D0)_")" Q
I $D(^MAG(2005.1,D0,0)) S OUT(1)="-3,Image #"_D0_" has been deleted." Q
I '$D(^MAG(2005,D0,0)) S OUT(1)="-2,No data for """_D0_"""." Q
;
D GETS^DIQ(2005,D0_",","*","REIN","TARGET","MSG")
S X="" F S X=$O(TARGET(2005,D0_",",X)) Q:X="" D
. S VI=$G(TARGET(2005,D0_",",X,"I"))
. S VE=$G(TARGET(2005,D0_",",X,"E"))
. S I=I+1,OUT(I)=X_"^"_VI S:VI'=VE OUT(I)=OUT(I)_"^"_VE
. Q
;
D FILEFIND^MAGD350K(D0,"FULL",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-1 Full FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-1 Full Path+FileName^"_V
;
D FILEFIND^MAGD350K(D0,"BIG",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-1 Big FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-1 Big Path+FileName^"_V
;
D FILEFIND^MAGD350K(D0,"ABSTRACT",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-1 Abstract FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-1 Abstract Path+FileName^"_V
;
S (V,X)=0 F S X=$O(^MAG(2005,D0,1,X)) Q:'X S V=V+1
S:V I=I+1,OUT(I)="# Images^"_V
;
; new code for TIER-2 support
;
D FILEFIND^MAGD350K(D0,"FULL TIER-2",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-2 Full FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-2 Full Path+FileName^"_V
;
D FILEFIND^MAGD350K(D0,"BIG TIER-2",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-2 Big FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-2 Big Path+FileName^"_V
;
D FILEFIND^MAGD350K(D0,"ABSTRACT TIER-2",0,0,.X,.V)
S:X'<0 I=I+1,OUT(I)="TIER-2 Abstract FileName^"_X
S:V'<0 I=I+1,OUT(I)="TIER-2 Abstract Path+FileName^"_V
;
S I=I+1,OUT(I)="ACCESSION NUMBER^"_$$ACNUMB(.OUT) ; get accession number
;
S (V,X)=0 F S X=$O(^MAG(2005,D0,1,X)) Q:'X S V=V+1
S:V I=I+1,OUT(I)="# Images^"_V
;
S OUT(1)=I-1
Q
;
ACNUMB(OUT) ; get accession number
N ACNUMB,DATA,FIELD,GMRCIEN,GMRCREF,I,TIUIEN,X
N PARENTDATAFILE,PARENTIMAGEPTR,PARENTROOTD0,PARENTROOTG1
S I=1 F S I=$O(OUT(I)) Q:I="" D
. S X=OUT(I),FIELD=$P(X,"^",1) S:FIELD'="" DATA(FIELD)=$P(X,"^",2,3)
. Q
S PARENTDATAFILE=$G(DATA("PARENT DATA FILE#"))
S PARENTROOTD0=$G(DATA("PARENT GLOBAL ROOT D0"))
S PARENTIMAGEPTR=$G(DATA("PARENT DATA FILE IMAGE POINTER"))
S PARENTROOTG1=$G(DATA("PARENT GLOBAL ROOT D1"))
;
S ACNUMB=""
;
I PARENTDATAFILE="74^RADIOLOGY" D ; radiololgy
. S ACNUMB=$$GET1^DIQ(74,PARENTROOTD0,.01) ; radiology day-case#
. Q
E I PARENTDATAFILE="8925^TIU" D ; tiu
. S TIUIEN=PARENTROOTD0
. S GMRCREF=$$GET1^DIQ(8925,TIUIEN,1405,"I")
. I GMRCREF?1N.N1";GMR(123," D
. . S GMRCIEN=$P(GMRCREF,";",1)
. . S ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
. . Q
. Q
E I PARENTDATAFILE="2006.5839^DICOM GMRC TEMP LIST" D ; dicom gmrc temp list
. S GMRCIEN=PARENTROOTD0
. S ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN) ; P350 PMK 07/25/2024
. Q
Q ACNUMB
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGD350J 4205 printed Nov 22, 2024@17:09:46 Page 2
MAGD350J ;WOIFO/EDM/PMK - Imaging RPCs ; Jul 26, 2024@10:41:12
+1 ;;3.0;IMAGING;**350**;Mar 19, 2002;Build 4
+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 ; Supported IA #2056 reference $$GET1^DIQ function call
+18 ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
+19 ; Controlled IA #3268 to read TIU DOCUMENT file (#8925)
+20 ;
+21 ; Copied from MAGDRPC2 and then modified to support TIER-2 lookups
+22 ;
+23 QUIT
+24 ;
IMAGE(OUT,D0) ; RPC = MAG DICOM P350 GET BASIC IMAGE
+1 NEW I,MSG,TARGET,V,VE,VI,X
+2 KILL OUT
SET I=1
+3 IF '$GET(D0)
SET OUT(1)="-1,Invalid IEN ("_$GET(D0)_")"
QUIT
+4 IF $DATA(^MAG(2005.1,D0,0))
SET OUT(1)="-3,Image #"_D0_" has been deleted."
QUIT
+5 IF '$DATA(^MAG(2005,D0,0))
SET OUT(1)="-2,No data for """_D0_"""."
QUIT
+6 ;
+7 DO GETS^DIQ(2005,D0_",","*","REIN","TARGET","MSG")
+8 SET X=""
FOR
SET X=$ORDER(TARGET(2005,D0_",",X))
if X=""
QUIT
Begin DoDot:1
+9 SET VI=$GET(TARGET(2005,D0_",",X,"I"))
+10 SET VE=$GET(TARGET(2005,D0_",",X,"E"))
+11 SET I=I+1
SET OUT(I)=X_"^"_VI
if VI'=VE
SET OUT(I)=OUT(I)_"^"_VE
+12 QUIT
End DoDot:1
+13 ;
+14 DO FILEFIND^MAGD350K(D0,"FULL",0,0,.X,.V)
+15 if X'<0
SET I=I+1
SET OUT(I)="TIER-1 Full FileName^"_X
+16 if V'<0
SET I=I+1
SET OUT(I)="TIER-1 Full Path+FileName^"_V
+17 ;
+18 DO FILEFIND^MAGD350K(D0,"BIG",0,0,.X,.V)
+19 if X'<0
SET I=I+1
SET OUT(I)="TIER-1 Big FileName^"_X
+20 if V'<0
SET I=I+1
SET OUT(I)="TIER-1 Big Path+FileName^"_V
+21 ;
+22 DO FILEFIND^MAGD350K(D0,"ABSTRACT",0,0,.X,.V)
+23 if X'<0
SET I=I+1
SET OUT(I)="TIER-1 Abstract FileName^"_X
+24 if V'<0
SET I=I+1
SET OUT(I)="TIER-1 Abstract Path+FileName^"_V
+25 ;
+26 SET (V,X)=0
FOR
SET X=$ORDER(^MAG(2005,D0,1,X))
if 'X
QUIT
SET V=V+1
+27 if V
SET I=I+1
SET OUT(I)="# Images^"_V
+28 ;
+29 ; new code for TIER-2 support
+30 ;
+31 DO FILEFIND^MAGD350K(D0,"FULL TIER-2",0,0,.X,.V)
+32 if X'<0
SET I=I+1
SET OUT(I)="TIER-2 Full FileName^"_X
+33 if V'<0
SET I=I+1
SET OUT(I)="TIER-2 Full Path+FileName^"_V
+34 ;
+35 DO FILEFIND^MAGD350K(D0,"BIG TIER-2",0,0,.X,.V)
+36 if X'<0
SET I=I+1
SET OUT(I)="TIER-2 Big FileName^"_X
+37 if V'<0
SET I=I+1
SET OUT(I)="TIER-2 Big Path+FileName^"_V
+38 ;
+39 DO FILEFIND^MAGD350K(D0,"ABSTRACT TIER-2",0,0,.X,.V)
+40 if X'<0
SET I=I+1
SET OUT(I)="TIER-2 Abstract FileName^"_X
+41 if V'<0
SET I=I+1
SET OUT(I)="TIER-2 Abstract Path+FileName^"_V
+42 ;
+43 ; get accession number
SET I=I+1
SET OUT(I)="ACCESSION NUMBER^"_$$ACNUMB(.OUT)
+44 ;
+45 SET (V,X)=0
FOR
SET X=$ORDER(^MAG(2005,D0,1,X))
if 'X
QUIT
SET V=V+1
+46 if V
SET I=I+1
SET OUT(I)="# Images^"_V
+47 ;
+48 SET OUT(1)=I-1
+49 QUIT
+50 ;
ACNUMB(OUT) ; get accession number
+1 NEW ACNUMB,DATA,FIELD,GMRCIEN,GMRCREF,I,TIUIEN,X
+2 NEW PARENTDATAFILE,PARENTIMAGEPTR,PARENTROOTD0,PARENTROOTG1
+3 SET I=1
FOR
SET I=$ORDER(OUT(I))
if I=""
QUIT
Begin DoDot:1
+4 SET X=OUT(I)
SET FIELD=$PIECE(X,"^",1)
if FIELD'=""
SET DATA(FIELD)=$PIECE(X,"^",2,3)
+5 QUIT
End DoDot:1
+6 SET PARENTDATAFILE=$GET(DATA("PARENT DATA FILE#"))
+7 SET PARENTROOTD0=$GET(DATA("PARENT GLOBAL ROOT D0"))
+8 SET PARENTIMAGEPTR=$GET(DATA("PARENT DATA FILE IMAGE POINTER"))
+9 SET PARENTROOTG1=$GET(DATA("PARENT GLOBAL ROOT D1"))
+10 ;
+11 SET ACNUMB=""
+12 ;
+13 ; radiololgy
IF PARENTDATAFILE="74^RADIOLOGY"
Begin DoDot:1
+14 ; radiology day-case#
SET ACNUMB=$$GET1^DIQ(74,PARENTROOTD0,.01)
+15 QUIT
End DoDot:1
+16 ; tiu
IF '$TEST
IF PARENTDATAFILE="8925^TIU"
Begin DoDot:1
+17 SET TIUIEN=PARENTROOTD0
+18 SET GMRCREF=$$GET1^DIQ(8925,TIUIEN,1405,"I")
+19 IF GMRCREF?1N.N1";GMR(123,"
Begin DoDot:2
+20 SET GMRCIEN=$PIECE(GMRCREF,";",1)
+21 SET ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
+22 QUIT
End DoDot:2
+23 QUIT
End DoDot:1
+24 ; dicom gmrc temp list
IF '$TEST
IF PARENTDATAFILE="2006.5839^DICOM GMRC TEMP LIST"
Begin DoDot:1
+25 SET GMRCIEN=PARENTROOTD0
+26 ; P350 PMK 07/25/2024
SET ACNUMB=$$GMRCACN^MAGDFCNV(GMRCIEN)
+27 QUIT
End DoDot:1
+28 QUIT ACNUMB
