MAGVCLN ;WOIFO/DAC - File 2005.6X Duplicate Removal Utility ; Feb 22, 2022@21:12:01
;;3.0;IMAGING;**278**;Mar 19, 2002;Build 138
;; Per VA Directive 6402, 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
;
ID ; Identify Duplicates and Unattached Records
N MAGQUIT,DELETE,LINE,MAGSCR,MAGQUE,MAGTEXT,MAGLICNT
S DELETE=0,$P(LINE,"-",30)="-"
D MSG^MAGVCLN1(DELETE,.MAGQUIT) Q:$G(MAGQUIT)
D DEVICE^MAGVCLN1(DELETE,.MAGQUIT,.MAGQUE,.MAGSCR) Q:$G(MAGQUIT)
I $G(MAGQUE) D CONT Q
W !!,"Identifying Duplicates...",!,LINE
D IDDEL(DELETE)
D CONT
Q
DELETE ; Change Status of Duplicates and Unattached Records to INACCESSIBLE
N MAGQ,DELETE,LINE,MAGSCR,MAGQUE,MAGTEXT,MAGLICNT
S DELETE=1,$P(LINE,"-",30)="-"
D MSG^MAGVCLN1(DELETE,.MAGQUIT) Q:$G(MAGQUIT)
D DEVICE^MAGVCLN1(DELETE,.MAGQUIT,.MAGQUE,.MAGSCR) Q:$G(MAGQUIT)
I $G(MAGQUE) D CONT Q
W !!,"Resolving Duplicates...",!,LINE
D IDDEL(DELETE)
D CONT
Q
IDDEL(DELETE,MAGPOST) ; Identify or Set Status of Duplicates and Unattached Records
; DELETE - Set STATUS to Inaccessible, move child records from duplicate to primary
; MAGPOST - Run from Post-Install, send output as message to installer
;
N FILE,MAGXTMP,LINE,MAGTEXT,MAGLICNT
K ^TMP("MAGCLN",$J)
S MAGXTMP="MAGVCLN"
S $P(LINE,"-",50)="-"
S MAGLICNT=1
;
S ^XTMP(MAGXTMP,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^IMAGING CLEANUP LOG"
I $G(MAGPOST) D MSGHDR^MAGVCLN1(.MAGLICNT,DELETE)
;
; Process duplicates
F FILE=2005.6,2005.61,2005.62,2005.63,2005.64,2005.65 D DELETE2(FILE,DELETE)
;
; Process Invalid parent pointers
S MAGTEXT=$S($G(DELETE):"Marking as INACCESSIBLE",1:"Identifying")_" Missing or Invalid Parent Links..."
D OUTPUT^MAGVCLN1(MAGTEXT,3,,$G(MAGPOST)),OUTPUT^MAGVCLN1(LINE,1,0,$G(MAGPOST))
F FILE=2005.61,2005.62,2005.63,2005.64,2005.65 D IDLINKS(FILE,DELETE)
;
S MAGTEXT="** FINISHED **" D OUTPUT^MAGVCLN1(MAGTEXT,3,2,$G(MAGPOST))
;
I $G(MAGPOST) D Q
. D TMPMSG^MAGVCLN1($G(DELETE))
. K ^TMP("MAGVCLN",$J)
;
I '$G(MAGSCR) W !,@IOF
D ^%ZISC
Q
;
IDLINKS(FILE,DELETE) ; Check 2005.6x files broken pointer to parent records
N IEN,PIEN,PFILE,PRIEN,PATIEN,KEY,BKEY,MAGCNT
S MAGTEXT="Searching File "_FILE D OUTPUT^MAGVCLN1(MAGTEXT,2,,$G(MAGPOST))
S IEN=0,MAGCNT=0
S BKEY="" F S BKEY=$O(^MAGV(FILE,"B",BKEY)) Q:BKEY="" D IDLINKS2(FILE,DELETE,BKEY,.MAGCNT)
I '$G(MAGCNT) S MAGTEXT=FILE_" - No missing or invalid pointers identified." D OUTPUT^MAGVCLN1(MAGTEXT,1,0,$G(MAGPOST))
Q
IDLINKS2(FILE,DELETE,BKEY,MAGCNT) ; Get IEN from "B" x-ref
N IEN
S IEN=0 F S IEN=$O(^MAGV(FILE,"B",BKEY,IEN)) Q:'+IEN D
. S KEY=$P($G(^MAGV(FILE,IEN,0)),U,1)
. S PIEN=$P($G(^MAGV(FILE,IEN,6)),U,1)
. I FILE=2005.62 S PATIEN=$P($G(^MAGV(2005.62,IEN,6)),U,3)
. S PFILE=FILE-.01
. I $G(PIEN)="" D DELBP(FILE,KEY,IEN,2,DELETE) Q
. I '$D(^MAGV(PFILE,PIEN,0)) D DELBP(FILE,KEY,IEN,3,DELETE,PIEN) Q
. I FILE=2005.62,$G(PATIEN)="" D DELBP(FILE,KEY,IEN,4,DELETE) Q
. I FILE=2005.62,$G(PATIEN)'="",'$D(^MAGV(2005.6,PATIEN,0)) D DELBP(FILE,KEY,IEN,5,DELETE,PATIEN) Q
Q
DELETE2(FILE,DELETE) ; Check 2005.6x files for B x-ref for duplicate key values
N NAOFS,AOFS,DUPE,NEXTIEN,MAGCNT,PATCHK,PATDIFF,MAGCNT
S KEY="",MAGCNT=0
S MAGTEXT="Searching File "_FILE D OUTPUT^MAGVCLN1(MAGTEXT,2,0,$G(MAGPOST))
F S KEY=$O(^MAGV(FILE,"B",KEY)) Q:KEY="" D
. S (PATCHK,PATDIFF)=""
. S AOFS="",NAOFS="",IEN="",DUPE=""
. F S IEN=$O(^MAGV(FILE,"B",KEY,IEN)) Q:IEN="" D
. . S NEXTIEN=$O(^MAGV(FILE,"B",KEY,IEN))
. . S:NEXTIEN DUPE=1 Q:NEXTIEN=""
. . ; Check 2005.6,2005.61 duplicate - multifield keys
. . I FILE=2005.6 S PATCHK=$$PATCHK(IEN,NEXTIEN) D I 'PATCHK Q
. . . I PATCHK=-1 S PATDIFF=1
. . I FILE=2005.61,'$$PROCCHK(IEN,NEXTIEN) Q
. . S AOF=$$AOF(FILE,IEN) D ADDAOF(IEN,AOF,.AOFS,.NAOFS)
. . S AOF=$$AOF(FILE,NEXTIEN) D ADDAOF(NEXTIEN,AOF,.AOFS,.NAOFS)
. I ($L(NAOFS,U)>1)!($L(AOFS,U)>1)!((AOFS'="")&(NAOFS'="")) D DELETE3(FILE,AOFS,NAOFS,DELETE,PATDIFF)
. Q
I '$G(MAGCNT) S MAGTEXT=" No duplicate records identified." D OUTPUT^MAGVCLN1(MAGTEXT,1,0,$G(MAGPOST))
Q
;
DELETE3(FILE,AOFS,NAOFS,DELETE,PATDIFF) ; Inactivate records identified as duplicates
; If no AOFS mark INACCESSIBLE all but first NAOFS
N DELIEN,ORIGNAOF,TOTNAOFS,TOTAOFS
I AOFS="" D Q
. S ORIGNAOF=$P(NAOFS,U)
. S TOTNAOFS=$L(NAOFS,U)
. I TOTNAOFS>=2 F DELIEN=2:1:TOTNAOFS D
. . I '$G(PATDIFF) D MOVESUBS(FILE,ORIGNAOF,$P(NAOFS,U,DELIEN),DELETE)
. . D DELDUP(FILE,ORIGNAOF,$P(NAOFS,U,DELIEN),DELETE)
. Q
; If AOF mark INACCESSIBLE all NAOFs and all but first AOF - link all children to 1st AOF record
I $G(AOFS) D Q
. S ORIGAOF=$P(AOFS,U),TOTNAOFS=0
. S TOTAOFS=$L(AOFS,U)
. I $G(NAOFS) S TOTNAOFS=$L(NAOFS,U)
. I TOTNAOFS F DELIEN=1:1:TOTNAOFS D
. . I '$G(PATDIFF) D MOVESUBS(FILE,ORIGAOF,$P(NAOFS,U,DELIEN),DELETE)
. . D DELDUP(FILE,ORIGAOF,$P(NAOFS,U,DELIEN),DELETE)
. I TOTAOFS F DELIEN=2:1:TOTAOFS D
. . I '$G(PATDIFF) D MOVESUBS(FILE,ORIGAOF,$P(AOFS,U,DELIEN),DELETE)
. . D DELDUP(FILE,ORIGAOF,$P(AOFS,U,DELIEN),DELETE)
. Q
Q
DELDUP(FILE,ORIGIEN,DUPEIEN,DELETE) ; Mark Duplicates INACCESSIBLE
N KEY,PROCKEY,STATUS,MAGPATID,PATIEN,PATNAME,FILEATT,FILERET,FILENAME,PATID
I FILE=2005.6 S KEY=$$PATKEY(DUPEIEN)
I FILE=2005.61 S KEY=$$PROCKEY(DUPEIEN)
I FILE>=2005.62 S KEY=$P($G(^MAGV(FILE,DUPEIEN,0)),U)
S STATUS=$$GET1^DIQ(FILE,DUPEIEN,"STATUS","I")
Q:STATUS="I"
S MAGCNT=$G(MAGCNT)+1
S MAGTEXT=" DUPLICATE Records Found in "_FILE_": " D OUTPUT^MAGVCLN1(MAGTEXT,2,0,$G(MAGPOST))
S PATID=$$PATMAGID^MAGVCLN1(FILE,ORIGIEN)
S MAGTEXT=" Enterprise Patient ID: "_PATID D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S FILEATT="NAME" D FILE^DID(FILE,,FILEATT,"FILERET") S FILENAME=$G(FILERET("NAME"))
S MAGTEXT=" File Name: "_FILENAME_" File Number: "_FILE D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S MAGTEXT=" Key: "_KEY D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S MAGTEXT=" File "_FILE_" Primary IEN: "_ORIGIEN D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S MAGTEXT=" File "_FILE_" Duplicate IEN: "_DUPEIEN D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
I $G(FILE),$G(DUPEIEN),$D(^MAGV(FILE,DUPEIEN,0)) M ^XTMP("MAGVCLN",+$G(FILE),+$G(DUPEIEN))=^MAGV(FILE,DUPEIEN)
I $G(DELETE) D
. N INACTBIEN,INACTREAS,MAGFDA,IENS,INACTOUT
. S MAGTEXT=" Setting STATUS to INACCESSIBLE..." D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. ;
. ; Attempt to inactivate all child records
. S INACTBIEN=$S($L($G(BADIEN)):BADIEN,1:"NULL")
. S INACTREAS=$S(INACTBIEN="NULL":"Missing",1:"Inactive")_" Parent Reference"
. D INACT^MAGVRS44(.INACTOUT,FILE,IEN,INACTBIEN,1,INACTREAS) ; Marks the entry indicated by file # and IEN as deleted (inactivated)
. ;
. ; Set status of problem record to inaccesible, to ensure duplicate records don't cause errors
. S IENS=DUPEIEN_","
. S MAGFDA(FILE,IENS,"STATUS")="I"
. D FILE^DIE("","MAGFDA","ERR")
. Q
D AUDIT^MAGVCLN1(KEY,FILE,DUPEIEN,ORIGIEN,1,DELETE)
Q
DELBP(FILE,KEY,IEN,REASON,DELETE,BADIEN) ; Report and/or inactivate (aka 'delete') records with broken pointers
N FILEATT,FILRET,FILENAME,PFILE,PFILENAME
Q:(($G(IEN)="")!($G(KEY)=""))
S STATUS=$$GET1^DIQ(FILE,IEN,"STATUS","I")
Q:STATUS="I"
S MAGCNT=$G(MAGCNT)+1
S MAGTEXT=" Identified "_$S($G(REASON)#2:"Invalid",1:"Missing")_" Parent File Pointer " D OUTPUT^MAGVCLN1(MAGTEXT,2,0,$G(MAGPOST))
S FILEATT="NAME" D FILE^DID(FILE,,FILEATT,"FILERET") S FILENAME=$G(FILERET("NAME"))
S MAGTEXT=" File Name: "_FILENAME_" File Number: "_FILE_" IEN: "_IEN D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S MAGTEXT=" Key: "_KEY D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
S PFILE=FILE-.01 I PFILE>2005.6 S FILEATT="NAME" D FILE^DID(PFILE,,FILEATT,"FILERET") S PFILENAME=$G(FILERET("NAME"))
S MAGTEXT=" Invalid Parent Pointer: "_$S($D(BADIEN):BADIEN,1:"NULL") D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
I $L($G(PFILENAME)) S MAGTEXT=" Points to: "_PFILENAME D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
I $G(FILE),$G(IEN),$D(^MAGV(FILE,IEN,0)) M ^XTMP("MAGVCLN",+$G(FILE),+$G(IEN))=^MAGV(FILE,IEN)
I $G(DELETE) D
. N IENS,MAGFDA,ERR,INACTREAS,INACTBIEN,INACTOUT
. S MAGTEXT=" Setting STATUS to INACCESSIBLE..." D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. ;
. ; Attempt to inactivate all child records
. S INACTBIEN=$S($L($G(BADIEN)):BADIEN,1:"NULL")
. S INACTREAS=$S(INACTBIEN="NULL":"Missing",1:"Inactive")_" Parent Reference"
. D INACT^MAGVRS44(.INACTOUT,FILE,IEN,INACTBIEN,1,INACTREAS) ; Marks the entry indicated by file # and IEN as deleted (inactivated)
. ;
. ; Set status of problem record to inaccessible, to ensure data access methods don't produce errors
. S IENS=IEN_","
. S MAGFDA(FILE,IENS,"STATUS")="I"
. D FILE^DIE("","MAGFDA","ERR")
. Q
D AUDIT^MAGVCLN1(KEY,FILE,IEN,"",REASON,DELETE,$G(BADIEN))
Q
;
ADDAOF(IEN,AOF,AOFS,NAOFS) ; Log AOF or NAOF
; If AOF add to AOF list
I AOF D
. N PC,REPEAT S REPEAT=0
. F PC=1:1:$L(AOFS,U) Q:REPEAT I $P(AOFS,U,PC)=IEN S REPEAT=1
. Q:REPEAT
. I $L(AOFS)>0 S AOFS=AOFS_U_IEN
. I $L(AOFS)=0 S AOFS=IEN
; If not AOF add to not AOF list
I 'AOF D
. N PC,REPEAT S REPEAT=0
. F PC=1:1:$L(NAOFS,U) Q:REPEAT I $P(NAOFS,U,PC)=IEN S REPEAT=1
. Q:REPEAT
. I $L(NAOFS)>0 S NAOFS=NAOFS_U_IEN
. I $L(NAOFS)=0 S NAOFS=IEN
. Q
Q
;
AOF(FILE,IEN) ; Determine if record has images on file
N AOF
I FILE=2005.6 S AOF=$P($G(^MAGV(2005.6,IEN,0)),U,4)
I FILE=2005.61 S AOF=$P($G(^MAGV(2005.61,IEN,0)),U,6)
I FILE=2005.62 S AOF=$P($G(^MAGV(2005.62,IEN,6)),U,2)
I FILE=2005.63 S AOF=$P($G(^MAGV(2005.63,IEN,6)),U,2)
I FILE=2005.64 S AOF=$P($G(^MAGV(2005.64,IEN,6)),U,2)
I FILE=2005.65 S AOF=$P($G(^MAGV(2005.65,IEN,0)),U,2)
Q AOF
PATKEY(IEN,PATFIL) ; Return 4-piece Patient Reference Key
N PATREF,PATKEY,PID,AUTH,INST
S PATREF=^MAGV(2005.6,IEN,0)
S PID=$P(PATREF,U,1)
S AUTH=$P(PATREF,U,2)
S IDTYPE=$P(PATREF,U,3)
S INST=$P(PATREF,U,8)
S PATFIL=$P(PATREF,U,7)
S PATKEY=PID_"/"_AUTH_"/"_IDTYPE_"/"_INST
Q PATKEY
PROCKEY(IEN) ; Return 4-piece Procedure Reference Key
N PROCREF,ACC,PROCT,AUTH,INST
S PROCREF=^MAGV(2005.61,IEN,0)
S ACC=$P(PROCREF,U,1)
S PROCT=$P(PROCREF,U,3)
S AUTH=$P(PROCREF,U,7)
S INST=$P(PROCREF,U,8)
S PROCKEY=ACC_"/"_PROCT_"/"_AUTH_"/"_INST
Q PROCKEY
PATCHK(IEN,NEXTIEN) ; Patient Reference Duplicate Check
; Patient references have 4 key values
N PATKEY1,PATKEY2,MATCH,IDTYPE,PATFIL1,PATFIL2
S MATCH=0,PATFIL=""
S PATKEY1=$$PATKEY(IEN,.PATFIL1)
S PATKEY2=$$PATKEY(NEXTIEN,.PATFIL2)
I PATKEY1=PATKEY2 S MATCH=1
I MATCH,($P(PATKEY1,"/",3)="D"),$G(PATFIL1)'=$G(PATFIL2) S MATCH=-1 ; Different PATIENT (#2) file records
Q MATCH
PROCCHK(IEN,NEXTIEN) ; Patient Reference Duplicate Check
; Procedure references have 4 key values
N PROCKEY1,PROCKEY2,MATCH
S MATCH=0
S PROCKEY1=$$PROCKEY(IEN)
S PROCKEY2=$$PROCKEY(NEXTIEN)
I PROCKEY1=PROCKEY2 S MATCH=1
Q MATCH
MOVESUBS(FILE,ORIGAOF,DELIEN,DELETE) ; Move subfile child records
Q:DELIEN=""
N MAGFDA,SFILE,FIELD,CHILD,REASON,ACTION,FILNAME,FILEATT,FIELDATT
S FILEATT="NAME" D FILE^DID(FILE,,FILEATT,"FILERET") S CHILDFILE=$G(FILERET("NAME"))
D FILE^DID(FILE-.01,,FILEATT,"FILRET") S PARENTFILE=$G(FILERET("NAME"))
S REASON=6
S ACTION=$S($G(DELETE):"MC",1:"MI")
S SFILE=FILE+.01,CHILD=0
F S CHILD=$O(^MAGV(SFILE,"C",DELIEN,CHILD)) Q:'CHILD D
. N KEY,FLDNAME,CHILDFILE,PARENTFILE,FILERET,PATNAME,PATIEN,FIELDATT,STATUS
. S STATUS=$$GET1^DIQ(SFILE,CHILD,"STATUS","I")
. Q:STATUS="I" ; Don't bother with Inaccessible children
. S FILEATT="NAME" D FILE^DID(SFILE,,FILEATT,"FILERET") S CHILDFILE=$G(FILERET("NAME"))
. K FILERET D FILE^DID(FILE,,FILEATT,"FILERET") S PARENTFILE=$G(FILERET("NAME"))
. S KEY=$$GET1^DIQ(SFILE,CHILD_",",.01)
. I SFILE=2005.61 S FIELD=.99
. I SFILE'=2005.61 S FIELD=11
. S FLDNAME=$P(^DD(SFILE,FIELD,0),"^")
. S MAGTEXT=$S(ACTION="MC":" Moving File "_SFILE_" Record's Pointer From Duplicate Parent to Primary Parent: ",1:" Identified File "_SFILE_" Record Pointing to Duplicate Record in File "_FILE)
. D OUTPUT^MAGVCLN1(MAGTEXT,1,0,$G(MAGPOST))
. S PATNAME=$$PATNAME^MAGVCLN1(SFILE,+$G(CHILD))
. S PATID=$$PATMAGID^MAGVCLN1(SFILE,+$G(CHILD))
. I $L(PATNAME) S MAGTEXT=" Enterprise Patient ID: "_PATID D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" File: "_$G(CHILDFILE)_" IEN: "_CHILD D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=$S($G(DELETE):" Old",1:" (Current)")_" Pointer to File "_FILE D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" Duplicate IEN: "_DELIEN D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S FIELDATT="LABEL" D FIELD^DID(FILE,.01,"",FIELDATT,"FIELDRET")
. I $L($G(FIELDRET("LABEL"))) S MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(FILE,DELIEN,.01) D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" "_$S($G(DELETE):"New",1:"(Prospective)")_" Pointer to File "_FILE D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" Primary IEN: "_ORIGAOF D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. I $L($G(FIELDRET("LABEL"))) S MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(FILE,ORIGAOF,.01) D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. ;
. I $G(DELETE) D
. . S MAGFDA(SFILE,CHILD_",",FIELD)=ORIGAOF
. . D FILE^DIE("","MAGFDA","ERR") K MAGFDA
. D AUDIT^MAGVCLN1(KEY,SFILE,CHILD,"",+$G(REASON),ACTION,,$G(ORIGAOF),DELIEN)
. Q
;
; Move Study's patient reference
I FILE=2005.6 S CHILD=0 F S CHILD=$O(^MAGV(2005.62,"L",DELIEN,CHILD)) Q:'CHILD D
. N KEY,FLDNAME,FILE6,FILE62
. S FLDNAME="PATIENT REFERENCE",FILE6="IMAGING PATIENT REFERENCE",FILE62="IMAGE STUDY"
. S KEY=$$GET1^DIQ(2005.62,CHILD,.01)
. S MAGTEXT=" "_$S(ACTION="MC":"Moving File 2005.62 Record's Pointer From Duplicate to Primary Record in File 2005.6",1:"Identified File 2005.62 Record Pointing to Duplicate Record in File 2005.6")
. D OUTPUT^MAGVCLN1(MAGTEXT,2,0,$G(MAGPOST))
. S PATNAME=$$PATNAME^MAGVCLN1(2005.62,CHILD)
. S PATID=$$PATMAGID^MAGVCLN1(2005.62,+$G(CHILD))
. S MAGTEXT=" Enterprise Patient ID: "_PATID D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" File: "_FILE62_" IEN: "_CHILD D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" "_$S($G(DELETE):" Old",1:" (Current)")_" Pointer to File 2005.6" D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" Duplicate IEN: "_DELIEN D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. K FIELDRET
. S FIELDATT="LABEL" D FIELD^DID(2005.6,.01,"",FIELDATT,"FIELDRET") I $L($G(FIELDRET("LABEL"))) D
. . S MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(2005.6,DELIEN,.01) D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" "_$S($G(DELETE):"New",1:" (Prospective)")_" Pointer to File 2005.6" D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. S MAGTEXT=" Primary IEN: "_ORIGAOF D OUTPUT^MAGVCLN1(MAGTEXT,0,0,$G(MAGPOST))
. ;
. I $L($G(FIELDRET("LABEL"))) D
. . S MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(2005.6,ORIGAOF,.01)
. I $G(DELETE) D
. . N MAGFDA S MAGFDA(2005.62,CHILD_",",13)=ORIGAOF
. . D FILE^DIE("","MAGFDA","ERR")
. D AUDIT^MAGVCLN1(KEY,2005.62,CHILD,"",REASON,ACTION,,$G(ORIGAOF),DELIEN)
. Q
Q
CONT ; Continue
W ! K DIR("A") S DIR(0)="E" D ^DIR K DIR
Q
;
QUE ; Queue Search and Resolve processes
N CALLBACK,MENUIEN
D CLEAR^MAGUERR(1)
;
D IDDEL^MAGVCLN(0,1) ; Log Identification of Problem Records
H 60 ; Ensure Identification and Resolution are logged at distinct date/times
D IDDEL^MAGVCLN(1,1) ; Log Resolution of Problem Records
;
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGVCLN 16666 printed Dec 13, 2024@02:09:32 Page 2
MAGVCLN ;WOIFO/DAC - File 2005.6X Duplicate Removal Utility ; Feb 22, 2022@21:12:01
+1 ;;3.0;IMAGING;**278**;Mar 19, 2002;Build 138
+2 ;; Per VA Directive 6402, 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 ;
ID ; Identify Duplicates and Unattached Records
+1 NEW MAGQUIT,DELETE,LINE,MAGSCR,MAGQUE,MAGTEXT,MAGLICNT
+2 SET DELETE=0
SET $PIECE(LINE,"-",30)="-"
+3 DO MSG^MAGVCLN1(DELETE,.MAGQUIT)
if $GET(MAGQUIT)
QUIT
+4 DO DEVICE^MAGVCLN1(DELETE,.MAGQUIT,.MAGQUE,.MAGSCR)
if $GET(MAGQUIT)
QUIT
+5 IF $GET(MAGQUE)
DO CONT
QUIT
+6 WRITE !!,"Identifying Duplicates...",!,LINE
+7 DO IDDEL(DELETE)
+8 DO CONT
+9 QUIT
DELETE ; Change Status of Duplicates and Unattached Records to INACCESSIBLE
+1 NEW MAGQ,DELETE,LINE,MAGSCR,MAGQUE,MAGTEXT,MAGLICNT
+2 SET DELETE=1
SET $PIECE(LINE,"-",30)="-"
+3 DO MSG^MAGVCLN1(DELETE,.MAGQUIT)
if $GET(MAGQUIT)
QUIT
+4 DO DEVICE^MAGVCLN1(DELETE,.MAGQUIT,.MAGQUE,.MAGSCR)
if $GET(MAGQUIT)
QUIT
+5 IF $GET(MAGQUE)
DO CONT
QUIT
+6 WRITE !!,"Resolving Duplicates...",!,LINE
+7 DO IDDEL(DELETE)
+8 DO CONT
+9 QUIT
IDDEL(DELETE,MAGPOST) ; Identify or Set Status of Duplicates and Unattached Records
+1 ; DELETE - Set STATUS to Inaccessible, move child records from duplicate to primary
+2 ; MAGPOST - Run from Post-Install, send output as message to installer
+3 ;
+4 NEW FILE,MAGXTMP,LINE,MAGTEXT,MAGLICNT
+5 KILL ^TMP("MAGCLN",$JOB)
+6 SET MAGXTMP="MAGVCLN"
+7 SET $PIECE(LINE,"-",50)="-"
+8 SET MAGLICNT=1
+9 ;
+10 SET ^XTMP(MAGXTMP,0)=$$FMADD^XLFDT(DT,60)_"^"_DT_"^IMAGING CLEANUP LOG"
+11 IF $GET(MAGPOST)
DO MSGHDR^MAGVCLN1(.MAGLICNT,DELETE)
+12 ;
+13 ; Process duplicates
+14 FOR FILE=2005.6,2005.61,2005.62,2005.63,2005.64,2005.65
DO DELETE2(FILE,DELETE)
+15 ;
+16 ; Process Invalid parent pointers
+17 SET MAGTEXT=$SELECT($GET(DELETE):"Marking as INACCESSIBLE",1:"Identifying")_" Missing or Invalid Parent Links..."
+18 DO OUTPUT^MAGVCLN1(MAGTEXT,3,,$GET(MAGPOST))
DO OUTPUT^MAGVCLN1(LINE,1,0,$GET(MAGPOST))
+19 FOR FILE=2005.61,2005.62,2005.63,2005.64,2005.65
DO IDLINKS(FILE,DELETE)
+20 ;
+21 SET MAGTEXT="** FINISHED **"
DO OUTPUT^MAGVCLN1(MAGTEXT,3,2,$GET(MAGPOST))
+22 ;
+23 IF $GET(MAGPOST)
Begin DoDot:1
+24 DO TMPMSG^MAGVCLN1($GET(DELETE))
+25 KILL ^TMP("MAGVCLN",$JOB)
End DoDot:1
QUIT
+26 ;
+27 IF '$GET(MAGSCR)
WRITE !,@IOF
+28 DO ^%ZISC
+29 QUIT
+30 ;
IDLINKS(FILE,DELETE) ; Check 2005.6x files broken pointer to parent records
+1 NEW IEN,PIEN,PFILE,PRIEN,PATIEN,KEY,BKEY,MAGCNT
+2 SET MAGTEXT="Searching File "_FILE
DO OUTPUT^MAGVCLN1(MAGTEXT,2,,$GET(MAGPOST))
+3 SET IEN=0
SET MAGCNT=0
+4 SET BKEY=""
FOR
SET BKEY=$ORDER(^MAGV(FILE,"B",BKEY))
if BKEY=""
QUIT
DO IDLINKS2(FILE,DELETE,BKEY,.MAGCNT)
+5 IF '$GET(MAGCNT)
SET MAGTEXT=FILE_" - No missing or invalid pointers identified."
DO OUTPUT^MAGVCLN1(MAGTEXT,1,0,$GET(MAGPOST))
+6 QUIT
IDLINKS2(FILE,DELETE,BKEY,MAGCNT) ; Get IEN from "B" x-ref
+1 NEW IEN
+2 SET IEN=0
FOR
SET IEN=$ORDER(^MAGV(FILE,"B",BKEY,IEN))
if '+IEN
QUIT
Begin DoDot:1
+3 SET KEY=$PIECE($GET(^MAGV(FILE,IEN,0)),U,1)
+4 SET PIEN=$PIECE($GET(^MAGV(FILE,IEN,6)),U,1)
+5 IF FILE=2005.62
SET PATIEN=$PIECE($GET(^MAGV(2005.62,IEN,6)),U,3)
+6 SET PFILE=FILE-.01
+7 IF $GET(PIEN)=""
DO DELBP(FILE,KEY,IEN,2,DELETE)
QUIT
+8 IF '$DATA(^MAGV(PFILE,PIEN,0))
DO DELBP(FILE,KEY,IEN,3,DELETE,PIEN)
QUIT
+9 IF FILE=2005.62
IF $GET(PATIEN)=""
DO DELBP(FILE,KEY,IEN,4,DELETE)
QUIT
+10 IF FILE=2005.62
IF $GET(PATIEN)'=""
IF '$DATA(^MAGV(2005.6,PATIEN,0))
DO DELBP(FILE,KEY,IEN,5,DELETE,PATIEN)
QUIT
End DoDot:1
+11 QUIT
DELETE2(FILE,DELETE) ; Check 2005.6x files for B x-ref for duplicate key values
+1 NEW NAOFS,AOFS,DUPE,NEXTIEN,MAGCNT,PATCHK,PATDIFF,MAGCNT
+2 SET KEY=""
SET MAGCNT=0
+3 SET MAGTEXT="Searching File "_FILE
DO OUTPUT^MAGVCLN1(MAGTEXT,2,0,$GET(MAGPOST))
+4 FOR
SET KEY=$ORDER(^MAGV(FILE,"B",KEY))
if KEY=""
QUIT
Begin DoDot:1
+5 SET (PATCHK,PATDIFF)=""
+6 SET AOFS=""
SET NAOFS=""
SET IEN=""
SET DUPE=""
+7 FOR
SET IEN=$ORDER(^MAGV(FILE,"B",KEY,IEN))
if IEN=""
QUIT
Begin DoDot:2
+8 SET NEXTIEN=$ORDER(^MAGV(FILE,"B",KEY,IEN))
+9 if NEXTIEN
SET DUPE=1
if NEXTIEN=""
QUIT
+10 ; Check 2005.6,2005.61 duplicate - multifield keys
+11 IF FILE=2005.6
SET PATCHK=$$PATCHK(IEN,NEXTIEN)
Begin DoDot:3
+12 IF PATCHK=-1
SET PATDIFF=1
End DoDot:3
IF 'PATCHK
QUIT
+13 IF FILE=2005.61
IF '$$PROCCHK(IEN,NEXTIEN)
QUIT
+14 SET AOF=$$AOF(FILE,IEN)
DO ADDAOF(IEN,AOF,.AOFS,.NAOFS)
+15 SET AOF=$$AOF(FILE,NEXTIEN)
DO ADDAOF(NEXTIEN,AOF,.AOFS,.NAOFS)
End DoDot:2
+16 IF ($LENGTH(NAOFS,U)>1)!($LENGTH(AOFS,U)>1)!((AOFS'="")&(NAOFS'=""))
DO DELETE3(FILE,AOFS,NAOFS,DELETE,PATDIFF)
+17 QUIT
End DoDot:1
+18 IF '$GET(MAGCNT)
SET MAGTEXT=" No duplicate records identified."
DO OUTPUT^MAGVCLN1(MAGTEXT,1,0,$GET(MAGPOST))
+19 QUIT
+20 ;
DELETE3(FILE,AOFS,NAOFS,DELETE,PATDIFF) ; Inactivate records identified as duplicates
+1 ; If no AOFS mark INACCESSIBLE all but first NAOFS
+2 NEW DELIEN,ORIGNAOF,TOTNAOFS,TOTAOFS
+3 IF AOFS=""
Begin DoDot:1
+4 SET ORIGNAOF=$PIECE(NAOFS,U)
+5 SET TOTNAOFS=$LENGTH(NAOFS,U)
+6 IF TOTNAOFS>=2
FOR DELIEN=2:1:TOTNAOFS
Begin DoDot:2
+7 IF '$GET(PATDIFF)
DO MOVESUBS(FILE,ORIGNAOF,$PIECE(NAOFS,U,DELIEN),DELETE)
+8 DO DELDUP(FILE,ORIGNAOF,$PIECE(NAOFS,U,DELIEN),DELETE)
End DoDot:2
+9 QUIT
End DoDot:1
QUIT
+10 ; If AOF mark INACCESSIBLE all NAOFs and all but first AOF - link all children to 1st AOF record
+11 IF $GET(AOFS)
Begin DoDot:1
+12 SET ORIGAOF=$PIECE(AOFS,U)
SET TOTNAOFS=0
+13 SET TOTAOFS=$LENGTH(AOFS,U)
+14 IF $GET(NAOFS)
SET TOTNAOFS=$LENGTH(NAOFS,U)
+15 IF TOTNAOFS
FOR DELIEN=1:1:TOTNAOFS
Begin DoDot:2
+16 IF '$GET(PATDIFF)
DO MOVESUBS(FILE,ORIGAOF,$PIECE(NAOFS,U,DELIEN),DELETE)
+17 DO DELDUP(FILE,ORIGAOF,$PIECE(NAOFS,U,DELIEN),DELETE)
End DoDot:2
+18 IF TOTAOFS
FOR DELIEN=2:1:TOTAOFS
Begin DoDot:2
+19 IF '$GET(PATDIFF)
DO MOVESUBS(FILE,ORIGAOF,$PIECE(AOFS,U,DELIEN),DELETE)
+20 DO DELDUP(FILE,ORIGAOF,$PIECE(AOFS,U,DELIEN),DELETE)
End DoDot:2
+21 QUIT
End DoDot:1
QUIT
+22 QUIT
DELDUP(FILE,ORIGIEN,DUPEIEN,DELETE) ; Mark Duplicates INACCESSIBLE
+1 NEW KEY,PROCKEY,STATUS,MAGPATID,PATIEN,PATNAME,FILEATT,FILERET,FILENAME,PATID
+2 IF FILE=2005.6
SET KEY=$$PATKEY(DUPEIEN)
+3 IF FILE=2005.61
SET KEY=$$PROCKEY(DUPEIEN)
+4 IF FILE>=2005.62
SET KEY=$PIECE($GET(^MAGV(FILE,DUPEIEN,0)),U)
+5 SET STATUS=$$GET1^DIQ(FILE,DUPEIEN,"STATUS","I")
+6 if STATUS="I"
QUIT
+7 SET MAGCNT=$GET(MAGCNT)+1
+8 SET MAGTEXT=" DUPLICATE Records Found in "_FILE_": "
DO OUTPUT^MAGVCLN1(MAGTEXT,2,0,$GET(MAGPOST))
+9 SET PATID=$$PATMAGID^MAGVCLN1(FILE,ORIGIEN)
+10 SET MAGTEXT=" Enterprise Patient ID: "_PATID
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+11 SET FILEATT="NAME"
DO FILE^DID(FILE,,FILEATT,"FILERET")
SET FILENAME=$GET(FILERET("NAME"))
+12 SET MAGTEXT=" File Name: "_FILENAME_" File Number: "_FILE
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+13 SET MAGTEXT=" Key: "_KEY
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+14 SET MAGTEXT=" File "_FILE_" Primary IEN: "_ORIGIEN
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+15 SET MAGTEXT=" File "_FILE_" Duplicate IEN: "_DUPEIEN
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+16 IF $GET(FILE)
IF $GET(DUPEIEN)
IF $DATA(^MAGV(FILE,DUPEIEN,0))
MERGE ^XTMP("MAGVCLN",+$GET(FILE),+$GET(DUPEIEN))=^MAGV(FILE,DUPEIEN)
+17 IF $GET(DELETE)
Begin DoDot:1
+18 NEW INACTBIEN,INACTREAS,MAGFDA,IENS,INACTOUT
+19 SET MAGTEXT=" Setting STATUS to INACCESSIBLE..."
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+20 ;
+21 ; Attempt to inactivate all child records
+22 SET INACTBIEN=$SELECT($LENGTH($GET(BADIEN)):BADIEN,1:"NULL")
+23 SET INACTREAS=$SELECT(INACTBIEN="NULL":"Missing",1:"Inactive")_" Parent Reference"
+24 ; Marks the entry indicated by file # and IEN as deleted (inactivated)
DO INACT^MAGVRS44(.INACTOUT,FILE,IEN,INACTBIEN,1,INACTREAS)
+25 ;
+26 ; Set status of problem record to inaccesible, to ensure duplicate records don't cause errors
+27 SET IENS=DUPEIEN_","
+28 SET MAGFDA(FILE,IENS,"STATUS")="I"
+29 DO FILE^DIE("","MAGFDA","ERR")
+30 QUIT
End DoDot:1
+31 DO AUDIT^MAGVCLN1(KEY,FILE,DUPEIEN,ORIGIEN,1,DELETE)
+32 QUIT
DELBP(FILE,KEY,IEN,REASON,DELETE,BADIEN) ; Report and/or inactivate (aka 'delete') records with broken pointers
+1 NEW FILEATT,FILRET,FILENAME,PFILE,PFILENAME
+2 if (($GET(IEN)="")!($GET(KEY)=""))
QUIT
+3 SET STATUS=$$GET1^DIQ(FILE,IEN,"STATUS","I")
+4 if STATUS="I"
QUIT
+5 SET MAGCNT=$GET(MAGCNT)+1
+6 SET MAGTEXT=" Identified "_$SELECT($GET(REASON)#2:"Invalid",1:"Missing")_" Parent File Pointer "
DO OUTPUT^MAGVCLN1(MAGTEXT,2,0,$GET(MAGPOST))
+7 SET FILEATT="NAME"
DO FILE^DID(FILE,,FILEATT,"FILERET")
SET FILENAME=$GET(FILERET("NAME"))
+8 SET MAGTEXT=" File Name: "_FILENAME_" File Number: "_FILE_" IEN: "_IEN
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+9 SET MAGTEXT=" Key: "_KEY
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+10 SET PFILE=FILE-.01
IF PFILE>2005.6
SET FILEATT="NAME"
DO FILE^DID(PFILE,,FILEATT,"FILERET")
SET PFILENAME=$GET(FILERET("NAME"))
+11 SET MAGTEXT=" Invalid Parent Pointer: "_$SELECT($DATA(BADIEN):BADIEN,1:"NULL")
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+12 IF $LENGTH($GET(PFILENAME))
SET MAGTEXT=" Points to: "_PFILENAME
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+13 IF $GET(FILE)
IF $GET(IEN)
IF $DATA(^MAGV(FILE,IEN,0))
MERGE ^XTMP("MAGVCLN",+$GET(FILE),+$GET(IEN))=^MAGV(FILE,IEN)
+14 IF $GET(DELETE)
Begin DoDot:1
+15 NEW IENS,MAGFDA,ERR,INACTREAS,INACTBIEN,INACTOUT
+16 SET MAGTEXT=" Setting STATUS to INACCESSIBLE..."
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+17 ;
+18 ; Attempt to inactivate all child records
+19 SET INACTBIEN=$SELECT($LENGTH($GET(BADIEN)):BADIEN,1:"NULL")
+20 SET INACTREAS=$SELECT(INACTBIEN="NULL":"Missing",1:"Inactive")_" Parent Reference"
+21 ; Marks the entry indicated by file # and IEN as deleted (inactivated)
DO INACT^MAGVRS44(.INACTOUT,FILE,IEN,INACTBIEN,1,INACTREAS)
+22 ;
+23 ; Set status of problem record to inaccessible, to ensure data access methods don't produce errors
+24 SET IENS=IEN_","
+25 SET MAGFDA(FILE,IENS,"STATUS")="I"
+26 DO FILE^DIE("","MAGFDA","ERR")
+27 QUIT
End DoDot:1
+28 DO AUDIT^MAGVCLN1(KEY,FILE,IEN,"",REASON,DELETE,$GET(BADIEN))
+29 QUIT
+30 ;
ADDAOF(IEN,AOF,AOFS,NAOFS) ; Log AOF or NAOF
+1 ; If AOF add to AOF list
+2 IF AOF
Begin DoDot:1
+3 NEW PC,REPEAT
SET REPEAT=0
+4 FOR PC=1:1:$LENGTH(AOFS,U)
if REPEAT
QUIT
IF $PIECE(AOFS,U,PC)=IEN
SET REPEAT=1
+5 if REPEAT
QUIT
+6 IF $LENGTH(AOFS)>0
SET AOFS=AOFS_U_IEN
+7 IF $LENGTH(AOFS)=0
SET AOFS=IEN
End DoDot:1
+8 ; If not AOF add to not AOF list
+9 IF 'AOF
Begin DoDot:1
+10 NEW PC,REPEAT
SET REPEAT=0
+11 FOR PC=1:1:$LENGTH(NAOFS,U)
if REPEAT
QUIT
IF $PIECE(NAOFS,U,PC)=IEN
SET REPEAT=1
+12 if REPEAT
QUIT
+13 IF $LENGTH(NAOFS)>0
SET NAOFS=NAOFS_U_IEN
+14 IF $LENGTH(NAOFS)=0
SET NAOFS=IEN
+15 QUIT
End DoDot:1
+16 QUIT
+17 ;
AOF(FILE,IEN) ; Determine if record has images on file
+1 NEW AOF
+2 IF FILE=2005.6
SET AOF=$PIECE($GET(^MAGV(2005.6,IEN,0)),U,4)
+3 IF FILE=2005.61
SET AOF=$PIECE($GET(^MAGV(2005.61,IEN,0)),U,6)
+4 IF FILE=2005.62
SET AOF=$PIECE($GET(^MAGV(2005.62,IEN,6)),U,2)
+5 IF FILE=2005.63
SET AOF=$PIECE($GET(^MAGV(2005.63,IEN,6)),U,2)
+6 IF FILE=2005.64
SET AOF=$PIECE($GET(^MAGV(2005.64,IEN,6)),U,2)
+7 IF FILE=2005.65
SET AOF=$PIECE($GET(^MAGV(2005.65,IEN,0)),U,2)
+8 QUIT AOF
PATKEY(IEN,PATFIL) ; Return 4-piece Patient Reference Key
+1 NEW PATREF,PATKEY,PID,AUTH,INST
+2 SET PATREF=^MAGV(2005.6,IEN,0)
+3 SET PID=$PIECE(PATREF,U,1)
+4 SET AUTH=$PIECE(PATREF,U,2)
+5 SET IDTYPE=$PIECE(PATREF,U,3)
+6 SET INST=$PIECE(PATREF,U,8)
+7 SET PATFIL=$PIECE(PATREF,U,7)
+8 SET PATKEY=PID_"/"_AUTH_"/"_IDTYPE_"/"_INST
+9 QUIT PATKEY
PROCKEY(IEN) ; Return 4-piece Procedure Reference Key
+1 NEW PROCREF,ACC,PROCT,AUTH,INST
+2 SET PROCREF=^MAGV(2005.61,IEN,0)
+3 SET ACC=$PIECE(PROCREF,U,1)
+4 SET PROCT=$PIECE(PROCREF,U,3)
+5 SET AUTH=$PIECE(PROCREF,U,7)
+6 SET INST=$PIECE(PROCREF,U,8)
+7 SET PROCKEY=ACC_"/"_PROCT_"/"_AUTH_"/"_INST
+8 QUIT PROCKEY
PATCHK(IEN,NEXTIEN) ; Patient Reference Duplicate Check
+1 ; Patient references have 4 key values
+2 NEW PATKEY1,PATKEY2,MATCH,IDTYPE,PATFIL1,PATFIL2
+3 SET MATCH=0
SET PATFIL=""
+4 SET PATKEY1=$$PATKEY(IEN,.PATFIL1)
+5 SET PATKEY2=$$PATKEY(NEXTIEN,.PATFIL2)
+6 IF PATKEY1=PATKEY2
SET MATCH=1
+7 ; Different PATIENT (#2) file records
IF MATCH
IF ($PIECE(PATKEY1,"/",3)="D")
IF $GET(PATFIL1)'=$GET(PATFIL2)
SET MATCH=-1
+8 QUIT MATCH
PROCCHK(IEN,NEXTIEN) ; Patient Reference Duplicate Check
+1 ; Procedure references have 4 key values
+2 NEW PROCKEY1,PROCKEY2,MATCH
+3 SET MATCH=0
+4 SET PROCKEY1=$$PROCKEY(IEN)
+5 SET PROCKEY2=$$PROCKEY(NEXTIEN)
+6 IF PROCKEY1=PROCKEY2
SET MATCH=1
+7 QUIT MATCH
MOVESUBS(FILE,ORIGAOF,DELIEN,DELETE) ; Move subfile child records
+1 if DELIEN=""
QUIT
+2 NEW MAGFDA,SFILE,FIELD,CHILD,REASON,ACTION,FILNAME,FILEATT,FIELDATT
+3 SET FILEATT="NAME"
DO FILE^DID(FILE,,FILEATT,"FILERET")
SET CHILDFILE=$GET(FILERET("NAME"))
+4 DO FILE^DID(FILE-.01,,FILEATT,"FILRET")
SET PARENTFILE=$GET(FILERET("NAME"))
+5 SET REASON=6
+6 SET ACTION=$SELECT($GET(DELETE):"MC",1:"MI")
+7 SET SFILE=FILE+.01
SET CHILD=0
+8 FOR
SET CHILD=$ORDER(^MAGV(SFILE,"C",DELIEN,CHILD))
if 'CHILD
QUIT
Begin DoDot:1
+9 NEW KEY,FLDNAME,CHILDFILE,PARENTFILE,FILERET,PATNAME,PATIEN,FIELDATT,STATUS
+10 SET STATUS=$$GET1^DIQ(SFILE,CHILD,"STATUS","I")
+11 ; Don't bother with Inaccessible children
if STATUS="I"
QUIT
+12 SET FILEATT="NAME"
DO FILE^DID(SFILE,,FILEATT,"FILERET")
SET CHILDFILE=$GET(FILERET("NAME"))
+13 KILL FILERET
DO FILE^DID(FILE,,FILEATT,"FILERET")
SET PARENTFILE=$GET(FILERET("NAME"))
+14 SET KEY=$$GET1^DIQ(SFILE,CHILD_",",.01)
+15 IF SFILE=2005.61
SET FIELD=.99
+16 IF SFILE'=2005.61
SET FIELD=11
+17 SET FLDNAME=$PIECE(^DD(SFILE,FIELD,0),"^")
+18 SET MAGTEXT=$SELECT(ACTION="MC":" Moving File "_SFILE_" Record's Pointer From Duplicate Parent to Primary Parent: ",1:" Identified File "_SFILE_" Record Pointing to Duplicate Record in File "_FILE)
+19 DO OUTPUT^MAGVCLN1(MAGTEXT,1,0,$GET(MAGPOST))
+20 SET PATNAME=$$PATNAME^MAGVCLN1(SFILE,+$GET(CHILD))
+21 SET PATID=$$PATMAGID^MAGVCLN1(SFILE,+$GET(CHILD))
+22 IF $LENGTH(PATNAME)
SET MAGTEXT=" Enterprise Patient ID: "_PATID
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+23 SET MAGTEXT=" File: "_$GET(CHILDFILE)_" IEN: "_CHILD
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+24 SET MAGTEXT=$SELECT($GET(DELETE):" Old",1:" (Current)")_" Pointer to File "_FILE
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+25 SET MAGTEXT=" Duplicate IEN: "_DELIEN
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+26 SET FIELDATT="LABEL"
DO FIELD^DID(FILE,.01,"",FIELDATT,"FIELDRET")
+27 IF $LENGTH($GET(FIELDRET("LABEL")))
SET MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(FILE,DELIEN,.01)
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+28 SET MAGTEXT=" "_$SELECT($GET(DELETE):"New",1:"(Prospective)")_" Pointer to File "_FILE
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+29 SET MAGTEXT=" Primary IEN: "_ORIGAOF
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+30 IF $LENGTH($GET(FIELDRET("LABEL")))
SET MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(FILE,ORIGAOF,.01)
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+31 ;
+32 IF $GET(DELETE)
Begin DoDot:2
+33 SET MAGFDA(SFILE,CHILD_",",FIELD)=ORIGAOF
+34 DO FILE^DIE("","MAGFDA","ERR")
KILL MAGFDA
End DoDot:2
+35 DO AUDIT^MAGVCLN1(KEY,SFILE,CHILD,"",+$GET(REASON),ACTION,,$GET(ORIGAOF),DELIEN)
+36 QUIT
End DoDot:1
+37 ;
+38 ; Move Study's patient reference
+39 IF FILE=2005.6
SET CHILD=0
FOR
SET CHILD=$ORDER(^MAGV(2005.62,"L",DELIEN,CHILD))
if 'CHILD
QUIT
Begin DoDot:1
+40 NEW KEY,FLDNAME,FILE6,FILE62
+41 SET FLDNAME="PATIENT REFERENCE"
SET FILE6="IMAGING PATIENT REFERENCE"
SET FILE62="IMAGE STUDY"
+42 SET KEY=$$GET1^DIQ(2005.62,CHILD,.01)
+43 SET MAGTEXT=" "_$SELECT(ACTION="MC":"Moving File 2005.62 Record's Pointer From Duplicate to Primary Record in File 2005.6",1:"Identified File 2005.62 Record Pointing to Duplicate Record in File 2005.6")
+44 DO OUTPUT^MAGVCLN1(MAGTEXT,2,0,$GET(MAGPOST))
+45 SET PATNAME=$$PATNAME^MAGVCLN1(2005.62,CHILD)
+46 SET PATID=$$PATMAGID^MAGVCLN1(2005.62,+$GET(CHILD))
+47 SET MAGTEXT=" Enterprise Patient ID: "_PATID
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+48 SET MAGTEXT=" File: "_FILE62_" IEN: "_CHILD
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+49 SET MAGTEXT=" "_$SELECT($GET(DELETE):" Old",1:" (Current)")_" Pointer to File 2005.6"
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+50 SET MAGTEXT=" Duplicate IEN: "_DELIEN
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+51 KILL FIELDRET
+52 SET FIELDATT="LABEL"
DO FIELD^DID(2005.6,.01,"",FIELDATT,"FIELDRET")
IF $LENGTH($GET(FIELDRET("LABEL")))
Begin DoDot:2
+53 SET MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(2005.6,DELIEN,.01)
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
End DoDot:2
+54 SET MAGTEXT=" "_$SELECT($GET(DELETE):"New",1:" (Prospective)")_" Pointer to File 2005.6"
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+55 SET MAGTEXT=" Primary IEN: "_ORIGAOF
DO OUTPUT^MAGVCLN1(MAGTEXT,0,0,$GET(MAGPOST))
+56 ;
+57 IF $LENGTH($GET(FIELDRET("LABEL")))
Begin DoDot:2
+58 SET MAGTEXT=" "_FIELDRET("LABEL")_": "_$$GET1^DIQ(2005.6,ORIGAOF,.01)
End DoDot:2
+59 IF $GET(DELETE)
Begin DoDot:2
+60 NEW MAGFDA
SET MAGFDA(2005.62,CHILD_",",13)=ORIGAOF
+61 DO FILE^DIE("","MAGFDA","ERR")
End DoDot:2
+62 DO AUDIT^MAGVCLN1(KEY,2005.62,CHILD,"",REASON,ACTION,,$GET(ORIGAOF),DELIEN)
+63 QUIT
End DoDot:1
+64 QUIT
CONT ; Continue
+1 WRITE !
KILL DIR("A")
SET DIR(0)="E"
DO ^DIR
KILL DIR
+2 QUIT
+3 ;
QUE ; Queue Search and Resolve processes
+1 NEW CALLBACK,MENUIEN
+2 DO CLEAR^MAGUERR(1)
+3 ;
+4 ; Log Identification of Problem Records
DO IDDEL^MAGVCLN(0,1)
+5 ; Ensure Identification and Resolution are logged at distinct date/times
HANG 60
+6 ; Log Resolution of Problem Records
DO IDDEL^MAGVCLN(1,1)
+7 ;
+8 QUIT
