MAGDRA1 ;WOIFO/LB,JSL,SAF -Routine for DICOM fix ; 09/15/2004 13:34
;;3.0;IMAGING;**10,11,30,123**;Mar 19, 2002;Build 67;Jul 24, 2012
;; 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. |
;; +---------------------------------------------------------------+
;;
Q
LOOP ;Loop thru ^TMP($J,"RAE1" global
;MAGDFN should exist.
;MAGNME,MAGPID may exist.
Q:'$D(^TMP($J,"RAE1"))!('$D(MAGDFN))
N CCASE,CASE,CDATE,CODE,DATA,DATE,ENTRY,ENTRIES,ERR,ESTAT,INDEX
N LOC,MAGCASE,MAGCNI,MAGCPT,MAGDTI,MAGPIEN,MAGPRC,MAGPSET,MAGPST
N OUT,OLDCNI,OLDDT,OLDENTRY,PROC,PSET,PTINFO,RARPT,RADTI,RACNI,RADFN
N RAMELOW,RAPRTSET,REIN,STAT,X,Y
S (ENTRY,ENTRIES,OLDDT)=0
F S ENTRY=$O(^TMP($J,"RAE1",MAGDFN,ENTRY)) Q:'ENTRY!$G(OUT) D
. S DATA=^TMP($J,"RAE1",MAGDFN,ENTRY),ENTRIES=ENTRIES+1
. S DATE=$P(ENTRY,"-"),CDATE=9999999.9999-DATE
. S DATE=$TR($$FMTE^XLFDT(CDATE,"2FD")," ","0")
. S PROC=$P(DATA,"^"),CASE=$P(DATA,"^",2),STAT=$P(DATA,"^",6)
. S ESTAT=$P(STAT,"~",2),LOC=$P(DATA,"^",7)
. S RARPT=$P(DATA,"^",5)
. S RADTI=$P(ENTRY,"-"),RACNI=$P(ENTRY,"-",2),RADFN=MAGDFN
. S MAGCASE=$$LCASE^MAGDRA2(CDATE,CASE)
. ;Above radiology variables needed for EN1^RAULT20
. K RAMELOW,RAPRTSET
. D EN1^RAUTL20
. S (PSET,MAGPSET)=""
. I OLDDT'=RADTI S OLDCNI=""
. S PSET=$S(RAMEMLOW:"+",RAPRTSET:".",1:"")
. I PSET="+" S OLDCNI=RACNI
. I PSET=".",OLDCNI D
. . N OLDENTRY S OLDENTRY=$P(ENTRY,"-")_"-"_OLDCNI
. . I $D(^TMP($J,"RAE1",MAGDFN,OLDENTRY)) D
. . . S MAGCASE=$P(^TMP($J,"RAE1",MAGDFN,OLDENTRY),"^",2)
. . . S CDATE=$P(ENTRY,"-")
. . . S CDATE=9999999.9999-CDATE,RADTI=$P(OLDENTRY,"-"),RACNI=OLDCNI
. . . S MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE)
. . . S MAGPSET=CASE_" is part of this printset."
. . . Q
. . Q
. I '$D(MAGNME)!'($D(MAGPID)) D
. . S PTINFO=$$PTINFO^MAGDRA2
. . S MAGNME=$P(PTINFO,"^"),MAGPID=$P(PTINFO,"^",2) ;P123
. . Q
. S INDEX(ENTRIES)=PROC_"^"_$G(MAGPSET)_"^"_RADTI_"^"_RACNI_"^"_MAGCASE
. ; Radiology procedure^Printset^Inverse radiology date/time^Radioloty multiple^radiology case number
. D PRT S OLDDT=RADTI
. Q
D:'$G(OUT) SEL I +X,$D(INDEX(+X)) D SET
K OUT
Q
PRT ;
S (X,Y)=0
I ENTRIES=1 D HEAD
I $Y+6>IOSL D HEAD
W !?1,ENTRIES,?5,PSET,?6,CASE_$$IMG^MAGDRA2(RARPT),?12,$E(PROC,1,28)
W ?41,DATE,?52,$E(ESTAT,1,12),?67,$E(LOC,1,12) Q:ENTRIES#15
D SEL
Q
HEAD ;
W @IOF,"Patient: ",MAGNME,?50,$$PIDLABEL^MAGSPID(),": ",MAGPID ;P123
W !!,?3,"Case #",?12,"Procedure",?41,"Exam Date",?52,"Status of"
W "Exam",?69,"Imaging Loc"
W !?3,"--------",?12,"-------------",?41,"---------"
W ?52,"--------------",?67,"-----------"
Q
SEL ;
N DIR ; -- array for FileMan prompt data
S DIR(0)="NAO^1:"_ENTRIES
S DIR("?",1)="Enter a number between 1 and "_ENTRIES
S DIR("?")="corresponding to a single exam you wish to select."
S DIR("A",1)="'i' next to a case number denotes images collected on study."
S DIR("A")="Select an exam: "
D ^DIR
I '$D(DTOUT),'$D(DUOUT) ; didn't time out or uparrow out
E S OUT=1 Q
I Y,$D(INDEX(Y)) D CHECK I 'Y G SEL
I Y S Y=INDEX(Y) S OUT=1
Q
SET ;
S DATA=Y K Y
S MAGCASE=$P(INDEX(+X),"^",5)
S MAGPRC=$P(INDEX(+X),"^"),MAGPIEN=$$PROC^MAGDRA2(MAGPRC)
S MAGDTI=$P(INDEX(+X),"^",3)
S MAGPST=$P(INDEX(+X),"^",2)
S MAGCNI=$P(INDEX(+X),"^",4)
D MAGDY^MAGDRA2
Q
CHECK ;
;Check to see if the entry still exists.
N RADTI,CNI
Q:'MAGDFN
S RADTI=$P(INDEX(Y),"^",3),CNI=$P(INDEX(Y),"^",4)
I '$D(^RADPT(MAGDFN,"DT",RADTI,"P",CNI)) D
. S Y=""
. W !,"There is a database problem with the entry selected.",!
. Q
I $P(INDEX(Y),"^")="" D
. S Y=""
. W !,"There are no procedures for the entry selected.",!
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRA1 4556 printed Sep 23, 2025@19:37:25 Page 2
MAGDRA1 ;WOIFO/LB,JSL,SAF -Routine for DICOM fix ; 09/15/2004 13:34
+1 ;;3.0;IMAGING;**10,11,30,123**;Mar 19, 2002;Build 67;Jul 24, 2012
+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 QUIT
LOOP ;Loop thru ^TMP($J,"RAE1" global
+1 ;MAGDFN should exist.
+2 ;MAGNME,MAGPID may exist.
+3 if '$DATA(^TMP($JOB,"RAE1"))!('$DATA(MAGDFN))
QUIT
+4 NEW CCASE,CASE,CDATE,CODE,DATA,DATE,ENTRY,ENTRIES,ERR,ESTAT,INDEX
+5 NEW LOC,MAGCASE,MAGCNI,MAGCPT,MAGDTI,MAGPIEN,MAGPRC,MAGPSET,MAGPST
+6 NEW OUT,OLDCNI,OLDDT,OLDENTRY,PROC,PSET,PTINFO,RARPT,RADTI,RACNI,RADFN
+7 NEW RAMELOW,RAPRTSET,REIN,STAT,X,Y
+8 SET (ENTRY,ENTRIES,OLDDT)=0
+9 FOR
SET ENTRY=$ORDER(^TMP($JOB,"RAE1",MAGDFN,ENTRY))
if 'ENTRY!$GET(OUT)
QUIT
Begin DoDot:1
+10 SET DATA=^TMP($JOB,"RAE1",MAGDFN,ENTRY)
SET ENTRIES=ENTRIES+1
+11 SET DATE=$PIECE(ENTRY,"-")
SET CDATE=9999999.9999-DATE
+12 SET DATE=$TRANSLATE($$FMTE^XLFDT(CDATE,"2FD")," ","0")
+13 SET PROC=$PIECE(DATA,"^")
SET CASE=$PIECE(DATA,"^",2)
SET STAT=$PIECE(DATA,"^",6)
+14 SET ESTAT=$PIECE(STAT,"~",2)
SET LOC=$PIECE(DATA,"^",7)
+15 SET RARPT=$PIECE(DATA,"^",5)
+16 SET RADTI=$PIECE(ENTRY,"-")
SET RACNI=$PIECE(ENTRY,"-",2)
SET RADFN=MAGDFN
+17 SET MAGCASE=$$LCASE^MAGDRA2(CDATE,CASE)
+18 ;Above radiology variables needed for EN1^RAULT20
+19 KILL RAMELOW,RAPRTSET
+20 DO EN1^RAUTL20
+21 SET (PSET,MAGPSET)=""
+22 IF OLDDT'=RADTI
SET OLDCNI=""
+23 SET PSET=$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:"")
+24 IF PSET="+"
SET OLDCNI=RACNI
+25 IF PSET="."
IF OLDCNI
Begin DoDot:2
+26 NEW OLDENTRY
SET OLDENTRY=$PIECE(ENTRY,"-")_"-"_OLDCNI
+27 IF $DATA(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY))
Begin DoDot:3
+28 SET MAGCASE=$PIECE(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY),"^",2)
+29 SET CDATE=$PIECE(ENTRY,"-")
+30 SET CDATE=9999999.9999-CDATE
SET RADTI=$PIECE(OLDENTRY,"-")
SET RACNI=OLDCNI
+31 SET MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE)
+32 SET MAGPSET=CASE_" is part of this printset."
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 IF '$DATA(MAGNME)!'($DATA(MAGPID))
Begin DoDot:2
+36 SET PTINFO=$$PTINFO^MAGDRA2
+37 ;P123
SET MAGNME=$PIECE(PTINFO,"^")
SET MAGPID=$PIECE(PTINFO,"^",2)
+38 QUIT
End DoDot:2
+39 SET INDEX(ENTRIES)=PROC_"^"_$GET(MAGPSET)_"^"_RADTI_"^"_RACNI_"^"_MAGCASE
+40 ; Radiology procedure^Printset^Inverse radiology date/time^Radioloty multiple^radiology case number
+41 DO PRT
SET OLDDT=RADTI
+42 QUIT
End DoDot:1
+43 if '$GET(OUT)
DO SEL
IF +X
IF $DATA(INDEX(+X))
DO SET
+44 KILL OUT
+45 QUIT
PRT ;
+1 SET (X,Y)=0
+2 IF ENTRIES=1
DO HEAD
+3 IF $Y+6>IOSL
DO HEAD
+4 WRITE !?1,ENTRIES,?5,PSET,?6,CASE_$$IMG^MAGDRA2(RARPT),?12,$EXTRACT(PROC,1,28)
+5 WRITE ?41,DATE,?52,$EXTRACT(ESTAT,1,12),?67,$EXTRACT(LOC,1,12)
if ENTRIES#15
QUIT
+6 DO SEL
+7 QUIT
HEAD ;
+1 ;P123
WRITE @IOF,"Patient: ",MAGNME,?50,$$PIDLABEL^MAGSPID(),": ",MAGPID
+2 WRITE !!,?3,"Case #",?12,"Procedure",?41,"Exam Date",?52,"Status of"
+3 WRITE "Exam",?69,"Imaging Loc"
+4 WRITE !?3,"--------",?12,"-------------",?41,"---------"
+5 WRITE ?52,"--------------",?67,"-----------"
+6 QUIT
SEL ;
+1 ; -- array for FileMan prompt data
NEW DIR
+2 SET DIR(0)="NAO^1:"_ENTRIES
+3 SET DIR("?",1)="Enter a number between 1 and "_ENTRIES
+4 SET DIR("?")="corresponding to a single exam you wish to select."
+5 SET DIR("A",1)="'i' next to a case number denotes images collected on study."
+6 SET DIR("A")="Select an exam: "
+7 DO ^DIR
+8 ; didn't time out or uparrow out
IF '$DATA(DTOUT)
IF '$DATA(DUOUT)
+9 IF '$TEST
SET OUT=1
QUIT
+10 IF Y
IF $DATA(INDEX(Y))
DO CHECK
IF 'Y
GOTO SEL
+11 IF Y
SET Y=INDEX(Y)
SET OUT=1
+12 QUIT
SET ;
+1 SET DATA=Y
KILL Y
+2 SET MAGCASE=$PIECE(INDEX(+X),"^",5)
+3 SET MAGPRC=$PIECE(INDEX(+X),"^")
SET MAGPIEN=$$PROC^MAGDRA2(MAGPRC)
+4 SET MAGDTI=$PIECE(INDEX(+X),"^",3)
+5 SET MAGPST=$PIECE(INDEX(+X),"^",2)
+6 SET MAGCNI=$PIECE(INDEX(+X),"^",4)
+7 DO MAGDY^MAGDRA2
+8 QUIT
CHECK ;
+1 ;Check to see if the entry still exists.
+2 NEW RADTI,CNI
+3 if 'MAGDFN
QUIT
+4 SET RADTI=$PIECE(INDEX(Y),"^",3)
SET CNI=$PIECE(INDEX(Y),"^",4)
+5 IF '$DATA(^RADPT(MAGDFN,"DT",RADTI,"P",CNI))
Begin DoDot:1
+6 SET Y=""
+7 WRITE !,"There is a database problem with the entry selected.",!
+8 QUIT
End DoDot:1
+9 IF $PIECE(INDEX(Y),"^")=""
Begin DoDot:1
+10 SET Y=""
+11 WRITE !,"There are no procedures for the entry selected.",!
End DoDot:1
+12 QUIT
