- 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 Feb 18, 2025@23:26:33 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(""))