MAGDHOWC ;WOIFO/PMK - Capture Consult/Procedure Request data ;13 Sep 2018 4:01 PM
;;3.0;IMAGING;**138,174,208**;Mar 19, 2002;Build 6;Sep 03, 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. |
;; +---------------------------------------------------------------+
;;
;;
; Supported IA #2056 reference $$GET1^DIQ function call
; Supported IA #10061 reference SDA^VADPT subroutine call
; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
; Supported IA #10040 to read HOSPITAL LOCATION file (#44)
;
ENTRY ;
; determine the kind of message and branch appropriately
N APTSCHED,CPINVOCATION,DEL,DEL2,DEL3,DEL4,DEL5,DFN,FILLER2,GMRCIEN,HL7,HL7MSH,HL7ORC
N I,SERVICE
;
I $D(GMRCMSG) M HL7=GMRCMSG
E I $D(XQORHSTK(0)) M HL7=XQORHSTK(0)
E Q ; can't find HL7 data to handle this!
S HL7MSH=HL7(1)
S DEL=$E(HL7MSH,4),X=$P(HL7MSH,DEL,2)
F I=1:1:$L(X) S @("DEL"_(I+1))=$E(X,I)
;
; find PID segment and get the DFN
S I=0 I '$$FINDSEG^MAGDHOW0(.HL7,"PID",.I,.X) Q ; no PID segment
S DFN=$P(X,DEL,3)
;
; find ORC segment and get GMRCIEN
S I=0 I '$$FINDSEG^MAGDHOW0(.HL7,"ORC",.I,.HL7ORC) Q ; no ORC segment
S GMRCIEN=+$P(HL7ORC,DEL,3) ; GMRC request is in ^GMR(123,GMRCIEN,...)
;
I $$CPORDER^MAGDHOWP(GMRCIEN)="2,UNFINISHED" Q ; don't generate HL7 for new CP orders - P208 PMK 4/24/18
S CPINVOCATION=0 ; Clinical Procedures exam HL7 flag (set to 1 in MAGDHOWP) P208 PMK 4/12/18
;
D ^MAGDTR01 ; update the Read/Unread list with the data from the HL7 message
;
S SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
D APTSCHED(GMRCIEN,SERVICE,.APTSCHED) ; get appointment scheduling information
;
I $P($P(HL7ORC,DEL,16),DEL2,5)="FORWARD" D ; check for a forwarded request
. N FROMSERVICE ; original service
. ; send an order cancellation to the original service
. S FILLER2="GMRC-CANCELLED" ; override actual GMRC status
. S FROMSERVICE=$$FWDFROM^MAGDGMRC(GMRCIEN) ; FORWARDED FROM service
. ;
. ; cancel the original order to the original service
. D MSGSETUP^MAGDHOW1(GMRCIEN,FROMSERVICE,"CA","CA") ; cancel order
. K FILLER2 ; use only for the first cancellation message
. ;
. ; send a new order to the new service
. D MSGSETUP^MAGDHOW1(GMRCIEN,SERVICE,"NW","IP",.APTSCHED) ; new order
. Q
;
E D ; normal processing
. N ORC1,ORC5
. S ORC1=$P(HL7ORC,DEL,1) ; original HL7 message order control
. S ORC5=$P(HL7ORC,DEL,5) ; original HL7 message order status
. D MSGSETUP^MAGDHOW1(GMRCIEN,SERVICE,ORC1,ORC5,.APTSCHED) ; regular transaction
Q
;
APTSCHED(GMRCIEN,SERVICE,APTSCHED) ; get appointment scheduling information
;
; first check if the appointment information is in the comment
I $$CHECKCMT(GMRCIEN,.APTSCHED) Q
;
; no appointment information in the comment
; check if there is an appointment that was previously scheduled
D CHECKAPT(GMRCIEN,SERVICE,.APTSCHED)
Q
;
CHECKCMT(GMRCIEN,APTSCHED) ; check if appointment is scheduled (Patch SD*5.3*478)
N COMMENT,DATETIME,I,SCHEDULE,SS1,SS2,X,Y
K APTSCHED
S SCHEDULE=""
F I=1:1 D Q:DATETIME=""
. S SS1=I_","_GMRCIEN ; subscript for file #123.02
. S DATETIME=$$GET1^DIQ(123.02,SS1,.01) Q:DATETIME=""
. S SS2="1,"_SS1 ; subscript for file #123.25
. S COMMENT=$$GET1^DIQ(123.25,SS2,.01) Q:COMMENT=""
. I COMMENT[" Consult Appt. on " S SCHEDULE=COMMENT
. Q
I SCHEDULE'="" D
. N %DT
. S X=$P(SCHEDULE," Consult Appt. on ",1)
. S Y=$S(X'="":$O(^SC("B",X,"")),1:"") ; clinic name could be null - their bug
. S APTSCHED("CLINIC IEN")=Y ; <file #44 ien>
. S APTSCHED("CLINIC NAME")=X
. S X=$P(SCHEDULE," Consult Appt. on ",2)
. S X=$TR(X," "),%DT="T" D ^%DT ; remove spaces & convert to FM format
. S APTSCHED("FM DATETIME")=Y
. Q
Q (SCHEDULE'="")
;
CHECKAPT(GMRCIEN,SERVICE,APTSCHED) ; check if appointment was previously scheduled
; quite often the appointment is entered before the order is entered
; if this is the case, see if we can find the corresponding appointment
N A,CLINIC,DATETIME,EARLIEST,HIT,I,J,SDAMDFN,SDAMGMRCIEN,SS
;
D SDA^VADPT ; get the list of the appointments
M A=^UTILITY("VASD",$J) K ^UTILITY("VASD",$J)
;
; remove appointments for other clinics
S I=0 F S I=$O(A(I)) Q:'I D
. S CLINIC=$P(A(I,"I"),"^",2)
. I '$$ISCLINIC(GMRCIEN,SERVICE,CLINIC) K A(I)
. Q
; remove appointments for other consult/procedure requests
S (HIT,I)=0 F S I=$O(A(I)) Q:'I D
. S DATETIME=$P(A(I,"I"),"^",1),CLINIC=$P(A(I,"I"),"^",2)
. F J=1:1 D Q:'SDAMDFN
. . S SS=J_","_DATETIME_","_CLINIC
. . S SDAMDFN=$$GET1^DIQ(44.003,SS,.01,"I")
. . I SDAMDFN=DFN D
. . . S SDAMGMRCIEN=$$GET1^DIQ(44.003,SS,688,"I")
. . . I SDAMGMRCIEN=GMRCIEN S HIT=I ; found one for this consult!
. . . E I SDAMGMRCIEN'="" K A(I)
. . . ; keep ones without consult pointer
. . . Q
. . Q
. Q
;
I 'HIT D ; get the earliest possible date for the appointment
. S EARLIEST=$$GET1^DIQ(123,GMRCIEN,17,"I")
. I EARLIEST D
. . S I=0 F S I=$O(A(I)) Q:'I D Q:HIT
. . . I A(I,"I")>EARLIEST S HIT=I
. . . Q
. . Q
. E S HIT=$O(A("")) ; pick the earliest scheduled appointment
. Q
;
I HIT D
. S APTSCHED("FM DATETIME")=$P(A(HIT,"I"),"^",1)
. S APTSCHED("CLINIC IEN")=$P(A(HIT,"I"),"^",2)
. S APTSCHED("DATETIME")=$P(A(HIT,"E"),"^",1)
. S APTSCHED("CLINIC NAME")=$P(A(HIT,"E"),"^",2)
. S FILLER2="GMRC-SCHEDULED" ; over-ride GMRC's status
. ; Note: If the study has been completed, FILLER2 will be killed in
. ; MAGSETUP^MAGHOW1 so that GMRC's actual status will be used.
. Q
Q
;
ISCLINIC(GMRCIEN,SERVICE,CLINIC) ; is a particular clinic defined for a given service?
N IEN,ISCLINIC
S ISCLINIC=0
I GMRCIEN,SERVICE,CLINIC D
. S IEN=$$MWLFIND^MAGDHOW1(SERVICE,GMRCIEN)
. I IEN,$D(^MAG(2006.5831,IEN,1,"B",CLINIC)) S ISCLINIC=1
. Q
Q ISCLINIC
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HMAGDHOWC 6705 printed Sep 23, 2025@19:36:23 Page 2
MAGDHOWC ;WOIFO/PMK - Capture Consult/Procedure Request data ;13 Sep 2018 4:01 PM
+1 ;;3.0;IMAGING;**138,174,208**;Mar 19, 2002;Build 6;Sep 03, 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 ;;
+17 ;;
+18 ; Supported IA #2056 reference $$GET1^DIQ function call
+19 ; Supported IA #10061 reference SDA^VADPT subroutine call
+20 ; Controlled IA #4110 to read REQUEST/CONSULTATION file (#123)
+21 ; Supported IA #10040 to read HOSPITAL LOCATION file (#44)
+22 ;
ENTRY ;
+1 ; determine the kind of message and branch appropriately
+2 NEW APTSCHED,CPINVOCATION,DEL,DEL2,DEL3,DEL4,DEL5,DFN,FILLER2,GMRCIEN,HL7,HL7MSH,HL7ORC
+3 NEW I,SERVICE
+4 ;
+5 IF $DATA(GMRCMSG)
MERGE HL7=GMRCMSG
+6 IF '$TEST
IF $DATA(XQORHSTK(0))
MERGE HL7=XQORHSTK(0)
+7 ; can't find HL7 data to handle this!
IF '$TEST
QUIT
+8 SET HL7MSH=HL7(1)
+9 SET DEL=$EXTRACT(HL7MSH,4)
SET X=$PIECE(HL7MSH,DEL,2)
+10 FOR I=1:1:$LENGTH(X)
SET @("DEL"_(I+1))=$EXTRACT(X,I)
+11 ;
+12 ; find PID segment and get the DFN
+13 ; no PID segment
SET I=0
IF '$$FINDSEG^MAGDHOW0(.HL7,"PID",.I,.X)
QUIT
+14 SET DFN=$PIECE(X,DEL,3)
+15 ;
+16 ; find ORC segment and get GMRCIEN
+17 ; no ORC segment
SET I=0
IF '$$FINDSEG^MAGDHOW0(.HL7,"ORC",.I,.HL7ORC)
QUIT
+18 ; GMRC request is in ^GMR(123,GMRCIEN,...)
SET GMRCIEN=+$PIECE(HL7ORC,DEL,3)
+19 ;
+20 ; don't generate HL7 for new CP orders - P208 PMK 4/24/18
IF $$CPORDER^MAGDHOWP(GMRCIEN)="2,UNFINISHED"
QUIT
+21 ; Clinical Procedures exam HL7 flag (set to 1 in MAGDHOWP) P208 PMK 4/12/18
SET CPINVOCATION=0
+22 ;
+23 ; update the Read/Unread list with the data from the HL7 message
DO ^MAGDTR01
+24 ;
+25 SET SERVICE=$$GET1^DIQ(123,GMRCIEN,1,"I")
+26 ; get appointment scheduling information
DO APTSCHED(GMRCIEN,SERVICE,.APTSCHED)
+27 ;
+28 ; check for a forwarded request
IF $PIECE($PIECE(HL7ORC,DEL,16),DEL2,5)="FORWARD"
Begin DoDot:1
+29 ; original service
NEW FROMSERVICE
+30 ; send an order cancellation to the original service
+31 ; override actual GMRC status
SET FILLER2="GMRC-CANCELLED"
+32 ; FORWARDED FROM service
SET FROMSERVICE=$$FWDFROM^MAGDGMRC(GMRCIEN)
+33 ;
+34 ; cancel the original order to the original service
+35 ; cancel order
DO MSGSETUP^MAGDHOW1(GMRCIEN,FROMSERVICE,"CA","CA")
+36 ; use only for the first cancellation message
KILL FILLER2
+37 ;
+38 ; send a new order to the new service
+39 ; new order
DO MSGSETUP^MAGDHOW1(GMRCIEN,SERVICE,"NW","IP",.APTSCHED)
+40 QUIT
End DoDot:1
+41 ;
+42 ; normal processing
IF '$TEST
Begin DoDot:1
+43 NEW ORC1,ORC5
+44 ; original HL7 message order control
SET ORC1=$PIECE(HL7ORC,DEL,1)
+45 ; original HL7 message order status
SET ORC5=$PIECE(HL7ORC,DEL,5)
+46 ; regular transaction
DO MSGSETUP^MAGDHOW1(GMRCIEN,SERVICE,ORC1,ORC5,.APTSCHED)
End DoDot:1
+47 QUIT
+48 ;
APTSCHED(GMRCIEN,SERVICE,APTSCHED) ; get appointment scheduling information
+1 ;
+2 ; first check if the appointment information is in the comment
+3 IF $$CHECKCMT(GMRCIEN,.APTSCHED)
QUIT
+4 ;
+5 ; no appointment information in the comment
+6 ; check if there is an appointment that was previously scheduled
+7 DO CHECKAPT(GMRCIEN,SERVICE,.APTSCHED)
+8 QUIT
+9 ;
CHECKCMT(GMRCIEN,APTSCHED) ; check if appointment is scheduled (Patch SD*5.3*478)
+1 NEW COMMENT,DATETIME,I,SCHEDULE,SS1,SS2,X,Y
+2 KILL APTSCHED
+3 SET SCHEDULE=""
+4 FOR I=1:1
Begin DoDot:1
+5 ; subscript for file #123.02
SET SS1=I_","_GMRCIEN
+6 SET DATETIME=$$GET1^DIQ(123.02,SS1,.01)
if DATETIME=""
QUIT
+7 ; subscript for file #123.25
SET SS2="1,"_SS1
+8 SET COMMENT=$$GET1^DIQ(123.25,SS2,.01)
if COMMENT=""
QUIT
+9 IF COMMENT[" Consult Appt. on "
SET SCHEDULE=COMMENT
+10 QUIT
End DoDot:1
if DATETIME=""
QUIT
+11 IF SCHEDULE'=""
Begin DoDot:1
+12 NEW %DT
+13 SET X=$PIECE(SCHEDULE," Consult Appt. on ",1)
+14 ; clinic name could be null - their bug
SET Y=$SELECT(X'="":$ORDER(^SC("B",X,"")),1:"")
+15 ; <file #44 ien>
SET APTSCHED("CLINIC IEN")=Y
+16 SET APTSCHED("CLINIC NAME")=X
+17 SET X=$PIECE(SCHEDULE," Consult Appt. on ",2)
+18 ; remove spaces & convert to FM format
SET X=$TRANSLATE(X," ")
SET %DT="T"
DO ^%DT
+19 SET APTSCHED("FM DATETIME")=Y
+20 QUIT
End DoDot:1
+21 QUIT (SCHEDULE'="")
+22 ;
CHECKAPT(GMRCIEN,SERVICE,APTSCHED) ; check if appointment was previously scheduled
+1 ; quite often the appointment is entered before the order is entered
+2 ; if this is the case, see if we can find the corresponding appointment
+3 NEW A,CLINIC,DATETIME,EARLIEST,HIT,I,J,SDAMDFN,SDAMGMRCIEN,SS
+4 ;
+5 ; get the list of the appointments
DO SDA^VADPT
+6 MERGE A=^UTILITY("VASD",$JOB)
KILL ^UTILITY("VASD",$JOB)
+7 ;
+8 ; remove appointments for other clinics
+9 SET I=0
FOR
SET I=$ORDER(A(I))
if 'I
QUIT
Begin DoDot:1
+10 SET CLINIC=$PIECE(A(I,"I"),"^",2)
+11 IF '$$ISCLINIC(GMRCIEN,SERVICE,CLINIC)
KILL A(I)
+12 QUIT
End DoDot:1
+13 ; remove appointments for other consult/procedure requests
+14 SET (HIT,I)=0
FOR
SET I=$ORDER(A(I))
if 'I
QUIT
Begin DoDot:1
+15 SET DATETIME=$PIECE(A(I,"I"),"^",1)
SET CLINIC=$PIECE(A(I,"I"),"^",2)
+16 FOR J=1:1
Begin DoDot:2
+17 SET SS=J_","_DATETIME_","_CLINIC
+18 SET SDAMDFN=$$GET1^DIQ(44.003,SS,.01,"I")
+19 IF SDAMDFN=DFN
Begin DoDot:3
+20 SET SDAMGMRCIEN=$$GET1^DIQ(44.003,SS,688,"I")
+21 ; found one for this consult!
IF SDAMGMRCIEN=GMRCIEN
SET HIT=I
+22 IF '$TEST
IF SDAMGMRCIEN'=""
KILL A(I)
+23 ; keep ones without consult pointer
+24 QUIT
End DoDot:3
+25 QUIT
End DoDot:2
if 'SDAMDFN
QUIT
+26 QUIT
End DoDot:1
+27 ;
+28 ; get the earliest possible date for the appointment
IF 'HIT
Begin DoDot:1
+29 SET EARLIEST=$$GET1^DIQ(123,GMRCIEN,17,"I")
+30 IF EARLIEST
Begin DoDot:2
+31 SET I=0
FOR
SET I=$ORDER(A(I))
if 'I
QUIT
Begin DoDot:3
+32 IF A(I,"I")>EARLIEST
SET HIT=I
+33 QUIT
End DoDot:3
if HIT
QUIT
+34 QUIT
End DoDot:2
+35 ; pick the earliest scheduled appointment
IF '$TEST
SET HIT=$ORDER(A(""))
+36 QUIT
End DoDot:1
+37 ;
+38 IF HIT
Begin DoDot:1
+39 SET APTSCHED("FM DATETIME")=$PIECE(A(HIT,"I"),"^",1)
+40 SET APTSCHED("CLINIC IEN")=$PIECE(A(HIT,"I"),"^",2)
+41 SET APTSCHED("DATETIME")=$PIECE(A(HIT,"E"),"^",1)
+42 SET APTSCHED("CLINIC NAME")=$PIECE(A(HIT,"E"),"^",2)
+43 ; over-ride GMRC's status
SET FILLER2="GMRC-SCHEDULED"
+44 ; Note: If the study has been completed, FILLER2 will be killed in
+45 ; MAGSETUP^MAGHOW1 so that GMRC's actual status will be used.
+46 QUIT
End DoDot:1
+47 QUIT
+48 ;
ISCLINIC(GMRCIEN,SERVICE,CLINIC) ; is a particular clinic defined for a given service?
+1 NEW IEN,ISCLINIC
+2 SET ISCLINIC=0
+3 IF GMRCIEN
IF SERVICE
IF CLINIC
Begin DoDot:1
+4 SET IEN=$$MWLFIND^MAGDHOW1(SERVICE,GMRCIEN)
+5 IF IEN
IF $DATA(^MAG(2006.5831,IEN,1,"B",CLINIC))
SET ISCLINIC=1
+6 QUIT
End DoDot:1
+7 QUIT ISCLINIC
