MAGDAIRF ;WOIFO/PMK - Automatic Import Reconciliation Workflow ; 17 Nov 2009 7:31 AM
;;3.0;IMAGING;**53**;Mar 19, 2002;Build 1719;Apr 28, 2010
;; 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
; Populate the OUTSIDE IMAGING LOCATION file (#2006.5759)
; This requires No Credit entries in the IMAGING LOCATIONS file (#79.1)
;
UPDATE ; update the OUTSIDE IMAGING LOCATION file
S DTIME=$G(DTIME,300)
N DIVISION ;------ INSTITUTION file #4 ien
N IMAGETYPE ;----- IMAGE TYPE file #79.2 ien
N NOCREDITLOCS ;-- array of IMAGING LOCATIONS with No Credit
N RADIMGLOC ;----- Radiology IMAGING LOCATIONS file (file 79.1) pointer)
N ERROR,I,N,X,Y
S ERROR=$$DISPLAY^MAGDAIRG(1,.NOCREDITLOCS)
Q:ERROR=-1 ; missing "No Credit" imaging location(s)
S DIVISION=0
F S DIVISION=$O(NOCREDITLOCS(DIVISION)) Q:'DIVISION D
. W !!!,"OUTSIDE IMAGING LOCATIONS for ",$$GET1^DIQ(4,DIVISION,.01)
. W " (",$$GET1^DIQ(4,DIVISION,99),")" S N=$X
. W ! F I=1:1:N W "-"
. S IMAGETYPE=""
. F S IMAGETYPE=$O(NOCREDITLOCS(DIVISION,IMAGETYPE)) Q:'IMAGETYPE D
. . K RADIMGLOC S RADIMGLOC=""
. . F S RADIMGLOC=$O(NOCREDITLOCS(DIVISION,IMAGETYPE,RADIMGLOC)) Q:RADIMGLOC="" D
. . . S RADIMGLOC(0)=$G(RADIMGLOC(0))+1,RADIMGLOC(RADIMGLOC(0))=RADIMGLOC
. . . Q
. . D SELECT(DIVISION,IMAGETYPE,.RADIMGLOC) W !
. . Q
. Q
Q
;
SELECT(DIVISION,IMAGETYPE,RADIMGLOC) ; pick IMAGING LOCATION
N OUTSIDE ; ------ OUTSIDE IMAGING LOCATIONS file #2006.5759 ien
N ABORT,CHOICE,I,OPTION,PROMPT,QUIT,X
W !,$$GET1^DIQ(79.2,IMAGETYPE,.01)," -- "
S OUTSIDE=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,""))
I $O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,OUTSIDE)) D Q:ABORT
. N X
. S X=$X
. W "*** Redundant records found! ***"
. S I="" F S I=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I)) Q:'I D
. . W !,?X,$$GET1^DIQ(2006.5759,I,.01)
. . Q
. W !,?X,"*** These must be deleted and replace by a single entry ***"
. S PROMPT="Proceed",ABORT=1
. S X=$$YESNO(PROMPT,"y",.CHOICE) Q:X<0
. I "Nn"[$E(CHOICE) Q
. S I="" F S I=$O(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I)) Q:'I D
. . D KILL(I) ; remove each entry
. . Q
. S (ABORT,OUTSIDE)=0
. Q
I OUTSIDE D Q:QUIT
. S QUIT=1
. W $$GET1^DIQ(2006.5759,OUTSIDE,.01)
. S PROMPT="Change it"
. S X=$$YESNO(PROMPT,"n",.CHOICE) Q:X<0
. I "Nn"[$E(CHOICE) Q
. D KILL(OUTSIDE)
. S QUIT=0 ; this will force a drop though to reset the node
. Q
E W "(not defined yet)"
F I=1:1:RADIMGLOC(0) D
. S OPTION(I)=$S(RADIMGLOC(0)>1:I_":",1:"")
. S OPTION(I)=OPTION(I)_$$GET1^DIQ(79.1,RADIMGLOC(I),.01)
. Q
I RADIMGLOC(0)>1 D
. S X=$$CHOOSE("Select location",,.CHOICE,.OPTION) Q:X<0
. D SET(DIVISION,IMAGETYPE,RADIMGLOC(+CHOICE))
. Q
E D
. S PROMPT(1)=OPTION(1)
. S PROMPT="Use this value?"
. S X=$$YESNO(.PROMPT,"n",.CHOICE) Q:X<0
. I "Nn"[$E(CHOICE) Q
. D SET(DIVISION,IMAGETYPE,RADIMGLOC(1))
. Q
Q
;
SET(DIVISION,IMAGETYPE,RADIMGLOC) ; create the OUTSIDE IMAGING LOCATION fle (#2006.5759) entry
N DIERR,IENS,MAGERR,MAGFDA,MAGIENS,SC44IEN
;
; check to see if it already exists
S MAGIENS=$O(^MAGD(2006.5759,"B",RADIMGLOC,"")) Q:MAGIENS MAGIENS
;
S SC44IEN=$$GET1^DIQ(79.1,RADIMGLOC,.01,"I")
;
S IENS="+1,"
S MAGFDA(2006.5759,IENS,.01)=RADIMGLOC ; IMAGING LOCATION
S MAGFDA(2006.5759,IENS,2)=IMAGETYPE ; IMAGING TYPE
S MAGFDA(2006.5759,IENS,3)=SC44IEN ; HOSPITAL LOCATION
S MAGFDA(2006.5759,IENS,4)=DIVISION ; INSTITUTION
D UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
I $D(DIERR) Q "-3 Entry not created in OUTSIDE IMAGING LOCATION file (#2006.5759)"
Q MAGIENS(1)
;
KILL(OUTSIDE) ; delete the file 2006.5759 entry
N DA,DIK
S DIK="^MAGD(2006.5759,",DA=OUTSIDE
D ^DIK
Q
;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
N DIR,DIRUT,DIROUT,X,Y
S DIR(0)="Y" S DIR("A")=PROMPT M DIR("A")=PROMPT
I $G(DEFAULT)'="" S DIR("B")=DEFAULT
D ^DIR
I $D(DIROUT) Q -2
I $D(DIRUT) Q -1
S CHOICE=Y(0)
Q 1
;
CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
N DIR,DIRUT,DIROUT,I,X,Y
S DIR(0)="S^",I=0
F S I=$O(OPTION(I)) Q:'I D
. S DIR(0)=DIR(0)_$S(I>1:";",1:"")_OPTION(I)
. Q
S DIR("A")=PROMPT
I $G(DEFAULT)'="" S DIR("B")=DEFAULT
D ^DIR
I $D(DIROUT) Q -2
I $D(DIRUT) Q -1
S CHOICE=Y
Q 1
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDAIRF 5277 printed Dec 13, 2024@01:59:40 Page 2
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
+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 ; Populate the OUTSIDE IMAGING LOCATION file (#2006.5759)
+19 ; This requires No Credit entries in the IMAGING LOCATIONS file (#79.1)
+20 ;
UPDATE ; update the OUTSIDE IMAGING LOCATION file
+1 SET DTIME=$GET(DTIME,300)
+2 ;------ INSTITUTION file #4 ien
NEW DIVISION
+3 ;----- IMAGE TYPE file #79.2 ien
NEW IMAGETYPE
+4 ;-- array of IMAGING LOCATIONS with No Credit
NEW NOCREDITLOCS
+5 ;----- Radiology IMAGING LOCATIONS file (file 79.1) pointer)
NEW RADIMGLOC
+6 NEW ERROR,I,N,X,Y
+7 SET ERROR=$$DISPLAY^MAGDAIRG(1,.NOCREDITLOCS)
+8 ; missing "No Credit" imaging location(s)
if ERROR=-1
QUIT
+9 SET DIVISION=0
+10 FOR
SET DIVISION=$ORDER(NOCREDITLOCS(DIVISION))
if 'DIVISION
QUIT
Begin DoDot:1
+11 WRITE !!!,"OUTSIDE IMAGING LOCATIONS for ",$$GET1^DIQ(4,DIVISION,.01)
+12 WRITE " (",$$GET1^DIQ(4,DIVISION,99),")"
SET N=$X
+13 WRITE !
FOR I=1:1:N
WRITE "-"
+14 SET IMAGETYPE=""
+15 FOR
SET IMAGETYPE=$ORDER(NOCREDITLOCS(DIVISION,IMAGETYPE))
if 'IMAGETYPE
QUIT
Begin DoDot:2
+16 KILL RADIMGLOC
SET RADIMGLOC=""
+17 FOR
SET RADIMGLOC=$ORDER(NOCREDITLOCS(DIVISION,IMAGETYPE,RADIMGLOC))
if RADIMGLOC=""
QUIT
Begin DoDot:3
+18 SET RADIMGLOC(0)=$GET(RADIMGLOC(0))+1
SET RADIMGLOC(RADIMGLOC(0))=RADIMGLOC
+19 QUIT
End DoDot:3
+20 DO SELECT(DIVISION,IMAGETYPE,.RADIMGLOC)
WRITE !
+21 QUIT
End DoDot:2
+22 QUIT
End DoDot:1
+23 QUIT
+24 ;
SELECT(DIVISION,IMAGETYPE,RADIMGLOC) ; pick IMAGING LOCATION
+1 ; ------ OUTSIDE IMAGING LOCATIONS file #2006.5759 ien
NEW OUTSIDE
+2 NEW ABORT,CHOICE,I,OPTION,PROMPT,QUIT,X
+3 WRITE !,$$GET1^DIQ(79.2,IMAGETYPE,.01)," -- "
+4 SET OUTSIDE=$ORDER(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,""))
+5 IF $ORDER(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,OUTSIDE))
Begin DoDot:1
+6 NEW X
+7 SET X=$X
+8 WRITE "*** Redundant records found! ***"
+9 SET I=""
FOR
SET I=$ORDER(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I))
if 'I
QUIT
Begin DoDot:2
+10 WRITE !,?X,$$GET1^DIQ(2006.5759,I,.01)
+11 QUIT
End DoDot:2
+12 WRITE !,?X,"*** These must be deleted and replace by a single entry ***"
+13 SET PROMPT="Proceed"
SET ABORT=1
+14 SET X=$$YESNO(PROMPT,"y",.CHOICE)
if X<0
QUIT
+15 IF "Nn"[$EXTRACT(CHOICE)
QUIT
+16 SET I=""
FOR
SET I=$ORDER(^MAGD(2006.5759,"D",DIVISION,IMAGETYPE,I))
if 'I
QUIT
Begin DoDot:2
+17 ; remove each entry
DO KILL(I)
+18 QUIT
End DoDot:2
+19 SET (ABORT,OUTSIDE)=0
+20 QUIT
End DoDot:1
if ABORT
QUIT
+21 IF OUTSIDE
Begin DoDot:1
+22 SET QUIT=1
+23 WRITE $$GET1^DIQ(2006.5759,OUTSIDE,.01)
+24 SET PROMPT="Change it"
+25 SET X=$$YESNO(PROMPT,"n",.CHOICE)
if X<0
QUIT
+26 IF "Nn"[$EXTRACT(CHOICE)
QUIT
+27 DO KILL(OUTSIDE)
+28 ; this will force a drop though to reset the node
SET QUIT=0
+29 QUIT
End DoDot:1
if QUIT
QUIT
+30 IF '$TEST
WRITE "(not defined yet)"
+31 FOR I=1:1:RADIMGLOC(0)
Begin DoDot:1
+32 SET OPTION(I)=$SELECT(RADIMGLOC(0)>1:I_":",1:"")
+33 SET OPTION(I)=OPTION(I)_$$GET1^DIQ(79.1,RADIMGLOC(I),.01)
+34 QUIT
End DoDot:1
+35 IF RADIMGLOC(0)>1
Begin DoDot:1
+36 SET X=$$CHOOSE("Select location",,.CHOICE,.OPTION)
if X<0
QUIT
+37 DO SET(DIVISION,IMAGETYPE,RADIMGLOC(+CHOICE))
+38 QUIT
End DoDot:1
+39 IF '$TEST
Begin DoDot:1
+40 SET PROMPT(1)=OPTION(1)
+41 SET PROMPT="Use this value?"
+42 SET X=$$YESNO(.PROMPT,"n",.CHOICE)
if X<0
QUIT
+43 IF "Nn"[$EXTRACT(CHOICE)
QUIT
+44 DO SET(DIVISION,IMAGETYPE,RADIMGLOC(1))
+45 QUIT
End DoDot:1
+46 QUIT
+47 ;
SET(DIVISION,IMAGETYPE,RADIMGLOC) ; create the OUTSIDE IMAGING LOCATION fle (#2006.5759) entry
+1 NEW DIERR,IENS,MAGERR,MAGFDA,MAGIENS,SC44IEN
+2 ;
+3 ; check to see if it already exists
+4 SET MAGIENS=$ORDER(^MAGD(2006.5759,"B",RADIMGLOC,""))
if MAGIENS
QUIT MAGIENS
+5 ;
+6 SET SC44IEN=$$GET1^DIQ(79.1,RADIMGLOC,.01,"I")
+7 ;
+8 SET IENS="+1,"
+9 ; IMAGING LOCATION
SET MAGFDA(2006.5759,IENS,.01)=RADIMGLOC
+10 ; IMAGING TYPE
SET MAGFDA(2006.5759,IENS,2)=IMAGETYPE
+11 ; HOSPITAL LOCATION
SET MAGFDA(2006.5759,IENS,3)=SC44IEN
+12 ; INSTITUTION
SET MAGFDA(2006.5759,IENS,4)=DIVISION
+13 DO UPDATE^DIE("","MAGFDA","MAGIENS","MAGERR")
+14 IF $DATA(DIERR)
QUIT "-3 Entry not created in OUTSIDE IMAGING LOCATION file (#2006.5759)"
+15 QUIT MAGIENS(1)
+16 ;
KILL(OUTSIDE) ; delete the file 2006.5759 entry
+1 NEW DA,DIK
+2 SET DIK="^MAGD(2006.5759,"
SET DA=OUTSIDE
+3 DO ^DIK
+4 QUIT
+5 ;
YESNO(PROMPT,DEFAULT,CHOICE) ; generic YES/NO question driver
+1 NEW DIR,DIRUT,DIROUT,X,Y
+2 SET DIR(0)="Y"
SET DIR("A")=PROMPT
MERGE DIR("A")=PROMPT
+3 IF $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
+4 DO ^DIR
+5 IF $DATA(DIROUT)
QUIT -2
+6 IF $DATA(DIRUT)
QUIT -1
+7 SET CHOICE=Y(0)
+8 QUIT 1
+9 ;
CHOOSE(PROMPT,DEFAULT,CHOICE,OPTION) ; generic question driver
+1 NEW DIR,DIRUT,DIROUT,I,X,Y
+2 SET DIR(0)="S^"
SET I=0
+3 FOR
SET I=$ORDER(OPTION(I))
if 'I
QUIT
Begin DoDot:1
+4 SET DIR(0)=DIR(0)_$SELECT(I>1:";",1:"")_OPTION(I)
+5 QUIT
End DoDot:1
+6 SET DIR("A")=PROMPT
+7 IF $GET(DEFAULT)'=""
SET DIR("B")=DEFAULT
+8 DO ^DIR
+9 IF $DATA(DIROUT)
QUIT -2
+10 IF $DATA(DIRUT)
QUIT -1
+11 SET CHOICE=Y
+12 QUIT 1
