MAGDQR08.m

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 ---MAGDQR08   9245     printed  Apr 23, 2025@18:15:28                                                                                                                                                                                                    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