Home   Package List   Routine Alphabetical List   Global Alphabetical List   FileMan Files List   FileMan Sub-Files List   Package Component Lists   Package-Namespace Mapping  
Routine: DGPFHLR

DGPFHLR.m

Go to the documentation of this file.
  1. DGPFHLR ;ALB/RPM - PRF HL7 RECEIVE DRIVERS ; Sep 11, 2023@10:20:27
  1. ;;5.3;Registration;**425,650,951,1005,1091**;Aug 13, 1993;Build 28
  1. ;;Per VA Directive 6402, this routine should not be modified.
  1. ;
  1. ; Reference to SAVEHL7^EHMHL7 supported by ICR #7424
  1. ;
  1. RCV ;Receive all message types and route to message specific receiver
  1. ;
  1. ;This procedure is the main driver entry point for receiving all
  1. ;message types (ORU, ACK, QRY and ORF) for patient record flag
  1. ;assignment sharing.
  1. ;
  1. ;All procedures and functions assume that all VistA HL7 environment
  1. ;variables are properly initialized and will produce a fatal error if
  1. ;they are missing.
  1. ;
  1. ;The received message is copied to a temporary work global for
  1. ;processing. The message type is determined from the MSH segment and
  1. ;a receive processing procedure specific to the message type is called.
  1. ;(Ex. ORU~R01 message calls procedure: RCVORU). The specific receive
  1. ;processing procedure calls a message specific parse procedure to
  1. ;validate the message data and return data arrays for storage. If no
  1. ;parse errors are reported during validation, then the data arrays are
  1. ;stored by the receive processing procedure. Control, along with any
  1. ;parse validation errors, is then passed to the message specific send
  1. ;processing procedures to build and transmit the acknowledgment and
  1. ;query results messages.
  1. ;
  1. ; The message specific procedures are as follows:
  1. ;
  1. ; Message Receive Procedure Parse Procedure Send Procedure
  1. ; ------- ----------------- ---------------- --------------
  1. ; ORU~R01 RCVORU^DGPFHLR PARSORU^DGPFHLU SNDACK^DGPFHLS
  1. ; ACK~R01 RCVACK^DGPFHLR PARSACK^DGPFHLU4 N/A
  1. ; QRY~R02 RCVQRY^DGPFHLR PARSQRY^DGPFHLQ3 SNDORF^DGPFHLS
  1. ; ORF~R04 RCVORF^DGPFHLR PARSORF^DGPFHLQ3 N/A
  1. ;
  1. N DGCNT
  1. N DGMSGTYP
  1. N DGSEG
  1. N DGSEGCNT
  1. N DGWRK
  1. ;
  1. S DGWRK=$NA(^TMP("DGPFHL7",$J))
  1. K @DGWRK
  1. ;
  1. ;load work global with segments
  1. F DGSEGCNT=1:1 X HLNEXT Q:HLQUIT'>0 D
  1. . S DGCNT=0
  1. . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE
  1. . F S DGCNT=$O(HLNODE(DGCNT)) Q:'DGCNT D
  1. . . S @DGWRK@(DGSEGCNT,DGCNT)=HLNODE(DGCNT)
  1. ;
  1. ;get message type from "MSH"
  1. I $$NXTSEG^DGPFHLUT(DGWRK,0,HL("FS"),.DGSEG),$G(DGSEG("TYPE"))="MSH" D
  1. . S DGMSGTYP=$P(DGSEG(9),$E(HL("ECH"),1),1)
  1. . ;HLMTIENS is only required by RCVORU and RCVQRY, thus $GET
  1. . I DGMSGTYP=HL("MTN") D @("RCV"_DGMSGTYP_"(DGWRK,$G(HLMTIENS),.HL)")
  1. ;
  1. ;cleanup
  1. K @DGWRK
  1. Q
  1. ;
  1. RCVORU(DGWRK,DGMIEN,DGHL) ;Receive ORU Message Types (ORU~R01)
  1. ;
  1. ; Input:
  1. ; DGWRK - name of work global containing segments
  1. ; DGMIEN - IEN of message entry in file #773
  1. ; DGHL - HL environment array
  1. ;
  1. ; Output:
  1. ; none
  1. ;
  1. N DGORU
  1. N DGSEGERR ;segment error array
  1. N DGSTOERR ;store error array
  1. N DGACKTYP
  1. ;
  1. S DGORU=$NA(^TMP("DGPF",$J))
  1. K @DGORU
  1. D PARSORU^DGPFHLU(DGWRK,.DGHL,DGORU,.DGSEGERR)
  1. I $D(DGSEGERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"P") ;parse error
  1. ;
  1. I '$D(DGSEGERR),$$STOORU(DGORU,.DGSTOERR) D
  1. . S DGACKTYP="AA"
  1. E D
  1. . S DGACKTYP="AE"
  1. ;
  1. I $D(DGSTOERR) D SDORUERR(DGMIEN,.DGSEGERR,.DGSTOERR,"S") ;store error
  1. D SNDACK^DGPFHLS(DGACKTYP,DGMIEN,.DGHL,.DGSEGERR,.DGSTOERR)
  1. ;
  1. ; Save message to EHRM HL7 Message file (#1609) if received from Cerner. p1091
  1. ;
  1. I $G(HL("SAF"))="200CRNR" D ;
  1. . N RTNVALUE K ^TMP("EHMHL7",$J) M ^TMP("EHMHL7",$J)=@DGWRK ;
  1. . S RTNVALUE=$$SAVEHL7X^EHMHL7("EHMHL7","PRF","200CRNR","VISTA-"_$$STA^XUAF4($$KSP^XUPARAM("INST")),DGHL("FS"),$E(DGHL("ECH"),1),$E(DGHL("ECH"),2)) ;
  1. . K ^TMP("EHMHL7",$J) ;
  1. ;
  1. ;cleanup
  1. K @DGORU
  1. Q
  1. ;
  1. STOORU(DGORU,DGERR) ;store ORU data array
  1. ;
  1. ; Input:
  1. ; DGORU - parsed ORU segment data array
  1. ;
  1. ; Output:
  1. ; Function value - 1 on success; 0 on failure
  1. ; DGERR - defined on failure
  1. ;
  1. N DGADT ;assignment date
  1. N DGCNT ;count of assignment histories sent
  1. N DGPFA ;assignment data array
  1. N DGPFAH ;assignment history data array
  1. N DGSINGLE ;flag to indicate a single history update
  1. N CURASGN,DBRSCNT,DBRSNUM,LASTDT,RES,STOFLG
  1. ;
  1. ;
  1. S DGPFA("SNDFAC")=$G(@DGORU@("SNDFAC"))
  1. S DGPFA("DFN")=$G(@DGORU@("DFN"))
  1. S DGPFA("FLAG")=$G(@DGORU@("FLAG"))
  1. ;
  1. ;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
  1. S DGPFA("STATUS")=""
  1. S DGPFA("OWNER")=$G(@DGORU@("OWNER"))
  1. S DGPFA("ORIGSITE")=$G(@DGORU@("ORIGSITE"))
  1. M DGPFA("NARR")=@DGORU@("NARR")
  1. ; DBRS data
  1. S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
  1. .S DBRSCNT=DBRSCNT+1
  1. .S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
  1. .S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))
  1. .S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
  1. .S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"ACTION"))
  1. .S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
  1. .Q
  1. ;count number of assignment histories sent
  1. S (DGADT,DGCNT)=0
  1. F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT S DGCNT=DGCNT+1
  1. S DGSINGLE=$S(DGCNT>1:0,1:1)
  1. S DGADT=0
  1. S LASTDT=+$O(@DGORU@(9999999.999999),-1) ; date of last history record
  1. ;
  1. ;process only the last history action when assignment already exists
  1. S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG"))
  1. I 'DGSINGLE,CURASGN S DGADT=LASTDT,DGSINGLE=1
  1. ;
  1. F S DGADT=$O(@DGORU@(DGADT)) Q:'DGADT D Q:$D(DGERR)
  1. .N DGPFAH ;assignment history data array
  1. .;
  1. .S DGPFAH("ASSIGNDT")=DGADT
  1. .S DGPFAH("ACTION")=$G(@DGORU@(DGADT,"ACTION"))
  1. .S DGPFAH("ENTERBY")=.5 ;POSTMASTER
  1. .S DGPFAH("APPRVBY")=.5 ;POSTMASTER
  1. .M DGPFAH("COMMENT")=@DGORU@(DGADT,"COMMENT")
  1. .S DGPFAH("ORIGFAC")=$G(@DGORU@(DGADT,"ORIGFAC"))
  1. .; DBRS data
  1. .S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORU@("DBRS",DBRSNUM)) Q:DBRSNUM="" D
  1. ..S DBRSCNT=DBRSCNT+1
  1. ..S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORU@("DBRS",DBRSNUM,"OTHER"))_U_$G(@DGORU@("DBRS",DBRSNUM,"DATE"))
  1. ..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="U" D
  1. ...S RES=$$FIND1^DIC(26.131,","_CURASGN_",","X",DBRSNUM)
  1. ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$S(RES:"E",1:"A")
  1. ...Q
  1. ..I $G(@DGORU@("DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D"
  1. ..S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORU@("DBRS",DBRSNUM,"SITE"))
  1. ..Q
  1. .; calculate the assignment STATUS from the ACTION
  1. .S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
  1. .; calculate new review date if this is ownership transfer
  1. .; if action = "continue" and current owner on file is different from owner in HL7 message, then it's an ownership transfer
  1. .I DGPFAH("ACTION")=2,$$GET1^DIQ(26.13,CURASGN_",",.04,"I")'=DGPFA("OWNER") D
  1. ..; if local site or division is the new owner, set review date
  1. ..I DGPFA("OWNER")=$P($$SITE^VASITE(),U)!$$ISDIV^DGPFUT(DGPFA("OWNER")) D
  1. ...S DGPFA("REVIEWDT")=$$GETRDT^DGPFAA3($P(DGPFA("FLAG"),U),DGPFAH("ASSIGNDT"))
  1. ...Q
  1. ..Q
  1. .; find out if we want to overwrite existing DBRS data
  1. .S STOFLG="" I DGADT=LASTDT,"^2^4^5^7^8^"[(U_DGPFAH("ACTION")_U) S STOFLG="D"
  1. .;validate before filing for single updates and new assignments
  1. .I DGSINGLE!(DGPFAH("ACTION")=1) S RES=$$STOHL7^DGPFAA3(.DGPFA,.DGPFAH,"DGERR",STOFLG) Q
  1. .;otherwise, just file it
  1. .S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,STOFLG)
  1. .Q
  1. ;convert dialog to dialog code
  1. I $D(DGERR) S DGERR=$G(DGERR("DIERR",1))
  1. ;
  1. Q '$D(DGERR)
  1. ;
  1. RCVACK(DGWRK,DGMIEN,DGHL) ;Receive ACK Message Types (ACK~R01)
  1. ;
  1. ; Input:
  1. ; DGWRK - name of work global containing segments
  1. ; DGMIEN - IEN of message entry in file #773
  1. ; DGHL - HL environment array
  1. ;
  1. ; Output:
  1. ; none
  1. ;
  1. N DGACK ;ACK data array
  1. N DGERR ;error array
  1. N DGLIEN ;HL7 transmission log IEN
  1. ;
  1. D PARSACK^DGPFHLU4(DGWRK,.DGHL,.DGACK,.DGERR)
  1. S DGLIEN=$$FNDLOG^DGPFHLL(26.17,$G(DGACK("MSGID")))
  1. Q:'DGLIEN
  1. ;
  1. I $G(DGACK("ACKCODE"))="AA" D
  1. . D STOSTAT^DGPFHLL(26.17,DGLIEN,"A",.DGERR)
  1. E D
  1. . ;update transmission log status (REJECTED) and process error
  1. . D STOSTAT^DGPFHLL(26.17,DGLIEN,"RJ",.DGERR)
  1. . D PROCERR^DGPFHLU5(DGLIEN,.DGACK,.DGERR)
  1. Q
  1. ;
  1. RCVQRY(DGWRK,DGMIEN,DGHL) ;Receive QRY Message Types (QRY~R02)
  1. ;
  1. ; Input:
  1. ; DGWRK - name of work global containing segments
  1. ; DGMIEN - IEN of message entry in file #773
  1. ; DGHL - HL environment array
  1. ;
  1. ; Output:
  1. ; none
  1. ;
  1. N DGDFN
  1. N DGDFNERR
  1. N DGQRY
  1. N DGQRYERR
  1. N DGSEGERR
  1. ;
  1. D PARSQRY^DGPFHLQ3(DGWRK,.DGHL,.DGQRY,.DGSEGERR)
  1. S DGDFN=$$GETDFN^DGPFUT2(DGQRY("ICN"),"DGDFNERR")
  1. I DGDFN'>0,$G(DGDFNERR("DIERR",1))]"" D
  1. . S DGQRYERR=DGDFNERR("DIERR",1)
  1. D SNDORF^DGPFHLS(.DGQRY,DGMIEN,.DGHL,DGDFN,.DGSEGERR,.DGQRYERR)
  1. Q
  1. ;
  1. RCVORF(DGWRK,DGMIEN,DGHL) ;Receive ORF Message Types (ORF~R04)
  1. ;
  1. ; Input:
  1. ; DGWRK - name of work global containing segments
  1. ; DGMIEN - IEN of message entry in file #773
  1. ; DGHL - HL environment array
  1. ;
  1. ; Output:
  1. ; none
  1. ;
  1. N DGDFN ;pointer to PATIENT (#2) file
  1. N DGLIEN ;HL7 query log IEN
  1. N DGORF ;ORF data array root
  1. N DGERR ;parser error array
  1. N DGSTAT ;query log status
  1. ;
  1. S DGORF=$NA(^TMP("DGPF",$J))
  1. K @DGORF
  1. D PARSORF^DGPFHLQ4(DGWRK,.DGHL,DGORF,.DGERR)
  1. S DGDFN=+$$GETDFN^MPIF001($G(@DGORF@("ICN")))
  1. ;
  1. ;successful query
  1. I $G(@DGORF@("ACKCODE"))="AA" D
  1. . S DGSTAT=$S(+$O(@DGORF@(0))>0:"A",1:"AN")
  1. . ;
  1. . ;REJECT when filer fails; otherwise mark event as COMPLETE
  1. . I '$$STOORF(DGDFN,DGORF) D
  1. . . S DGSTAT="RJ"
  1. . . S DGERR($O(DGERR(""),-1)+1)=261120 ;Unable to file
  1. . E D STOEVNT^DGPFHLL1(DGDFN,"C")
  1. ;
  1. ;failed query
  1. I $G(@DGORF@("ACKCODE"))'="AA" S DGSTAT="RJ"
  1. ;
  1. ;find and update query log status
  1. S DGLIEN=$$FNDLOG^DGPFHLL(26.19,$G(@DGORF@("MSGID")))
  1. I DGLIEN D STOSTAT^DGPFHLL(26.19,DGLIEN,DGSTAT,.DGERR)
  1. ;
  1. ;purge PRF HL7 QUERY LOG when status is COMPLETE
  1. I $$GETSTAT^DGPFHLL1(DGDFN)="C" D PRGQLOG^DGPFHLL($$FNDEVNT^DGPFHLL1(DGDFN))
  1. ;
  1. ;cleanup
  1. K @DGORF
  1. Q
  1. ;
  1. STOORF(DGDFN,DGORF,DGERR) ;store ORF data
  1. ;
  1. ; Input:
  1. ; DGDFN - pointer to patient in PATIENT (#2) file
  1. ; DGORF - parsed ORF segments data array
  1. ;
  1. ; Output:
  1. ; Function value - 1 on success; 0 on failure
  1. ; DGERR - defined on failure
  1. ;
  1. N DGADT ;activity date ("ASSIGNDT")
  1. N DGPFA ;assignment data array
  1. N DGPFAH ;assignment history data array
  1. N DGSET ;set id to represent a single PRF assignment
  1. N CURASGN,DBRSCNT,DBRSNUM,RES
  1. ;
  1. S DGSET=0 F S DGSET=$O(@DGORF@(DGSET)) Q:'DGSET D
  1. .N DGPFA ;assignment data array
  1. .;
  1. .S DGPFA("DFN")=DGDFN
  1. .S DGPFA("FLAG")=$G(@DGORF@(DGSET,"FLAG"))
  1. .Q:DGPFA("FLAG")']""
  1. .;prevent overwriting existing assignments
  1. .S CURASGN=$$FNDASGN^DGPFAA(DGPFA("DFN"),DGPFA("FLAG")) Q:CURASGN
  1. .;init STATUS as a placeholder, $$STATUS^DGPFUT sets value in loop
  1. .S DGPFA("STATUS")=""
  1. .S DGPFA("OWNER")=$G(@DGORF@(DGSET,"OWNER"))
  1. .S DGPFA("ORIGSITE")=$G(@DGORF@(DGSET,"ORIGSITE"))
  1. .M DGPFA("NARR")=@DGORF@(DGSET,"NARR")
  1. .; DBRS data
  1. .S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
  1. ..S DBRSCNT=DBRSCNT+1
  1. ..S DGPFA("DBRS#",DBRSCNT)=DBRSNUM
  1. ..S DGPFA("DBRS OTHER",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
  1. ..S DGPFA("DBRS DATE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
  1. ..S DGPFA("DBRS ACTION",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))
  1. ..S DGPFA("DBRS SITE",DBRSCNT)=$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
  1. ..Q
  1. .S DGADT=0 ;each DGADT represents a single PRF history action
  1. .F S DGADT=$O(@DGORF@(DGSET,DGADT)) Q:'DGADT D Q:$D(DGERR)
  1. ..N DGPFAH ;assignment history data array
  1. ..;
  1. ..S DGPFAH("ASSIGNDT")=DGADT
  1. ..S DGPFAH("ACTION")=$G(@DGORF@(DGSET,DGADT,"ACTION"))
  1. ..S DGPFAH("ENTERBY")=.5 ;POSTMASTER
  1. ..S DGPFAH("APPRVBY")=.5 ;POSTMASTER
  1. ..M DGPFAH("COMMENT")=@DGORF@(DGSET,DGADT,"COMMENT")
  1. ..S DGPFAH("ORIGFAC")=$G(@DGORF@(DGSET,DGADT,"ORIGFAC"))
  1. ..; DBRS data
  1. ..S DBRSCNT=0,DBRSNUM="" F S DBRSNUM=$O(@DGORF@(DGSET,"DBRS",DBRSNUM)) Q:DBRSNUM="" D
  1. ...S DBRSCNT=DBRSCNT+1
  1. ...S DGPFAH("DBRS",DBRSCNT)=DBRSNUM_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"OTHER"))
  1. ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"DATE"))
  1. ...I $G(@DGORF@(DGSET,"DBRS",DBRSNUM,"ACTION"))="D" S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"D" Q
  1. ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_"A"
  1. ...S DGPFAH("DBRS",DBRSCNT)=DGPFAH("DBRS",DBRSCNT)_U_$G(@DGORF@(DGSET,"DBRS",DBRSNUM,"SITE"))
  1. ...Q
  1. ..;calculate the assignment STATUS from the ACTION
  1. ..S DGPFA("STATUS")=$$STATUS^DGPFUT(DGPFAH("ACTION"))
  1. ..S RES=$$STOALL^DGPFAA(.DGPFA,.DGPFAH,.DGERR,"")
  1. ..Q
  1. .Q
  1. Q '$D(DGERR)
  1. ;
  1. ;call to $$PROD^XUPROD supported by ICR #4440
  1. ;
  1. SDORUERR(DGMIEN,DGSEGERR,DGSTOERR,DGETYP) ;
  1. N XMDUZ,XMSUB,XMTEXT,XMY,XMZ ;MailMan variables
  1. N DGTXT,DGSTAT,DGCODE
  1. S DGSTAT=$P($$SITE^VASITE,U,3)
  1. S XMDUZ="PRF Error Processor"
  1. S XMSUB="PRF Application Error (station #"_DGSTAT_")"
  1. S XMSUB=XMSUB_" ["_$S($$PROD^XUPROD:"P",1:"T")_"]" ;production or test?
  1. S XMY("G.DG PRF APPLICATION ERRORS")=""
  1. I DGETYP="P" D
  1. .D ERRMSGP(DGMIEN,.DGSEGERR,.DGTXT)
  1. I DGETYP="S" D
  1. .S DGTXT(1)="A store error occurred."
  1. .S DGCODE=$G(DGSTOERR("DIERR",1))
  1. .S:$L(DGCODE)>0 DGTXT(2)="The error code is "_DGCODE_"."
  1. S XMTEXT="DGTXT("
  1. D ^XMD
  1. Q
  1. ;
  1. ERRMSGP(DGMIEN,DGERR,DGTXT) ;
  1. N DGLC,DGSEG,DGFLD,DGE,DGI,DGJ,DGK,DGEMSG
  1. S DGLC=1
  1. S DGTXT(DGLC)="One or more parse errors occurred in message #"_DGMIEN_"."
  1. S DGI="" F S DGI=$O(DGERR(DGI)) Q:DGI="" D
  1. .S DGSEG=DGI ;segment name
  1. .S DGJ="" F S DGJ=$O(DGERR(DGI,DGJ)) Q:DGJ="" D
  1. ..S DGK="" F S DGK=$O(DGERR(DGI,DGJ,DGK)) Q:DGK="" D
  1. ...S DGFLD=DGK
  1. ...S DGE=$G(DGERR(DGI,DGJ,DGK))
  1. ...S DGEMSG="Error #"_DGE_" occurred in "_DGSEG_"-"_DGFLD
  1. ...S DGLC=DGLC+1,DGTXT(DGLC)=DGEMSG_"."
  1. Q