MAGDMEDJ ;WOIFO/LB,RRB,MLH - Routine to fix failed DICOM entries ; 11 Apr 2012 1:01 PM
;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
;; 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
L ;Loop thru the entire file for entries that need processing
;The "F" xref is set for unique Study UIDs. The entry setting this xref
;will also have a "RLATE" node with all the Xray images associated with
;that unique Study UID.
N ANS,CASEDATE,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FOUND,MACHID,MAGDY,MAGIEN,MAGDIMG
N MAGDIEN,MOD,MODEL,MSG,MAGPAT,MAGTYPE,MEDFILE
N NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC,NEWSSN
N OOUT,OUT,PAT,PID,REASON,STUDYUID,JJ,ITEM
I '$D(^MAGD(2006.575,"F")) W !,"Nothing to process!" Q
S (MAGIEN,STUDYUID,OOUT,OUT)=0
F S STUDYUID=$O(^MAGD(2006.575,"F",STUDYUID)) Q:STUDYUID<1!(OOUT) D
. S MAGIEN=$O(^MAGD(2006.575,"F",STUDYUID,0)) Q:'MAGIEN
. Q:'$D(^MAGD(2006.575,MAGIEN,0))
. Q:$P($G(^MAGD(2006.575,MAGIEN,"FIXD")),"^") ;Already fixed.
. ; Only Medicine images
. S MAGTYPE=$G(^MAGD(2006.575,MAGIEN,"TYPE"))
. Q:MAGTYPE'["MED"
. ; Only Medicine images need to be fixed thru this program.
. S DATA=^MAGD(2006.575,MAGIEN,0),FILE=$P(^(0),"^")
. S DATA1=^MAGD(2006.575,MAGIEN,1) ;Case no. info
. S DATA2=$G(^MAGD(2006.575,MAGIEN,"AMFG")) ;Modality info
. S PAT=$P(DATA,"^",4),PID=$P(DATA,"^",3),REASON=$P(DATA,"^",2)
. S MOD=$P(DATA2,"^"),MODEL=$P(DATA2,"^",6)
. S CASENO=$P(DATA1,"^",2),CASEDATE=$P(DATA1,"^",3)
. S MACHID=$P(DATA1,"^",4),DATE=CASEDATE
. S COMNT1=$G(^MAGD(2006.575,MAGIEN,"ACSTXT")) ;1st line comment.
. ; Use patient information send via DICOM FILE
. S MEDFILE=$$FILE^MAGDMEDI($P(CASENO,"-"))
. D DISPLAY S ANS=$$ASK^MAGDLB1 I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 Q
. I ANS="N" S OUT=1 Q
. I ANS="D" D SETDEL Q
. Q:OUT
. K MAGDY W !," Lookup patient name",!
. S MAGPAT=$$PATLK^MCARUTL2
. I 'MAGPAT D Q
. . W !,"Cannot update if patient cannot be identified.",$C(7)
. ; If patient name could not be determined then we cannot correct.
. D PATSUB^MAGDMEDK(.MAGSUB,MAGPAT)
. Q:'$D(MAGSUB)#10 ;No subspecialties found
. ; Select subspecialty
. S SUB=$$DISPLAY^MAGDMEDL(.MAGSUB) I 'SUB D Q
. . W !,"No specialty selected"
. S SUB=$P(MAGSUB(SUB),"^"),SUB=$P(SUB,"(",2),SUB=$P(SUB,")",1)
. D SUB^MAGDMEDK(SUB,MAGPAT)
. I '$D(MAGMC)#10 D Q
. . W !,"No entries were found for the selected specialty."
. D LOOP^MAGDMEDL(.XX,MAGPAT,SUB,CASEDATE)
. I $D(XX(0)),$P(XX(0),"^")=0 D Q:MAGDOUT
. . S MAGDOUT=0
. . W !,"No Medicine file entries found for this patient"
. . W !,"on the date/time the image was captured."
. . S FOUND=$$ASKMORE^MAGDMEDL I 'FOUND S MAGDOUT=1
. S ITEM=$$DISPLAY^MAGDMEDL(.XX) I 'ITEM D Q
. . W !,"Cannot update if Medicine file entry cannot be found.",$C(7)
. D NEWCASE,CHK,NEWDIS S ANS=$$ASK^MAGDLB1 I ANS="D" D SETDEL Q
. I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 Q
. I ANS="N" S OUT=1 Q
. Q:OUT D UPDT
. Q
K OUT,OOUT,ANS,MAGDOUT,MAGMC,MAGSUB,SUB,XX
Q
DISPLAY ;
D DISPLAY^MAGDLB1
Q
NEWCASE ;
Q:'$D(XX(0))
Q:'$D(XX(ITEM,1))
S MAGDY=$G(XX(ITEM,1)) ;W !,MAGDY
I MAGDY="" Q
S NEWDFN=MAGPAT,NEWNME=$P(MAGDY,"^",2),NEWSSN=$P(MAGDY,"^",3)
S NEWCAS=$P(MAGDY,"^",1),NEWPROC=$P(MAGDY,"^",5),NEWDTI=$P(MAGDY,"^",4)
S NEWPIEN=$P(MAGDY,"^",6),MAGDIMG=$P(MAGDY,"^",7),MEDFILE=$P(MAGDY,"^",8)
Q
CHK ;remove any punctuation before doing comparison on SSN
;stop on 1st check.
N OLD,I
Q:MAGDY=""
S OLD="" F I=1:1:$L(PID) I $E(PID,I)?1AN S OLD=OLD_$E(PID,I)
I NEWSSN'=OLD D Q
. S MSG="Social Security numbers do not match. Update?"
. Q
I NEWNME'=PAT D
. S MSG="Patient names do not match. Update?"
. Q
;Finally the problem is with the case number/DICOM ID
S MSG="DICOM ID number is different. Update?"
Q
NEWDIS ;
D NEWDIS^MAGDLB1
Q
UPDT ;
N %,RLATEIEN ; utility variable for FM calls
W !,"Are you sure you want to CORRECT?" S %=2 D YN^DICN
I %=-1!(%=2) S OUT=1 Q
W !,"Updating the file."
S ^MAGD(2006.575,MAGIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWSSN_"^"_NEWCAS_"^"_NEWDTI_"^^^"_NEWPIEN W "."
S ^MAGD(2006.575,MAGIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC_"^"_$G(MAGDIMG)_"^"_MEDFILE W "."
S MACHID=$S(MACHID="":"A",1:MACHID) ;Server ID
S ^MAGD(2006.575,"AFX",MACHID,MAGIEN)="" W "."
; Update all related records with updated fields
S RLATEIEN=""
F S RLATEIEN=$O(^MAGD(2006.575,MAGIEN,"RLATE","B",RLATEIEN)) Q:RLATEIEN="" D
. S ^MAGD(2006.575,RLATEIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWSSN_"^"_NEWCAS_"^"_NEWDTI_"^"_NEWMUL_"^"_NEWDTIM W "."
. S ^MAGD(2006.575,RLATEIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC W "."
. S ^MAGD(2006.575,"AFX",MACHID,RLATEIEN)="" W "."
. Q
Q
SETDEL ;Entry to be deleted
D SETDEL^MAGDLB1
Q
ASKWHCH ;More than one patient found with same name
S MAGPAT=""
N ITEM
Q:'$D(JJ(0))
S ITEM=$$DISPLAY^MAGDMEDL(.JJ)
I ITEM S MAGPAT=$P(JJ(+ITEM,1),"^",3)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDMEDJ 5905 printed Apr 09, 2024@21:04:03 Page 2
MAGDMEDJ ;WOIFO/LB,RRB,MLH - Routine to fix failed DICOM entries ; 11 Apr 2012 1:01 PM
+1 ;;3.0;IMAGING;**118**;Mar 19, 2002;Build 4525;May 01, 2013
+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
L ;Loop thru the entire file for entries that need processing
+1 ;The "F" xref is set for unique Study UIDs. The entry setting this xref
+2 ;will also have a "RLATE" node with all the Xray images associated with
+3 ;that unique Study UID.
+4 NEW ANS,CASEDATE,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FOUND,MACHID,MAGDY,MAGIEN,MAGDIMG
+5 NEW MAGDIEN,MOD,MODEL,MSG,MAGPAT,MAGTYPE,MEDFILE
+6 NEW NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC,NEWSSN
+7 NEW OOUT,OUT,PAT,PID,REASON,STUDYUID,JJ,ITEM
+8 IF '$DATA(^MAGD(2006.575,"F"))
WRITE !,"Nothing to process!"
QUIT
+9 SET (MAGIEN,STUDYUID,OOUT,OUT)=0
+10 FOR
SET STUDYUID=$ORDER(^MAGD(2006.575,"F",STUDYUID))
if STUDYUID<1!(OOUT)
QUIT
Begin DoDot:1
+11 SET MAGIEN=$ORDER(^MAGD(2006.575,"F",STUDYUID,0))
if 'MAGIEN
QUIT
+12 if '$DATA(^MAGD(2006.575,MAGIEN,0))
QUIT
+13 ;Already fixed.
if $PIECE($GET(^MAGD(2006.575,MAGIEN,"FIXD")),"^")
QUIT
+14 ; Only Medicine images
+15 SET MAGTYPE=$GET(^MAGD(2006.575,MAGIEN,"TYPE"))
+16 if MAGTYPE'["MED"
QUIT
+17 ; Only Medicine images need to be fixed thru this program.
+18 SET DATA=^MAGD(2006.575,MAGIEN,0)
SET FILE=$PIECE(^(0),"^")
+19 ;Case no. info
SET DATA1=^MAGD(2006.575,MAGIEN,1)
+20 ;Modality info
SET DATA2=$GET(^MAGD(2006.575,MAGIEN,"AMFG"))
+21 SET PAT=$PIECE(DATA,"^",4)
SET PID=$PIECE(DATA,"^",3)
SET REASON=$PIECE(DATA,"^",2)
+22 SET MOD=$PIECE(DATA2,"^")
SET MODEL=$PIECE(DATA2,"^",6)
+23 SET CASENO=$PIECE(DATA1,"^",2)
SET CASEDATE=$PIECE(DATA1,"^",3)
+24 SET MACHID=$PIECE(DATA1,"^",4)
SET DATE=CASEDATE
+25 ;1st line comment.
SET COMNT1=$GET(^MAGD(2006.575,MAGIEN,"ACSTXT"))
+26 ; Use patient information send via DICOM FILE
+27 SET MEDFILE=$$FILE^MAGDMEDI($PIECE(CASENO,"-"))
+28 DO DISPLAY
SET ANS=$$ASK^MAGDLB1
IF ANS="Q"!(ANS["^")
SET (OOUT,OUT)=1
QUIT
+29 IF ANS="N"
SET OUT=1
QUIT
+30 IF ANS="D"
DO SETDEL
QUIT
+31 if OUT
QUIT
+32 KILL MAGDY
WRITE !," Lookup patient name",!
+33 SET MAGPAT=$$PATLK^MCARUTL2
+34 IF 'MAGPAT
Begin DoDot:2
+35 WRITE !,"Cannot update if patient cannot be identified.",$CHAR(7)
End DoDot:2
QUIT
+36 ; If patient name could not be determined then we cannot correct.
+37 DO PATSUB^MAGDMEDK(.MAGSUB,MAGPAT)
+38 ;No subspecialties found
if '$DATA(MAGSUB)#10
QUIT
+39 ; Select subspecialty
+40 SET SUB=$$DISPLAY^MAGDMEDL(.MAGSUB)
IF 'SUB
Begin DoDot:2
+41 WRITE !,"No specialty selected"
End DoDot:2
QUIT
+42 SET SUB=$PIECE(MAGSUB(SUB),"^")
SET SUB=$PIECE(SUB,"(",2)
SET SUB=$PIECE(SUB,")",1)
+43 DO SUB^MAGDMEDK(SUB,MAGPAT)
+44 IF '$DATA(MAGMC)#10
Begin DoDot:2
+45 WRITE !,"No entries were found for the selected specialty."
End DoDot:2
QUIT
+46 DO LOOP^MAGDMEDL(.XX,MAGPAT,SUB,CASEDATE)
+47 IF $DATA(XX(0))
IF $PIECE(XX(0),"^")=0
Begin DoDot:2
+48 SET MAGDOUT=0
+49 WRITE !,"No Medicine file entries found for this patient"
+50 WRITE !,"on the date/time the image was captured."
+51 SET FOUND=$$ASKMORE^MAGDMEDL
IF 'FOUND
SET MAGDOUT=1
End DoDot:2
if MAGDOUT
QUIT
+52 SET ITEM=$$DISPLAY^MAGDMEDL(.XX)
IF 'ITEM
Begin DoDot:2
+53 WRITE !,"Cannot update if Medicine file entry cannot be found.",$CHAR(7)
End DoDot:2
QUIT
+54 DO NEWCASE
DO CHK
DO NEWDIS
SET ANS=$$ASK^MAGDLB1
IF ANS="D"
DO SETDEL
QUIT
+55 IF ANS="Q"!(ANS["^")
SET (OOUT,OUT)=1
QUIT
+56 IF ANS="N"
SET OUT=1
QUIT
+57 if OUT
QUIT
DO UPDT
+58 QUIT
End DoDot:1
+59 KILL OUT,OOUT,ANS,MAGDOUT,MAGMC,MAGSUB,SUB,XX
+60 QUIT
DISPLAY ;
+1 DO DISPLAY^MAGDLB1
+2 QUIT
NEWCASE ;
+1 if '$DATA(XX(0))
QUIT
+2 if '$DATA(XX(ITEM,1))
QUIT
+3 ;W !,MAGDY
SET MAGDY=$GET(XX(ITEM,1))
+4 IF MAGDY=""
QUIT
+5 SET NEWDFN=MAGPAT
SET NEWNME=$PIECE(MAGDY,"^",2)
SET NEWSSN=$PIECE(MAGDY,"^",3)
+6 SET NEWCAS=$PIECE(MAGDY,"^",1)
SET NEWPROC=$PIECE(MAGDY,"^",5)
SET NEWDTI=$PIECE(MAGDY,"^",4)
+7 SET NEWPIEN=$PIECE(MAGDY,"^",6)
SET MAGDIMG=$PIECE(MAGDY,"^",7)
SET MEDFILE=$PIECE(MAGDY,"^",8)
+8 QUIT
CHK ;remove any punctuation before doing comparison on SSN
+1 ;stop on 1st check.
+2 NEW OLD,I
+3 if MAGDY=""
QUIT
+4 SET OLD=""
FOR I=1:1:$LENGTH(PID)
IF $EXTRACT(PID,I)?1AN
SET OLD=OLD_$EXTRACT(PID,I)
+5 IF NEWSSN'=OLD
Begin DoDot:1
+6 SET MSG="Social Security numbers do not match. Update?"
+7 QUIT
End DoDot:1
QUIT
+8 IF NEWNME'=PAT
Begin DoDot:1
+9 SET MSG="Patient names do not match. Update?"
+10 QUIT
End DoDot:1
+11 ;Finally the problem is with the case number/DICOM ID
+12 SET MSG="DICOM ID number is different. Update?"
+13 QUIT
NEWDIS ;
+1 DO NEWDIS^MAGDLB1
+2 QUIT
UPDT ;
+1 ; utility variable for FM calls
NEW %,RLATEIEN
+2 WRITE !,"Are you sure you want to CORRECT?"
SET %=2
DO YN^DICN
+3 IF %=-1!(%=2)
SET OUT=1
QUIT
+4 WRITE !,"Updating the file."
+5 SET ^MAGD(2006.575,MAGIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWSSN_"^"_NEWCAS_"^"_NEWDTI_"^^^"_NEWPIEN
WRITE "."
+6 SET ^MAGD(2006.575,MAGIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC_"^"_$GET(MAGDIMG)_"^"_MEDFILE
WRITE "."
+7 ;Server ID
SET MACHID=$SELECT(MACHID="":"A",1:MACHID)
+8 SET ^MAGD(2006.575,"AFX",MACHID,MAGIEN)=""
WRITE "."
+9 ; Update all related records with updated fields
+10 SET RLATEIEN=""
+11 FOR
SET RLATEIEN=$ORDER(^MAGD(2006.575,MAGIEN,"RLATE","B",RLATEIEN))
if RLATEIEN=""
QUIT
Begin DoDot:1
+12 SET ^MAGD(2006.575,RLATEIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWSSN_"^"_NEWCAS_"^"_NEWDTI_"^"_NEWMUL_"^"_NEWDTIM
WRITE "."
+13 SET ^MAGD(2006.575,RLATEIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC
WRITE "."
+14 SET ^MAGD(2006.575,"AFX",MACHID,RLATEIEN)=""
WRITE "."
+15 QUIT
End DoDot:1
+16 QUIT
SETDEL ;Entry to be deleted
+1 DO SETDEL^MAGDLB1
+2 QUIT
ASKWHCH ;More than one patient found with same name
+1 SET MAGPAT=""
+2 NEW ITEM
+3 if '$DATA(JJ(0))
QUIT
+4 SET ITEM=$$DISPLAY^MAGDMEDL(.JJ)
+5 IF ITEM
SET MAGPAT=$PIECE(JJ(+ITEM,1),"^",3)
+6 QUIT
