MAGDHOW1 ;WOIFO/PMK/DAC - Capture Consult/Procedure Request data ; Jul 26, 2022@07:38:34
;;3.0;IMAGING;**138,174,180,210,208,292,323**;Mar 19, 2002;Build 8
;; 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. |
;; +---------------------------------------------------------------+
;;
;
; Supported IA #10006 reference ^DIC routine call
; Supported IA #2056 reference $$GET1^DIQ function call
; Supported IA #10103 reference $$NOW^XLFDT function call
; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
; Supported IA #6925 to read HLO SUBSCRIPTION REGISTRY (#779.4)
;
MSGSETUP(GMRCIEN,SERVICE,ORC1,ORC5,APTSCHED) ; called by ^MAGDHOWC and ^MAGDHOWS
; setup to send a message, if required
N CONSULT,CPTIEN,DATETIME,DIVISION,FMDATE,FMDATETM
N HL7SUBLIST,I,ITYPCODE,ITYPNAME,MSGTYPE,OBXSEGNO
N ORCTRL,ORSTATUS,ORIGSERV,PARMS,SEGMENT,SENDIT,X,Y,Z
;
S FMDATETM=$$NOW^XLFDT(),FMDATE=FMDATETM\1
S MSGTYPE="ORM" ; HL7 message type for orders
;
; decide if service is one that requires HL7->DICOM gateway and PACS
;
S SENDIT=$$SERVICE(SERVICE,GMRCIEN,.DIVISION,.ITYPNAME,.ITYPCODE,.CPTIEN,.HL7SUBLIST)
;
I SENDIT D ; send this transaction via HL7 to DICOM gateway and PACS
. ; check for an "OK" order control value which indicates a new order
. I ORC1="OK" D
. . S ORCTRL="NW" ; order control
. . S ORSTATUS="IP" ; order status
. . Q
. ;
. ; check for a cancelled or discontinued request
. E I " CA CR DR OC OD "[(" "_ORC1_" ") D
. . ; P210 DAC - Instead of Killing FILLER2, it will now be set to cancelled
. . S FILLER2="GMRC-CANCELLED"
. . S ORCTRL="CA" ; order control
. . S ORSTATUS="CA" ; order status
. . Q
. ;
. ; check for scheduled request (set in ^MAGDHOWS)
. E I ORC1="XO",ORC5="SC" D
. . S ORCTRL="XO" ; order control
. . S ORSTATUS="SC" ; order status
. . Q
. ;
. ; look for a result message
. E I ORC1="RE" D ; result
. . S MSGTYPE="ORU" ; HL7 message type for results
. . ;
. . I (ORC5="A")!($$UNSIGNED^MAGDGMRC(GMRCIEN)) D ; P180 DAC - Process unsigned TIU notes
. . . S FILLER2="GMRC-NEW UNSIGNED RESULT"
. . . S ORCTRL="RE" ; order control
. . . S ORSTATUS="A" ; order status
. . . Q
. . E D ; new signed TIU note
. . . K FILLER2 ; P174 DAC - remove any preset status like GMRC-SCHEDULED set in CHECKAPT^MAGDHOWC
. . . S ORCTRL="RE" ; order control
. . . S ORSTATUS="CM" ; order status
. . . Q
. . Q
. ;
. E D ; default
. . S ORCTRL="SC" ; order control
. . S ORSTATUS="IP" ; order status
. . Q
. D MESSAGE^MAGDHOW2(SERVICE)
. Q
;
I ORC1="RE" D ; do this for all consult results
. ; link any outstanding DICOM images to the new TIU note
. S I=$$NEWTIU^MAGDHOW0(GMRCIEN)
. Q
;
Q
;
SERVICE(SERVICE,GMRCIEN,DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST) ;
; check if the service is in the DICOM Clinical Service dictionary, and
; if so, then get all of the attributes
N MWLCONFIG,SENDIT,X,Y,Z
S (DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST,SENDIT)=0
I SERVICE D ; ignore SERVICE if it is null
. S MWLCONFIG=$$MWLFIND(SERVICE,GMRCIEN)
. S DIVISION=""
. I MWLCONFIG D ; send order
. . S X=$G(^MAG(2006.5831,MWLCONFIG,0))
. . S DIVISION=$P(X,"^",5),CPTIEN=$P(X,"^",6),HL7SUBLIST=$P(X,"^",7)
. . I HL7SUBLIST,$$GET1^DIQ(779.4,HL7SUBLIST,.01)="" S HL7SUBLIST=0 ; absent
. . I 'HL7SUBLIST D ; lookup default HL7 subscription list
. . . N DIC,DO,X,Y
. . . S DIC=779.4,DIC(0)="BX",X="MAGD DEFAULT" D ^DIC
. . . S HL7SUBLIST=$P(Y,"^",1) ; Y should equal "<ien>^MAGD DEFAULT"
. . . Q
. . ; get specialty index and procedure index (if available, otherwise, use 0)
. . S Y=$P(X,"^",3)
. . S ITYPNAME=$P(^MAG(2005.84,Y,0),"^",1)
. . S ITYPCODE=$P($G(^MAG(2005.84,Y,2)),"^",1) ; P323 JCH - Fix undefined abbreviation issue
. . S Z=$P(X,"^",4)
. . I Z D ; get procedure name and code
. . . S ITYPNAME=ITYPNAME_" -- "_$P(^MAG(2005.85,Z,0),"^",1)
. . . S ITYPCODE=ITYPCODE_"/"_$P($G(^MAG(2005.85,Z,2)),"^",1) ; P292 DAC - Fix undefined abbreviation issue
. . . Q
. . S SENDIT=1
. . Q
. Q
Q SENDIT
;
MWLFIND(SERVICE,GMRCIEN) ; lookup 2006.5831 entry by service and procedure
; ordering a procedure and the 2006.5831 procedure entry are optional
N PROCEDURE
S PROCEDURE=+$$GET1^DIQ(123,GMRCIEN,4,"I")
Q $$IREQUEST(SERVICE,PROCEDURE) ; pointer to modality worklist dictionary file #2006.5831
;
IREQUEST(SERVICE,PROCEDURE) ; return the IEN of the consult or procedure for the request service
N IEN,LIST
;
S SERVICE=$G(SERVICE) I 'SERVICE Q 0
;
; if this is a lookup for a procedure, just return the "C" cross reference
S PROCEDURE=$G(PROCEDURE)
I PROCEDURE Q $O(^MAG(2006.5831,"C",SERVICE,PROCEDURE,""))
;
; use the "B" cross reference to make a list of all IENs for the request service
S IEN="" F S IEN=$O(^MAG(2006.5831,"B",SERVICE,IEN)) Q:IEN="" S LIST(IEN)=""
;
; use the "C" cross reference to delete the IENs for the procedures
S PROCEDURE="" F S PROCEDURE=$O(^MAG(2006.5831,"C",SERVICE,PROCEDURE)) Q:PROCEDURE="" D
. S IEN=$O(^MAG(2006.5831,"C",SERVICE,PROCEDURE,""))
. K LIST(IEN) ; remove the procedures from the list
. Q
;
; return what is left in the list, which should be the consult, if there is one
Q $O(LIST(""))
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDHOW1 6170 printed Apr 09, 2024@21:05:37 Page 2
MAGDHOW1 ;WOIFO/PMK/DAC - Capture Consult/Procedure Request data ; Jul 26, 2022@07:38:34
+1 ;;3.0;IMAGING;**138,174,180,210,208,292,323**;Mar 19, 2002;Build 8
+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 ;
+18 ; Supported IA #10006 reference ^DIC routine call
+19 ; Supported IA #2056 reference $$GET1^DIQ function call
+20 ; Supported IA #10103 reference $$NOW^XLFDT function call
+21 ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
+22 ; Supported IA #6925 to read HLO SUBSCRIPTION REGISTRY (#779.4)
+23 ;
MSGSETUP(GMRCIEN,SERVICE,ORC1,ORC5,APTSCHED) ; called by ^MAGDHOWC and ^MAGDHOWS
+1 ; setup to send a message, if required
+2 NEW CONSULT,CPTIEN,DATETIME,DIVISION,FMDATE,FMDATETM
+3 NEW HL7SUBLIST,I,ITYPCODE,ITYPNAME,MSGTYPE,OBXSEGNO
+4 NEW ORCTRL,ORSTATUS,ORIGSERV,PARMS,SEGMENT,SENDIT,X,Y,Z
+5 ;
+6 SET FMDATETM=$$NOW^XLFDT()
SET FMDATE=FMDATETM\1
+7 ; HL7 message type for orders
SET MSGTYPE="ORM"
+8 ;
+9 ; decide if service is one that requires HL7->DICOM gateway and PACS
+10 ;
+11 SET SENDIT=$$SERVICE(SERVICE,GMRCIEN,.DIVISION,.ITYPNAME,.ITYPCODE,.CPTIEN,.HL7SUBLIST)
+12 ;
+13 ; send this transaction via HL7 to DICOM gateway and PACS
IF SENDIT
Begin DoDot:1
+14 ; check for an "OK" order control value which indicates a new order
+15 IF ORC1="OK"
Begin DoDot:2
+16 ; order control
SET ORCTRL="NW"
+17 ; order status
SET ORSTATUS="IP"
+18 QUIT
End DoDot:2
+19 ;
+20 ; check for a cancelled or discontinued request
+21 IF '$TEST
IF " CA CR DR OC OD "[(" "_ORC1_" ")
Begin DoDot:2
+22 ; P210 DAC - Instead of Killing FILLER2, it will now be set to cancelled
+23 SET FILLER2="GMRC-CANCELLED"
+24 ; order control
SET ORCTRL="CA"
+25 ; order status
SET ORSTATUS="CA"
+26 QUIT
End DoDot:2
+27 ;
+28 ; check for scheduled request (set in ^MAGDHOWS)
+29 IF '$TEST
IF ORC1="XO"
IF ORC5="SC"
Begin DoDot:2
+30 ; order control
SET ORCTRL="XO"
+31 ; order status
SET ORSTATUS="SC"
+32 QUIT
End DoDot:2
+33 ;
+34 ; look for a result message
+35 ; result
IF '$TEST
IF ORC1="RE"
Begin DoDot:2
+36 ; HL7 message type for results
SET MSGTYPE="ORU"
+37 ;
+38 ; P180 DAC - Process unsigned TIU notes
IF (ORC5="A")!($$UNSIGNED^MAGDGMRC(GMRCIEN))
Begin DoDot:3
+39 SET FILLER2="GMRC-NEW UNSIGNED RESULT"
+40 ; order control
SET ORCTRL="RE"
+41 ; order status
SET ORSTATUS="A"
+42 QUIT
End DoDot:3
+43 ; new signed TIU note
IF '$TEST
Begin DoDot:3
+44 ; P174 DAC - remove any preset status like GMRC-SCHEDULED set in CHECKAPT^MAGDHOWC
KILL FILLER2
+45 ; order control
SET ORCTRL="RE"
+46 ; order status
SET ORSTATUS="CM"
+47 QUIT
End DoDot:3
+48 QUIT
End DoDot:2
+49 ;
+50 ; default
IF '$TEST
Begin DoDot:2
+51 ; order control
SET ORCTRL="SC"
+52 ; order status
SET ORSTATUS="IP"
+53 QUIT
End DoDot:2
+54 DO MESSAGE^MAGDHOW2(SERVICE)
+55 QUIT
End DoDot:1
+56 ;
+57 ; do this for all consult results
IF ORC1="RE"
Begin DoDot:1
+58 ; link any outstanding DICOM images to the new TIU note
+59 SET I=$$NEWTIU^MAGDHOW0(GMRCIEN)
+60 QUIT
End DoDot:1
+61 ;
+62 QUIT
+63 ;
SERVICE(SERVICE,GMRCIEN,DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST) ;
+1 ; check if the service is in the DICOM Clinical Service dictionary, and
+2 ; if so, then get all of the attributes
+3 NEW MWLCONFIG,SENDIT,X,Y,Z
+4 SET (DIVISION,ITYPNAME,ITYPCODE,CPTIEN,HL7SUBLIST,SENDIT)=0
+5 ; ignore SERVICE if it is null
IF SERVICE
Begin DoDot:1
+6 SET MWLCONFIG=$$MWLFIND(SERVICE,GMRCIEN)
+7 SET DIVISION=""
+8 ; send order
IF MWLCONFIG
Begin DoDot:2
+9 SET X=$GET(^MAG(2006.5831,MWLCONFIG,0))
+10 SET DIVISION=$PIECE(X,"^",5)
SET CPTIEN=$PIECE(X,"^",6)
SET HL7SUBLIST=$PIECE(X,"^",7)
+11 ; absent
IF HL7SUBLIST
IF $$GET1^DIQ(779.4,HL7SUBLIST,.01)=""
SET HL7SUBLIST=0
+12 ; lookup default HL7 subscription list
IF 'HL7SUBLIST
Begin DoDot:3
+13 NEW DIC,DO,X,Y
+14 SET DIC=779.4
SET DIC(0)="BX"
SET X="MAGD DEFAULT"
DO ^DIC
+15 ; Y should equal "<ien>^MAGD DEFAULT"
SET HL7SUBLIST=$PIECE(Y,"^",1)
+16 QUIT
End DoDot:3
+17 ; get specialty index and procedure index (if available, otherwise, use 0)
+18 SET Y=$PIECE(X,"^",3)
+19 SET ITYPNAME=$PIECE(^MAG(2005.84,Y,0),"^",1)
+20 ; P323 JCH - Fix undefined abbreviation issue
SET ITYPCODE=$PIECE($GET(^MAG(2005.84,Y,2)),"^",1)
+21 SET Z=$PIECE(X,"^",4)
+22 ; get procedure name and code
IF Z
Begin DoDot:3
+23 SET ITYPNAME=ITYPNAME_" -- "_$PIECE(^MAG(2005.85,Z,0),"^",1)
+24 ; P292 DAC - Fix undefined abbreviation issue
SET ITYPCODE=ITYPCODE_"/"_$PIECE($GET(^MAG(2005.85,Z,2)),"^",1)
+25 QUIT
End DoDot:3
+26 SET SENDIT=1
+27 QUIT
End DoDot:2
+28 QUIT
End DoDot:1
+29 QUIT SENDIT
+30 ;
MWLFIND(SERVICE,GMRCIEN) ; lookup 2006.5831 entry by service and procedure
+1 ; ordering a procedure and the 2006.5831 procedure entry are optional
+2 NEW PROCEDURE
+3 SET PROCEDURE=+$$GET1^DIQ(123,GMRCIEN,4,"I")
+4 ; pointer to modality worklist dictionary file #2006.5831
QUIT $$IREQUEST(SERVICE,PROCEDURE)
+5 ;
IREQUEST(SERVICE,PROCEDURE) ; return the IEN of the consult or procedure for the request service
+1 NEW IEN,LIST
+2 ;
+3 SET SERVICE=$GET(SERVICE)
IF 'SERVICE
QUIT 0
+4 ;
+5 ; if this is a lookup for a procedure, just return the "C" cross reference
+6 SET PROCEDURE=$GET(PROCEDURE)
+7 IF PROCEDURE
QUIT $ORDER(^MAG(2006.5831,"C",SERVICE,PROCEDURE,""))
+8 ;
+9 ; use the "B" cross reference to make a list of all IENs for the request service
+10 SET IEN=""
FOR
SET IEN=$ORDER(^MAG(2006.5831,"B",SERVICE,IEN))
if IEN=""
QUIT
SET LIST(IEN)=""
+11 ;
+12 ; use the "C" cross reference to delete the IENs for the procedures
+13 SET PROCEDURE=""
FOR
SET PROCEDURE=$ORDER(^MAG(2006.5831,"C",SERVICE,PROCEDURE))
if PROCEDURE=""
QUIT
Begin DoDot:1
+14 SET IEN=$ORDER(^MAG(2006.5831,"C",SERVICE,PROCEDURE,""))
+15 ; remove the procedures from the list
KILL LIST(IEN)
+16 QUIT
End DoDot:1
+17 ;
+18 ; return what is left in the list, which should be the consult, if there is one
+19 QUIT $ORDER(LIST(""))
