Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: MAGDLB12

MAGDLB12.m

Go to the documentation of this file. 
  1. 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
  1.  ;; Per VHA Directive 2004-038, this routine should not be modified.
  1.  ;; +---------------------------------------------------------------+
  1.  ;; | Property of the US Government.                                |
  1.  ;; | No permission to copy or redistribute this software is given. |
  1.  ;; | Use of unreleased versions of this software requires the user |
  1.  ;; | to execute a written test agreement with the VistA Imaging    |
  1.  ;; | Development Office of the Department of Veterans Affairs,     |
  1.  ;; | telephone (301) 734-0100.                                     |
  1.  ;; | The Food and Drug Administration classifies this software as  |
  1.  ;; | a medical device.  As such, it may not be changed in any way. |
  1.  ;; | Modifications to this software may result in an adulterated   |
  1.  ;; | medical device under 21CFR820, the use of which is considered |
  1.  ;; | to be a violation of US Federal Statutes.                     |
  1.  ;; +---------------------------------------------------------------+
  1.  ;;
  1.  Q
  1. LOOP ;
  1.  N ANS,ANSR,CASENO,COMNT1,DATA,DATA1,DATA2,DATE,FILE,FIRST,FIRSTS
  1.  N MACHID,MAGDY,MAGDIEN,MAGIEN,MAGTYPE,MSG,START,STOP,SUID
  1.  N MOD,MODEL,NEWCAS,NEWDFN,NEWDTI,NEWDTIM,NEWMUL,NEWNME,NEWPIEN,NEWPROC
  1.  N NEWPID,OK,OOUT,OUT,PAT,PID,PP,PREV,PREVS,REASON,SITE,STUDYUID,WHY,MAGFIX
  1.  N KFIXALL ; -- does user hold MAGDFIX ALL security key?
  1.  ;
  1.  S KFIXALL=$$SECKEY()
  1.  S (OOUT,OUT,PREV,FIRST)=0
  1.  ; select a site - bail if no images to correct or no site selected
  1.  S STAT=$$SITE(.SITE) Q:'SITE
  1.  S SUID=0
  1.  F  S SUID=$O(^MAGD(2006.575,"F",SITE,SUID)) Q:SUID=""!(OOUT)  D
  1.  . S MAGIEN=$O(^MAGD(2006.575,"F",SITE,SUID,0)) Q:'MAGIEN
  1.  . ; if image isn't on file, clean up xrefs
  1.  . I '$D(^MAGD(2006.575,MAGIEN,0)) D  Q
  1.  . . K ^MAGD(2006.575,"F",SITE,SUID,MAGIEN)
  1.  . . Q
  1.  . ; if gateway site isn't the user's site, bail unless the user holds
  1.  . ; the MAGDFIX ALL security key
  1.  . I $P($G(^MAGD(2006.575,MAGIEN,1)),U,5)'=DUZ(2),'KFIXALL Q
  1.  . ;Only process Radiology images...medicine images done by other rtns.
  1.  . S MAGTYPE=$P($G(^MAGD(2006.575,MAGIEN,"TYPE")),"^") I MAGTYPE'["RAD" Q
  1.  . I $D(^MAGD(2006.575,MAGIEN,"FIXD")),$P(^MAGD(2006.575,MAGIEN,"FIXD"),"^") Q
  1.  . I 'FIRST S PREV=MAGIEN,PREVS=SUID,FIRST=MAGIEN
  1.  . D SET^MAGDLB1
  1.  . Q
  1.  Q
  1. SITE(XSITE) ; select a site for which to process entries
  1.  ; input:        none
  1.  ; output:   .XSITE   site number for which to process entries
  1.  ; 
  1.  ; return:   0 always
  1.  ; 
  1.  N CNT,KFIXALL,RESULT,SITES
  1.  S (CNT,XSITE)=0 F  S XSITE=$O(^MAGD(2006.575,"F",XSITE)) Q:'XSITE  D
  1.  . Q:'$$FIND1^DIC(4,"","","`"_XSITE)
  1.  . S CNT=CNT+1,SITES(CNT)=XSITE
  1.  . Q
  1.  Q:'CNT 0
  1.  ;
  1.  S KFIXALL=$$SECKEY I '$$MDIV S KFIXALL=1
  1.  ; If not multi-division set the KFIXALL - site should be able to correct any entry
  1.  I KFIXALL D FIX(.SITES,CNT) Q 0
  1.  I $D(DUZ(2)) D  Q 0
  1.  . S XSITE=DUZ(2)
  1.  . I '$D(^MAGD(2006.575,"F",XSITE)) W !,"No entries for division "_$$GET1^DIQ(4,+XSITE,".01","E")
  1.  . Q
  1.  D LKUSR(.RESULT,DUZ)
  1.  I '$D(RESULT(0)) Q 0
  1.  I $P(RESULT(0),"^")=0 W !,$P(RESULT,"^",2) Q 0
  1.  ;
  1.  N EN,II,NSITE,MAGSITE,X
  1.  S (CNT,XSITE)=0
  1.  S X=0 F  S X=$O(SITES(X)) Q:'X  S II=$G(SITES(X)) I II S NSITE(II)=""
  1.  S II=0
  1.  F  S II=$O(RESULT(II)) Q:'II  S EN=$G(RESULT(II)) I $D(NSITE(EN)) S CNT=CNT+1,MAGSITE(CNT)=EN
  1.  I 'CNT Q 0 ;no matches
  1.  I CNT=1 S XSITE=$G(MAGSITE(1)) Q 0
  1.  D FIX(.MAGSITE,CNT) ; select a SITE to fix
  1.  Q 0
  1.  ;
  1. 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.
  1.  N DIR,I,Y,X
  1.  I 'CNT Q
  1.  I CNT=1 S SITE=$G(SITES(CNT)) Q
  1.  S I=0 F  S I=$O(SITES(I)) Q:'I  D
  1.  . W !,I,") ",$G(SITES(I)),"  ",$$GET1^DIQ(4,+$G(SITES(I)),".01","E")
  1.  . Q
  1.  F  D  Q:Y'>CNT
  1.  . S DIR(0)="N:1:"_CNT
  1.  . S DIR("A",1)="There are images to be corrected for multiple divisions."
  1.  . S DIR("A")="Select by number (1-"_CNT_")"
  1.  . D ^DIR
  1.  . W:Y>CNT " ??"
  1.  . Q
  1.  S:Y SITE=$G(SITES(+Y))
  1.  Q
  1.  ;
  1. SECKEY() ;
  1.  N MAGKY,MAGRSLT
  1.  I '$D(DUZ) Q 0
  1.  S MAGKY("MAGDFIX ALL")="MAGDFIX ALL"
  1.  D OWNSKEY^XUSRB(.MAGRSLT,.MAGKY)
  1.  I +$G(MAGRSLT("MAGDFIX ALL")) Q 1
  1.  Q 0
  1.  ;
  1. MDIV() ;Multi-divisional flag
  1.  N CNT,I
  1.  S (CNT,I)=0
  1.  F  S I=$O(^MAG(2006.1,I)) Q:'I  S CNT=CNT+1
  1.  I CNT>1 Q 1
  1.  Q 0
  1.  ;
  1. LKUSR(RESULT,USER) ;
  1.  ;RETURNS: 0^Message for failure
  1.  ;         IENs for Institution file entry^
  1.  ; If the user has more than one division and more than one match in the Imaging Site
  1.  ; Parameter file, then it returns the 1st matching division entry in the New Person file.
  1.  I $D(DUZ(2)) S RESULT(0)="1^Number of entries",RESULT(DUZ(2))=DUZ(2) Q
  1.  N MAGARRAY,CNT,MAGERR,MAGOUT,MAGDV,MAGX
  1.  S RESULT(0)="0^Your division entry is not part of the Imaging Site Parameter."
  1.  D GETS^DIQ(200,USER,"16*","I","MAGOUT")
  1.  ;MAGOUT(200.02,"institution entry,duz,",.01,"I")=institution entry
  1.  I $D(MAGOUT)=0 Q
  1.  S MAGX="",CNT=0
  1.  F  S MAGX=$O(MAGOUT(200.02,MAGX)) Q:MAGX=""  D
  1.  . S MAGDV=$P(MAGX,",") I $D(^MAG(2006.1,"B",MAGDV)) S CNT=CNT+1,MAGARRAY(CNT)=MAGDV
  1.  . Q
  1.  I 'CNT Q
  1.  S CNT=0
  1.  S X=0 F  S X=$O(MAGARRAY(X)) Q:'X  S CNT=CNT+1,RESULT(X)=$P(MAGARRAY(X),"^")
  1.  S RESULT(0)=CNT_"^Number of entries"
  1.  ; Get the 1st institution, the calling routine should check for keys.
  1.  Q
  1.  ;