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

MAGDAIRF.m

Go to the documentation of this file. 
  1. MAGDAIRF ;WOIFO/PMK - Automatic Import Reconciliation Workflow ; 17 Nov 2009 7:31 AM
  1.  ;;3.0;IMAGING;**53**;Mar 19, 2002;Build 1719;Apr 28, 2010
  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.  ; Populate the OUTSIDE IMAGING LOCATION file (#2006.5759)
  1.  ; This requires No Credit entries in the IMAGING LOCATIONS file (#79.1)
  1.  ;
  1. UPDATE ; update the OUTSIDE IMAGING LOCATION file
  1.  S DTIME=$G(DTIME,300)
  1.  N DIVISION ;------ INSTITUTION file #4 ien
  1.  N IMAGETYPE ;----- IMAGE TYPE file #79.2 ien
  1.  N NOCREDITLOCS ;-- array of IMAGING LOCATIONS with No Credit
  1.  N RADIMGLOC ;----- Radiology IMAGING LOCATIONS file (file 79.1) pointer)
  1.  N ERROR,I,N,X,Y
  1.  S ERROR=$$DISPLAY^MAGDAIRG(1,.NOCREDITLOCS)
  1.  Q:ERROR=-1  ; missing "No Credit" imaging location(s)
  1.  S DIVISION=0
  1.  F  S DIVISION=$O(NOCREDITLOCS(DIVISION)) Q:'DIVISION  D
  1.  . W !!!,"OUTSIDE IMAGING LOCATIONS for ",$$GET1^DIQ(4,DIVISION,.01)
  1.  . W " (",$$GET1^DIQ(4,DIVISION,99),")" S N=$X
  1.  . W ! F I=1:1:N W "-"
  1.  . S IMAGETYPE=""
  1.  . F  S IMAGETYPE=$O(NOCREDITLOCS(DIVISION,IMAGETYPE)) Q:'IMAGETYPE  D
  1.  . . K RADIMGLOC S RADIMGLOC=""
  1.  . . F  S RADIMGLOC=$O(NOCREDITLOCS(DIVISION,IMAGETYPE,RADIMGLOC)) Q:RADIMGLOC=""  D
  1.  . . . S RADIMGLOC(0)=$G(RADIMGLOC(0))+1,RADIMGLOC(RADIMGLOC(0))=RADIMGLOC
  1.  . . . Q
  1.  . . D SELECT(DIVISION,IMAGETYPE,.RADIMGLOC) W !
  1.  . . Q
  1.  . Q
  1.  Q
  1.  ;
  1. SELECT(DIVISION,IMAGETYPE,RADIMGLOC) ; pick IMAGING LOCATION
  1.  N OUTSIDE ; ------ OUTSIDE IMAGING LOCATIONS file #2006.5759 ien
  1.  N ABORT,CHOICE,I,OPTION,PROMPT,QUIT,X
  1.  W !,$$GET1^DIQ(79.2,IMAGETYPE,.01)," -- "
  1.  S OUTSIDE=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,""))
  1.  I $O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,OUTSIDE)) D  Q:ABORT
  1.  . N X
  1.  . S X=$X
  1.  . W "*** Redundant records found! ***"
  1.  . S I="" F  S I=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I)) Q:'I  D
  1.  . . W !,?X,$$GET1^DIQ(2006.5759,I,.01)
  1.  . . Q
  1.  . W !,?X,"*** These must be deleted and replace by a single entry ***"
  1.  . S PROMPT="Proceed",ABORT=1
  1.  . S X=$$YESNO(PROMPT,"y",.CHOICE) Q:X<0
  1.  . I "Nn"[$E(CHOICE) Q
  1.  . S I="" F  S I=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I)) Q:'I  D
  1.  . . D KILL(I) ; remove each entry
  1.  . . Q 
  1.  . S (ABORT,OUTSIDE)=0
  1.  . Q
  1.  I OUTSIDE D  Q:QUIT
  1.  . S QUIT=1
  1.  . W $$GET1^DIQ(2006.5759,OUTSIDE,.01)
  1.  . S PROMPT="Change it"
  1.  . S X=$$YESNO(PROMPT,"n",.CHOICE) Q:X<0
  1.  . I "Nn"[$E(CHOICE) Q
  1.  . D KILL(OUTSIDE)
  1.  . S QUIT=0 ; this will force a drop though to reset the node
  1.  . Q
  1.  E  W "(not defined yet)"
  1.  F I=1:1:RADIMGLOC(0) D
  1.  . S OPTION(I)=$S(RADIMGLOC(0)>1:I_":",1:"")
  1.  . S OPTION(I)=OPTION(I)_$$GET1^DIQ(79.1,RADIMGLOC(I),.01)
  1.  . Q
  1.  I RADIMGLOC(0)>1 D
  1.  . S X=$$CHOOSE("Select location",,.CHOICE,.OPTION) Q:X<0
  1.  . D SET(DIVISION,IMAGETYPE,RADIMGLOC(+CHOICE))
  1.  . Q
  1.  E  D
  1.  . S PROMPT(1)=OPTION(1)
  1.  . S PROMPT="Use this value?"
  1.  . S X=$$YESNO(.PROMPT,"n",.CHOICE) Q:X<0
  1.  . I "Nn"[$E(CHOICE) Q
  1.  . D SET(DIVISION,IMAGETYPE,RADIMGLOC(1))
  1.  . Q
  1.  Q
  1.  ;
  1. SET(DIVISION,IMAGETYPE,RADIMGLOC) ; create the OUTSIDE IMAGING LOCATION fle (#2006.5759) entry
  1.  N DIERR,IENS,MAGERR,MAGFDA,MAGIENS,SC44IEN
  1.  ;
  1.  ; check to see if it already exists
  1.  S MAGIENS=$O(^MAGD(2006.5759,"B",RADIMGLOC,"")) Q:MAGIENS MAGIENS
  1.  ;
  1.  S SC44IEN=$$GET1^DIQ(79.1,RADIMGLOC,.01,"I")
  1.  ;
  1.  S IENS="+1,"
  1.  S MAGFDA(2006.5759,IENS,.01)=RADIMGLOC    ; IMAGING LOCATION
  1.  S MAGFDA(2006.5759,IENS,2)=IMAGETYPE      ; IMAGING TYPE
  1.  S MAGFDA(2006.5759,IENS,3)=SC44IEN        ; HOSPITAL LOCATION
  1.  S MAGFDA(2006.5759,IENS,4)=DIVISION       ; INSTITUTION
  1.  D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
  1.  I $D(DIERR) Q "-3 Entry not created in OUTSIDE IMAGING LOCATION file (#2006.5759)"
  1.  Q MAGIENS(1)
  1.  ;
  1. KILL(OUTSIDE) ; delete the file 2006.5759 entry
  1.  N DA,DIK
  1.  S DIK="^MAGD(2006.5759,",DA=OUTSIDE
  1.  D ^DIK
  1.  Q
  1.  ;
  1. YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
  1.  N DIR,DIRUT,DIROUT,X,Y
  1.  S DIR(0)="Y" S DIR("A")=PROMPT M DIR("A")=PROMPT
  1.  I $G(DEFAULT)'="" S DIR("B")=DEFAULT
  1.  D ^DIR
  1.  I $D(DIROUT) Q -2
  1.  I $D(DIRUT) Q -1
  1.  S CHOICE=Y(0)
  1.  Q 1
  1.  ;
  1. CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
  1.  N DIR,DIRUT,DIROUT,I,X,Y
  1.  S DIR(0)="S^",I=0
  1.  F  S I=$O(OPTION(I)) Q:'I  D
  1.  . S DIR(0)=DIR(0)_$S(I>1:";",1:"")_OPTION(I)
  1.  . Q
  1.  S DIR("A")=PROMPT
  1.  I $G(DEFAULT)'="" S DIR("B")=DEFAULT
  1.  D ^DIR
  1.  I $D(DIROUT) Q -2
  1.  I $D(DIRUT) Q -1
  1.  S CHOICE=Y
  1.  Q 1