Changeset 623 for WorldVistAEHR/trunk/r/MY_HEALTHEVET-MHV/MHV7R1.m

Timestamp:

Dec 4, 2009, 12:11:15 AM (14 years ago)

Author:

George Lilly

Message:

revised back to 6/30/08 version

File:

• WorldVistAEHR/trunk/r/MY_HEALTHEVET-MHV/MHV7R1.m (modified) (1 diff)

WorldVistAEHR/trunk/r/MY_HEALTHEVET-MHV/MHV7R1.m

@@ -1 @@
-MHV7R1  ;WAS/GPM - HL7 RECEIVER FOR QBP QUERIES ; [12/31/07 3:11pm]
-        ;;1.0;My HealtheVet;**1,2**;Aug 23, 2005;Build 22
-        ;;Per VHA Directive 2004-038, this routine should not be modified.
-        ;
-        Q
-        ;
-QBPQ13  ;Process QBP^Q13 messages from the MHV QBP-Q13 Subscriber protocol
-        ;
-QBPQ11  ;Process QBP^Q11 messages from the MHV QBP-Q11 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
-        ;
-        N MSGROOT,QRY,XMT,ERR,RNAME
-        S (QRY,XMT,ERR)=""
-        ; 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="^TMP(""MHV7"",$J)"
-        ;K @MSGROOT
-        S MSGROOT="MHV7MSG"
-        N MHV7MSG
-        D LOADXMT^MHV7U(.XMT)         ;Load inbound message information
-        ;
-        S RNAME=XMT("MESSAGE TYPE")_"-"_XMT("EVENT TYPE")_" RECEIVER"
-        D LOG^MHVUL2(RNAME,"BEGIN","S","TRACE")
-        ;
-        D LOADMSG^MHV7U(MSGROOT)
-        D LOG^MHVUL2("LOAD",MSGROOT,"I","DEBUG")
-        ;
-        D PARSEMSG^MHV7U(MSGROOT,.HL)
-        D LOG^MHVUL2("PARSE",MSGROOT,"I","DEBUG")
-        ;
-        I '$$VALIDMSG(MSGROOT,.QRY,.XMT,.ERR) D  Q
-        . D LOG^MHVUL2("MSG CHECK","INVALID^"_ERR,"S","ERROR")
-        . D XMIT^MHV7T(.QRY,.XMT,ERR,"",.HL)
-        D LOG^MHVUL2("MSG CHECK","VALID","S","TRACE")
-        ;
-        ; Immediate Mode
-        ; Deferred mode queries are not supported at this time
-        D REALTIME^MHVRQI(.QRY,.XMT,.HL)
-        ;
-        D LOG^MHVUL2(RNAME,"END","S","TRACE")
-        D RESET^MHVUL2          ;Clean up TMP used by logging
-        ;K @MSGROOT
-        ;
-        Q
-        ;
-VALIDMSG(MSGROOT,QRY,XMT,ERR)   ;Validate message
-        ;
-        ;  Messages handled: QBP^Q13
-        ;                    QBP^Q11
-        ;
-        ;  QBP query messages must contain PID, QPD and RCP segments
-        ;  RXE segments are processed on Q13 prescription queries
-        ;  Any additional segments are ignored
-        ;
-        ;  The following sequences are required
-        ;     PID(3)  - Patient ID
-        ;     PID(5)* - Patient Name
-        ;     QPD(1)* - Message Query Name
-        ;     QPD(2)* - Query Tag
-        ;     QPD(3)  - Request ID
-        ;     QPD(4)  - Subject Area
-        ;     RCP(1)  - Query Priority
-        ;               * required by HL7 standard but not used by MHV
-        ;
-        ;  The following sequences are optional
-        ;     QPD(5)  - From Date
-        ;     QPD(6)  - To Date
-        ;     RCP(2)  - Quantity Limited
-        ;
-        ;  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,PID,RDF,RXE,QPD,RCP,REQID,REQTYPE,FROMDT,TODT,PRI,QTAG,QNAME,SEGTYPE,CNT,OCNT,RXNUM,QTY,UNIT
-        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,PID,RXE,RDF,RCP in any order
-        ; RXE is processed on Q13 prescriptions queries
-        ; RDF is not required
-        ; Any 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,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 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
-        S PRI=$G(RCP(1))             ;Query Priority
-        S QTY=$G(RCP(2,1,1))         ;Quantity Limited
-        S UNIT=$G(RCP(2,1,2))        ;Quantity units
-        ;
-        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
-        S QRY("REQID")=REQID
-        ;
-        I REQTYPE="" S ERR="QPD^1^4^101^AE^Missing Request Type" Q 0
-        I '$$VALRTYPE^MHV7RU(REQTYPE,.QRY,.ERR) S ERR="QPD^1^4^"_ERR Q 0
-        ;
-        I '$$VALIDDT^MHV7RU(.FROMDT) S ERR="QPD^1^5^102^AE^Invalid From Date" Q 0
-        S QRY("FROM")=FROMDT
-        I '$$VALIDDT^MHV7RU(.TODT) S ERR="QPD^1^6^102^AE^Invalid To Date" Q 0
-        I TODT'="",TODT<FROMDT S ERR="QPD^1^6^102^AE^To Date precedes From Date" Q 0
-        S QRY("TO")=TODT
-        ;
-        I '$$VALIDPID^MHV7RUS(.PID,.QRY,.ERR) 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
-        S QRY("PRI")=PRI
-        ;
-        I QTY'?0.N S ERR="RCP^1^2^102^AE^Invalid Quantity" Q 0
-        S QRY("QTY")=+QTY
-        S XMT("MAX SIZE")=+QTY
-        ;
-        I QTY,UNIT'="CH" S ERR="RCP^1^2^102^AE^Invalid Units" Q 0
-        ;
-        ; Setup prescription list (if passed)
-        ;------------------------------------
-        F CNT=1:1 Q:'$D(RXE(CNT))  D  Q:ERR'=""
-        . S RXNUM=$G(RXE(CNT,15))
-        . I RXNUM="" S ERR="RXE^"_CNT_"^15^101^AE^Missing Prescription#" Q
-        . I RXNUM'?1.N0.A S ERR="RXE^"_CNT_"^15^102^AE^Invalid Prescription#" Q
-        . S QRY("RXLIST",RXNUM)=""
-        . Q
-        Q:ERR'="" 0
-        ;
-        Q 1
-        ;
+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
+ ;