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

MAGDHPS.m

Go to the documentation of this file.
  1. MAGDHPS ;WOIFO/MLH - Maintain subscriptions to Rad HL7 drivers ;25 Sep 2018 9:47 AM
  1. ;;3.0;IMAGING;**49,183,208**;Mar 19, 2002;Build 6;Apr 07, 2011
  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. ; Supported IA #1373 -- accessing ^ORD(101,"B" & ^ORD(101,D0,"775" (including the "B" xref under 775)
  1. Q
  1. ;
  1. MAGIP208 ; post install entry point to set subscriptions to V2.4 Radiology
  1. N MAG30P208 ; special variable to control non-intractive mode
  1. S MAG30P208=1
  1. ;
  1. MAINT ; MAIN ENTRY POINT - allow the user to select the version of HL7
  1. ; that will be used to create Radiology messages to the VistA Text/
  1. ; DICOM Gateway and to commercial imaging systems.
  1. ;
  1. N MAGPIX ; --- protocol index, either MAGPIXO or MAGPIXR
  1. N MAGPIXO ; -- protocol index for MAGD SEND ORM
  1. N MAGPIXR ; -- protocol index for MAGD SEND ORU
  1. N RADPSTR ; -- Radiology protocol name string
  1. N I ; -------- scratch index variable
  1. N RADPA ; ---- array containing Radiology protocol names and IENs
  1. N RADPEX ; --- exception flag for Radiology protocol name processing
  1. N RADPI ; ---- Radiology protocol IEN
  1. N DA,DIC,DIK,DIR,DTOUT,DUOUT,X,Y ; -- FileMan work variables
  1. N HL7VER ; --- HL7 version desired
  1. ;
  1. W !!,"This option is used to set the Radiology HL7 version for the DICOM Text Gateway."
  1. W !,"The HL7 v2.4 is the default and is recommended because it provides more data."
  1. ; Are there a MAGD SEND ORM and MAGD SEND ORU protocols for us to subscribe?
  1. S MAGPIXO=$O(^ORD(101,"B","MAGD SEND ORM",0))
  1. I MAGPIXO D ; yes
  1. . U IO(0) W !!,"MAGD SEND ORM protocol found..."
  1. . Q
  1. E D G ABEND ; no, bail
  1. . U IO(0) W !!,"ATTENTION: The MAGD SEND ORM protocol does not exist"
  1. . W !,"on this system."
  1. . Q
  1. ;
  1. S MAGPIXR=$O(^ORD(101,"B","MAGD SEND ORU",0))
  1. I MAGPIXR D ; yes
  1. . U IO(0) W !,"MAGD SEND ORU protocol found...",!
  1. . Q
  1. E D G ABEND ; no, bail
  1. . U IO(0) W !!,"ATTENTION: The MAGD SEND ORU protocol does not exist"
  1. . W !,"on this system."
  1. . Q
  1. ;
  1. ; Make sure we have all the Radiology protocols we need.
  1. S RADPSTR="RA CANCEL^RA EXAMINED^RA REG^RA RPT"
  1. F I=1:1:4 S RADPA(I,0)=$P(RADPSTR,"^",I),RADPA(I+4,0)=RADPA(I,0)_" 2.3",RADPA(I+8,0)=RADPA(I,0)_" 2.4"
  1. S RADPEX=0
  1. F I=1:1:12 D G ABEND:RADPEX
  1. . U IO(0) W !,RADPA(I,0)_" protocol "
  1. . S RADPI=$O(^ORD(101,"B",RADPA(I,0),0))
  1. . I RADPI D
  1. . . U IO(0) W "found..."
  1. . . S RADPA(I,1)=RADPI
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXO)) W ?35," MAGD SEND ORM subscribed "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXR)) W ?35," MAGD SEND ORU subscribed"
  1. . . Q
  1. . E D
  1. . . U IO(0) W "not found..."
  1. . . S RADPEX=1
  1. . . Q
  1. . Q
  1. ;
  1. I $G(MAG30P208) S HL7VER=2.4 ; default for MAG*3.0*208 post install
  1. E D G END:$D(DTOUT),END:$D(DUOUT)
  1. . ; Find out which version of HL7 they want to send.
  1. . S DIR(0)="SAX^2.1:HL7 Version 2.1;2.3:HL7 Version 2.3;2.4:HL7 Version 2.4 - Highly Recommended"
  1. . S DIR("A")="Enter the desired version of HL7: "
  1. . U IO(0) W !
  1. . D ^DIR I $D(DTOUT)!$D(DUOUT) Q
  1. . S HL7VER=Y
  1. . Q
  1. ;
  1. U IO(0) W !,"Subscribing to HL7 version "_HL7VER_" Radiology HL7 protocols..."
  1. ;
  1. S RADPEX=0
  1. I HL7VER=2.1 D G ABEND:RADPEX
  1. . ; If 2.1 protocols are already subscribed to, do nothing;
  1. . ; otherwise, subscribe to them.
  1. . F I=1:1:4 D Q:RADPEX
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . S MAGPIX=$S(I=4:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIX)) D
  1. . . . W "is already subscribed to, no action taken"
  1. . . . Q
  1. . . E D ADD(MAGPIX,RADPA(I,1),.RADPEX)
  1. . . W "..."
  1. . . Q
  1. . ; If 2.3 or 2.4 protocols are currently subscribed to, unsubscribe from them;
  1. . ; otherwise, do nothing.
  1. . F I=5:1:12 D
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . ; S MAGPIX=$S(I=8:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXO)) D
  1. . . . D KILL(MAGPIXO,RADPA(I,1))
  1. . . . Q
  1. . . E I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXR)) D
  1. . . . D KILL(MAGPIXR,RADPA(I,1))
  1. . . . Q
  1. . . E D
  1. . . . W "is not currently subscribed to, no action taken"
  1. . . . Q
  1. . . W "..."
  1. . . Q
  1. . Q
  1. ;
  1. I HL7VER=2.3 D G ABEND:RADPEX
  1. . ; If 2.1 or 2.4 protocols are currently subscribed to, unsubscribe from them;
  1. . ; otherwise, do nothing.
  1. . F I=1:1:4,9:1:12 D
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . ; S MAGPIX=$S(I=4:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXO)) D
  1. . . . D KILL(MAGPIXO,RADPA(I,1))
  1. . . . Q
  1. . . E I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXR)) D
  1. . . . D KILL(MAGPIXR,RADPA(I,1))
  1. . . . Q
  1. . . E D
  1. . . . W "is not currently subscribed to, no action taken"
  1. . . . Q
  1. . . W "..."
  1. . . Q
  1. . ; If 2.3 protocols are already subscribed to, do nothing;
  1. . ; otherwise, subscribe to them.
  1. . F I=5:1:8 D Q:RADPEX
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . S MAGPIX=$S(I=8:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIX)) D
  1. . . . W "is already subscribed to, no action taken"
  1. . . . Q
  1. . . E D ADD(MAGPIX,RADPA(I,1),.RADPEX)
  1. . . W "..."
  1. . . Q
  1. . Q
  1. ;
  1. I HL7VER=2.4 D G ABEND:RADPEX
  1. . ; If 2.1 or 2.3 protocols are currently subscribed to, unsubscribe from them;
  1. . ; otherwise, do nothing.
  1. . F I=1:1:8 D
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . ; S MAGPIX=$S(I=4:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXO)) D
  1. . . . D KILL(MAGPIXO,RADPA(I,1))
  1. . . . Q
  1. . . E I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXR)) D
  1. . . . D KILL(MAGPIXR,RADPA(I,1))
  1. . . . Q
  1. . . E D
  1. . . . W "is not currently subscribed to, no action taken"
  1. . . . Q
  1. . . W "..."
  1. . . Q
  1. . ; If 2.4 protocols are already subscribed to, do nothing;
  1. . ; otherwise, subscribe to them.
  1. . F I=9:1:12 D Q:RADPEX
  1. . . ; associate Imaging and Radiology order and report protocols appropriately
  1. . . S MAGPIX=$S(I=12:MAGPIXR,1:MAGPIXO)
  1. . . U IO(0) W !," Protocol "_RADPA(I,0)_" "
  1. . . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIX)) D
  1. . . . W "is already subscribed to, no action taken"
  1. . . . Q
  1. . . E D ADD(MAGPIX,RADPA(I,1),.RADPEX)
  1. . . W "..."
  1. . . Q
  1. . Q
  1. ;
  1. ; P208 PMK 9/24/18
  1. U IO(0)
  1. W !!,"The MAGD SEND ORU protocol should no longer be a subscriber to the RA RPT *"
  1. W !,"event drivers. Vestigial MAGD SEND ORU subscribers to the RA RPT, RA RPT 2.3,"
  1. W !,"and RA RPT 2.4 protocols are now removed.",!
  1. S I=0 F S I=$O(RADPA(I)) Q:'I I RADPA(I,0)?1"RA RPT".E D
  1. . W !,"Protocol ",RADPA(I,0)," "
  1. . I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXO)) D
  1. . . D KILL(MAGPIXR,RADPA(I,1))
  1. . . W "..."
  1. . . Q
  1. . E I $D(^ORD(101,RADPA(I,1),775,"B",MAGPIXR)) D
  1. . . D KILL(MAGPIXR,RADPA(I,1))
  1. . . W "..."
  1. . . Q
  1. . Q
  1. Q
  1. ;
  1. G END
  1. ;
  1. ABEND ; exception raised
  1. U IO(0) W !,"Please contact Imaging Support for further assistance."
  1. END ;
  1. Q
  1. ;
  1. ADD(SUB,EVENTDRV,STATFLAG) ; SUBROUTINE - not to be invoked except from within this routine
  1. ; Subscribe gateway protocol SUB to the Radiology event driver protocol EVENTDRV.
  1. N Y,DIC,DA,X ; -- Fileman variables
  1. S DIC="^ORD(101,"_EVENTDRV_",775,",DIC(0)="L",DA(1)=EVENTDRV,X=SUB
  1. D FILE^DICN
  1. I Y=-1 S STATFLAG=1
  1. W $S('$G(STATFLAG):"has been",1:"could not be")_" subscribed to"
  1. Q
  1. ;
  1. KILL(SUB,EVENTDRV) ; SUBROUTINE - not to be invoked except from within this routine
  1. ; Unsubscribe gateway protocol SUB from the Radiology event driver protocol EVENTDRV.
  1. N DA,DIK ; -- Fileman variables
  1. S DA(1)=EVENTDRV,DA=$O(^ORD(101,DA(1),775,"B",SUB,0))
  1. S DIK="^ORD(101,"_EVENTDRV_",775,"
  1. D ^DIK
  1. W "has been unsubscribed from"
  1. Q