MAGDRA2 ;WOIFO/LB,JSL,SAF - Routine for DICOM fix ; 13 Jul 2011 10:22 AM
;;3.0;IMAGING;**10,11,51,54,49,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
; Routine to create the MAGDY variable needed by MAGDLB1 routine when
; manually correcting DICOM FIX files.
EN ;
; MAGDY variable to be created during this execution.
N MAGBEG,MAGEND,MAGDFN,MAGOUT,MAGX,MAGXX,INFO,MAGNME,MAGPID
S MAGBEG=1070101,MAGEND=$$DT^XLFDT
READ ;
S (MAGDFN,MAGX)=$$READ^MAGDRA3
Q:MAGX="^"
S MAGDFN=+MAGDFN
I 'MAGDFN W !,"Entry not found, enter a ""^"" to quit." G READ
;
I MAGX["~" G ONE ;Lookup was on case number and successful
S MAGXX=$$FIND1^DIC(70,"","","`"_MAGDFN) ;Radiology patient
;
I MAGDFN=MAGXX D
. S INFO=$$PTINFO Q:$D(MAGERR)
. S MAGNME=$P(INFO,"^"),MAGPID=$P(INFO,"^",2)
. K ^TMP($J,"RAE1") ;Re-established by EN1^RA07PC1 -DBIA available
. ; Set the beginning and ending date.
. D EN1^RAO7PC1(MAGDFN,MAGBEG,MAGEND,500)
. D:$D(^TMP($J,"RAE1")) LOOP^MAGDRA1
. Q
E D G:MAGX'="^" READ
. W !,"No Radiology information found for the supplied answer.",$C(7)
. Q
Q
;
PTINFO() ;
N INFO,MAGOUT
I '$D(MAGDFN) Q ""
I $$ISIHS^MAGSPID() D Q INFO ;P123 - MOD for IHS patients with Health Record Numbers (i.e. Chawktaw)
. N DFN S DFN=MAGDFN,INFO="" D DEM^VADPT
. I $G(VA("PID"))'="" S INFO=$G(VADM(1))_"^"_$TR(VA("PID"),"-")
. E S INFO=$G(VADM(1))_"^"_$P($G(VADM(2)),"^")
. Q
D GETS^DIQ(2,MAGDFN,".01;.09","E","MAGOUT","MAGERR")
I $D(MAGERR) Q ""
I $D(MAGOUT) D Q INFO
. S INFO=$G(MAGOUT(2,MAGDFN_",",.01,"E"))
. S INFO=INFO_"^"_$G(MAGOUT(2,MAGDFN_",",.09,"E"))
. Q
Q ""
;
LCASE(MAGDT,MAGCASE) ; return the accession number
N ACNUMB,ARESULT
S ACNUMB=$TR($TR($$FMTE^XLFDT(MAGDT,"2FD")," ","0"),"/","")_"-"_MAGCASE
I $$USESSAN^RAHLRU1(),$$ACCFIND^RAAPI(ACNUMB,.ARESULT)>0 D ; ICR 5600
. ; lookup site-specific accession number
. N ACNUMB1,RADFN,RADTI,RACNI
. S RADFN=$P(ARESULT(1),"^",1),RADTI=$P(ARESULT(1),"^",2)
. S RACNI=$P(ARESULT(1),"^",3)
. S ACNUMB1=$$GET1^DIQ(70.03,(RACNI_","_RADTI_","_RADFN),31)
. I ACNUMB1'="" S ACNUMB=ACNUMB1
. Q
Q ACNUMB
;
IMG(MAGRPT) ;
N INFO,MAGOUT,MAGERR
I 'MAGRPT Q ""
D GETS^DIQ(74,MAGRPT,"2005*","I","MAGOUT","MAGERR")
I $D(MAGERR) Q ""
I $D(MAGOUT(74.02005)) Q " i"
Q ""
;
PROC(MAGPRC) ;
Q $$FIND1^DIC(71,,"XB",MAGPRC)
;
ONE ;
;MAGDFN,MAGX variables expected from EN
I 'MAGDFN,'+MAGX Q
N BEG,CASE,CDATE,CS,DATA,END,FLDS,INFO,MAGCASE,MAGCNI,MAGDATE,MAGDTI
N MAGEXST,MAGLOC,MAGNME,MAGOUT,MAGPIEN,MAGPRC,MAGPSET,MAGPST,MAGRPT
N PP,PSET,RAENTRY,RAMEMLOW,RAPRTSET,RIEN,STAT,X,X1,X2,XX
N RARPT,RADFN,RADTI,RACNI ;<--Variables needed for EN1^RAUTL20
; RAUTL20 used to retrieve if case is part of a print set.
S MAGDFN=$P(MAGX,"~"),INFO=$$PTINFO
S MAGNME=$P(INFO,"^"),MAGPID=$P(INFO,"^",2)
S RIEN=$P(MAGX,"~",2)_","_$P(MAGX,"~",1)
S BEG=9999999.9999-$P(MAGX,"~",2),END=$$FMADD^XLFDT(BEG,2)
K ^TMP($J,"RAE1")
D EN1^RAO7PC1(MAGDFN,BEG,END,20)
S RAENTRY=$P(MAGX,"~",2)_"-"_$P(MAGX,"~",3)
Q:'$D(^TMP($J,"RAE1"))
Q:'$D(^TMP($J,"RAE1",MAGDFN,RAENTRY))
S DATA=^TMP($J,"RAE1",MAGDFN,RAENTRY)
S MAGDATE=$P(RAENTRY,"-"),CDATE=9999999.9999-MAGDATE
S MAGDATE=$TR($$FMTE^XLFDT(CDATE,"2FD")," ","0")
S MAGPRC=$P(DATA,"^"),CASE=$P(DATA,"^",2),STAT=$P(DATA,"^",6)
S MAGEXST=$P(STAT,"~",2),MAGLOC=$P(DATA,"^",7)
S (MAGRPT,RARPT)=$P(DATA,"^",5)
S (MAGDTI,RADTI)=$P(RAENTRY,"-")
S (MAGCNI,RACNI)=$P(RAENTRY,"-",2),RADFN=MAGDFN
S MAGCASE=$$LCASE(CDATE,CASE),MAGPIEN=$$PROC(MAGPRC)
; RADTI, RADFN, RACNI variables needed for EN1^RAUTL20
D EN1^RAUTL20
S (PSET,MAGPSET)=""
S PSET=$S(RAMEMLOW:"+",RAPRTSET:".",1:"")
I PSET=".",RACNI>1 D
. N OLDENTRY S OLDENTRY=$P(RAENTRY,"-")_"-"
. S OLDENTRY=$O(^TMP($J,"RAE1",MAGDFN,OLDENTRY)) I $L(OLDENTRY) D
. . S MAGCASE=$P(^TMP($J,"RAE1",MAGDFN,OLDENTRY),"^",2)
. . S CDATE=$P(RAENTRY,"-")
. . S CDATE=9999999.9999-CDATE
. . S MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE),RACNI=$P(OLDENTRY,"-",2)
. . S MAGPST=CASE_" is part of this printset."
. . Q
. Q
I $D(RAPRTSET) S PP=$S(MAGCNI>1:".",MAGCNI=1:"+",1:"")
S MAGCNI=RACNI
W !,"PATIENT: ",MAGNME,?51,$$PIDLABEL^MAGSPID(),": ",MAGPID
W !,"Case No.",?15,"Procedure",?42,"Location",?64,"Exam Date"
W !,"________",?15,"_________",?42,"________________",?64,"________"
W !,$G(PP),CASE,$$IMG(MAGRPT),?15,MAGPRC,?42,MAGLOC,?64,MAGDATE
W !,"Exam status: ",MAGEXST," "," ",$G(MAGPST)
D MAGDY
Q
;
MAGDY ;
S MAGDY=MAGDFN_"^"_MAGNME_"^"_MAGPID_"^"_MAGCASE_"^"_MAGPRC_"^"_MAGDTI
S MAGDY=MAGDY_"^"_MAGCNI_"^"_MAGPIEN_"^"_$G(MAGPST)_"^"
K MAGNME,MAGPID,MAGCASE,MAGPRC,MAGDTI,MAGCNI,MAGPIEN,MAPST
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDRA2 5699 printed Oct 16, 2024@18:01:59 Page 2
MAGDRA2 ;WOIFO/LB,JSL,SAF - Routine for DICOM fix ; 13 Jul 2011 10:22 AM
+1 ;;3.0;IMAGING;**10,11,51,54,49,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
+18 ; Routine to create the MAGDY variable needed by MAGDLB1 routine when
+19 ; manually correcting DICOM FIX files.
EN ;
+1 ; MAGDY variable to be created during this execution.
+2 NEW MAGBEG,MAGEND,MAGDFN,MAGOUT,MAGX,MAGXX,INFO,MAGNME,MAGPID
+3 SET MAGBEG=1070101
SET MAGEND=$$DT^XLFDT
READ ;
+1 SET (MAGDFN,MAGX)=$$READ^MAGDRA3
+2 if MAGX="^"
QUIT
+3 SET MAGDFN=+MAGDFN
+4 IF 'MAGDFN
WRITE !,"Entry not found, enter a ""^"" to quit."
GOTO READ
+5 ;
+6 ;Lookup was on case number and successful
IF MAGX["~"
GOTO ONE
+7 ;Radiology patient
SET MAGXX=$$FIND1^DIC(70,"","","`"_MAGDFN)
+8 ;
+9 IF MAGDFN=MAGXX
Begin DoDot:1
+10 SET INFO=$$PTINFO
if $DATA(MAGERR)
QUIT
+11 SET MAGNME=$PIECE(INFO,"^")
SET MAGPID=$PIECE(INFO,"^",2)
+12 ;Re-established by EN1^RA07PC1 -DBIA available
KILL ^TMP($JOB,"RAE1")
+13 ; Set the beginning and ending date.
+14 DO EN1^RAO7PC1(MAGDFN,MAGBEG,MAGEND,500)
+15 if $DATA(^TMP($JOB,"RAE1"))
DO LOOP^MAGDRA1
+16 QUIT
End DoDot:1
+17 IF '$TEST
Begin DoDot:1
+18 WRITE !,"No Radiology information found for the supplied answer.",$CHAR(7)
+19 QUIT
End DoDot:1
if MAGX'="^"
GOTO READ
+20 QUIT
+21 ;
PTINFO() ;
+1 NEW INFO,MAGOUT
+2 IF '$DATA(MAGDFN)
QUIT ""
+3 ;P123 - MOD for IHS patients with Health Record Numbers (i.e. Chawktaw)
IF $$ISIHS^MAGSPID()
Begin DoDot:1
+4 NEW DFN
SET DFN=MAGDFN
SET INFO=""
DO DEM^VADPT
+5 IF $GET(VA("PID"))'=""
SET INFO=$GET(VADM(1))_"^"_$TRANSLATE(VA("PID"),"-")
+6 IF '$TEST
SET INFO=$GET(VADM(1))_"^"_$PIECE($GET(VADM(2)),"^")
+7 QUIT
End DoDot:1
QUIT INFO
+8 DO GETS^DIQ(2,MAGDFN,".01;.09","E","MAGOUT","MAGERR")
+9 IF $DATA(MAGERR)
QUIT ""
+10 IF $DATA(MAGOUT)
Begin DoDot:1
+11 SET INFO=$GET(MAGOUT(2,MAGDFN_",",.01,"E"))
+12 SET INFO=INFO_"^"_$GET(MAGOUT(2,MAGDFN_",",.09,"E"))
+13 QUIT
End DoDot:1
QUIT INFO
+14 QUIT ""
+15 ;
LCASE(MAGDT,MAGCASE) ; return the accession number
+1 NEW ACNUMB,ARESULT
+2 SET ACNUMB=$TRANSLATE($TRANSLATE($$FMTE^XLFDT(MAGDT,"2FD")," ","0"),"/","")_"-"_MAGCASE
+3 ; ICR 5600
IF $$USESSAN^RAHLRU1()
IF $$ACCFIND^RAAPI(ACNUMB,.ARESULT)>0
Begin DoDot:1
+4 ; lookup site-specific accession number
+5 NEW ACNUMB1,RADFN,RADTI,RACNI
+6 SET RADFN=$PIECE(ARESULT(1),"^",1)
SET RADTI=$PIECE(ARESULT(1),"^",2)
+7 SET RACNI=$PIECE(ARESULT(1),"^",3)
+8 SET ACNUMB1=$$GET1^DIQ(70.03,(RACNI_","_RADTI_","_RADFN),31)
+9 IF ACNUMB1'=""
SET ACNUMB=ACNUMB1
+10 QUIT
End DoDot:1
+11 QUIT ACNUMB
+12 ;
IMG(MAGRPT) ;
+1 NEW INFO,MAGOUT,MAGERR
+2 IF 'MAGRPT
QUIT ""
+3 DO GETS^DIQ(74,MAGRPT,"2005*","I","MAGOUT","MAGERR")
+4 IF $DATA(MAGERR)
QUIT ""
+5 IF $DATA(MAGOUT(74.02005))
QUIT " i"
+6 QUIT ""
+7 ;
PROC(MAGPRC) ;
+1 QUIT $$FIND1^DIC(71,,"XB",MAGPRC)
+2 ;
ONE ;
+1 ;MAGDFN,MAGX variables expected from EN
+2 IF 'MAGDFN
IF '+MAGX
QUIT
+3 NEW BEG,CASE,CDATE,CS,DATA,END,FLDS,INFO,MAGCASE,MAGCNI,MAGDATE,MAGDTI
+4 NEW MAGEXST,MAGLOC,MAGNME,MAGOUT,MAGPIEN,MAGPRC,MAGPSET,MAGPST,MAGRPT
+5 NEW PP,PSET,RAENTRY,RAMEMLOW,RAPRTSET,RIEN,STAT,X,X1,X2,XX
+6 ;<--Variables needed for EN1^RAUTL20
NEW RARPT,RADFN,RADTI,RACNI
+7 ; RAUTL20 used to retrieve if case is part of a print set.
+8 SET MAGDFN=$PIECE(MAGX,"~")
SET INFO=$$PTINFO
+9 SET MAGNME=$PIECE(INFO,"^")
SET MAGPID=$PIECE(INFO,"^",2)
+10 SET RIEN=$PIECE(MAGX,"~",2)_","_$PIECE(MAGX,"~",1)
+11 SET BEG=9999999.9999-$PIECE(MAGX,"~",2)
SET END=$$FMADD^XLFDT(BEG,2)
+12 KILL ^TMP($JOB,"RAE1")
+13 DO EN1^RAO7PC1(MAGDFN,BEG,END,20)
+14 SET RAENTRY=$PIECE(MAGX,"~",2)_"-"_$PIECE(MAGX,"~",3)
+15 if '$DATA(^TMP($JOB,"RAE1"))
QUIT
+16 if '$DATA(^TMP($JOB,"RAE1",MAGDFN,RAENTRY))
QUIT
+17 SET DATA=^TMP($JOB,"RAE1",MAGDFN,RAENTRY)
+18 SET MAGDATE=$PIECE(RAENTRY,"-")
SET CDATE=9999999.9999-MAGDATE
+19 SET MAGDATE=$TRANSLATE($$FMTE^XLFDT(CDATE,"2FD")," ","0")
+20 SET MAGPRC=$PIECE(DATA,"^")
SET CASE=$PIECE(DATA,"^",2)
SET STAT=$PIECE(DATA,"^",6)
+21 SET MAGEXST=$PIECE(STAT,"~",2)
SET MAGLOC=$PIECE(DATA,"^",7)
+22 SET (MAGRPT,RARPT)=$PIECE(DATA,"^",5)
+23 SET (MAGDTI,RADTI)=$PIECE(RAENTRY,"-")
+24 SET (MAGCNI,RACNI)=$PIECE(RAENTRY,"-",2)
SET RADFN=MAGDFN
+25 SET MAGCASE=$$LCASE(CDATE,CASE)
SET MAGPIEN=$$PROC(MAGPRC)
+26 ; RADTI, RADFN, RACNI variables needed for EN1^RAUTL20
+27 DO EN1^RAUTL20
+28 SET (PSET,MAGPSET)=""
+29 SET PSET=$SELECT(RAMEMLOW:"+",RAPRTSET:".",1:"")
+30 IF PSET="."
IF RACNI>1
Begin DoDot:1
+31 NEW OLDENTRY
SET OLDENTRY=$PIECE(RAENTRY,"-")_"-"
+32 SET OLDENTRY=$ORDER(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY))
IF $LENGTH(OLDENTRY)
Begin DoDot:2
+33 SET MAGCASE=$PIECE(^TMP($JOB,"RAE1",MAGDFN,OLDENTRY),"^",2)
+34 SET CDATE=$PIECE(RAENTRY,"-")
+35 SET CDATE=9999999.9999-CDATE
+36 SET MAGCASE=$$LCASE^MAGDRA2(CDATE,MAGCASE)
SET RACNI=$PIECE(OLDENTRY,"-",2)
+37 SET MAGPST=CASE_" is part of this printset."
+38 QUIT
End DoDot:2
+39 QUIT
End DoDot:1
+40 IF $DATA(RAPRTSET)
SET PP=$SELECT(MAGCNI>1:".",MAGCNI=1:"+",1:"")
+41 SET MAGCNI=RACNI
+42 WRITE !,"PATIENT: ",MAGNME,?51,$$PIDLABEL^MAGSPID(),": ",MAGPID
+43 WRITE !,"Case No.",?15,"Procedure",?42,"Location",?64,"Exam Date"
+44 WRITE !,"________",?15,"_________",?42,"________________",?64,"________"
+45 WRITE !,$GET(PP),CASE,$$IMG(MAGRPT),?15,MAGPRC,?42,MAGLOC,?64,MAGDATE
+46 WRITE !,"Exam status: ",MAGEXST," "," ",$GET(MAGPST)
+47 DO MAGDY
+48 QUIT
+49 ;
MAGDY ;
+1 SET MAGDY=MAGDFN_"^"_MAGNME_"^"_MAGPID_"^"_MAGCASE_"^"_MAGPRC_"^"_MAGDTI
+2 SET MAGDY=MAGDY_"^"_MAGCNI_"^"_MAGPIEN_"^"_$GET(MAGPST)_"^"
+3 KILL MAGNME,MAGPID,MAGCASE,MAGPRC,MAGDTI,MAGCNI,MAGPIEN,MAPST
+4 QUIT
+5 ;
