MAGDTR01 ;WOIFO/PMK/NST - Unread List for Consult/Procedure Request ; 12 Apr 2012 1:24 AM
;;3.0;IMAGING;**46,127**;Mar 19, 2002;Build 4231;Apr 01, 2013
;; 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. |
;; +---------------------------------------------------------------+
;;
ENTRY ; entry point from ^MAGDHWC for a consult request
N GMRCSTS ;-- GMRC request status
N RESULT ;--- scratch variable
;
; check for an "OK" order control value in the ORC segment
I $P(HL7ORC,DEL)="OK" D Q ; new order
. D ADD^MAGDTR03(.RESULT,GMRCIEN,"O") ; add if "on order" is set
. Q
;
; check for a discontinued order
I " CA CR DC DR OC OD "[(" "_$P(HL7ORC,DEL)_" ") D Q
. D CANCEL^MAGDTR03 ; record the order as cancelled
. Q
;
; check for a FORWARD in the ORC segment
I $P($P(HL7ORC,DEL,16),DEL2,5)="FORWARD" D Q
. D FORWARD^MAGDTR02 ; handle forward for Unread List
. Q
;
; drive it off the GMRC request status
S GMRCSTS=$$GET1^DIQ(123,GMRCIEN,8)
I (GMRCSTS="PENDING")!(GMRCSTS="ACTIVE") D Q
. D ADD^MAGDTR03(.RESULT,GMRCIEN,"O") ; add if "on order" is set
. Q
I GMRCSTS="COMPLETE" D Q
. D COMPLETE^MAGDTR03 ; tag study as completed
. Q
I (GMRCSTS="CANCELLED")!(GMRCSTS="DISCONTINUED") D Q
. D CANCEL^MAGDTR03 ; tag study as cancelled
. Q
Q
;
ORRIN ; entry point for processing IFC responses
N MAGETLVL,$ET
S $ET="D ORRINER1^"_$T(+0),MAGETLVL=$ST+1
D ORRINPRC
Q
;
ORRINER1 ; Log the error
D ^%ZTER
S $ET="D ORRINER2^"_$T(+0)
I $ST>MAGETLVL Q:$Q "" Q
S $EC=""
Q
;
ORRINER2 ; Unwind
I $ST>MAGETLVL Q:$Q "" Q
S $EC=""
Q
;
ORRINPRC ;
; this is "piggy-backed" onto the GMRC IFC ORM EVENT protocol
; see the RESPONSE PROCESSING ROUTINE for this protocol
; the HL7 event handler first invokes ORRIN^GMRCIMSG and then this
;
N GMRCIEN ;-- IEN of consult
N ORDCTRL ;-- order control code from ORC segment
N UNREAD ;--- IEN of entry on ^MAG(2006.5849)
N TIMESTMP ;- FileMan time stamp of unread item
N LISTDATA ;- unread list info from ^MAG(2006.5849)
N ACQSITE ;-- acquisition site
N IPROCIDX ;- procedure index
N ISPECIDX ;- specialty index
;
D GETHL7A^MAGDTR01(.ORDCTRL,.GMRCIEN) Q:ORDCTRL'="OK"
Q:'$$FINDLIST^MAGDTR01(GMRCIEN) ; not in unread list
S UNREAD=$$UNREAD^MAGDTR02(GMRCIEN) Q:'UNREAD ; not there yet
S TIMESTMP=$$TIMESTMP^MAGDTR02(UNREAD) ; update the timestamp
S LISTDATA=^MAG(2006.5849,UNREAD,0)
; record time of IFC response
S:$P(LISTDATA,"^",6)="" $P(^MAG(2006.5849,UNREAD,0),"^",6)=TIMESTMP
; now change status to "Unread", if it was a "Waiting" previously
I $P(LISTDATA,"^",11)="W" D ; switch status and update cross reference
. S $P(^MAG(2006.5849,UNREAD,0),"^",11)="U"
. S ACQSITE=$P(LISTDATA,"^",2),ISPECIDX=$P(LISTDATA,"^",3)
. S IPROCIDX=$P(LISTDATA,"^",4)
. K ^MAG(2006.5849,"D",ACQSITE,ISPECIDX,IPROCIDX,"W",UNREAD)
. S ^MAG(2006.5849,"D",ACQSITE,ISPECIDX,IPROCIDX,"U",UNREAD)=""
. Q
Q
;
GETHL7A(STATUS,GMRCIEN) ; get data from HL7 message - called from above
; input: none
; output: PERSON name of person ordering the consult
; LOCATION IEN of the location from which the consult is ordered
;
N HL7PARSE ;- name of parsed HL7 array defined by GETHL7
N HL7RAW ;--- name of raw HL7 array defined by GETHL7
N HL7SEGNO ;- segment number index returned by $$GETSEG^MAGDHRC0
;
D GETHL7
S (STATUS,GMRCIEN)=""
S HL7SEGNO=$$GETSEG^MAGDHRC0("ORC")
I HL7SEGNO D
. S STATUS=$$GETDATA^MAGDHRC0(1)
. S GMRCIEN=$$GETDATA^MAGDHRC0(2,1,1)
. Q
K @HL7PARSE
Q
;
GETHL7B(PERSON,LOCATION) ; get data from HL7 message - call from ^MAGDTR03
; input: none
; output: PERSON name of person ordering the consult
; LOCATION IEN of the location from which the consult is ordered
;
N HL7PARSE ;- name of parsed HL7 array defined by GETHL7
N HL7RAW ;--- name of raw HL7 array defined by GETHL7
N HL7SEGNO ;- segment number index returned by $$GETSEG^MAGDHRC0
N IPERSON ;-- field number in ORC segment that contains responsible/entered-by person
;
D GETHL7
K PERSON S LOCATION=""
S HL7SEGNO=$$GETSEG^MAGDHRC0("ORC")
; get "responsible person" from ORC-12 or "entered by" person from ORC-10
S IPERSON=$S($$GETDATA^MAGDHRC0(12)="":10,1:12)
S PERSON("FAMILY")=$$GETDATA^MAGDHRC0(IPERSON,1,1)
S PERSON("GIVEN")=$$GETDATA^MAGDHRC0(IPERSON,1,2)
S PERSON("MIDDLE")=$$GETDATA^MAGDHRC0(IPERSON,1,3)
S PERSON("SUFFIX")=$$GETDATA^MAGDHRC0(IPERSON,1,4)
S PERSON=PERSON("FAMILY")
I PERSON("GIVEN")'="" S PERSON=PERSON_","_PERSON("GIVEN")
I PERSON("MIDDLE")'="" S PERSON=PERSON_" "_PERSON("MIDDLE")
I PERSON("SUFFIX")'="" S PERSON=PERSON_" "_PERSON("SUFFIX")
; location of the consult is in OBX-5.3(?)
S HL7SEGNO=$$GETSEG^MAGDHRC0("OBX")
S:HL7SEGNO LOCATION=$$IEN^XUAF4($$GETDATA^MAGDHRC0(5,1,3))
K @HL7PARSE
Q
;
GETHL7 ; get data from HL7 message
; called from above and also called from ^MAGDTR03
;
; returns: HL7PARSE (name of parsed HL7 array)
; HL7RAW (name of array of unparsed HL7 segments)
;
N HLNODE ;--- a full HL7 segment returned by X HLNEXT
N I ;-------- scratch array index
N X ;-------- dummy status return from $$PARSE^MAG7UP
;
S HL7PARSE=$NAME(^TMP("MAG",$J,"HL7","PARSED"))
S HL7RAW="HL7RAW"
K @HL7PARSE ; initialize the destination global
; copy HL7 message from ^TMP to HL7RAW global array
F I=1:1 X HLNEXT Q:HLQUIT'>0 S @HL7RAW@(I)=HLNODE
S X=$$PARSE^MAG7UP(HL7RAW,HL7PARSE) ; build the parsed HL7 array
Q
;
FINDLIST(GMRCIEN,ISPECIDX,IPROCIDX,ACQSITE,TRIGGER,TIUNOTE,ALTSERV) ;
; find the read/unread list for this consult
N CONSPROC,PROC,TOSERV,X,XREF
S (ISPECIDX,IPROCIDX,ACQSITE,TRIGGER,TIUNOTE)=""
Q:'$G(GMRCIEN) 0
S TOSERV=$G(ALTSERV) ; optional argument
I TOSERV="" S TOSERV=+$$GET1^DIQ(123,GMRCIEN,1,"I")
S CONSPROC=$$GET1^DIQ(123,GMRCIEN,13,"I")
S PROC=$S(CONSPROC="C":"",1:$$GET1^DIQ(123,GMRCIEN,4,"I"))
S XREF=$O(^MAG(2006.5841,"AC",TOSERV,+PROC,""))
I 'XREF Q 0 ; no read/unread list
S X=$G(^MAG(2006.5841,XREF,0))
I X="" Q 0 ; record doesn't exist
S ISPECIDX=$P(X,"^",3),IPROCIDX=$P(X,"^",4),ACQSITE=$P(X,"^",5)
S TRIGGER=$P(X,"^",6),TIUNOTE=$P(X,"^",7)
Q XREF
;
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDTR01 7107 printed Apr 09, 2024@21:06:12 Page 2
MAGDTR01 ;WOIFO/PMK/NST - Unread List for Consult/Procedure Request ; 12 Apr 2012 1:24 AM
+1 ;;3.0;IMAGING;**46,127**;Mar 19, 2002;Build 4231;Apr 01, 2013
+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 ;;
ENTRY ; entry point from ^MAGDHWC for a consult request
+1 ;-- GMRC request status
NEW GMRCSTS
+2 ;--- scratch variable
NEW RESULT
+3 ;
+4 ; check for an "OK" order control value in the ORC segment
+5 ; new order
IF $PIECE(HL7ORC,DEL)="OK"
Begin DoDot:1
+6 ; add if "on order" is set
DO ADD^MAGDTR03(.RESULT,GMRCIEN,"O")
+7 QUIT
End DoDot:1
QUIT
+8 ;
+9 ; check for a discontinued order
+10 IF " CA CR DC DR OC OD "[(" "_$PIECE(HL7ORC,DEL)_" ")
Begin DoDot:1
+11 ; record the order as cancelled
DO CANCEL^MAGDTR03
+12 QUIT
End DoDot:1
QUIT
+13 ;
+14 ; check for a FORWARD in the ORC segment
+15 IF $PIECE($PIECE(HL7ORC,DEL,16),DEL2,5)="FORWARD"
Begin DoDot:1
+16 ; handle forward for Unread List
DO FORWARD^MAGDTR02
+17 QUIT
End DoDot:1
QUIT
+18 ;
+19 ; drive it off the GMRC request status
+20 SET GMRCSTS=$$GET1^DIQ(123,GMRCIEN,8)
+21 IF (GMRCSTS="PENDING")!(GMRCSTS="ACTIVE")
Begin DoDot:1
+22 ; add if "on order" is set
DO ADD^MAGDTR03(.RESULT,GMRCIEN,"O")
+23 QUIT
End DoDot:1
QUIT
+24 IF GMRCSTS="COMPLETE"
Begin DoDot:1
+25 ; tag study as completed
DO COMPLETE^MAGDTR03
+26 QUIT
End DoDot:1
QUIT
+27 IF (GMRCSTS="CANCELLED")!(GMRCSTS="DISCONTINUED")
Begin DoDot:1
+28 ; tag study as cancelled
DO CANCEL^MAGDTR03
+29 QUIT
End DoDot:1
QUIT
+30 QUIT
+31 ;
ORRIN ; entry point for processing IFC responses
+1 NEW MAGETLVL,$ETRAP
+2 SET $ETRAP="D ORRINER1^"_$TEXT(+0)
SET MAGETLVL=$STACK+1
+3 DO ORRINPRC
+4 QUIT
+5 ;
ORRINER1 ; Log the error
+1 DO ^%ZTER
+2 SET $ETRAP="D ORRINER2^"_$TEXT(+0)
+3 IF $STACK>MAGETLVL
if $QUIT
QUIT ""
QUIT
+4 SET $ECODE=""
+5 QUIT
+6 ;
ORRINER2 ; Unwind
+1 IF $STACK>MAGETLVL
if $QUIT
QUIT ""
QUIT
+2 SET $ECODE=""
+3 QUIT
+4 ;
ORRINPRC ;
+1 ; this is "piggy-backed" onto the GMRC IFC ORM EVENT protocol
+2 ; see the RESPONSE PROCESSING ROUTINE for this protocol
+3 ; the HL7 event handler first invokes ORRIN^GMRCIMSG and then this
+4 ;
+5 ;-- IEN of consult
NEW GMRCIEN
+6 ;-- order control code from ORC segment
NEW ORDCTRL
+7 ;--- IEN of entry on ^MAG(2006.5849)
NEW UNREAD
+8 ;- FileMan time stamp of unread item
NEW TIMESTMP
+9 ;- unread list info from ^MAG(2006.5849)
NEW LISTDATA
+10 ;-- acquisition site
NEW ACQSITE
+11 ;- procedure index
NEW IPROCIDX
+12 ;- specialty index
NEW ISPECIDX
+13 ;
+14 DO GETHL7A^MAGDTR01(.ORDCTRL,.GMRCIEN)
if ORDCTRL'="OK"
QUIT
+15 ; not in unread list
if '$$FINDLIST^MAGDTR01(GMRCIEN)
QUIT
+16 ; not there yet
SET UNREAD=$$UNREAD^MAGDTR02(GMRCIEN)
if 'UNREAD
QUIT
+17 ; update the timestamp
SET TIMESTMP=$$TIMESTMP^MAGDTR02(UNREAD)
+18 SET LISTDATA=^MAG(2006.5849,UNREAD,0)
+19 ; record time of IFC response
+20 if $PIECE(LISTDATA,"^",6)=""
SET $PIECE(^MAG(2006.5849,UNREAD,0),"^",6)=TIMESTMP
+21 ; now change status to "Unread", if it was a "Waiting" previously
+22 ; switch status and update cross reference
IF $PIECE(LISTDATA,"^",11)="W"
Begin DoDot:1
+23 SET $PIECE(^MAG(2006.5849,UNREAD,0),"^",11)="U"
+24 SET ACQSITE=$PIECE(LISTDATA,"^",2)
SET ISPECIDX=$PIECE(LISTDATA,"^",3)
+25 SET IPROCIDX=$PIECE(LISTDATA,"^",4)
+26 KILL ^MAG(2006.5849,"D",ACQSITE,ISPECIDX,IPROCIDX,"W",UNREAD)
+27 SET ^MAG(2006.5849,"D",ACQSITE,ISPECIDX,IPROCIDX,"U",UNREAD)=""
+28 QUIT
End DoDot:1
+29 QUIT
+30 ;
GETHL7A(STATUS,GMRCIEN) ; get data from HL7 message - called from above
+1 ; input: none
+2 ; output: PERSON name of person ordering the consult
+3 ; LOCATION IEN of the location from which the consult is ordered
+4 ;
+5 ;- name of parsed HL7 array defined by GETHL7
NEW HL7PARSE
+6 ;--- name of raw HL7 array defined by GETHL7
NEW HL7RAW
+7 ;- segment number index returned by $$GETSEG^MAGDHRC0
NEW HL7SEGNO
+8 ;
+9 DO GETHL7
+10 SET (STATUS,GMRCIEN)=""
+11 SET HL7SEGNO=$$GETSEG^MAGDHRC0("ORC")
+12 IF HL7SEGNO
Begin DoDot:1
+13 SET STATUS=$$GETDATA^MAGDHRC0(1)
+14 SET GMRCIEN=$$GETDATA^MAGDHRC0(2,1,1)
+15 QUIT
End DoDot:1
+16 KILL @HL7PARSE
+17 QUIT
+18 ;
GETHL7B(PERSON,LOCATION) ; get data from HL7 message - call from ^MAGDTR03
+1 ; input: none
+2 ; output: PERSON name of person ordering the consult
+3 ; LOCATION IEN of the location from which the consult is ordered
+4 ;
+5 ;- name of parsed HL7 array defined by GETHL7
NEW HL7PARSE
+6 ;--- name of raw HL7 array defined by GETHL7
NEW HL7RAW
+7 ;- segment number index returned by $$GETSEG^MAGDHRC0
NEW HL7SEGNO
+8 ;-- field number in ORC segment that contains responsible/entered-by person
NEW IPERSON
+9 ;
+10 DO GETHL7
+11 KILL PERSON
SET LOCATION=""
+12 SET HL7SEGNO=$$GETSEG^MAGDHRC0("ORC")
+13 ; get "responsible person" from ORC-12 or "entered by" person from ORC-10
+14 SET IPERSON=$SELECT($$GETDATA^MAGDHRC0(12)="":10,1:12)
+15 SET PERSON("FAMILY")=$$GETDATA^MAGDHRC0(IPERSON,1,1)
+16 SET PERSON("GIVEN")=$$GETDATA^MAGDHRC0(IPERSON,1,2)
+17 SET PERSON("MIDDLE")=$$GETDATA^MAGDHRC0(IPERSON,1,3)
+18 SET PERSON("SUFFIX")=$$GETDATA^MAGDHRC0(IPERSON,1,4)
+19 SET PERSON=PERSON("FAMILY")
+20 IF PERSON("GIVEN")'=""
SET PERSON=PERSON_","_PERSON("GIVEN")
+21 IF PERSON("MIDDLE")'=""
SET PERSON=PERSON_" "_PERSON("MIDDLE")
+22 IF PERSON("SUFFIX")'=""
SET PERSON=PERSON_" "_PERSON("SUFFIX")
+23 ; location of the consult is in OBX-5.3(?)
+24 SET HL7SEGNO=$$GETSEG^MAGDHRC0("OBX")
+25 if HL7SEGNO
SET LOCATION=$$IEN^XUAF4($$GETDATA^MAGDHRC0(5,1,3))
+26 KILL @HL7PARSE
+27 QUIT
+28 ;
GETHL7 ; get data from HL7 message
+1 ; called from above and also called from ^MAGDTR03
+2 ;
+3 ; returns: HL7PARSE (name of parsed HL7 array)
+4 ; HL7RAW (name of array of unparsed HL7 segments)
+5 ;
+6 ;--- a full HL7 segment returned by X HLNEXT
NEW HLNODE
+7 ;-------- scratch array index
NEW I
+8 ;-------- dummy status return from $$PARSE^MAG7UP
NEW X
+9 ;
+10 SET HL7PARSE=$NAME(^TMP("MAG",$JOB,"HL7","PARSED"))
+11 SET HL7RAW="HL7RAW"
+12 ; initialize the destination global
KILL @HL7PARSE
+13 ; copy HL7 message from ^TMP to HL7RAW global array
+14 FOR I=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
SET @HL7RAW@(I)=HLNODE
+15 ; build the parsed HL7 array
SET X=$$PARSE^MAG7UP(HL7RAW,HL7PARSE)
+16 QUIT
+17 ;
FINDLIST(GMRCIEN,ISPECIDX,IPROCIDX,ACQSITE,TRIGGER,TIUNOTE,ALTSERV) ;
+1 ; find the read/unread list for this consult
+2 NEW CONSPROC,PROC,TOSERV,X,XREF
+3 SET (ISPECIDX,IPROCIDX,ACQSITE,TRIGGER,TIUNOTE)=""
+4 if '$GET(GMRCIEN)
QUIT 0
+5 ; optional argument
SET TOSERV=$GET(ALTSERV)
+6 IF TOSERV=""
SET TOSERV=+$$GET1^DIQ(123,GMRCIEN,1,"I")
+7 SET CONSPROC=$$GET1^DIQ(123,GMRCIEN,13,"I")
+8 SET PROC=$SELECT(CONSPROC="C":"",1:$$GET1^DIQ(123,GMRCIEN,4,"I"))
+9 SET XREF=$ORDER(^MAG(2006.5841,"AC",TOSERV,+PROC,""))
+10 ; no read/unread list
IF 'XREF
QUIT 0
+11 SET X=$GET(^MAG(2006.5841,XREF,0))
+12 ; record doesn't exist
IF X=""
QUIT 0
+13 SET ISPECIDX=$PIECE(X,"^",3)
SET IPROCIDX=$PIECE(X,"^",4)
SET ACQSITE=$PIECE(X,"^",5)
+14 SET TRIGGER=$PIECE(X,"^",6)
SET TIUNOTE=$PIECE(X,"^",7)
+15 QUIT XREF
+16 ;
