source: WorldVistAEHR/trunk/r/MY_HEALTHEVET-MHV/MHV7R1.m@ 1720

MHV7R1 ;WAS/GPM - HL7 RECEIVER FOR QBP^Q13 ; [5/24/06 10:19am]
 ;;1.0;My HealtheVet;**1**;Aug 23, 2005
 ;;Per VHA Directive 2004-038, this routine should not be modified.
 ;
QBPQ13 ;Process QBP^Q13 messages from the MHV QBP-Q13 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 QBP^Q13 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.
 ; In the future deferred mode queries may be filed in a database for 
 ; later processing, or transmission.
 ;
 ;  Integration Agreements:
 ;        10103 : $$HL7TFM^XLFDT
 ;
 ;  Input:
 ;          HL7 environment variables
 ;
 ; Output:
 ;          Processed query or negative acknowledgement
 ;
 N MSGROOT,QRY,XMT,ERR
 S (QRY,XMT,ERR)=""
 ;S MSGROOT="^TMP(""MHV7"",$J)"
 S MSGROOT="MHV7MSG"
 N MHV7MSG
 D LOG^MHV7U("QBP-Q13 RECEIVER","","S",1)
 ;
 D LOADMSG^MHV7U(MSGROOT)
 D LOG^MHV7U("LOAD",MSGROOT,"I",0)
 ;
 D PARSEMSG^MHV7U(MSGROOT,.HL)
 ;D LOG^MHV7U("PARSE",MSGROOT,"I",0)
 ;
 I '$$VALIDQ13(MSGROOT,.QRY,.XMT,.ERR) D  Q
 . D LOG^MHV7U("MSG CHECK","INVALID^"_ERR,"S",0)
 . D XMIT^MHV7T(.QRY,.XMT,ERR,"",.HL)
 D LOG^MHV7U("MSG CHECK","VALID","S",0)
 ;
 ; Immediate Mode
 ; Only real time synchronous calls are supported at this time.
 I QRY("PRI")="I" D REALTIME^MHVRQI(.QRY,.XMT,.HL)
 K ^TMP("MHV7LOG",$J)
 ;
 Q
 ;
VALIDQ13(MSG,QRY,XMT,ERR) ;Parse and Validate message
 ;
 ;  QBP^Q13 messages must contain QPD and RCP segments
 ;          RDF segments are optional but not processed
 ;  The following sequences are required
 ;     PID(3) - Patient ID
 ;     QPD(3) - Request ID
 ;     QPD(4) - Subject Area
 ;     RCP(1) - priority
 ;  The following sequences are optional
 ;     QPD(5) - From Date
 ;     QPD(6) - To Date
 ;     QPD(7) - ICN
 ;     QPD(8) - DFN
 ;
 ;  ERR = segment^sequence^field^code^ACK type^error text
 ;
 N MSH,PID,RDF,RXE,QPD,RCP,REQID,ICN,REQTYPE,FROMDT,TODT,DFN,PRI,REQTIEN,REQT0,QTAG,QNAME,SEGTYPE,CNT,SSN,FAMILY,GIVEN,MIDDLE,SUFFIX,SEGTYPE,CNT,OCNT,RXNUM,I,ID,TYPE
 S ERR=""
 K QRY,XMT
 ;
 ;Set response control defaults
 S XMT("PROTOCOL")="MHV RTB-K13 Event Driver"   ;Response protocol
 S XMT("BUILDER")="RTBK13^MHV7B1"               ;Response builder
 S XMT("MODE")="D"                               ;Response mode
 I $G(HL("APAT"))="" S XMT("MODE")="I"           ;Immediate mode
 S XMT("HLMTIENS")=HLMTIENS                      ;Message IEN
 S QRY("MID")=""                                 ;Message ID
 S QRY("QPD")=""                                 ;QPD segment
 ;
 ;
 ;Validate message is a well formed QBP^Q13 message
 ;
 ;Must have MSH first, followed by QPD,PID,RXE,RDF,RCP in any order
 ;RDF is not required, any other segments are ignored
 ;
 I $G(@MSGROOT@(1,0))="MSH" M MSH=@MSGROOT@(1) S QRY("MID")=$G(MSH(9))
 E  S ERR="MSH^1^^100^AE^Missing MSH segment" Q 0
 S CNT=2,OCNT=0
 F  Q:'$D(@MSGROOT@(CNT))  D  S CNT=CNT+1
 . S SEGTYPE=$G(@MSGROOT@(CNT,0))
 . I SEGTYPE="PID" M PID=@MSGROOT@(CNT),QRY("PID")=PID Q
 . I SEGTYPE="QPD" M QPD=@MSGROOT@(CNT),QRY("QPD")=QPD Q
 . I SEGTYPE="RDF" M RDF=@MSGROOT@(CNT) Q
 . I SEGTYPE="RCP" M RCP=@MSGROOT@(CNT) Q
 . I SEGTYPE="RXE" S OCNT=OCNT+1 M RXE(OCNT)=@MSGROOT@(CNT) Q
 . Q
 ;
 I '$D(PID) S ERR="PID^1^^100^AE^Missing PID segment" Q 0
 I '$D(QPD) S ERR="QPD^1^^100^AE^Missing QPD segment" Q 0
 I '$D(RCP) S ERR="RCP^1^^100^AE^Missing RCP segment" Q 0
 ;
 ;
 ;Validate required fields and query parameters
 ;
 S ICN="",DFN="",SSN=""
 F I=1:1:3 Q:'$D(PID(3,I))  D  Q:ERR'=""
 . S ID=$G(PID(3,I,1))
 . S TYPE=$G(PID(3,I,5))
 . I ID="" S ERR="PID^1^3^101^AE^Missing Patient ID" Q
 . I TYPE="" S ERR="PID^1^3^101^AE^Missing Patient ID Type" Q
 . I TYPE="NI" S ICN=ID
 . I TYPE="PI" S DFN=ID
 . I TYPE="SS" S SSN=ID
 . Q
 Q:ERR'="" 0
 ;
 S FAMILY=$G(PID(5,1,1))
 S GIVEN=$G(PID(5,1,2))
 S MIDDLE=$G(PID(5,1,3))
 S SUFFIX=$G(PID(5,1,4))
 ;
 ; ID is validated from PID only,
 ; May want to add fallback to use ID supplied in QPD
 I '$$VALIDID^MHV7R2(.ICN,.DFN,.SSN,.ERR) S ERR="PID^1^3^"_ERR Q 0
 ;
 ; *** May need to add validation of name - compare against system
 ;I FAMILY="" S ERR="PID^1^5^101^AE^Missing Patient Family Name" Q 0
 ;I GIVEN="" S ERR="PID^1^5^101^AE^Missing Patient Given Name" Q 0
 ;
 ;
 S QTAG=$G(QPD(2))            ;Query Tag
 S REQID=$G(QPD(3))           ;Request ID
 S REQTYPE=$G(QPD(4))         ;Request Type
 S FROMDT=$G(QPD(5))          ;From Date
 S TODT=$G(QPD(6))            ;To Date
 ; Do not use ICN or DFN from QPD, get from PID
 ;I ICN="" S ICN=$G(QPD(7))    ;ICN
 ;I DFN="" S DFN=$G(QPD(8))    ;DFN
 S PRI=$G(RCP(1))             ;Query Priority
 ;
 I '$D(QPD(1)) S ERR="QPD^1^1^101^AE^Missing Message Query Name" Q 0
 M QNAME=QPD(1)  ;Message Query Name
 ;
 I QTAG="" S ERR="QPD^1^2^101^AE^Missing Query Tag" Q 0
 ;
 I REQID="" S ERR="QPD^1^3^101^AE^Missing Request ID" Q 0
 ;
 I REQTYPE="" S ERR="QPD^1^4^101^AE^Missing Request Type" Q 0
 S REQTIEN=$O(^MHV(2275.3,"D",REQTYPE,0))
 I 'REQTIEN S ERR="QPD^1^4^103^AE^Request Type Not Found" Q 0
 S REQT0=$G(^MHV(2275.3,REQTIEN,0))
 S REQTYPE=$P(REQT0,"^",2)
 ;
 I FROMDT'="" D  Q:ERR'="" 0
 . I FROMDT'?8.16N S ERR="QPD^1^5^102^AE^Invalid From Date" Q
 . ;***Check into Time Zone issue between MHV server and site
 . S FROMDT=$$HL7TFM^XLFDT(FROMDT)\1
 . I FROMDT'?7N S ERR="QPD^1^5^102^AE^Invalid From Date" Q
 . Q
 ;
 I TODT'="" D  Q:ERR'="" 0
 . I TODT'?8.16N S ERR="QPD^1^6^102^AE^Invalid To Date" Q
 . ;***Check into Time Zone issue between MHV server and site
 . S TODT=$$HL7TFM^XLFDT(TODT)\1
 . I TODT'?7N S ERR="QPD^1^6^102^AE^Invalid To Date" Q
 . Q
 ;
 I TODT'="",TODT<FROMDT S ERR="QPD^1^6^102^AE^To Date precedes From Date" Q 0
 ;
 I PRI="" S ERR="RCP^1^1^101^AE^Missing Query Priority" Q 0
 I "D|I"'[PRI S ERR="RCP^1^1^102^AE^Invalid Query Priority" Q 0
 ;
 F CNT=1:1 Q:'$D(RXE(CNT))  D
 . S RXNUM=$G(RXE(CNT,15))
 . Q:RXNUM<1
 . S QRY("RXLIST",RXNUM)=""
 . Q
 ;
 S QRY("REQID")=REQID     ;Request ID
 S QRY("ICN")=ICN         ;ICN
 S QRY("TYPE")=REQTYPE    ;Request Data Type
 S QRY("FROM")=FROMDT     ;From Date
 S QRY("TO")=TODT         ;To Date
 S QRY("DFN")=DFN         ;DFN
 S QRY("SSN")=SSN         ;SSN
 S QRY("PRI")=PRI         ;Priority
 ;
 S QRY("BLOCKED")=$P(REQT0,"^",3)
 S QRY("REALTIME")=$P(REQT0,"^",4)
 S QRY("EXECUTE")=$TR($P(REQT0,"^",5),"~","^")
 ;
 Q 1
 ;