SDHL7CON ;MS/TG/MS/PB - TMP HL7 Routine;JULY 05, 2018
;;5.3;Scheduling;**704,773,812,858**;May 29, 2018;Build 2
;
; Integration Agreements:
;
;SD*5.3*773 - Removed unused function TMCONV
;SD*5.3*812 - Removed code that sent AA for "No consults found" and then quit the process
;SD*5.3*858 - Filter out a MRTC type RTC from being returned to TMP till a future patch restores this feature.
Q
;
PARSEQ13 ;Process QBP^Q13 messages from the "TMP VISTA" Subscriber protocol
;
; This routine and subroutines assume that all VistA HL7 environment
; variables are properly initialized and will produce a fatal error
; if they are missing.
;
; The message will be checked to see if it is a valid query.
; If not a negative acknowledgement will be sent. If the query is an
; immediate mode or synchronous query, the realtime request manager
; is called to handle the query. This means the query will be
; processed and a response generated immediately.
; In the future deferred mode queries may be filed in a database for
; later processing, or transmission.
;
; Input:
; HL7 environment variables
;
; Output:
; Processed query or negative acknowledgement
; If handled real-time the query response is generated
;
; Integration Agreements
;
N MSGROOT,DATAROOT,QRY,XMT,ERR,RNAME,IX
S (MSGROOT,QRY,XMT,ERR,RNAME)=""
; Inbound query messages are small enough to be held in a local.
; The following lines commented out support use of global and are
; left in case use a global becomes necessary.
;
S MSGROOT="SDHL7MSG"
K @MSGROOT
N EIN
S EIN=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
;
D LOADXMT(.HL,.XMT) ;Load inbound message information
S RNAME=XMT("MESSAGE TYPE")_"-"_XMT("EVENT TYPE")_" RECEIVER"
;
N CNT,SEG
K @MSGROOT
D LOADMSG(MSGROOT)
;
D PARSEMSG(MSGROOT,.HL)
;
I '$$VALIDMSG(MSGROOT,.QRY,.XMT,.ERR) D Q
. D SENDERR(ERR)
. K @MSGROOT
. Q
;
N CNT,RDT,HIT,EXTIME,RDF,QPD,QRYDFN,MSGCONID,LST,MYRESULT,HLA,RTCLST
;
S (MSGCONID,QRYDFN)=""
S CNT=1
;
F Q:'$D(@MSGROOT@(CNT)) D S CNT=CNT+1
. S SEGTYPE=$G(@MSGROOT@(CNT,0))
. I SEGTYPE="QPD" M QPD=@MSGROOT@(CNT) S QRYDFN=$G(@MSGROOT@(CNT,3)) Q
. I SEGTYPE="RDF" M RDF=@MSGROOT@(CNT) Q
. I SEGTYPE="MSH" S MSGCONID=$G(@MSGROOT@(CNT,9)) Q
. Q
;
I QRYDFN="" D Q
. S ERR="QPD^1^^100^AE^No DFN value sent"
. D SENDERR(ERR)
. K @MSGROOT
. Q
;
I '$D(^DPT(QRYDFN,0)) D Q
. S ERR="QPD^1^^100^AE^Undefined DFN"
. D SENDERR(ERR)
. K @MSGROOT
. Q
S DATAROOT=$NA(^TMP("ORQQCN",$J,"CS"))
K @DATAROOT
D LIST(.LST,QRYDFN)
D RTCLIST(.RTCLST,QRYDFN)
;
S HIT=0,EXTIME=""
;
;****BUILD THE RESPONSE MSG
K @MSGROOT
;
D INIT^HLFNC2(EIN,.HL)
S HL("FS")="|",HL("ECH")="^~\&"
;
N ERR,LEN S ERR=""
N FOUNDCN
S FOUNDCN=0
S CNT=1,@MSGROOT@(CNT)=$$MSA^SDTMBUS($G(HL("MID")),ERR,.HL),LEN=$L(@MSGROOT@(CNT))
S CNT=CNT+1,@MSGROOT@(CNT)=$$QAK^SDTMBUS(.HL,""),LEN=LEN+$L(@MSGROOT@(CNT))
S CNT=CNT+1,@MSGROOT@(CNT)=$$BLDSEG^SDHL7UL(.QPD,.HL),LEN=LEN+$L(@MSGROOT@(CNT))
S CNT=CNT+1,@MSGROOT@(CNT)=$$BLDSEG^SDHL7UL(.RDF,.HL),LEN=LEN+$L(@MSGROOT@(CNT))
I '$P(ERR,"^",4) D
. Q:DATAROOT=""
. D @("RDT^SDTMBUS"_"(MSGROOT,DATAROOT,.CNT,.LEN,.HL,.FOUNDCN)")
. D RTCRDT^SDTMBUS(MSGROOT,RTCLST,.CNT,.LEN,.HL)
. Q
;
F IX=1:1:CNT S HLA("HLS",IX)=$G(@MSGROOT@(IX))
;
M HLA("HLA")=HLA("HLS")
;
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
;
D RESET^SDHL7UL ;Clean up TMP used by logging
K @DATAROOT,@MSGROOT
;
Q
;
VALIDMSG(MSGROOT,QRY,XMT,ERR) ;Validate message
;
; Messages handled: QBP^Q13
;
; QBP query messages must contain QPD and RCP segments
; Any additional segments are ignored
;
; Input:
; MSGROOT - Root of array holding message
; XMT - Transmission parameters
;
; Output:
; QRY - Query Array
; XMT - Transmission parameters
; ERR - segment^sequence^field^code^ACK type^error text
;
N MSH,QPD,REQID,REQTYPE,QTAG,QNAME,RDF
N SEGTYPE,CNT
K QRY,ERR
S ERR=""
;
; Set up basics for responding to message.
;-----------------------------------------
S QRY("MID")=XMT("MID") ;Message ID
S QRY("QPD")=""
;
; Validate message is a well-formed QBP query message.
;-----------------------------------------------------------
; Must have MSH first, followed by QPD,RCP in any order
; PID and STF are optional. All other segments are ignored.
;
I $G(@MSGROOT@(1,0))="MSH" M MSH=@MSGROOT@(1)
E S ERR="MSH^1^^100^AE^Missing MSH segment" Q 0
;
S CNT=2
F Q:'$D(@MSGROOT@(CNT)) D S CNT=CNT+1
. S SEGTYPE=$G(@MSGROOT@(CNT,0))
. I SEGTYPE="QPD" M QPD=@MSGROOT@(CNT),QRY("QPD")=QPD Q
. I SEGTYPE="RDF" M RDF=@MSGROOT@(CNT) Q
. Q
;
I '$D(QPD) S ERR="QPD^1^^100^AE^Missing QPD segment" Q 0
;
S QTAG=$G(QPD(1,1,2)) ;Query Tag
S REQID=$G(QPD(2)) ;Request ID
S REQTYPE=$G(QPD(3,1,1)) ;Request Type
S:REQTYPE="" REQTYPE=$G(QPD(3)) ;Request Type if no other params
;
; Validate required fields and query parameters
;------------------------------------------------------
;
; Check for missing/invalid fields
;
I '$D(QPD(1)) S ERR="QPD^1^1^101^AE^Missing Message Query Name" Q 0
;
I QTAG="" S ERR="QPD^1^2^101^AE^Missing Query Tag" Q 0
I REQID="" S ERR="QPD^1^2^101^AE^Missing Request ID" Q 0
S (QRY("DCLSNM"),QRY("DFN"))=""
S QRY("REQID")=REQID
;
I REQTYPE="" S ERR="QPD^1^3^101^AE^Missing Request Type" Q 0
;
Q 1
;
LOADXMT(HL,XMT) ;Set HL dependent XMT values
;
; The HL array and variables are expected to be defined. If not,
; message processing will fail. These references should not be
; wrapped in $G, as null values will simply postpone the failure to
; a point that will be harder to diagnose. Except HL("APAT") which
; is not defined on synchronous calls.
;
; Integration Agreements:
; 1373 : Reference to PROTOCOL file #101
;
N SUBPROT,RESPIEN,RESP0
S HL("EID")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
S HL("EIDS")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Subscriber")
S XMT("MID")=HL("MID") ;Message ID
S XMT("MODE")="A" ;Response mode
I $G(HL("APAT"))="" S XMT("MODE")="S" ;Synchronous mode
S XMT("MESSAGE TYPE")=HL("MTN") ;Message type
S XMT("EVENT TYPE")=HL("ETN") ;Event type
S XMT("DELIM")=HL("FS")_HL("ECH") ;HL Delimiters
;S XMT("DELIM")="~^\&"
S XMT("MAX SIZE")=0 ;Default size unlimited
;
; Map response protocol and builder
S SUBPROT=$P(^ORD(101,HL("EIDS"),0),"^")
Q
LIST(SDY,SDPT,SDSDT,SDEDT,SDSERV,SDSTATUS) ; return patient's consult requests between start date and stop date for the service and status indicated:
N I,J,SITE,SEQ,DIFF,SDSRV,ORLOC,GMRCOER
S J=1,SEQ="",GMRCOER=2
S:'$L($G(SDSDT)) SDSDT=""
S:'$L($G(SDEDT)) SDEDT=""
S:'$L($G(SDSERV))!(+$G(SDSERV)=0) SDSERV=""
S:'$L($G(SDSTATUS)) SDSTATUS="" ;ALL STATI
K ^TMP("GMRCR",$J)
S SDY=$NA(^TMP("ORQQCN",$J,"CS"))
D OER^GMRCSLM1(SDPT,SDSERV,SDSDT,SDEDT,SDSTATUS,GMRCOER)
M @SDY=^TMP("GMRCR",$J,"CS")
K @SDY@("AD")
K @SDY@(0)
K ^TMP("GMRCR",$J)
Q
RTCLIST(SDY,SDPT,SDSDT,SDEDT) ; return patient's "Return to Clinic" appointment requests
;SDY = return global
;SDPT = dfn of patient
;SDSDT = start date (based on CREATE DATE of request)
;SDEDT = end date (based on END DATE of request)
N IDX,IEN,SDEC0,REQDT,CNT,CLINID,CID,STOP,PRVID,CMTS,MRTC,RTCINT,RTCINT,RTCPAR
S SDY=$NA(^TMP("SDHL7CON",$J,"RTCLIST")) K @SDY
S SDSDT=$G(SDSDT,"ALL"),SDEDT=$G(SDEDT),CNT=0
Q:'$G(SDPT) ; Return nothing if no patient passed
S IDX=$NA(^SDEC(409.85,"B",SDPT)),IEN=0
F S IEN=$O(@IDX@(IEN)) Q:'$G(IEN) D
. K RTCINT,MRTC,RTCPAR,SDEC0,CLINID,CID,PRVID,CMTS,CLINNM,STOP
. S SDEC0=$G(^SDEC(409.85,IEN,0))
. I $P(SDEC0,U,5)'="RTC" Q
. I $P(SDEC0,U,17)'="O" Q
. S REQDT=$P(SDEC0,U,2) I SDSDT'="ALL",$P(REQDT,".",1)<SDSDT!($P(REQDT,".",1)>SDEDT) Q
. S CLINID=$P(SDEC0,U,9),CID=$P(SDEC0,U,16),PRVID=$P(SDEC0,U,13),CMTS=$P(SDEC0,U,18),CMTS=$E(CMTS,1,80)
. S:$P($G(^SDEC(409.85,IEN,3)),"^")=1 MRTC=$P($G(^SDEC(409.85,IEN,3)),"^",3),RTCINT=$P($G(^SDEC(409.85,IEN,3)),"^",2),RTCPAR=$P($G(^SDEC(409.85,IEN,3)),"^",5)
. S:$G(RTCPAR)="" RTCPAR=IEN
. S:$G(MRTC)="" MRTC=0 S:$G(RTCINT)="" RTCINT=0
. Q:$P($G(^SDEC(409.85,IEN,3)),U,1) ;858 this Requests rec is MRTC related do not return.
. I +CLINID D
. . S CLINNM=$$GET1^DIQ(44,CLINID_",",".01")
. . S STOP=$$GET1^DIQ(44,CLINID_",",8)_","_$$GET1^DIQ(44,CLINID_",",2503)
. S CNT=CNT+1,@SDY@(CNT)=IEN_U_REQDT_U_CLINID_U_CID_U_PRVID_U_CMTS_U_$G(MRTC)_U_$G(RTCINT)_U_$G(RTCPAR)
S @SDY=CNT
Q
PARSESEG(SEG,DATA,HL) ;Generic segment parser
;This procedure parses a single HL7 segment and builds an array
;subscripted by the field number containing the data for that field.
; Does not handle segments that span nodes
;
; Input:
; SEG - HL7 segment to parse
; HL - HL7 environment array
;
; Output:
; Function value - field data array [SUB1:field, SUB2:repetition,
; SUB3:component, SUB4:sub-component]
;
N CMP ;component subscript
N CMPVAL ;component value
N FLD ;field subscript
N FLDVAL ;field value
N REP ;repetition subscript
N REPVAL ;repetition value
N SUB ;sub-component subscript
N SUBVAL ;sub-component value
N FS ;field separator
N CS ;component separator
N RS ;repetition separator
N SS ;sub-component separator
;
K DATA
S FS=HL("FS")
S CS=$E(HL("ECH"))
S RS=$E(HL("ECH"),2)
S SS=$E(HL("ECH"),4)
;
S DATA(0)=$P(SEG,FS)
S SEG=$P(SEG,FS,2,9999)
;
F FLD=1:1:$L(SEG,FS) D
. S FLDVAL=$P(SEG,FS,FLD)
. F REP=1:1:$L(FLDVAL,RS) D
. . S REPVAL=$P(FLDVAL,RS,REP)
. . I REPVAL[CS F CMP=1:1:$L(REPVAL,CS) D
. . . S CMPVAL=$P(REPVAL,CS,CMP)
. . . I CMPVAL[SS F SUB=1:1:$L(CMPVAL,SS) D
. . . . S SUBVAL=$P(CMPVAL,SS,SUB)
. . . . I SUBVAL'="" S DATA(FLD,REP,CMP,SUB)=SUBVAL
. . . I '$D(DATA(FLD,REP,CMP)),CMPVAL'="" S DATA(FLD,REP,CMP)=CMPVAL
. . I '$D(DATA(FLD,REP)),REPVAL'="",FLDVAL[RS S DATA(FLD,REP)=REPVAL
. I '$D(DATA(FLD)),FLDVAL'="" S DATA(FLD)=FLDVAL
Q
;
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
;
;This subroutine assumes that all VistA HL7 environment variables are
;properly initialized and will produce a fatal error if they aren't.
;
N CNT,SEG
K @MSGROOT
F SEG=1:1 X HLNEXT Q:HLQUIT'>0 D
. S CNT=0
. S @MSGROOT@(SEG,CNT)=HLNODE
. F S CNT=$O(HLNODE(CNT)) Q:'CNT S @MSGROOT@(SEG,CNT)=HLNODE(CNT)
Q
;
PARSEMSG(MSGROOT,HL) ; Message Parser
; Does not handle segments that span nodes
; Does not handle extremely long segments (uses a local)
; Does not handle long fields (segment parser doesn't)
;
N SEG,CNT,DATA,MSG
F CNT=1:1 Q:'$D(@MSGROOT@(CNT)) M SEG=@MSGROOT@(CNT) D
. D PARSESEG(SEG(0),.DATA,.HL)
. K @MSGROOT@(CNT)
. I DATA(0)'="" M @MSGROOT@(CNT)=DATA
. Q:'$D(SEG(1))
. ;
. Q
Q
SENDERR(ERR) ; Send for unsuccessful response
K @MSGROOT
D INIT^HLFNC2(EIN,.HL)
S HL("FS")="|",HL("ECH")="^~\&"
S CNT=1,@MSGROOT@(CNT)=$$MSA^SDTMBUS($G(HL("MID")),ERR,.HL),LEN=$L(@MSGROOT@(CNT))
S CNT=CNT+1,@MSGROOT@(CNT)=$$QAK^SDTMBUS(.HL,ERR),LEN=LEN+$L(@MSGROOT@(CNT))
F IX=1:1:CNT S HLA("HLS",IX)=$G(@MSGROOT@(IX))
M HLA("HLA")=HLA("HLS")
D GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
Q
--- Routine Detail --- with STRUCTURED ROUTINE LISTING ---[H[J[2J[HSDHL7CON 11444 printed Apr 09, 2024@21:50:22 Page 2
SDHL7CON ;MS/TG/MS/PB - TMP HL7 Routine;JULY 05, 2018
+1 ;;5.3;Scheduling;**704,773,812,858**;May 29, 2018;Build 2
+2 ;
+3 ; Integration Agreements:
+4 ;
+5 ;SD*5.3*773 - Removed unused function TMCONV
+6 ;SD*5.3*812 - Removed code that sent AA for "No consults found" and then quit the process
+7 ;SD*5.3*858 - Filter out a MRTC type RTC from being returned to TMP till a future patch restores this feature.
+8 QUIT
+9 ;
PARSEQ13 ;Process QBP^Q13 messages from the "TMP VISTA" Subscriber protocol
+1 ;
+2 ; This routine and subroutines assume that all VistA HL7 environment
+3 ; variables are properly initialized and will produce a fatal error
+4 ; if they are missing.
+5 ;
+6 ; The message will be checked to see if it is a valid query.
+7 ; If not a negative acknowledgement will be sent. If the query is an
+8 ; immediate mode or synchronous query, the realtime request manager
+9 ; is called to handle the query. This means the query will be
+10 ; processed and a response generated immediately.
+11 ; In the future deferred mode queries may be filed in a database for
+12 ; later processing, or transmission.
+13 ;
+14 ; Input:
+15 ; HL7 environment variables
+16 ;
+17 ; Output:
+18 ; Processed query or negative acknowledgement
+19 ; If handled real-time the query response is generated
+20 ;
+21 ; Integration Agreements
+22 ;
+23 NEW MSGROOT,DATAROOT,QRY,XMT,ERR,RNAME,IX
+24 SET (MSGROOT,QRY,XMT,ERR,RNAME)=""
+25 ; Inbound query messages are small enough to be held in a local.
+26 ; The following lines commented out support use of global and are
+27 ; left in case use a global becomes necessary.
+28 ;
+29 SET MSGROOT="SDHL7MSG"
+30 KILL @MSGROOT
+31 NEW EIN
+32 SET EIN=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
+33 ;
+34 ;Load inbound message information
DO LOADXMT(.HL,.XMT)
+35 SET RNAME=XMT("MESSAGE TYPE")_"-"_XMT("EVENT TYPE")_" RECEIVER"
+36 ;
+37 NEW CNT,SEG
+38 KILL @MSGROOT
+39 DO LOADMSG(MSGROOT)
+40 ;
+41 DO PARSEMSG(MSGROOT,.HL)
+42 ;
+43 IF '$$VALIDMSG(MSGROOT,.QRY,.XMT,.ERR)
Begin DoDot:1
+44 DO SENDERR(ERR)
+45 KILL @MSGROOT
+46 QUIT
End DoDot:1
QUIT
+47 ;
+48 NEW CNT,RDT,HIT,EXTIME,RDF,QPD,QRYDFN,MSGCONID,LST,MYRESULT,HLA,RTCLST
+49 ;
+50 SET (MSGCONID,QRYDFN)=""
+51 SET CNT=1
+52 ;
+53 FOR
if '$DATA(@MSGROOT@(CNT))
QUIT
Begin DoDot:1
+54 SET SEGTYPE=$GET(@MSGROOT@(CNT,0))
+55 IF SEGTYPE="QPD"
MERGE QPD=@MSGROOT@(CNT)
SET QRYDFN=$GET(@MSGROOT@(CNT,3))
QUIT
+56 IF SEGTYPE="RDF"
MERGE RDF=@MSGROOT@(CNT)
QUIT
+57 IF SEGTYPE="MSH"
SET MSGCONID=$GET(@MSGROOT@(CNT,9))
QUIT
+58 QUIT
End DoDot:1
SET CNT=CNT+1
+59 ;
+60 IF QRYDFN=""
Begin DoDot:1
+61 SET ERR="QPD^1^^100^AE^No DFN value sent"
+62 DO SENDERR(ERR)
+63 KILL @MSGROOT
+64 QUIT
End DoDot:1
QUIT
+65 ;
+66 IF '$DATA(^DPT(QRYDFN,0))
Begin DoDot:1
+67 SET ERR="QPD^1^^100^AE^Undefined DFN"
+68 DO SENDERR(ERR)
+69 KILL @MSGROOT
+70 QUIT
End DoDot:1
QUIT
+71 SET DATAROOT=$NAME(^TMP("ORQQCN",$JOB,"CS"))
+72 KILL @DATAROOT
+73 DO LIST(.LST,QRYDFN)
+74 DO RTCLIST(.RTCLST,QRYDFN)
+75 ;
+76 SET HIT=0
SET EXTIME=""
+77 ;
+78 ;****BUILD THE RESPONSE MSG
+79 KILL @MSGROOT
+80 ;
+81 DO INIT^HLFNC2(EIN,.HL)
+82 SET HL("FS")="|"
SET HL("ECH")="^~\&"
+83 ;
+84 NEW ERR,LEN
SET ERR=""
+85 NEW FOUNDCN
+86 SET FOUNDCN=0
+87 SET CNT=1
SET @MSGROOT@(CNT)=$$MSA^SDTMBUS($GET(HL("MID")),ERR,.HL)
SET LEN=$LENGTH(@MSGROOT@(CNT))
+88 SET CNT=CNT+1
SET @MSGROOT@(CNT)=$$QAK^SDTMBUS(.HL,"")
SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
+89 SET CNT=CNT+1
SET @MSGROOT@(CNT)=$$BLDSEG^SDHL7UL(.QPD,.HL)
SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
+90 SET CNT=CNT+1
SET @MSGROOT@(CNT)=$$BLDSEG^SDHL7UL(.RDF,.HL)
SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
+91 IF '$PIECE(ERR,"^",4)
Begin DoDot:1
+92 if DATAROOT=""
QUIT
+93 DO @("RDT^SDTMBUS"_"(MSGROOT,DATAROOT,.CNT,.LEN,.HL,.FOUNDCN)")
+94 DO RTCRDT^SDTMBUS(MSGROOT,RTCLST,.CNT,.LEN,.HL)
+95 QUIT
End DoDot:1
+96 ;
+97 FOR IX=1:1:CNT
SET HLA("HLS",IX)=$GET(@MSGROOT@(IX))
+98 ;
+99 MERGE HLA("HLA")=HLA("HLS")
+100 ;
+101 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
+102 ;
+103 ;Clean up TMP used by logging
DO RESET^SDHL7UL
+104 KILL @DATAROOT,@MSGROOT
+105 ;
+106 QUIT
+107 ;
VALIDMSG(MSGROOT,QRY,XMT,ERR) ;Validate message
+1 ;
+2 ; Messages handled: QBP^Q13
+3 ;
+4 ; QBP query messages must contain QPD and RCP segments
+5 ; Any additional segments are ignored
+6 ;
+7 ; Input:
+8 ; MSGROOT - Root of array holding message
+9 ; XMT - Transmission parameters
+10 ;
+11 ; Output:
+12 ; QRY - Query Array
+13 ; XMT - Transmission parameters
+14 ; ERR - segment^sequence^field^code^ACK type^error text
+15 ;
+16 NEW MSH,QPD,REQID,REQTYPE,QTAG,QNAME,RDF
+17 NEW SEGTYPE,CNT
+18 KILL QRY,ERR
+19 SET ERR=""
+20 ;
+21 ; Set up basics for responding to message.
+22 ;-----------------------------------------
+23 ;Message ID
SET QRY("MID")=XMT("MID")
+24 SET QRY("QPD")=""
+25 ;
+26 ; Validate message is a well-formed QBP query message.
+27 ;-----------------------------------------------------------
+28 ; Must have MSH first, followed by QPD,RCP in any order
+29 ; PID and STF are optional. All other segments are ignored.
+30 ;
+31 IF $GET(@MSGROOT@(1,0))="MSH"
MERGE MSH=@MSGROOT@(1)
+32 IF '$TEST
SET ERR="MSH^1^^100^AE^Missing MSH segment"
QUIT 0
+33 ;
+34 SET CNT=2
+35 FOR
if '$DATA(@MSGROOT@(CNT))
QUIT
Begin DoDot:1
+36 SET SEGTYPE=$GET(@MSGROOT@(CNT,0))
+37 IF SEGTYPE="QPD"
MERGE QPD=@MSGROOT@(CNT),QRY("QPD")=QPD
QUIT
+38 IF SEGTYPE="RDF"
MERGE RDF=@MSGROOT@(CNT)
QUIT
+39 QUIT
End DoDot:1
SET CNT=CNT+1
+40 ;
+41 IF '$DATA(QPD)
SET ERR="QPD^1^^100^AE^Missing QPD segment"
QUIT 0
+42 ;
+43 ;Query Tag
SET QTAG=$GET(QPD(1,1,2))
+44 ;Request ID
SET REQID=$GET(QPD(2))
+45 ;Request Type
SET REQTYPE=$GET(QPD(3,1,1))
+46 ;Request Type if no other params
if REQTYPE=""
SET REQTYPE=$GET(QPD(3))
+47 ;
+48 ; Validate required fields and query parameters
+49 ;------------------------------------------------------
+50 ;
+51 ; Check for missing/invalid fields
+52 ;
+53 IF '$DATA(QPD(1))
SET ERR="QPD^1^1^101^AE^Missing Message Query Name"
QUIT 0
+54 ;
+55 IF QTAG=""
SET ERR="QPD^1^2^101^AE^Missing Query Tag"
QUIT 0
+56 IF REQID=""
SET ERR="QPD^1^2^101^AE^Missing Request ID"
QUIT 0
+57 SET (QRY("DCLSNM"),QRY("DFN"))=""
+58 SET QRY("REQID")=REQID
+59 ;
+60 IF REQTYPE=""
SET ERR="QPD^1^3^101^AE^Missing Request Type"
QUIT 0
+61 ;
+62 QUIT 1
+63 ;
LOADXMT(HL,XMT) ;Set HL dependent XMT values
+1 ;
+2 ; The HL array and variables are expected to be defined. If not,
+3 ; message processing will fail. These references should not be
+4 ; wrapped in $G, as null values will simply postpone the failure to
+5 ; a point that will be harder to diagnose. Except HL("APAT") which
+6 ; is not defined on synchronous calls.
+7 ;
+8 ; Integration Agreements:
+9 ; 1373 : Reference to PROTOCOL file #101
+10 ;
+11 NEW SUBPROT,RESPIEN,RESP0
+12 SET HL("EID")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Event Driver")
+13 SET HL("EIDS")=$$FIND1^DIC(101,,,"TMP QBP-Q13 Subscriber")
+14 ;Message ID
SET XMT("MID")=HL("MID")
+15 ;Response mode
SET XMT("MODE")="A"
+16 ;Synchronous mode
IF $GET(HL("APAT"))=""
SET XMT("MODE")="S"
+17 ;Message type
SET XMT("MESSAGE TYPE")=HL("MTN")
+18 ;Event type
SET XMT("EVENT TYPE")=HL("ETN")
+19 ;HL Delimiters
SET XMT("DELIM")=HL("FS")_HL("ECH")
+20 ;S XMT("DELIM")="~^\&"
+21 ;Default size unlimited
SET XMT("MAX SIZE")=0
+22 ;
+23 ; Map response protocol and builder
+24 SET SUBPROT=$PIECE(^ORD(101,HL("EIDS"),0),"^")
+25 QUIT
LIST(SDY,SDPT,SDSDT,SDEDT,SDSERV,SDSTATUS) ; return patient's consult requests between start date and stop date for the service and status indicated:
+1 NEW I,J,SITE,SEQ,DIFF,SDSRV,ORLOC,GMRCOER
+2 SET J=1
SET SEQ=""
SET GMRCOER=2
+3 if '$LENGTH($GET(SDSDT))
SET SDSDT=""
+4 if '$LENGTH($GET(SDEDT))
SET SDEDT=""
+5 if '$LENGTH($GET(SDSERV))!(+$GET(SDSERV)=0)
SET SDSERV=""
+6 ;ALL STATI
if '$LENGTH($GET(SDSTATUS))
SET SDSTATUS=""
+7 KILL ^TMP("GMRCR",$JOB)
+8 SET SDY=$NAME(^TMP("ORQQCN",$JOB,"CS"))
+9 DO OER^GMRCSLM1(SDPT,SDSERV,SDSDT,SDEDT,SDSTATUS,GMRCOER)
+10 MERGE @SDY=^TMP("GMRCR",$JOB,"CS")
+11 KILL @SDY@("AD")
+12 KILL @SDY@(0)
+13 KILL ^TMP("GMRCR",$JOB)
+14 QUIT
RTCLIST(SDY,SDPT,SDSDT,SDEDT) ; return patient's "Return to Clinic" appointment requests
+1 ;SDY = return global
+2 ;SDPT = dfn of patient
+3 ;SDSDT = start date (based on CREATE DATE of request)
+4 ;SDEDT = end date (based on END DATE of request)
+5 NEW IDX,IEN,SDEC0,REQDT,CNT,CLINID,CID,STOP,PRVID,CMTS,MRTC,RTCINT,RTCINT,RTCPAR
+6 SET SDY=$NAME(^TMP("SDHL7CON",$JOB,"RTCLIST"))
KILL @SDY
+7 SET SDSDT=$GET(SDSDT,"ALL")
SET SDEDT=$GET(SDEDT)
SET CNT=0
+8 ; Return nothing if no patient passed
if '$GET(SDPT)
QUIT
+9 SET IDX=$NAME(^SDEC(409.85,"B",SDPT))
SET IEN=0
+10 FOR
SET IEN=$ORDER(@IDX@(IEN))
if '$GET(IEN)
QUIT
Begin DoDot:1
+11 KILL RTCINT,MRTC,RTCPAR,SDEC0,CLINID,CID,PRVID,CMTS,CLINNM,STOP
+12 SET SDEC0=$GET(^SDEC(409.85,IEN,0))
+13 IF $PIECE(SDEC0,U,5)'="RTC"
QUIT
+14 IF $PIECE(SDEC0,U,17)'="O"
QUIT
+15 SET REQDT=$PIECE(SDEC0,U,2)
IF SDSDT'="ALL"
IF $PIECE(REQDT,".",1)<SDSDT!($PIECE(REQDT,".",1)>SDEDT)
QUIT
+16 SET CLINID=$PIECE(SDEC0,U,9)
SET CID=$PIECE(SDEC0,U,16)
SET PRVID=$PIECE(SDEC0,U,13)
SET CMTS=$PIECE(SDEC0,U,18)
SET CMTS=$EXTRACT(CMTS,1,80)
+17 if $PIECE($GET(^SDEC(409.85,IEN,3)),"^")=1
SET MRTC=$PIECE($GET(^SDEC(409.85,IEN,3)),"^",3)
SET RTCINT=$PIECE($GET(^SDEC(409.85,IEN,3)),"^",2)
SET RTCPAR=$PIECE($GET(^SDEC(409.85,IEN,3)),"^",5)
+18 if $GET(RTCPAR)=""
SET RTCPAR=IEN
+19 if $GET(MRTC)=""
SET MRTC=0
if $GET(RTCINT)=""
SET RTCINT=0
+20 ;858 this Requests rec is MRTC related do not return.
if $PIECE($GET(^SDEC(409.85,IEN,3)),U,1)
QUIT
+21 IF +CLINID
Begin DoDot:2
+22 SET CLINNM=$$GET1^DIQ(44,CLINID_",",".01")
+23 SET STOP=$$GET1^DIQ(44,CLINID_",",8)_","_$$GET1^DIQ(44,CLINID_",",2503)
End DoDot:2
+24 SET CNT=CNT+1
SET @SDY@(CNT)=IEN_U_REQDT_U_CLINID_U_CID_U_PRVID_U_CMTS_U_$GET(MRTC)_U_$GET(RTCINT)_U_$GET(RTCPAR)
End DoDot:1
+25 SET @SDY=CNT
+26 QUIT
PARSESEG(SEG,DATA,HL) ;Generic segment parser
+1 ;This procedure parses a single HL7 segment and builds an array
+2 ;subscripted by the field number containing the data for that field.
+3 ; Does not handle segments that span nodes
+4 ;
+5 ; Input:
+6 ; SEG - HL7 segment to parse
+7 ; HL - HL7 environment array
+8 ;
+9 ; Output:
+10 ; Function value - field data array [SUB1:field, SUB2:repetition,
+11 ; SUB3:component, SUB4:sub-component]
+12 ;
+13 ;component subscript
NEW CMP
+14 ;component value
NEW CMPVAL
+15 ;field subscript
NEW FLD
+16 ;field value
NEW FLDVAL
+17 ;repetition subscript
NEW REP
+18 ;repetition value
NEW REPVAL
+19 ;sub-component subscript
NEW SUB
+20 ;sub-component value
NEW SUBVAL
+21 ;field separator
NEW FS
+22 ;component separator
NEW CS
+23 ;repetition separator
NEW RS
+24 ;sub-component separator
NEW SS
+25 ;
+26 KILL DATA
+27 SET FS=HL("FS")
+28 SET CS=$EXTRACT(HL("ECH"))
+29 SET RS=$EXTRACT(HL("ECH"),2)
+30 SET SS=$EXTRACT(HL("ECH"),4)
+31 ;
+32 SET DATA(0)=$PIECE(SEG,FS)
+33 SET SEG=$PIECE(SEG,FS,2,9999)
+34 ;
+35 FOR FLD=1:1:$LENGTH(SEG,FS)
Begin DoDot:1
+36 SET FLDVAL=$PIECE(SEG,FS,FLD)
+37 FOR REP=1:1:$LENGTH(FLDVAL,RS)
Begin DoDot:2
+38 SET REPVAL=$PIECE(FLDVAL,RS,REP)
+39 IF REPVAL[CS
FOR CMP=1:1:$LENGTH(REPVAL,CS)
Begin DoDot:3
+40 SET CMPVAL=$PIECE(REPVAL,CS,CMP)
+41 IF CMPVAL[SS
FOR SUB=1:1:$LENGTH(CMPVAL,SS)
Begin DoDot:4
+42 SET SUBVAL=$PIECE(CMPVAL,SS,SUB)
+43 IF SUBVAL'=""
SET DATA(FLD,REP,CMP,SUB)=SUBVAL
End DoDot:4
+44 IF '$DATA(DATA(FLD,REP,CMP))
IF CMPVAL'=""
SET DATA(FLD,REP,CMP)=CMPVAL
End DoDot:3
+45 IF '$DATA(DATA(FLD,REP))
IF REPVAL'=""
IF FLDVAL[RS
SET DATA(FLD,REP)=REPVAL
End DoDot:2
+46 IF '$DATA(DATA(FLD))
IF FLDVAL'=""
SET DATA(FLD)=FLDVAL
End DoDot:1
+47 QUIT
+48 ;
LOADMSG(MSGROOT) ; Load HL7 message into temporary global for processing
+1 ;
+2 ;This subroutine assumes that all VistA HL7 environment variables are
+3 ;properly initialized and will produce a fatal error if they aren't.
+4 ;
+5 NEW CNT,SEG
+6 KILL @MSGROOT
+7 FOR SEG=1:1
XECUTE HLNEXT
if HLQUIT'>0
QUIT
Begin DoDot:1
+8 SET CNT=0
+9 SET @MSGROOT@(SEG,CNT)=HLNODE
+10 FOR
SET CNT=$ORDER(HLNODE(CNT))
if 'CNT
QUIT
SET @MSGROOT@(SEG,CNT)=HLNODE(CNT)
End DoDot:1
+11 QUIT
+12 ;
PARSEMSG(MSGROOT,HL) ; Message Parser
+1 ; Does not handle segments that span nodes
+2 ; Does not handle extremely long segments (uses a local)
+3 ; Does not handle long fields (segment parser doesn't)
+4 ;
+5 NEW SEG,CNT,DATA,MSG
+6 FOR CNT=1:1
if '$DATA(@MSGROOT@(CNT))
QUIT
MERGE SEG=@MSGROOT@(CNT)
Begin DoDot:1
+7 DO PARSESEG(SEG(0),.DATA,.HL)
+8 KILL @MSGROOT@(CNT)
+9 IF DATA(0)'=""
MERGE @MSGROOT@(CNT)=DATA
+10 if '$DATA(SEG(1))
QUIT
+11 ;
+12 QUIT
End DoDot:1
+13 QUIT
SENDERR(ERR) ; Send for unsuccessful response
+1 KILL @MSGROOT
+2 DO INIT^HLFNC2(EIN,.HL)
+3 SET HL("FS")="|"
SET HL("ECH")="^~\&"
+4 SET CNT=1
SET @MSGROOT@(CNT)=$$MSA^SDTMBUS($GET(HL("MID")),ERR,.HL)
SET LEN=$LENGTH(@MSGROOT@(CNT))
+5 SET CNT=CNT+1
SET @MSGROOT@(CNT)=$$QAK^SDTMBUS(.HL,ERR)
SET LEN=LEN+$LENGTH(@MSGROOT@(CNT))
+6 FOR IX=1:1:CNT
SET HLA("HLS",IX)=$GET(@MSGROOT@(IX))
+7 MERGE HLA("HLA")=HLA("HLS")
+8 DO GENACK^HLMA1(HL("EID"),HLMTIENS,HL("EIDS"),"LM",1,.MYRESULT)
+9 QUIT
