MAGDLBAA ;WOIFO/LB/JSL/SAF - Routine to move failed dicom images to ^MAG(2006.575 ; 05/18/2007 11:23
;;3.0;IMAGING;**11,51,54,53,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
MOVE ;called from MAGDIR1 to move entries not matching Radiology case #.
;Not done thru FM because the system should be independent.
;These variable are needed to be defined before using this routine:
;PIDCHECK, FIRSTDCM, IMGSVC, MIDCM, MACHID,ACNUMB, CASENUMB, PNAMEDCM, PID
;MODALITY, CASETEXT
N DATE,REASON,ENTRY,IEN,NIEN,ORIG,DCMPNME,CASE,CASENUM,PATIENT,RESULT
S DATE=$$NOW^XLFDT()\1,RESULT=0
;
; if the entry already exists in file 2006.575, skip it
S MACHID=$G(MACHID,"A")
I $$EXIST(.RESULT,FROMPATH,MACHID,LOCATION) D Q
. D REMOAFX(.RESULT,MACHID,LOCATION,STUDYUID)
. Q
;
;ADD ENTRY
L +^MAGD(2006.575,0):1E9 ; Background process MUST wait
S X=$G(^MAGD(2006.575,0))
S $P(X,"^",1,2)="DICOM FAILED IMAGES^2006.575"
S IEN=$O(^MAGD(2006.575," "),-1)+1,$P(X,"^",3)=IEN
S $P(X,"^",4)=$P(X,"^",4)+1 ; # entries
S ^MAGD(2006.575,0)=X
;
S REASON=$P(PIDCHECK,",",2)
S PATIENT=LASTDCM_","_FIRSTDCM_$S($L(MIDCM)>0:" "_MIDCM,1:"")
; PNAMEDCM usually contains an "^" between last & first name
; CHANGE ^ TO ~
S CASE=$TR(ACNUMB,"^","~"),CASENUM=$TR(CASENUMB,"^","~")
S DCMPNME=$TR(PNAMEDCM,"^","~")
S ^MAGD(2006.575,IEN,0)=FROMPATH_"^"_REASON_"^"_PID_"^"_PATIENT_"^"_DCMPNME
S ^MAGD(2006.575,IEN,1)=CASE_"^"_CASENUM_"^"_DATE_"^"_MACHID_"^"_LOCATION
S ^MAGD(2006.575,IEN,"AIUID")=$G(IMAGEUID)
S ^MAGD(2006.575,IEN,"ASUID")=STUDYUID
;MOD for IHS multiple Chart ID (i.e. Chawktaw)
S ^MAGD(2006.575,IEN,"AMFG")=$G(INSTNAME)_"^"_$G(ROWS)_"^"_$G(COLUMNS)_"^"_$G(OFFSET)_"^"_$G(MODIEN)_"^"_$G(MODALITY)_"^"_$$UP^MAGDFCNV($G(MFGR))_"^"_$$UP^MAGDFCNV($G(MODEL))_"^"_INSTLOC ;P123
S ^MAGD(2006.575,IEN,"ACSTXT")=$G(CASETEXT)
; Image type can be RAD, MEDICINE, SURGERY, etc.
S ^MAGD(2006.575,IEN,"TYPE")=$G(IMGSVC)
;Setting xrefs
S ^MAGD(2006.575,"B",FROMPATH,IEN)=""
; Clean up---no longer need this cross reference
K ^MAGD(2006.575,"D") ; Used for Consults only
L -^MAGD(2006.575,0)
;
;The following xref ("F") will be set on the 1st entry having a unique
;STUDYUID. The remaining entries with the same # will be added
;to the RELATED IMAGES multiple field for the entry that set the
;F xref.
S ORIG=0
I '$D(^MAGD(2006.575,"F",LOCATION,STUDYUID)) D Q ; Quit if 1st entry
. S ^MAGD(2006.575,"F",LOCATION,STUDYUID,IEN)=""
. Q
S ORIG=$O(^MAGD(2006.575,"F",LOCATION,STUDYUID,0))
Q:'ORIG
I ORIG'=IEN D
. I '$D(^MAGD(2006.575,ORIG,"RLATE",0)) D
. . S ^MAGD(2006.575,ORIG,"RLATE",0)="^2006.57526PA^^"
. S NIEN=$P(^MAGD(2006.575,ORIG,"RLATE",0),"^",3),NIEN=NIEN+1
. S $P(^MAGD(2006.575,ORIG,"RLATE",0),"^",3)=NIEN ; #next ien entry
. S $P(^MAGD(2006.575,ORIG,"RLATE",0),"^",4)=$P(^MAGD(2006.575,ORIG,"RLATE",0),"^",4)+1 ; #record for multiple field
. S ^MAGD(2006.575,ORIG,"RLATE",NIEN,0)=IEN
. S ^MAGD(2006.575,ORIG,"RLATE","B",IEN,NIEN)=""
. Q
Q
;
EXIST(RESULT,PATH,MACHINE,SITE) ; if it exist don't add it.
N IEN,NODE1
S RESULT=0
I $D(^MAGD(2006.575,"B",PATH)) D
. S IEN=$O(^MAGD(2006.575,"B",PATH,"")) I 'IEN S RESULT=0 Q
. I '$D(^MAGD(2006.575,+IEN)) S RESULT=0 Q
. S NODE1=$G(^MAGD(2006.575,IEN,1))
. I $P(NODE1,"^",4)'=MACHINE S RESULT=0 Q
. I $P(NODE1,"^",5)'=SITE S RESULT=0 Q
. S RESULT=IEN
. Q
Q RESULT
REMOAFX(IEN,MACHINE,SITE,STUDY) ; Remove AFX cross reference.
N PENTRY
;IEN is the result of the call to line tag EXIST.
; The AFX cross reference governs what needs processing.
I $D(^MAGD(2006.575,"AFX",SITE,MACHINE,IEN)) D Q
. S $P(^MAGD(2006.575,IEN,"FIXD"),"^")=0
. K ^MAGD(2006.575,"AFX",SITE,MACHINE,IEN)
. Q
;may be a child entry check the 'F' cross reference to find the parent.
S PENTRY=$O(^MAGD(2006.575,"F",SITE,STUDY,0))
Q:'$D(^MAGD(2006.575,+PENTRY,0))
;is it a child entry check the multiple 'b' cross reference
I $D(^MAGD(2006.575,PENTRY,"RELATE",0)),$D(^MAGD(2006.575,PENTRY,"B",IEN)) D
. I $D(^MAGD(2006.575,"AFX",SITE,MACHINE,PENTRY)) D
. . K ^MAGD(2006.575,"AFX",SITE,MACHINE,PENTRY)
. . S $P(^MAGD(2006.575,PENTRY,"FIXD"),"^")=0
. . Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDLBAA 5210 printed Dec 13, 2024@02:00:40 Page 2
MAGDLBAA ;WOIFO/LB/JSL/SAF - Routine to move failed dicom images to ^MAG(2006.575 ; 05/18/2007 11:23
+1 ;;3.0;IMAGING;**11,51,54,53,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
MOVE ;called from MAGDIR1 to move entries not matching Radiology case #.
+1 ;Not done thru FM because the system should be independent.
+2 ;These variable are needed to be defined before using this routine:
+3 ;PIDCHECK, FIRSTDCM, IMGSVC, MIDCM, MACHID,ACNUMB, CASENUMB, PNAMEDCM, PID
+4 ;MODALITY, CASETEXT
+5 NEW DATE,REASON,ENTRY,IEN,NIEN,ORIG,DCMPNME,CASE,CASENUM,PATIENT,RESULT
+6 SET DATE=$$NOW^XLFDT()\1
SET RESULT=0
+7 ;
+8 ; if the entry already exists in file 2006.575, skip it
+9 SET MACHID=$GET(MACHID,"A")
+10 IF $$EXIST(.RESULT,FROMPATH,MACHID,LOCATION)
Begin DoDot:1
+11 DO REMOAFX(.RESULT,MACHID,LOCATION,STUDYUID)
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 ;ADD ENTRY
+15 ; Background process MUST wait
LOCK +^MAGD(2006.575,0):1E9
+16 SET X=$GET(^MAGD(2006.575,0))
+17 SET $PIECE(X,"^",1,2)="DICOM FAILED IMAGES^2006.575"
+18 SET IEN=$ORDER(^MAGD(2006.575," "),-1)+1
SET $PIECE(X,"^",3)=IEN
+19 ; # entries
SET $PIECE(X,"^",4)=$PIECE(X,"^",4)+1
+20 SET ^MAGD(2006.575,0)=X
+21 ;
+22 SET REASON=$PIECE(PIDCHECK,",",2)
+23 SET PATIENT=LASTDCM_","_FIRSTDCM_$SELECT($LENGTH(MIDCM)>0:" "_MIDCM,1:"")
+24 ; PNAMEDCM usually contains an "^" between last & first name
+25 ; CHANGE ^ TO ~
+26 SET CASE=$TRANSLATE(ACNUMB,"^","~")
SET CASENUM=$TRANSLATE(CASENUMB,"^","~")
+27 SET DCMPNME=$TRANSLATE(PNAMEDCM,"^","~")
+28 SET ^MAGD(2006.575,IEN,0)=FROMPATH_"^"_REASON_"^"_PID_"^"_PATIENT_"^"_DCMPNME
+29 SET ^MAGD(2006.575,IEN,1)=CASE_"^"_CASENUM_"^"_DATE_"^"_MACHID_"^"_LOCATION
+30 SET ^MAGD(2006.575,IEN,"AIUID")=$GET(IMAGEUID)
+31 SET ^MAGD(2006.575,IEN,"ASUID")=STUDYUID
+32 ;MOD for IHS multiple Chart ID (i.e. Chawktaw)
+33 ;P123
SET ^MAGD(2006.575,IEN,"AMFG")=$GET(INSTNAME)_"^"_$GET(ROWS)_"^"_$GET(COLUMNS)_"^"_$GET(OFFSET)_"^"_$GET(MODIEN)_"^"_$GET(MODALITY)_"^"_$$UP^MAGDFCNV($GET(MFGR))_"^"_$$UP^MAGDFCNV($GET(MODEL))_"^"_INSTLOC
+34 SET ^MAGD(2006.575,IEN,"ACSTXT")=$GET(CASETEXT)
+35 ; Image type can be RAD, MEDICINE, SURGERY, etc.
+36 SET ^MAGD(2006.575,IEN,"TYPE")=$GET(IMGSVC)
+37 ;Setting xrefs
+38 SET ^MAGD(2006.575,"B",FROMPATH,IEN)=""
+39 ; Clean up---no longer need this cross reference
+40 ; Used for Consults only
KILL ^MAGD(2006.575,"D")
+41 LOCK -^MAGD(2006.575,0)
+42 ;
+43 ;The following xref ("F") will be set on the 1st entry having a unique
+44 ;STUDYUID. The remaining entries with the same # will be added
+45 ;to the RELATED IMAGES multiple field for the entry that set the
+46 ;F xref.
+47 SET ORIG=0
+48 ; Quit if 1st entry
IF '$DATA(^MAGD(2006.575,"F",LOCATION,STUDYUID))
Begin DoDot:1
+49 SET ^MAGD(2006.575,"F",LOCATION,STUDYUID,IEN)=""
+50 QUIT
End DoDot:1
QUIT
+51 SET ORIG=$ORDER(^MAGD(2006.575,"F",LOCATION,STUDYUID,0))
+52 if 'ORIG
QUIT
+53 IF ORIG'=IEN
Begin DoDot:1
+54 IF '$DATA(^MAGD(2006.575,ORIG,"RLATE",0))
Begin DoDot:2
+55 SET ^MAGD(2006.575,ORIG,"RLATE",0)="^2006.57526PA^^"
End DoDot:2
+56 SET NIEN=$PIECE(^MAGD(2006.575,ORIG,"RLATE",0),"^",3)
SET NIEN=NIEN+1
+57 ; #next ien entry
SET $PIECE(^MAGD(2006.575,ORIG,"RLATE",0),"^",3)=NIEN
+58 ; #record for multiple field
SET $PIECE(^MAGD(2006.575,ORIG,"RLATE",0),"^",4)=$PIECE(^MAGD(2006.575,ORIG,"RLATE",0),"^",4)+1
+59 SET ^MAGD(2006.575,ORIG,"RLATE",NIEN,0)=IEN
+60 SET ^MAGD(2006.575,ORIG,"RLATE","B",IEN,NIEN)=""
+61 QUIT
End DoDot:1
+62 QUIT
+63 ;
EXIST(RESULT,PATH,MACHINE,SITE) ; if it exist don't add it.
+1 NEW IEN,NODE1
+2 SET RESULT=0
+3 IF $DATA(^MAGD(2006.575,"B",PATH))
Begin DoDot:1
+4 SET IEN=$ORDER(^MAGD(2006.575,"B",PATH,""))
IF 'IEN
SET RESULT=0
QUIT
+5 IF '$DATA(^MAGD(2006.575,+IEN))
SET RESULT=0
QUIT
+6 SET NODE1=$GET(^MAGD(2006.575,IEN,1))
+7 IF $PIECE(NODE1,"^",4)'=MACHINE
SET RESULT=0
QUIT
+8 IF $PIECE(NODE1,"^",5)'=SITE
SET RESULT=0
QUIT
+9 SET RESULT=IEN
+10 QUIT
End DoDot:1
+11 QUIT RESULT
REMOAFX(IEN,MACHINE,SITE,STUDY) ; Remove AFX cross reference.
+1 NEW PENTRY
+2 ;IEN is the result of the call to line tag EXIST.
+3 ; The AFX cross reference governs what needs processing.
+4 IF $DATA(^MAGD(2006.575,"AFX",SITE,MACHINE,IEN))
Begin DoDot:1
+5 SET $PIECE(^MAGD(2006.575,IEN,"FIXD"),"^")=0
+6 KILL ^MAGD(2006.575,"AFX",SITE,MACHINE,IEN)
+7 QUIT
End DoDot:1
QUIT
+8 ;may be a child entry check the 'F' cross reference to find the parent.
+9 SET PENTRY=$ORDER(^MAGD(2006.575,"F",SITE,STUDY,0))
+10 if '$DATA(^MAGD(2006.575,+PENTRY,0))
QUIT
+11 ;is it a child entry check the multiple 'b' cross reference
+12 IF $DATA(^MAGD(2006.575,PENTRY,"RELATE",0))
IF $DATA(^MAGD(2006.575,PENTRY,"B",IEN))
Begin DoDot:1
+13 IF $DATA(^MAGD(2006.575,"AFX",SITE,MACHINE,PENTRY))
Begin DoDot:2
+14 KILL ^MAGD(2006.575,"AFX",SITE,MACHINE,PENTRY)
+15 SET $PIECE(^MAGD(2006.575,PENTRY,"FIXD"),"^")=0
+16 QUIT
End DoDot:2
End DoDot:1
+17 QUIT
