MAGDLB12 ;WOIFO/LB,MLH/JSL/SAF - Routine to fix failed DICOM entries ; 04/25/2005 07:46
;;3.0;IMAGING;**11,51,20,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
LOOP ;
N ANS,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
N MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP,SUID
N MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC
N NEWPID,OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,SITE,STUDYUID,WHY,MAGFIX
N KFIXALL ; -- does user hold MAGDFIX ALL security key?
;
S KFIXALL=$$SECKEY()
S (OOUT,OUT,PREV,FIRST)=0
; select a site - bail if no images to correct or no site selected
S STAT=$$SITE(.SITE) Q:'SITE
S SUID=0
F S SUID=$O(^MAGD(2006.575,"F",SITE,SUID)) Q:SUID=""!(OOUT) D
. S MAGIEN=$O(^MAGD(2006.575,"F",SITE,SUID,0)) Q:'MAGIEN
. ; if image isn't on file, clean up xrefs
. I '$D(^MAGD(2006.575,MAGIEN,0)) D Q
. . K ^MAGD(2006.575,"F",SITE,SUID,MAGIEN)
. . Q
. ; if gateway site isn't the user's site, bail unless the user holds
. ; the MAGDFIX ALL security key
. I $P($G(^MAGD(2006.575,MAGIEN,1)),U,5)'=DUZ(2),'KFIXALL Q
. ;Only process Radiology images...medicine images done by other rtns.
. S MAGTYPE=$P($G(^MAGD(2006.575,MAGIEN,"TYPE")),"^") I MAGTYPE'["RAD" 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^MAGDLB1
. Q
Q
SITE(XSITE) ; select a site for which to process entries
; input: none
; output: .XSITE site number for which to process entries
;
; return: 0 always
;
N CNT,KFIXALL,RESULT,SITES
S (CNT,XSITE)=0 F S XSITE=$O(^MAGD(2006.575,"F",XSITE)) Q:'XSITE D
. Q:'$$FIND1^DIC(4,"","","`"_XSITE)
. S CNT=CNT+1,SITES(CNT)=XSITE
. Q
Q:'CNT 0
;
S KFIXALL=$$SECKEY I '$$MDIV S KFIXALL=1
; If not multi-division set the KFIXALL - site should be able to correct any entry
I KFIXALL D FIX(.SITES,CNT) Q 0
I $D(DUZ(2)) D Q 0
. S XSITE=DUZ(2)
. I '$D(^MAGD(2006.575,"F",XSITE)) W !,"No entries for division "_$$GET1^DIQ(4,+XSITE,".01","E")
. Q
D LKUSR(.RESULT,DUZ)
I '$D(RESULT(0)) Q 0
I $P(RESULT(0),"^")=0 W !,$P(RESULT,"^",2) Q 0
;
N EN,II,NSITE,MAGSITE,X
S (CNT,XSITE)=0
S X=0 F S X=$O(SITES(X)) Q:'X S II=$G(SITES(X)) I II S NSITE(II)=""
S II=0
F S II=$O(RESULT(II)) Q:'II S EN=$G(RESULT(II)) I $D(NSITE(EN)) S CNT=CNT+1,MAGSITE(CNT)=EN
I 'CNT Q 0 ;no matches
I CNT=1 S XSITE=$G(MAGSITE(1)) Q 0
D FIX(.MAGSITE,CNT) ; select a SITE to fix
Q 0
;
FIX(SITES,CNT) ;SUBROUTINE - Prepare to fix the entries for the user's division entries.
; Multiple divisions have images to be corrected and user has appropriate security key.
N DIR,I,Y,X
I 'CNT Q
I CNT=1 S SITE=$G(SITES(CNT)) Q
S I=0 F S I=$O(SITES(I)) Q:'I D
. W !,I,") ",$G(SITES(I))," ",$$GET1^DIQ(4,+$G(SITES(I)),".01","E")
. Q
F D Q:Y'>CNT
. S DIR(0)="N:1:"_CNT
. S DIR("A",1)="There are images to be corrected for multiple divisions."
. S DIR("A")="Select by number (1-"_CNT_")"
. D ^DIR
. W:Y>CNT " ??"
. Q
S:Y SITE=$G(SITES(+Y))
Q
;
SECKEY() ;
N MAGKY,MAGRSLT
I '$D(DUZ) Q 0
S MAGKY("MAGDFIX ALL")="MAGDFIX ALL"
D OWNSKEY^XUSRB(.MAGRSLT,.MAGKY)
I +$G(MAGRSLT("MAGDFIX ALL")) Q 1
Q 0
;
MDIV() ;Multi-divisional flag
N CNT,I
S (CNT,I)=0
F S I=$O(^MAG(2006.1,I)) Q:'I S CNT=CNT+1
I CNT>1 Q 1
Q 0
;
LKUSR(RESULT,USER) ;
;RETURNS: 0^Message for failure
; IENs for Institution file entry^
; If the user has more than one division and more than one match in the Imaging Site
; Parameter file, then it returns the 1st matching division entry in the New Person file.
I $D(DUZ(2)) S RESULT(0)="1^Number of entries",RESULT(DUZ(2))=DUZ(2) Q
N MAGARRAY,CNT,MAGERR,MAGOUT,MAGDV,MAGX
S RESULT(0)="0^Your division entry is not part of the Imaging Site Parameter."
D GETS^DIQ(200,USER,"16*","I","MAGOUT")
;MAGOUT(200.02,"institution entry,duz,",.01,"I")=institution entry
I $D(MAGOUT)=0 Q
S MAGX="",CNT=0
F S MAGX=$O(MAGOUT(200.02,MAGX)) Q:MAGX="" D
. S MAGDV=$P(MAGX,",") I $D(^MAG(2006.1,"B",MAGDV)) S CNT=CNT+1,MAGARRAY(CNT)=MAGDV
. Q
I 'CNT Q
S CNT=0
S X=0 F S X=$O(MAGARRAY(X)) Q:'X S CNT=CNT+1,RESULT(X)=$P(MAGARRAY(X),"^")
S RESULT(0)=CNT_"^Number of entries"
; Get the 1st institution, the calling routine should check for keys.
Q
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDLB12 5392 printed Sep 23, 2025@19:36:47 Page 2
MAGDLB12 ;WOIFO/LB,MLH/JSL/SAF - Routine to fix failed DICOM entries ; 04/25/2005 07:46
+1 ;;3.0;IMAGING;**11,51,20,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
LOOP ;
+1 NEW ANS,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
+2 NEW MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP,SUID
+3 NEW MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC
+4 NEW NEWPID,OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,SITE,STUDYUID,WHY,MAGFIX
+5 ; -- does user hold MAGDFIX ALL security key?
NEW KFIXALL
+6 ;
+7 SET KFIXALL=$$SECKEY()
+8 SET (OOUT,OUT,PREV,FIRST)=0
+9 ; select a site - bail if no images to correct or no site selected
+10 SET STAT=$$SITE(.SITE)
if 'SITE
QUIT
+11 SET SUID=0
+12 FOR
SET SUID=$ORDER(^MAGD(2006.575,"F",SITE,SUID))
if SUID=""!(OOUT)
QUIT
Begin DoDot:1
+13 SET MAGIEN=$ORDER(^MAGD(2006.575,"F",SITE,SUID,0))
if 'MAGIEN
QUIT
+14 ; if image isn't on file, clean up xrefs
+15 IF '$DATA(^MAGD(2006.575,MAGIEN,0))
Begin DoDot:2
+16 KILL ^MAGD(2006.575,"F",SITE,SUID,MAGIEN)
+17 QUIT
End DoDot:2
QUIT
+18 ; if gateway site isn't the user's site, bail unless the user holds
+19 ; the MAGDFIX ALL security key
+20 IF $PIECE($GET(^MAGD(2006.575,MAGIEN,1)),U,5)'=DUZ(2)
IF 'KFIXALL
QUIT
+21 ;Only process Radiology images...medicine images done by other rtns.
+22 SET MAGTYPE=$PIECE($GET(^MAGD(2006.575,MAGIEN,"TYPE")),"^")
IF MAGTYPE'["RAD"
QUIT
+23 IF $DATA(^MAGD(2006.575,MAGIEN,"FIXD"))
IF $PIECE(^MAGD(2006.575,MAGIEN,"FIXD"),"^")
QUIT
+24 IF 'FIRST
SET PREV=MAGIEN
SET PREVS=SUID
SET FIRST=MAGIEN
+25 DO SET^MAGDLB1
+26 QUIT
End DoDot:1
+27 QUIT
SITE(XSITE) ; select a site for which to process entries
+1 ; input: none
+2 ; output: .XSITE site number for which to process entries
+3 ;
+4 ; return: 0 always
+5 ;
+6 NEW CNT,KFIXALL,RESULT,SITES
+7 SET (CNT,XSITE)=0
FOR
SET XSITE=$ORDER(^MAGD(2006.575,"F",XSITE))
if 'XSITE
QUIT
Begin DoDot:1
+8 if '$$FIND1^DIC(4,"","","`"_XSITE)
QUIT
+9 SET CNT=CNT+1
SET SITES(CNT)=XSITE
+10 QUIT
End DoDot:1
+11 if 'CNT
QUIT 0
+12 ;
+13 SET KFIXALL=$$SECKEY
IF '$$MDIV
SET KFIXALL=1
+14 ; If not multi-division set the KFIXALL - site should be able to correct any entry
+15 IF KFIXALL
DO FIX(.SITES,CNT)
QUIT 0
+16 IF $DATA(DUZ(2))
Begin DoDot:1
+17 SET XSITE=DUZ(2)
+18 IF '$DATA(^MAGD(2006.575,"F",XSITE))
WRITE !,"No entries for division "_$$GET1^DIQ(4,+XSITE,".01","E")
+19 QUIT
End DoDot:1
QUIT 0
+20 DO LKUSR(.RESULT,DUZ)
+21 IF '$DATA(RESULT(0))
QUIT 0
+22 IF $PIECE(RESULT(0),"^")=0
WRITE !,$PIECE(RESULT,"^",2)
QUIT 0
+23 ;
+24 NEW EN,II,NSITE,MAGSITE,X
+25 SET (CNT,XSITE)=0
+26 SET X=0
FOR
SET X=$ORDER(SITES(X))
if 'X
QUIT
SET II=$GET(SITES(X))
IF II
SET NSITE(II)=""
+27 SET II=0
+28 FOR
SET II=$ORDER(RESULT(II))
if 'II
QUIT
SET EN=$GET(RESULT(II))
IF $DATA(NSITE(EN))
SET CNT=CNT+1
SET MAGSITE(CNT)=EN
+29 ;no matches
IF 'CNT
QUIT 0
+30 IF CNT=1
SET XSITE=$GET(MAGSITE(1))
QUIT 0
+31 ; select a SITE to fix
DO FIX(.MAGSITE,CNT)
+32 QUIT 0
+33 ;
FIX(SITES,CNT) ;SUBROUTINE - Prepare to fix the entries for the user's division entries.
+1 ; Multiple divisions have images to be corrected and user has appropriate security key.
+2 NEW DIR,I,Y,X
+3 IF 'CNT
QUIT
+4 IF CNT=1
SET SITE=$GET(SITES(CNT))
QUIT
+5 SET I=0
FOR
SET I=$ORDER(SITES(I))
if 'I
QUIT
Begin DoDot:1
+6 WRITE !,I,") ",$GET(SITES(I))," ",$$GET1^DIQ(4,+$GET(SITES(I)),".01","E")
+7 QUIT
End DoDot:1
+8 FOR
Begin DoDot:1
+9 SET DIR(0)="N:1:"_CNT
+10 SET DIR("A",1)="There are images to be corrected for multiple divisions."
+11 SET DIR("A")="Select by number (1-"_CNT_")"
+12 DO ^DIR
+13 if Y>CNT
WRITE " ??"
+14 QUIT
End DoDot:1
if Y'>CNT
QUIT
+15 if Y
SET SITE=$GET(SITES(+Y))
+16 QUIT
+17 ;
SECKEY() ;
+1 NEW MAGKY,MAGRSLT
+2 IF '$DATA(DUZ)
QUIT 0
+3 SET MAGKY("MAGDFIX ALL")="MAGDFIX ALL"
+4 DO OWNSKEY^XUSRB(.MAGRSLT,.MAGKY)
+5 IF +$GET(MAGRSLT("MAGDFIX ALL"))
QUIT 1
+6 QUIT 0
+7 ;
MDIV() ;Multi-divisional flag
+1 NEW CNT,I
+2 SET (CNT,I)=0
+3 FOR
SET I=$ORDER(^MAG(2006.1,I))
if 'I
QUIT
SET CNT=CNT+1
+4 IF CNT>1
QUIT 1
+5 QUIT 0
+6 ;
LKUSR(RESULT,USER) ;
+1 ;RETURNS: 0^Message for failure
+2 ; IENs for Institution file entry^
+3 ; If the user has more than one division and more than one match in the Imaging Site
+4 ; Parameter file, then it returns the 1st matching division entry in the New Person file.
+5 IF $DATA(DUZ(2))
SET RESULT(0)="1^Number of entries"
SET RESULT(DUZ(2))=DUZ(2)
QUIT
+6 NEW MAGARRAY,CNT,MAGERR,MAGOUT,MAGDV,MAGX
+7 SET RESULT(0)="0^Your division entry is not part of the Imaging Site Parameter."
+8 DO GETS^DIQ(200,USER,"16*","I","MAGOUT")
+9 ;MAGOUT(200.02,"institution entry,duz,",.01,"I")=institution entry
+10 IF $DATA(MAGOUT)=0
QUIT
+11 SET MAGX=""
SET CNT=0
+12 FOR
SET MAGX=$ORDER(MAGOUT(200.02,MAGX))
if MAGX=""
QUIT
Begin DoDot:1
+13 SET MAGDV=$PIECE(MAGX,",")
IF $DATA(^MAG(2006.1,"B",MAGDV))
SET CNT=CNT+1
SET MAGARRAY(CNT)=MAGDV
+14 QUIT
End DoDot:1
+15 IF 'CNT
QUIT
+16 SET CNT=0
+17 SET X=0
FOR
SET X=$ORDER(MAGARRAY(X))
if 'X
QUIT
SET CNT=CNT+1
SET RESULT(X)=$PIECE(MAGARRAY(X),"^")
+18 SET RESULT(0)=CNT_"^Number of entries"
+19 ; Get the 1st institution, the calling routine should check for keys.
+20 QUIT
+21 ;
