MAGDQR08 ;WOIFO/EdM,MLH,BT - Cross-References for Query/Retrieve ; 27 Nov 2012 12:58 PM
;;3.0;IMAGING;**54,118,138**;Mar 19, 2002;Build 5380;Sep 03, 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
;
UIDS(REQ,T,UID,PRMUID,ANY,OK,UIDS) ; Overflow from MAGDQR02
N FATAL,I,P,V,IDX,PAT,PAT0
S FATAL=0
S PRMUID=$G(PRMUID)
F I=20:1:23 K ^TMP("MAG",$J,"QR",I)
S T=$$STUIDTAG^MAGDQR00,(ANY,PAT)=0
;
S P=""
F S P=$O(REQ(T,P)) Q:P="" D:REQ(T,P)'=""
. S ANY=1 K ^TMP("MAG",$J,"QR",7)
. ; old DB structure
. S I=$$MATCHD^MAGDQR03(REQ(T,P),"^MAG(2005,""P"",LOOP)","^TMP(""MAG"",$J,""QR"",7,LOOP)")
. S V=""
. F S V=$O(^TMP("MAG",$J,"QR",7,V)) Q:V="" D
. . S PAT=""
. . S I=""
. . F S I=$O(^MAG(2005,"P",V,I)) Q:I="" D
. . . N C,X
. . . ; If this image has a parent,
. . . ; its UID is an image UID and not a study UID
. . . S X=$G(^MAG(2005,I,0)),PAT0=$P(X,"^",7)
. . . S IDX=$G(^MAG(2005,I,2))\2_" "_PAT0
. . . D:PAT0
. . . . I PAT="" S PAT=PAT0 Q
. . . . Q:PRMUID=1
. . . . S:PAT'=PAT0 PAT=-1 ; Duplicate UID if different patient...
. . . . Q
. . . Q:$P(X,"^",10)
. . . S UID=1,^TMP("MAG",$J,"QR",20,I)=""
. . . S C=0 F S C=$O(^MAG(2005,I,1,C)) Q:'C D
. . . . S X=+$P($G(^MAG(2005,I,1,C,0)),"^",1)
. . . . S:X ^TMP("MAG",$J,"QR",21,X)=""
. . . . Q
. . . Q
. . Q
. ; new DB structure
. S I=$$MATCHD^MAGDQR03(REQ(T,P),"^MAGV(2005.62,""B"",LOOP)","^TMP(""MAG"",$J,""QR"",27,LOOP)")
. S V=""
. F S V=$O(^TMP("MAG",$J,"QR",27,V)) Q:V="" D Q:PAT<0
. . S PAT=""
. . S I="" F S I=$O(^MAGV(2005.62,"B",V,I)) Q:I="" D Q:PAT<0
. . . Q:$P($G(^MAGV(2005.62,I,5)),"^",2)="I" ; study marked inaccessible
. . . N PROCIX,PATIX
. . . S PROCIX=$P($G(^MAGV(2005.62,I,6)),"^",1) Q:'PROCIX
. . . S PATIX=$P($G(^MAGV(2005.61,PROCIX,6)),"^",1) Q:'PATIX
. . . S PAT0=$P($G(^MAGV(2005.6,PATIX,0)),"^",1) Q:PAT0=""
. . . S:PAT="" PAT=PAT0
. . . I PRMUID'=1,PAT'=PAT0 S PAT=-1 Q ; duplicate UID if different patient...
. . . S UID=1,^TMP("MAG",$J,"QR",20,"N"_I)=""
. . . Q
. . Q
. Q
;
D:PAT<0
. I (PRMUID=2)!(PRMUID=3) S PRMUID(T)="" Q
. D ERR^MAGDQRUE("Duplicate Study UID (tag 0020,000D)")
. S FATAL=1
. Q
I FATAL D ERRSAV^MAGDQRUE Q
;
S OK=1,X="Study Series Image",UIDS=""
F T=23,22 S I="" F S I=$O(^TMP("MAG",$J,"QR",T,I)) Q:I="" D Q:'OK
. F P=22,21 D
. . Q:P'<T Q:'$D(^TMP("MAG",$J,"QR",P)) Q:$D(^TMP("MAG",$J,"QR",P,I))
. . S OK=0 S:UIDS'="" UIDS=UIDS=UIDS_", "
. . S UIDS=UIDS_$P(X," ",P)_"/"_$P(X," ",T)
. . Q
. Q
;
S T=0 S:OK T=1
F I=23,22,20 D:T
. Q:'$D(^TMP("MAG",$J,"QR",I))
. M ^TMP("MAG",$J,"QR",8)=^TMP("MAG",$J,"QR",I)
. S T=0
. Q
;
F I=20:1:23,27 K ^TMP("MAG",$J,"QR",I)
Q
;
PRUNE(RESULT) ; Remove duplicate UIDs based on PRMUID
; PRMUID must be defined before calling this procedure
; PRMUID : Duplicate UID Handling parameter
; 0 : Error if there is duplicate UID (Error Handled outside this procedure)
; 1 : All (Duplicate is not an error so this proc won't be called)
; 2 : Keep UID with the oldest image saved date, delete the rest (handled in this procedure)
; 3 : Keep UID with the latest image saved date, delete the rest (handled in this procedure)
;
I PRMUID'=2,PRMUID'=3 Q
;
; Based on Study UID and PRMUID, generate KEEP array containing Header Records to keep
N KEEP
D KEEPHDR(.KEEP)
;
; Based on what records to keep, generate HDR containing all headers with remove/keep indicator
N HDR
D SAVHDR(.KEEP,.HDR)
;
; Based on HDR indicators, remove or keep Study UID, return number of records removed
N KILLCNT
S KILLCNT=$$REMDUP(.HDR)
;
; Update the Sub File 2006.57321 Header's highest IEN and # of entries
D UPDSUBHD(RESULT,KILLCNT)
Q
;
REMDUP(HDR) ; Based on HDR array, remove or keep Study UID records, return number of records removed
N NEWCNT,KILLCNT
S NEWCNT=0 ;Result # counter
S KILLCNT=0 ;Number of killed records
N HDRRECNO
S HDRRECNO=0
;
F S HDRRECNO=$O(HDR(HDRRECNO)) Q:'HDRRECNO D
. ; if this header to delete, delete the rest of the group records
. I HDR(HDRRECNO)=0 S KILLCNT=KILLCNT+$$DELSUB(RESULT,HDRRECNO) Q
. ; if this header to keep, update the "Result # " with the new counter
. D UPDHDREC(RESULT,HDRRECNO,.NEWCNT)
;
Q KILLCNT
;
SAVHDR(KEEP,HDR) ; Based on what to keep, generate HDR array contains records to keep and to remove
N STUIDTAG,HDRTAG
S STUIDTAG=$$STUIDTAG^MAGDQR00
S HDRTAG=$$HDRTAG^MAGDQR00
;
N STUIDREC,STUDYUID,HDRRECNO
S STUIDREC=0
F S STUIDREC=$O(^MAGDQR(2006.5732,RESULT,1,"B",STUIDTAG,STUIDREC)) Q:'STUIDREC D
. S STUDYUID=$P(^MAGDQR(2006.5732,RESULT,1,STUIDREC,0),U,2)
. S HDRRECNO=$O(^MAGDQR(2006.5732,RESULT,1,"B",HDRTAG,STUIDREC),-1)
. S HDR(HDRRECNO)=$D(KEEP(STUDYUID,HDRRECNO))
Q
;
KEEPHDR(KEEP) ; Based on PRMUID, get "the oldest/latest date" records to keep
N ORD
S ORD=$S(PRMUID=2:1,1:-1)
;
N STUDYUID,IMGSAVDT,HDRRECNO
S STUDYUID=""
F S STUDYUID=$O(^TMP("MAG",$J,"QR",99,STUDYUID)) Q:STUDYUID="" D
. S IMGSAVDT=$O(^TMP("MAG",$J,"QR",99,STUDYUID,""),ORD) Q:IMGSAVDT=""
. S HDRRECNO=$O(^TMP("MAG",$J,"QR",99,STUDYUID,IMGSAVDT,""))
. S KEEP(STUDYUID,HDRRECNO)=""
. Q
Q
;
DELSUB(RESULT,HDRRECNO) ; Delete Sub File (2006.57321) record group including indices
; The Header Information such as Highest IEN and Counter will be updated at the end (UPDSUBHD)
N HDRTAG
S HDRTAG=$$HDRTAG^MAGDQR00
N DELCNT,RECNO,TAG,QUIT
S (QUIT,DELCNT)=0
S RECNO=HDRRECNO-1
;
F S RECNO=$O(^MAGDQR(2006.5732,RESULT,1,RECNO)) Q:'RECNO D Q:QUIT
. S TAG=$P(^MAGDQR(2006.5732,RESULT,1,RECNO,0),U)
. I TAG=HDRTAG,RECNO'=HDRRECNO S QUIT=1 Q
. K ^MAGDQR(2006.5732,RESULT,1,RECNO)
. K ^MAGDQR(2006.5732,RESULT,1,"B",TAG,RECNO)
. S DELCNT=DELCNT+1
;
Q DELCNT
;
UPDHDREC(RESULT,R1,NEWCNT) ; Update Header Result # record with a new counter
N TAGVAL
S NEWCNT=NEWCNT+1
S TAGVAL="Result # "_NEWCNT
S ^MAGDQR(2006.5732,RESULT,1,R1,0)=$$HDRTAG^MAGDQR00_U_TAGVAL
Q
;
UPDSUBHD(RESULT,KILLCNT) ; Update the Sub File 2006.57321 Header
N HDR,LSTIEN,LSTRECNO,CNT
S HDR=$G(^MAGDQR(2006.5732,RESULT,1,0))
S LSTIEN=$P(HDR,U,3)
S LSTRECNO=$O(^MAGDQR(2006.5732,RESULT,1," "),-1)
S:LSTRECNO<LSTIEN LSTIEN=$O(^MAGDQR(2006.5732,RESULT,1,LSTIEN),-1)
S CNT=$P(HDR,U,4)-KILLCNT
S ^MAGDQR(2006.5732,RESULT,1,0)="TAG"_U_"2006.57321"_U_LSTIEN_U_CNT
Q
;
ACCNUM(IMAGE) ; Calculate Accession Number for Image
N GMRCPTR,PARENT,TIUPTR,X
S X=$G(^MAG(2005,IMAGE,2)),PARENT=+$P(X,"^",6),TIUPTR=$P(X,"^",7)
I PARENT'=8925,PARENT'=2006.5839 Q ""
Q:'TIUPTR ""
S GMRCPTR=$$GET1^DIQ(8925,TIUPTR,1405,"I") Q:GMRCPTR'[";GMR(123" "" ; IA # 3268
Q $$GMRCACN^MAGDFCNV(+GMRCPTR)
;
PROCNAM(IMAGE) ; Calculate Procedure Name for Image
N PROCPTR,X
S X=$G(^MAG(2005,IMAGE,40)),PROCPTR=$P(X,"^",4) Q:'PROCPTR ""
S X=$G(^MAG(2005.84,PROCPTR,0))
Q $P(X,"^",1)
;
PROCNUM(IMAGE) ; Calculate Procedure Number for Image
N X
S X=$G(^MAG(2005,IMAGE,40))
Q $P(X,"^",4)
;
;
; This routine takes care of two cross-references on the Image File
;
; ^MAG(2005,"CONSULT1",accession,image)=""
; ^MAG(2005,"CONSULT2",procedure,accession,image)=""
;
; DA ---- Image #
; KILL -- flag: 0=SET, 1=KILL
;
X1(DA,KILL) N GP,PA,T0,X
S X=$G(^MAG(2005,IMAGE,2)),PA=+$P(X,"^",6),T0=$P(X,"^",7)
I PA'=8925,PA'=2006.5839 Q
Q:'T0
S GP=$$GET1^DIQ(8925,T0,1405,"I") Q:GP'[";GMR(123"
I KILL K ^MAG(2005,"CONSULT1",$$GMRCACN^MAGDFCNV(+GP),IMAGE) Q
S ^MAG(2005,"CONSULT1",$$GMRCACN^MAGDFCNV(+GP),IMAGE)=""
Q
;
X2(IMAGE,KILL) N CO,GP,PA,PR,T0,X
S X=$G(^MAG(2005,IMAGE,2)),PA=+$P(X,"^",6),T0=$P(X,"^",7)
I PA'=8925,PA'=2006.5839 Q
Q:'T0
S X=$G(^MAG(2005,IMAGE,40)),PR=$P(X,"^",4) Q:'PR
S X=$G(^MAG(2005.84,PR,0)),CO=$P(X,"^",1) Q:CO=""
S GP=$$GET1^DIQ(8925,T0,1405,"I") Q:GP'[";GMR(123"
I KILL K ^MAG(2005,"CONSULT2",CO,$$GMRCACN^MAGDFCNV(+GP),IMAGE) Q
S ^MAG(2005,"CONSULT2",CO,$$GMRCACN^MAGDFCNV(+GP),IMAGE)=""
Q
;
; ============================================================
; To be included in post-init (through TaskMan?):
;
REDO F X="CONSULT1","CONSULT2" K ^MAG(2005,X)
S DA=0 F S DA=$O(^MAG(2005,DA)) Q:'DA D
. D X1(DA,0)
. D X2(DA,0)
. Q
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDQR08 9245 printed Apr 09, 2024@21:01:58 Page 2
MAGDQR08 ;WOIFO/EdM,MLH,BT - Cross-References for Query/Retrieve ; 27 Nov 2012 12:58 PM
+1 ;;3.0;IMAGING;**54,118,138**;Mar 19, 2002;Build 5380;Sep 03, 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 ;
UIDS(REQ,T,UID,PRMUID,ANY,OK,UIDS) ; Overflow from MAGDQR02
+1 NEW FATAL,I,P,V,IDX,PAT,PAT0
+2 SET FATAL=0
+3 SET PRMUID=$GET(PRMUID)
+4 FOR I=20:1:23
KILL ^TMP("MAG",$JOB,"QR",I)
+5 SET T=$$STUIDTAG^MAGDQR00
SET (ANY,PAT)=0
+6 ;
+7 SET P=""
+8 FOR
SET P=$ORDER(REQ(T,P))
if P=""
QUIT
if REQ(T,P)'=""
Begin DoDot:1
+9 SET ANY=1
KILL ^TMP("MAG",$JOB,"QR",7)
+10 ; old DB structure
+11 SET I=$$MATCHD^MAGDQR03(REQ(T,P),"^MAG(2005,""P"",LOOP)","^TMP(""MAG"",$J,""QR"",7,LOOP)")
+12 SET V=""
+13 FOR
SET V=$ORDER(^TMP("MAG",$JOB,"QR",7,V))
if V=""
QUIT
Begin DoDot:2
+14 SET PAT=""
+15 SET I=""
+16 FOR
SET I=$ORDER(^MAG(2005,"P",V,I))
if I=""
QUIT
Begin DoDot:3
+17 NEW C,X
+18 ; If this image has a parent,
+19 ; its UID is an image UID and not a study UID
+20 SET X=$GET(^MAG(2005,I,0))
SET PAT0=$PIECE(X,"^",7)
+21 SET IDX=$GET(^MAG(2005,I,2))\2_" "_PAT0
+22 if PAT0
Begin DoDot:4
+23 IF PAT=""
SET PAT=PAT0
QUIT
+24 if PRMUID=1
QUIT
+25 ; Duplicate UID if different patient...
if PAT'=PAT0
SET PAT=-1
+26 QUIT
End DoDot:4
+27 if $PIECE(X,"^",10)
QUIT
+28 SET UID=1
SET ^TMP("MAG",$JOB,"QR",20,I)=""
+29 SET C=0
FOR
SET C=$ORDER(^MAG(2005,I,1,C))
if 'C
QUIT
Begin DoDot:4
+30 SET X=+$PIECE($GET(^MAG(2005,I,1,C,0)),"^",1)
+31 if X
SET ^TMP("MAG",$JOB,"QR",21,X)=""
+32 QUIT
End DoDot:4
+33 QUIT
End DoDot:3
+34 QUIT
End DoDot:2
+35 ; new DB structure
+36 SET I=$$MATCHD^MAGDQR03(REQ(T,P),"^MAGV(2005.62,""B"",LOOP)","^TMP(""MAG"",$J,""QR"",27,LOOP)")
+37 SET V=""
+38 FOR
SET V=$ORDER(^TMP("MAG",$JOB,"QR",27,V))
if V=""
QUIT
Begin DoDot:2
+39 SET PAT=""
+40 SET I=""
FOR
SET I=$ORDER(^MAGV(2005.62,"B",V,I))
if I=""
QUIT
Begin DoDot:3
+41 ; study marked inaccessible
if $PIECE($GET(^MAGV(2005.62,I,5)),"^",2)="I"
QUIT
+42 NEW PROCIX,PATIX
+43 SET PROCIX=$PIECE($GET(^MAGV(2005.62,I,6)),"^",1)
if 'PROCIX
QUIT
+44 SET PATIX=$PIECE($GET(^MAGV(2005.61,PROCIX,6)),"^",1)
if 'PATIX
QUIT
+45 SET PAT0=$PIECE($GET(^MAGV(2005.6,PATIX,0)),"^",1)
if PAT0=""
QUIT
+46 if PAT=""
SET PAT=PAT0
+47 ; duplicate UID if different patient...
IF PRMUID'=1
IF PAT'=PAT0
SET PAT=-1
QUIT
+48 SET UID=1
SET ^TMP("MAG",$JOB,"QR",20,"N"_I)=""
+49 QUIT
End DoDot:3
if PAT<0
QUIT
+50 QUIT
End DoDot:2
if PAT<0
QUIT
+51 QUIT
End DoDot:1
+52 ;
+53 if PAT<0
Begin DoDot:1
+54 IF (PRMUID=2)!(PRMUID=3)
SET PRMUID(T)=""
QUIT
+55 DO ERR^MAGDQRUE("Duplicate Study UID (tag 0020,000D)")
+56 SET FATAL=1
+57 QUIT
End DoDot:1
+58 IF FATAL
DO ERRSAV^MAGDQRUE
QUIT
+59 ;
+60 SET OK=1
SET X="Study Series Image"
SET UIDS=""
+61 FOR T=23,22
SET I=""
FOR
SET I=$ORDER(^TMP("MAG",$JOB,"QR",T,I))
if I=""
QUIT
Begin DoDot:1
+62 FOR P=22,21
Begin DoDot:2
+63 if P'<T
QUIT
if '$DATA(^TMP("MAG",$JOB,"QR",P))
QUIT
if $DATA(^TMP("MAG",$JOB,"QR",P,I))
QUIT
+64 SET OK=0
if UIDS'=""
SET UIDS=UIDS=UIDS_", "
+65 SET UIDS=UIDS_$PIECE(X," ",P)_"/"_$PIECE(X," ",T)
+66 QUIT
End DoDot:2
+67 QUIT
End DoDot:1
if 'OK
QUIT
+68 ;
+69 SET T=0
if OK
SET T=1
+70 FOR I=23,22,20
if T
Begin DoDot:1
+71 if '$DATA(^TMP("MAG",$JOB,"QR",I))
QUIT
+72 MERGE ^TMP("MAG",$JOB,"QR",8)=^TMP("MAG",$JOB,"QR",I)
+73 SET T=0
+74 QUIT
End DoDot:1
+75 ;
+76 FOR I=20:1:23,27
KILL ^TMP("MAG",$JOB,"QR",I)
+77 QUIT
+78 ;
PRUNE(RESULT) ; Remove duplicate UIDs based on PRMUID
+1 ; PRMUID must be defined before calling this procedure
+2 ; PRMUID : Duplicate UID Handling parameter
+3 ; 0 : Error if there is duplicate UID (Error Handled outside this procedure)
+4 ; 1 : All (Duplicate is not an error so this proc won't be called)
+5 ; 2 : Keep UID with the oldest image saved date, delete the rest (handled in this procedure)
+6 ; 3 : Keep UID with the latest image saved date, delete the rest (handled in this procedure)
+7 ;
+8 IF PRMUID'=2
IF PRMUID'=3
QUIT
+9 ;
+10 ; Based on Study UID and PRMUID, generate KEEP array containing Header Records to keep
+11 NEW KEEP
+12 DO KEEPHDR(.KEEP)
+13 ;
+14 ; Based on what records to keep, generate HDR containing all headers with remove/keep indicator
+15 NEW HDR
+16 DO SAVHDR(.KEEP,.HDR)
+17 ;
+18 ; Based on HDR indicators, remove or keep Study UID, return number of records removed
+19 NEW KILLCNT
+20 SET KILLCNT=$$REMDUP(.HDR)
+21 ;
+22 ; Update the Sub File 2006.57321 Header's highest IEN and # of entries
+23 DO UPDSUBHD(RESULT,KILLCNT)
+24 QUIT
+25 ;
REMDUP(HDR) ; Based on HDR array, remove or keep Study UID records, return number of records removed
+1 NEW NEWCNT,KILLCNT
+2 ;Result # counter
SET NEWCNT=0
+3 ;Number of killed records
SET KILLCNT=0
+4 NEW HDRRECNO
+5 SET HDRRECNO=0
+6 ;
+7 FOR
SET HDRRECNO=$ORDER(HDR(HDRRECNO))
if 'HDRRECNO
QUIT
Begin DoDot:1
+8 ; if this header to delete, delete the rest of the group records
+9 IF HDR(HDRRECNO)=0
SET KILLCNT=KILLCNT+$$DELSUB(RESULT,HDRRECNO)
QUIT
+10 ; if this header to keep, update the "Result # " with the new counter
+11 DO UPDHDREC(RESULT,HDRRECNO,.NEWCNT)
End DoDot:1
+12 ;
+13 QUIT KILLCNT
+14 ;
SAVHDR(KEEP,HDR) ; Based on what to keep, generate HDR array contains records to keep and to remove
+1 NEW STUIDTAG,HDRTAG
+2 SET STUIDTAG=$$STUIDTAG^MAGDQR00
+3 SET HDRTAG=$$HDRTAG^MAGDQR00
+4 ;
+5 NEW STUIDREC,STUDYUID,HDRRECNO
+6 SET STUIDREC=0
+7 FOR
SET STUIDREC=$ORDER(^MAGDQR(2006.5732,RESULT,1,"B",STUIDTAG,STUIDREC))
if 'STUIDREC
QUIT
Begin DoDot:1
+8 SET STUDYUID=$PIECE(^MAGDQR(2006.5732,RESULT,1,STUIDREC,0),U,2)
+9 SET HDRRECNO=$ORDER(^MAGDQR(2006.5732,RESULT,1,"B",HDRTAG,STUIDREC),-1)
+10 SET HDR(HDRRECNO)=$DATA(KEEP(STUDYUID,HDRRECNO))
End DoDot:1
+11 QUIT
+12 ;
KEEPHDR(KEEP) ; Based on PRMUID, get "the oldest/latest date" records to keep
+1 NEW ORD
+2 SET ORD=$SELECT(PRMUID=2:1,1:-1)
+3 ;
+4 NEW STUDYUID,IMGSAVDT,HDRRECNO
+5 SET STUDYUID=""
+6 FOR
SET STUDYUID=$ORDER(^TMP("MAG",$JOB,"QR",99,STUDYUID))
if STUDYUID=""
QUIT
Begin DoDot:1
+7 SET IMGSAVDT=$ORDER(^TMP("MAG",$JOB,"QR",99,STUDYUID,""),ORD)
if IMGSAVDT=""
QUIT
+8 SET HDRRECNO=$ORDER(^TMP("MAG",$JOB,"QR",99,STUDYUID,IMGSAVDT,""))
+9 SET KEEP(STUDYUID,HDRRECNO)=""
+10 QUIT
End DoDot:1
+11 QUIT
+12 ;
DELSUB(RESULT,HDRRECNO) ; Delete Sub File (2006.57321) record group including indices
+1 ; The Header Information such as Highest IEN and Counter will be updated at the end (UPDSUBHD)
+2 NEW HDRTAG
+3 SET HDRTAG=$$HDRTAG^MAGDQR00
+4 NEW DELCNT,RECNO,TAG,QUIT
+5 SET (QUIT,DELCNT)=0
+6 SET RECNO=HDRRECNO-1
+7 ;
+8 FOR
SET RECNO=$ORDER(^MAGDQR(2006.5732,RESULT,1,RECNO))
if 'RECNO
QUIT
Begin DoDot:1
+9 SET TAG=$PIECE(^MAGDQR(2006.5732,RESULT,1,RECNO,0),U)
+10 IF TAG=HDRTAG
IF RECNO'=HDRRECNO
SET QUIT=1
QUIT
+11 KILL ^MAGDQR(2006.5732,RESULT,1,RECNO)
+12 KILL ^MAGDQR(2006.5732,RESULT,1,"B",TAG,RECNO)
+13 SET DELCNT=DELCNT+1
End DoDot:1
if QUIT
QUIT
+14 ;
+15 QUIT DELCNT
+16 ;
UPDHDREC(RESULT,R1,NEWCNT) ; Update Header Result # record with a new counter
+1 NEW TAGVAL
+2 SET NEWCNT=NEWCNT+1
+3 SET TAGVAL="Result # "_NEWCNT
+4 SET ^MAGDQR(2006.5732,RESULT,1,R1,0)=$$HDRTAG^MAGDQR00_U_TAGVAL
+5 QUIT
+6 ;
UPDSUBHD(RESULT,KILLCNT) ; Update the Sub File 2006.57321 Header
+1 NEW HDR,LSTIEN,LSTRECNO,CNT
+2 SET HDR=$GET(^MAGDQR(2006.5732,RESULT,1,0))
+3 SET LSTIEN=$PIECE(HDR,U,3)
+4 SET LSTRECNO=$ORDER(^MAGDQR(2006.5732,RESULT,1," "),-1)
+5 if LSTRECNO<LSTIEN
SET LSTIEN=$ORDER(^MAGDQR(2006.5732,RESULT,1,LSTIEN),-1)
+6 SET CNT=$PIECE(HDR,U,4)-KILLCNT
+7 SET ^MAGDQR(2006.5732,RESULT,1,0)="TAG"_U_"2006.57321"_U_LSTIEN_U_CNT
+8 QUIT
+9 ;
ACCNUM(IMAGE) ; Calculate Accession Number for Image
+1 NEW GMRCPTR,PARENT,TIUPTR,X
+2 SET X=$GET(^MAG(2005,IMAGE,2))
SET PARENT=+$PIECE(X,"^",6)
SET TIUPTR=$PIECE(X,"^",7)
+3 IF PARENT'=8925
IF PARENT'=2006.5839
QUIT ""
+4 if 'TIUPTR
QUIT ""
+5 ; IA # 3268
SET GMRCPTR=$$GET1^DIQ(8925,TIUPTR,1405,"I")
if GMRCPTR'[";GMR(123"
QUIT ""
+6 QUIT $$GMRCACN^MAGDFCNV(+GMRCPTR)
+7 ;
PROCNAM(IMAGE) ; Calculate Procedure Name for Image
+1 NEW PROCPTR,X
+2 SET X=$GET(^MAG(2005,IMAGE,40))
SET PROCPTR=$PIECE(X,"^",4)
if 'PROCPTR
QUIT ""
+3 SET X=$GET(^MAG(2005.84,PROCPTR,0))
+4 QUIT $PIECE(X,"^",1)
+5 ;
PROCNUM(IMAGE) ; Calculate Procedure Number for Image
+1 NEW X
+2 SET X=$GET(^MAG(2005,IMAGE,40))
+3 QUIT $PIECE(X,"^",4)
+4 ;
+5 ;
+6 ; This routine takes care of two cross-references on the Image File
+7 ;
+8 ; ^MAG(2005,"CONSULT1",accession,image)=""
+9 ; ^MAG(2005,"CONSULT2",procedure,accession,image)=""
+10 ;
+11 ; DA ---- Image #
+12 ; KILL -- flag: 0=SET, 1=KILL
+13 ;
X1(DA,KILL) NEW GP,PA,T0,X
+1 SET X=$GET(^MAG(2005,IMAGE,2))
SET PA=+$PIECE(X,"^",6)
SET T0=$PIECE(X,"^",7)
+2 IF PA'=8925
IF PA'=2006.5839
QUIT
+3 if 'T0
QUIT
+4 SET GP=$$GET1^DIQ(8925,T0,1405,"I")
if GP'[";GMR(123"
QUIT
+5 IF KILL
KILL ^MAG(2005,"CONSULT1",$$GMRCACN^MAGDFCNV(+GP),IMAGE)
QUIT
+6 SET ^MAG(2005,"CONSULT1",$$GMRCACN^MAGDFCNV(+GP),IMAGE)=""
+7 QUIT
+8 ;
X2(IMAGE,KILL) NEW CO,GP,PA,PR,T0,X
+1 SET X=$GET(^MAG(2005,IMAGE,2))
SET PA=+$PIECE(X,"^",6)
SET T0=$PIECE(X,"^",7)
+2 IF PA'=8925
IF PA'=2006.5839
QUIT
+3 if 'T0
QUIT
+4 SET X=$GET(^MAG(2005,IMAGE,40))
SET PR=$PIECE(X,"^",4)
if 'PR
QUIT
+5 SET X=$GET(^MAG(2005.84,PR,0))
SET CO=$PIECE(X,"^",1)
if CO=""
QUIT
+6 SET GP=$$GET1^DIQ(8925,T0,1405,"I")
if GP'[";GMR(123"
QUIT
+7 IF KILL
KILL ^MAG(2005,"CONSULT2",CO,$$GMRCACN^MAGDFCNV(+GP),IMAGE)
QUIT
+8 SET ^MAG(2005,"CONSULT2",CO,$$GMRCACN^MAGDFCNV(+GP),IMAGE)=""
+9 QUIT
+10 ;
+11 ; ============================================================
+12 ; To be included in post-init (through TaskMan?):
+13 ;
REDO FOR X="CONSULT1","CONSULT2"
KILL ^MAG(2005,X)
+1 SET DA=0
FOR
SET DA=$ORDER(^MAG(2005,DA))
if 'DA
QUIT
Begin DoDot:1
+2 DO X1(DA,0)
+3 DO X2(DA,0)
+4 QUIT
End DoDot:1
+5 QUIT
