MAGDCCS ;WOIFO/MLH/JSL/SAF - DICOM Correct - Clinical Specialties ; 13 Feb 2012 1:13 PM
;;3.0;IMAGING;**10,11,85,54,123,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,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
N MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP
N MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPID,NEWPIEN,NEWPROC
N OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,STUDYUID,WHY,MAGFIX
N KFIXALL ; --- does user hold MAGDFIX ALL key
N GWLOC ; -- gateway site
;
S KFIXALL=$$SECKEY^MAGDLB12()
I '$D(^MAGD(2006.575,"F")) W !,"Nothing to process!" Q
S (OOUT,OUT,PREV,FIRST)=0
S GWLOC=0
F S GWLOC=$O(^MAGD(2006.575,"F",GWLOC)) Q:'GWLOC D
. S SUID=""
. F S SUID=$O(^MAGD(2006.575,"F",GWLOC,SUID)) Q:SUID=""!(OOUT) D
. . S MAGIEN=$O(^MAGD(2006.575,"F",GWLOC,SUID,0)) Q:'MAGIEN
. . ; if no main failed image rec, there's a xref prob, so bail
. . I '$D(^MAGD(2006.575,MAGIEN,0)) D Q ; clean up xref
. . . K ^MAGD(2006.575,"F",GWLOC,SUID,MAGIEN)
. . . Q
. . ;Only process clinical specialties images... radiology and medicine images done by other rtns.
. . S MAGTYPE=$P($G(^MAGD(2006.575,MAGIEN,"TYPE")),"^") I MAGTYPE'="CON" Q
. . I $D(^MAGD(2006.575,MAGIEN,"FIXD")),$P(^MAGD(2006.575,MAGIEN,"FIXD"),"^") Q
. . I 'FIRST S PREV=MAGIEN,PREVS=SUID,FIRST=MAGIEN
. . D SET
. . Q
. Q
Q
;
DISPLAY ;
S OUT=0
W !,"**************Processing entry**********"
W !!,?2,"PATIENT: ",PAT,?50,$$PIDLABEL^MAGSPID(),PID,!,"Request/Consultation #: ",CASENO
W !,?2,"Equipment: ",MOD,?50,"Model: ",MODEL
W !,?2,"Date Processed: ",DATE,?50,"Problem with: ",REASON
W !,?2,"Comment: ",COMNT1
W !,?2,"Correcting file on server ID: ",MACHID,!,?5,FILE
S MSG="Do you want to Correct this entry? "
Q
;
NEWCASE ;
S NEWDFN=$P(MAGDY,"^"),NEWNME=$P(MAGDY,"^",2),NEWPID=$P(MAGDY,"^",3)
S NEWCAS=$P(MAGDY,"^",4),NEWPROC=$P(MAGDY,"^",5),NEWDTI=$P(MAGDY,"^",6)
S NEWMUL=$P(MAGDY,"^",7),NEWPIEN=$P(MAGDY,"^",8),PP=$P(MAGDY,"^",9)
Q
;
ASK() ;
N ANS,ASK
ASK1 S ASK="Y/N/D/Q"
I $G(PREV)'=$G(MAGIEN),MAGTYPE="CON" S ASK=ASK_"/P"
W !,$G(MSG),"("_ASK_")// " R ANS:600
I '$T!(ANS["^") Q "^"
I ANS="" Q "N"
I "YNDPQyndpq"'[$E(ANS) D G ASK1
. W !,"Please respond with one of the following codes."
. W !,"Legend: Y=yes, N=no, D=delete, P=Previous entry, and Q=quit",!
. Q
S ANS=$TR(ANS,"yndpq","YNDPQ")
Q $E(ANS)
;
CHK ;remove any punctuation before doing comparison on SSN
;stop on 1st check.
N OLD,I
S OLD="" F I=1:1:$L(PID) I $E(PID,I)?1AN S OLD=OLD_$E(PID,I)
I NEWPID'=OLD D Q
. S MSG=$$PIDLABEL^MAGSPID()_"s do not match. Update? "
I NEWNME'=PAT D Q
. S MSG="Patient names do not match. Update? "
;Finally the problem is with the case number...either no longer in "C"
;xref or invalid number provided
S MSG="Accession number different. Update? "
Q
;
NEWDIS ;
W !,?2,"****Please review the following: *****"
W !,?2,"Previous name: ",PAT,!,?2," New name: ",NEWNME
W !,?2,"Previous ",$$PIDLABEL^MAGSPID(),": ",PID,!,?2," New ",$$PIDLABEL^MAGSPID(),": ",NEWPID
W !,?2,"Previous request/consultation #: ",CASENO,!,?2," New request/consultation #: ",NEWCAS
; Variable PP already has text message about being part of printset.
Q
;
UPDT ;
N GWLOC ; -- gateway location
N % ; ------ var for FM utility call
W !,"Will change the following: " D NEWDIS
W !,"Are you sure you want to correct this entry? " S %=2 D YN^DICN
I %=-1!(%=2) S OUT=1 Q
W !,"Updating the file."
S NEWDTIM=$TR(NEWDTI,"0123456789","9876543210")
S ^MAGD(2006.575,MAGIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWPID_"^"_NEWCAS_"^"_NEWDTI_"^"_NEWMUL_"^"_NEWDTIM W "."
S ^MAGD(2006.575,MAGIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC W "."
;Same as ^radpt(newdfn,"DT",newdti,"P",newmul,0) & ^RAMIS(71,newpien,0)
S GWLOC=$P($G(^MAGD(2006.575,MAGIEN,1)),"^",5)
S MACHID=$S(MACHID="":"A",1:MACHID) ; server ID
I GWLOC S ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)="" W "."
E W !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
;Xref to loop & process entries; processing will be minimal.
S MAGFIX(MAGIEN)="F"
Q
;
SETDEL ;Entry to be deleted
N GWLOC ; -- gateway location
D LOGERR I ANS="^" S OUT=1 Q
S GWLOC=$P($G(^MAGD(2006.575,MAGIEN,1)),"^",5)
I GWLOC S ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)="D" W "."
E W !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
S $P(^MAGD(2006.575,MAGIEN,0),"^",6)="1"
S ^MAGD(2006.575,MAGIEN,"FIXD")=1
S MAGFIX(MAGIEN)="D"
Q
;
LOGERR ;Need to record error
N DIR,DIRUT,DTOUT,ENTRY,I,MAGERR,MAGOUT,NOW,WHY,WHO,X,Y
W !! F I=1:1:80 W "*"
W !,"*** Will log in error log (file 2006.599). ****"
S NOW=$$NOW^XLFDT()
S DIR(0)="F^3:30"
S DIR("A")="Reason for deletion"
S DIR("A",1)="Please enter a reason for deleting."
S DIR("A",2)="For example: TEST PATIENT"
D ^DIR
I $D(DIRUT)!($D(DTOUT))!(Y="") D S ANS="^" Q
. W !,"Can not delete if a reason is not provided."
. Q
S WHY=Y,WHO=$G(DUZ)
I WHO D
. D GETS^DIQ(200,DUZ,".01","E","MAGOUT","MAGERR")
. Q:$D(MAGERR("DIERR"))
. S WHO=$G(MAGOUT(200,DUZ_",",.01,"E"))
I WHO="" S WHO="UNKNOWN"
I '$D(^MAGD(2006.599,0)) D
. S ^MAGD(2006.599,0)="Dicom Error Log^2006.599^^"
. Q
S ENTRY=$P(^MAGD(2006.599,0),"^",3)+1
S $P(^MAGD(2006.599,0),"^",3)=ENTRY
S $P(^MAGD(2006.599,0),"^",4)=$P(^MAGD(2006.599,0),"^",4)+1
S ^MAGD(2006.599,ENTRY,0)=NOW_"^"_WHY_"^"_FILE_"^"_MODEL
S ^MAGD(2006.599,ENTRY,1)=WHO_"^"_PAT_"^"_PID_"^"_CASENO_"^"_MACHID
S ^MAGD(2006.599,"B",NOW,ENTRY)=""
Q
;
SET ;
S MAGTYPE=$P(^MAGD(2006.575,MAGIEN,"TYPE"),"^")
Q:$P($G(^MAGD(2006.575,MAGIEN,"FIXD")),"^") ;Already fixed.
;Only process Clinical Specialties images...radiology & medicine images done by other rtns.
I $E(MAGTYPE,1,3)'="CON" Q
S DATA=^MAGD(2006.575,MAGIEN,0)
S FILE=$P(^MAGD(2006.575,MAGIEN,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),MACHID=$P(DATA1,"^",4)
S Y=$P(DATA1,"^",3) X ^DD("DD") S DATE=Y
S COMNT1=$G(^MAGD(2006.575,MAGIEN,"ACSTXT")) ;1st line comment.
S MACHID=$P(DATA1,"^",4)
S ANS="" D DISPLAY S ANS=$$ASK
I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 D SETPREV Q
I ANS="N" S OUT=1 D SETPREV Q
I ANS="P" D CHKPREV Q
I ANS="D" D SETDEL,SETPREV Q
Q:OUT
K MAGDY W !," Lookup by case number or patient name"
;
LOOK ;
D EN^MAGDCCS2 Q:'$D(MAGDY) Q:MAGDY'[""
D NEWCASE,CHK,NEWDIS S ANS=$$ASK
I ANS="Q"!(ANS["^") S (OOUT,OUT)=1 D SETPREV Q
I ANS="D" D SETDEL,SETPREV Q
I ANS="P" D CHKPREV Q
I ANS="N" S OUT=1 D SETPREV Q
Q:OUT
D UPDT
I ANS="P" D CHKPREV Q
D SETMAG
Q
;
DATELOOP(START,STOP) ;Loop thru the "AD" cross reference
N MAGIEN,SUID,THEDT,FIRST,OOUT,MAGFIX
S THEDT=START-.1,(OOUT,FIRST)=0
F S THEDT=$O(^MAGD(2006.575,"AD",THEDT)) Q:'THEDT!(THEDT>STOP)!(OOUT) D
. S MAGIEN=0
. F S MAGIEN=$O(^MAGD(2006.575,"AD",THEDT,MAGIEN)) Q:'MAGIEN D
. . I '$D(^MAGD(2006.575,MAGIEN,0)) K ^MAGD(2006.575,"AD",THEDT,MAGIEN)
. . I $D(^MAGD(2006.575,MAGIEN,"TYPE")),$E($P(^MAGD(2006.575,MAGIEN,"TYPE"),"^"),1,3)'="CON" Q
. . I 'FIRST S PREV=MAGIEN,FIRST=1
. . D SET
. . Q
. Q
Q
;
SETPREV ;
S PREV=MAGIEN,PREVS=$G(SUID)
Q
;
SETMAG ;
S FIRST=MAGIEN,FIRSTS=$G(SUID),MAGIEN=PREV,SUID=$G(PREVS)
S PREV=FIRST,PREVS=FIRSTS
Q
;
CHKPREV ;
S OUT=1 N STATUS
I '$D(MAGFIX(PREV)) D SETMAG G SET
S STATUS=$S($G(MAGFIX(PREV))="D":"deleted",1:"corrected")
W !,"Previous entry has been "_STATUS_".",$C(7)
G SET
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDCCS 8966 printed Apr 09, 2024@21:06:35 Page 2
MAGDCCS ;WOIFO/MLH/JSL/SAF - DICOM Correct - Clinical Specialties ; 13 Feb 2012 1:13 PM
+1 ;;3.0;IMAGING;**10,11,85,54,123,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
+18 ;
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,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
+5 NEW MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP
+6 NEW MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPID,NEWPIEN,NEWPROC
+7 NEW OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,STUDYUID,WHY,MAGFIX
+8 ; --- does user hold MAGDFIX ALL key
NEW KFIXALL
+9 ; -- gateway site
NEW GWLOC
+10 ;
+11 SET KFIXALL=$$SECKEY^MAGDLB12()
+12 IF '$DATA(^MAGD(2006.575,"F"))
WRITE !,"Nothing to process!"
QUIT
+13 SET (OOUT,OUT,PREV,FIRST)=0
+14 SET GWLOC=0
+15 FOR
SET GWLOC=$ORDER(^MAGD(2006.575,"F",GWLOC))
if 'GWLOC
QUIT
Begin DoDot:1
+16 SET SUID=""
+17 FOR
SET SUID=$ORDER(^MAGD(2006.575,"F",GWLOC,SUID))
if SUID=""!(OOUT)
QUIT
Begin DoDot:2
+18 SET MAGIEN=$ORDER(^MAGD(2006.575,"F",GWLOC,SUID,0))
if 'MAGIEN
QUIT
+19 ; if no main failed image rec, there's a xref prob, so bail
+20 ; clean up xref
IF '$DATA(^MAGD(2006.575,MAGIEN,0))
Begin DoDot:3
+21 KILL ^MAGD(2006.575,"F",GWLOC,SUID,MAGIEN)
+22 QUIT
End DoDot:3
QUIT
+23 ;Only process clinical specialties images... radiology and medicine images done by other rtns.
+24 SET MAGTYPE=$PIECE($GET(^MAGD(2006.575,MAGIEN,"TYPE")),"^")
IF MAGTYPE'="CON"
QUIT
+25 IF $DATA(^MAGD(2006.575,MAGIEN,"FIXD"))
IF $PIECE(^MAGD(2006.575,MAGIEN,"FIXD"),"^")
QUIT
+26 IF 'FIRST
SET PREV=MAGIEN
SET PREVS=SUID
SET FIRST=MAGIEN
+27 DO SET
+28 QUIT
End DoDot:2
+29 QUIT
End DoDot:1
+30 QUIT
+31 ;
DISPLAY ;
+1 SET OUT=0
+2 WRITE !,"**************Processing entry**********"
+3 WRITE !!,?2,"PATIENT: ",PAT,?50,$$PIDLABEL^MAGSPID(),PID,!,"Request/Consultation #: ",CASENO
+4 WRITE !,?2,"Equipment: ",MOD,?50,"Model: ",MODEL
+5 WRITE !,?2,"Date Processed: ",DATE,?50,"Problem with: ",REASON
+6 WRITE !,?2,"Comment: ",COMNT1
+7 WRITE !,?2,"Correcting file on server ID: ",MACHID,!,?5,FILE
+8 SET MSG="Do you want to Correct this entry? "
+9 QUIT
+10 ;
NEWCASE ;
+1 SET NEWDFN=$PIECE(MAGDY,"^")
SET NEWNME=$PIECE(MAGDY,"^",2)
SET NEWPID=$PIECE(MAGDY,"^",3)
+2 SET NEWCAS=$PIECE(MAGDY,"^",4)
SET NEWPROC=$PIECE(MAGDY,"^",5)
SET NEWDTI=$PIECE(MAGDY,"^",6)
+3 SET NEWMUL=$PIECE(MAGDY,"^",7)
SET NEWPIEN=$PIECE(MAGDY,"^",8)
SET PP=$PIECE(MAGDY,"^",9)
+4 QUIT
+5 ;
ASK() ;
+1 NEW ANS,ASK
ASK1 SET ASK="Y/N/D/Q"
+1 IF $GET(PREV)'=$GET(MAGIEN)
IF MAGTYPE="CON"
SET ASK=ASK_"/P"
+2 WRITE !,$GET(MSG),"("_ASK_")// "
READ ANS:600
+3 IF '$TEST!(ANS["^")
QUIT "^"
+4 IF ANS=""
QUIT "N"
+5 IF "YNDPQyndpq"'[$EXTRACT(ANS)
Begin DoDot:1
+6 WRITE !,"Please respond with one of the following codes."
+7 WRITE !,"Legend: Y=yes, N=no, D=delete, P=Previous entry, and Q=quit",!
+8 QUIT
End DoDot:1
GOTO ASK1
+9 SET ANS=$TRANSLATE(ANS,"yndpq","YNDPQ")
+10 QUIT $EXTRACT(ANS)
+11 ;
CHK ;remove any punctuation before doing comparison on SSN
+1 ;stop on 1st check.
+2 NEW OLD,I
+3 SET OLD=""
FOR I=1:1:$LENGTH(PID)
IF $EXTRACT(PID,I)?1AN
SET OLD=OLD_$EXTRACT(PID,I)
+4 IF NEWPID'=OLD
Begin DoDot:1
+5 SET MSG=$$PIDLABEL^MAGSPID()_"s do not match. Update? "
End DoDot:1
QUIT
+6 IF NEWNME'=PAT
Begin DoDot:1
+7 SET MSG="Patient names do not match. Update? "
End DoDot:1
QUIT
+8 ;Finally the problem is with the case number...either no longer in "C"
+9 ;xref or invalid number provided
+10 SET MSG="Accession number different. Update? "
+11 QUIT
+12 ;
NEWDIS ;
+1 WRITE !,?2,"****Please review the following: *****"
+2 WRITE !,?2,"Previous name: ",PAT,!,?2," New name: ",NEWNME
+3 WRITE !,?2,"Previous ",$$PIDLABEL^MAGSPID(),": ",PID,!,?2," New ",$$PIDLABEL^MAGSPID(),": ",NEWPID
+4 WRITE !,?2,"Previous request/consultation #: ",CASENO,!,?2," New request/consultation #: ",NEWCAS
+5 ; Variable PP already has text message about being part of printset.
+6 QUIT
+7 ;
UPDT ;
+1 ; -- gateway location
NEW GWLOC
+2 ; ------ var for FM utility call
NEW %
+3 WRITE !,"Will change the following: "
DO NEWDIS
+4 WRITE !,"Are you sure you want to correct this entry? "
SET %=2
DO YN^DICN
+5 IF %=-1!(%=2)
SET OUT=1
QUIT
+6 WRITE !,"Updating the file."
+7 SET NEWDTIM=$TRANSLATE(NEWDTI,"0123456789","9876543210")
+8 SET ^MAGD(2006.575,MAGIEN,"FIXD")="1^"_NEWDFN_"^"_NEWNME_"^"_NEWPID_"^"_NEWCAS_"^"_NEWDTI_"^"_NEWMUL_"^"_NEWDTIM
WRITE "."
+9 SET ^MAGD(2006.575,MAGIEN,"FIXPR")=NEWPIEN_"^"_NEWPROC
WRITE "."
+10 ;Same as ^radpt(newdfn,"DT",newdti,"P",newmul,0) & ^RAMIS(71,newpien,0)
+11 SET GWLOC=$PIECE($GET(^MAGD(2006.575,MAGIEN,1)),"^",5)
+12 ; server ID
SET MACHID=$SELECT(MACHID="":"A",1:MACHID)
+13 IF GWLOC
SET ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)=""
WRITE "."
+14 IF '$TEST
WRITE !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
+15 ;Xref to loop & process entries; processing will be minimal.
+16 SET MAGFIX(MAGIEN)="F"
+17 QUIT
+18 ;
SETDEL ;Entry to be deleted
+1 ; -- gateway location
NEW GWLOC
+2 DO LOGERR
IF ANS="^"
SET OUT=1
QUIT
+3 SET GWLOC=$PIECE($GET(^MAGD(2006.575,MAGIEN,1)),"^",5)
+4 IF GWLOC
SET ^MAGD(2006.575,"AFX",GWLOC,MACHID,MAGIEN)="D"
WRITE "."
+5 IF '$TEST
WRITE !,"Gateway place not defined on image entry "_MAGIEN_", continuing.."
+6 SET $PIECE(^MAGD(2006.575,MAGIEN,0),"^",6)="1"
+7 SET ^MAGD(2006.575,MAGIEN,"FIXD")=1
+8 SET MAGFIX(MAGIEN)="D"
+9 QUIT
+10 ;
LOGERR ;Need to record error
+1 NEW DIR,DIRUT,DTOUT,ENTRY,I,MAGERR,MAGOUT,NOW,WHY,WHO,X,Y
+2 WRITE !!
FOR I=1:1:80
WRITE "*"
+3 WRITE !,"*** Will log in error log (file 2006.599). ****"
+4 SET NOW=$$NOW^XLFDT()
+5 SET DIR(0)="F^3:30"
+6 SET DIR("A")="Reason for deletion"
+7 SET DIR("A",1)="Please enter a reason for deleting."
+8 SET DIR("A",2)="For example: TEST PATIENT"
+9 DO ^DIR
+10 IF $DATA(DIRUT)!($DATA(DTOUT))!(Y="")
Begin DoDot:1
+11 WRITE !,"Can not delete if a reason is not provided."
+12 QUIT
End DoDot:1
SET ANS="^"
QUIT
+13 SET WHY=Y
SET WHO=$GET(DUZ)
+14 IF WHO
Begin DoDot:1
+15 DO GETS^DIQ(200,DUZ,".01","E","MAGOUT","MAGERR")
+16 if $DATA(MAGERR("DIERR"))
QUIT
+17 SET WHO=$GET(MAGOUT(200,DUZ_",",.01,"E"))
End DoDot:1
+18 IF WHO=""
SET WHO="UNKNOWN"
+19 IF '$DATA(^MAGD(2006.599,0))
Begin DoDot:1
+20 SET ^MAGD(2006.599,0)="Dicom Error Log^2006.599^^"
+21 QUIT
End DoDot:1
+22 SET ENTRY=$PIECE(^MAGD(2006.599,0),"^",3)+1
+23 SET $PIECE(^MAGD(2006.599,0),"^",3)=ENTRY
+24 SET $PIECE(^MAGD(2006.599,0),"^",4)=$PIECE(^MAGD(2006.599,0),"^",4)+1
+25 SET ^MAGD(2006.599,ENTRY,0)=NOW_"^"_WHY_"^"_FILE_"^"_MODEL
+26 SET ^MAGD(2006.599,ENTRY,1)=WHO_"^"_PAT_"^"_PID_"^"_CASENO_"^"_MACHID
+27 SET ^MAGD(2006.599,"B",NOW,ENTRY)=""
+28 QUIT
+29 ;
SET ;
+1 SET MAGTYPE=$PIECE(^MAGD(2006.575,MAGIEN,"TYPE"),"^")
+2 ;Already fixed.
if $PIECE($GET(^MAGD(2006.575,MAGIEN,"FIXD")),"^")
QUIT
+3 ;Only process Clinical Specialties images...radiology & medicine images done by other rtns.
+4 IF $EXTRACT(MAGTYPE,1,3)'="CON"
QUIT
+5 SET DATA=^MAGD(2006.575,MAGIEN,0)
+6 SET FILE=$PIECE(^MAGD(2006.575,MAGIEN,0),"^")
+7 ;Case no. info
SET DATA1=^MAGD(2006.575,MAGIEN,1)
+8 ;Modality info
SET DATA2=$GET(^MAGD(2006.575,MAGIEN,"AMFG"))
+9 SET PAT=$PIECE(DATA,"^",4)
SET PID=$PIECE(DATA,"^",3)
SET REASON=$PIECE(DATA,"^",2)
+10 SET MOD=$PIECE(DATA2,"^")
SET MODEL=$PIECE(DATA2,"^",6)
+11 SET CASENO=$PIECE(DATA1,"^",2)
SET MACHID=$PIECE(DATA1,"^",4)
+12 SET Y=$PIECE(DATA1,"^",3)
XECUTE ^DD("DD")
SET DATE=Y
+13 ;1st line comment.
SET COMNT1=$GET(^MAGD(2006.575,MAGIEN,"ACSTXT"))
+14 SET MACHID=$PIECE(DATA1,"^",4)
+15 SET ANS=""
DO DISPLAY
SET ANS=$$ASK
+16 IF ANS="Q"!(ANS["^")
SET (OOUT,OUT)=1
DO SETPREV
QUIT
+17 IF ANS="N"
SET OUT=1
DO SETPREV
QUIT
+18 IF ANS="P"
DO CHKPREV
QUIT
+19 IF ANS="D"
DO SETDEL
DO SETPREV
QUIT
+20 if OUT
QUIT
+21 KILL MAGDY
WRITE !," Lookup by case number or patient name"
+22 ;
LOOK ;
+1 DO EN^MAGDCCS2
if '$DATA(MAGDY)
QUIT
if MAGDY'[""
QUIT
+2 DO NEWCASE
DO CHK
DO NEWDIS
SET ANS=$$ASK
+3 IF ANS="Q"!(ANS["^")
SET (OOUT,OUT)=1
DO SETPREV
QUIT
+4 IF ANS="D"
DO SETDEL
DO SETPREV
QUIT
+5 IF ANS="P"
DO CHKPREV
QUIT
+6 IF ANS="N"
SET OUT=1
DO SETPREV
QUIT
+7 if OUT
QUIT
+8 DO UPDT
+9 IF ANS="P"
DO CHKPREV
QUIT
+10 DO SETMAG
+11 QUIT
+12 ;
DATELOOP(START,STOP) ;Loop thru the "AD" cross reference
+1 NEW MAGIEN,SUID,THEDT,FIRST,OOUT,MAGFIX
+2 SET THEDT=START-.1
SET (OOUT,FIRST)=0
+3 FOR
SET THEDT=$ORDER(^MAGD(2006.575,"AD",THEDT))
if 'THEDT!(THEDT>STOP)!(OOUT)
QUIT
Begin DoDot:1
+4 SET MAGIEN=0
+5 FOR
SET MAGIEN=$ORDER(^MAGD(2006.575,"AD",THEDT,MAGIEN))
if 'MAGIEN
QUIT
Begin DoDot:2
+6 IF '$DATA(^MAGD(2006.575,MAGIEN,0))
KILL ^MAGD(2006.575,"AD",THEDT,MAGIEN)
+7 IF $DATA(^MAGD(2006.575,MAGIEN,"TYPE"))
IF $EXTRACT($PIECE(^MAGD(2006.575,MAGIEN,"TYPE"),"^"),1,3)'="CON"
QUIT
+8 IF 'FIRST
SET PREV=MAGIEN
SET FIRST=1
+9 DO SET
+10 QUIT
End DoDot:2
+11 QUIT
End DoDot:1
+12 QUIT
+13 ;
SETPREV ;
+1 SET PREV=MAGIEN
SET PREVS=$GET(SUID)
+2 QUIT
+3 ;
SETMAG ;
+1 SET FIRST=MAGIEN
SET FIRSTS=$GET(SUID)
SET MAGIEN=PREV
SET SUID=$GET(PREVS)
+2 SET PREV=FIRST
SET PREVS=FIRSTS
+3 QUIT
+4 ;
CHKPREV ;
+1 SET OUT=1
NEW STATUS
+2 IF '$DATA(MAGFIX(PREV))
DO SETMAG
GOTO SET
+3 SET STATUS=$SELECT($GET(MAGFIX(PREV))="D":"deleted",1:"corrected")
+4 WRITE !,"Previous entry has been "_STATUS_".",$CHAR(7)
+5 GOTO SET
+6 QUIT
